vhdl: handle 'element in 'range. Fix #2071

2 files changed, 104 insertions, 23 deletions

diff --git a/src/vhdl/translate/trans-chap14.adb b/src/vhdl/translate/trans-chap14.adb
index 31c000bd3..c66961954 100644
--- a/src/vhdl/translate/trans-chap14.adb
+++ b/src/vhdl/translate/trans-chap14.adb
@@ -31,22 +31,57 @@ with Trans.Foreach_Non_Composite;
 package body Trans.Chap14 is
    use Trans.Helpers;
 
+   function Translate_Name_Bounds (Name : Iir) return Mnode
+   is
+      Res : Mnode;
+   begin
+      case Get_Kind (Name) is
+         when Iir_Kinds_Denoting_Name =>
+            return Translate_Name_Bounds (Get_Named_Entity (Name));
+         when Iir_Kind_Type_Declaration
+           | Iir_Kind_Subtype_Declaration =>
+            Res := T2M (Get_Type (Name), Mode_Value);
+            Res := Chap3.Get_Composite_Bounds (Res);
+            return Res;
+         when Iir_Kinds_Object_Declaration
+           | Iir_Kind_Stable_Attribute
+           | Iir_Kind_Quiet_Attribute
+           | Iir_Kind_Delayed_Attribute
+           | Iir_Kind_Transaction_Attribute
+           | Iir_Kind_Image_Attribute
+           | Iir_Kind_Indexed_Name
+           | Iir_Kind_Selected_Element
+           | Iir_Kind_Slice_Name
+           | Iir_Kind_Dereference
+           | Iir_Kind_Implicit_Dereference
+           | Iir_Kind_Function_Call =>
+            --  Prefix is an object.
+            Res := Chap6.Translate_Name (Name, Mode_Value);
+            Res := Chap3.Get_Composite_Bounds (Res);
+            return Res;
+         when Iir_Kind_Element_Attribute =>
+            declare
+               Pfx : constant Iir := Get_Prefix (Name);
+               Pfx_Type : constant Iir := Get_Type (Pfx);
+            begin
+               Res := Translate_Name_Bounds (Pfx);
+               Res := Chap3.Array_Bounds_To_Element_Bounds (Res, Pfx_Type);
+               return Res;
+            end;
+         when others =>
+            Error_Kind ("translate_name_bounds", Name);
+      end case;
+   end Translate_Name_Bounds;
+
    function Translate_Array_Attribute_To_Range (Expr : Iir) return Mnode
    is
-      Prefix    : constant Iir := Get_Prefix (Expr);
-      Type_Name : constant Iir := Is_Type_Name (Prefix);
-      Arr       : Mnode;
-      Dim       : Natural;
+      Prefix : constant Iir := Get_Prefix (Expr);
+      Bnd : Mnode;
+      Dim : Natural;
    begin
-      if Type_Name /= Null_Iir then
-         --  Prefix denotes a type name
-         Arr := T2M (Type_Name, Mode_Value);
-      else
-         --  Prefix is an object.
-         Arr := Chap6.Translate_Name (Prefix, Mode_Value);
-      end if;
+      Bnd := Translate_Name_Bounds (Prefix);
       Dim := Eval_Attribute_Parameter_Or_1 (Expr);
-      return Chap3.Get_Array_Range (Arr, Get_Type (Prefix), Dim);
+      return Chap3.Bounds_To_Range (Bnd, Get_Type (Prefix), Dim);
    end Translate_Array_Attribute_To_Range;
 
    function Translate_Range_Array_Attribute (Expr : Iir)
diff --git a/src/vhdl/vhdl-sem_names.adb b/src/vhdl/vhdl-sem_names.adb
index d38f78ee5..c9608f2c2 100644
--- a/src/vhdl/vhdl-sem_names.adb
+++ b/src/vhdl/vhdl-sem_names.adb
@@ -3592,6 +3592,37 @@ package body Vhdl.Sem_Names is
       return Res;
    end Sem_Predefined_Type_Attribute;
 
