diff options
Diffstat (limited to 'ppc.fun')
| -rw-r--r-- | ppc.fun | 300 |
1 files changed, 300 insertions, 0 deletions
@@ -0,0 +1,300 @@ +functor ppc(structure H: HASHTABLE; structure T: TOKENIZER): PPC = +struct + + structure T = T + + datatype tkPos = TkPos of T.S.pos + + 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 *) + + EOSreached: bool, + incDirs: string list + } + + type tkErrorVal = tkPos * string + exception TkError of tkErrorVal + + datatype expTk = + ExpTk of T.token | + ExpId | + ExpConst | + ExpUnop | + ExpBinop | + ExpOp + + type tkErrorExpVal = tkPos * expTk list + exception TkErrorExp of tkErrorExpVal + + fun raiseTkError msg pos = raise TkError (pos, msg) + fun raiseTkErrorSPos pos msg = raiseTkError msg (TkPos pos) + + fun tkErrorPrint (TkPos pos, msg) = + printLn $ T.S.pos2str pos ^ ": " ^ msg + + fun raiseTkErrorExp pos exp = raise TkErrorExp (pos, exp) + fun raiseTkErrorExpSPos pos exp = raiseTkErrorExp (TkPos pos) exp + + fun tkErrorExpPrint (TkPos pos, exp) = + 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" + + fun printExpList [] = raise Unreachable + | printExpList [etk] = printEtk etk + | printExpList [etk1, etk2] = ( + printEtk etk1; + print " or "; + printEtk etk2 + ) + | printExpList (etk :: etks) = ( + printEtk etk; + print ", "; + printExpList etks + ) + in + print $ T.S.pos2str pos ^ ": expected "; + printExpList exp; + print "\n" + 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 + in + FRU.makeUpdate5 (from, from, to) + end + z + + fun create { fname, incDirs } = + { streams = [T.S.create fname], buffer = [], macros = H.create 10, + EOSreached = false, incDirs } + + datatype IncludeArg = + LocalInc of string * T.S.pos | + ExternalInc of string * T.S.pos + + fun parseIncludeArg stream = + let + fun eat pred stream skipFirst acc = + let + val (c, stream') = T.S.getcharEx stream + in + if pred c then + eat pred stream' skipFirst (c :: acc) + else + (implode o rev $ acc, if skipFirst then stream' else stream) + end + val (_, stream) = eat Char.isSpace stream false [] + val (pos, stream) = T.S.getPos stream + val (start, stream) = T.S.getcharEx stream + val finish = + if start = #"\"" then + #"\"" + else if start = #"<" then + #">" + else + raiseTkErrorSPos pos "expected \" or <" + + val (arg, stream) = eat (fn c => c <> finish) stream true [] + val (_, stream) = + eat (fn c => c = #" " orelse c = #"\t") stream false [] + val (c, stream) = T.S.getcharEx stream + in + if c <> #"\n" then + let + val (pos, _) = T.S.getPosAfterChar stream + in + raiseTkErrorSPos pos "expected '\n'" + end + else + (if start = #"\"" then LocalInc (arg, pos) + else ExternalInc (arg, pos), stream) + end handle T.S.EOF => + let + val (pos, _) = T.S.EOFpos stream + in + raiseTkErrorSPos pos "unexpected EOF during #include argument parsing" + end + + fun findFile arg (stream, incDirs) = + case arg of + 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 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 + + fun handleInclude (P as { streams = head :: tail, incDirs, ... }: t) = + let + val (arg, oldHead) = parseIncludeArg head + val (path, instream) = findFile arg (head, incDirs) + val head = T.S.createFromInstream path instream + in + updatePpc P s#streams (head :: oldHead :: tail) % + end + | handleInclude _ = raise Unreachable + + fun handleDefine (P as { streams = head :: _, ... }: t) = + 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] + 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, head) = getName head + val (macroBody, head) = getBody head [] + + val () = H.insert (#macros P) macroName macroBody 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 = + let + fun def () = (tk, TkPos pos, P) + 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 () + end + + and getToken (P as { streams = [stream], EOSreached = true, ... }) = + let + val (pos, stream) = T.S.EOFpos stream + in + (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 %) + | 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 % + 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 + end + | getToken _ = raise Unreachable + + + fun debugPrint' ppc shouldPrintLine (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 finish shouldPrintLine = + if tk <> T.EOS then + debugPrint' ppc shouldPrintLine (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 + ) + end + + fun debugPrint fname incDirs = + let + val ppc = create { fname, incDirs } + in + debugPrint' ppc true ("", 0); + print "\n" + end +end |