diff options
| -rw-r--r-- | common.sml | 4 | ||||
| -rw-r--r-- | parser.fun | 284 | ||||
| -rw-r--r-- | stream.sig | 1 | ||||
| -rw-r--r-- | stream.sml | 2 | ||||
| -rw-r--r-- | tokenizer.fun | 21 | ||||
| -rw-r--r-- | tokenizer.sig | 2 |
6 files changed, 283 insertions, 31 deletions
@@ -169,14 +169,14 @@ 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 = +fun plist p l (s, parens, from) out = let 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 - if parens andalso length l > 1 then + if parens andalso length l >= from then Printf out `"(" A1 f l `")" % else Printf out A1 f l % @@ -142,6 +142,9 @@ functor Parser(structure Tree: TREE; structure P: PPC; datatype ini = IniExpr of exprAug | IniCompound of ini list + datatype cini = CiniExpr of exprAug | CiniConst of word | + CiniLayout of { offset: word, t: ctype, value: word } list + datatype storageSpec = SpecTypedef | SpecExtern | @@ -168,7 +171,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; datatype stmt = StmtExpr of exprAug | - StmtCompound of (int * ini option) list * stmt list | + StmtCompound of (int * cini option) list * stmt list | StmtIf of exprAug * stmt * stmt option | StmtFor of exprAug option * exprAug option * exprAug option * stmt | StmtWhile of exprAug * stmt | @@ -189,7 +192,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; datatype linkage = LinkInternal | LinkExternal datatype declClass = DeclRegular | DeclTentative | DeclDefined - type objDef = int * P.tkPos * ctype * ini * linkage + type objDef = int * P.tkPos * ctype * cini * linkage type funcInfo = { name: int, @@ -360,7 +363,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; else Printf out `"{" I plevel `"} " A2 pctype false t % | function_t (ret, params) => Printf out `"{" - Plist (pctype short) params (if short then "" else ", ", false) + Plist (pctype short) params (if short then "" else ", ", false, 2) `"}" `(if short then "" else " -> ") A2 pctype short ret % | array_t (n, el) => Printf out `"[" W n `"]" A2 pctype short el % @@ -602,12 +605,13 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun typeRepr2type typeReprId = valOf o #1 o Array.sub $ (prefixFsm, typeReprId) + (* fun pTokenL l out = let fun pToken (tk, _) out = let fun printList list opr cpr = Printf out `(opr ^ "| ") - Plist pToken list (",", false) `(" |" ^ cpr) % + Plist pToken list (",", false, 2) `(" |" ^ cpr) % in case tk of Tk tk => Printf out P.Ptk tk % @@ -617,8 +621,9 @@ functor Parser(structure Tree: TREE; structure P: PPC; | TkTernary list => printList list "?" ":" end in - Printf out Plist pToken l (",", false) % + Printf out Plist pToken l (",", false, 2) % end + *) fun isIntegral t = case resolveType t of @@ -841,7 +846,8 @@ functor Parser(structure Tree: TREE; structure P: PPC; | EmemberByP p => mem p "->" | EsizeofType ctype => Printf out `"sizeof(" Pctype ctype `")" % | EfuncCall (func, args) => - Printf out `"fcall " A1 pea func `", " Plist pea args (", ", false) % + Printf out `"fcall " A1 pea func `", " + Plist pea args (", ", false, 2) % | Eternary (cond, ifB, elseB) => Printf out A1 pea cond `" ? " A1 pea ifB `" : " A1 pea elseB % | Ebinop(BinopTernaryIncomplete _, _, _) => raise Unreachable @@ -2805,9 +2811,16 @@ functor Parser(structure Tree: TREE; structure P: PPC; ini = NONE, params }: rawDecl) end - fun printIni (IniExpr ea) out = Printf out A1 pea ea % - | printIni (IniCompound inis) out = Printf out - `"{" Plist (printIni) inis (", ", false) `"}" % + fun printIni _ (CiniExpr ea) out = Printf out A1 pea ea % + | printIni _ (CiniConst w) out = Printf out W w % + | printIni off (CiniLayout layout) out = + let + fun pentry ({ offset, t, value }) out = + Printf out R off `"\t" W offset `": " + Pctype t `": " W value `"\n" % + in + Printf out `"{\n" Plist pentry layout ("", false, 0) R off `"}\n" % + end fun dieExpTerms pos terms = P.clerror pos $ map P.Ctk terms @@ -2815,9 +2828,9 @@ functor Parser(structure Tree: TREE; structure P: PPC; let fun collect ctx acc = let - val (status, ini, ctx) = parseInitializer [T.Comma] ctx + val (status, ini, ctx) = parseInitializer [T.Comma, T.EOS] ctx in - if status = 0 then + if status = 0 orelse status = 2 then (rev $ ini :: acc, ctx) else collect ctx (ini :: acc) @@ -2838,6 +2851,8 @@ functor Parser(structure Tree: TREE; structure P: PPC; val (ini, ctx) = ctxWithLayer ctx' list parseCompoundInitializer val (tk, pos, ctx) = getTokenCtx ctx val status = oneOfEndTks tk terms + + val () = printf `"Status: " I status % in if status = 0 then dieExpTerms pos terms @@ -2847,7 +2862,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; | _ => let val ((status, ea), ctx) = parseExpr terms ctx - fun isToplev [_, _] = true + fun isToplev [T.Comma, T.Semicolon] = true | isToplev _ = false in if status = 0 andalso isToplev terms then @@ -2963,14 +2978,225 @@ functor Parser(structure Tree: TREE; structure P: PPC; 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 + datatype layout = LcScalar of ctype | LcAggr of layoutAux list + and layoutAux = LcAux of word * layout + + fun computeTLayout t = + let + val t = resolveType t + in + if isScalar t then + LcScalar t + else + case t of + struct_t { fields, ... } => + let + fun comp ((_, offset, t) :: fs) acc = + let + val layout = computeTLayout t + in + comp fs (LcAux (offset, layout) :: acc) + end + | comp [] acc = rev acc + in + LcAggr $ comp fields [] + end + | union_t { fields, ... } => computeTLayout (#3 $ hd fields) + | array_t (n, t) => + LcAggr $ List.tabulate (Word.toInt n, fn n => + let + val l = computeTLayout t + val lx = LcAux (Word.fromInt n * sizeOfType t, l) + in + lx + end) + + | _ => raise Unimplemented + end + + fun printOffsets (LcAux (offset, l)) out = + let + val () = Printf out W offset `":" % + in + case l of + LcScalar t => Printf out `"[" Pctype t `"]" % + | LcAggr lxs => Printf out Plist printOffsets lxs (", ", true, 1) % + end + + fun calcOffsets offset (LcAux (off, l)) = + case l of + LcScalar t => LcAux (offset + off, LcScalar t) + | LcAggr lxs => + let + val lxs = List.map (calcOffsets $ offset + off) lxs + in + LcAux (offset + off, LcAggr lxs) + end + + fun extractFirstScalar (LcAux (off, l)) = + let + fun restore [] = NONE + | restore (first :: tail) = + let + fun rest [] (buf: layoutAux) = buf + | rest (LcAux (off, LcAggr lcxs) :: tail) buf = + rest tail (LcAux (off, LcAggr (buf :: lcxs))) + | rest _ _ = raise Unreachable + in + SOME $ rest tail first + end + + fun extractFirst acc (LcAux (off, l)) = + case l of + LcScalar t => ((off, t), restore acc) + | LcAggr (lcxs) => + let + val acc = + if length lcxs = 1 then + acc + else + LcAux (off, LcAggr (tl lcxs)) :: acc + in + extractFirst acc (hd lcxs) + end + in + case l of + LcScalar t => ((off, t), NONE) + | L => extractFirst [] (LcAux (off, L)) + end + + fun getOneIni _ (IniExpr _) = raise Unreachable + | getOneIni pos (I as IniCompound []) = + (IniExpr (EA (Econst (0, Ninteger 0w0), pos, false, int_t)), I) + | getOneIni _ (IniCompound (ini :: inis)) = (ini, IniCompound inis) + + fun reachedImplicitZeros (IniCompound []) = true + | reachedImplicitZeros (IniCompound _) = false + | reachedImplicitZeros _ = raise Unreachable + + fun matchInitializer _ (LcAux (offset, LcScalar t)) (IniExpr ea) acc = + let + val value = eval ea t + in + (NONE, ({ offset, t, value } :: acc)) + end + | matchInitializer pos (LcAux (_, LcScalar _)) _ _ = + P.error pos `"cannot match scalar with compound initializer" % + | matchInitializer _ (L as LcAux (_, LcAggr _)) (IniExpr ea) acc = + let + val ((offset, t), tail) = extractFirstScalar L + + val value = eval ea t + in + (tail: layoutAux option, { offset, t, value } :: acc) + end + | matchInitializer pos (LcAux (_, LcAggr lcxs)) + (Ini as IniCompound _) acc + = + let + fun matchOne acc lcx inis = + let + val (ini, inis) = getOneIni pos inis + val (tail, acc) = matchInitializer pos lcx ini acc + in + case tail of + NONE => (acc, inis) + | SOME lcx => matchOne acc lcx inis + end + + fun matchAll acc [] ini = + if reachedImplicitZeros ini then + acc else - P.error pos `"aggregate with scalar initializer" % + P.error pos `"extra initializer components" % + | matchAll acc (lcx :: lcxs) ini = + let + val (acc, ini) = matchOne acc lcx ini + in + matchAll acc lcxs ini + end + + val acc = matchAll acc lcxs Ini + in + (NONE, acc) + end + + fun flattenIni pos lcx ini = + let + val (res, acc) = matchInitializer pos lcx ini [] + val () = + case res of + NONE => () + | SOME _ => raise Unreachable + in + rev acc + end + + fun getCharArrayLen t = + case resolveType t of + array_t (n, t) => if resolveType t = char_t then SOME n else NONE + | _ => NONE + + fun convStrlitIni pos t ini = + let + fun convStrlit2ini n id = + let + open List + + fun min a b = if a < b then a else b + + val chars = P.T.strlit2charList $ P.?? id + val chars = take (chars, min n (length chars)) + val bytes = + map (fn c => Econst(id, Ninteger (Word.fromInt $ ord c))) chars + in + IniCompound + (map (fn b => IniExpr (EA (b, pos, false, char_t))) bytes) + end + in + case getCharArrayLen t of + NONE => ini + | SOME len => ( + case ini of + IniExpr (EA (Estrlit id, _, _, _)) + | IniCompound ([IniExpr (EA (Estrlit id, _, _, _))]) => + convStrlit2ini (Word.toInt len) id + | _ => ini + ) + end + + fun canonExprIni toplev t ea = + if toplev then + let + val w = eval ea t + in + CiniConst w + end + else + CiniExpr $ convEA t ea + + + fun canonIni toplev pos t ini = + let + val ini = convStrlitIni pos t ini + in + if isScalar t then + case ini of + IniExpr ea | IniCompound [IniExpr ea] => canonExprIni toplev t ea + | _ => P.error pos `"compound initializer with scalar variable" % + else + case ini of + IniExpr _ => + P.error pos + `"cannot initialize aggregate with scalar initializer" % + | _ => + let + val layout = calcOffsets 0w0 $ LcAux (0w0, computeTLayout t) + val seq = flattenIni pos layout ini + in + CiniLayout seq + end + end fun handleToplevDecl ctx rawDecl = let @@ -2986,7 +3212,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; in if class = DeclDefined then let - val ini = canonIni pos t (valOf ini) + val ini = canonIni (isGlobalScope ctx) pos t (valOf ini) in (SOME $ ToplevId (id, pos, t, ini, linkage), ctx) end @@ -3355,7 +3581,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; (StmtExpr ea, ctx) end - and handleInis l = + and handleInis ctx l = let fun handleIni (id, NONE) = (id, NONE) | handleIni (id, SOME ini) = @@ -3363,7 +3589,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; val (pos, t) = (fn ({pos, t, ... }) => (pos, t)) $ D.get localVars id - val ini = canonIni pos t ini + val ini = canonIni (isGlobalScope ctx) pos t ini in (id, SOME ini) end @@ -3382,7 +3608,7 @@ functor Parser(structure Tree: TREE; structure P: PPC; val (res, ctx) = parseDeclaration ctx val inits = case res of - LocalVarInits l => handleInis l + LocalVarInits l => handleInis ctx l | _ => raise Unreachable in collectDecls (List.revAppend (inits, acc)) ctx @@ -3421,12 +3647,12 @@ functor Parser(structure Tree: TREE; structure P: PPC; fun pinit off (id, ini) out = Printf out R off - `"%" I id `" <- " A3 poptN "alloc" printIni ini `"\n" % + `"%" I id `" <- " A3 poptN "alloc" (printIni off) 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) + Plist (pinit (off + 1)) inits ("", false, 2) + Plist (pstmt (off + 1)) stmts ("\n", false, 2) R off `"}" % | pstmt' _ (StmtExpr ea) out = Printf out A1 pea ea `";" % @@ -3559,7 +3785,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, 2) `" -> " Pctype ret `"\n" % end @@ -3570,10 +3796,10 @@ functor Parser(structure Tree: TREE; structure P: PPC; val link = if linkage = LinkInternal then "static" else "global" in Printf out `link `" " P.?id `":" Pctype t - `" = " A1 printIni ini `"\n" % + `" = " A2 printIni 0 ini `"\n" % end in - printf Plist pobj objs ("", false) % + printf Plist pobj objs ("", false, 2) % end | printDef (Definition (D as { stmt, localVars, ... })) = let @@ -25,6 +25,7 @@ signature STREAM = sig (* both throw IO.Io *) val create: string -> t val createFromInstream: string -> TextIO.instream -> t + val createFromString: string -> t val getOffset: t -> fileOffset val isFirstOnLine: t -> fileOffset -> bool @@ -73,6 +73,8 @@ structure Stream :> STREAM = struct fun create fname = createFromInstream fname (TextIO.openIn fname) + fun createFromString s = createFromInstream s (TextIO.openString s) + fun getOffset ({ off, ... }: t) = off fun isFirstOnLine ({ contents, ... }: t) off = diff --git a/tokenizer.fun b/tokenizer.fun index cce6bea..80200d5 100644 --- a/tokenizer.fun +++ b/tokenizer.fun @@ -253,6 +253,9 @@ struct fun clKw tk (ppc, NONE) = (ppc, SOME tk) | clKw _ _ = raise Unreachable + + val res = ST.getId symtab "0" + val () = if res <> 0 then raise Unreachable else () in app (fn (tk, repr) => if ?repr = ppcPrefix then @@ -576,6 +579,24 @@ struct | _ => (c, stream) end + fun strlit2charList (s: string) = + let + val s = String.substring (s, 1, size s - 2) + val stream = S.createFromString s + + fun collect acc stream = + let + val (c, stream) = getMaybeBackslashed stream + in + case c of + Reg #"\000" => rev $ #"\000" :: acc + | Reg c | EscSeqed c => collect (c :: acc) stream + | NoChar => raise Unreachable + end + in + collect [] stream + end + fun parseCharConst symtab stream = let val startOff = S.getOffset stream - 1 diff --git a/tokenizer.sig b/tokenizer.sig index 958619a..e436374 100644 --- a/tokenizer.sig +++ b/tokenizer.sig @@ -120,6 +120,8 @@ signature TOKENIZER = sig val getToken: token ST.t -> S.t -> token * S.pos * S.t val Ptk: (token ST.t, token, 'a, 'b, 'c) a2printer + val strlit2charList: string -> char list + val isPpcDir: token -> bool val debugPrint: string -> unit end |