diff options
Diffstat (limited to 'ppc.fun')
| -rw-r--r-- | ppc.fun | 298 |
1 files changed, 189 insertions, 109 deletions
@@ -5,11 +5,17 @@ struct datatype tkPos = TkPos of T.S.pos + type macroBody = (T.token * T.S.pos) list + datatype macro = + ObjMacro of macroBody | + FuncMacro of string list * macroBody + type t = { streams: T.S.t list, buffer: (T.token * T.S.pos) list, - macros: (T.token * T.S.pos) list H.t, (* body is stored reversed *) + + macros: (bool * macro) H.t, EOSreached: bool, incDirs: string list @@ -33,7 +39,7 @@ struct fun raiseTkErrorSPos pos msg = raiseTkError msg (TkPos pos) fun tkErrorPrint (TkPos pos, msg) = - printLn $ T.S.pos2str pos ^ ": " ^ msg + printf A1 T.S.pos2str pos `": " `msg `"\n" % fun raiseTkErrorExp pos exp = raise TkErrorExp (pos, exp) fun raiseTkErrorExpSPos pos exp = raiseTkErrorExp (TkPos pos) exp @@ -42,28 +48,28 @@ struct let val printEtk = fn ExpTk tk => T.printToken tk - | ExpId => print "identifier" - | ExpConst => print "constant" - | ExpUnop => print "unary operator" - | ExpBinop => print "binary operator" - | ExpOp => print "operator" + | 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; - print " or "; + output " or "; printEtk etk2 ) | printExpList (etk :: etks) = ( printEtk etk; - print ", "; + output ", "; printExpList etks ) in - print $ T.S.pos2str pos ^ ": expected "; + printf A1 T.S.pos2str pos `": expected " %; printExpList exp; - print "\n" + output "\n" end val updatePpc = fn z => @@ -78,7 +84,7 @@ struct z fun create { fname, incDirs } = - { streams = [T.S.create fname], buffer = [], macros = H.create 10, + { streams = [T.S.create fname], buffer = [], macros = H.createLog 10, EOSreached = false, incDirs } datatype IncludeArg = @@ -130,34 +136,34 @@ struct fun findFile arg (stream, incDirs) = case arg of - LocalInc (arg, pos) => ( + LocalInc (arg, pos) => ( + let + val dir = OS.Path.getParent o T.S.getFname $ stream + val path = OS.Path.concat (dir, arg) + + val (path, instream) = (path, TextIO.openIn path) + in + (path, instream) + end handle + OS.Path.Path => raiseTkErrorSPos pos "invalid argument" + | Size => raiseTkErrorSPos pos "resulting path is too long" + | IO.Io v => raise IO.Io v + ) + | ExternalInc (arg, pos) => + let + fun try (dir :: tail) = ( let - val dir = OS.Path.getParent o T.S.getFname $ stream val path = OS.Path.concat (dir, arg) - - val (path, instream) = (path, TextIO.openIn path) in - (path, instream) - end handle - OS.Path.Path => raiseTkErrorSPos pos "invalid argument" - | Size => raiseTkErrorSPos pos "resulting path is too long" - | IO.Io v => raise IO.Io v + SOME (path, TextIO.openIn path) + end handle _ => try tail ) - | ExternalInc (arg, pos) => - let - fun try (dir :: tail) = ( - let - val path = OS.Path.concat (dir, arg) - in - SOME (path, TextIO.openIn path) - end handle _ => try tail - ) - | try [] = NONE - in - case try incDirs of - SOME pair => pair - | NONE => raiseTkErrorSPos pos "unable to find header" - end + | try [] = NONE + in + case try incDirs of + SOME pair => pair + | NONE => raiseTkErrorSPos pos "unable to find header" + end fun handleInclude (P as { streams = head :: tail, incDirs, ... }: t) = let @@ -169,59 +175,141 @@ struct end | handleInclude _ = raise Unreachable - fun handleDefine (P as { streams = head :: _, ... }: t) = + fun getDefineMacroBody stream acc = + let + val (tk, pos, stream) = T.getToken stream + in + case tk of + T.NewLine => (acc, stream) + | T.EOS => raiseTkErrorExpSPos pos [ExpTk T.NewLine] + | _ => getDefineMacroBody stream ((tk, pos) :: acc) + end + + fun isFuncMacroDefine nameLength (T.S.Pos (_, line1, col1)) stream = + let + val (tk, T.S.Pos (_, line2, col2), _) = T.getToken stream + in + tk = T.LParen andalso line1 = line2 andalso col1 + nameLength = col2 + end + + fun parseDefineObjMacro stream = + let + val (body, stream) = getDefineMacroBody stream [] + in + (ObjMacro body, stream) + end + + fun getSpecific stream expList = + let + val (tk, pos, stream) = T.getToken stream + in + raise Unimplemented + end + + fun parseDefineMacroArgs stream = + let + datatype arg = + Arg of string * T.S.pos | + LastArg of string * T.S.pos | + EmptyArg + in + raise Unimplemented + end + + fun parseDefineFuncMacro stream = + let + val (_, _, stream) = T.getToken stream + in + raise Unimplemented + end + + fun parseDefine stream = let fun getName stream = let val (tk, pos, stream) = T.getToken stream in case tk of - T.Id id => (id, pos, stream) - | _ => raiseTkErrorExpSPos pos [ExpId] + T.Id id => (id, pos, stream) + | _ => raiseTkErrorExpSPos pos [ExpId] end - fun getBody stream acc = - let - val (tk, pos, stream) = T.getToken stream - in - case tk of - T.NewLine => (acc, stream) - | T.EOS => raiseTkErrorExpSPos pos [ExpTk T.NewLine] - | _ => getBody stream ((tk, pos) :: acc) - end + val (macroName, pos, stream) = getName stream - val (macroName, pos, head) = getName head - val (macroBody, head) = getBody head [] + val parser = + if isFuncMacroDefine (size macroName) pos stream then + parseDefineFuncMacro + else + parseDefineObjMacro + + val (macro, stream) = parser stream + in + ((macroName, pos), macro, stream) + end - val () = H.insert (#macros P) macroName macroBody handle + fun handleDefine (P as { streams = head :: _, ... }: t) = + let + val ((macroName, pos), macro, head) = parseDefine head + + val () = H.insert (#macros P) macroName (false, macro) handle H.Exists => raiseTkErrorSPos pos "macro redefinition" in updatePpc P u#streams (fn s => head :: tl s) % end | handleDefine _ = raise Unreachable - fun handleRegularToken tk pos P = + val directiveTable = [ + (T.CppInclude, handleInclude), + (T.CppDefine, handleDefine) + ] + + fun expandObjMacro (id, pos) body ppc = let - fun def () = (tk, TkPos pos, P) + 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]] + in + updatePpc ppc u#buffer (fn buf => List.revAppend (revBody, buf)) % + end + + fun expandFuncMacro (_, _) (_, _) _ = + raise Unimplemented + + 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 case tk of - T.Id id => ( - case H.lookup (#macros P) id of - NONE => def () - | SOME body => - let - val mstart = (T.MacroStart id, pos) - val mend = (T.MacroEnd, - if body = [] then pos else (#2 o hd) body) - val revBody = List.concat [[mend], body, [mstart]] - in - getToken $ updatePpc P - u#buffer (fn buf => List.revAppend (revBody, buf)) % - end - ) - | _ => def () + T.Id id => ( + case H.lookup2 (#macros ppc) id + checkAndMark (fn () => NONE) + of + NONE => def () + | SOME (ObjMacro body) => + getToken $ expandObjMacro (id, pos) body ppc + | SOME (FuncMacro (arg, body)) => + getToken $ expandFuncMacro (id, pos) (arg, body) ppc + ) + | T.MacroEnd id => + let + val () = H.lookup2 (#macros ppc) id + (fn (_, body) => (SOME (false, body), ())) + (fn () => raise Unreachable) + in + def () + end + | _ => 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 @@ -229,72 +317,64 @@ struct (T.EOS, TkPos pos, updatePpc P s#streams [stream] %) end | getToken (P as { buffer = (tk, pos) :: tail, ... }: t) = - handleRegularToken tk pos (updatePpc P s#buffer tail %) + handleToken tk pos (updatePpc P s#buffer tail %) | getToken (P as { streams = head :: tail, ... }: t) = let val (tk, pos, head) = T.getToken head - val directiveTable = [ - (T.CppInclude, handleInclude), - (T.CppDefine, handleDefine) - ] in if tk = T.EOS then case tail of - [] => getToken $ updatePpc P s#EOSreached true % - | _ => getToken $ updatePpc P s#streams tail % + [] => getToken $ updatePpc P s#EOSreached true % + | _ => getToken $ updatePpc P s#streams tail % else - case List.find (fn (tk', _) => tk' = tk) directiveTable of - SOME (_, f) => getToken o f $ - updatePpc P s#streams (head :: tail) % - | NONE => - let - val ppc = updatePpc P u#streams (fn s => head :: tl s) % - in - handleRegularToken tk pos ppc - end + handleToken tk pos $ updatePpc P s#streams (head :: tail) % end | getToken _ = raise Unreachable - - fun debugPrint' ppc shouldPrintLine (fname, line) = + fun debugPrint' ppc (shouldPrintLine, indent) (fname, line) = let val (tk, pos, ppc) = getToken ppc val TkPos (t as (T.S.Pos (fname', line', col))) = pos - fun printLine () = - printOnNL $ fname' ^ ":" ^ Int.toString line' ^ "\n\t" + fun repeat n s = String.concat (List.tabulate (n, fn _ => s)) + val Indent = fn z => bind A0 (fn () => repeat indent "\t") z - fun finish shouldPrintLine = + fun printLine () = printf `"\n" Indent `fname' `":" I line' `" \t" % + + fun finish pair = if tk <> T.EOS then - debugPrint' ppc shouldPrintLine (fname', line') + debugPrint' ppc pair (fname', line') else () in case tk of - T.MacroStart macroName => ( - printOnNL $ "macro " ^ macroName ^ " (" ^ T.S.pos2str t ^ ") {"; - finish true - ) - | T.MacroEnd => (printOnNL "}\n"; finish true) - | _ => ( - if shouldPrintLine orelse fname' <> fname - orelse line' <> line - then - printLine() - else - (); - print $ Int.toString col ^ ":"; - T.printToken tk; - print " "; - finish false - ) + 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) + ) end fun debugPrint fname incDirs = let val ppc = create { fname, incDirs } in - debugPrint' ppc true ("", 0); - print "\n" + debugPrint' ppc (true, 0) ("", 0); + output "\n" end end |