From 1f31e550385cfa64a36167a5f3f9ec780baaad86 Mon Sep 17 00:00:00 2001 From: Vladimir Azarov Date: Wed, 14 May 2025 17:16:25 +0200 Subject: Proper ppc.tkPos --- ppc.fun | 261 ++++++++++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 170 insertions(+), 91 deletions(-) (limited to 'ppc.fun') diff --git a/ppc.fun b/ppc.fun index e41caec..51b6a4e 100644 --- a/ppc.fun +++ b/ppc.fun @@ -3,7 +3,8 @@ struct structure T = T - datatype tkPos = TkPos of T.S.pos + type layers = (string * T.S.pos) list + datatype tkPos = TkPos of T.S.pos * layers type macroBody = (T.token * T.S.pos) list datatype macro = @@ -13,7 +14,7 @@ struct type t = { streams: T.S.t list, - buffer: (T.token * T.S.pos) list, + buffer: (T.token * tkPos) list, macros: (bool * macro) H.t, @@ -24,52 +25,62 @@ struct type tkErrorVal = tkPos * string exception TkError of tkErrorVal - datatype expTk = - ExpTk of T.token | - ExpId | - ExpConst | - ExpUnop | - ExpBinop | - ExpOp + datatype tkClass = + Ctk of T.token | + Cid | + Cconst | + Cunop | + Cbinop | + Cop - type tkErrorExpVal = tkPos * expTk list - exception TkErrorExp of tkErrorExpVal + type tkClassErrorVal = tkPos * tkClass list + exception TkClassError of tkClassErrorVal fun raiseTkError msg pos = raise TkError (pos, msg) - fun raiseTkErrorSPos pos msg = raiseTkError msg (TkPos pos) + fun raiseTkErrorSPos pos msg = raiseTkError msg (TkPos (pos, [])) - fun tkErrorPrint (TkPos pos, msg) = - printf A1 T.S.pos2str pos `": " `msg `"\n" % + fun printLayers ((macroName, pos) :: layers) = ( + printf `"\t" `macroName `" " A1 T.S.pos2str pos %; + printLayers layers + ) + | printLayers [] = () - fun raiseTkErrorExp pos exp = raise TkErrorExp (pos, exp) - fun raiseTkErrorExpSPos pos exp = raiseTkErrorExp (TkPos pos) exp + fun tkErrorPrint (TkPos (pos, layers), msg) = ( + printf A1 T.S.pos2str pos `": " `msg `"\n" %; + printLayers layers + ) - fun tkErrorExpPrint (TkPos pos, exp) = + fun raiseTkClassError pos cls = raise TkClassError (pos, cls) + fun raiseTkClassErrorSPos pos cls = + raiseTkClassError (TkPos (pos, [])) cls + + fun tkClassErrorPrint (TkPos (pos, layers), cls) = let - val printEtk = fn - ExpTk tk => T.printToken tk - | 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; + 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" + + fun printClassList [] = raise Unreachable + | printClassList [ctk] = printCtk ctk + | printClassList [ctk1, ctk2] = ( + printCtk ctk1; output " or "; - printEtk etk2 + printCtk ctk2 ) - | printExpList (etk :: etks) = ( - printEtk etk; + | printClassList (ctk :: ctks) = ( + printCtk ctk; output ", "; - printExpList etks + printClassList ctks ) in printf A1 T.S.pos2str pos `": expected " %; - printExpList exp; - output "\n" + printClassList cls; + output "\n"; + printLayers layers end val updatePpc = fn z => @@ -181,7 +192,7 @@ struct in case tk of T.NewLine => (acc, stream) - | T.EOS => raiseTkErrorExpSPos pos [ExpTk T.NewLine] + | T.EOS => raiseTkClassErrorSPos pos [Ctk T.NewLine] | _ => getDefineMacroBody stream ((tk, pos) :: acc) end @@ -199,28 +210,94 @@ struct (ObjMacro body, stream) end - fun getSpecific stream expList = + fun getClass stream clList = 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) = + if belongsToClass tk cl then + () + else + checkClass tail + + val () = checkClass clList in - raise Unimplemented + (tk, pos, stream) + end + + fun validateArgs args = + let + fun validateArg (id, _) [] = id + | validateArg (id, pos) ((id', pos') :: tail) = + if id = id' then + raiseTkErrorSPos pos' "macro argument name is already taken" + else + validateArg (id, pos) tail + + fun validate [] = [] + | validate (arg :: args) = validateArg arg args :: validate args + + in + validate args end fun parseDefineMacroArgs stream = let datatype arg = Arg of string * T.S.pos | - LastArg of string * T.S.pos | - EmptyArg + LastArg of string * T.S.pos + + fun parseArg stream = + let + val (tkId, posId, stream) = getClass stream [Cid] + val (tk, _, stream) = getClass stream [Ctk T.RParen, Ctk T.Coma] + val id = case tkId of T.Id id => id | _ => raise Unreachable + in + case tk of + T.RParen => (LastArg (id, posId), stream) + | T.Coma => (Arg (id, posId), stream) + | _ => raise Unreachable + end + + fun parseArgs stream = + let + val (tk, _, stream) = T.getToken stream + + fun parse stream acc = + case parseArg stream of + (LastArg p, stream) => (rev (p :: acc), stream) + | (Arg p, stream) => parse stream (p :: acc) + in + if tk = T.RParen then + ([], stream) + else + let + val (args, stream) = parse stream [] + val args = validateArgs args + in + (args, stream) + end + end in - raise Unimplemented + parseArgs stream end fun parseDefineFuncMacro stream = let - val (_, _, stream) = T.getToken stream + val (args, stream) = parseDefineMacroArgs stream + val (body, stream) = getDefineMacroBody stream [] in - raise Unimplemented + printf `"func macro (" %; + List.app (fn arg => printf `arg `", " %) args; + printf `") \n" %; + (FuncMacro (args, body), stream) end fun parseDefine stream = @@ -231,7 +308,7 @@ struct in case tk of T.Id id => (id, pos, stream) - | _ => raiseTkErrorExpSPos pos [ExpId] + | _ => raiseTkClassErrorSPos pos [Cid] end val (macroName, pos, stream) = getName stream @@ -263,23 +340,25 @@ struct (T.CppDefine, handleDefine) ] - fun expandObjMacro (id, pos) body ppc = + fun expandObjMacro (id, TkPos (mPos, layers)) body ppc = let - 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]] + val mend = (T.MacroEnd id, if body = [] then mPos else (#2 o hd) body) + + fun formLayers (tk, pos) = (tk, TkPos (pos, (id, mPos) :: layers)) + + val revBody = List.map formLayers $ List.concat [[mend], body] in updatePpc ppc u#buffer (fn buf => List.revAppend (revBody, buf)) % end fun expandFuncMacro (_, _) (_, _) _ = + let + in raise Unimplemented + end 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 @@ -288,7 +367,7 @@ struct case H.lookup2 (#macros ppc) id checkAndMark (fn () => NONE) of - NONE => def () + NONE => (tk, pos, ppc) | SOME (ObjMacro body) => getToken $ expandObjMacro (id, pos) body ppc | SOME (FuncMacro (arg, body)) => @@ -300,9 +379,9 @@ struct (fn (_, body) => (SOME (false, body), ())) (fn () => raise Unreachable) in - def () + getToken ppc end - | _ => def () + | _ => (tk, pos, ppc) end and handleToken tk pos ppc = @@ -314,7 +393,7 @@ struct let val (pos, stream) = T.S.EOFpos stream in - (T.EOS, TkPos pos, updatePpc P s#streams [stream] %) + (T.EOS, TkPos (pos, []), updatePpc P s#streams [stream] %) end | getToken (P as { buffer = (tk, pos) :: tail, ... }: t) = handleToken tk pos (updatePpc P s#buffer tail %) @@ -323,58 +402,58 @@ struct val (tk, pos, head) = T.getToken head in if tk = T.EOS then - case tail of - [] => getToken $ updatePpc P s#EOSreached true % - | _ => getToken $ updatePpc P s#streams tail % + case tail of + [] => getToken $ updatePpc P s#EOSreached true % + | _ => getToken $ updatePpc P s#streams tail % else - handleToken tk pos $ updatePpc P s#streams (head :: tail) % + handleToken tk (TkPos (pos, [])) $ + updatePpc P s#streams (head :: tail) % end | getToken _ = raise Unreachable - fun debugPrint' ppc (shouldPrintLine, indent) (fname, line) = + fun debugPrint' ppc = let val (tk, pos, ppc) = getToken ppc - val TkPos (t as (T.S.Pos (fname', line', col))) = pos - fun repeat n s = String.concat (List.tabulate (n, fn _ => s)) - val Indent = fn z => bind A0 (fn () => repeat indent "\t") z + fun printTkPos (TkPos (pos, layers)) = + let + fun printLayer (macroName, pos) = + printf `macroName `" " A1 T.S.pos2str pos % - fun printLine () = printf `"\n" Indent `fname' `":" I line' `" \t" % + fun printLayers' [layer] = printLayer layer + | printLayers' (layer :: layers) = ( + printLayer layer; + output ", "; + printLayers' layers + ) + | printLayers' [] = raise Unreachable - fun finish pair = - if tk <> T.EOS then - debugPrint' ppc pair (fname', line') - else - () + fun printLayers [] = () + | printLayers layers = ( + output " ("; + printLayers' layers; + output ")" + ) + in + printf A1 T.S.pos2str pos %; + printLayers layers; + output ": " + end in - case tk of - 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) - ) + printTkPos pos; + T.printToken tk; + printf `"\n" %; + if tk = T.EOS then + () + else + debugPrint' ppc end fun debugPrint fname incDirs = let val ppc = create { fname, incDirs } in - debugPrint' ppc (true, 0) ("", 0); + debugPrint' ppc; output "\n" end end -- cgit v1.2.3