Flattening of initializers

1 files changed, 255 insertions, 29 deletions

diff --git a/parser.fun b/parser.fun
index d8784e3..c0c9eaf 100644
--- a/parser.fun
+++ b/parser.fun
@@ -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