Rework translation of unbounded and complex types.

2 files changed, 59 insertions, 14 deletions

diff --git a/src/ortho/llvm-nodebug/ortho_llvm.adb b/src/ortho/llvm-nodebug/ortho_llvm.adb
index 7eb7277c6..443b469aa 100644
--- a/src/ortho/llvm-nodebug/ortho_llvm.adb
+++ b/src/ortho/llvm-nodebug/ortho_llvm.adb
@@ -779,22 +779,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;
 
@@ -808,6 +807,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 --
    -------------------
@@ -1174,6 +1191,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 --
    ------------------------
@@ -1364,12 +1403,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
@@ -1718,7 +1753,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);
@@ -1751,6 +1787,8 @@ package body Ortho_LLVM is
       Destroy_Declare_Block;
 
       Cur_Func := Null_ValueRef;
+
+      Unreach := False;
    end Finish_Subprogram_Body;
 
    -------------------------
diff --git a/src/ortho/llvm-nodebug/ortho_llvm.private.ads b/src/ortho/llvm-nodebug/ortho_llvm.private.ads
index e5527a734..723aa5c7a 100644
--- a/src/ortho/llvm-nodebug/ortho_llvm.private.ads
+++ b/src/ortho/llvm-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;