diff options
| -rw-r--r-- | common.sml | 11 | ||||
| -rw-r--r-- | parser.fun | 380 | ||||
| -rw-r--r-- | ppc.fun | 20 | ||||
| -rw-r--r-- | ppc.sig | 4 |
4 files changed, 296 insertions, 119 deletions
@@ -184,11 +184,14 @@ type ('t1, 't2, 'a, 'b, 'c) a2printer = (bool * ((string -> unit) * 'a)) * 'b -> 't1 -> 't2 -> ((bool * ((string -> unit) * 'a)) * 'b -> 'c) -> 'c -fun popt p v out = +fun poptInternal addSpace none p v out = case v of - NONE => Printf out `"none" % - | SOME v => Printf out A1 p v % -val Popt = fn z => bind A2 popt z + NONE => Printf out `none % + | SOME v => Printf out A1 p v `(if addSpace then " " else "") % + +fun poptN z = poptInternal false z +val Popt = fn z => bind A2 (poptInternal false "") z +val PoptS = fn z => bind A2 (poptInternal true "") z fun plist p l (s, parens) out = let @@ -100,8 +100,6 @@ functor Parser(P: PPC): PARSER = struct SpecStatic | SpecRegister - datatype stmt = StmtCompound of exprAug list - type declaredId = { id: int option, pos: P.tkPos, @@ -110,9 +108,19 @@ functor Parser(P: PPC): PARSER = struct params: (int option * P.tkPos) list option } + datatype stmt = + StmtExpr of exprAug | + StmtCompound of declaredId list * stmt list | + StmtIf of exprAug * stmt * stmt option | + StmtFor of exprAug option * exprAug option * exprAug option * stmt | + StmtWhile of exprAug * stmt | + StmtDoWhile of stmt * exprAug + datatype def = Declaration of declaredId list | Definition of declaredId * stmt + datatype parseBinopRes = BRbinop of exprPart | BRfinish of bool + datatype token = Tk of T.token | TkParens of (token * P.tkPos) list | @@ -120,6 +128,8 @@ functor Parser(P: PPC): PARSER = struct TkBraces of (token * P.tkPos) list | TkTernary of (token * P.tkPos) list + type parseCtx = P.t * (token * P.tkPos) list list + datatype declParts = Pointer of int | Id of int * P.tkPos | @@ -447,8 +457,6 @@ functor Parser(P: PPC): PARSER = struct Printf out Plist pToken l (",", false) % end - type parseCtx = P.t * (token * P.tkPos) list list - fun createParseCtx fname incDirs = (P.create { fname, incDirs, debugMode = false }, []) @@ -543,58 +551,55 @@ functor Parser(P: PPC): PARSER = struct SOME (_, tk, _, _) => Printf out P.Ptk tk % | NONE => raise Unreachable - and printExpr off ea out = + and printExpr' off (EAug (e, pos)) out = let - fun printExpr' off (EAug (e, pos)) out = + val P = fn z => let - val P = fn z => - let - fun Ppos out = Printf out `"| " P.PtkPos pos % - in - bind A0 Ppos - end z - - fun member (member, ea) s = Printf out - `"(" `s P.?member P `"\n" A2 printExpr' (off + 1) ea `")" %; + fun Ppos out = Printf out `"| " P.PtkPos pos % in - printf R off %; - case e of - Eid id => Printf out P.?id P % - | Enum => Printf out `"num" P % - | Estrlit s => Printf out P.?s P % - | EmemberByV pair => member pair "." - | EmemberByP pair => member pair "->" - | EfuncCall (func, args) => ( - Printf out `"(fcall" P `"\n" A2 printExpr' (off + 1) func `"\n" %; - app (fn arg => - (Printf out A2 printExpr' (off + 1) arg `"\n" %)) args; - Printf out R off `")" % - ) - | Eunop (unop, ea) => Printf out - `"(" A1 Punop unop P `"\n" A2 printExpr' (off + 1) ea `")" % - | Ebinop (BR binop, left, right) => - let - val binop = - if binop = BrSubscript then - "[]" - else - sprintf A1 Pbinop binop % - in - Printf out `"(" `binop P `"\n" - A2 printExpr (off + 1) left - A2 printExpr' (off + 1) right `")" % - end - | Ebinop(BinopTernaryIncomplete _, _, _) => raise Unreachable - | ETernary (cond, trueBody, falseBody) => - Printf out `"(?:" P `"\n" - A2 printExpr (off + 1) cond - A2 printExpr (off + 1) trueBody - A2 printExpr' (off + 1) falseBody `")" % - end + bind A0 Ppos + end z + + fun member (member, ea) s = Printf out + `"(" `s P.?member P `"\n" A2 printExpr' (off + 1) ea `")" %; in - Printf out A2 printExpr' off ea `"\n" % + printf R off %; + case e of + Eid id => Printf out P.?id P % + | Enum => Printf out `"num" P % + | Estrlit s => Printf out P.?s P % + | EmemberByV pair => member pair "." + | EmemberByP pair => member pair "->" + | EfuncCall (func, args) => ( + Printf out `"(fcall" P `"\n" A2 printExpr' (off + 1) func `"\n" %; + app (fn arg => + (Printf out A2 printExpr' (off + 1) arg `"\n" %)) args; + Printf out R off `")" % + ) + | Eunop (unop, ea) => Printf out + `"(" A1 Punop unop P `"\n" A2 printExpr' (off + 1) ea `")" % + | Ebinop (BR binop, left, right) => + let + val binop = + if binop = BrSubscript then + "[]" + else + sprintf A1 Pbinop binop % + in + Printf out `"(" `binop P `"\n" + A2 printExpr (off + 1) left + A2 printExpr' (off + 1) right `")" % + end + | Ebinop(BinopTernaryIncomplete _, _, _) => raise Unreachable + | ETernary (cond, trueBody, falseBody) => + Printf out `"(?:" P `"\n" + A2 printExpr (off + 1) cond + A2 printExpr (off + 1) trueBody + A2 printExpr' (off + 1) falseBody `")" % end + and printExpr off ea out = Printf out A2 printExpr' off ea `"\n" % + and parseUnaryPrefix ctx acc = let val unopPreTable = [ @@ -635,19 +640,20 @@ functor Parser(P: PPC): PARSER = struct case tk of TkTernary list => let - val (ea, ctx) = ctxWithLayer ctx list - (fn ctx => parseExpr ctx NONE) + val ((_, ea), ctx) = ctxWithLayer ctx list (parseExpr NONE) in - SOME (EPbinop (BinopTernaryIncomplete ea, pos, + (BRbinop $ EPbinop (BinopTernaryIncomplete ea, pos, ternaryOpPrio, ternaryOpLeftAssoc), ctx) end | Tk tk => - if tk = T.EOS orelse (isSome endTk andalso tk = valOf endTk) then - NONE + if tk = T.EOS then + (BRfinish true, ctx) + else if isSome endTk andalso tk = valOf endTk then + (BRfinish false, ctx) else ( case List.find (fn (_, tk', _, _) => tk' = tk) binopTable of SOME (binop, _, prio, leftAssoc) => - SOME (EPbinop (BR binop, pos, prio, leftAssoc), ctx) + (BRbinop $ EPbinop (BR binop, pos, prio, leftAssoc), ctx) | NONE => P.clerror pos [P.Cbinop] ) | _ => P.clerror pos [P.Cbinop] @@ -657,12 +663,12 @@ functor Parser(P: PPC): PARSER = struct let fun collectArgs ctx acc = let - val (ea, ctx) = parseExpr ctx (SOME T.Comma) - val (tk, _, ctx) = getTokenCtx ctx + val ((eofReached, ea), ctx) = parseExpr (SOME T.Comma) ctx in - case tk of - Tk T.EOS => (rev $ ea :: acc, ctx) - | _ => collectArgs ctx (ea :: acc) + if eofReached then + (rev $ ea :: acc, ctx) + else + collectArgs ctx (ea :: acc) end val (args, ctx) = ctxWithLayer ctx list (fn ctx => collectArgs ctx []) in @@ -690,8 +696,8 @@ functor Parser(P: PPC): PARSER = struct | Tk T.Arrow => formMemberOp EmemberByP | TkBrackets list => let - val (ea, ctx) = - ctxWithLayer ctx1 list (fn ctx => parseExpr ctx NONE) + val ((_, ea), ctx) = + ctxWithLayer ctx1 list (parseExpr NONE) in (SOME $ EAug (Ebinop (BR BrSubscript, eAug, ea), pos1), ctx) end @@ -719,8 +725,12 @@ functor Parser(P: PPC): PARSER = struct | Tk (T.CharConst _) => raise Unimplemented | Tk (T.Num _) => wrap Enum | TkParens list => - ctxWithLayer ctx list (fn (ctx: parseCtx) => parseExpr ctx NONE) - | _ => P.clerror pos [P.Cid, P.Cconst] + let + val ((_, ea), ctx) = ctxWithLayer ctx list (parseExpr NONE) + in + (ea, ctx) + end + | _ => P.clerror pos [P.Cid, P.Cconst, P.Cstrlit] end and parseUnary ctx = @@ -779,7 +789,7 @@ functor Parser(P: PPC): PARSER = struct construct ([], []) parts end - and parseExpr ctx endTk = + and parseExpr endTk ctx = let fun collect ctx expVal acc = if expVal then @@ -790,13 +800,13 @@ functor Parser(P: PPC): PARSER = struct end else case parseBinop ctx endTk of - SOME (binop, ctx) => collect ctx (not expVal) (binop :: acc) - | NONE => (rev acc, ctx) + (BRbinop binop, ctx) => collect ctx (not expVal) (binop :: acc) + | (BRfinish eofReached, ctx) => (eofReached, rev acc, ctx) - val (parts, ctx) = collect ctx true [] + val (eofReached, parts, ctx) = collect ctx true [] val expr = constructExpr parts in - (expr, ctx) + ((eofReached, expr), ctx) end and tryGetSpec ctx = @@ -1020,14 +1030,14 @@ functor Parser(P: PPC): PARSER = struct { id, pos, spec = storSpec, ctype = complete $ tl parts, params } end - fun pDeclId ({ id, spec, ctype, params, ... }: declaredId) out = ( - Printf out Popt pStorSpec spec `" " Popt P.psid id `": " - Pctype ctype `"\n" %; + fun pDeclId off ({ id, spec, ctype, params, ... }: declaredId) out = ( + Printf out R off PoptS pStorSpec spec + Popt P.psid id `": " Pctype ctype `"\n" %; case params of NONE => () - | SOME params => Printf out - `"params: " Plist (popt P.psid) (map #1 params) (", ", false) `"\n" % + | SOME params => Printf out `"params: " + Plist (poptN "none" P.psid) (map #1 params) (", ", false) `"\n" % ) datatype declaration = @@ -1044,7 +1054,7 @@ functor Parser(P: PPC): PARSER = struct val declaredId = assembleDeclarator prefix parts val (tk, pos, ctx) = getTokenCtx ctx - fun first () = null acc + fun fdefPossible () = expectFdef andalso null acc fun die () = P.clerror pos [P.Ctk T.Comma, P.Ctk T.Semicolon] fun die2 () = P.clerror pos @@ -1053,54 +1063,207 @@ functor Parser(P: PPC): PARSER = struct case tk of Tk T.Comma => collectDeclarators (declaredId :: acc) ctx | Tk T.Semicolon => (DeclIds $ rev $ declaredId :: acc, ctx) - | TkBraces list => - if expectFdef andalso first () then - (FuncDef (declaredId, list), ctx) - else - die () | _ => - if first () then - die2 () - else - die () + if fdefPossible () then + case tk of + TkBraces list => (FuncDef (declaredId, list), ctx) + | _ => die2 () + else + die () end in collectDeclarators [] ctx end - fun parseStmtCompound ctx = + fun parseStmt ctx = + let + val (tk, _, ctx') = getTokenCtx ctx + in + case tk of + TkBraces list => + ctxWithLayer ctx' list (fn ctx => parseStmtCompound ctx) + | Tk T.kwIf => parseStmtIf ctx' + | Tk T.kwFor => parseStmtFor ctx' + | Tk T.kwWhile => parseStmtWhile ctx' + | Tk T.kwDo => parseStmtDoWhile ctx' + | _ => parseStmtExpr ctx + end + + and getParenInsides ctx = + let + val (tk, pos, ctx) = getTokenCtx ctx + in + case tk of + TkParens list => (list, ctx) + | _ => P.clerror pos [P.Ctk T.LParen] + end + + and parseExprFor last ctx = let - fun collect acc ctx = + val (tk, pos, ctx') = getTokenCtx ctx + + val notlastExp = [P.Ctk T.Semicolon, P.Cexpr] + val lastExp = [P.Ctk T.RParen, P.Cexpr] + in + case tk of + Tk tk => + if (last andalso tk = T.EOS) orelse + (not last andalso tk = T.Semicolon) + then + (NONE, ctx') + else + let + val ((eof, ea), ctx) = parseExpr (SOME T.Semicolon) ctx + in + if eof andalso not last then + P.clerror (#2 $ getTokenCtx ctx) [P.Ctk T.Semicolon] + else if not eof andalso last then + P.clerror (#2 $ getTokenCtx ctx) [P.Ctk T.RParen] + else + (SOME ea, ctx) + end + | _ => P.clerror pos (if last then lastExp else notlastExp) + end + + and parseStmtFor ctx = + let + fun parseHeader ctx = + let + val (pre, ctx) = parseExprFor false ctx + val (cord, ctx) = parseExprFor false ctx + val (post, ctx) = parseExprFor true ctx + in + ((pre, cord, post), ctx) + end + + val (list, ctx) = getParenInsides ctx + val ((pre, cord, post), ctx) = ctxWithLayer ctx list parseHeader + val (body, ctx) = parseStmt ctx + in + (StmtFor (pre, cord, post, body), ctx) + end + + and parseExprInParens ctx = + let + val (list, ctx) = getParenInsides ctx + val ((_, ea), ctx) = ctxWithLayer ctx list (parseExpr NONE) + in + (ea, ctx) + end + + and parseStmtIf ctx = + let + val (cond, ctx) = parseExprInParens ctx + val (stmt, ctx) = parseStmt ctx + + val (tk, _, ctx') = getTokenCtx ctx + val (elseBody, ctx) = + case tk of + Tk T.kwElse => (fn (a, b) => (SOME a, b)) $ parseStmt ctx' + | _ => (NONE, ctx) + in + (StmtIf (cond, stmt, elseBody), ctx) + end + + and parseStmtWhile ctx = + let + val (cond, ctx) = parseExprInParens ctx + val (stmt, ctx) = parseStmt ctx + in + (StmtWhile (cond, stmt), ctx) + end + + and parseStmtDoWhile ctx = + let + val (stmt, ctx) = parseStmt ctx + val (cond, ctx) = parseExprInParens ctx + in + (StmtDoWhile (stmt, cond), ctx) + end + + and parseStmtExpr ctx = + let + val ((eof, ea), ctx) = parseExpr (SOME T.Semicolon) ctx + in + if eof then + P.clerror (#2 $ getTokenCtx ctx) [P.Ctk T.Semicolon] + else + (StmtExpr ea, ctx) + end + + and parseStmtCompound ctx = + let + fun collectDecls acc ctx = + let + val (tk, _, _) = getTokenCtx ctx + in + if isTypeNameStart tk then + let + val (decl, ctx) = parseDeclaration ctx false + val declaredIds = + case decl of + DeclIds ids => ids + | _ => raise Unreachable + in + collectDecls (declaredIds :: acc) ctx + end + else + (List.concat $ rev acc, ctx) + end + + fun collectStmts acc ctx = let val (tk, _, _) = getTokenCtx ctx in case tk of Tk T.EOS => (rev acc, ctx) | _ => - let - val (ea, ctx) = parseExpr ctx (SOME T.Semicolon) - val (tk, pos, ctx) = getTokenCtx ctx - in - case tk of - Tk T.Semicolon => collect (ea :: acc) ctx - | _ => P.clerror pos [P.Ctk T.Semicolon] - end + let + val (stmt, ctx) = parseStmt ctx + in + collectStmts (stmt :: acc) ctx + end end - val (eas, ctx) = collect [] ctx + val (decls, ctx) = collectDecls [] ctx + val (stmts, ctx) = collectStmts [] ctx in - (StmtCompound eas, ctx) + (StmtCompound (decls, stmts), ctx) end - val Pstmt = fn z => - let - fun Pstmt off (StmtCompound eas) out = - Printf out R off `"{\n" - Plist (printExpr (off + 1)) eas ("", false) - R off `"}\n" % - in - bind A2 Pstmt - end z + fun pstmt off (StmtCompound (decls, stmts)) out = + Printf out R off `"{\n" + Plist (pDeclId (off + 1)) decls ("", false) + `(if null decls then "" else "\n") + Plist (pstmt (off + 1)) stmts ("\n", false) + R off `"}\n" % + + | pstmt off (StmtExpr ea) out = + Printf out A2 printExpr' off ea `";\n" % + + | pstmt off (StmtIf (cond, ifBody, elseBody)) out = ( + Printf out R off `"if\n" A2 printExpr (off + 1) cond + `"\n" A2 pstmt (off + 1) ifBody %; + case elseBody of + NONE => () + | SOME stmt => Printf out R off `"else\n" A2 pstmt (off + 1) stmt % + ) + | pstmt off (StmtFor (pre, cond, post, body)) out = + let + fun pe NONE out = Printf out R (off + 1) `"none\n" % + | pe (SOME expr) out = Printf out A2 printExpr (off + 1) expr % + in + Printf out R off `"for\n" A1 pe pre A1 pe cond A1 pe post + `"\n" A2 pstmt (off + 1) body % + end + | pstmt off (StmtWhile (cond, body)) out = + Printf out R off `"while\n" A2 printExpr (off + 1) cond + `"\n" A2 pstmt (off + 1) body % + | pstmt off (StmtDoWhile (body, cond)) out = + Printf out R off `"do\n" A2 pstmt (off + 1) body + `"\n" A2 printExpr (off + 1) cond % + + val Pstmt = fn z => bind A2 pstmt z fun parseFuncDefinition id ctx = let @@ -1110,8 +1273,9 @@ functor Parser(P: PPC): PARSER = struct end fun printDef (Definition (id, stmt)) = - printf `"Function: " A1 pDeclId id Pstmt 0 stmt % - | printDef (Declaration ids) = printf Plist pDeclId ids ("", false) % + printf `"Function: " A2 pDeclId 0 id Pstmt 0 stmt % + | printDef (Declaration ids) = + printf Plist (pDeclId 0) ids ("", false) % fun parseDef ctx = let @@ -42,9 +42,11 @@ struct Ctk of T.token | Cid | Cconst | + Cstrlit | Cunop | Cbinop | - Cop + Cop | + Cexpr fun pos2tkPos pos = TkPos (pos, []) fun tkPos2pos (TkPos (pos, [])) = pos @@ -75,13 +77,19 @@ struct fun clerror (TkPos (pos, layers)) cls = let fun pcl cl out = + let + fun p s = Printf out `s % + in case cl of Ctk tk => Printf out Ptk tk % - | Cid => Printf out `"identifier" % - | Cconst => Printf out `"constant" % - | Cunop => Printf out `"unary operator" % - | Cbinop => Printf out `"binary operator" % - | Cop => Printf out `"operator" % + | Cid => p "identifier" + | Cconst => p "constant" + | Cstrlit => p "string literal" + | Cunop => p "unary operator" + | Cbinop => p "binary operator" + | Cop => p "operator" + | Cexpr => p "expression" + end fun pcls [] _ = raise Unreachable | pcls [cl] out = Printf out A1 pcl cl % @@ -9,9 +9,11 @@ signature PPC = sig Ctk of T.token | Cid | Cconst | + Cstrlit | Cunop | Cbinop | - Cop + Cop | + Cexpr val clerror: tkPos -> tkClass list -> 'a val error: tkPos -> ((bool * ((string -> unit) * (unit -> unit))) |