Rework translation of unbounded and complex types.

3 files changed, 80 insertions, 20 deletions

diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.adb b/src/ortho/llvm4-nodebug/ortho_llvm.adb
index 4e02a908a..2f0edca3c 100644
--- a/src/ortho/llvm4-nodebug/ortho_llvm.adb
+++ b/src/ortho/llvm4-nodebug/ortho_llvm.adb
@@ -782,22 +782,21 @@ package body Ortho_LLVM is
    -- New_Global_Address --
    ------------------------
 
-   function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+   function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
                                return O_Cnode is
    begin
-      return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
-                      Ctype => Atype);
+      return New_Global_Unchecked_Address (Lvalue, Atype);
    end New_Global_Address;
 
    ----------------------------------
    -- New_Global_Unchecked_Address --
    ----------------------------------
 
-   function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
-                                         return O_Cnode
-   is
+   function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+                                         return O_Cnode is
    begin
-      return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
+      return O_Cnode'(LLVM => ConstBitCast (Lvalue.LLVM,
+                                            Get_LLVM_Type (Atype)),
                       Ctype => Atype);
    end New_Global_Unchecked_Address;
 
@@ -811,6 +810,24 @@ package body Ortho_LLVM is
                       Etype => Lit.Ctype);
    end New_Lit;
 
+   ----------------
+   -- New_Global --
+   ----------------
+
+   function New_Global (Decl : O_Dnode) return O_Gnode is
+   begin
+      --  Can be used to build global objects, even when Unreach is set.
+      --  As this doesn't generate code, this is ok.
+      case Decl.Kind is
+         when ON_Const_Decl
+           | ON_Var_Decl =>
+            return O_Gnode'(LLVM => Decl.LLVM,
+                            Ltype => Decl.Dtype);
+         when others =>
+            raise Program_Error;
+      end case;
+   end New_Global;
+
    -------------------
    -- New_Dyadic_Op --
    -------------------
@@ -1177,6 +1194,28 @@ package body Ortho_LLVM is
       return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype);
    end New_Selected_Element;
 
+   function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+                                        return O_Gnode
+   is
+      Res : ValueRef;
+   begin
+      case El.Kind is
+         when OF_Record =>
+            declare
+               Idx : constant ValueRefArray (1 .. 2) :=
+                 (ConstInt (Int32Type, 0, 0),
+                  ConstInt (Int32Type, Unsigned_64 (El.Index), 0));
+            begin
+               Res := ConstGEP (Rec.LLVM, Idx, 2);
+            end;
+         when OF_Union =>
+            Res := ConstBitCast (Rec.LLVM, El.Ptr_Type);
+         when OF_None =>
+            raise Program_Error;
+      end case;
+      return O_Gnode'(LLVM => Res, Ltype => El.Ftype);
+   end New_Global_Selected_Element;
+
    ------------------------
    -- New_Access_Element --
    ------------------------
@@ -1367,12 +1406,8 @@ package body Ortho_LLVM is
 
    function New_Obj (Obj : O_Dnode) return O_Lnode is
    begin
-      if Unreach then
-         return O_Lnode'(Direct => False,
-                         LLVM => Null_ValueRef,
-                         Ltype => Obj.Dtype);
-      end if;
-
+      --  Can be used to build global objects, even when Unreach is set.
+      --  As this doesn't generate code, this is ok.
       case Obj.Kind is
          when ON_Const_Decl
            | ON_Var_Decl
@@ -1725,7 +1760,8 @@ package body Ortho_LLVM is
 
       Cur_Func := Func.LLVM;
       Cur_Func_Decl := Func;
-      Unreach := False;
+
+      pragma Assert (not Unreach);
 
       Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring);
       PositionBuilderAtEnd (Decl_Builder, Decl_BB);
@@ -1758,6 +1794,8 @@ package body Ortho_LLVM is
       Destroy_Declare_Block;
 
       Cur_Func := Null_ValueRef;
+
+      Unreach := False;
    end Finish_Subprogram_Body;
 
    -------------------------
diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.ads b/src/ortho/llvm4-nodebug/ortho_llvm.ads
index 772a91894..837f4846e 100644
--- a/src/ortho/llvm4-nodebug/ortho_llvm.ads
+++ b/src/ortho/llvm4-nodebug/ortho_llvm.ads
@@ -50,10 +50,12 @@ package Ortho_LLVM is
    type O_Tnode is private;
    type O_Snode is private;
    type O_Dnode is private;
+   type O_Gnode is private;
    type O_Fnode is private;
 
    O_Cnode_Null : constant O_Cnode;
    O_Dnode_Null : constant O_Dnode;
+   O_Gnode_Null : constant O_Gnode;
    O_Enode_Null : constant O_Enode;
    O_Fnode_Null : constant O_Fnode;
    O_Lnode_Null : constant O_Lnode;
@@ -199,17 +201,17 @@ package Ortho_LLVM is
 
    --  Get the address of a subprogram.
    function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
-     return O_Cnode;
+                                   return O_Cnode;
 
    --  Get the address of LVALUE.
    --  ATYPE must be a type access whose designated type is the type of LVALUE.
    --  FIXME: what about arrays.
-   function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+   function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
                                return O_Cnode;
 
    --  Same as New_Address but without any restriction.
-   function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
-     return O_Cnode;
+   function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+                                         return O_Cnode;
 
    -------------------
    --  Expressions  --
@@ -308,12 +310,15 @@ package Ortho_LLVM is
    --  base type of ARR.
    --  INDEX must be of the type of the array index.
    function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
-     return O_Lnode;
+                      return O_Lnode;
 
    --  Get an element of a record or a union.
    --  Type of REC must be a record or a union type.
    function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
-     return O_Lnode;
+                                 return O_Lnode;
+
+   function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+                                        return O_Gnode;
 
    --  Reference an access.
    --  Type of ACC must be an access type.
@@ -340,6 +345,9 @@ package Ortho_LLVM is
    --  Get an lvalue from a declaration.
    function New_Obj (Obj : O_Dnode) return O_Lnode;
 
+   --  Get a global lvalue from a declaration.
+   function New_Global (Decl : O_Dnode) return O_Gnode;
+
    --  Return a pointer of type RTPE to SIZE bytes allocated on the stack.
    function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode;
 
@@ -614,6 +622,13 @@ private
 
    O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null);
 
+   type O_Gnode is record
+      LLVM : ValueRef;
+      Ltype : O_Tnode;
+   end record;
+
+   O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null);
+
    type O_Snode is record
       --  First BB in the loop body.
       Bb_Entry : BasicBlockRef;
diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.private.ads b/src/ortho/llvm4-nodebug/ortho_llvm.private.ads
index e5527a734..723aa5c7a 100644
--- a/src/ortho/llvm4-nodebug/ortho_llvm.private.ads
+++ b/src/ortho/llvm4-nodebug/ortho_llvm.private.ads
@@ -178,6 +178,13 @@ private
 
    O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null);
 
+   type O_Gnode is record
+      LLVM : ValueRef;
+      Ltype : O_Tnode;
+   end record;
+
+   O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null);
+
    type O_Snode is record
       --  First BB in the loop body.
       Bb_Entry : BasicBlockRef;