Fix bug21497: do not create an indirection for access to complex type.

Add a type check in mcode for New_Address.

4 files changed, 25 insertions, 2 deletions

diff --git a/ortho/debug/ortho_debug.adb b/ortho/debug/ortho_debug.adb
index 723fe3cd6..bed2e722e 100644
--- a/ortho/debug/ortho_debug.adb
+++ b/ortho/debug/ortho_debug.adb
@@ -19,6 +19,9 @@
 with Ada.Unchecked_Deallocation;
 
 package body Ortho_Debug is
+   --  If True, disable some checks so that the output can be generated.
+   Disable_Checks : constant Boolean := False;
+
    --  Metrics:
    --  Alignment and size for an address.
    Metric_Access_Align : constant Natural := 2;
@@ -844,7 +847,6 @@ package body Ortho_Debug is
       end case;
    end Get_Base_Type;
 
-
    procedure Start_Record_Aggr (List : out O_Record_Aggr_List; Atype : O_Tnode)
    is
       subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate);
@@ -1118,7 +1120,9 @@ package body Ortho_Debug is
          raise Type_Error;
       end if;
       if Get_Base_Type (Lvalue.Rtype) /= Get_Base_Type (Atype.D_Type) then
-         raise Type_Error;
+         if not Disable_Checks then
+            raise Type_Error;
+         end if;
       end if;
       return new O_Enode_Address'(Kind => OE_Address,
                                   Rtype => Atype,
diff --git a/ortho/mcode/ortho_code-exprs.adb b/ortho/mcode/ortho_code-exprs.adb
index 4f7140753..b2dfa1a67 100644
--- a/ortho/mcode/ortho_code-exprs.adb
+++ b/ortho/mcode/ortho_code-exprs.adb
@@ -1035,6 +1035,11 @@ package body Ortho_Code.Exprs is
          if Get_Type_Kind (Atype) /= OT_Access then
             raise Syntax_Error;
          end if;
+         if Get_Base_Type (Get_Enode_Type (O_Enode (Lvalue)))
+           /= Get_Base_Type (Get_Type_Access_Type (Atype))
+         then
+            raise Syntax_Error;
+         end if;
          Check_Ref (Lvalue);
       end if;
 
diff --git a/ortho/mcode/ortho_code-types.adb b/ortho/mcode/ortho_code-types.adb
index 79569653d..d15722865 100644
--- a/ortho/mcode/ortho_code-types.adb
+++ b/ortho/mcode/ortho_code-types.adb
@@ -774,6 +774,17 @@ package body Ortho_Code.Types is
       end case;
    end Get_Type_Next;
 
+   function Get_Base_Type (Atype : O_Tnode) return O_Tnode
+   is
+   begin
+      case Get_Type_Kind (Atype) is
+         when OT_Subarray =>
+            return Get_Type_Subarray_Base (Atype);
+         when others =>
+            return Atype;
+      end case;
+   end Get_Base_Type;
+
    procedure Mark (M : out Mark_Type) is
    begin
       M.Tnode := Tnodes.Last;
diff --git a/ortho/mcode/ortho_code-types.ads b/ortho/mcode/ortho_code-types.ads
index c8d8cc03f..86a6c2cd3 100644
--- a/ortho/mcode/ortho_code-types.ads
+++ b/ortho/mcode/ortho_code-types.ads
@@ -149,6 +149,9 @@ package Ortho_Code.Types is
    function New_Constrained_Array_Type (Atype : O_Tnode; Length : Uns32)
      return O_Tnode;
 
+   --  Return the base type of ATYPE: for a subarray this is the uc array,
+   --  otherwise this is the type.
+   function Get_Base_Type (Atype : O_Tnode) return O_Tnode;
 
    type O_Element_List is limited private;