Rework translation of unbounded and complex types.

3 files changed, 107 insertions, 31 deletions

diff --git a/src/ortho/debug/ortho_debug-disp.adb b/src/ortho/debug/ortho_debug-disp.adb
index 53e4a6767..51707786e 100644
--- a/src/ortho/debug/ortho_debug-disp.adb
+++ b/src/ortho/debug/ortho_debug-disp.adb
@@ -264,6 +264,7 @@ package body Ortho_Debug.Disp is
 
    procedure Disp_Enode (E : O_Enode; Etype : O_Tnode);
    procedure Disp_Lnode (Node : O_Lnode);
+   procedure Disp_Gnode (Node : O_Gnode);
    procedure Disp_Snode (First, Last : O_Snode);
    procedure Disp_Dnode (Decl : O_Dnode);
    procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean);
@@ -556,17 +557,17 @@ package body Ortho_Debug.Disp is
          when OC_Address =>
             Disp_Tnode_Name (C.Ctype);
             Put ("'address (");
-            Disp_Dnode_Name (C.Decl);
+            Disp_Gnode (C.Addr_Global);
             Put (")");
          when OC_Unchecked_Address =>
             Disp_Tnode_Name (C.Ctype);
             Put ("'unchecked_address (");
-            Disp_Dnode_Name (C.Decl);
+            Disp_Gnode (C.Addr_Global);
             Put (")");
          when OC_Subprogram_Address =>
             Disp_Tnode_Name (C.Ctype);
             Put ("'subprg_addr (");
-            Disp_Dnode_Name (C.Decl);
+            Disp_Dnode_Name (C.Addr_Decl);
             Put (")");
       end case;
    end Disp_Cnode;
@@ -677,13 +678,21 @@ package body Ortho_Debug.Disp is
             Disp_Lnode (Node.Rec_Base);
             Put ('.');
             Disp_Ident (Node.Rec_El.Ident);
---          when OL_Var_Ref
---            | OL_Const_Ref
---            | OL_Param_Ref =>
---             Disp_Dnode_Name (Node.Decl);
       end case;
    end Disp_Lnode;
 
+   procedure Disp_Gnode (Node : O_Gnode) is
+   begin
+      case Node.Kind is
+         when OG_Decl =>
+            Disp_Dnode_Name (Node.Decl);
+         when OG_Selected_Element =>
+            Disp_Gnode (Node.Rec_Base);
+            Put ('.');
+            Disp_Ident (Node.Rec_El.Ident);
+      end case;
+   end Disp_Gnode;
+
    procedure Disp_Fnodes (First : O_Fnode)
    is
       El : O_Fnode;
diff --git a/src/ortho/debug/ortho_debug.adb b/src/ortho/debug/ortho_debug.adb
index 3645b89e8..bb32197a4 100644
--- a/src/ortho/debug/ortho_debug.adb
+++ b/src/ortho/debug/ortho_debug.adb
@@ -288,6 +288,14 @@ package body Ortho_Debug is
       N.Ref := True;
    end Check_Ref;
 
+   procedure Check_Ref (N : O_Gnode) is
+   begin
+      if N.Ref then
+         raise Syntax_Error;
+      end if;
+      N.Ref := True;
+   end Check_Ref;
+
    procedure Check_Complete_Type (T : O_Tnode) is
    begin
       if not T.Complete then
@@ -928,7 +936,7 @@ package body Ortho_Debug is
            | ON_Interface_Decl =>
             null;
          when others =>
-            raise Program_Error;
+            raise Syntax_Error;
       end case;
       Check_Scope (Obj);
       return new O_Lnode_Obj'(Kind => OL_Obj,
@@ -937,8 +945,28 @@ package body Ortho_Debug is
                               Obj => Obj);
    end New_Obj;
 
+   function New_Global (Decl : O_Dnode) return O_Gnode
+   is
+      subtype O_Gnode_Decl is O_Gnode_Type (OG_Decl);
+   begin
+      case Decl.Kind is
+         when ON_Const_Decl
+           | ON_Var_Decl =>
+            null;
+         when others =>
+            raise Syntax_Error;
+      end case;
+      if Decl.Storage = O_Storage_Local then
+         raise Syntax_Error;
+      end if;
+      return new O_Gnode_Decl'(Kind => OG_Decl,
+                               Rtype => Decl.Dtype,
+                               Ref => False,
+                               Decl => Decl);
+   end New_Global;
+
    function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
-     return O_Lnode
+                                return O_Lnode
    is
       subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element);
       Res : O_Lnode;
@@ -953,7 +981,7 @@ package body Ortho_Debug is
    end New_Indexed_Element;
 
    function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
-     return O_Lnode
+                      return O_Lnode
    is
       subtype O_Lnode_Slice is O_Lnode_Type (OL_Slice);
       Res : O_Lnode;
@@ -995,6 +1023,27 @@ package body Ortho_Debug is
                                            Rec_El => El);
    end New_Selected_Element;
 
