vhdl: improve support of subtype attribute. For #641

4 files changed, 89 insertions, 26 deletions

diff --git a/src/vhdl/vhdl-sem_decls.adb b/src/vhdl/vhdl-sem_decls.adb
index c7bd4ce43..ffb55d0a7 100644
--- a/src/vhdl/vhdl-sem_decls.adb
+++ b/src/vhdl/vhdl-sem_decls.adb
@@ -1134,15 +1134,24 @@ package body Vhdl.Sem_Decls is
             --  For a variable or signal declared by an object declaration, the
             --  subtype indication of the corresponding object declaration
             --  must define a constrained array subtype.
-            if not Is_Fully_Constrained_Type (Atype) then
-               Error_Msg_Sem
-                 (+Decl,
-                  "declaration of %n with unconstrained %n is not allowed",
-                  (+Decl, +Atype));
-               if Default_Value /= Null_Iir then
-                  Error_Msg_Sem (+Decl, "(even with a default value)");
+            declare
+               Ind : constant Iir := Get_Subtype_Indication (Decl);
+            begin
+               if not (Is_Valid (Ind)
+                       and then Get_Kind (Ind) = Iir_Kind_Subtype_Attribute)
+                 and then not Is_Fully_Constrained_Type (Atype)
+               then
+                  Report_Start_Group;
+                  Error_Msg_Sem
+                    (+Decl,
+                     "declaration of %n with unconstrained %n is not allowed",
+                     (+Decl, +Atype));
+                  if Default_Value /= Null_Iir then
+                     Error_Msg_Sem (+Decl, "(even with a default value)");
+                  end if;
+                  Report_End_Group;
                end if;
-            end if;
+            end;
 
          when others =>
             Error_Kind ("sem_object_declaration(2)", Decl);
diff --git a/src/vhdl/vhdl-sem_names.adb b/src/vhdl/vhdl-sem_names.adb
index 657eea53d..7f1766b5b 100644
--- a/src/vhdl/vhdl-sem_names.adb
+++ b/src/vhdl/vhdl-sem_names.adb
@@ -1913,10 +1913,9 @@ package body Vhdl.Sem_Names is
                Free_Parenthesis_Name (Name, Res);
             end if;
             return Res;
-         when Iir_Kind_Subtype_Attribute
-           | Iir_Kind_Across_Attribute
-           | Iir_Kind_Through_Attribute
-           | Iir_Kind_Nature_Reference_Attribute =>
+         when Iir_Kind_Across_Attribute
+            | Iir_Kind_Through_Attribute
+            | Iir_Kind_Nature_Reference_Attribute =>
             null;
          when Iir_Kinds_Signal_Value_Attribute =>
             null;
@@ -1943,11 +1942,12 @@ package body Vhdl.Sem_Names is
             end if;
             return Res;
          when Iir_Kind_Dot_Attribute
-           | Iir_Kind_Integ_Attribute =>
+            | Iir_Kind_Integ_Attribute =>
             --  Already finished.
             return Res;
          when Iir_Kinds_Type_Attribute
-           |  Iir_Kind_Base_Attribute =>
+            | Iir_Kind_Subtype_Attribute
+            | Iir_Kind_Base_Attribute =>
             pragma Assert (Get_Kind (Name) = Iir_Kind_Attribute_Name);
             Free_Iir (Name);
             return Res;
@@ -3609,31 +3609,39 @@ package body Vhdl.Sem_Names is
    --  For 'Subtype
    function Sem_Subtype_Attribute (Attr : Iir_Attribute_Name) return Iir
    is
-      Prefix_Name : constant Iir := Get_Prefix (Attr);
-      Prefix : Iir;
-      Prefix_Type : Iir;
-      Res : Iir;
+      Prefix_Name : Iir;
+      Attr_Type   : Iir;
+      Res         : Iir;
    begin
-      Prefix := Get_Named_Entity (Prefix_Name);
+      Prefix_Name := Get_Prefix (Attr);
+      Prefix_Name := Finish_Sem_Name (Prefix_Name);
+      Set_Prefix (Attr, Prefix_Name);
 
       --  LRM08 16.2 Predefined attributes
       --  Prefix: Any prefix O that is appropriate for an object, or an alias
       --  thereof
-      if Get_Kind (Prefix) not in Iir_Kinds_Object_Declaration then
+      if (Get_Kind (Get_Base_Name (Prefix_Name))
+          not in Iir_Kinds_Object_Declaration)
+      then
          Error_Msg_Sem (+Attr, "prefix must denote an object");
          return Error_Mark;
       end if;
 
