diff options
| -rw-r--r-- | ppc.fun | 147 | ||||
| -rw-r--r-- | tokenizer.fun | 1 | ||||
| -rw-r--r-- | tree.sig | 5 | ||||
| -rw-r--r-- | tree.sml | 20 |
4 files changed, 130 insertions, 43 deletions
@@ -16,7 +16,7 @@ struct type t = { buffer: layer list, - macros: (string, bool * macro) Tree.t, + macros: (string, bool * tkPos * macro) Tree.t, debugMode: bool, incDirs: string list @@ -45,7 +45,8 @@ struct val dummyEOSpos = pos2tkPos $ T.S.Pos ("<Unreachable>", 0, 0) fun raiseTkError pos msg = raise TkError (pos, msg) - (* fun raiseTkErrorSPos pos = raiseTkError (pos2tkPos pos) *) + 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 %; @@ -202,6 +203,8 @@ struct bind A1 PtkPos end z + fun warning pos g = printf `"\n" PtkPos pos `":warning: " g + val printMacroHeader = fn z => let fun printMacroHeader (out, (id, mLayers)) = @@ -494,9 +497,13 @@ struct let val ((macroName, pos), macro, ppc) = parseDefine ppc - val macros = insertMacro (#macros ppc) macroName (false, macro) - handle Tree.Exists => raiseTkError pos "macro redefinition" + val (prevVal, macros) = + insertMacro (#macros ppc) macroName (false, pos, macro) in + case prevVal of + SOME (_, pos', _) => warning pos + `"macro redefinition (see " PtkPos pos' `")" % + | NONE => (); updatePpc ppc s#macros macros % end @@ -530,6 +537,9 @@ struct bind A1 printBody end z + datatype collectCtx = + AfterIf | AfterIfdef | AfterIfndef | AfterElse | AfterElif + fun expandObjMacro (id, pos) body ppc = let val mend = (T.MacroEnd id, if body = [] then pos else (#2 o hd) body) @@ -672,37 +682,99 @@ struct insertRevBody (rev body) ppc end - and getIfRevBody ifPos cond (ppc: t) = + and collectRevBody ifPos acc ctx ppc = let - fun collect level f acc ppc = + fun collect level ppc acc = let val (tk, pos, ppc) = getTokenNoexpand ppc - fun def dx = collect (level + dx) f (f ((tk, pos), acc)) ppc + fun def dl = collect (level + dl) ppc ((tk, pos) :: acc) + + fun unexpected tk prevTk = + raiseTkErrorP pos + `"unexpected " T.Ptoken tk `" inside " T.Ptoken prevTk % + + fun handleIfdef ifTk = + if tk = T.PpcElif then + unexpected tk ifTk + else + (SOME (tk, pos), acc, ppc) + + fun handleElse () = + if level > 0 then + def 0 + else + case ctx of + AfterIf => (SOME (tk, pos), acc, ppc) + | AfterIfdef => handleIfdef T.PpcIfdef + | AfterIfndef => handleIfdef T.PpcIfndef + | AfterElse => unexpected tk T.PpcElse + | AfterElif => def 0 in case tk of - T.PpcEndif => + T.EOS => raiseTkError ifPos "unfinished conditional directive" + | T.PpcEndif => if level = 0 then - let - val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine] - in - (acc, ppc) - end + if ctx = AfterElif then + (NONE, (tk, pos) :: acc, ppc) + else + let + val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine] + in + (NONE, 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 + | T.PpcElse => handleElse () + | T.PpcElif => handleElse () + | T.PpcIf => def 1 + | T.PpcIfdef => def 1 + | T.PpcIfndef => def 1 + | _ => def 0 end + in + collect 0 ppc acc + end - val skip = collect 0 (fn (_, _) => []) [] - val collect = collect 0 (op ::) [] + and finishElse collect ppc = + let + val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine] + val (_, body, ppc) = collect [] AfterElse ppc in - (if cond then collect else skip) ppc + (body, ppc) + end + + and getIfdefRevBody ifTk ifPos cond ppc = + let + val collect = collectRevBody ifPos + val afterTk = if ifTk = T.PpcIfdef then AfterIfdef else AfterIfndef + + val (elseTk, ifTrue, ppc) = collect [] afterTk ppc + val (ifFalse, ppc) = + case elseTk of + SOME (T.PpcElse, _) => finishElse collect ppc + | NONE => ([], ppc) + | _ => raise Unreachable + in + (if cond then ifTrue else ifFalse, ppc) + end + + and getIfRevBody ifPos cond ppc = + let + val collect = collectRevBody ifPos + val (elseTk, ifTrue, ppc) = collect [] AfterIf ppc + val (ifFalse, ppc) = + case elseTk of + NONE => ([], ppc) + | SOME (T.PpcElse, _) => finishElse collect ppc + | SOME (T.PpcElif, pos) => + let + val (_, body, ppc) = collect [(T.PpcIf, pos)] AfterElif ppc + in + (body, ppc) + end + | _ => raise Unreachable + in + (if cond then ifTrue else ifFalse, ppc) end and ifdefEval pos ifPos ppc = @@ -738,29 +810,34 @@ struct | T.NewLine => ppc | _ => skip ppc end + val cond = true in - (true, skip ppc) + dprintf ppc `"\n" PtkPos ifPos `": #if -> " B cond `" (skipping)" %; + (cond, 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 (eval, getRevBody) = + case tk of + T.PpcIfdef => (ifdefEval true, getIfdefRevBody T.PpcIfdef) + | T.PpcIfndef => (ifdefEval false, getIfdefRevBody T.PpcIfndef) + | T.PpcIf => (ifEval, getIfRevBody) + | _ => raise Unreachable - val (revBody, ppc) = getIfRevBody ifPos cond ppc + 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 handleRegularToken tk pos ppc = let - fun checkAndMark (true, _) = (NONE, NONE) - | checkAndMark (false, macro) = (SOME (true, macro), SOME macro) + fun checkAndMark (true, _, _) = (NONE, NONE) + | checkAndMark (false, pos, macro) = + (SOME (true, pos, macro), SOME macro) fun getMacro tree id = macrosLookup tree id (checkAndMark, NONE) fun def () = (tk, pos, ppc) @@ -781,7 +858,7 @@ struct T.Id id => handleMacro id | T.MacroEnd id => let - val f = fn (_, macro) => (SOME (false, macro), ()) + val f = fn (_, pos, macro) => (SOME (false, pos, macro), ()) val ((), tree) = macrosLookup (#macros ppc) id (f, ()) in getToken $ updatePpc ppc s#macros tree % diff --git a/tokenizer.fun b/tokenizer.fun index 4bdc047..999aabf 100644 --- a/tokenizer.fun +++ b/tokenizer.fun @@ -282,6 +282,7 @@ struct case tk of Id s => Printf out `s % | MacroEnd macro => Printf out `"mend(" `macro `")" % + | NewLine => Printf out `"\\n" % | PpcInclude (dir, arg) => Printf out `"#include(" `dir `", " `arg `")" % | Num (IntConst (it, str, sfx)) => @@ -1,10 +1,11 @@ signature TREE = sig type ('k, 'v) t - exception Exists val empty: ('k, 'v) t - val insert: ('k -> 'k -> order) -> ('k, 'v) t -> 'k -> 'v -> ('k, 'v) t + val insert: ('k -> 'k -> order) -> ('k, 'v) t -> 'k -> 'v + -> 'v option * ('k, 'v) t + val lookup: ('k -> 'k -> order) -> ('k, 'v) t -> 'k -> 'v option val lookup2: ('k -> 'k -> order) -> ('k, 'v) t -> 'k -> ('v -> 'v option * 'a) * 'a -> 'a * ('k, 'v) t @@ -1,16 +1,24 @@ structure Tree: TREE = struct datatype ('k, 'v) t = Node of 'k * 'v * ('k, 'v) t * ('k, 'v) t | Empty - exception Exists - val empty = Empty - fun insert _ Empty k v = Node (k, v, Empty, Empty) + fun insert _ Empty k v = (NONE, Node (k, v, Empty, Empty)) | insert cmp (Node (k', v', left, right)) k v = case cmp k k' of - LESS => Node (k', v', insert cmp left k v, right) - | EQUAL => raise Exists - | GREATER => Node (k', v', left, insert cmp right k v) + LESS => + let + val (res, left) = insert cmp left k v + in + (res, Node (k', v', left, right)) + end + | EQUAL => (SOME v', Node (k, v, left, right)) + | GREATER => + let + val (res, right) = insert cmp right k v + in + (res, Node (k', v', left, right)) + end fun lookup _ Empty _ = NONE | lookup cmp (Node (k', v', left, right)) k = |