From 183a4420d2f2a985dd26d76e63c2cdcaafedc5ad Mon Sep 17 00:00:00 2001 From: Vladimir Azarov Date: Sun, 18 May 2025 12:07:58 +0200 Subject: Conditional inclusion --- ppc.fun | 576 +++++++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 349 insertions(+), 227 deletions(-) (limited to 'ppc.fun') diff --git a/ppc.fun b/ppc.fun index fcd0676..58ca66f 100644 --- a/ppc.fun +++ b/ppc.fun @@ -3,22 +3,21 @@ struct structure T = T - type layers = (string * T.S.pos) list - datatype tkPos = TkPos of T.S.pos * layers + type mLayers = (string * T.S.pos) list + datatype tkPos = TkPos of T.S.pos * mLayers - type macroBody = (T.token * T.S.pos) list + type macroBody = (T.token * tkPos) list datatype macro = ObjMacro of macroBody | FuncMacro of string list * macroBody - type t = { - streams: T.S.t list, + datatype layer = Stream of T.S.t | Tokens of (T.token * tkPos) list - buffer: (T.token * tkPos) list, + type t = { + buffer: layer list, macros: (string, bool * macro) Tree.t, - restricted: bool, debugMode: bool, incDirs: string list } @@ -45,8 +44,8 @@ struct val dummyEOSpos = pos2tkPos $ T.S.Pos ("", 0, 0) - fun raiseTkError msg pos = raise TkError (pos, msg) - fun raiseTkErrorSPos pos msg = raiseTkError msg $ pos2tkPos pos + fun raiseTkError pos msg = raise TkError (pos, msg) + (* fun raiseTkErrorSPos pos = raiseTkError (pos2tkPos pos) *) fun printLayers ((macroName, pos) :: layers) = ( printf `"\t" `macroName `" " T.S.Ppos pos %; @@ -60,7 +59,6 @@ struct ) fun raiseTkClassError pos cls = raise TkClassError (pos, cls) - fun raiseTkClassErrorSPos pos cls = raiseTkClassError (pos2tkPos pos) cls fun tkClassErrorPrint (TkPos (pos, layers), cls) = let @@ -93,18 +91,17 @@ struct val updatePpc = fn z => let - 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 + fun from buffer macros debugMode incDirs = + { buffer, macros, debugMode, incDirs } + fun to f { buffer, macros, debugMode, incDirs } = + f buffer macros debugMode incDirs in - FRU.makeUpdate6 (from, from, to) + FRU.makeUpdate4 (from, from, to) end z fun create { fname, incDirs, debugMode } = - { streams = [T.S.create fname], buffer = [], macros = Tree.empty, - restricted = false, debugMode, incDirs } + { buffer = [Stream $ T.S.create fname], macros = Tree.empty, debugMode, + incDirs } fun compareLayers cached macroLayers = let @@ -172,29 +169,43 @@ struct (offset2, layers', (fname', line')) end - val printMacroHeader = fn z => + val Players = fn z => let - fun printMacroHeader (out, (id, mLayers)) = + fun Players (out, layers) = 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 + 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 - Printf out `"\n" `"(" A1 Players layers `"): macro " `id % + printLayers layers end + in + bind A1 Players + end z + + val PtkPos = fn z => + let + fun PtkPos (out, TkPos (pos, layers)) = ( + if layers <> [] then + Printf out `"(" Players layers `") " % + else + (); + Printf out T.S.Ppos pos % + ) + in + bind A1 PtkPos + end z + + val printMacroHeader = fn z => + let + fun printMacroHeader (out, (id, mLayers)) = + Printf out `"\n" `"(" Players (rev mLayers) `"): macro " `id % in bind A1 printMacroHeader end z @@ -220,69 +231,66 @@ struct bind A1 printTokenL end z - datatype IncludeArg = - LocalInc of string * T.S.pos | - ExternalInc of string * T.S.pos + fun updateH head = fn s => Stream head :: tl s - fun parseIncludeArg stream = + fun getTokenNoexpand (P as { buffer = Tokens tks :: _, ... }: t) = ( + case tks of + (tk, pos) :: tail => + (tk, pos, updatePpc P u#buffer (fn buf => Tokens tail :: tl buf) %) + | [] => getTokenNoexpand $ updatePpc P u#buffer tl % + ) + | getTokenNoexpand (P as { buffer = Stream head :: _, ... }: t) = 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 (tk, pos, head) = T.getToken head + in + (tk, pos2tkPos pos, updatePpc P u#buffer (updateH head) %) + end + | getTokenNoexpand _ = raise Unreachable + + fun checkClass (tk, pos) clList raiseClassErr = + let + fun belongsToClass tk (Ctk tk') = tk = tk' + | belongsToClass (T.Id _) (Cid) = true + | belongsToClass _ Cid = false + | belongsToClass _ _ = raise Unreachable - 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 + fun checkClass' [] = raiseClassErr pos clList + | checkClass' (cl :: tail) = + if belongsToClass tk cl then + () + else + checkClass' tail 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 => + checkClass' clList + end + + fun getClassGeneric clList getToken raiseClassErr buf = let - val (pos, _) = T.S.EOFpos stream + val (tk, pos, buf) = getToken buf + val () = checkClass (tk, pos) clList raiseClassErr in - raiseTkErrorSPos pos "unexpected EOF during #include argument parsing" + (tk, pos, buf) end - fun findFile arg (stream, incDirs) = + fun getClassNoexpand (ppc: t) clList = + getClassGeneric clList getTokenNoexpand raiseTkClassError ppc + + datatype IncludeArg = LocalInc of string * string | ExternalInc of string + + fun findFile pos arg incDirs = case arg of - LocalInc (arg, pos) => ( + LocalInc (dir, arg) => ( 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" + OS.Path.Path => raiseTkError pos "invalid argument" + | Size => raiseTkError pos "resulting path is too long" | IO.Io v => raise IO.Io v ) - | ExternalInc (arg, pos) => + | ExternalInc arg => let fun try (dir :: tail) = ( let @@ -295,149 +303,157 @@ struct in case try incDirs of SOME pair => pair - | NONE => raiseTkErrorSPos pos "unable to find header" + | NONE => raiseTkError pos "unable to find header" end - fun handleInclude (P as { streams = head :: tail, incDirs, ... }: t) = + fun checkEndsWith pos arg c = let - val (arg, oldHead) = parseIncludeArg head - val (path, instream) = findFile arg (head, incDirs) - val head = T.S.createFromInstream path instream + fun find i = + if i = size arg then + raiseTkError pos "unfinished #include argument" + else if String.sub (arg, i) = c then + if i + 1 = size arg then + String.extract (arg, 1, SOME $ size arg - 2) + else + raiseTkError pos "some garbage after #include argument" + else + find (i + 1) in - updatePpc P s#streams (head :: oldHead :: tail) % + find 1 end - | handleInclude _ = raise Unreachable - fun getDefineMacroBody stream acc = + fun parseIncludeArg pos arg dir = let - val (tk, pos, stream) = T.getToken stream - in - case tk of - T.NewLine => (acc, stream) - | T.EOS => raiseTkClassErrorSPos pos [Ctk T.NewLine] - | _ => getDefineMacroBody stream ((tk, pos) :: acc) - end + fun eatSpaces s off = + if off = size s then + raiseTkError pos "invalid #include argument" + else if String.sub (s, off) = #" " then + eatSpaces s (off + 1) + else + String.extract (s, off, NONE) - fun isFuncMacroDefine nameLength (T.S.Pos (_, line1, col1)) stream = - let - val (tk, T.S.Pos (_, line2, col2), _) = T.getToken stream + val arg = eatSpaces arg 0 + val start = String.sub (arg, 0) + val check = checkEndsWith pos arg in - tk = T.LParen andalso line1 = line2 andalso col1 + nameLength = col2 + if start = #"<" then + LocalInc (dir, check #">") + else if start = #"\"" then + ExternalInc $ check #"\"" + else + raiseTkError pos "invalid #include argument" end - fun dBprintf debugMode = - if debugMode then + fun dprintf ppc = + if #debugMode ppc then printf else - printf Ign true - fun dprintf ppc = dBprintf (#debugMode ppc) + printf Ign - fun PrintMacroBody (out, body) = + fun handleInclude (T.PpcInclude (dir, arg), pos) ppc = let - val body = List.map (fn (tk, pos) => (tk, pos2tkPos pos)) body + val arg = parseIncludeArg pos arg dir + val (path, instream) = findFile pos arg (#incDirs ppc) + val () = dprintf ppc `"\n#include: " `path % + val stream = T.S.createFromInstream path instream in - Printf out `" {"; - Printf out printTokenL (0, [], body); - Printf out `"}" % + updatePpc ppc u#buffer (fn buf => Stream stream :: buf) % end + | handleInclude _ _ = raise Unreachable - fun parseDefineObjMacro debugMode stream = + fun getDefineMacroBody ppc acc = let - val (body, stream) = getDefineMacroBody stream [] + val (tk, pos, ppc) = getTokenNoexpand ppc in - dBprintf debugMode A1 PrintMacroBody body; - (ObjMacro body, stream) + case tk of + T.NewLine => (acc, ppc) + | T.EOS => raiseTkClassError pos [Ctk T.NewLine] + | _ => getDefineMacroBody ppc ((tk, pos) :: acc) end - fun checkClass (tk, pos) clList raiseClassErr = + fun isFuncMacroDefine len (TkPos (T.S.Pos (_, line1, col1), [])) ppc = let - fun belongsToClass tk (Ctk tk') = tk = tk' - | belongsToClass (T.Id _) (Cid) = true - | belongsToClass _ Cid = false - | belongsToClass _ _ = raise Unreachable - - fun checkClass' [] = raiseClassErr pos clList - | checkClass' (cl :: tail) = - if belongsToClass tk cl then - () - else - checkClass' tail + val (tk, TkPos (T.S.Pos (_, line2, col2), _), _) = getTokenNoexpand ppc in - checkClass' clList + tk = T.LParen andalso line1 = line2 andalso col1 + len = col2 end + | isFuncMacroDefine _ _ _ = raise Unreachable - fun getClassGeneric clList getToken raiseClassErr buf = + fun PrintMacroBody (out, body) = + if body = [] then + () + else ( + Printf out `" {"; + Printf out printTokenL (0, [], body); + Printf out `"}" % + ) + + fun parseDefineObjMacro ppc = let - val (tk, pos, buf) = getToken buf - val () = checkClass (tk, pos) clList raiseClassErr + val (body, ppc) = getDefineMacroBody ppc [] in - (tk, pos, buf) + dprintf ppc A1 PrintMacroBody body; + (ObjMacro body, ppc) end - fun getClassFromStream stream clList = - getClassGeneric clList T.getToken raiseTkClassErrorSPos stream - 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" + raiseTkError 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 = + fun parseDefineMacroArgs ppc = let - datatype arg = - Arg of string * T.S.pos | - LastArg of string * T.S.pos + datatype arg = Arg of string * tkPos | LastArg of string * tkPos - fun parseArg stream = + fun parseArg ppc = let - val (tkId, posId, stream) = getClassFromStream stream [Cid] - val (tk, _, stream) = getClassFromStream stream [Ctk T.RParen, Ctk T.Coma] + val (tkId, posId, ppc) = getClassNoexpand ppc [Cid] + val (tk, _, ppc) = getClassNoexpand ppc [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) + T.RParen => (LastArg (id, posId), ppc) + | T.Coma => (Arg (id, posId), ppc) | _ => raise Unreachable end - fun parseArgs stream = + fun parseArgs ppc = let - val (tk, _, stream) = T.getToken stream + val (tk, _, ppc) = getTokenNoexpand ppc - fun parse stream acc = - case parseArg stream of - (LastArg p, stream) => (rev (p :: acc), stream) - | (Arg p, stream) => parse stream (p :: acc) + fun parse ppc acc = + case parseArg ppc of + (LastArg p, ppc) => (rev (p :: acc), ppc) + | (Arg p, ppc) => parse ppc (p :: acc) in if tk = T.RParen then - ([], stream) + ([], ppc) else let - val (args, stream) = parse stream [] + val (args, ppc) = parse ppc [] val args = validateArgs args in - (args, stream) + (args, ppc) end end in - parseArgs stream + parseArgs ppc end - fun parseDefineFuncMacro debugMode stream = + fun parseDefineFuncMacro ppc = let - val (params, stream) = parseDefineMacroArgs stream - val (body, stream) = getDefineMacroBody stream [] + val (params, ppc) = parseDefineMacroArgs ppc + val (body, ppc) = getDefineMacroBody ppc [] fun printParams out = let @@ -450,58 +466,58 @@ struct Printf out `")" % end in - dBprintf debugMode A0 printParams; - dBprintf debugMode A1 PrintMacroBody body; - (FuncMacro (params, rev body), stream) + dprintf ppc A0 printParams; + dprintf ppc A1 PrintMacroBody body; + (FuncMacro (params, rev body), ppc) end - fun parseDefine stream debugMode = + fun parseDefine ppc = let - val (macroName, pos, stream) = getClassFromStream stream [Cid] + val (macroName, pos, ppc) = getClassNoexpand ppc [Cid] val macroName = case macroName of T.Id id => id | _ => raise Unreachable - val () = dBprintf debugMode `"\ndefine " `macroName % + val () = dprintf ppc `"\ndefine " `macroName % val parser = - if isFuncMacroDefine (size macroName) pos stream then + if isFuncMacroDefine (size macroName) pos ppc then parseDefineFuncMacro else parseDefineObjMacro - val (macro, stream) = parser debugMode stream + val (macro, ppc) = parser ppc in - ((macroName, pos), macro, stream) + ((macroName, pos), macro, ppc) end - fun updateH head = fn s => head :: tl s - - fun handleDefine (P as { streams = head :: _, ... }: t) = + fun handleDefine _ ppc = let - val ((macroName, pos), macro, head) = parseDefine head (#debugMode P) + val ((macroName, pos), macro, ppc) = parseDefine ppc - val macros = insertMacro (#macros P) macroName (false, macro) handle - Tree.Exists => raiseTkErrorSPos pos "macro redefinition" + val macros = insertMacro (#macros ppc) macroName (false, macro) + handle Tree.Exists => raiseTkError pos "macro redefinition" in - updatePpc P u#streams (updateH head) s#macros macros % + updatePpc ppc s#macros macros % end - | handleDefine _ = raise Unreachable - - val directiveTable = [ - (T.PpcInclude, handleInclude), - (T.PpcDefine, handleDefine) - ] fun addLayer (id, TkPos (pos, layers)) = (id, pos) :: layers - fun addLayers idPos body = + + fun setLayers idPos body = let - fun formLayers (tk, pos) = (tk, TkPos (pos, addLayer idPos)) + fun formLayers (tk, TkPos (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)) % + let + fun f (B as (Stream _ :: _)) = Tokens (rev body) :: B + | f (Tokens tks :: tail) = + Tokens (List.revAppend (body, tks)) :: tail + | f _ = raise Unreachable + in + updatePpc ppc u#buffer f % + end val printBody = fn z => let @@ -516,12 +532,10 @@ struct fun expandObjMacro (id, pos) body ppc = let - 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 mend = (T.MacroEnd id, if body = [] then pos else (#2 o hd) body) + val revBody = setLayers (id, pos) $ List.concat [[mend], body] val mLayers = addLayer (id, pos) - in dprintf ppc printMacroHeader (id, mLayers); dprintf ppc printBody (mLayers, "body", rev revBody); @@ -533,12 +547,23 @@ struct and parseFuncMacroArgs mPos params ppc = let + + fun getTokenRestricted ppc = + let + val (tk, pos, ppc) = getTokenNoexpand ppc + in + if T.isPpcDir tk then + raiseTkError pos "preprocessor directive inside macro arguments" + else + (tk, pos, ppc) + end + fun parseArg ppc acc = let - val (tk, pos, ppc) = getToken ppc (* TODO: should be restricted *) + val (tk, pos, ppc) = getTokenRestricted ppc in case tk of - T.EOS => raiseTkError "unfinished argument list" mPos + T.EOS => raiseTkError mPos "unfinished argument list" | T.Coma => (true, rev acc, ppc) | T.RParen => (false, rev acc, ppc) | _ => parseArg ppc ((tk, pos) :: acc) @@ -546,7 +571,7 @@ struct fun parseArgs ppc params acc = let - fun bind _ [] = raiseTkError "too many arguments" mPos + fun bind _ [] = raiseTkError mPos "too many arguments" | bind body (param :: params) = ((param, body), params) val (continue, arg, ppc) = parseArg ppc [] @@ -556,22 +581,21 @@ struct parseArgs ppc otherParams (bindedParam :: acc) else if length otherParams > 0 then - raiseTkError "not enough arguments" mPos + raiseTkError mPos "not enough arguments" else (rev (bindedParam :: acc), ppc) end - val ppc = updatePpc ppc s#restricted true % - val (_, _, ppc) = getClass ppc [Ctk T.LParen] + val (_, _, ppc) = getClassGeneric [Ctk T.LParen] + getTokenRestricted raiseTkClassError ppc val (res, ppc) = parseArgs ppc params [] - val ppc = updatePpc ppc s#restricted false % in (res, ppc) end and expandArgument ppc arg = let - val ppc = updatePpc ppc s#streams [] s#buffer arg % + val ppc = updatePpc ppc s#buffer [Tokens arg] % fun getAll ppc acc = let val (tk, pos, ppc) = getToken ppc @@ -641,20 +665,103 @@ struct val bp2 = apply (expandArgument ppc) bp1 val () = dprintf ppc printBinded (mLayers, "expanded args", bp2) % - val body = addLayers (id, mPos) body + val body = setLayers (id, mPos) body val body = subst bp2 body [] in dprintf ppc printBody (mLayers, "subst", body); insertRevBody (rev body) ppc end + and getIfRevBody ifPos cond (ppc: t) = + let + fun collect level f acc ppc = + let + val (tk, pos, ppc) = getTokenNoexpand ppc + fun def dx = collect (level + dx) f (f ((tk, pos), acc)) ppc + in + case tk of + T.PpcEndif => + if level = 0 then + let + val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine] + in + (acc, ppc) + end + else + def (~1) + | T.EOS => raiseTkError ifPos "unfinished conditional directive" + | _ => + if tk = T.PpcIf orelse tk = T.PpcIfdef + orelse tk = T.PpcIfndef + then + def 1 + else + def 0 + end + + val skip = collect 0 (fn (_, _) => []) [] + val collect = collect 0 (op ::) [] + in + (if cond then collect else skip) ppc + end + + and ifdefEval pos ifPos ppc = + let + fun isDefined id = + case Tree.lookup macroCompare (#macros ppc) id of + SOME _ => true + | _ => false + + val (macro, _, ppc) = getClassNoexpand ppc [Cid] + val id = case macro of T.Id id => id | _ => raise Unreachable + val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine] + + val defined = isDefined id + val (cond, form) = + if pos then + (defined, "ifdef") + else + (not defined, "ifndef") + in + dprintf ppc `"\n" PtkPos ifPos `": #" `form `" " `id `" -> " B cond %; + (cond, ppc) + end + + and ifEval ifPos ppc = + let + fun skip ppc = + let + val (tk, _, ppc) = getTokenNoexpand ppc + in + case tk of + T.EOS => raiseTkError ifPos "unfinished #if condition" + | T.NewLine => ppc + | _ => skip ppc + end + in + (true, skip ppc) + end + + and handleIf (tk, ifPos) ppc = + let + val dprintf = dprintf ppc `"\n" + val (cond, ppc) = + (case tk of + T.PpcIfdef => ifdefEval true + | T.PpcIfndef => ifdefEval false + | _ => ifEval) ifPos ppc + + val (revBody, ppc) = getIfRevBody ifPos cond ppc + in + dprintf `"{" printTokenL (1, [], rev revBody) `"}\n"; + insertRevBody revBody ppc + end + 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 = @@ -671,7 +778,7 @@ struct end in case tk of - T.Id id => if (#restricted ppc) then def () else handleMacro id + T.Id id => handleMacro id | T.MacroEnd id => let val f = fn (_, macro) => (SOME (false, macro), ()) @@ -682,40 +789,55 @@ struct | _ => def () end - and handleToken tk pos ppc = - let - fun checkMode () = - if (#restricted ppc) then - raiseTkError "directive in unexpected place" pos - else - ppc - in - case List.find (fn (tk', _) => tk' = tk) directiveTable of - SOME (_, f) => getToken o f $ checkMode () + and ppcFallback (_, pos) _ = + raiseTkError pos "directive is not implemented" + + and handleToken tk pos (ppc: t) = + let + fun %tk = fn tk' => tk' = tk + val directiveTable = [ + (fn T.PpcInclude _ => true | _ => false, handleInclude), + (%T.PpcDefine, handleDefine), + (%T.PpcIfdef, handleIf), + (%T.PpcIfndef, handleIf), + (%T.PpcUndef, ppcFallback), + (%T.PpcIf, handleIf), + (%T.PpcElse, ppcFallback), + (%T.PpcElif, ppcFallback), + (%T.PpcEndif, ppcFallback), + (%T.PpcWarning, ppcFallback), + (%T.PpcError, ppcFallback), + (%T.PpcPragma, ppcFallback) + ] + in + case List.find (fn (f, _) => f tk) directiveTable of + SOME (_, f) => getToken $ f (tk, pos) ppc | NONE => handleRegularToken tk pos ppc end - and getToken (P as { buffer = (tk, pos) :: tail, ... }: t) = - handleToken tk pos (updatePpc P s#buffer tail %) - | getToken (P as { streams = [], ... }: t) = (T.EOS, dummyEOSpos, P) - | getToken (P as { streams = head :: tail, restricted, ... }: t) = + and getToken (P as { buffer = Tokens tks :: _, ... }: t) = ( + case tks of + (tk, pos) :: tail => + handleToken tk pos + (updatePpc P u#buffer (fn b => Tokens tail :: tl b) %) + | [] => getToken $ updatePpc P u#buffer tl % + ) + | getToken (P as { buffer = [], ... }: t) = (T.EOS, dummyEOSpos, P) + | getToken (P as { buffer = Stream head :: tail, ... }: t) = let val (tk, pos, head) = T.getToken head in - if tk = T.EOS then - 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 + case (tk, tail) of + (T.EOS, []) => + let + val (pos, head) = T.S.EOFpos head + in + (T.EOS, pos2tkPos pos, updatePpc P s#buffer [Stream head] %) + end + | (T.EOS, tail) => getToken $ updatePpc P s#buffer tail % + | (_, _) => handleToken tk (pos2tkPos pos) $ - updatePpc P u#streams (updateH head) % + updatePpc P u#buffer (updateH head) % end fun debugPrint' cache ppc = -- cgit v1.2.3