-      Prefix_Type := Get_Type (Prefix);
+      --  The type defined by 'subtype is always constrained.  Create
+      --  a subtype if it is not.
+      Attr_Type := Get_Type (Prefix_Name);
+      if False then
+         Attr_Type := Sem_Types.Build_Constrained_Subtype (Attr_Type, Attr);
+      end if;
 
       Res := Create_Iir (Iir_Kind_Subtype_Attribute);
       Location_Copy (Res, Attr);
-      Set_Prefix (Res, Prefix);
-      Set_Type (Res, Prefix_Type);
+      Set_Prefix (Res, Prefix_Name);
+      Set_Type (Res, Attr_Type);
 
-      Set_Base_Name (Res, Get_Base_Name (Prefix_Name));
-      Set_Name_Staticness (Res, Get_Name_Staticness (Prefix));
-      Set_Type_Staticness (Res, Get_Type_Staticness (Prefix_Type));
+      Set_Base_Name (Res, Res);
+      Set_Name_Staticness (Res, Get_Name_Staticness (Prefix_Name));
+      Set_Type_Staticness (Res, Get_Type_Staticness (Attr_Type));
 
       return Res;
    end Sem_Subtype_Attribute;
diff --git a/src/vhdl/vhdl-sem_types.adb b/src/vhdl/vhdl-sem_types.adb
index a0b9a1c4d..7b2179201 100644
--- a/src/vhdl/vhdl-sem_types.adb
+++ b/src/vhdl/vhdl-sem_types.adb
@@ -1545,6 +1545,48 @@ package body Vhdl.Sem_Types is
       return Res;
    end Copy_Subtype_Indication;
 
+   function Build_Constrained_Subtype (Atype : Iir; Loc : Iir) return Iir
+   is
+      Res : Iir;
+   begin
+      if Is_Fully_Constrained_Type (Atype) then
+         --  Already constrained, nothing to do.
+         return Atype;
+      end if;
+
+      --  The type defined by 'subtype is always constrained.  Create
+      --  a subtype if it is not.
+      case Get_Kind (Atype) is
+         when Iir_Kind_Array_Subtype_Definition
+            | Iir_Kind_Array_Type_Definition =>
+            Res := Create_Iir (Iir_Kind_Array_Subtype_Definition);
+            --  Humm, the element is also constrained...
+            Set_Element_Subtype (Res, Get_Element_Subtype (Atype));
+            Set_Index_Subtype_List (Res, Get_Index_Subtype_List (Atype));
+            Set_Index_Constraint_Flag (Res, True);
+         when Iir_Kind_Record_Subtype_Definition
+            | Iir_Kind_Record_Type_Definition =>
+            Res := Create_Iir (Iir_Kind_Record_Subtype_Definition);
+            --  Humm, the elements are also constrained.
+            Set_Elements_Declaration_List
+              (Res, Get_Elements_Declaration_List (Atype));
+            Set_Is_Ref (Res, True);
+         when others =>
+            Error_Kind ("build_constrained_subtype", Atype);
+      end case;
+      Location_Copy (Res, Loc);
+      --  FIXME: can be globally!
+      Set_Type_Staticness (Res, None);
+      Set_Base_Type (Res, Get_Base_Type (Atype));
+      Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Atype));
+      Set_Resolved_Flag (Res, Get_Resolved_Flag (Atype));
+      Set_Constraint_State (Res, Fully_Constrained);
+      if Get_Kind (Atype) in Iir_Kinds_Subtype_Definition then
+         Set_Resolution_Indication (Res, Copy_Resolution_Indication (Atype));
+      end if;
+      return Res;
+   end Build_Constrained_Subtype;
+
    --  DEF is an array_subtype_definition or array_subnature_definition
    --   which contains indexes constraints.
    --  MARK_DEF is the parent type or nature, given by the type or nature mark.
diff --git a/src/vhdl/vhdl-sem_types.ads b/src/vhdl/vhdl-sem_types.ads
index 996dae14f..406ec9bce 100644
--- a/src/vhdl/vhdl-sem_types.ads
+++ b/src/vhdl/vhdl-sem_types.ads
@@ -56,6 +56,10 @@ package Vhdl.Sem_Types is
    --  none.
    function Copy_Resolution_Indication (Subdef : Iir) return Iir;
 
+   --  If ATYPE is not fully constrained, build a fully constrained subtype.
+   --  This is for 'subtype attribute.
+   function Build_Constrained_Subtype (Atype : Iir; Loc : Iir) return Iir;
+
    --  Adjust the constraint state CONSTRAINT given new element EL_TYPE.
    --  Initially CONSTRAINT must be Fully_Constrained and COMPOSITE_FOUND
    --  must be false.