+   function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+                                        return O_Gnode
+   is
+      subtype O_Gnode_Selected_Element is O_Gnode_Type (OG_Selected_Element);
+   begin
+      if Rec.Rtype.Kind /= ON_Record_Type
+        and then Rec.Rtype.Kind /= ON_Union_Type
+      then
+         raise Type_Error;
+      end if;
+      if Rec.Rtype /= El.Parent then
+         raise Type_Error;
+      end if;
+      Check_Ref (Rec);
+      return new O_Gnode_Selected_Element'(Kind => OG_Selected_Element,
+                                           Rtype => El.Ftype,
+                                           Ref => False,
+                                           Rec_Base => Rec,
+                                           Rec_El => El);
+   end New_Global_Selected_Element;
+
    function New_Access_Element (Acc : O_Enode) return O_Lnode
    is
       subtype O_Lnode_Access_Element is O_Lnode_Type (OL_Access_Element);
@@ -1086,12 +1135,13 @@ package body Ortho_Debug is
                                   Lvalue => Lvalue);
    end New_Address;
 
-   function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+   function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
      return O_Cnode
    is
       subtype O_Cnode_Address is O_Cnode_Type (OC_Unchecked_Address);
    begin
-      Check_Scope (Decl);
+      --  FIXME: check Lvalue is a static object.
+      Check_Ref (Lvalue);
       if Atype.Kind /= ON_Access_Type then
          --  An address is of type access.
          raise Type_Error;
@@ -1099,25 +1149,27 @@ package body Ortho_Debug is
       return new O_Cnode_Address'(Kind => OC_Unchecked_Address,
                                   Ctype => Atype,
                                   Ref => False,
-                                  Decl => Decl);
+                                  Addr_Global => Lvalue);
    end New_Global_Unchecked_Address;
 
-   function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode
+   function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+                               return O_Cnode
    is
       subtype O_Cnode_Address is O_Cnode_Type (OC_Address);
    begin
-      Check_Scope (Decl);
+      --  FIXME: check Lvalue is a static object.
+      Check_Ref (Lvalue);
       if Atype.Kind /= ON_Access_Type then
          --  An address is of type access.
          raise Type_Error;
       end if;
-      if Get_Base_Type (Decl.Dtype) /= Get_Base_Type (Atype.D_Type) then
+      if Get_Base_Type (Lvalue.Rtype) /= Get_Base_Type (Atype.D_Type) then
          raise Type_Error;
       end if;
       return new O_Cnode_Address'(Kind => OC_Address,
                                   Ctype => Atype,
                                   Ref => False,
-                                  Decl => Decl);
+                                  Addr_Global => Lvalue);
    end New_Global_Address;
 
    function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
@@ -1132,7 +1184,7 @@ package body Ortho_Debug is
       return new O_Cnode_Subprg_Address'(Kind => OC_Subprogram_Address,
                                          Ctype => Atype,
                                          Ref => False,
-                                         Decl => Subprg);
+                                         Addr_Decl => Subprg);
    end New_Subprogram_Address;
 
    --  Raise TYPE_ERROR is ATYPE is a composite type.
diff --git a/src/ortho/debug/ortho_debug.private.ads b/src/ortho/debug/ortho_debug.private.ads
index a1e711b62..b505ff434 100644
--- a/src/ortho/debug/ortho_debug.private.ads
+++ b/src/ortho/debug/ortho_debug.private.ads
@@ -179,9 +179,10 @@ private
             Aggr_Value : O_Cnode;
             Aggr_Next : O_Cnode;
          when OC_Address
-           | OC_Unchecked_Address
-           | OC_Subprogram_Address =>
-            Decl : O_Dnode;
+           | OC_Unchecked_Address =>
+            Addr_Global : O_Gnode;
+         when OC_Subprogram_Address =>
+            Addr_Decl : O_Dnode;
       end case;
    end record;
 
@@ -280,12 +281,6 @@ private
       OL_Slice,
       OL_Selected_Element,
       OL_Access_Element
-
-      --  Variable, constant, parameter reference.
-      --  This allows to read/write a declaration.
-      --OL_Var_Ref,
-      --OL_Const_Ref,
-      --OL_Param_Ref
       );
 
    type O_Lnode_Type (Kind : OL_Kind);
@@ -311,10 +306,30 @@ private
             Rec_El : O_Fnode;
          when OL_Access_Element =>
             Acc_Base : O_Enode;
---          when OL_Var_Ref
---            | OL_Const_Ref
---            | OL_Param_Ref =>
---             Decl : O_Dnode;
+      end case;
+   end record;
+
+   type OG_Kind is
+     (
+      OG_Decl,
+      OG_Selected_Element
+     );
+
+   type O_Gnode_Type (Kind : OG_Kind);
+   type O_Gnode is access O_Gnode_Type;
+   O_Gnode_Null : constant O_Gnode := null;
+
+   type O_Gnode_Type (Kind : OG_Kind) is record
+      --  Type of the result.
+      Rtype : O_Tnode;
+      --  True if referenced.
+      Ref : Boolean;
+      case Kind is
+         when OG_Decl =>
+            Decl : O_Dnode;
+         when OG_Selected_Element =>
+            Rec_Base : O_Gnode;
+            Rec_El : O_Fnode;
       end case;
    end record;