diff options
| -rw-r--r-- | exn_handler.fun | 11 | ||||
| -rw-r--r-- | ppc.fun | 261 | ||||
| -rw-r--r-- | ppc.sig | 22 |
3 files changed, 188 insertions, 106 deletions
diff --git a/exn_handler.fun b/exn_handler.fun index b95e847..078225f 100644 --- a/exn_handler.fun +++ b/exn_handler.fun @@ -8,7 +8,7 @@ struct let val hist = MLton.Exn.history e in - eprint $ "exception " ^ exnMessage e ^ " was raised"; + eprint $ "exception " ^ exnMessage e ^ " was raised\n"; if hist = [] then (output "No stack trace is avaliable\n"; output "Recompile with -const \"Exn.keepHistory true\"\n") @@ -30,13 +30,16 @@ struct end | ioExn _ = (output "ioExn: unreachable\n"; exit 254) - fun handler e = - (case e of + fun handler e = ( + printf `"\n" %; + case e of T.FsmTableIsTooSmall => eprint "fsm table is too small. Increate 'maxState' value" | IO.Io _ => ioExn e | T.TkErrorAug (pos, msg) => eprint $ T.S.pos2str pos ^ ": " ^ msg | P.TkError v => P.tkErrorPrint v + | P.TkClassError v => P.tkClassErrorPrint v | _ => otherExn e; - exit 255) + exit 255 + ) end @@ -3,7 +3,8 @@ struct structure T = T - datatype tkPos = TkPos of T.S.pos + type layers = (string * T.S.pos) list + datatype tkPos = TkPos of T.S.pos * layers type macroBody = (T.token * T.S.pos) list datatype macro = @@ -13,7 +14,7 @@ struct type t = { streams: T.S.t list, - buffer: (T.token * T.S.pos) list, + buffer: (T.token * tkPos) list, macros: (bool * macro) H.t, @@ -24,52 +25,62 @@ struct type tkErrorVal = tkPos * string exception TkError of tkErrorVal - datatype expTk = - ExpTk of T.token | - ExpId | - ExpConst | - ExpUnop | - ExpBinop | - ExpOp + datatype tkClass = + Ctk of T.token | + Cid | + Cconst | + Cunop | + Cbinop | + Cop - type tkErrorExpVal = tkPos * expTk list - exception TkErrorExp of tkErrorExpVal + type tkClassErrorVal = tkPos * tkClass list + exception TkClassError of tkClassErrorVal fun raiseTkError msg pos = raise TkError (pos, msg) - fun raiseTkErrorSPos pos msg = raiseTkError msg (TkPos pos) + fun raiseTkErrorSPos pos msg = raiseTkError msg (TkPos (pos, [])) - fun tkErrorPrint (TkPos pos, msg) = - printf A1 T.S.pos2str pos `": " `msg `"\n" % + fun printLayers ((macroName, pos) :: layers) = ( + printf `"\t" `macroName `" " A1 T.S.pos2str pos %; + printLayers layers + ) + | printLayers [] = () - fun raiseTkErrorExp pos exp = raise TkErrorExp (pos, exp) - fun raiseTkErrorExpSPos pos exp = raiseTkErrorExp (TkPos pos) exp + fun tkErrorPrint (TkPos (pos, layers), msg) = ( + printf A1 T.S.pos2str pos `": " `msg `"\n" %; + printLayers layers + ) - fun tkErrorExpPrint (TkPos pos, exp) = + fun raiseTkClassError pos cls = raise TkClassError (pos, cls) + fun raiseTkClassErrorSPos pos cls = + raiseTkClassError (TkPos (pos, [])) cls + + fun tkClassErrorPrint (TkPos (pos, layers), cls) = let - val printEtk = fn - ExpTk tk => T.printToken tk - | ExpId => output "identifier" - | ExpConst => output "constant" - | ExpUnop => output "unary operator" - | ExpBinop => output "binary operator" - | ExpOp => output "operator" - - fun printExpList [] = raise Unreachable - | printExpList [etk] = printEtk etk - | printExpList [etk1, etk2] = ( - printEtk etk1; + val printCtk = fn + Ctk tk => T.printToken tk + | Cid => output "identifier" + | Cconst => output "constant" + | Cunop => output "unary operator" + | Cbinop => output "binary operator" + | Cop => output "operator" + + fun printClassList [] = raise Unreachable + | printClassList [ctk] = printCtk ctk + | printClassList [ctk1, ctk2] = ( + printCtk ctk1; output " or "; - printEtk etk2 + printCtk ctk2 ) - | printExpList (etk :: etks) = ( - printEtk etk; + | printClassList (ctk :: ctks) = ( + printCtk ctk; output ", "; - printExpList etks + printClassList ctks ) in printf A1 T.S.pos2str pos `": expected " %; - printExpList exp; - output "\n" + printClassList cls; + output "\n"; + printLayers layers end val updatePpc = fn z => @@ -181,7 +192,7 @@ struct in case tk of T.NewLine => (acc, stream) - | T.EOS => raiseTkErrorExpSPos pos [ExpTk T.NewLine] + | T.EOS => raiseTkClassErrorSPos pos [Ctk T.NewLine] | _ => getDefineMacroBody stream ((tk, pos) :: acc) end @@ -199,28 +210,94 @@ struct (ObjMacro body, stream) end - fun getSpecific stream expList = + fun getClass stream clList = let val (tk, pos, stream) = T.getToken stream + + fun belongsToClass tk (Ctk tk') = tk = tk' + | belongsToClass (T.Id _) (Cid) = true + | belongsToClass _ Cid = false + | belongsToClass _ _ = raise Unreachable + + fun checkClass [] = + raiseTkClassErrorSPos pos clList + | checkClass (cl :: tail) = + if belongsToClass tk cl then + () + else + checkClass tail + + val () = checkClass clList in - raise Unimplemented + (tk, pos, stream) + end + + fun validateArgs args = + let + fun validateArg (id, _) [] = id + | validateArg (id, pos) ((id', pos') :: tail) = + if id = id' then + raiseTkErrorSPos pos' "macro argument name is already taken" + else + validateArg (id, pos) tail + + fun validate [] = [] + | validate (arg :: args) = validateArg arg args :: validate args + + in + validate args end fun parseDefineMacroArgs stream = let datatype arg = Arg of string * T.S.pos | - LastArg of string * T.S.pos | - EmptyArg + LastArg of string * T.S.pos + + fun parseArg stream = + let + val (tkId, posId, stream) = getClass stream [Cid] + val (tk, _, stream) = getClass stream [Ctk T.RParen, Ctk T.Coma] + val id = case tkId of T.Id id => id | _ => raise Unreachable + in + case tk of + T.RParen => (LastArg (id, posId), stream) + | T.Coma => (Arg (id, posId), stream) + | _ => raise Unreachable + end + + fun parseArgs stream = + let + val (tk, _, stream) = T.getToken stream + + fun parse stream acc = + case parseArg stream of + (LastArg p, stream) => (rev (p :: acc), stream) + | (Arg p, stream) => parse stream (p :: acc) + in + if tk = T.RParen then + ([], stream) + else + let + val (args, stream) = parse stream [] + val args = validateArgs args + in + (args, stream) + end + end in - raise Unimplemented + parseArgs stream end fun parseDefineFuncMacro stream = let - val (_, _, stream) = T.getToken stream + val (args, stream) = parseDefineMacroArgs stream + val (body, stream) = getDefineMacroBody stream [] in - raise Unimplemented + printf `"func macro (" %; + List.app (fn arg => printf `arg `", " %) args; + printf `") \n" %; + (FuncMacro (args, body), stream) end fun parseDefine stream = @@ -231,7 +308,7 @@ struct in case tk of T.Id id => (id, pos, stream) - | _ => raiseTkErrorExpSPos pos [ExpId] + | _ => raiseTkClassErrorSPos pos [Cid] end val (macroName, pos, stream) = getName stream @@ -263,23 +340,25 @@ struct (T.CppDefine, handleDefine) ] - fun expandObjMacro (id, pos) body ppc = + fun expandObjMacro (id, TkPos (mPos, layers)) body ppc = let - val mstart = (T.MacroStart id, pos) - val mend = (T.MacroEnd id, - if body = [] then pos else (#2 o hd) body) - val revBody = List.concat [[mend], body, [mstart]] + val mend = (T.MacroEnd id, if body = [] then mPos else (#2 o hd) body) + + fun formLayers (tk, pos) = (tk, TkPos (pos, (id, mPos) :: layers)) + + val revBody = List.map formLayers $ List.concat [[mend], body] in updatePpc ppc u#buffer (fn buf => List.revAppend (revBody, buf)) % end fun expandFuncMacro (_, _) (_, _) _ = + let + in raise Unimplemented + end fun handleRegularToken tk pos ppc = let - fun def () = (tk, TkPos pos, ppc) - fun checkAndMark (true, _) = (NONE, NONE) | checkAndMark (false, macro) = (SOME (true, macro), SOME macro) in @@ -288,7 +367,7 @@ struct case H.lookup2 (#macros ppc) id checkAndMark (fn () => NONE) of - NONE => def () + NONE => (tk, pos, ppc) | SOME (ObjMacro body) => getToken $ expandObjMacro (id, pos) body ppc | SOME (FuncMacro (arg, body)) => @@ -300,9 +379,9 @@ struct (fn (_, body) => (SOME (false, body), ())) (fn () => raise Unreachable) in - def () + getToken ppc end - | _ => def () + | _ => (tk, pos, ppc) end and handleToken tk pos ppc = @@ -314,7 +393,7 @@ struct let val (pos, stream) = T.S.EOFpos stream in - (T.EOS, TkPos pos, updatePpc P s#streams [stream] %) + (T.EOS, TkPos (pos, []), updatePpc P s#streams [stream] %) end | getToken (P as { buffer = (tk, pos) :: tail, ... }: t) = handleToken tk pos (updatePpc P s#buffer tail %) @@ -323,58 +402,58 @@ struct val (tk, pos, head) = T.getToken head in if tk = T.EOS then - case tail of - [] => getToken $ updatePpc P s#EOSreached true % - | _ => getToken $ updatePpc P s#streams tail % + case tail of + [] => getToken $ updatePpc P s#EOSreached true % + | _ => getToken $ updatePpc P s#streams tail % else - handleToken tk pos $ updatePpc P s#streams (head :: tail) % + handleToken tk (TkPos (pos, [])) $ + updatePpc P s#streams (head :: tail) % end | getToken _ = raise Unreachable - fun debugPrint' ppc (shouldPrintLine, indent) (fname, line) = + fun debugPrint' ppc = let val (tk, pos, ppc) = getToken ppc - val TkPos (t as (T.S.Pos (fname', line', col))) = pos - fun repeat n s = String.concat (List.tabulate (n, fn _ => s)) - val Indent = fn z => bind A0 (fn () => repeat indent "\t") z + fun printTkPos (TkPos (pos, layers)) = + let + fun printLayer (macroName, pos) = + printf `macroName `" " A1 T.S.pos2str pos % - fun printLine () = printf `"\n" Indent `fname' `":" I line' `" \t" % + fun printLayers' [layer] = printLayer layer + | printLayers' (layer :: layers) = ( + printLayer layer; + output ", "; + printLayers' layers + ) + | printLayers' [] = raise Unreachable - fun finish pair = - if tk <> T.EOS then - debugPrint' ppc pair (fname', line') - else - () + fun printLayers [] = () + | printLayers layers = ( + output " ("; + printLayers' layers; + output ")" + ) + in + printf A1 T.S.pos2str pos %; + printLayers layers; + output ": " + end in - case tk of - T.MacroStart macroName => ( - printf `"\n" Indent A1 T.S.pos2str t `": macro " `macroName `" {" %; - finish (true, indent + 1) - ) - | T.MacroEnd id => ( - output "\n"; - printf Indent `"} " `id %; - finish (true, indent - 1) - ) - | _ => ( - if shouldPrintLine orelse fname' <> fname orelse line' <> line - then - printLine() - else - (); - printf I col `":" %; - T.printToken tk; - printf `" " %; - finish (false, indent) - ) + printTkPos pos; + T.printToken tk; + printf `"\n" %; + if tk = T.EOS then + () + else + debugPrint' ppc end fun debugPrint fname incDirs = let val ppc = create { fname, incDirs } in - debugPrint' ppc (true, 0) ("", 0); + debugPrint' ppc; output "\n" end end @@ -4,20 +4,20 @@ signature PPC = sig type t type tkErrorVal - type tkErrorExpVal + type tkClassErrorVal type tkPos exception TkError of tkErrorVal - exception TkErrorExp of tkErrorExpVal + exception TkClassError of tkClassErrorVal - datatype expTk = - ExpTk of T.token | - ExpId | - ExpConst | - ExpUnop | - ExpBinop | - ExpOp + datatype tkClass = + Ctk of T.token | + Cid | + Cconst | + Cunop | + Cbinop | + Cop val create: { fname: string, incDirs: string list } -> t val debugPrint: string -> string list -> unit @@ -26,6 +26,6 @@ signature PPC = sig val raiseTkError: string -> tkPos -> 'a val tkErrorPrint: tkErrorVal -> unit - val raiseTkErrorExp: tkPos -> expTk list -> 'a - val tkErrorExpPrint: tkErrorExpVal -> unit + val raiseTkClassError: tkPos -> tkClass list -> 'a + val tkClassErrorPrint: tkClassErrorVal -> unit end |