diff options
Diffstat (limited to 'ppc.fun')
| -rw-r--r-- | ppc.fun | 307 |
1 files changed, 175 insertions, 132 deletions
@@ -16,7 +16,7 @@ struct type t = { buffer: layer list, - macros: (string, bool * tkPos * macro) Tree.t, + macros: (string, bool * T.S.pos * macro) Tree.t, debugMode: bool, incDirs: string list @@ -48,15 +48,15 @@ struct fun raiseTkErrorP pos g = sprintf (fn (a, f) => g (a, raiseTkError pos o f)) - fun printLayers ((macroName, pos) :: layers) = ( - printf `"\t" `macroName `" " T.S.Ppos pos %; - printLayers layers + fun printLayersU ((macroName, pos) :: layers) = ( + printf `"\tfrom " `macroName `" at " T.S.Ppos pos `"\n" %; + printLayersU layers ) - | printLayers [] = () + | printLayersU [] = () fun tkErrorPrint (TkPos (pos, layers), msg) = ( printf T.S.Ppos pos `": " `msg `"\n" %; - printLayers layers + printLayersU layers ) fun raiseTkClassError pos cls = raise TkClassError (pos, cls) @@ -87,7 +87,7 @@ struct printf T.S.Ppos pos `": expected " %; printClassList cls; printf `"\n"; - printLayers layers + printLayersU layers end val updatePpc = fn z => @@ -104,92 +104,89 @@ struct { buffer = [Stream $ T.S.create fname], macros = Tree.empty, debugMode, incDirs } - fun compareLayers cached macroLayers = + fun printLayer out (macro, pos) = Printf out `macro `" " T.S.Ppos pos % + + fun printLayers _ [] = () + | printLayers out [layer] = printLayer out layer + | printLayers out (layer :: layers) = ( + printLayer out layer; + Printf out `", "; + printLayers out layers + ) + + val Players = fn z => 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) + fun Players (out, layers) = printLayers out layers in - (length cachedTail, macroTail) + bind A1 Players + end z + + fun convPos (T.S.Pos (fname, line, col)) plen = + let + val fname = String.extract (fname, plen, NONE) + in + T.S.Pos ("@" ^ fname, line, col) end - fun printClosure offset _ 0 = offset - | printClosure offset out toClose = + fun findPrefix s1 s2 = let - fun printBrace offset 1 = Printf out R offset `"}" % - | printBrace offset toClose = ( - Printf out R offset `"}\n"; - printBrace (offset - 1) (toClose - 1) - ) + fun findPrefix' i s1 s2 = + if i = size s1 orelse i = size s2 then + String.substring (s1, 0, i) + else if String.sub (s1, i) = String.sub (s2, i) then + findPrefix' (i + 1) s1 s2 + else + String.substring (s1, 0, i) in - Printf out `"\n"; - printBrace (offset - 1) toClose; - offset - toClose + findPrefix' 0 s1 s2 end - fun printNewLayers offset _ [] = offset - | printNewLayers offset out layers = + fun PlayersCompact (_, (_, [])) = "" + | PlayersCompact (out, (startPrx, L as (layer :: layers))) = let - fun printLayer offset (macro, pos) = - Printf out R offset `macro `" " T.S.Ppos pos `" {" % - val () = Printf out `"\n" % + fun getFname (_, T.S.Pos (fname, _, _)) = fname - fun printLayers offset [layer] = printLayer offset layer - | printLayers offset (layer :: tail) = ( - printLayer offset layer; - Printf out `"\n"; - printLayers (offset + 1) tail - ) - | printLayers _ [] = raise Unreachable + fun findCommonPrefix prefix [] = prefix + | findCommonPrefix prefix (layer :: layers) = + findCommonPrefix (findPrefix prefix $ getFname layer) layers + + val (startPrx, layers) = + case startPrx of + SOME prx => (prx, L) + | NONE => (getFname layer, layers) + val prefix = findCommonPrefix startPrx layers + val plen = size prefix in - printLayers offset layers; - offset + length layers + Printf out `prefix `" | " %; + printLayers out $ map (fn (m, pos) => (m, convPos pos plen)) L; + prefix end - fun printToken (offset, layers, (fname, line)) out (tk, pos) = + val startCache = (0, [], ("", 0)) + + fun printTokenCompact (off, 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 + fun Ppos out = + case layers' of + [] => Printf out `fname' `":" I line' `"| \t" % + | _ => + let + val prefix = PlayersCompact (out, (SOME fname', layers')) + val fname' = String.extract (fname', size prefix, NONE) + in + Printf out `"; @" `fname' `":" I line' `"| \t" % + end in - if offset1 <> offset orelse offset2 <> offset1 orelse - fname' <> fname orelse line' <> line - then - Printf out `"\n" R offset2 `fname' `":" I line' `"|\t" % + if layers <> layers' orelse fname' <> fname orelse line' <> line then + Printf out `"\n" R off A0 Ppos % else (); Printf out I col' `":" T.Ptk tk `" "; - (offset2, layers', (fname', line')) + (off, layers', (fname', line')) end - val Players = fn z => - 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 - in - bind A1 Players - end z - val PtkPos = fn z => let fun PtkPos (out, TkPos (pos, layers)) = ( @@ -203,31 +200,49 @@ struct bind A1 PtkPos end z - fun warning pos g = printf `"\n" PtkPos pos `":warning: " g + fun warning (TkPos (pos, layers)) g = + printf `"\n" T.S.Ppos pos `":warning: " + (fn (a, _) => g (a, fn (_, output) => + (output "\n"; printLayersU layers))) val printMacroHeader = fn z => let fun printMacroHeader (out, (id, mLayers)) = - Printf out `"\n" `"(" Players (rev mLayers) `"): macro " `id % + let + fun Players (out, v) = ignore $ PlayersCompact (out, v) + in + Printf out `"\nexpanding (" A1 Players (NONE, rev mLayers) + `") macro " `id % + end in bind A1 printMacroHeader end z - val startCache = (0, [], ("", 0)) - val printTokenL = fn z => let - fun printTokenL (out, (offset, layers, l)) = + fun printTokenL (out, (offset, l)) = let - fun printList cache [] = cache + fun printList _ [] = () | printList cache (tk :: tail) = - printList (printToken cache out tk) tail + printList (printTokenCompact cache out tk) tail + + fun getLast5 (l as _ :: _ :: _ :: _ :: _ :: []) = l + | getLast5 (_ :: xs) = getLast5 xs + | getLast5 _ = raise Unreachable - val cache = (offset, layers, ("", 0)) - val (offset, layers', _) = printList cache l - val toClose = length layers' - length layers + val cache = (offset, [], ("", 0)) in - printClosure offset out toClose; + if length l <= 10 then + printList cache l + else + let + val first5 = List.take (l, 5) + val last5 = getLast5 l + in + printList cache first5; + Printf out `"\n\t..."; + printList cache last5 + end; Printf out `"\n" % end in @@ -236,9 +251,24 @@ struct fun updateH head = fn s => Stream head :: tl s + fun handleMacroEnd id ppc = + let + val f = fn (_, pos, macro) => (SOME (false, pos, macro), ()) + val ((), tree) = macrosLookup (#macros ppc) id (f, ()) + in + updatePpc ppc s#macros tree % + end + fun getTokenNoexpand (P as { buffer = Tokens tks :: _, ... }: t) = ( case tks of - (tk, pos) :: tail => + (T.MacroEnd id, _) :: tail => + let + val ppc = handleMacroEnd id P + val ppc = updatePpc ppc u#buffer (fn buf => Tokens tail :: tl buf) % + in + getTokenNoexpand ppc + end + | (tk, pos) :: tail => (tk, pos, updatePpc P u#buffer (fn buf => Tokens tail :: tl buf) %) | [] => getTokenNoexpand $ updatePpc P u#buffer tl % ) @@ -248,7 +278,7 @@ struct in (tk, pos2tkPos pos, updatePpc P u#buffer (updateH head) %) end - | getTokenNoexpand _ = raise Unreachable + | getTokenNoexpand ppc = (T.EOS, dummyEOSpos, ppc) fun checkClass (tk, pos) clList raiseClassErr = let @@ -339,10 +369,10 @@ struct val start = String.sub (arg, 0) val check = checkEndsWith pos arg in - if start = #"<" then - LocalInc (dir, check #">") - else if start = #"\"" then - ExternalInc $ check #"\"" + if start = #"\"" then + LocalInc (dir, check #"\"") + else if start = #"<" then + ExternalInc $ check #">" else raiseTkError pos "invalid #include argument" end @@ -374,20 +404,19 @@ struct | _ => getDefineMacroBody ppc ((tk, pos) :: acc) end - fun isFuncMacroDefine len (TkPos (T.S.Pos (_, line1, col1), [])) ppc = + fun isFuncMacroDefine len (T.S.Pos (_, line1, col1)) ppc = let val (tk, TkPos (T.S.Pos (_, line2, col2), _), _) = getTokenNoexpand ppc in tk = T.LParen andalso line1 = line2 andalso col1 + len = col2 end - | isFuncMacroDefine _ _ _ = raise Unreachable fun PrintMacroBody (out, body) = if body = [] then () else ( Printf out `" {"; - Printf out printTokenL (0, [], body); + Printf out printTokenL (1, body); Printf out `"}" % ) @@ -477,6 +506,7 @@ struct fun parseDefine ppc = let val (macroName, pos, ppc) = getClassNoexpand ppc [Cid] + val TkPos (pos, _) = pos val macroName = case macroName of T.Id id => id | _ => raise Unreachable @@ -499,10 +529,25 @@ struct val (prevVal, macros) = insertMacro (#macros ppc) macroName (false, pos, macro) + + fun eqMacroBody [] [] = true + | eqMacroBody [] _ = false + | eqMacroBody _ [] = false + | eqMacroBody ((tk1, _) :: tl1) ((tk2, _) :: tl2) = + if tk1 <> tk2 then false else eqMacroBody tl1 tl2 + + fun eqMacro (ObjMacro b1, ObjMacro b2) = eqMacroBody b1 b2 + | eqMacro (FuncMacro (pl1, b1), FuncMacro (pl2, b2)) = + pl1 = pl2 andalso eqMacroBody b1 b2 + | eqMacro _ = false in case prevVal of - SOME (_, pos', _) => warning pos - `"macro redefinition (see " PtkPos pos' `")" % + SOME (_, pos', macro') => + if not $ eqMacro (macro, macro') then ( + warning (pos2tkPos pos) `macroName `" macro redefinition" %; + printf `"See " T.S.Ppos pos' % + ) else + () | NONE => (); updatePpc ppc s#macros macros % end @@ -528,9 +573,9 @@ struct val printBody = fn z => let - fun printBody (out, (mLayers, msg, body)) = ( + fun printBody (out, (msg, body)) = ( Printf out `"\n" `msg `" {"; - Printf out printTokenL (1, mLayers, body); + Printf out printTokenL (1, body); Printf out `"}\n" % ) in @@ -548,7 +593,7 @@ struct val mLayers = addLayer (id, pos) in dprintf ppc printMacroHeader (id, mLayers); - dprintf ppc printBody (mLayers, "body", rev revBody); + dprintf ppc printBody ("body", rev revBody); insertRevBody revBody ppc end @@ -615,8 +660,12 @@ struct getAll ppc [] end - and subst _ [] (acc: (T.token * tkPos) list) = rev acc - | subst bindedParams ((P as (T.Id id, _)) :: tail) acc = + and subst (id, pos)_ [] acc = + if acc = [] then + [(T.MacroEnd id, pos)] + else + rev $ (T.MacroEnd id, #2 o hd $ acc) :: acc + | subst idPos bindedParams ((P as (T.Id id, _)) :: tail) acc = let fun findArg ((id', args) :: tail) = if id' = id then @@ -626,21 +675,21 @@ struct | findArg [] = NONE in case findArg bindedParams of - NONE => subst bindedParams tail (P :: acc) + NONE => subst idPos bindedParams tail (P :: acc) | SOME arg => - subst bindedParams tail (List.revAppend (arg, acc)) + subst idPos bindedParams tail (List.revAppend (arg, acc)) end - | subst bindedParams (P :: tail) acc = - subst bindedParams tail (P :: acc) + | subst bindedParams idPos (P :: tail) acc = + subst bindedParams idPos tail (P :: acc) and printBinded z = let - fun printBinded (out, (mLayer, msg, params)) = + fun printBinded (out, (msg, params)) = let fun print [] = () | print ((p, args) :: tail) = ( Printf out `p `": "; - Printf out printTokenL (1, mLayer, args); + Printf out printTokenL (1, args); print tail ) in @@ -667,15 +716,15 @@ struct val (bindedParams, ppc) = parseFuncMacroArgs mPos params ppc val bp1 = apply addLayers2args bindedParams - val () = dprintf ppc printBinded (mLayers, "args", bp1) % + val () = dprintf ppc printBinded ("args", bp1) % val bp2 = apply (expandArgument ppc) bp1 - val () = dprintf ppc printBinded (mLayers, "expanded args", bp2) % + val () = dprintf ppc printBinded ("expanded args", bp2) % val body = setLayers (id, mPos) body - val body = subst bp2 body [] + val body = subst (id, mPos) bp2 body [] in - dprintf ppc printBody (mLayers, "subst", body); + dprintf ppc printBody ("subst", body); insertRevBody (rev body) ppc end @@ -826,10 +875,25 @@ struct val (cond, ppc) = eval ifPos ppc val (revBody, ppc) = getRevBody ifPos cond ppc in - dprintf `" {" printTokenL (1, [], rev revBody) `"}\n"; + dprintf `" {" printTokenL (1, rev revBody) `"}\n"; insertRevBody revBody ppc end + and handleUndef _ ppc = + let + val (tk, pos, ppc) = getTokenNoexpand ppc + val id = case tk of T.Id id => id | _ => raise Unreachable + val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine] + val (prevVal, macros) = Tree.delete macroCompare (#macros ppc) id + in + dprintf ppc `"\n#undef " `id %; + case prevVal of + NONE => warning pos + `"#undef: no macro with provided name was defined" % + | SOME _ => (); + updatePpc ppc s#macros macros % + end + and handleRegularToken tk pos ppc = let fun checkAndMark (true, _, _) = (NONE, NONE) @@ -853,31 +917,10 @@ struct in case tk of T.Id id => handleMacro id - | T.MacroEnd id => - let - val f = fn (_, pos, macro) => (SOME (false, pos, macro), ()) - val ((), tree) = macrosLookup (#macros ppc) id (f, ()) - in - getToken $ updatePpc ppc s#macros tree % - end + | T.MacroEnd id => getToken $ handleMacroEnd id ppc | _ => def () end - and handleUndef _ ppc = - let - val (tk, pos, ppc) = getTokenNoexpand ppc - val id = case tk of T.Id id => id | _ => raise Unreachable - val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine] - val (prevVal, macros) = Tree.delete macroCompare (#macros ppc) id - in - dprintf ppc `"\n#undef " `id %; - case prevVal of - NONE => warning pos - `"#undef: no macro with provided name was defined" % - | SOME _ => (); - updatePpc ppc s#macros macros % - end - and ppcFallback (_, pos) _ = raiseTkError pos "directive is not implemented" @@ -932,7 +975,7 @@ struct fun debugPrint' cache ppc = let val (tk, pos, ppc) = getToken ppc - val cache = printToken cache (output TextIO.stdOut) (tk, pos) + val cache = printTokenCompact cache (output TextIO.stdOut) (tk, pos) in if tk = T.EOS then () |