diff options
| -rw-r--r-- | ccross.mlb | 1 | ||||
| -rw-r--r-- | ccross.sml | 2 | ||||
| -rw-r--r-- | common.sml | 58 | ||||
| -rw-r--r-- | driver.fun | 54 | ||||
| -rw-r--r-- | exn_handler.fun | 26 | ||||
| -rw-r--r-- | ppc.fun | 544 | ||||
| -rw-r--r-- | ppc.sig | 2 | ||||
| -rw-r--r-- | stream.sig | 2 | ||||
| -rw-r--r-- | stream.sml | 9 | ||||
| -rw-r--r-- | tokenizer.fun | 160 | ||||
| -rw-r--r-- | tokenizer.sig | 30 | ||||
| -rw-r--r-- | tree.sig | 13 | ||||
| -rw-r--r-- | tree.sml | 75 |
13 files changed, 704 insertions, 272 deletions
@@ -8,6 +8,7 @@ in stream.sig stream.sml hashtable.sig hashtable.sml + tree.sig tree.sml tokenizer.sig tokenizer.fun ppc.sig ppc.fun exn_handler.sig exn_handler.fun @@ -2,7 +2,7 @@ structure ccross:> CCROSS = struct structure T:> TOKENIZER = Tokenizer(structure H = Hashtable; structure S = Stream) - structure ppc:> PPC = ppc(structure H = Hashtable; structure T = T) + structure ppc:> PPC = ppc(structure Tree = Tree; structure T = T) structure D:> DRIVER = Driver(ppc) @@ -96,21 +96,53 @@ fun % (a, f) = f a val s = FRU.set val u = FRU.upd -fun output s = TextIO.output (TextIO.stdOut, s) +fun sysExit code = Posix.Process.exit $ Word8.fromInt code + +fun exit code = ( + TextIO.closeOut TextIO.stdOut; + TextIO.closeOut TextIO.stdErr; + sysExit code +) + +fun output stream s = TextIO.output (stream, s) + +fun fprint stream g = Fold.fold ((false, output stream), fn _ => ()) g +fun printf g = fprint TextIO.stdOut g +fun Printf output g = Fold.fold ((false, output), fn _ => ()) g + local - fun printBuffer _ [] = () - | printBuffer stream (s :: acc) = - (TextIO.output (stream, s); printBuffer stream acc) + fun ifF flag cl = if not flag then cl () else () in - fun fprintf stream f = Fold.fold - ((stream, []), fn (stream, acc) => printBuffer stream (rev acc)) f - fun printf f = fprintf TextIO.stdOut f + fun ` z = Fold.step1 (fn (s, (ign, output)) => + (ifF ign (fn () => output s); (ign, output))) z + + fun A0 z = Fold.step1 (fn (f, (ign, output)) => + (ifF ign (fn () => f output); (ign, output))) z + fun A1 z = Fold.step2 (fn (f, v, (ign, output)) => + (ifF ign (fn () => f (output, v)); (ign, output))) z +end - fun ` z = Fold.step1 (fn (str, (s, acc)) => (s, str :: acc)) z - fun A0 z = Fold.step1 (fn (f, (s, a)) => (s, f () :: a)) z - fun A1 z = Fold.step2 (fn (f, v, (s, a)) => (s, f v :: a)) z - fun bind A f = fn z => Fold.fold z A f +fun Ign z = Fold.step1 (fn (_, (_, output)) => (true, output)) z - val C = fn z => bind A1 str z - val I = fn z => bind A1 Int.toString z +fun bind A f = fn z => Fold.fold z A f +fun bindWith2str to = bind A1 (fn (output, v) => output (to v)) + +val I = fn z => bindWith2str Int.toString z +val C = fn z => bindWith2str str z +val B = fn z => bindWith2str (fn true => "true" | false => "false") z +val R = fn z => bind A1 (fn (output, n) => app (fn f => f ()) + (List.tabulate (n, fn _ => fn () => output "\t"))) z + +type ('t, 'a, 'b) a1printer = (bool * (string -> unit)) * 'a -> 't -> + ((bool * (string -> unit)) * 'a -> 'b) -> 'b + +fun die code g = +let + fun finish (true, _) = raise Unreachable + | finish (false, output) = ( + output "\n"; + exit code + ) +in + printf `"error: " (fn (a, _) => g (a, finish)) end @@ -1,38 +1,58 @@ functor Driver(P: PPC): DRIVER = struct structure P = P + datatype execMode = Normal | DebugE | DebugT + type config = { file: string option, - includeDirs: string list + includeDirs: string list, + mode: execMode } - val initConfig: config = { file = NONE, includeDirs = [] } + val updateC = fn z => + let + fun from file includeDirs mode = { file, includeDirs, mode } + fun to f { file, includeDirs, mode } = f file includeDirs mode + in + FRU.makeUpdate3 (from, from, to) + end z + + val initConfig: config = { file = NONE, includeDirs = [], mode = Normal } + + val die = fn z => die 1 z + + fun finish ({ file = NONE, ... }: config) = die `"missing input file" % + | finish conf = updateC conf u#includeDirs rev % - fun die msg = (printf `msg `"\n"; Posix.Process.exit $ Word8.fromInt 1) + fun parseFlag conf "-dE" tail = + parseCmdArgs (updateC conf s#mode DebugE %) tail + | parseFlag conf "-dT" tail = + parseCmdArgs (updateC conf s#mode DebugT %) tail + | parseFlag _ arg _ = die `arg `": unknown flag" % - fun parseCmdArgs { file, includeDirs } [] = - if file = NONE then - die "missing input file" - else - { file, includeDirs = rev includeDirs } + and parseCmdArgs conf [] = finish conf | parseCmdArgs _ ("-I" :: []) = - die "-I: expected directory path after flag" - | parseCmdArgs { file, includeDirs } ("-I" :: path :: tail) = - parseCmdArgs { file, includeDirs = path :: includeDirs } tail - | parseCmdArgs { file, includeDirs } (arg :: tail) = + die `"-I: expected directory path after flag" % + | parseCmdArgs conf ("-I" :: path :: tail) = + parseCmdArgs (updateC conf u#includeDirs + (fn dirs => path :: dirs) %) tail + | parseCmdArgs (C as { file, ... }) (arg :: tail) = if String.sub (arg, 0) = #"-" then - die $ arg ^ ": unknown flag" + parseFlag C arg tail else case file of - NONE => parseCmdArgs { file = SOME arg, includeDirs } tail - | SOME _ => die $ arg ^ ": file already specified" + NONE => parseCmdArgs (updateC C s#file (SOME arg) %) tail + | SOME _ => die `arg `": file already specified" % fun exec () = let val config = parseCmdArgs initConfig (CommandLine.arguments ()) - val fname = valOf $ #file config + val file = valOf $ #file config in - P.debugPrint fname (#includeDirs config) + case (#mode config) of + Normal => die `"Normal mode is not implemented yet" % + | DebugT => P.T.debugPrint file + | DebugE => P.debugPrint file (#includeDirs config) end end diff --git a/exn_handler.fun b/exn_handler.fun index 078225f..b4e7275 100644 --- a/exn_handler.fun +++ b/exn_handler.fun @@ -2,44 +2,42 @@ functor ExnHandler(structure T: TOKENIZER; structure P: PPC): EXN_HANDLER = struct - fun eprint s = printf `"error: " `s % + val eprintf = fn z => printf `"error: " z fun otherExn e = let val hist = MLton.Exn.history e in - eprint $ "exception " ^ exnMessage e ^ " was raised\n"; + eprintf `"exception " `(exnMessage e) `" was raised\n"; if hist = [] then - (output "No stack trace is avaliable\n"; - output "Recompile with -const \"Exn.keepHistory true\"\n") + printf + `"No stack trace is avaliable\n" + `"Recompile with -const \"Exn.keepHistory true\"\n" % else List.app (fn x => printf `"\t" `x `"\n" %) hist end - fun exit code = Posix.Process.exit $ Word8.fromInt code - fun ioExn (IO.Io { name, function = _, cause }) = let - val prefix = name ^ ": " val reason = case cause of OS.SysErr (str, _) => str | _ => exnMessage cause in - printf `prefix `reason `"\n" % + eprintf `name `": " `reason `"\n" % end - | ioExn _ = (output "ioExn: unreachable\n"; exit 254) + | ioExn _ = die 126 `"ioExn: unreachable\n" % fun handler e = ( - printf `"\n" %; + printf `"\n"; case e of T.FsmTableIsTooSmall => - eprint "fsm table is too small. Increate 'maxState' value" + eprintf `"fsm table is too small. Increate 'maxState' value\n" % | IO.Io _ => ioExn e - | T.TkErrorAug (pos, msg) => eprint $ T.S.pos2str pos ^ ": " ^ msg + | T.TkErrorAug (pos, msg) => eprintf T.S.Ppos pos `": " `msg `"\n" % | P.TkError v => P.tkErrorPrint v | P.TkClassError v => P.tkClassErrorPrint v | _ => otherExn e; - exit 255 - ) + exit 1 + ) handle _ => sysExit 127 end @@ -1,4 +1,4 @@ -functor ppc(structure H: HASHTABLE; structure T: TOKENIZER): PPC = +functor ppc(structure Tree: TREE; structure T: TOKENIZER): PPC = struct structure T = T @@ -16,12 +16,17 @@ struct buffer: (T.token * tkPos) list, - macros: (bool * macro) H.t, + macros: (string, bool * macro) Tree.t, - EOSreached: bool, + restricted: bool, + debugMode: bool, incDirs: string list } + val macroCompare = fn s1 => fn s2 => String.compare (s1, s2) + val insertMacro = Tree.insert macroCompare + val macrosLookup = fn z => Tree.lookup2 macroCompare z + type tkErrorVal = tkPos * string exception TkError of tkErrorVal @@ -36,67 +41,184 @@ struct type tkClassErrorVal = tkPos * tkClass list exception TkClassError of tkClassErrorVal + fun pos2tkPos pos = TkPos (pos, []) + + val dummyEOSpos = pos2tkPos $ T.S.Pos ("<Unreachable>", 0, 0) + fun raiseTkError msg pos = raise TkError (pos, msg) - fun raiseTkErrorSPos pos msg = raiseTkError msg (TkPos (pos, [])) + fun raiseTkErrorSPos pos msg = raiseTkError msg $ pos2tkPos pos fun printLayers ((macroName, pos) :: layers) = ( - printf `"\t" `macroName `" " A1 T.S.pos2str pos %; + printf `"\t" `macroName `" " T.S.Ppos pos %; printLayers layers ) | printLayers [] = () fun tkErrorPrint (TkPos (pos, layers), msg) = ( - printf A1 T.S.pos2str pos `": " `msg `"\n" %; + printf T.S.Ppos pos `": " `msg `"\n" %; printLayers layers ) fun raiseTkClassError pos cls = raise TkClassError (pos, cls) - fun raiseTkClassErrorSPos pos cls = - raiseTkClassError (TkPos (pos, [])) cls + fun raiseTkClassErrorSPos pos cls = raiseTkClassError (pos2tkPos pos) cls fun tkClassErrorPrint (TkPos (pos, layers), cls) = let 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" + Ctk tk => printf T.Ptoken tk % + | Cid => printf `"identifier" % + | Cconst => printf `"constant" % + | Cunop => printf `"unary operator" % + | Cbinop => printf `"binary operator" % + | Cop => printf `"operator" % fun printClassList [] = raise Unreachable | printClassList [ctk] = printCtk ctk | printClassList [ctk1, ctk2] = ( printCtk ctk1; - output " or "; + printf `" or "; printCtk ctk2 ) | printClassList (ctk :: ctks) = ( printCtk ctk; - output ", "; + printf `", "; printClassList ctks ) in - printf A1 T.S.pos2str pos `": expected " %; + printf T.S.Ppos pos `": expected " %; printClassList cls; - output "\n"; + printf `"\n"; printLayers layers end val updatePpc = fn z => let - fun from streams buffer macros EOSreached incDirs = - { streams, buffer, macros, EOSreached, incDirs } - fun to f { streams, buffer, macros, EOSreached, incDirs } = - f streams buffer macros EOSreached incDirs + fun from streams buffer macros restricted debugMode incDirs = + { streams, buffer, macros, restricted, debugMode, incDirs } + fun to f { streams, buffer, macros, restricted, debugMode, + incDirs } = + f streams buffer macros restricted debugMode incDirs + in + FRU.makeUpdate6 (from, from, to) + end z + + fun create { fname, incDirs, debugMode } = + { streams = [T.S.create fname], buffer = [], macros = Tree.empty, + restricted = false, debugMode, incDirs } + + fun compareLayers cached macroLayers = + let + fun dropCommonPrefix [] l2 = ([], l2) + | dropCommonPrefix l1 [] = (l1, []) + | dropCommonPrefix (e1 :: l1) (e2 :: l2) = + if e1 = e2 then + dropCommonPrefix l1 l2 + else + (e1 :: l1, e2 :: l2) + val (cachedTail, macroTail) = + dropCommonPrefix (rev cached) (rev macroLayers) + in + (length cachedTail, macroTail) + end + + fun printClosure offset _ 0 = offset + | printClosure offset out toClose = + let + fun printBrace offset 1 = Printf out R offset `"}" % + | printBrace offset toClose = ( + Printf out R offset `"}\n"; + printBrace (offset - 1) (toClose - 1) + ) + in + Printf out `"\n"; + printBrace (offset - 1) toClose; + offset - toClose + end + + fun printNewLayers offset _ [] = offset + | printNewLayers offset out layers = + let + fun printLayer offset (macro, pos) = + Printf out R offset `macro `" " T.S.Ppos pos `" {" % + val () = Printf out `"\n" % + + fun printLayers offset [layer] = printLayer offset layer + | printLayers offset (layer :: tail) = ( + printLayer offset layer; + Printf out `"\n"; + printLayers (offset + 1) tail + ) + | printLayers _ [] = raise Unreachable + in + printLayers offset layers; + offset + length layers + end + + fun printToken (offset, layers, (fname, line)) out (tk, pos) = + let + val TkPos (T.S.Pos (fname', line', col'), layers') = pos + val (toClose, newLayers) = compareLayers layers layers' + + val offset1 = printClosure offset out toClose + val offset2 = printNewLayers offset1 out newLayers + in + if offset1 <> offset orelse offset2 <> offset1 orelse + fname' <> fname orelse line' <> line + then + Printf out `"\n" R offset2 `fname' `":" I line' `"|\t" % + else + (); + Printf out I col' `":" T.Ptoken tk `" "; + (offset2, layers', (fname', line')) + end + + val printMacroHeader = fn z => + let + fun printMacroHeader (out, (id, mLayers)) = + let + fun Players (out, layers) = + let + fun printLayer (macro, pos) = + Printf out `macro `" " T.S.Ppos pos % + fun printLayers [] = () + | printLayers [layer] = printLayer layer + | printLayers (layer :: layers) = ( + printLayer layer; + out ", "; + printLayers layers + ) + in + printLayers layers + end + + val layers = rev mLayers in - FRU.makeUpdate5 (from, from, to) + Printf out `"\n" `"(" A1 Players layers `"): macro " `id % end - z + in + bind A1 printMacroHeader + end z - fun create { fname, incDirs } = - { streams = [T.S.create fname], buffer = [], macros = H.createLog 10, - EOSreached = false, incDirs } + val startCache = (0, [], ("", 0)) + + val printTokenL = fn z => + let + fun printTokenL (out, (offset, layers, l)) = + let + fun printList cache [] = cache + | printList cache (tk :: tail) = + printList (printToken cache out tk) tail + + val cache = (offset, layers, ("", 0)) + val (offset, layers', _) = printList cache l + val toClose = length layers' - length layers + in + printClosure offset out toClose; + Printf out `"\n" % + end + in + bind A1 printTokenL + end z datatype IncludeArg = LocalInc of string * T.S.pos | @@ -203,35 +325,58 @@ struct tk = T.LParen andalso line1 = line2 andalso col1 + nameLength = col2 end - fun parseDefineObjMacro stream = + fun dBprintf debugMode = + if debugMode then + printf + else + printf Ign true + fun dprintf ppc = dBprintf (#debugMode ppc) + + fun PrintMacroBody (out, body) = + let + val body = List.map (fn (tk, pos) => (tk, pos2tkPos pos)) body + in + Printf out `" {"; + Printf out printTokenL (0, [], body); + Printf out `"}" % + end + + fun parseDefineObjMacro debugMode stream = let val (body, stream) = getDefineMacroBody stream [] in + dBprintf debugMode A1 PrintMacroBody body; (ObjMacro body, stream) end - fun getClass stream clList = + fun checkClass (tk, pos) clList raiseClassErr = 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) = + fun checkClass' [] = raiseClassErr pos clList + | checkClass' (cl :: tail) = if belongsToClass tk cl then () else - checkClass tail + checkClass' tail + in + checkClass' clList + end - val () = checkClass clList + fun getClassGeneric clList getToken raiseClassErr buf = + let + val (tk, pos, buf) = getToken buf + val () = checkClass (tk, pos) clList raiseClassErr in - (tk, pos, stream) + (tk, pos, buf) end + fun getClassFromStream stream clList = + getClassGeneric clList T.getToken raiseTkClassErrorSPos stream + fun validateArgs args = let fun validateArg (id, _) [] = id @@ -256,8 +401,8 @@ struct fun parseArg stream = let - val (tkId, posId, stream) = getClass stream [Cid] - val (tk, _, stream) = getClass stream [Ctk T.RParen, Ctk T.Coma] + val (tkId, posId, stream) = getClassFromStream stream [Cid] + val (tk, _, stream) = getClassFromStream stream [Ctk T.RParen, Ctk T.Coma] val id = case tkId of T.Id id => id | _ => raise Unreachable in case tk of @@ -289,29 +434,34 @@ struct parseArgs stream end - fun parseDefineFuncMacro stream = + fun parseDefineFuncMacro debugMode stream = let - val (args, stream) = parseDefineMacroArgs stream + val (params, stream) = parseDefineMacroArgs stream val (body, stream) = getDefineMacroBody stream [] - in - printf `"func macro (" %; - List.app (fn arg => printf `arg `", " %) args; - printf `") \n" %; - (FuncMacro (args, body), stream) - end - fun parseDefine stream = - let - fun getName stream = + fun printParams out = let - val (tk, pos, stream) = T.getToken stream + fun printParams' [] = () + | printParams' [p] = Printf out `p % + | printParams' (p :: ps) = (Printf out `p `", "; printParams' ps) in - case tk of - T.Id id => (id, pos, stream) - | _ => raiseTkClassErrorSPos pos [Cid] + Printf out `"("; + printParams' params; + Printf out `")" % end + in + dBprintf debugMode A0 printParams; + dBprintf debugMode A1 PrintMacroBody body; + (FuncMacro (params, rev body), stream) + end - val (macroName, pos, stream) = getName stream + fun parseDefine stream debugMode = + let + val (macroName, pos, stream) = getClassFromStream stream [Cid] + val macroName = + case macroName of T.Id id => id | _ => raise Unreachable + + val () = dBprintf debugMode `"\ndefine " `macroName % val parser = if isFuncMacroDefine (size macroName) pos stream then @@ -319,141 +469,271 @@ struct else parseDefineObjMacro - val (macro, stream) = parser stream + val (macro, stream) = parser debugMode stream in ((macroName, pos), macro, stream) end + fun updateH head = fn s => head :: tl s + fun handleDefine (P as { streams = head :: _, ... }: t) = let - val ((macroName, pos), macro, head) = parseDefine head + val ((macroName, pos), macro, head) = parseDefine head (#debugMode P) - val () = H.insert (#macros P) macroName (false, macro) handle - H.Exists => raiseTkErrorSPos pos "macro redefinition" + val macros = insertMacro (#macros P) macroName (false, macro) handle + Tree.Exists => raiseTkErrorSPos pos "macro redefinition" in - updatePpc P u#streams (fn s => head :: tl s) % + updatePpc P u#streams (updateH head) s#macros macros % end | handleDefine _ = raise Unreachable val directiveTable = [ - (T.CppInclude, handleInclude), - (T.CppDefine, handleDefine) + (T.PpcInclude, handleInclude), + (T.PpcDefine, handleDefine) ] - fun expandObjMacro (id, TkPos (mPos, layers)) body ppc = + fun addLayer (id, TkPos (pos, layers)) = (id, pos) :: layers + fun addLayers idPos body = + let + fun formLayers (tk, pos) = (tk, TkPos (pos, addLayer idPos)) + in + List.map formLayers body + end + + fun insertRevBody body ppc = + updatePpc ppc u#buffer (fn buf => List.revAppend (body, buf)) % + + val printBody = fn z => + let + fun printBody (out, (mLayers, msg, body)) = ( + Printf out `"\n" `msg `" {"; + Printf out printTokenL (1, mLayers, body); + Printf out `"}\n" % + ) + in + bind A1 printBody + end z + + fun expandObjMacro (id, pos) body ppc = let - val mend = (T.MacroEnd id, if body = [] then mPos else (#2 o hd) body) + val TkPos (pos', _) = pos + val mend = (T.MacroEnd id, if body = [] then pos' else (#2 o hd) body) + val revBody = addLayers (id, pos) $ List.concat [[mend], body] + + val mLayers = addLayer (id, pos) + + in + dprintf ppc printMacroHeader (id, mLayers); + dprintf ppc printBody (mLayers, "body", rev revBody); + insertRevBody revBody ppc + end + + fun getClass ppc clList = + getClassGeneric clList getToken raiseTkClassError ppc + + and parseFuncMacroArgs mPos params ppc = + let + fun parseArg ppc acc = + let + val (tk, pos, ppc) = getToken ppc (* TODO: should be restricted *) + in + case tk of + T.EOS => raiseTkError "unfinished argument list" mPos + | T.Coma => (true, rev acc, ppc) + | T.RParen => (false, rev acc, ppc) + | _ => parseArg ppc ((tk, pos) :: acc) + end + + fun parseArgs ppc params acc = + let + fun bind _ [] = raiseTkError "too many arguments" mPos + | bind body (param :: params) = ((param, body), params) + + val (continue, arg, ppc) = parseArg ppc [] + val (bindedParam, otherParams) = bind arg params + in + if continue then + parseArgs ppc otherParams (bindedParam :: acc) + else + if length otherParams > 0 then + raiseTkError "not enough arguments" mPos + else + (rev (bindedParam :: acc), ppc) + end - fun formLayers (tk, pos) = (tk, TkPos (pos, (id, mPos) :: layers)) + val ppc = updatePpc ppc s#restricted true % + val (_, _, ppc) = getClass ppc [Ctk T.LParen] + val (res, ppc) = parseArgs ppc params [] + val ppc = updatePpc ppc s#restricted false % + in + (res, ppc) + end - val revBody = List.map formLayers $ List.concat [[mend], body] + and expandArgument ppc arg = + let + val ppc = updatePpc ppc s#streams [] s#buffer arg % + fun getAll ppc acc = + let + val (tk, pos, ppc) = getToken ppc + in + case tk of + T.EOS => rev acc + | _ => getAll ppc ((tk, pos) :: acc) + end + in + getAll ppc [] + end + + and subst _ [] (acc: (T.token * tkPos) list) = rev acc + | subst bindedParams ((P as (T.Id id, _)) :: tail) acc = + let + fun findArg ((id', args) :: tail) = + if id' = id then + SOME args + else + findArg tail + | findArg [] = NONE in - updatePpc ppc u#buffer (fn buf => List.revAppend (revBody, buf)) % + case findArg bindedParams of + NONE => subst bindedParams tail (P :: acc) + | SOME arg => + subst bindedParams tail (List.revAppend (arg, acc)) end + | subst bindedParams (P :: tail) acc = + subst bindedParams tail (P :: acc) + + and printBinded z = + let + fun printBinded (out, (mLayer, msg, params)) = + let + fun print [] = () + | print ((p, args) :: tail) = ( + Printf out `p `": "; + Printf out printTokenL (1, mLayer, args); + print tail + ) + in + Printf out `"\n" `msg `" {\n"; + print params; + Printf out `"}\n" % + end + in + bind A1 printBinded + end z - fun expandFuncMacro (_, _) (_, _) _ = + and expandFuncMacro (id, mPos) (params, body) ppc = let + val mLayers = addLayer (id, mPos) + fun addLayers2args body = + let + fun formLayers (tk, TkPos (pos, _)) = (tk, TkPos (pos, mLayers)) + in + List.map formLayers body + end + fun apply f bp = List.map (fn (p, arg) => (p, f arg)) bp + + val () = dprintf ppc printMacroHeader (id, mLayers) % + val (bindedParams, ppc) = parseFuncMacroArgs mPos params ppc + + val bp1 = apply addLayers2args bindedParams + val () = dprintf ppc printBinded (mLayers, "args", bp1) % + + val bp2 = apply (expandArgument ppc) bp1 + val () = dprintf ppc printBinded (mLayers, "expanded args", bp2) % + + val body = addLayers (id, mPos) body + val body = subst bp2 body [] in - raise Unimplemented + dprintf ppc printBody (mLayers, "subst", body); + insertRevBody (rev body) ppc end - fun handleRegularToken tk pos ppc = + and handleRegularToken tk pos ppc = let fun checkAndMark (true, _) = (NONE, NONE) | checkAndMark (false, macro) = (SOME (true, macro), SOME macro) + + fun getMacro tree id = macrosLookup tree id (checkAndMark, NONE) + + fun def () = (tk, pos, ppc) + + fun handleMacro id = + let + val (macro, tree) = getMacro (#macros ppc) id + fun newPpc () = updatePpc ppc s#macros tree % + in + case macro of + NONE => def () + | SOME (ObjMacro body) => + getToken $ expandObjMacro (id, pos) body (newPpc ()) + | SOME (FuncMacro (arg, body)) => + getToken $ expandFuncMacro (id, pos) (arg, body) (newPpc ()) + end in case tk of - T.Id id => ( - case H.lookup2 (#macros ppc) id - checkAndMark (fn () => NONE) - of - NONE => (tk, pos, ppc) - | SOME (ObjMacro body) => - getToken $ expandObjMacro (id, pos) body ppc - | SOME (FuncMacro (arg, body)) => - getToken $ expandFuncMacro (id, pos) (arg, body) ppc - ) + T.Id id => if (#restricted ppc) then def () else handleMacro id | T.MacroEnd id => let - val () = H.lookup2 (#macros ppc) id - (fn (_, body) => (SOME (false, body), ())) - (fn () => raise Unreachable) + val f = fn (_, macro) => (SOME (false, macro), ()) + val ((), tree) = macrosLookup (#macros ppc) id (f, ()) in - getToken ppc + getToken $ updatePpc ppc s#macros tree % end - | _ => (tk, pos, ppc) + | _ => def () end and handleToken tk pos ppc = - case List.find (fn (tk', _) => tk' = tk) directiveTable of - SOME (_, f) => getToken o f $ ppc - | NONE => handleRegularToken tk pos ppc - - and getToken (P as { streams = [stream], EOSreached = true, ... }) = let - val (pos, stream) = T.S.EOFpos stream + fun checkMode () = + if (#restricted ppc) then + raiseTkError "directive in unexpected place" pos + else + ppc in - (T.EOS, TkPos (pos, []), updatePpc P s#streams [stream] %) + case List.find (fn (tk', _) => tk' = tk) directiveTable of + SOME (_, f) => getToken o f $ checkMode () + | NONE => handleRegularToken tk pos ppc end - | getToken (P as { buffer = (tk, pos) :: tail, ... }: t) = + + and getToken (P as { buffer = (tk, pos) :: tail, ... }: t) = handleToken tk pos (updatePpc P s#buffer tail %) - | getToken (P as { streams = head :: tail, ... }: t) = + | getToken (P as { streams = [], ... }: t) = (T.EOS, dummyEOSpos, P) + | getToken (P as { streams = head :: tail, restricted, ... }: t) = let val (tk, pos, head) = T.getToken head in if tk = T.EOS then - case tail of - [] => getToken $ updatePpc P s#EOSreached true % + case (restricted, tail) of + (true, _) => + (T.EOS, dummyEOSpos, updatePpc P u#streams (updateH head) %) + | (false, []) => + let + val (pos, head) = T.S.EOFpos head + in + (T.EOS, pos2tkPos pos, updatePpc P s#streams [head] %) + end | _ => getToken $ updatePpc P s#streams tail % else - handleToken tk (TkPos (pos, [])) $ - updatePpc P s#streams (head :: tail) % + handleToken tk (pos2tkPos pos) $ + updatePpc P u#streams (updateH head) % end - | getToken _ = raise Unreachable - fun debugPrint' ppc = + fun debugPrint' cache ppc = let val (tk, pos, ppc) = getToken ppc - - fun printTkPos (TkPos (pos, layers)) = - let - fun printLayer (macroName, pos) = - printf `macroName `" " A1 T.S.pos2str pos % - - fun printLayers' [layer] = printLayer layer - | printLayers' (layer :: layers) = ( - printLayer layer; - output ", "; - printLayers' layers - ) - | printLayers' [] = raise Unreachable - - fun printLayers [] = () - | printLayers layers = ( - output " ("; - printLayers' layers; - output ")" - ) - in - printf A1 T.S.pos2str pos %; - printLayers layers; - output ": " - end + val cache = printToken cache (output TextIO.stdOut) (tk, pos) in - printTkPos pos; - T.printToken tk; - printf `"\n" %; if tk = T.EOS then () else - debugPrint' ppc + debugPrint' cache ppc end fun debugPrint fname incDirs = let - val ppc = create { fname, incDirs } + val ppc = create { fname, incDirs, debugMode = true } in - debugPrint' ppc; - output "\n" + debugPrint' startCache ppc; + printf `"\n" % end end @@ -19,7 +19,7 @@ signature PPC = sig Cbinop | Cop - val create: { fname: string, incDirs: string list } -> t + val create: { fname: string, incDirs: string list, debugMode: bool } -> t val debugPrint: string -> string list -> unit @@ -8,7 +8,7 @@ signature STREAM = sig exception EOF - val pos2str: pos -> string + val Ppos: (pos, 'a, 'b) a1printer val getchar: t -> char option * t val getcharEx: t -> char * t (* throws EOF *) @@ -28,12 +28,13 @@ structure Stream :> STREAM = struct end z - fun pos2str (Pos (pos, line, col)) = + val Ppos = fn z => let - val % = Int.toString + fun p (out, Pos (fname, line, col)) = + Printf out `fname `":" I line `":" I col % in - pos ^ ":" ^ %line ^ ":" ^ %col - end + bind A1 p + end z fun getcharSure (S as { contents, off, ... }: t) = (String.sub (contents, off), updateStream S s#off (off + 1) %) diff --git a/tokenizer.fun b/tokenizer.fun index 12b3257..9d7f8fc 100644 --- a/tokenizer.fun +++ b/tokenizer.fun @@ -114,25 +114,25 @@ struct CommentStart | - CppInclude | - CppDefine | - CppUndef | - CppIf | - CppIfdef | - CppIfndef | - CppElse | - CppElif | - CppEndif | - CppWarning | - CppError | - CppPragma + PpcInclude | + PpcDefine | + PpcUndef | + PpcIf | + PpcIfdef | + PpcIfndef | + PpcElse | + PpcElif | + PpcEndif | + PpcWarning | + PpcError | + PpcPragma datatype tkErrorAuxInfo = TkiEOF | TkiDx of int | TkiStart exception TkError of tkErrorAuxInfo * string exception TkErrorAug of S.pos * string - exception ExpectedCppDir (* handled in postprocess *) + exception ExpectedPpcDir (* handled in postprocess *) exception FsmTableIsTooSmall @@ -141,17 +141,19 @@ struct exception SuffixWithoutRepr val kwPrefix = #"`" - val cppPrefix = #"$" + val ppcPrefix = #"$" val otherPrefix = #"@" val tokenRepr = let fun & repr = str kwPrefix ^ repr - fun % repr = str cppPrefix ^ repr + fun % repr = str ppcPrefix ^ repr + fun ` repr = str otherPrefix ^ repr in [ - (NewLine, "@NewLine"), - (EOS, "@EOS"), + (NewLine, `"NewLine"), + (EOS, `"EOS"), + (Invalid, `"Invalid"), (kwBreak, &"break"), (kwCase, &"case"), @@ -242,18 +244,18 @@ struct (CommentStart, "/*"), - (CppInclude, %"include"), - (CppDefine, %"define"), - (CppUndef, %"undef"), - (CppIf, %"if"), - (CppIfdef, %"ifdef"), - (CppIfndef, %"ifndef"), - (CppElse, %"else"), - (CppElif, %"elif"), - (CppEndif, %"endif"), - (CppWarning, %"warning"), - (CppError, %"error"), - (CppPragma, %"pragma") + (PpcInclude, %"include"), + (PpcDefine, %"define"), + (PpcUndef, %"undef"), + (PpcIf, %"if"), + (PpcIfdef, %"ifdef"), + (PpcIfndef, %"ifndef"), + (PpcElse, %"else"), + (PpcElif, %"elif"), + (PpcEndif, %"endif"), + (PpcWarning, %"warning"), + (PpcError, %"error"), + (PpcPragma, %"pragma") ] end @@ -280,10 +282,11 @@ struct fun getSfxReprSimple sfx buf = getSfxRepr sfx buf (fn () => raise SuffixWithoutRepr) - val token2str = fn - Id s => s - | MacroStart macro => "m(" ^ macro ^ ")" - | MacroEnd macro => "mend(" ^ macro ^ ")" + fun printToken (out, tk) = + case tk of + Id s => Printf out `s % + | MacroStart macro => Printf out `"m(" `macro `")" % + | MacroEnd macro => Printf out `"mend(" `macro `")" % | Num (IntConst (it, str, sfx)) => let val intType = @@ -292,19 +295,25 @@ struct | ItOct => "0" | ItHex => "0x" in - intType ^ str ^ getSfxReprSimple sfx intSuffixRepr + Printf out `intType `str `(getSfxReprSimple sfx intSuffixRepr) % end | Num (FloatConst (str, sfx)) => - str ^ getSfxReprSimple sfx floatSuffixRepr - | CharConst (repr, _) => repr - | StringConst s => - "\"" ^ s ^ "\"" + Printf out `str `(getSfxReprSimple sfx floatSuffixRepr) % + | CharConst (repr, _) => Printf out `repr % + | StringConst s => Printf out `"\"" `s `"\"" % | v => case List.find (fn (x, _) => x = v) tokenRepr of - SOME (_, repr) => repr + SOME (_, repr) => + let + val head = String.sub (repr, 0) + val head = if head = ppcPrefix then #"#" else head + val tail = String.extract (repr, 1, NONE) + in + Printf out C head `tail % + end | NONE => raise TokenWithoutRepr - fun printToken tk = printf A1 token2str tk % + val Ptoken = fn z => bind A1 printToken z fun isIdStart c = Char.isAlpha c orelse c = #"_" fun isIdBody c = Char.isAlphaNum c orelse c = #"_" @@ -356,7 +365,7 @@ struct let val c = String.sub (repr, 0) in - c <> kwPrefix andalso c <> cppPrefix + c <> kwPrefix andalso c <> ppcPrefix andalso c <> otherPrefix end) tokenRepr @@ -401,12 +410,12 @@ struct T end - (* Unused right now fun printTable (nextState, buf) = let + open Array fun printRow i row = if i = length row then - output "\n" + printf `"\n" % else let val state = sub (row, i) @@ -414,7 +423,7 @@ struct if state = ~1 then () else - printf C (chr i) `": " I state `", " %; + printf C (chr i) `" -> " I state `", " %; printRow (i + 1) row end @@ -425,16 +434,16 @@ struct let val (tk, row) = sub (buf, rowNum) in - printf A1 token2string tk `": " %; + printf `"row " I rowNum `" - " Ptoken tk `": \t" %; printRow 0 row; print' (rowNum + 1) buf end in + printf `"FSM table:\n"; printf `"NextState: " I (!nextState) `"\n" %; print' 0 buf; - output "\n" + printf `"\n" % end - *) val fsmTable = lazy fsmTableCreate @@ -852,26 +861,26 @@ struct val charParser = seqParser SpmChr val strParser = seqParser SpmStr - fun formCppDir (Id s) = + fun formPpcDir (Id s) = let open String in case List.find (fn (_, repr) => - sub (repr, 0) = cppPrefix andalso + sub (repr, 0) = ppcPrefix andalso extract (repr, 1, NONE) = s) tokenRepr of SOME (tk, _) => tk - | NONE => raise ExpectedCppDir + | NONE => raise ExpectedPpcDir end - | formCppDir kwElse = CppElse - | formCppDir kwIf = CppIf - | formCppDir _ = raise ExpectedCppDir + | formPpcDir kwElse = PpcElse + | formPpcDir kwIf = PpcIf + | formPpcDir _ = raise ExpectedPpcDir - fun handleCppDir (pos, tk) = - formCppDir tk handle - ExpectedCppDir => + fun handlePpcDir (pos, tk) = + formPpcDir tk handle + ExpectedPpcDir => raise TkErrorAug (pos, "expected preprocessor directive") fun unexpectedCharRaise stream c = @@ -940,7 +949,7 @@ struct if tk = EOS then raise TkErrorAug (pos, "unfinished preprecessor directive") else - (handleCppDir (pos', tk), pos, stream) + (handlePpcDir (pos', tk), pos, stream) end else (tk, pos, stream) @@ -977,23 +986,28 @@ struct unexpectedCharRaise stream c end - (* TODO: remove *) - fun debugPrint tkl fname = + fun debugPrint fname = let - fun print' line _ ((NewLine, _) :: tks) = - print' (line + 1) true tks - | print' line firstOnLine ((tk, _) :: tks) = ( - if firstOnLine then - printf `"\n" `fname `":" I line `"\t" % - else - (); - printToken tk; - output " "; - print' line false tks - ) - | print' _ _ [] = () + val stream = S.create fname + + fun print line stream = + let + val (tk, S.Pos (_, line', col'), stream) = getToken stream + in + if line <> line' then + printf `"\nline " I line' `": \t" % + else + (); + printf I col' `":" Ptoken tk `" "; + if tk = EOS then + () + else + print line' stream + end in - print' 1 true tkl; - output "\n" + printTable $ fsmTable (); + printf `"Tokenizing file: " `fname; + print 0 stream; + printf `"\n" % end end diff --git a/tokenizer.sig b/tokenizer.sig index f79e62a..53a9f17 100644 --- a/tokenizer.sig +++ b/tokenizer.sig @@ -111,27 +111,25 @@ signature TOKENIZER = sig CommentStart | - CppInclude | - CppDefine | - CppUndef | - CppIf | - CppIfdef | - CppIfndef | - CppElse | - CppElif | - CppEndif | - CppWarning | - CppError | - CppPragma + PpcInclude | + PpcDefine | + PpcUndef | + PpcIf | + PpcIfdef | + PpcIfndef | + PpcElse | + PpcElif | + PpcEndif | + PpcWarning | + PpcError | + PpcPragma (* Fatal. both may be thrown by tokenize *) exception FsmTableIsTooSmall exception TkErrorAug of S.pos * string val getToken: S.t -> token * S.pos * S.t + val Ptoken: (token, 'a, 'b) a1printer - val token2str: token -> string - val printToken: token -> unit - - val debugPrint: (token * S.pos) list -> string -> unit + val debugPrint: string -> unit end diff --git a/tree.sig b/tree.sig new file mode 100644 index 0000000..afab259 --- /dev/null +++ b/tree.sig @@ -0,0 +1,13 @@ +signature TREE = sig + type ('k, 'v) t + exception Exists + + val empty: ('k, 'v) t + + val insert: ('k -> 'k -> order) -> ('k, 'v) t -> 'k -> 'v -> ('k, 'v) t + val lookup: ('k -> 'k -> order) -> ('k, 'v) t -> 'k -> 'v option + val lookup2: ('k -> 'k -> order) -> ('k, 'v) t -> 'k -> + ('v -> 'v option * 'a) * 'a -> 'a * ('k, 'v) t + + val print: ('k, 'v) t -> ('k -> string) -> ('v -> string) -> unit +end diff --git a/tree.sml b/tree.sml new file mode 100644 index 0000000..597e469 --- /dev/null +++ b/tree.sml @@ -0,0 +1,75 @@ +structure Tree: TREE = struct + datatype ('k, 'v) t = Node of 'k * 'v * ('k, 'v) t * ('k, 'v) t | Empty + + exception Exists + + val empty = Empty + + fun insert _ Empty k v = Node (k, v, Empty, Empty) + | insert cmp (Node (k', v', left, right)) k v = + case cmp k k' of + LESS => Node (k', v', insert cmp left k v, right) + | EQUAL => raise Exists + | GREATER => Node (k', v', left, insert cmp right k v) + + fun lookup _ Empty _ = NONE + | lookup cmp (Node (k', v', left, right)) k = + case cmp k k' of + LESS => lookup cmp left k + | EQUAL => SOME v' + | GREATER => lookup cmp right k + + datatype ('k, 'v) arc = + Left of 'k * 'v * ('k, 'v) t | + Right of 'k * 'v * ('k, 'v) t + + fun assemble n buf = + let + fun assemble' tree (Left (k, v, right) :: tail) = + assemble' (Node (k, v, tree, right)) tail + | assemble' tree (Right (k, v, left) :: tail) = + assemble' (Node (k, v, left, tree)) tail + | assemble' tree [] = tree + in + assemble' n buf + end + + fun lookup' _ _ Empty _ _ g = (g, NONE) + | lookup' buf cmp (Node (k', v', left, right)) k f g = + case cmp k k' of + LESS => lookup' (Left (k', v', right) :: buf) cmp left k f g + | GREATER => lookup' (Right (k', v', left) :: buf) cmp right k f g + | EQUAL => + let + val (newV, result) = f v' + in + case newV of + NONE => (result, NONE) + | SOME v => (result, SOME (assemble (Node (k', v, left, right)) buf)) + end + + fun lookup2 cmp t k (f, g) = + let + val (result, newTree) = lookup' [] cmp t k f g + in + (result, case newTree of + NONE => t + | SOME t => t) + end + + fun print t key2str value2str = + let + fun Pkey z = bindWith2str key2str z + fun Pvalue z = bindWith2str value2str z + + fun print' off Empty = printf R off `"()\n" % + | print' off (Node (k, v, left, right)) = ( + printf R off `"(" Pkey k `", " Pvalue v `"\n"; + print' (off + 1) left; + print' (off + 1) right; + printf R off `")\n" % + ) + in + print' 0 t + end +end |