+   function Is_Element_Attribute_Prefix_A_Type (Prefix : Iir) return Boolean
+   is
+      Pfx : Iir;
+      Ent : Iir;
+   begin
+      Pfx := Prefix;
+      loop
+         case Get_Kind (Pfx) is
+            when Iir_Kinds_Denoting_Name
+              | Iir_Kind_Attribute_Name =>
+               Ent := Get_Named_Entity (Pfx);
+               case Get_Kind (Ent) is
+                  when Iir_Kind_Type_Declaration
+                    | Iir_Kind_Subtype_Declaration
+                    | Iir_Kind_Base_Attribute =>
+                     return True;
+                  when Iir_Kind_Element_Attribute =>
+                     --  Continue.
+                     Pfx := Get_Prefix (Ent);
+                  when others =>
+                     return False;
+               end case;
+            when Iir_Kind_Element_Attribute =>
+               --  Continue
+               Pfx := Get_Prefix (Pfx);
+            when others =>
+               return False;
+         end case;
+      end loop;
+   end Is_Element_Attribute_Prefix_A_Type;
+
    --  Called for attributes Length, Left, Right, High, Low, Range,
    --  Reverse_Range, Ascending.
    --  FIXME: handle overload
@@ -3603,6 +3634,7 @@ package body Vhdl.Sem_Names is
       Prefix : Iir;
       Res : Iir;
       Res_Type : Iir;
+      Is_Prefix_Object : Boolean;
    begin
       Prefix := Get_Named_Entity (Prefix_Name);
 
@@ -3637,6 +3669,7 @@ package body Vhdl.Sem_Names is
            | Iir_Kind_Attribute_Value
            | Iir_Kind_Image_Attribute =>
             --  FIXME: list of expr.
+            Is_Prefix_Object := True;
             Prefix_Type := Get_Type (Prefix);
             case Get_Kind (Prefix_Type) is
                when Iir_Kind_Access_Type_Definition
@@ -3657,21 +3690,24 @@ package body Vhdl.Sem_Names is
             end case;
          when Iir_Kind_Subtype_Declaration
            | Iir_Kind_Type_Declaration
-           | Iir_Kind_Base_Attribute
-           | Iir_Kind_Subtype_Attribute
-           | Iir_Kind_Element_Attribute =>
+           | Iir_Kind_Base_Attribute =>
+            Is_Prefix_Object := False;
+            Prefix_Type := Get_Type (Prefix);
+         when Iir_Kind_Subtype_Attribute =>
+            --  Always constrained as the prefix is an object.
+            Is_Prefix_Object := True;
             Prefix_Type := Get_Type (Prefix);
-            if not Is_Fully_Constrained_Type (Prefix_Type) then
-               Error_Msg_Sem (+Attr, "prefix type is not constrained");
-               --  We continue using the unconstrained array type.
-               --  At least, this type is valid; and even if the array was
-               --  constrained, the base type would be the same.
-            end if;
          when Iir_Kind_Range_Array_Attribute
-           | Iir_Kind_Reverse_Range_Array_Attribute =>
+            | Iir_Kind_Reverse_Range_Array_Attribute =>
             --  For names such as pfx'Range'Left.
-            --  Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Null_Iir);
+            Is_Prefix_Object := False;  --  Doesn't matter, it's scalar.
             Prefix_Type := Get_Type (Prefix);
+         when Iir_Kind_Element_Attribute =>
+            Prefix_Type := Get_Type (Prefix);
+            --  We need to know if the prefix is or denotes an object, as in
+            --  that case the type is constrained.
+            Is_Prefix_Object :=
+              not Is_Element_Attribute_Prefix_A_Type (Prefix);
          when Iir_Kind_Process_Statement =>
             Error_Msg_Sem
               (+Attr, "%n is not an appropriate prefix for %i attribute",
@@ -3695,6 +3731,16 @@ package body Vhdl.Sem_Names is
             return Error_Mark;
       end case;
 
+      --  If the prefix is an object, we know its type is constrained.
+      if not Is_Prefix_Object
+        and then not Get_Index_Constraint_Flag (Prefix_Type)
+      then
+         Error_Msg_Sem (+Attr, "prefix type is not constrained");
+         --  We continue using the unconstrained array type.
+         --  At least, this type is valid; and even if the array was
+         --  constrained, the base type would be the same.
+      end if;
+
       --  Type of the attribute.  This is correct unless there is a parameter,
       --  and furthermore 'range and 'reverse_range has to be handled
       --  specially because the result is a range and not a value.