From 5edd85474d6d8f3a0cc06cc0250ed3db8b26fcfa Mon Sep 17 00:00:00 2001 From: Vladimir Azarov Date: Sat, 17 May 2025 14:45:50 +0200 Subject: Function-like macros --- ppc.fun | 544 ++++++++++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 412 insertions(+), 132 deletions(-) (limited to 'ppc.fun') diff --git a/ppc.fun b/ppc.fun index 51b6a4e..fcd0676 100644 --- a/ppc.fun +++ b/ppc.fun @@ -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 ("", 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 -- cgit v1.2.3