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

Add a type check in mcode for New_Address.

7 files changed, 73 insertions, 17 deletions

diff --git a/ortho/debug/ortho_debug.adb b/ortho/debug/ortho_debug.adb
index 723fe3c..bed2e72 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 4f71407..b2dfa1a 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 7956965..d157228 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 c8d8cc0..86a6c2c 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;
 
diff --git a/testsuite/gna/bug21497/repro.vhdl b/testsuite/gna/bug21497/repro.vhdl
new file mode 100755
index 0000000..fe6e1c3
--- /dev/null
+++ b/testsuite/gna/bug21497/repro.vhdl
@@ -0,0 +1,19 @@
+entity tb is
+  generic (low : integer := 1 ; high : integer := 10);
+end;
+
+architecture behav of tb is
+begin
+   process
+     type  st_arr1 is array (low to high) of integer;
+
+     type  st_arr2 is array (low to high) of st_arr1;
+     constant c_st_arr2 : st_arr2 := (others => (others => 1));
+
+     type a_st_arr2 is access st_arr2;
+     variable v_st_arr2 : a_st_arr2 := new st_arr2'(c_st_arr2) ;
+   begin
+     assert v_st_arr2.all = c_st_arr2 severity failure;
+     wait;
+   end process ;
+end behav;
diff --git a/testsuite/gna/bug21497/testsuite.sh b/testsuite/gna/bug21497/testsuite.sh
new file mode 100755
index 0000000..5322424
--- /dev/null
+++ b/testsuite/gna/bug21497/testsuite.sh
@@ -0,0 +1,11 @@
+#! /bin/sh
+
+. ../../testenv.sh
+
+
+analyze repro.vhdl
+elab_simulate tb
+
+clean
+
+echo "Test successful"
diff --git a/translate/translation.adb b/translate/translation.adb
index bb1e06c..926dc60 100644
--- a/translate/translation.adb
+++ b/translate/translation.adb
@@ -6575,7 +6575,7 @@ package body Translation is
            or else not Info.Type_Locally_Constrained
          then
             --  This is a complex type as the size is not known at compile
-            --- time.
+            --  time.
             Info.Ortho_Type := Binfo.T.Base_Ptr_Type;
             Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type;
 
@@ -6993,16 +6993,12 @@ package body Translation is
       --------------
       procedure Translate_Access_Type (Def : Iir_Access_Type_Definition)
       is
-         D_Type : Iir;
-         D_Info : Ortho_Info_Acc;
+         D_Type : constant Iir := Get_Designated_Type (Def);
+         D_Info : constant Ortho_Info_Acc := Get_Info (D_Type);
+         Def_Info : constant Type_Info_Acc := Get_Info (Def);
          Dtype : O_Tnode;
-         Def_Info : Type_Info_Acc;
          Arr_Info : Type_Info_Acc;
       begin
-         D_Type := Get_Designated_Type (Def);
-         D_Info := Get_Info (D_Type);
-         Def_Info := Get_Info (Def);
-
          if not Is_Fully_Constrained_Type (D_Type) then
             --  An access type to an unconstrained type definition is a fat
             --  pointer.
@@ -7023,8 +7019,19 @@ package body Translation is
          else
             --  Otherwise, it is a thin pointer.
             Def_Info.Type_Mode := Type_Mode_Acc;
+            --  No access types for signals.
+            Def_Info.Ortho_Type (Mode_Signal) := O_Tnode_Null;
+
             if D_Info.Kind = Kind_Incomplete_Type then
                Dtype := O_Tnode_Null;
+            elsif Is_Complex_Type (D_Info) then
+               --  The type for a complex type is already a pointer, do not
+               --  create a new indirection.
+               Def_Info.Ortho_Type (Mode_Value) :=
+                 D_Info.Ortho_Type (Mode_Value);
+               Finish_Type_Definition (Def_Info, True);
+               --  FIXME: avoid this return in the middle of the code.
+               return;
             elsif D_Info.Type_Mode in Type_Mode_Arrays then
                --  The designated type cannot be a sub array inside ortho.
                Dtype := D_Info.T.Base_Type (Mode_Value);
@@ -7032,7 +7039,6 @@ package body Translation is
                Dtype := D_Info.Ortho_Type (Mode_Value);
             end if;
             Def_Info.Ortho_Type (Mode_Value) := New_Access_Type (Dtype);
-            Def_Info.Ortho_Type (Mode_Signal) := O_Tnode_Null;
             Finish_Type_Definition (Def_Info);
          end if;
       end Translate_Access_Type;
@@ -13417,13 +13423,10 @@ package body Translation is
 
       function Translate_Name (Name : Iir) return Mnode
       is
-         Name_Type : Iir;
-         Name_Info : Ortho_Info_Acc;
-         Type_Info : Type_Info_Acc;
+         Name_Type : constant Iir := Get_Type (Name);
+         Name_Info : constant Ortho_Info_Acc := Get_Info (Name);
+         Type_Info : constant Type_Info_Acc := Get_Info (Name_Type);
       begin
-         Name_Type := Get_Type (Name);
-         Name_Info := Get_Info (Name);
-         Type_Info := Get_Info (Name_Type);
          case Get_Kind (Name) is
             when Iir_Kind_Constant_Declaration
               | Iir_Kind_Variable_Declaration