Union support

1 files changed, 161 insertions, 93 deletions

diff --git a/parser.fun b/parser.fun
index f2966b6..f0e5448 100644
--- a/parser.fun
+++ b/parser.fun
@@ -106,6 +106,9 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     struct_t of
      { name: nid, size: word, alignment: word,
         fields: (nid * word * ctype) list } |
+    union_t of
+     { name: nid, size: word, alignment: word,
+        fields: (nid * word * ctype) list } |
 
     remote_t of int
 
@@ -198,7 +201,9 @@ functor Parser(structure Tree: TREE; structure P: PPC;
 
   type scope = (nid, int) Tree.t
 
-  datatype typeStatus = TsDefined | TsIncomplete | TsNotDefined
+  datatype tag = TagStruct | TagUnion
+
+  datatype typeStatus = TsDefined of tag | TsIncomplete of tag | TsNotDefined
 
   (*
    * For structures and unions the type name (nid) is duplicated for the
@@ -295,9 +300,15 @@ functor Parser(structure Tree: TREE; structure P: PPC;
   fun pctype short t out =
   let
     fun &(f, s) = Printf out `(if short then s else f) %
+
+    fun paggr (s, l) id out =
+      if short then
+        Printf out `s I id %
+      else
+        Printf out `l `" " P.? id %
   in
     case t of
-      unknown_t => & ("unknown", "u")
+      unknown_t => & ("unknown", "x")
     | void_t => & ("void", "v")
     | char_t => & ("char", "c")
     | uchar_t => & ("unsigned char", "C")
@@ -329,11 +340,8 @@ 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, ... } =>
-        if short then
-          Printf out `"r" I name %
-        else
-          Printf out `"struct " P.? name %
+    | struct_t { name, ... } => Printf out A2 paggr ("r", "struct") name %
+    | union_t { name, ... } => Printf out A2 paggr ("u", "union") name %
   end
 
   val Pctype = fn z => bind A1 (pctype false) z
@@ -349,7 +357,8 @@ functor Parser(structure Tree: TREE; structure P: PPC;
       T.kwSigned,
       T.kwUnsigned,
 
-      T.kwStruct
+      T.kwStruct,
+      T.kwUnion
   ]
 
   fun ts2idx ts =
@@ -609,10 +618,9 @@ functor Parser(structure Tree: TREE; structure P: PPC;
       function_t _ => true
     | _ => false
 
-
-  val isPointer = fn
-      pointer_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
@@ -624,6 +632,19 @@ functor Parser(structure Tree: TREE; structure P: PPC;
       isObj t
     | isPointerToObj _ = false
 
+  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 isStruct (struct_t _) = true
+    | isStruct (remote_t id) = (isStruct o #3 o D.get types) id
+    | isStruct _ = false
+
+  fun isUnion (union_t _) = true
+    | isUnion (remote_t id) = (isUnion o #3 o D.get types) id
+    | isUnion t = false
+
   fun funcParts (function_t pair) = pair
     | funcParts _ = raise Unreachable
 
@@ -633,9 +654,10 @@ functor Parser(structure Tree: TREE; structure P: PPC;
         if n < 2 then raise Unreachable else pointer_t (n - 1, t)
     | _ => raise Unreachable
 
-  fun tryGetFields (struct_t { fields, ... }) = SOME fields
+  fun tryGetFields (struct_t { fields, ... }) = fields
+    | tryGetFields (union_t { fields, ... }) = fields
     | tryGetFields (remote_t id) = (tryGetFields o #3 o D.get types) id
-    | tryGetFields _ = NONE
+    | tryGetFields _ = raise Unreachable
 
   fun createCtx fname incDirs = Ctx {
     aggrTypeNames = Tree.empty,
@@ -1310,6 +1332,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     | array_t _ => 14
     | function_t _ => 15
     | struct_t _ => 16
+    | union_t _ => 17
     | remote_t id => (typeRank o #3 o D.get types) id
     | unknown_t => raise Unreachable
 
@@ -1702,42 +1725,54 @@ functor Parser(structure Tree: TREE; structure P: PPC;
   end
     | checkTernary _ _ = raise Unreachable
 
-  and checkMemberAccess check byP
-    (EA (EmemberByV (ea, field) | EmemberByP (ea, field), pos, _, _))
-  =
+  and checkMemberAccessByV check (EA (EmemberByV (ea, field), pos, _, _)) =
   let
     val ea = check ea
-
-    val pos' = getPos ea
     val t = getT ea
 
     val t =
-      if byP then
-        if isPointer t then
-          pointsTo t
-        else
-          P.error pos' `"expected a pointer to aggregate" %
+      if isStruct t orelse isUnion t then
+        t
       else
-          t
-
-    val fields =
-      case (tryGetFields t, byP) of
-        (NONE, true) =>
-            P.error pos' `"expected a pointer to an aggregate" %
-      | (NONE, false) => P.error pos' `"expected an aggregate" %
-      | (SOME fields, _) => fields
-
-    val e =
-      if byP then
-        EmemberByP (ea, field)
+        P.error (getPos ea) `"expected an aggregate" %
+
+    val fields = tryGetFields t
+  in
+    case List.find (fn (f, _, _) => f = field) fields of
+      NONE => P.error pos `"unknown field" %
+    | SOME (_, _, field_type) =>
+        EA (EmemberByV (ea, field), pos, true, field_type)
+  end
+    | checkMemberAccessByV _ _ = raise Unreachable
+
+  and checkMemberAccessByP check (EA (EmemberByP (ea, field), pos, _, _)) =
+  let
+    val ea = check ea
+    val t = getT ea
+
+    val t =
+      if isPointer t then
+        let
+          val t = pointsTo t
+        in
+          if isStruct t orelse isUnion t then
+            t
+          else
+            P.error (getPos ea) Pctype t `": "
+                B (isUnion t) `": expected a pointer to an Aggregate" %
+        end
       else
-        EmemberByV (ea, field)
+        P.error (getPos ea) `"expected a pointer to an aggregate" %
+
+
+    val fields = tryGetFields t
   in
     case List.find (fn (f, _, _) => f = field) fields of
       NONE => P.error pos `"unknown field" %
-    | SOME (_, _, field_type) => EA (e, pos, true, field_type)
+    | SOME (_, _, field_type) =>
+        EA (EmemberByP (ea, field), pos, true, field_type)
   end
-   | checkMemberAccess _ _ _ = raise Unreachable
+   | checkMemberAccessByP _ _ = raise Unreachable
 
   and checkExpr ctx sizeofOrAddr (E as EA (e, pos, _, _)) =
   let
@@ -1757,8 +1792,8 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     | Ebinop (_, _, _) => checkBinop (check false) E
     | Eternary _ => checkTernary (check false) E
     | Eunop (_, _) => checkUnop check sizeofOrAddr E
-    | EmemberByV _ => checkMemberAccess (check false) false E
-    | EmemberByP _ => checkMemberAccess (check false) true E
+    | EmemberByV _ => checkMemberAccessByV (check false) E
+    | EmemberByP _ => checkMemberAccessByP (check false) E
     | Econst _ | Estrlit _ => E
   end
 
@@ -2095,9 +2130,10 @@ functor Parser(structure Tree: TREE; structure P: PPC;
               P.error pos `"storage specifier is already provided" %
       )
 
-      | (SOME (TypeSpec T.kwStruct, _), TypeId 0) =>
+      | (SOME (TypeSpec (t as T.kwStruct | t as T.kwUnion), _), TypeId 0) =>
           let
-            val (t, ctx) = processStruct ctx
+            val tag = case t of T.kwStruct => TagStruct | _ => TagUnion
+            val (t, ctx) = processAggr tag ctx
           in
             ((storSpec, t), ctx)
           end
@@ -2112,18 +2148,18 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     collect ctx (NONE, TypeId 0)
   end
 
-  and getStructName ctx =
+  and getAggrName ctx =
   let
     val (tk, pos, ctx) = getTokenCtx ctx
   in
     case tk of
       Tk (T.Id id) => (id, pos, ctx)
     | TkBrackets _ =>
-        P.error pos `"anonymous structures are not supported" %
-    | _ => P.error pos `"expected struct name" %
+        P.error pos `"anonymous aggregates are not supported" %
+    | _ => P.error pos `"expected aggregate name" %
   end
 
-  and parseStructDeclaration ctx =
+  and parseAggrDeclaration ctx =
   let
     val (prefix, ctx) = parseDeclPrefix ctx
 
@@ -2132,6 +2168,8 @@ functor Parser(structure Tree: TREE; structure P: PPC;
       | convToField ({ id, pos, spec = NONE, t, ... }) =
         if isFunc t then
           P.error pos `"field of function type" %
+        else if isIncomplete t then
+          P.error pos `"field of incomplete type" %
         else
           (valOf id, pos, t)
 
@@ -2154,7 +2192,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     collect [] ctx
   end
 
-  and tryGetStructBody pos ctx: (nid * ctype) list option * ctx =
+  and tryGetAggrBody pos ctx: (nid * ctype) list option * ctx =
   let
     val (tk, _, ctx') = getTokenCtx ctx
 
@@ -2175,7 +2213,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
           val acc = rev acc
         in
           if null acc then
-            P.error pos `"empty structures are not supported" %
+            P.error pos `"empty aggregates are not supported" %
           else (
             checkFieldUniqueness acc;
             (SOME $ map (fn (id, _, t) => (id, t)) acc, ctx)
@@ -2183,7 +2221,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
         end
       | _ =>
         let
-          val (fields, ctx) = parseStructDeclaration ctx
+          val (fields, ctx) = parseAggrDeclaration ctx
         in
           collectFields (List.revAppend (fields, acc)) ctx
         end
@@ -2194,7 +2232,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     | _ => (NONE, ctx)
   end
 
-  and getStructStatus id (Ctx { aggrTypeNames, ... }) =
+  and getAggrStatus id (Ctx { aggrTypeNames, ... }) =
   let
     val bufId = lookup aggrTypeNames id
 
@@ -2204,85 +2242,113 @@ functor Parser(structure Tree: TREE; structure P: PPC;
       NONE => TsNotDefined
     | SOME id =>
       case #3 $ D.get types id of
-        struct_t { fields = [], ... } => TsIncomplete
-      | _ => TsDefined
+        struct_t { fields, ... } =>
+          ((if null fields then TsIncomplete else TsDefined) TagStruct)
+      | union_t { fields, ... } =>
+          ((if null fields then TsIncomplete else TsDefined) TagUnion)
+      | _ => raise Unreachable
   end
 
   and getTypeIdFromName id (Ctx { aggrTypeNames, ... }) =
     valOf $ lookup aggrTypeNames id
 
-  and calcStruct id [] =
-    struct_t { name = id, size = 0w0, alignment = 0w0, fields = [] }
-    | calcStruct id fields =
+  and ctFromTag TagStruct = struct_t
+    | ctFromTag TagUnion = union_t
+
+  and sFromTag TagStruct = "struct"
+    | sFromTag TagUnion = "union"
+
+  and calcAggr tag id [] =
+    ctFromTag tag $ { name = id, size = 0w0, alignment = 0w0, fields = [] }
+    | calcAggr tag id fields =
   let
-    val alignment: word =
+
+    fun max l f =
       List.foldl (fn ((_, t), m) =>
         let
-          val fa = alignOfType t
+          val fa = f t
         in
           if fa > m then fa else m
-        end) 0w0 $ fields
+        end) 0w0 l
+
+    val alignment: word = max fields alignOfType
 
     fun align v align =
       if v mod align = 0w0 then v else v + align - v mod align
 
-    fun calcSize size [] offsets =
+    fun calcStructSize size [] offsets =
       if size mod alignment = 0w0 then
         (size, rev offsets)
       else
         (align size alignment, rev offsets)
-      | calcSize size ((_, t) :: fields) offsets =
+      | calcStructSize size ((_, t) :: fields) offsets =
       let
         val fieldOffset = align size (alignOfType t)
         val size = fieldOffset + sizeOfType t
 
         val () = printf `"foffset : " W fieldOffset `"\n" %
       in
-        calcSize size fields (fieldOffset :: offsets)
+        calcStructSize size fields (fieldOffset :: offsets)
       end
 
+    fun calcUnionSize fields =
+    let
+      val offsets = List.tabulate (length fields, fn _ => 0w0)
+      val size = max fields sizeOfType
+      val size = align size alignment
+    in
+      (size, offsets)
+    end
+
     val (size, offsets) =
-      calcSize ((sizeOfType o #2 o hd) fields) (tl fields) [0w0]
+      case tag of
+        TagStruct =>
+            calcStructSize
+                ((sizeOfType o #2 o hd) fields) (tl fields) [0w0]
+      | TagUnion => calcUnionSize fields
 
     fun zipOffsets (off :: offs) ((id, t) :: fs) =
       (id, off, t) :: zipOffsets offs fs
       | zipOffsets [] [] = []
       | zipOffsets _ _ = raise Unreachable
   in
-    struct_t { name = id, size, alignment,
+    ctFromTag tag $ { name = id, size, alignment,
         fields = zipOffsets offsets fields }
   end
 
-  and Pstruct z =
+  and Paggr z =
   let
     fun p [] _ = ()
       | p ((id, offset, t) :: fields) out =
         Printf out `"\t" W offset `": " P.? id `": "
                 Pctype t `"\n" A1 p fields %
 
-    fun f (struct_t { size, alignment, fields, ... }) out =
-      Printf out `"{ size = " W size `", alignment = " W alignment `"\n"
-        A1 p fields `"}\n" %
+    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 _ _ = raise Unreachable
   in
     bind A1 f
   end z
 
-  (*
-  val Ptk = fn z =>
+  and checkTags pos nTag tag =
+    if nTag <> tag then
+      P.error pos `"aggregate with same name but different tag exists" %
+    else
+      ()
+
+  and registerDefault id pos ctx (nTag, tag) =
   let
-    fun f tk out = Printf out T.Ptk symtab tk %
+    val () = checkTags pos nTag tag
   in
-    bind A1 f
-  end z
-  *)
+    (getTypeIdFromName id ctx, ctx)
+  end
 
-  and registerStruct id _ TsIncomplete NONE ctx =
-      (getTypeIdFromName id ctx, ctx)
-    | registerStruct id _ TsDefined NONE ctx =
-      (getTypeIdFromName id ctx, ctx)
+  and registerAggr id pos nTag (TsIncomplete tag | TsDefined tag) NONE ctx
+  =
+      registerDefault id pos ctx (nTag, tag)
 
-    | registerStruct id pos TsNotDefined body
+    | registerAggr id pos nTag TsNotDefined body
       (C as Ctx { aggrTypeNames, ... })
     =
     let
@@ -2294,37 +2360,39 @@ functor Parser(structure Tree: TREE; structure P: PPC;
           NONE => ([], "incomplete")
         | SOME body => (body, "complete")
 
-      val newInfo = (id, pos, calcStruct id body')
+      val newInfo = (id, pos, calcAggr nTag id body')
     in
       D.push types newInfo;
-      printf `"new " `status `" struct: " P.? id `":" I id `"\n" %;
-      printf Pstruct (#3 newInfo) %;
+      printf `"new " `status `" " `(sFromTag nTag) `": "
+        P.? id `":" I id `"\n" Paggr (#3 newInfo) %;
       (newBufId, updateCtx C s#aggrTypeNames aggrTypeNames %)
     end
 
-    | registerStruct id pos TsIncomplete (SOME body)
+    | registerAggr 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, calcStruct id body)
+      val newInfo = (id, pos, calcAggr tag id body)
     in
       D.set types bufId newInfo;
-      printf `"completing struct: " P.? id `":" I id `"\n" %;
-      printf Pstruct (#3 newInfo) %;
+      printf `"completing " `(sFromTag nTag) `": "
+        P.? id `":" I id `"\n" Paggr (#3 newInfo) %;
       (bufId, C)
     end
-    | registerStruct _ pos TsDefined (SOME _) _ =
-      P.error pos `"struct redefinition" %
+    | registerAggr _ pos _ (TsDefined _) (SOME _) _ =
+      P.error pos `"aggregate redefinition" %
 
-  and processStruct ctx =
+  and processAggr tag ctx =
   let
-    val (id, pos, ctx) = getStructName ctx
+    val (id, pos, ctx) = getAggrName ctx
 
-    val status = getStructStatus id ctx
-    val (body, ctx) = tryGetStructBody pos ctx
+    val curStatus = getAggrStatus id ctx
+    val (body, ctx) = tryGetAggrBody pos ctx
 
-    val (bufTypeId, ctx) = registerStruct id pos status body ctx
+    val (bufTypeId, ctx) = registerAggr id pos tag curStatus body ctx
   in
     (remote_t bufTypeId, ctx)
   end