diff options
Diffstat (limited to 'parser.fun')
| -rw-r--r-- | parser.fun | 883 |
1 files changed, 653 insertions, 230 deletions
@@ -1,4 +1,4 @@ -functor Parser(P: PPC): PARSER = struct +functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct structure P = P structure T = P.T @@ -13,7 +13,7 @@ functor Parser(P: PPC): PARSER = struct UnopComp | UnopLogNeg | UnopSizeof | - UnopCast of ctype | + UnopCast | UnopPostInc | UnopPostDec @@ -55,7 +55,7 @@ functor Parser(P: PPC): PARSER = struct BrComma and cnum = - Ninteger of ctype * Word64.word + Ninteger of Word64.word | Nfloat of Real32.real | Ndouble of Real64.real @@ -66,16 +66,17 @@ functor Parser(P: PPC): PARSER = struct EmemberByV of int * exprAug | EmemberByP of int * exprAug | EfuncCall of exprAug * exprAug list | - ETernary of exprAug * exprAug * exprAug | + Eternary of exprAug * exprAug * exprAug | EsizeofType of ctype | Eunop of unop * exprAug | Ebinop of binop * exprAug * exprAug - and exprAug = EAug of expr * P.tkPos + and exprAug = EA of expr * P.tkPos * ctype and binop = BR of binopReg | BinopTernaryIncomplete of exprAug and ctype = + unknown_t | void_t | char_t | uchar_t | @@ -101,10 +102,13 @@ functor Parser(P: PPC): PARSER = struct (* last two are prio and leftAssoc *) EPbinop of binop * P.tkPos * int * bool - type unopList = (unop * P.tkPos) list + type unopList = (unop * P.tkPos * ctype) list datatype exprPrefix = - NormalPrefix of unopList | SizeofType of unopList * ctype * P.tkPos + NormalPrefix of unopList | + SizeofType of unopList * ctype * P.tkPos * ctype + + datatype ini = IniExpr of exprAug | IniCompound of ini list datatype storageSpec = SpecTypedef | @@ -112,26 +116,38 @@ functor Parser(P: PPC): PARSER = struct SpecStatic | SpecRegister - type declaredId = { + type rawDecl = { id: int option, pos: P.tkPos, spec: storageSpec option, - ctype: ctype, - value: exprAug option, + t: ctype, + ini: ini option, params: (int option * P.tkPos) list option } + val updateRD = fn z => + let + fun from id pos spec t ini params = { id, pos, spec, t, ini, params } + fun to f { id, pos, spec, t, ini, params } = f id pos spec t ini params + in + FRU.makeUpdate6 (from, from, to) + end z + + type declaredId = { + id: int, + pos: P.tkPos, + ctype: ctype, + ini: ini option + } + datatype stmt = StmtExpr of exprAug | - StmtCompound of declaredId list * stmt list | + StmtCompound of (int * ini option) 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 int datatype token = @@ -141,7 +157,49 @@ 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 linkage = LinkInternal | LinkExternal + datatype declClass = DeclRegular | DeclTentative | DeclDefined + (* datatype id = Lid of int | Gid of int *) + + type objDef = int * P.tkPos * ctype * ini * linkage + + type funcInfo = { + name: int, + pos: P.tkPos, + t: ctype, + paramNum: int, + localVars: (int * P.tkPos * ctype) vector, + stmt: stmt + } + + datatype def = Objects of objDef list | Definition of funcInfo + + type nid = int + + type scope = (nid, int) Tree.t + + datatype ctx = Ctx of { + localScopes: scope list, + + localVars: (int * P.tkPos * ctype) list, + globalDecls: (int, P.tkPos * declClass * ctype * linkage) Tree.t, + + tokenBuf: P.t * (token * P.tkPos) list list + } + + val intCompare = fn a => fn b => Int.compare (a, b) + val lookup = fn z => Tree.lookup intCompare z + val lookup2 = fn z => Tree.lookup2 intCompare z + + 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 + in + FRU.makeUpdate4 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f)) + end datatype declParts = Pointer of int | @@ -191,44 +249,37 @@ functor Parser(P: PPC): PARSER = struct (BrComma, T.Comma, 1, true) ] - fun pStorSpec s out = - Printf out `( - case s of - SpecTypedef => "typedef" - | SpecExtern => "extern" - | SpecRegister => "register" - | SpecStatic => "static" - ) % - - val Pctype = fn z => + fun pctype short t out = let - fun pctype t out = - let - fun &s = Printf out `s % - in - case t of - void_t => &"void" - | char_t => &"char" - | uchar_t => &"unsigned char" - | short_t => &"short" - | ushort_t => &"usigned short" - | int_t => &"int" - | uint_t => &"unsigned int" - | long_t => &"long" - | ulong_t => &"unsigned long" - | longlong_t => &"long long" - | ulonglong_t => &"unsigned long long" - | float_t => &"float" - | double_t => &"double" - | pointer_t (plevel, t) => - 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 + fun &(f, s) = Printf out `(if short then s else f) % in - bind A1 pctype - end z + case t of + unknown_t => & ("unknown", "u") + | void_t => & ("void", "v") + | char_t => & ("char", "c") + | uchar_t => & ("unsigned char", "C") + | short_t => & ("short", "s") + | ushort_t => & ("usigned short", "S") + | int_t => & ("int", "i") + | uint_t => & ("unsigned int", "I") + | long_t => & ("long", "l") + | 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 % + else + Printf out `"{" I plevel `"} " A2 pctype false t % + | function_t (ret, params) => Printf out + Plist (pctype short) params (if short then "" else ", ", true) + `(if short then "" else " -> ") A2 pctype short ret % + | array_t el => Printf out `"[] " A2 pctype short el % + end + + val Pctype = fn z => bind A1 (pctype false) z val typeSpecs = [ T.kwVoid, @@ -470,10 +521,14 @@ functor Parser(P: PPC): PARSER = struct Printf out Plist pToken l (",", false) % end - fun createParseCtx fname incDirs = - (P.create { fname, incDirs, debugMode = false }, []) + fun createCtx fname incDirs = Ctx { + localScopes = [], + localVars = [], + globalDecls = Tree.empty, + tokenBuf = (P.create { fname, incDirs, debugMode = false }, []) + } - fun getTokenCtx (ppc, []) = + fun getToken (ppc, []) = let fun first T.RParen = "'('" | first T.RBracket = "'['" @@ -527,19 +582,29 @@ functor Parser(P: PPC): PARSER = struct (fn (tk, pos, ppc) => (tk, pos, (ppc, []))) $ collect ppc [layer] | NONE => (Tk tk, pos, (ppc, [])) end - | getTokenCtx (C as (_, [(Tk T.EOS, pos)] :: _)) = + | getToken (C as (_, [(Tk T.EOS, pos)] :: _)) = (Tk T.EOS, pos, C) - | getTokenCtx (_, [_] :: _) = raise Unreachable - | getTokenCtx (_, [] :: _) = raise Unreachable - | getTokenCtx (ppc, ((tk, pos) :: tail) :: layers) = + | getToken (_, [_] :: _) = raise Unreachable + | getToken (_, [] :: _) = raise Unreachable + | getToken (ppc, ((tk, pos) :: tail) :: layers) = (tk, pos, (ppc, tail :: layers)) - fun ctxWithLayer (ppc, layers) list cl = + fun getTokenCtx (C as Ctx { tokenBuf, ... }) = + let + val (tk, pos, tokenBuf) = getToken tokenBuf + in + (tk, pos, updateCtx C s#tokenBuf tokenBuf %) + end + + fun isGlobalScope (Ctx { localScopes, ... }) = null localScopes + + fun ctxWithLayer (C as Ctx { tokenBuf = (ppc, layers), ... }) list cl = let - val ctx = (ppc, list :: layers) + val ctx = updateCtx C s#tokenBuf (ppc, list :: layers) % val (v, ctx) = cl ctx + val restore = fn (ppc, layers) => (ppc, tl layers) in - (v, (fn (ppc, layers) => (ppc, tl layers)) ctx) + (v, updateCtx ctx u#tokenBuf restore %) end fun Punop unop out = @@ -556,7 +621,7 @@ functor Parser(P: PPC): PARSER = struct | UnopDeref => ~"*" | UnopComp => ~"~" | UnopLogNeg => ~"!" - | UnopCast ctype => Printf out Pctype ctype % + | UnopCast => raise Unreachable end and Pbinop binop out = @@ -565,60 +630,51 @@ functor Parser(P: PPC): PARSER = struct SOME (_, tk, _, _) => Printf out P.Ptk tk % | NONE => raise Unreachable - and printExpr' off (EAug (e, pos)) out = + and pexpr e out = 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 mem (id, ea) s = Printf out A1 pea ea `s P.? id % in - printf R off %; case e of - Eid id => Printf out P.?id P % + Eid id => Printf out P.? id % | Econst (id, n) => ( case n of - Ninteger (t, _) => Printf out P.?id `":" Pctype t `" " P % - | Nfloat _ => Printf out P.?id `":float" P % - | Ndouble _ => Printf out P.?id `":double" P % + Ninteger _ => Printf out P.? id % + | Nfloat _ => Printf out P.? id `":float" % + | Ndouble _ => Printf out P.? id `":double" % ) - | 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" - Plist (printExpr' (off + 1)) args ("\n", false) - R off `")" % - ) - | EsizeofType ctype => - Printf out `"(sizeof " P `"\n" R (off + 1) Pctype ctype `")" % - | 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 + | Estrlit id => Printf out P.? id % + | EmemberByV p => mem p "." + | EmemberByP p => mem p "->" + | EsizeofType ctype => Printf out `"sizeof(" Pctype ctype `")" % + | EfuncCall (func, args) => + Printf out A1 pea func Plist pea args (", ", true) % + | Eternary (cond, ifB, elseB) => + Printf out A1 pea cond `"?" A1 pea ifB `":" A1 pea elseB % | 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 `")" % + | Ebinop(BR binop, left, right) => + let + val binop = + if binop = BrSubscript then "[]" else sprintf A1 Pbinop binop % + in + Printf out A1 pea left `" " `binop `" " A1 pea right % + end + | Eunop (UnopCast, _) => raise Unreachable + | Eunop (unop, ea) => Printf out A1 Punop unop `" " A1 pea ea % end - and printExpr off ea out = Printf out A2 printExpr' off ea `"\n" % + and pea (EA (e, _, t)) out = + let + fun pType out = Printf out A2 pctype true t % + fun exprPrinter e out = + case e of + Eid _ | Econst _ | Estrlit _ => + Printf out A1 pexpr e `":" A0 pType % + | Eunop (UnopCast, ea) => + Printf out A1 pea ea `"@" A0 pType % + | _ => Printf out `"(" A1 pexpr e `"):" A0 pType % + in + Printf out A1 exprPrinter e % + end and isTypeInParens tk ctx = case tk of @@ -651,28 +707,37 @@ functor Parser(P: PPC): PARSER = struct case tk of Tk tk => ( case List.find (fn (tk', _) => tk' = tk) unopPreTable of - SOME (_, unop) => parseUnaryPrefix ctx' ((unop, pos) :: acc) + SOME (_, unop) => + parseUnaryPrefix ctx' ((unop, pos, unknown_t) :: acc) | _ => (NormalPrefix acc, ctx) ) | _ => ( case isTypeInParens tk ctx' of SOME (ctype, ctx) => if #1 (hd acc) = UnopSizeof handle Empty => false then - (SizeofType (tl acc, ctype, #2 $ hd acc), ctx) + (SizeofType (tl acc, ctype, #2 $ hd acc, ulong_t), ctx) else - parseUnaryPrefix ctx ((UnopCast ctype, pos) :: acc) + parseUnaryPrefix ctx ((UnopCast, pos, ctype) :: acc) | NONE => (NormalPrefix acc, ctx) ) end - and parseBinop ctx endTks = + and oneOfEndTks tk terms = let - val (tk, pos, ctx) = getTokenCtx ctx - fun oneOfEndTks _ _ [] = 0 - | oneOfEndTks tk idx (tk' :: tks) = - if tk = tk' then idx else oneOfEndTks tk (idx + 1) tks + fun f idx tk (tk' :: tks) = + if tk = tk' then idx else f (idx + 1) tk tks + | f _ _ [] = 0 in case tk of + Tk tk => f 1 tk terms + | _ => 0 + end + + and parseBinop ctx endTks = + let + val (tk', pos, ctx) = getTokenCtx ctx + in + case tk' of TkTernary list => let val ((_, ea), ctx) = ctxWithLayer ctx list (parseExpr []) @@ -685,7 +750,7 @@ functor Parser(P: PPC): PARSER = struct (BRfinish 0, ctx) else let - val status = oneOfEndTks tk 1 endTks + val status = oneOfEndTks tk' endTks in if status > 0 then (BRfinish status, ctx) @@ -698,33 +763,35 @@ functor Parser(P: PPC): PARSER = struct | _ => P.clerror pos [P.Cbinop] end - and parseFuncCall ctx funcEa list pos = + and parseFuncCall funcEa pos ctx = let - fun collectArgs ctx acc = + fun collectArgs acc ctx = let val ((status, ea), ctx) = parseExpr [T.Comma] ctx in if status = 0 then (rev $ ea :: acc, ctx) else - collectArgs ctx (ea :: acc) + collectArgs (ea :: acc) ctx end - val (args, ctx) = ctxWithLayer ctx list (fn ctx => collectArgs ctx []) + val (args, ctx) = collectArgs [] ctx in - (SOME $ EAug (EfuncCall (funcEa, args), pos), ctx) + (SOME $ EA (EfuncCall (funcEa, args), pos, unknown_t), ctx) end and parseExprSuffix1 eAug ctx = let val (tk, pos1, ctx1) = getTokenCtx ctx - fun formUnop1 unop = (SOME (EAug (Eunop (unop, eAug), pos1)), ctx1) + fun formUnop1 unop = + (SOME $ EA (Eunop (unop, eAug), pos1, unknown_t), ctx1) fun formMemberOp unop = let val (tk, pos2, ctx2) = getTokenCtx ctx1 in case tk of - Tk (T.Id id) => (SOME (EAug (unop (id, eAug), pos1)), ctx2) + Tk (T.Id id) => + (SOME $ EA (unop (id, eAug), pos1, unknown_t), ctx2) | _ => P.clerror pos2 [P.Cid] end in @@ -737,10 +804,11 @@ functor Parser(P: PPC): PARSER = struct let val ((_, ea), ctx) = ctxWithLayer ctx1 list (parseExpr []) + val ea = EA (Ebinop (BR BrSubscript, eAug, ea), pos1, unknown_t) in - (SOME $ EAug (Ebinop (BR BrSubscript, eAug, ea), pos1), ctx) + (SOME ea, ctx) end - | TkParens list => parseFuncCall ctx1 eAug list pos1 + | TkParens list => ctxWithLayer ctx1 list (parseFuncCall eAug pos1) | _ => (NONE, ctx) end @@ -885,9 +953,9 @@ functor Parser(P: PPC): PARSER = struct let val (num, suffix) = getSuffix pos s val (acc, isDec) = collectNum pos num - val p = determiteIntNumType isDec (acc, suffix) + val (t, v) = determiteIntNumType isDec (acc, suffix) in - Ninteger p + (t, Ninteger v) end and isFPconst s = @@ -924,10 +992,10 @@ functor Parser(P: PPC): PARSER = struct let val repr = String.substring (s, 0, String.size s - 1) in - Nfloat o handleStatus o parseFloat $ repr + (float_t, Nfloat o handleStatus o parseFloat $ repr) end | #"L" => P.error pos `"long double is not supported" % - | _ => Ndouble o handleStatus o parseDouble $ s + | _ => (double_t, Ndouble o handleStatus o parseDouble $ s) end and parseNumber pos s = @@ -936,14 +1004,14 @@ functor Parser(P: PPC): PARSER = struct and parsePrimaryExpr ctx = let val (tk, pos, ctx) = getTokenCtx ctx - fun wrap e = (EAug (e, pos), ctx) + fun wrap e = (EA (e, pos, unknown_t), ctx) + fun wrapNum id (t, v) = (EA (Econst (id, v), pos, t), ctx) in case tk of Tk (T.Id id) => wrap $ Eid id | Tk (T.Strlit id) => wrap $ Estrlit id - | Tk (T.CharConst (id, v)) => - wrap $ Econst (id, Ninteger (int_t, Word64.fromInt v)) - | Tk (T.Num id) => wrap $ Econst (id, parseNumber pos $ P.?? id) + | Tk (T.CharConst (id, v)) => wrapNum id (int_t, Ninteger v) + | Tk (T.Num id) => wrapNum id $ parseNumber pos $ P.?? id | TkParens list => let val ((_, ea), ctx) = ctxWithLayer ctx list (parseExpr []) @@ -957,8 +1025,8 @@ functor Parser(P: PPC): PARSER = struct let val (prefix, ctx) = parseUnaryPrefix ctx [] fun applyPrefix prefix ea = - List.foldl (fn ((unop, pos), e) => - EAug (Eunop (unop, e), pos)) ea prefix + List.foldl (fn ((unop, pos, t), e) => + EA (Eunop (unop, e), pos, t)) ea prefix in case prefix of NormalPrefix unopList => @@ -968,8 +1036,8 @@ functor Parser(P: PPC): PARSER = struct in (applyPrefix unopList ea, ctx) end - | SizeofType (unopList, ctype, pos) => - (applyPrefix unopList (EAug (EsizeofType ctype, pos)), ctx) + | SizeofType (unopList, ctype, pos, resType) => + (applyPrefix unopList (EA (EsizeofType ctype, pos, resType)), ctx) end and constructExpr parts = @@ -988,13 +1056,13 @@ functor Parser(P: PPC): PARSER = struct val (right, left, vstack) = take2 vstack val (binop, pos, _) = hd opstack - val head = EAug ( + val head = case binop of BR binop => Ebinop (BR binop, left, right) | BinopTernaryIncomplete trueBody => - ETernary(left, trueBody, right), pos) + Eternary(left, trueBody, right) in - (head :: vstack, tl opstack) + (EA (head, pos, unknown_t) :: vstack, tl opstack) end fun insert (Q as (binop, pos, p, _)) (vstack, opstack) = @@ -1108,9 +1176,16 @@ functor Parser(P: PPC): PARSER = struct val (parts, ctx) = parseDeclarator (true, APenforced) [] ctx val declId = assembleDeclarator prefix parts in - (#ctype declId, ctx) + (#t declId, ctx) end + and checkParamStorSpec ({ spec = spec, pos, ... }: rawDecl) = + case spec of + SOME SpecRegister => + P.warning pos `"declaration with register storage specifier" % + | SOME _ => P.error pos `"parameter with invalid storage specifier" % + | _ => () + and parseFuncParams ctx = let fun collect ctx acc = @@ -1119,6 +1194,7 @@ functor Parser(P: PPC): PARSER = struct val (parts, ctx) = parseDeclarator (false, APpermitted) [] ctx val declaredId = assembleDeclarator prefix parts + val () = checkParamStorSpec declaredId val (tk, pos, ctx) = getTokenCtx ctx in case tk of @@ -1138,7 +1214,7 @@ functor Parser(P: PPC): PARSER = struct val (params, ctx) = collect2 () val params = - map (fn { id, pos, ctype, ... } => (id, pos, ctype)) params + map (fn { id, pos, t, ... } => (id, pos, t)) params in (FuncApp params, ctx) end @@ -1180,7 +1256,7 @@ functor Parser(P: PPC): PARSER = struct else (Id (id, pos) :: parts, ctx') | TkParens list => ctxWithLayer ctx' list - (fn ctx => parseDeclarator (true, absPolicy) parts ctx) + (parseDeclarator (true, absPolicy) parts) | _ => ( case absPolicy of APprohibited => P.clerror pos [P.Cid, P.Ctk T.LParen] @@ -1254,75 +1330,310 @@ functor Parser(P: PPC): PARSER = struct | _ => NONE in - { id, pos, spec = storSpec, ctype = complete $ tl parts, - value = NONE, params } + { id, pos, spec = storSpec, t = complete $ tl parts, + ini = NONE, params } + end + + fun printIni (IniExpr ea) out = Printf out A1 pea ea % + | printIni (IniCompound inis) out = Printf out + `"{" Plist (printIni) inis (", ", false) `"}" % + + fun pDeclId off ({ id, ctype, ini, pos = _}: declaredId) out = + Printf out R off + P.?id `": " Pctype ctype + Popt (fn ini => fn out => + Printf out `" = " A1 printIni ini %) ini `"\n" % + + fun dieExpTerms pos terms = P.clerror pos $ map P.Ctk terms + + fun parseCompoundInitializer ctx = + let + fun collect ctx acc = + let + val (status, ini, ctx) = parseInitializer [T.Comma] ctx + in + if status = 0 then + (rev $ ini :: acc, ctx) + else + collect ctx (ini :: acc) + end + + val (inis, ctx) = collect ctx [] + in + (IniCompound inis, ctx) + end + + and parseInitializer terms ctx = + let + val (tk, _, ctx') = getTokenCtx ctx + in + case tk of + TkBraces list => + let + val (ini, ctx) = ctxWithLayer ctx' list parseCompoundInitializer + val (tk, pos, ctx) = getTokenCtx ctx + val status = oneOfEndTks tk terms + in + if status = 0 then + dieExpTerms pos terms + else + (status, ini, ctx) + end + | _ => + let + val ((status, ea), ctx) = parseExpr terms ctx + fun isToplev [_, _] = true + | isToplev _ = false + in + if status = 0 andalso isToplev terms then + dieExpTerms (#2 $ getTokenCtx ctx) terms + else + (status, IniExpr ea, ctx) + end + end + + fun tryParseInitializer ctx rawId = + let + val (status, ini, ctx) = parseInitializer [T.Comma, T.Semicolon] ctx + in + (status, updateRD rawId s#ini (SOME ini) %, ctx) end - fun pDeclId off ({ id, spec, ctype, params, value, ... }: declaredId) - out = ( - Printf out R off PoptS pStorSpec spec - Popt P.psid id `": " Pctype ctype `"\n" - Popt (printExpr (off + 1)) value %; + val isFunc = fn + function_t _ => true + | _ => false + + val isScalar = fn + function_t _ | array_t _ => false + | _ => true - case params of - NONE => () - | SOME params => Printf out `"params: " - Plist (poptN "none" P.psid) (map #1 params) (", ", false) `"\n" % - ) + fun getLinkage ctx (D as { spec = NONE, t, ... }) = + if isFunc t then + getLinkage ctx (updateRD D s#spec (SOME SpecExtern) %) + else + LinkExternal + | getLinkage _ { spec = SOME SpecStatic, ... } = LinkInternal + | getLinkage (Ctx ctx) { spec = SOME SpecExtern, id, ... } = + let + val prevLinkage = + case lookup (#globalDecls ctx) (valOf id) of + NONE => NONE + | SOME (_, _, _, linkage) => SOME linkage + in + case prevLinkage of + SOME linkage => linkage + | NONE => LinkExternal + end + | getLinkage _ { pos, ... } = + P.error pos `"declaration with invalid storage specifier" % - datatype declaration = - DeclIds of declaredId list | - FuncDef of declaredId * (token * P.tkPos) list + fun getToplevFuncDeclKind ctx (D as { id, pos, t, ... }: rawDecl) = + let + val linkage = getLinkage ctx D + in + (DeclRegular, (valOf id, pos, t, linkage), NONE) + end + + fun getToplevObjDeclKind ctx + (D as { ini, id, pos, t, spec, ... }: rawDecl) = + let + val linkage = getLinkage ctx D + val decl = (valOf id, pos, t, linkage) + in + case ini of + SOME _ => (DeclDefined, decl, ini) + | NONE => + let + val class = + case spec of + SOME SpecExtern => DeclRegular + | NONE | SOME SpecStatic => + if isFunc t then DeclRegular else DeclTentative + | _ => raise Unreachable + in + (class, decl, ini) + end + end + + fun getToplevDeclKind ctx (id as { t, ... }: rawDecl) = + (if isFunc t then getToplevFuncDeclKind else getToplevObjDeclKind) + ctx id + + fun link2str LinkInternal = "internal" + | link2str LinkExternal = "external" + + fun class2str DeclRegular = "regular" + | class2str DeclTentative = "tentative" + | class2str DeclDefined = "definition" + + fun addDeclaration (Ctx ctx) (id, pos, t, linkage) class = + let + fun f NONE = ((), SOME (pos, class, t, linkage)) + | f (SOME (_, class', t', linkage')) = + if linkage' <> linkage then + P.error pos `"declaration linkage conflict" % + else if t <> t' then + P.error pos `"declaration type conflict" % + else + let + val newClass = + case (class, class') of + (DeclRegular, DeclRegular) => DeclRegular + | (DeclRegular, DeclTentative) | (DeclTentative, DeclRegular) | + (DeclTentative, DeclTentative) => DeclTentative + | (DeclDefined, DeclDefined) => + P.error pos `"redefinition" % + | _ => DeclDefined + in + ((), SOME (pos, newClass, t, linkage)) + end + + 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 % + end + + datatype idData = ToplevId of objDef | LocalId of int * ini option + + fun handleToplevDecl ctx rawDecl = + let + val (class, D as (id, pos, t, linkage), ini) = + getToplevDeclKind ctx rawDecl + val ctx = addDeclaration ctx D class + in + if class = DeclDefined then + (SOME $ ToplevId (id, pos, t, valOf ini, linkage), ctx) + else + (NONE, ctx) + end + + fun warnRegister pos (SOME SpecRegister) = + P.warning pos `"register storage specifier" % + | warnRegister _ _ = () + + fun checkLocalVarType pos t = + if isFunc t then + P.error pos `"variable with function type" % + else + () + + fun insertLocalVar (Ctx ctx) ({ id, pos, t, ... }: rawDecl) = + let + val id = valOf id + val scope = hd $ #localScopes ctx + val oldVal = lookup scope id + in + case oldVal of + SOME _ => P.error pos `"local variable redefinition" % + | NONE => + let + val varId = length $ #localVars ctx + val localVars = (id, pos, t) :: #localVars ctx + val (_, scope) = Tree.insert intCompare scope id varId + in + (varId, id, updateCtx (Ctx ctx) + u#localScopes (fn scs => scope :: tl scs) + s#localVars localVars %) + end + end + + fun handleLocalVar ctx (D as { spec, pos, t, ini, ... }: rawDecl) = + let + val () = warnRegister pos spec + val () = checkLocalVarType pos t + val (varId, nid, ctx) = insertLocalVar ctx D + + val offset = case ctx of Ctx v => length $ #localScopes v + in + printf R offset + `"local var " P.?nid `"(" I varId `"): " Pctype t `"\n" %; + + if isSome ini orelse not $ isScalar t then + (SOME $ LocalId (varId, ini), ctx) + else + (NONE, ctx) + end + + fun handleRawDecl ctx (D as { spec, pos, ... }: rawDecl) = + case spec of + SOME SpecTypedef => P.error pos `"typedef is not supported yet\n" % + | _ => + (if isGlobalScope ctx then handleToplevDecl else handleLocalVar) + ctx D datatype fdecRes = - FDnormal of bool * declaredId | FDFuncDef of declaration + FDnormal of (bool * idData option) | + FDFuncDef of rawDecl * (token * P.tkPos) list - fun finishDeclarator (declId: declaredId) expectFDef ctx = + fun finishDeclarator rawId expectFdef ctx = let val (tk, pos, ctx) = getTokenCtx ctx + fun ret continue rawId ctx = + let + val (def, ctx) = handleRawDecl ctx rawId + in + (FDnormal (continue, def), ctx) + end in case tk of - Tk T.Comma => (FDnormal (true, declId), ctx) - | Tk T.Semicolon => (FDnormal (false, declId), ctx) + Tk T.Comma => ret true rawId ctx + | Tk T.Semicolon => ret false rawId ctx | Tk T.EqualSign => let - val ((status, ea), ctx) = parseExpr [T.Comma, T.Semicolon] ctx - val { id, pos, spec, ctype, params, ... } = declId - val declId = { id, pos, spec, ctype, value = SOME ea, params } + val (status, rawId, ctx) = tryParseInitializer ctx rawId in - if status = 0 then - P.clerror pos [P.Ctk T.Comma, P.Ctk T.Semicolon] - else - (FDnormal (status = 1, declId), ctx) + ret (status = 1) rawId ctx end | _ => - if expectFDef then + if expectFdef then case tk of - TkBraces list => (FDFuncDef $ FuncDef (declId, list), ctx) + TkBraces list => (FDFuncDef (rawId, list), ctx) | _ => P.clerror pos [P.Ctk T.Comma, P.Ctk T.Semicolon, P.Ctk T.LBrace] else P.clerror pos [P.Ctk T.Comma, P.Ctk T.Semicolon] end - fun parseDeclaration ctx expectFdef = + datatype toplev = + ObjDefs of objDef list | + LocalVarInits of (int * ini option) list | + FuncDef of rawDecl * (token * P.tkPos) list + + fun parseDeclaration ctx = let + val toplev = isGlobalScope ctx val (prefix, ctx) = parseDeclPrefix ctx + fun finishNormal acc = + let + val acc = rev acc + in + if toplev then + ObjDefs $ map (fn ToplevId v => v | _ => raise Unreachable) acc + else + LocalVarInits $ map (fn LocalId v => v | _ => raise Unreachable) + acc + end + fun collectDeclarators acc ctx = let + fun add (SOME v) = v :: acc + | add NONE = acc + val (parts, ctx) = parseDeclarator (false, APprohibited) [] ctx - val declaredId = assembleDeclarator prefix parts - val (res, ctx) = finishDeclarator declaredId - (expectFdef andalso null acc) ctx + val declIdRaw = assembleDeclarator prefix parts + val (res, ctx) = finishDeclarator declIdRaw + (toplev andalso null acc) ctx in case res of - FDFuncDef fd => (fd, ctx) - | FDnormal (continue, declId) => + FDFuncDef fd => (FuncDef fd, ctx) + | FDnormal (continue, toplevMaybe) => if continue then - collectDeclarators (declId :: acc) ctx + collectDeclarators (add toplevMaybe) ctx else - (DeclIds $ rev $ declId :: acc, ctx) + (finishNormal $ add toplevMaybe, ctx) end in collectDeclarators [] ctx @@ -1333,8 +1644,7 @@ functor Parser(P: PPC): PARSER = struct val (tk, _, ctx') = getTokenCtx ctx in case tk of - TkBraces list => - ctxWithLayer ctx' list (fn ctx => parseStmtCompound ctx) + TkBraces list => ctxWithLayer ctx' list (parseStmtCompound false) | Tk T.kwIf => parseStmtIf ctx' | Tk T.kwFor => parseStmtFor ctx' | Tk T.kwWhile => parseStmtWhile ctx' @@ -1428,8 +1738,24 @@ functor Parser(P: PPC): PARSER = struct and parseStmtDoWhile 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 + val ctx = skipExpected T.Semicolon ctx in (StmtDoWhile (stmt, cond), ctx) end @@ -1444,7 +1770,7 @@ functor Parser(P: PPC): PARSER = struct (StmtExpr ea, ctx) end - and parseStmtCompound ctx = + and parseStmtCompound isFuncBody ctx = let fun collectDecls acc ctx = let @@ -1452,16 +1778,16 @@ functor Parser(P: PPC): PARSER = struct in if isTypeNameStart tk then let - val (decl, ctx) = parseDeclaration ctx false - val declaredIds = - case decl of - DeclIds ids => ids + val (res , ctx) = parseDeclaration ctx + val inits = + case res of + LocalVarInits l => l | _ => raise Unreachable in - collectDecls (declaredIds :: acc) ctx + collectDecls (List.revAppend (inits, acc)) ctx end else - (List.concat $ rev acc, ctx) + (rev acc, ctx) end fun collectStmts acc ctx = @@ -1478,57 +1804,155 @@ functor Parser(P: PPC): PARSER = struct end end - val (decls, ctx) = collectDecls [] ctx + val ctx = + if isFuncBody then + ctx + else + updateCtx ctx u#localScopes (fn scs => Tree.empty :: scs) % + + val (inits, ctx) = collectDecls [] ctx val (stmts, ctx) = collectStmts [] ctx + + val ctx = updateCtx ctx u#localScopes tl % in - (StmtCompound (decls, stmts), ctx) + (StmtCompound (rev inits, stmts), ctx) end - fun pstmt off (StmtCompound (decls, stmts)) out = - Printf out R off `"{\n" - Plist (pDeclId (off + 1)) decls ("", false) - `(if null decls then "" else "\n") + fun pinit off (id, ini) out = + Printf out R off + `"%" I id `" = " A3 poptN "alloc" printIni ini `"\n" % + + fun pstmt' off (StmtCompound (inits, stmts)) out = + Printf out `"{\n" + Plist (pinit (off + 1)) inits ("", false) Plist (pstmt (off + 1)) stmts ("\n", false) - R off `"}\n" % + R off `"}" % - | pstmt off (StmtExpr ea) out = - Printf out A2 printExpr' off ea `";\n" % + | pstmt' _ (StmtExpr ea) out = Printf out A1 pea ea `";" % - | 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 % + | pstmt' off (StmtIf (cond, ifBody, elseBody)) out = + Printf out `"if " A1 pea cond `" " A2 pCompBody (off + 1) ifBody + Popt (fn stmt => fn out => + Printf out R off `"else " A2 pCompBody (off + 1) stmt %) elseBody % + + | pstmt' off (StmtFor (pre, cond, post, body)) out = + Printf out + `"for " Popt pea pre `"; " Popt pea cond `"; " Popt pea post + A2 pCompBody (off + 1) body % + + | pstmt' off (StmtWhile (cond, body)) out = + Printf out `"while " A1 pea cond `" " + A2 pCompBody (off + 1) body % + + | pstmt' off (StmtDoWhile (body, cond)) out = + Printf out `"do " A2 pCompBody (off + 1) body + `" " A1 pea cond `";" % + + and pCompBody off (S as (StmtCompound _)) out = + Printf out A2 pstmt' (off - 1) S % + | pCompBody (off:int) stmt out = Printf out `"\n" A2 pstmt off stmt % + + and pstmt off stmt out = Printf out R off A2 pstmt' off stmt `"\n" % val Pstmt = fn z => bind A2 pstmt z - fun parseFuncDefinition id ctx = + fun validateFuncHeader ({ t, pos, params, ... }: rawDecl) = let - val (stmt, ctx) = parseStmtCompound ctx + val () = + if not $ isFunc t then + P.error pos `"identifier not of function type\n" % + else + () + fun checkParams [] = () + | checkParams ((id, pos) :: tail) = + case id of + NONE => P.error pos `"expected parameter name\n" % + | SOME _ => checkParams tail + in + checkParams $ valOf params + end + + fun ctxPrepareForFunc ctx t params = + let + val paramTypes = + case t of function_t (_, ts) => ts | _ => raise Unreachable + + fun createLocalVars acc [] [] = acc + | createLocalVars acc (t :: ts) ((id, pos) :: params) = + createLocalVars ((valOf id, pos, t) :: acc) ts params + | createLocalVars _ _ _ = raise Unreachable + + val localVars = createLocalVars [] paramTypes params in - (Definition (id, stmt), ctx) + updateCtx ctx s#localVars localVars s#localScopes [Tree.empty] % end - fun printDef (Definition (id, stmt)) = - printf `"Function: " A2 pDeclId 0 id Pstmt 0 stmt % - | printDef (Declaration ids) = - printf Plist (pDeclId 0) ids ("", false) % + fun finishLocalVars (Ctx ctx) = Vector.fromList o rev o #localVars $ ctx + + fun parseFuncDefinition (D as { id, pos, t, params, ... }: rawDecl) ctx = + let + val () = validateFuncHeader D + val (id, params) = (valOf id, valOf params) + + val ctx = ctxPrepareForFunc ctx t params + + val linkage = getLinkage ctx D + val ctx = addDeclaration ctx (id, pos, t, linkage) DeclDefined + + val (stmt, ctx) = parseStmtCompound true ctx + val localVars = finishLocalVars ctx + in + (Definition { + name = id, + pos, + t, + paramNum = length params, + localVars, + stmt }, + ctx) + end + + fun printFuncHeader ({ name, localVars, paramNum, t, ... }: funcInfo) = + let + fun getParams acc idx = + if idx = paramNum then + rev acc + else + let + val param = #3 $ Vector.sub (localVars, idx) + in + getParams ((idx, param) :: acc) (idx + 1) + end + + val params = getParams [] 0 + fun printParam (id, t) out = Printf out `"%" I id `": " Pctype t % + val ret = case t of function_t (ret, _) => ret | _ => raise Unreachable + in + printf P.?name Plist printParam params (", ", true) + `" -> " Pctype ret `"\n" % + end + + fun printDef (Objects objs) = + let + fun pobj (id, _, t, ini, linkage) out = + let + val link = if linkage = LinkInternal then "static" else "global" + in + Printf out `link `" " P.?id `":" Pctype t + `" = " A1 printIni ini `"\n" % + end + in + printf Plist pobj objs ("", false) % + end + | printDef (Definition (D as { stmt, localVars, ... })) = + let + fun pLocalVar i (id, _, t) out = + Printf out `"%" I i `"(" P.?id `"): " Pctype t `"\n" % + in + printFuncHeader D; + printf Pstmt 0 stmt %; + Vector.appi (fn (i, var) => printf A2 pLocalVar i var %) localVars + end fun parseDef ctx = let @@ -1538,14 +1962,13 @@ functor Parser(P: PPC): PARSER = struct Tk T.EOS => NONE | _ => let - val (toplev, ctx) = parseDeclaration ctx true + val (toplev, ctx) = parseDeclaration ctx in SOME (case toplev of - DeclIds ids => (Declaration ids, ctx) + ObjDefs objDefList => (Objects objDefList, ctx) | FuncDef (id, body) => - ctxWithLayer ctx body (fn ctx => - parseFuncDefinition id ctx)) + ctxWithLayer ctx body (parseFuncDefinition id) + | LocalVarInits _ => raise Unreachable) end - end end |