From aeb15c6d168fd032689c85fdb42e2a4904bfbd6f Mon Sep 17 00:00:00 2001
From: Tristan Gingold <tgingold@free.fr>
Date: Sun, 30 Apr 2023 19:05:16 +0200
Subject: vhdl-sem_specs: allow attribute specification on a type if -frelaxed

Fix #2427
---
 src/errorout.ads            |  1 +
 src/vhdl/vhdl-sem_specs.adb | 31 +++++++++++++++++++++----------
 2 files changed, 22 insertions(+), 10 deletions(-)

diff --git a/src/errorout.ads b/src/errorout.ads
index d49ff5b5a..676c5b519 100644
--- a/src/errorout.ads
+++ b/src/errorout.ads
@@ -78,6 +78,7 @@ package Errorout is
 
       --  An all/others specification does not apply, because there is no such
       --  named entities.
+      --  Attribute specification of class type to an anonymous type.
       Warnid_Specs,
 
       --  Incorrect use of universal value.
diff --git a/src/vhdl/vhdl-sem_specs.adb b/src/vhdl/vhdl-sem_specs.adb
index dbc3e376c..9ff333a28 100644
--- a/src/vhdl/vhdl-sem_specs.adb
+++ b/src/vhdl/vhdl-sem_specs.adb
@@ -242,6 +242,8 @@ package body Vhdl.Sem_Specs is
       Attr_Decl : Iir;
 
       Attr_Chain_Parent : Iir;
+
+      Is_Anon_Type : Boolean;
    begin
       --  LRM93 5.1
       --  It is an error if the class of those names is not the same as that
@@ -250,22 +252,31 @@ package body Vhdl.Sem_Specs is
         and then Get_Entity_Class_Kind (Decl) /= Attr_Class
       then
          if Check_Class then
-            Error_Msg_Sem
-              (+Attr, "%n is not of class %t", (+Decl, +Attr_Class));
-            if Get_Kind (Decl) = Iir_Kind_Subtype_Declaration
+            --  If -frelaxed, specifying an attribute of class 'type' to
+            --  an anonynous type declaration is allowed.
+            Is_Anon_Type := Get_Kind (Decl) = Iir_Kind_Subtype_Declaration
               and then Get_Entity_Class (Attr) = Tok_Type
               and then Get_Type (Decl) /= Null_Iir
               and then Get_Base_Type (Get_Type (Decl)) /= Null_Iir
-              and then Get_Kind
-              (Get_Type_Declarator (Get_Base_Type (Get_Type (Decl))))
-              = Iir_Kind_Anonymous_Type_Declaration
-            then
+              and then (Get_Kind (Get_Type_Declarator
+                                   (Get_Base_Type (Get_Type (Decl))))
+                          = Iir_Kind_Anonymous_Type_Declaration);
+
+            if Is_Anon_Type then
                --  The type declaration declares an anonymous type
                --  and a named subtype.
-               Error_Msg_Sem
-                 (+Decl,
+               Report_Start_Group;
+               Error_Msg_Sem_Relaxed
+                 (Attr, Warnid_Specs,
+                  "%n is not of class %t", (+Decl, +Attr_Class));
+               Error_Msg_Sem_Relaxed
+                 (Decl, Warnid_Specs,
                   "%i declares both an anonymous type and a named subtype",
-                  +Decl);
+                  (1 => +Decl));
+               Report_End_Group;
+            else
+               Error_Msg_Sem
+                 (+Attr, "%n is not of class %t", (+Decl, +Attr_Class));
             end if;
          end if;
          return;
-- 
cgit v1.2.3