diff options
Diffstat (limited to 'parser.fun')
| -rw-r--r-- | parser.fun | 450 |
1 files changed, 326 insertions, 124 deletions
@@ -62,7 +62,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; | Nfloat of Real32.real | Ndouble of Real64.real - and evalRes = ER of Word64.word * ctype + and evalRes = ER of word * ctype and id = Lid of int | Gid of int @@ -110,6 +110,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; { name: nid, size: word, alignment: word, fields: (nid * word * ctype) list } | + enum_t of nid * bool | (* is complete? *) remote_t of int val typeSizes = [ @@ -193,7 +194,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; pos: P.tkPos, t: ctype, paramNum: int, - localVars: (int * P.tkPos * ctype) vector, + localVars: (nid * P.tkPos * ctype) vector, stmt: stmt } @@ -201,7 +202,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; type scope = (nid, int) Tree.t - datatype tag = TagStruct | TagUnion + datatype tag = TagStruct | TagUnion | TagEnum datatype typeStatus = TsDefined of tag | TsIncomplete of tag | TsNotDefined @@ -209,7 +210,32 @@ functor Parser(structure Tree: TREE; structure P: PPC; * For structures and unions the type name (nid) is duplicated for the * ease of pctype function *) - val types: (nid * P.tkPos * ctype) D.t = D.create0 () + val types: { name: nid, pos: P.tkPos, t: ctype } D.t = + D.create0 () + + fun resolveType t = + let + fun resolve id = + let + val { t, ... } = D.get types id + in + case t of + remote_t id => resolve id + | t => t + + end + in + case t of + remote_t id => resolve id + | t => t + end + + datatype taggedBody = EnumBody of (nid * P.tkPos * int) list + | AggrBody of (nid * ctype) list + + datatype globalSym = + GsDecl of P.tkPos * declClass * ctype * linkage | + GsEnumConst of int datatype ctx = Ctx of { aggrTypeNames: scope, @@ -218,7 +244,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; localVars: (int * P.tkPos * ctype) list, funcRetType: ctype option, - globalDecls: (int, P.tkPos * declClass * ctype * linkage) Tree.t, + globalSyms: (int, globalSym) Tree.t, tokenBuf: P.t * (token * P.tkPos) list list, @@ -232,16 +258,16 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun updateCtx (Ctx ctx) = fn z => let fun from aggrTypeNames localScopes localVars - funcRetType globalDecls tokenBuf loopLevel + funcRetType globalSyms tokenBuf loopLevel = { aggrTypeNames, localScopes, localVars, - funcRetType, globalDecls, tokenBuf, loopLevel } + funcRetType, globalSyms, tokenBuf, loopLevel } fun to f { aggrTypeNames, localScopes, localVars, - funcRetType, globalDecls, tokenBuf, loopLevel } + funcRetType, globalSyms, tokenBuf, loopLevel } = f aggrTypeNames localScopes localVars funcRetType - globalDecls tokenBuf loopLevel + globalSyms tokenBuf loopLevel in FRU.makeUpdate7 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f)) end @@ -301,13 +327,13 @@ functor Parser(structure Tree: TREE; structure P: PPC; let fun &(f, s) = Printf out `(if short then s else f) % - fun paggr (s, l) id out = + fun ptagged (s, l) id out = if short then Printf out `s I id % else Printf out `l `" " P.? id % in - case t of + case resolveType t of unknown_t => & ("unknown", "x") | void_t => & ("void", "v") | char_t => & ("char", "c") @@ -320,12 +346,6 @@ functor Parser(structure Tree: TREE; structure P: PPC; | ulong_t => & ("unsigned long", "L") | longlong_t => & ("long long", "w") | ulonglong_t => & ("unsigned long long", "W") - | remote_t id => - let - val (_, _, t) = D.get types id - in - pctype short t out - end (* | float_t => & ("float", "f") | double_t => & ("double", "d") @@ -340,8 +360,10 @@ functor Parser(structure Tree: TREE; structure P: PPC; `"}" `(if short then "" else " -> ") A2 pctype short ret % | array_t (n, el) => Printf out `"[" `(Word64.toString n) `"]" A2 pctype short el % - | struct_t { name, ... } => Printf out A2 paggr ("r", "struct") name % - | union_t { name, ... } => Printf out A2 paggr ("u", "union") name % + | struct_t { name, ... } => Printf out A2 ptagged ("r", "struct") name % + | union_t { name, ... } => Printf out A2 ptagged ("u", "union") name % + | enum_t (name, _) => Printf out A2 ptagged ("e", "enum") name % + | remote_t _ => raise Unreachable end val Pctype = fn z => bind A1 (pctype false) z @@ -358,7 +380,8 @@ functor Parser(structure Tree: TREE; structure P: PPC; T.kwUnsigned, T.kwStruct, - T.kwUnion + T.kwUnion, + T.kwEnum ] fun ts2idx ts = @@ -595,69 +618,81 @@ functor Parser(structure Tree: TREE; structure P: PPC; end *) - val isIntegral = fn + fun isIntegral t = + case resolveType t of char_t | uchar_t | short_t | ushort_t | int_t | uint_t | long_t | ulong_t | longlong_t | ulonglong_t => true | _ => false fun isArith t = - case t of + case resolveType t of (* float_t | double_t => true | *) _ => isIntegral t - val isSigned = fn - char_t | short_t | int_t | long_t | longlong_t => true - | _ => false + fun isSigned t = + case resolveType t of + char_t | short_t | int_t | long_t | longlong_t => true + | _ => false fun isScalar t = - case t of + case resolveType t of pointer_t _ => true | t => isArith t - val isFunc = fn + fun isFunc t = + case resolveType t of function_t _ => true | _ => false - fun isPointer (pointer_t _) = true - | isPointer (remote_t id) = (isPointer o #3 o D.get types) id - | isPointer t = false - fun isObj (void_t | function_t _) = false - | isObj _ = true + fun isPointer t = + case resolveType t of + (pointer_t _) => true + | _ => false - fun isPointerToObj (pointer_t (n, t)) = - if n > 1 then - true - else - isObj t - | isPointerToObj _ = false + fun isIncomplete t = + case resolveType t of + (struct_t { fields, ... }) => null fields + | (union_t { fields, ... }) => null fields + | _ => false + + fun isObj t = + case resolveType t of + (void_t | function_t _) => false + | _ => not $ isIncomplete t - fun isIncomplete (struct_t { fields, ... }) = null fields - | isIncomplete (union_t { fields, ... }) = null fields - | isIncomplete (remote_t id) = (isIncomplete o #3 o D.get types) id - | isIncomplete _ = false + fun isPointerToObj t = + case resolveType t of + (pointer_t (n, t)) => if n > 1 then true else isObj t + | _ => false - fun isStruct (struct_t _) = true - | isStruct (remote_t id) = (isStruct o #3 o D.get types) id - | isStruct _ = false + fun isStruct t = + case resolveType t of + (struct_t _) => true + | _ => false - fun isUnion (union_t _) = true - | isUnion (remote_t id) = (isUnion o #3 o D.get types) id - | isUnion t = false + fun isUnion t = + case resolveType t of + (union_t _) => true + | _ => false - fun funcParts (function_t pair) = pair - | funcParts _ = raise Unreachable + fun funcParts t = + case resolveType t of + (function_t pair) => pair + | _ => raise Unreachable - val pointsTo = fn + fun pointsTo t = + case resolveType t of pointer_t (1, t) => t | pointer_t (n, t) => if n < 2 then raise Unreachable else pointer_t (n - 1, t) | _ => raise Unreachable - fun tryGetFields (struct_t { fields, ... }) = fields - | tryGetFields (union_t { fields, ... }) = fields - | tryGetFields (remote_t id) = (tryGetFields o #3 o D.get types) id - | tryGetFields _ = raise Unreachable + fun tryGetFields t = + case resolveType t of + (struct_t { fields, ... }) => fields + | (union_t { fields, ... }) => fields + | _ => raise Unreachable fun createCtx fname incDirs = Ctx { aggrTypeNames = Tree.empty, @@ -665,7 +700,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; localScopes = [], localVars = [], funcRetType = NONE, - globalDecls = Tree.empty, + globalSyms = Tree.empty, tokenBuf = (P.create { fname, incDirs, debugMode = false }, []), loopLevel = 0 } @@ -1298,7 +1333,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; val locals = rev o #localVars $ ctx val t = #3 $ List.nth (locals, lid) in - SOME (Lid lid, true, convAggr sizeofOrAddr t) + SOME (Lid lid, true, convAggr sizeofOrAddr t, NONE) end | NONE => findLocal scopes end @@ -1307,16 +1342,18 @@ functor Parser(structure Tree: TREE; structure P: PPC; SOME p => p | NONE => let - val res = lookup (#globalDecls ctx) id + val res = lookup (#globalSyms ctx) id in case res of - SOME (_, _, t, _) => (Gid id, false, convAggr sizeofOrAddr t) + SOME (GsDecl (_, _, t, _)) => + (Gid id, not $ isFunc t, convAggr sizeofOrAddr t, NONE) + | SOME (GsEnumConst v) => (Gid id, false, int_t, SOME v) | NONE => P.error pos `"unknown identifier" % end end and typeRank t = - case t of + case resolveType t of char_t => 0 | uchar_t => 1 | short_t => 2 @@ -1333,8 +1370,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; | function_t _ => 15 | struct_t _ => 16 | union_t _ => 17 - | remote_t id => (typeRank o #3 o D.get types) id - | unknown_t => raise Unreachable + | unknown_t | remote_t _ | enum_t _ => raise Unreachable and convEA t (E as EA (_, pos, _, t')) = if t = t' then @@ -1783,9 +1819,12 @@ functor Parser(structure Tree: TREE; structure P: PPC; case e of Eid (id', _) => let - val (id, lvalue, t) = findId ctx pos sizeofOrAddr id' + val (id, lvalue, t, const) = findId ctx pos sizeofOrAddr id' in - EA (Eid (id', SOME id), pos, lvalue, t) + case const of + SOME v => + EA (Econst (id', Ninteger (Word.fromInt v)), pos, false, int_t) + | _ => EA (Eid (id', SOME id), pos, lvalue, t) end | EsizeofType _ => checkSizeofType E | EfuncCall _ => checkFuncCall (check false) E @@ -1825,21 +1864,24 @@ functor Parser(structure Tree: TREE; structure P: PPC; SOME (_, size) => Word64.fromInt size | _ => raise Unreachable - and alignOfType (pointer_t _) = pointerSize - | alignOfType (array_t (_, t)) = alignOfType t - | alignOfType (struct_t { alignment, ... }) = alignment - | alignOfType (remote_t id) = (alignOfType o #3 o D.get types) id - | alignOfType t = findPrimTypeSize t - - and sizeOfType (pointer_t _) = pointerSize - | sizeOfType (array_t (n, t)) = Word64.* (n, sizeOfType t) - | sizeOfType (struct_t { size, ... }) = size - | sizeOfType (remote_t id) = (sizeOfType o #3 o D.get types) id - | sizeOfType t = findPrimTypeSize t + and alignOfType t = + case resolveType t of + (pointer_t _) => pointerSize + | (array_t (_, t)) => alignOfType t + | (struct_t { alignment, ... } | union_t { alignment, ... }) => + alignment + | t => findPrimTypeSize t + + and sizeOfType t = + case resolveType t of + (pointer_t _) => pointerSize + | (array_t (n, t)) => n * sizeOfType t + | (struct_t { size, ... } | union_t { size, ... }) => size + | t => findPrimTypeSize t and sizeofWrapper t = Word64.toInt $ sizeOfType t - and zeroExtend (ER (w, t)) = + and zeroExtend (ER (w, t)): word = let val size = Word.fromLarge $ sizeOfType t val minus1 = Word64.notb (Word64.fromInt 0) @@ -2091,7 +2133,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; P.error pos `"not an arithmetic expression" % | Eternary (cond, left, right) => evalTernary cond left right - and eval (E as EA (_, pos, _, _)) t' = + and eval (E as EA (_, pos, _, _)) t': word = let val e = Eunop (UnopCast, E) val res = eval' $ EA (e, pos, false, t') @@ -2102,6 +2144,11 @@ functor Parser(structure Tree: TREE; structure P: PPC; zeroExtend res end + and convEnum t = + case resolveType t of + enum_t _ => int_t + | _ => t + and parseDeclPrefix ctx = let datatype state = TypeId of int | Type of ctype @@ -2109,6 +2156,13 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun collect ctx (storSpec, typeReprId) = let val (spec, ctx) = tryGetSpec ctx + + fun handleTagged tag = + let + val (t, ctx) = processTagged tag ctx + in + ((storSpec, convEnum t), ctx) + end in case (spec, typeReprId) of (NONE, TypeId 0) => @@ -2121,7 +2175,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; end | (NONE, TypeId id) => ((storSpec, typeRepr2type id), ctx) - | (NONE, Type t) => ((storSpec, t), ctx) + | (NONE, Type t) => ((storSpec, convEnum t), ctx) | (SOME (StorageSpec spec, pos), _) => ( case storSpec of @@ -2130,14 +2184,11 @@ functor Parser(structure Tree: TREE; structure P: PPC; P.error pos `"storage specifier is already provided" % ) - | (SOME (TypeSpec (t as T.kwStruct | t as T.kwUnion), _), TypeId 0) => - let - val tag = case t of T.kwStruct => TagStruct | _ => TagUnion - val (t, ctx) = processAggr tag ctx - in - ((storSpec, t), ctx) - end - | (SOME (TypeSpec T.kwStruct, pos), _) => + | (SOME (TypeSpec T.kwStruct, _), TypeId 0) => + handleTagged TagStruct + | (SOME (TypeSpec T.kwUnion, _), TypeId 0) => handleTagged TagUnion + | (SOME (TypeSpec T.kwEnum, _), TypeId 0) => handleTagged TagEnum + | (SOME (TypeSpec (T.kwStruct | T.kwUnion | T.kwEnum), pos), _) => P.error pos `"invalid type specifier" % | (SOME (TypeSpec tk, pos), TypeId id) => collect ctx (storSpec, TypeId $ advanceTypeRepr id (tk, pos)) @@ -2148,7 +2199,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; collect ctx (NONE, TypeId 0) end - and getAggrName ctx = + and getTaggedName ctx = let val (tk, pos, ctx) = getTokenCtx ctx in @@ -2192,7 +2243,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; collect [] ctx end - and tryGetAggrBody pos ctx: (nid * ctype) list option * ctx = + and tryGetAggrBody pos ctx: taggedBody option * ctx = let val (tk, _, ctx') = getTokenCtx ctx @@ -2216,7 +2267,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; P.error pos `"empty aggregates are not supported" % else ( checkFieldUniqueness acc; - (SOME $ map (fn (id, _, t) => (id, t)) acc, ctx) + (SOME $ AggrBody $ map (fn (id, _, t) => (id, t)) acc, ctx) ) end | _ => @@ -2232,7 +2283,77 @@ functor Parser(structure Tree: TREE; structure P: PPC; | _ => (NONE, ctx) end - and getAggrStatus id (Ctx { aggrTypeNames, ... }) = + and addEnumConstant (Ctx ctx) (id, pos, v) = + let + fun f NONE = ((), SOME $ GsEnumConst v) + | f (SOME (GsDecl _)) = + P.error pos `"symbol already denotes a declaration" % + | f (SOME (GsEnumConst _)) = + P.error pos `"symbol already denotes a enum constast" % + + val ((), globalSyms) = lookup2 (#globalSyms ctx) id f + in + updateCtx (Ctx ctx) s#globalSyms globalSyms % + end + + and tryGetEnumBody ctx = + let + val (tk, _, ctx') = getTokenCtx ctx + + fun collect defVal acc ctx = + let + fun getValue ctx = + let + val ((status, ea), ctx) = parseExpr [T.Comma] ctx + + val w = eval ea int_t + val value = word64Toint32 w + in + (status, value, ctx) + end + + val (tk, idPos, ctx) = getTokenCtx ctx + val id = + case tk of + Tk (T.Id id) => id + | _ => P.clerror idPos [P.Cid] + + val (tk, pos, ctx) = getTokenCtx ctx + + fun fin v ctx = + let + val ctx = addEnumConstant ctx (id, idPos, v) + in + (SOME $ EnumBody $ rev $ (id, idPos, v) :: acc, ctx) + end + fun cont v ctx = + let + val ctx = addEnumConstant ctx (id, idPos, v) + in + collect (v + 1) ((id, idPos, v) :: acc) ctx + end + in + case tk of + Tk T.EOS => fin defVal ctx + | Tk T.Comma => cont defVal ctx + | Tk T.EqualSign => + let + val (continue, v, ctx) = getValue ctx + in + if continue = 1 then + cont v ctx + else + fin v ctx + end + | _ => P.clerror pos [P.Ctk T.EqualSign, P.Ctk T.RBrace] + end + in + case tk of + TkBraces list => ctxWithLayer ctx' list (collect 0 []) + | _ => (NONE, ctx) + end + + and getTaggedStatus id (Ctx { aggrTypeNames, ... }) = let val bufId = lookup aggrTypeNames id @@ -2241,11 +2362,13 @@ functor Parser(structure Tree: TREE; structure P: PPC; case bufId of NONE => TsNotDefined | SOME id => - case #3 $ D.get types id of + case resolveType $ #t $ D.get types id of struct_t { fields, ... } => - ((if null fields then TsIncomplete else TsDefined) TagStruct) + (if null fields then TsIncomplete else TsDefined) TagStruct | union_t { fields, ... } => - ((if null fields then TsIncomplete else TsDefined) TagUnion) + (if null fields then TsIncomplete else TsDefined) TagUnion + | enum_t (_, isComplete) => + (if isComplete then TsDefined else TsIncomplete) TagEnum | _ => raise Unreachable end @@ -2254,9 +2377,11 @@ functor Parser(structure Tree: TREE; structure P: PPC; and ctFromTag TagStruct = struct_t | ctFromTag TagUnion = union_t + | ctFromTag TagEnum = raise Unreachable and sFromTag TagStruct = "struct" | sFromTag TagUnion = "union" + | sFromTag TagEnum = "enum" and calcAggr tag id [] = ctFromTag tag $ { name = id, size = 0w0, alignment = 0w0, fields = [] } @@ -2306,6 +2431,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; calcStructSize ((sizeOfType o #2 o hd) fields) (tl fields) [0w0] | TagUnion => calcUnionSize fields + | TagEnum => raise Unreachable fun zipOffsets (off :: offs) ((id, t) :: fs) = (id, off, t) :: zipOffsets offs fs @@ -2316,7 +2442,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; fields = zipOffsets offsets fields } end - and Paggr z = + and Ptagged z = let fun p [] _ = () | p ((id, offset, t) :: fields) out = @@ -2326,6 +2452,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun f (struct_t info | union_t info) out = Printf out `"{ size = " W (#size info) `", alignment = " W (#alignment info) `"\n" A1 p (#fields info) `"}\n" % + | f (enum_t _) _ = () | f _ _ = raise Unreachable in bind A1 f @@ -2337,6 +2464,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; else () + and registerDefault id pos ctx (nTag, tag) = let val () = checkTags pos nTag tag @@ -2344,55 +2472,83 @@ functor Parser(structure Tree: TREE; structure P: PPC; (getTypeIdFromName id ctx, ctx) end - and registerAggr id pos nTag (TsIncomplete tag | TsDefined tag) NONE ctx + and prepareInfo ctx id pos TagEnum NONE = + ({ name = id, pos, t = enum_t (id, false) }, ctx) + | prepareInfo ctx id pos TagEnum (SOME (EnumBody vals)) = + let + fun print ((id, _, v) :: vs) out = + Printf out `"\t" P.? id `" = " I v `"\n" A1 print vs % + | print [] _ = () + + val () = printf `"enum constants:\n" A1 print vals % + in + ({ name = id, pos, t = enum_t (id, true) }, ctx) + end + | prepareInfo ctx id pos tag body = + let + val body = + if isSome body then + case valOf body of + EnumBody _ => raise Unreachable + | AggrBody body => body + else + [] + in + ({ name = id, pos, t = calcAggr tag id body }, ctx) + end + + and registerTagged id pos nTag (TsIncomplete tag | TsDefined tag) NONE ctx = registerDefault id pos ctx (nTag, tag) - | registerAggr id pos nTag TsNotDefined body + | registerTagged id pos nTag TsNotDefined (body: taggedBody option) (C as Ctx { aggrTypeNames, ... }) = let val newBufId = D.length types val (_, aggrTypeNames) = Tree.insert intCompare aggrTypeNames id newBufId - val (body', status) = - case body of - NONE => ([], "incomplete") - | SOME body => (body, "complete") + val status = if isSome body then "complete" else "incomplete" - val newInfo = (id, pos, calcAggr nTag id body') + val (newInfo, C) = prepareInfo C id pos nTag body in D.push types newInfo; printf `"new " `status `" " `(sFromTag nTag) `": " - P.? id `":" I id `"\n" Paggr (#3 newInfo) %; + P.? id `":" I id `"\n" Ptagged (#t newInfo) %; (newBufId, updateCtx C s#aggrTypeNames aggrTypeNames %) end - | registerAggr id pos nTag (TsIncomplete tag) (SOME body) + | registerTagged id pos nTag (TsIncomplete tag) (SOME body) (C as Ctx { aggrTypeNames, ... }) = let val () = checkTags pos nTag tag val bufId = valOf $ lookup aggrTypeNames id - val newInfo = (id, pos, calcAggr tag id body) + val (newInfo, C) = prepareInfo C id pos nTag (SOME body) in D.set types bufId newInfo; printf `"completing " `(sFromTag nTag) `": " - P.? id `":" I id `"\n" Paggr (#3 newInfo) %; + P.? id `":" I id `"\n" Ptagged (#t newInfo) %; (bufId, C) end - | registerAggr _ pos _ (TsDefined _) (SOME _) _ = + | registerTagged _ pos _ (TsDefined _) (SOME _) _ = P.error pos `"aggregate redefinition" % - and processAggr tag ctx = + and processTagged tag ctx = let - val (id, pos, ctx) = getAggrName ctx + val (id, pos, ctx) = getTaggedName ctx + + val curStatus = getTaggedStatus id ctx - val curStatus = getAggrStatus id ctx - val (body, ctx) = tryGetAggrBody pos ctx + (* TODO *) - val (bufTypeId, ctx) = registerAggr id pos tag curStatus body ctx + val (body, ctx) = + case tag of + TagEnum => tryGetEnumBody ctx + | _ => tryGetAggrBody pos ctx + + val (bufTypeId, ctx) = registerTagged id pos tag curStatus body ctx in (remote_t bufTypeId, ctx) end @@ -2476,7 +2632,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; | TkBrackets list => let val ((_, ea), ctx) = ctxWithLayer ctx' list $ parseExpr [] - val w = eval ea ulong_t + val w: word = eval ea ulong_t in collectDDeclaratorTail (ArrayApplication w :: parts) untilEnd ctx end @@ -2661,12 +2817,14 @@ functor Parser(structure Tree: TREE; structure P: PPC; else LinkExternal | getLinkage _ { spec = SOME SpecStatic, ... } = LinkInternal - | getLinkage (Ctx ctx) { spec = SOME SpecExtern, id, ... } = + | getLinkage (Ctx ctx) { spec = SOME SpecExtern, id, pos, ... } = let val prevLinkage = - case lookup (#globalDecls ctx) (valOf id) of + case lookup (#globalSyms ctx) (valOf id) of NONE => NONE - | SOME (_, _, _, linkage) => SOME linkage + | SOME (GsDecl (_, _, _, linkage)) => SOME linkage + | SOME (GsEnumConst _) => + P.error pos `"symbol is already defined as a enum costant" % in case prevLinkage of SOME linkage => linkage @@ -2716,8 +2874,8 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun addDeclaration (Ctx ctx) (id, pos, t, linkage) class = let - fun f NONE = ((), SOME (pos, class, t, linkage)) - | f (SOME (_, class', t', linkage')) = + fun f NONE = ((), SOME (GsDecl (pos, class, t, linkage))) + | f (SOME (GsDecl (_, class', t', linkage'))) = if linkage' <> linkage then P.error pos `"declaration linkage conflict" % else if t <> t' then @@ -2733,27 +2891,48 @@ functor Parser(structure Tree: TREE; structure P: PPC; P.error pos `"redefinition" % | _ => DeclDefined in - ((), SOME (pos, newClass, t, linkage)) + ((), SOME (GsDecl (pos, newClass, t, linkage))) end + | f (SOME (GsEnumConst _)) = + P.error pos `"enum constant with such name is already defined" % val () = printf `(class2str class) `" decl " `(link2str linkage) `" " P.?id `": " Pctype t `"\n" % - val ((), tree) = lookup2 (#globalDecls ctx) id f + val ((), tree) = lookup2 (#globalSyms ctx) id f in - updateCtx (Ctx ctx) s#globalDecls tree % + updateCtx (Ctx ctx) s#globalSyms tree % end datatype idData = ToplevId of objDef | LocalId of int * ini option + fun canonIni pos t ini = + case ini of + IniCompound _ => raise Unimplemented + | IniExpr ea => + if isScalar t then + IniExpr $ convEA t ea + else + P.error pos `"aggregate with scalar initializer" % + fun handleToplevDecl ctx rawDecl = let val (class, D as (id, pos, t, linkage), ini) = getToplevDeclKind ctx rawDecl + + val () = + if isIncomplete t then + P.error pos `"toplev declaration of incomplete type" % + else + () val ctx = addDeclaration ctx D class in if class = DeclDefined then - (SOME $ ToplevId (id, pos, t, valOf ini, linkage), ctx) + let + val ini = canonIni pos t (valOf ini) + in + (SOME $ ToplevId (id, pos, t, ini, linkage), ctx) + end else (NONE, ctx) end @@ -2765,6 +2944,8 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun checkLocalVarType pos t = if isFunc t then P.error pos `"variable with function type" % + else if isIncomplete t then + P.error pos `"variable with incomplete type" % else () @@ -2780,6 +2961,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; 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) @@ -2807,7 +2989,11 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun handleRawDecl ctx (D as { spec, pos, ... }: rawDecl) = case spec of - SOME SpecTypedef => P.error pos `"typedef is not supported yet\n" % + SOME SpecTypedef => + if isGlobalScope ctx then + raise Unimplemented + else + P.error pos `"typedef in local scope is not supported\n" % | _ => (if isGlobalScope ctx then handleToplevDecl else handleLocalVar) ctx D @@ -3081,6 +3267,22 @@ functor Parser(structure Tree: TREE; structure P: PPC; (StmtExpr ea, ctx) end + and handleInis (Ctx ctx) l = + let + fun handleIni (id, NONE) = (id, NONE) + | handleIni (id, SOME ini) = + let + val (pos, t) = (fn (_, pos, t) => (pos, t)) $ + List.nth (rev $ #localVars ctx, id) + + val ini = canonIni pos t ini + in + (id, SOME ini) + end + in + List.map handleIni l + end + and parseStmtCompound isFuncBody ctx = let fun collectDecls acc ctx = @@ -3092,7 +3294,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; val (res, ctx) = parseDeclaration ctx val inits = case res of - LocalVarInits l => l + LocalVarInits l => handleInis ctx l | _ => raise Unreachable in collectDecls (List.revAppend (inits, acc)) ctx @@ -3266,7 +3468,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; 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) + printf P.?name `" " Plist printParam params (", ", true) `" -> " Pctype ret `"\n" % end |