diff options
| -rw-r--r-- | common.sml | 38 | ||||
| -rw-r--r-- | driver.fun | 15 | ||||
| -rw-r--r-- | parser.fun | 177 | ||||
| -rw-r--r-- | parser.sig | 3 | ||||
| -rw-r--r-- | ppc.fun | 60 | ||||
| -rw-r--r-- | ppc.sig | 1 | ||||
| -rw-r--r-- | stream.sml | 10 | ||||
| -rw-r--r-- | tokenizer.fun | 6 |
8 files changed, 180 insertions, 130 deletions
@@ -37,6 +37,7 @@ structure Fold = struct fun step1 h (a, f) b = fold (h (b, a), f) fun step2 h (a, f) b c = fold (h (b, c, a), f) fun step3 h (a, f) b c d = fold (h (b, c, d, a), f) + fun step4 h (a, f) b c d e = fold (h (b, c, d, e, a), f) end structure FRU = struct @@ -127,6 +128,8 @@ in (output', mf) end +type 'a acc = (string -> unit) * 'a + local val ctx = ((false, makePrintfBase $ output TextIO.stdOut), fn (_: bool * ((string -> unit) * (unit -> unit))) => ()) @@ -154,22 +157,24 @@ in fun A0 z = Fold.step1 (fn (f, (ign, out)) => (ifF ign (fn () => f out); (ign, out))) z fun A1 z = Fold.step2 (fn (f, v, (ign, out)) => - (ifF ign (fn () => f (out, v)); (ign, out))) z + (ifF ign (fn () => f v out); (ign, out))) z fun A2 z = Fold.step3 (fn (f, v1, v2, (ign, out)) => - (ifF ign (fn () => f (out, v1, v2)); (ign, out))) z + (ifF ign (fn () => f v1 v2 out); (ign, out))) z + fun A3 z = Fold.step4 (fn (f, v1, v2, v3, (ign, out)) => + (ifF ign (fn () => f v1 v2 v3 out); (ign, out))) z end fun Ign z = Fold.step0 (fn (_, out) => (true, out)) z fun bind A f = fn z => Fold.fold z A f -fun bindWith2str to = bind A1 (fn ((output, _), v) => output $ to v) +fun bindWith2str to = bind A1 (fn v => fn (output, _) => output $ to v) fun F z = bind A0 (fn (_, mf) => mf ()) z val I = fn z => bindWith2str Int.toString z val C = fn z => bindWith2str str z val B = fn z => bindWith2str Bool.toString z -val R = fn z => bind A1 (fn ((output, _), n) => app (fn f => f ()) +val R = fn z => bind A1 (fn n => fn (output, _) => app (fn f => f ()) (List.tabulate (n, fn _ => fn () => output " "))) z type ('t, 'a, 'b, 'c) a1printer = (bool * ((string -> unit) * 'a)) * 'b @@ -179,15 +184,26 @@ type ('t1, 't2, 'a, 'b, 'c) a2printer = (bool * ((string -> unit) * 'a)) * 'b -> 't1 -> 't2 -> ((bool * ((string -> unit) * 'a)) * 'b -> 'c) -> 'c -val Popt = fn z => +fun popt 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 + +fun plist p l (s, parens) out = let - fun f (out, p, v) = - case v of - NONE => Printf out `"none" % - | SOME v => Printf out p v % + fun f [] _ = () + | f [e] out = Printf out A1 p e % + | f (e1 :: e2 :: tail) out = + (Printf out A1 p e1 %; Printf out `s A1 f (e2 :: tail) %) in - bind A2 f -end z + if parens andalso length l > 1 then + Printf out `"(" A1 f l `")" % + else + Printf out A1 f l % +end + +val Plist = fn z => bind A3 plist z fun die code g = let @@ -53,9 +53,20 @@ functor Driver(P: PARSER): DRIVER = struct Normal => let val parseCtx = P.createParseCtx file (#includeDirs config) - val (_, _) = P.parseDef parseCtx + + fun collect ctx = + let + val result = P.parseDef ctx + in + case result of + NONE => () + | SOME (def, ctx) => ( + P.printDef def; + collect ctx + ) + end in - raise Unimplemented + collect parseCtx end | DebugT => P.P.T.debugPrint file | DebugE => P.P.debugPrint file (#includeDirs config) @@ -100,7 +100,7 @@ functor Parser(P: PPC): PARSER = struct SpecStatic | SpecRegister - datatype stmt = StmtCompound of exprAug + datatype stmt = StmtCompound of exprAug list type declaredId = { id: int option, @@ -168,23 +168,18 @@ functor Parser(P: PPC): PARSER = struct (BrComma, T.Comma, 1, true) ] - val PstorSpec = fn z => - let - fun f (out, s) = - Printf out `( - case s of - SpecTypedef => "typedef" - | SpecExtern => "extern" - | SpecRegister => "register" - | SpecStatic => "static" - ) % - in - bind A1 f - end z + fun pStorSpec s out = + Printf out `( + case s of + SpecTypedef => "typedef" + | SpecExtern => "extern" + | SpecRegister => "register" + | SpecStatic => "static" + ) % val Pctype = fn z => let - fun Pctype (out, t) = + fun pctype t out = let fun &s = Printf out `s % in @@ -203,20 +198,13 @@ functor Parser(P: PPC): PARSER = struct | float_t => &"float" | double_t => &"double" | pointer_t (plevel, t) => - Printf out `"[" I plevel `"]" A1 Pctype t % - | function_t (ret, params) => - let - fun Pparams (_, []) = () - | Pparams (out, [p]) = Printf out A1 Pctype p % - | Pparams (out, (p1 :: p2 :: t)) = - Printf out A1 Pctype p1 `", " A1 Pparams (p2 :: t) % - in - Printf out `"(" A1 Pparams params `") -> " A1 Pctype ret % - end - | array_t el => Printf out `"() -> " A1 Pctype el % + Printf out `"{" I plevel `"} " A1 pctype t % + | function_t (ret, params) => Printf out + Plist pctype params (", ", true) `" -> " A1 pctype ret % + | array_t el => Printf out `"[] -> " A1 pctype el % end in - bind A1 Pctype + bind A1 pctype end z val typeSpecs = [ @@ -343,11 +331,11 @@ functor Parser(P: PPC): PARSER = struct SOME (repr, _) => repr | NONE => raise Unreachable - fun printRepr (out, l) = + fun printRepr l out = let - fun printRepr' (_, []) = () - | printRepr' (out, [tk]) = Printf out P.Ptk tk % - | printRepr' (out, tk1 :: tk2 :: tail) = + fun printRepr' [] _ = () + | printRepr' [tk] out = Printf out P.Ptk tk % + | printRepr' (tk1 :: tk2 :: tail) out = Printf out P.Ptk tk1 `", " A1 printRepr' (tk2 :: tail) % in Printf out `"[" A1 printRepr' l `"]" % @@ -441,20 +429,23 @@ functor Parser(P: PPC): PARSER = struct fun typeRepr2type typeReprId = valOf o #1 o Array.sub $ (prefixFsm, typeReprId) - fun PtokenL (_, []) = () - | PtokenL (out, head :: tail) = + fun pTokenL l out = + let + fun pToken (tk, _) out = let - fun printL list s e = - Printf out `s`"| " A1 PtokenL list `" |"`e `", " A1 PtokenL tail % - val (tk, _) = head + fun printList list opr cpr = Printf out `(opr ^ "| ") + Plist pToken list (",", false) `(" |" ^ cpr) % in case tk of - Tk tk => Printf out P.Ptk tk `"," A1 PtokenL tail % - | TkParens list => printL list "(" ")" - | TkBrackets list => printL list "[" "]" - | TkBraces list => printL list "{" "}" - | TkTernary list => printL list "?" ":" + Tk tk => Printf out P.Ptk tk % + | TkParens list => printList list "(" ")" + | TkBrackets list => printList list "[" "]" + | TkBraces list => printList list "{" "}" + | TkTernary list => printList list "?" ":" end + in + Printf out Plist pToken l (",", false) % + end type parseCtx = P.t * (token * P.tkPos) list list @@ -530,7 +521,7 @@ functor Parser(P: PPC): PARSER = struct (v, (fn (ppc, layers) => (ppc, tl layers)) ctx) end - fun Punop (out, unop) = + fun Punop unop out = let fun ~s = Printf out `s % in @@ -546,15 +537,15 @@ functor Parser(P: PPC): PARSER = struct | UnopCast ctype => Printf out Pctype ctype % end - and Pbinop (out, binop) = + and Pbinop binop out = case List.find (fn (binop', _, _, _) => binop' = binop) binopTable of SOME (_, tk, _, _) => Printf out P.Ptk tk % | NONE => raise Unreachable - and printExpr (out, off, ea) = + and printExpr off ea out = let - fun printExpr' (out, off, EAug (e, pos)) = + fun printExpr' off (EAug (e, pos)) out = let val P = fn z => let @@ -842,8 +833,10 @@ functor Parser(P: PPC): PARSER = struct if typeReprId = 0 then let val (_, pos, _) = getTokenCtx ctx + val ets = "expected type specifier" + val etss = "expected type or storage specifier" in - P.error pos `"expected type specifier" % + P.error pos `(if isSome storSpec then ets else etss) % end else ((storSpec, typeRepr2type typeReprId), ctx) @@ -860,7 +853,7 @@ functor Parser(P: PPC): PARSER = struct collect ctx (NONE, 0) end - and Ppart (out, part) = + and Ppart part out = case part of Pointer plevel => Printf out `"[" I plevel `"] " % | Id _ => Printf out `"id" % @@ -872,7 +865,6 @@ functor Parser(P: PPC): PARSER = struct isSome $ List.find (fn tk' => case tk of Tk tk => tk = tk' | _ => false) typeSpecs - and parseTypeName ctx = let val (prefix, ctx) = parseDeclPrefix ctx @@ -987,6 +979,15 @@ functor Parser(P: PPC): PARSER = struct parts, ctx) end + and checkParamUniqueness _ [] = () + | checkParamUniqueness acc ((SOME id, pos, _) :: ids) = ( + case List.find (fn id' => id' = id) acc of + SOME _ => P.error pos `"parameter redefinition" % + | NONE => checkParamUniqueness (id :: acc) ids + ) + | checkParamUniqueness acc ((NONE, _, _) :: ids) = + checkParamUniqueness acc ids + and assembleDeclarator (storSpec, ctype) parts = let val parts = rev parts @@ -1001,7 +1002,7 @@ functor Parser(P: PPC): PARSER = struct pointer_t (plevel, complete tail) | complete (FuncApp params :: tail) = let - (* TODO: check params uniqness *) + val () = checkParamUniqueness [] params val params = map (fn (_, _, ctype) => ctype) params in function_t (complete tail, params) @@ -1019,20 +1020,15 @@ functor Parser(P: PPC): PARSER = struct { id, pos, spec = storSpec, ctype = complete $ tl parts, params } end - fun printDeclId ({ id, spec, ctype, params, ... }: declaredId) = - let - fun Pstor (_, NONE) = () - | Pstor (out, SOME s) = Printf out PstorSpec s % - in - printf A1 Pstor spec Popt P.? id `": " Pctype ctype `"\n" %; + fun pDeclId ({ id, spec, ctype, params, ... }: declaredId) out = ( + Printf out Popt pStorSpec spec `" " Popt P.psid id `": " + Pctype ctype `"\n" %; + case params of NONE => () - | SOME params => ( - printf `"params: " %; - List.app (fn (id, _) => printf Popt P.?id `", " %) params; - printf `"\n" % - ) - end + | SOME params => Printf out + `"params: " Plist (popt P.psid) (map #1 params) (", ", false) `"\n" % + ) datatype declaration = DeclIds of declaredId list | @@ -1074,15 +1070,38 @@ functor Parser(P: PPC): PARSER = struct fun parseStmtCompound ctx = let - val (ea, ctx) = parseExpr ctx (SOME T.Semicolon) - val (_, _, ctx) = getTokenCtx ctx - val (tk, pos, ctx) = getTokenCtx ctx + fun collect 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 + end + + val (eas, ctx) = collect [] ctx in - case tk of - Tk T.EOS => (StmtCompound ea, ctx) - | _ => P.clerror pos [P.Ctk T.RBrace] + (StmtCompound eas, 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 parseFuncDefinition id ctx = let val (stmt, ctx) = parseStmtCompound ctx @@ -1090,14 +1109,26 @@ functor Parser(P: PPC): PARSER = struct (Definition (id, stmt), ctx) end + fun printDef (Definition (id, stmt)) = + printf `"Function: " A1 pDeclId id Pstmt 0 stmt % + | printDef (Declaration ids) = printf Plist pDeclId ids ("", false) % + fun parseDef ctx = let - val (toplev, ctx) = parseDeclaration ctx true + val (tk, _, _) = getTokenCtx ctx in - case toplev of - DeclIds ids => (Declaration ids, ctx) - | FuncDef (id, body) => - ctxWithLayer ctx body (fn ctx => - parseFuncDefinition id ctx) + case tk of + Tk T.EOS => NONE + | _ => + let + val (toplev, ctx) = parseDeclaration ctx true + in + SOME (case toplev of + DeclIds ids => (Declaration ids, ctx) + | FuncDef (id, body) => + ctxWithLayer ctx body (fn ctx => + parseFuncDefinition id ctx)) + end + end end @@ -6,5 +6,6 @@ signature PARSER = sig type def val createParseCtx: string -> string list -> parseCtx - val parseDef: parseCtx -> def * parseCtx + val parseDef: parseCtx -> (def * parseCtx) option + val printDef: def -> unit end @@ -6,16 +6,12 @@ struct val symtab = T.initSymtab () fun ?? id = T.ST.getStr symtab id - val ? = fn z => - let - fun f (out, id) = Printf out `(??id) % - in - bind A1 f - end z + fun psid id out = Printf out `(??id) % + val ? = fn z => bind A1 psid z val Ptk = fn z => let - fun f (out, tk) = Printf out T.Ptk symtab tk % + fun f tk out = Printf out T.Ptk symtab tk % in bind A1 f end z @@ -58,10 +54,10 @@ struct val PlayersU = fn z => let - fun PlayersU (out, ((macroName, pos) :: layers)) = + fun PlayersU ((macroName, pos) :: layers) out = Printf out F `"\tfrom " ?macroName `" at " T.S.Ppos pos `"\n" A1 PlayersU layers % - | PlayersU (_, []) = () + | PlayersU [] _ = () in bind A1 PlayersU end z @@ -78,7 +74,7 @@ struct fun clerror (TkPos (pos, layers)) cls = let - fun Pcl (out, cl) = + fun pcl cl out = case cl of Ctk tk => Printf out Ptk tk % | Cid => Printf out `"identifier" % @@ -87,14 +83,12 @@ struct | Cbinop => Printf out `"binary operator" % | Cop => Printf out `"operator" % - fun Pcls (_, []) = raise Unreachable - | Pcls (out, [cl]) = Printf out A1 Pcl cl % - | Pcls (out, [cl1, cl2]) = - Printf out A1 Pcl cl1 `" or " A1 Pcl cl2 % - | Pcls (out, cl :: cls) = - Printf out A1 Pcl cl `", " A1 Pcls cls % + fun pcls [] _ = raise Unreachable + | pcls [cl] out = Printf out A1 pcl cl % + | pcls [cl1, cl2] out = Printf out A1 pcl cl1 `" or " A1 pcl cl2 % + | pcls (cl :: cls) out = Printf out A1 pcl cl `", " A1 pcls cls % in - printf F T.S.Ppos pos `":error: expected " A1 Pcls cls `"\n" + printf F T.S.Ppos pos `":error: expected " A1 pcls cls `"\n" PlayersU layers; exit 1 end @@ -143,8 +137,8 @@ struct findPrefix' 0 s1 s2 end - fun PlayersCompact (_, _, []) = "" - | PlayersCompact (out, startPrx, L as (layer :: layers)) = + fun PlayersCompact _ [] _ = "" + | PlayersCompact startPrx (L as (layer :: layers)) out = let fun getFname (_, T.S.Pos (fname, _, _)) = fname @@ -166,18 +160,18 @@ struct val PtkPos = fn z => let - fun PtkPos (out, TkPos (p as T.S.Pos (fname, line, col), layers)) = + fun ptkPos (TkPos (p as T.S.Pos (fname, line, col), layers)) out = case layers of [] => Printf out T.S.Ppos p % | _ => let - val prefix = PlayersCompact (out, SOME fname, layers) + val prefix = PlayersCompact (SOME fname) layers out val fname = String.extract (fname, size prefix, NONE) in Printf out `"; @" T.S.Ppos (T.S.Pos (fname, line, col)) % end in - bind A1 PtkPos + bind A1 ptkPos end z val startCache = (0, [], ("", 0)) @@ -191,7 +185,7 @@ struct [] => Printf out `fname' `":" I line' `"| \t" % | _ => let - val prefix = PlayersCompact (out, SOME fname', layers') + val prefix = PlayersCompact (SOME fname') layers' out val fname' = String.extract (fname', size prefix, NONE) in Printf out `"; @" `fname' `":" I line' `"| \t" % @@ -207,9 +201,9 @@ struct val PmacroHeader = fn z => let - fun printMacroHeader (out, id, mLayers) = + fun printMacroHeader id mLayers out = let - fun Players (out, x, y) = ignore $ PlayersCompact (out, x, y) + fun Players x y out = ignore $ PlayersCompact x y out in Printf out F `"expanding (" A2 Players NONE (rev mLayers) `") macro " ?id % @@ -220,7 +214,7 @@ struct val PtokenL = fn z => let - fun printTokenL (out, offset, l) = + fun printTokenL offset l out = let fun printList _ [] = () | printList cache (tk :: tail) = @@ -413,7 +407,7 @@ struct tk = T.LParen andalso line1 = line2 andalso col1 + len = col2 end - fun PrintMacroBody (out, body) = + fun PrintMacroBody body out = if body = [] then () else ( @@ -575,7 +569,7 @@ struct val Pbody = fn z => let - fun printBody (out, msg, body) = ( + fun printBody msg body out = ( Printf out F `msg `" {"; Printf out PtokenL 1 body; Printf out `"}\n" % @@ -697,7 +691,7 @@ struct and printBinded z = let - fun printBinded (out, (msg, params)) = + fun printBinded msg params out = let fun print [] = () | print ((p, args) :: tail) = ( @@ -711,7 +705,7 @@ struct Printf out `"}\n" % end in - bind A1 printBinded + bind A2 printBinded end z and expandFuncMacro (id, mPos) (params, body) ppc = @@ -729,10 +723,10 @@ struct val (bindedParams, ppc) = parseFuncMacroArgs mPos params ppc val bp1 = apply addLayers2args bindedParams - val () = dprintf ppc printBinded ("args", bp1) % + val () = dprintf ppc printBinded "args" bp1 % val bp2 = apply (expandArgument ppc) bp1 - val () = dprintf ppc printBinded ("expanded args", bp2) % + val () = dprintf ppc printBinded "expanded args" bp2 % val body = setLayers (id, mPos) body val body = subst (id, mPos) bp2 body [] @@ -1003,7 +997,7 @@ struct | _ => (tk, pos, ppc) end - fun debugPrint' (out, cache, ppc) = + fun debugPrint' cache ppc out = let val (tk, pos, ppc) = getToken ppc val cache = printTokenCompact cache out (tk, pos) @@ -22,6 +22,7 @@ signature PPC = sig val debugPrint: string -> string list -> unit val ? : (int, 'a, 'b, 'c) a1printer + val psid: int -> 'a acc -> unit val Ptk: (T.token, 'a, 'b, 'c) a1printer val PtkPos: (tkPos, 'a, 'b, 'c) a1printer end @@ -28,13 +28,9 @@ structure Stream :> STREAM = struct end z - val Ppos = fn z => - let - fun p (out, Pos (fname, line, col)) = - Printf out `fname `":" I line `":" I col % - in - bind A1 p - end z + fun ppos (Pos (fname, line, col)) out = + Printf out `fname `":" I line `":" I col % + val Ppos = fn z => bind A1 ppos z fun getchar (S as { contents, off, ... }: t) = (String.sub (contents, off), updateStream S s#off (off + 1) %) diff --git a/tokenizer.fun b/tokenizer.fun index d6695d0..2adfd5c 100644 --- a/tokenizer.fun +++ b/tokenizer.fun @@ -265,11 +265,11 @@ struct symtab end - fun printToken (out, symtab, tk) = + fun ptk symtab tk out = let val ? = fn z => let - fun f (out, id) = Printf out `(ST.getStr symtab id) % + fun f id out = Printf out `(ST.getStr symtab id) % in bind A1 f end z @@ -296,7 +296,7 @@ struct | NONE => raise TokenWithoutRepr end - val Ptk = fn z => bind A2 printToken z + val Ptk = fn z => bind A2 ptk z fun isNondigit c = Char.isAlpha c orelse c = #"_" |