diff options
| -rw-r--r-- | common.sml | 26 | ||||
| -rw-r--r-- | parser.fun | 155 | ||||
| -rw-r--r-- | tokenizer.fun | 8 | ||||
| -rw-r--r-- | tree.sig | 1 | ||||
| -rw-r--r-- | tree.sml | 28 |
5 files changed, 132 insertions, 86 deletions
@@ -6,32 +6,6 @@ fun id x = x fun assert truth = if not truth then raise Unreachable else () -(* All global values which computations may raise an exception must be - * wrapped in lazy, so that no exception is thrown before custom - * top-level handler is set. - *) -fun lazy thunk = -let - datatype 'a value = - Unevaluated of unit -> 'a | - Evaluated of 'a | - Exn of exn - - val value = ref $ Unevaluated thunk -in - fn () => - case !value of - Unevaluated th => - let - val x = th () handle e => (value := Exn e; raise e) - in - value := Evaluated x; - x - end - | Evaluated v => v - | Exn e => raise e -end - structure Fold = struct fun fold (a, f) g = g (a, f) fun step0 h (a, f) = fold (h a, f) @@ -90,9 +90,10 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct ulong_t | longlong_t | ulonglong_t | + (* float_t | double_t | - + *) pointer_t of int * ctype | function_t of ctype * ctype list | array_t of Word64.word * ctype @@ -141,7 +142,10 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct StmtIf of exprAug * stmt * stmt option | StmtFor of exprAug option * exprAug option * exprAug option * stmt | StmtWhile of exprAug * stmt | - StmtDoWhile of stmt * exprAug + StmtDoWhile of stmt * exprAug | + StmtReturn of exprAug | + StmtBreak | + StmtContinue datatype parseBinopRes = BRbinop of exprPart | BRfinish of int @@ -178,7 +182,9 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct localVars: (int * P.tkPos * ctype) list, globalDecls: (int, P.tkPos * declClass * ctype * linkage) Tree.t, - tokenBuf: P.t * (token * P.tkPos) list list + tokenBuf: P.t * (token * P.tkPos) list list, + + loopLevel: int } val intCompare = fn a => fn b => Int.compare (a, b) @@ -187,12 +193,12 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct fun updateCtx (Ctx ctx) = fn z => let - fun from localScopes localVars globalDecls tokenBuf = - { localScopes, localVars, globalDecls, tokenBuf } - fun to f { localScopes, localVars, globalDecls, tokenBuf } = - f localScopes localVars globalDecls tokenBuf + fun from localScopes localVars globalDecls tokenBuf loopLevel = + { localScopes, localVars, globalDecls, tokenBuf, loopLevel } + fun to f { localScopes, localVars, globalDecls, tokenBuf, loopLevel } = + f localScopes localVars globalDecls tokenBuf loopLevel in - FRU.makeUpdate4 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f)) + FRU.makeUpdate5 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f)) end datatype declParts = @@ -260,8 +266,10 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct | ulong_t => & ("unsigned long", "L") | longlong_t => & ("long long", "w") | ulonglong_t => & ("unsigned long long", "W") + (* | float_t => & ("float", "f") | double_t => & ("double", "d") + *) | pointer_t (plevel, t) => if short then Printf out I plevel A2 pctype true t % @@ -323,8 +331,10 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct [T.kwSigned, T.kwLong, T.kwLong, T.kwInt]]), (ulonglong_t, [[T.kwUnsigned, T.kwLong, T.kwLong], [T.kwUnsigned, T.kwLong, T.kwLong, T.kwInt]]), + (* (float_t, [[T.kwFloat]]), (double_t, [[T.kwDouble]]) + *) ] fun genReprChildren l = @@ -523,8 +533,8 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct fun isArith t = case t of - float_t | double_t => true - | t => isIntegral t + (* float_t | double_t => true | *) + _ => isIntegral t fun isScalar t = case t of @@ -543,9 +553,21 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct localScopes = [], localVars = [], globalDecls = Tree.empty, - tokenBuf = (P.create { fname, incDirs, debugMode = false }, []) + tokenBuf = (P.create { fname, incDirs, debugMode = false }, []), + loopLevel = 0 } + fun loopWrapper ctx f = + let + val ctx = updateCtx ctx u#loopLevel (fn l => l + 1) % + val (r, ctx) = f ctx + val ctx = updateCtx ctx u#loopLevel (fn l => l - 1) % + in + (r, ctx) + end + + fun isInLoop (Ctx ctx) = #loopLevel ctx > 0 + fun getToken (ppc, []) = let fun first T.RParen = "'('" @@ -668,7 +690,7 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct | EmemberByP p => mem p "->" | EsizeofType ctype => Printf out `"sizeof(" Pctype ctype `")" % | EfuncCall (func, args) => - Printf out A1 pea func Plist pea args (", ", true) % + Printf out `"fcall " A1 pea func `", " Plist pea args (", ", false) % | Eternary (cond, ifB, elseB) => Printf out A1 pea cond `"?" A1 pea ifB `":" A1 pea elseB % | Ebinop(BinopTernaryIncomplete _, _, _) => raise Unreachable @@ -997,6 +1019,7 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct find 0 end + (* and parseFP pos s = let val lastC = String.sub (s, String.size s - 1) @@ -1018,9 +1041,12 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct | #"L" => P.error pos `"long double is not supported" % | _ => (double_t, Ndouble o handleStatus o parseDouble $ s) end + *) and parseNumber pos s = - (if isFPconst s then parseFP else parseInteger) pos s + (if isFPconst s then + P.error pos `"floating-point numbers are not implemented" % + else parseInteger) pos s and parsePrimaryExpr ctx = let @@ -1168,20 +1194,29 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct end end - and intRank t = + and typeRank t = case t of - char_t | uchar_t => 0 - | short_t | ushort_t => 1 - | int_t | uint_t => 2 - | long_t | ulong_t => 3 - | longlong_t | ulonglong_t => 4 - | _ => raise Unreachable + char_t => 0 + | uchar_t => 1 + | short_t => 2 + | ushort_t => 3 + | int_t => 4 + | uint_t => 5 + | long_t => 6 + | ulong_t => 7 + | longlong_t => 8 + | ulonglong_t => 9 + | void_t => 12 + | pointer_t _ => 13 + | array_t _ => 14 + | function_t _ => 15 + | unknown_t => raise Unreachable and convEA t (E as EA (_, pos, _, _)) = EA (Eunop (UnopCast, E), pos, false, t) and promoteToInt (E as EA (_, _, _, t)) = - if intRank t < 2 then + if typeRank t < typeRank int_t then convEA int_t E else E @@ -1679,6 +1714,7 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct val () = printf `(class2str class) `" decl " `(link2str linkage) `" " P.?id `": " Pctype t `"\n" % + val ((), tree) = lookup2 (#globalDecls ctx) id f in updateCtx (Ctx ctx) s#globalDecls tree % @@ -1828,16 +1864,47 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct collectDeclarators [] ctx end + fun skipExpected expectedTk ctx = + let + val (tk, pos, ctx) = getTokenCtx ctx + fun die () = P.clerror pos [P.Ctk expectedTk] + in + case tk of + Tk tk => + if tk = expectedTk then + ctx + else + die () + | _ => die () + end + + fun parseJmp (ctx, pos) stmt = + let + val () = + if not $ isInLoop ctx then + P.error pos `"loop jump outside of loop" % + else + () + val ctx' = skipExpected T.Semicolon ctx + in + (stmt, ctx') + end + fun parseStmt ctx = let - val (tk, _, ctx') = getTokenCtx ctx + val (tk, pos, ctx') = getTokenCtx ctx + val loopWrapper = loopWrapper ctx' + val parseJmp = parseJmp (ctx', pos) in case tk of TkBraces list => ctxWithLayer ctx' list (parseStmtCompound false) - | Tk T.kwIf => parseStmtIf ctx' - | Tk T.kwFor => parseStmtFor ctx' - | Tk T.kwWhile => parseStmtWhile ctx' - | Tk T.kwDo => parseStmtDoWhile ctx' + | Tk T.kwIf => parseIf ctx' + | Tk T.kwFor => loopWrapper parseFor + | Tk T.kwWhile => loopWrapper parseWhile + | Tk T.kwDo => loopWrapper parseDoWhile + | Tk T.kwBreak => parseJmp StmtBreak + | Tk T.kwContinue => parseJmp StmtContinue + | Tk T.kwReturn => parseReturn ctx' | _ => parseStmtExpr ctx end @@ -1850,6 +1917,16 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct | _ => P.clerror pos [P.Ctk T.LParen] end + and parseReturn ctx = + let + val ((status, ea), ctx) = parseExpr [T.Semicolon] ctx + in + if status = 0 then + P.clerror (#2 $ getTokenCtx ctx) [P.Ctk T.Semicolon] + else + (StmtReturn ea, ctx) + end + and parseExprFor last ctx = let val (tk, pos, ctx') = getTokenCtx ctx @@ -1877,7 +1954,7 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct | _ => P.clerror pos (if last then lastExp else notlastExp) end - and parseStmtFor ctx = + and parseFor ctx = let fun parseHeader ctx = let @@ -1903,7 +1980,7 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct (ea, ctx) end - and parseStmtIf ctx = + and parseIf ctx = let val (cond, ctx) = parseExprInParens ctx val (stmt, ctx) = parseStmt ctx @@ -1917,7 +1994,7 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct (StmtIf (cond, stmt, elseBody), ctx) end - and parseStmtWhile ctx = + and parseWhile ctx = let val (cond, ctx) = parseExprInParens ctx val (stmt, ctx) = parseStmt ctx @@ -1925,22 +2002,8 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct (StmtWhile (cond, stmt), ctx) end - and parseStmtDoWhile ctx = + and parseDoWhile ctx = let - fun skipExpected expectedTk ctx = - let - val (tk, pos, ctx) = getTokenCtx ctx - fun die () = P.clerror pos [P.Ctk expectedTk] - in - case tk of - Tk tk => - if tk = expectedTk then - ctx - else - die () - | _ => die () - end - val (stmt, ctx) = parseStmt ctx val ctx = skipExpected T.kwWhile ctx val (cond, ctx) = parseExprInParens ctx @@ -2036,6 +2099,10 @@ functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct | pstmt' off (StmtDoWhile (body, cond)) out = Printf out `"do " A2 pCompBody (off + 1) body `" " A1 pea cond `";" % + | pstmt' _ (StmtReturn ea) out = + Printf out `"return " A1 pea ea `";" % + | pstmt' _ StmtBreak out = Printf out `"break;" % + | pstmt' _ StmtContinue out = Printf out `"continue;" % and pCompBody off (S as (StmtCompound _)) out = Printf out A2 pstmt' (off - 1) S % diff --git a/tokenizer.fun b/tokenizer.fun index 14f4289..cce6bea 100644 --- a/tokenizer.fun +++ b/tokenizer.fun @@ -426,7 +426,7 @@ struct printf `"\n" % end - val fsmTable = lazy fsmTableCreate + val fsmTable = fsmTableCreate () fun fsmEat stream = let @@ -438,10 +438,10 @@ struct val (c, stream) = S.getchar stream in if c = #"\000" then - (#1 $ sub (#2 $ fsmTable (), curState), stream) + (#1 $ sub (#2 $ fsmTable, curState), stream) else let - val (tk, row) = sub (#2 $ fsmTable (), curState) + val (tk, row) = sub (#2 $ fsmTable, curState) val nextState = sub (row, ord c) in if nextState = ~1 then @@ -841,7 +841,7 @@ struct print line' stream end in - printTable symtab $ fsmTable (); + printTable symtab $ fsmTable; printf `"Tokenizing file: " `fname; print 0 stream; printf `"\n" % @@ -14,4 +14,5 @@ signature TREE = sig ('v option -> 'a * 'v option) -> 'a * ('k, 'v) t val print: ('k, 'v) t -> ('k -> string) -> ('v -> string) -> unit + val size: ('k, 'v) t -> int end @@ -71,24 +71,25 @@ structure Tree: TREE = struct Left of 'k * 'v * ('k, 'v) t | Right of 'k * 'v * ('k, 'v) t - fun assemble n buf = + fun assemble buf n = let - fun assemble' tree (Left (k, v, right) :: tail) = - assemble' (Node (k, v, tree, right)) tail - | assemble' tree (Right (k, v, left) :: tail) = - assemble' (Node (k, v, left, tree)) tail - | assemble' tree [] = tree + fun assemble' (Left (k, v, right) :: tail) tree = + assemble' tail (Node (k, v, tree, right)) + | assemble' (Right (k, v, left) :: tail) tree = + assemble' tail (Node (k, v, left, tree)) + | assemble' [] tree = tree in - assemble' n buf + assemble' buf n end - fun lookup' _ _ Empty k f = + fun lookup' buf _ Empty k f = let val (res, newV) = f NONE in - case newV of - NONE => (res, Empty) - | SOME v => (res, Node (k, v, Empty, Empty)) + (res, assemble buf + (case newV of + NONE => Empty + | SOME v => Node (k, v, Empty, Empty))) end | lookup' buf cmp (T as Node (k', v', left, right)) k f = case cmp k k' of @@ -100,7 +101,7 @@ structure Tree: TREE = struct in case newV of NONE => (res, T) - | SOME v => (res, assemble (Node (k', v, left, right)) buf) + | SOME v => (res, assemble buf (Node (k', v, left, right))) end fun lookup2 cmp t k f = lookup' [] cmp t k f @@ -120,4 +121,7 @@ structure Tree: TREE = struct in print' 0 t end + + fun size Empty = 0 + | size (Node(_, _, l, r)) = 1 + size l + size r end |