From b8ea7696f5e7fee31fb39c13e08a241514caecd4 Mon Sep 17 00:00:00 2001
From: Tristan Gingold <tgingold@free.fr>
Date: Sun, 1 Mar 2020 11:47:31 +0100
Subject: vhdl: a function call is not an object.  Fix #1138.

Report a warning (or an error if not relaxed) when a non-object name
is used for an array attribute.
Also consider subtype attribute as a type name.
---
 src/errorout.ads            |  5 ++++-
 src/vhdl/vhdl-sem_names.adb |  6 ++++++
 src/vhdl/vhdl-utils.adb     | 37 +++++++++++++++++++++++--------------
 3 files changed, 33 insertions(+), 15 deletions(-)

diff --git a/src/errorout.ads b/src/errorout.ads
index 0ec341514..763a8344b 100644
--- a/src/errorout.ads
+++ b/src/errorout.ads
@@ -108,6 +108,9 @@ package Errorout is
       --  Assertion during analysis.
       Warnid_Analyze_Assert,
 
+      --  Incorrect use of attributes (like non-object prefix).
+      Warnid_Attribute,
+
       --  Violation of staticness rules
       Warnid_Static,
 
@@ -298,7 +301,7 @@ private
    Default_Warnings : constant Warnings_Setting :=
      (Warnid_Library | Warnid_Binding | Warnid_Port | Warnid_Shared
         | Warnid_Runtime_Error | Warnid_Pure | Warnid_Specs | Warnid_Hide
-        | Warnid_Pragma | Warnid_Analyze_Assert
+        | Warnid_Pragma | Warnid_Analyze_Assert | Warnid_Attribute
         | Msgid_Warning  => (Enabled => True, Error => False),
       others             => (Enabled => False, Error => False));
 
diff --git a/src/vhdl/vhdl-sem_names.adb b/src/vhdl/vhdl-sem_names.adb
index b02fdedd4..ebed95997 100644
--- a/src/vhdl/vhdl-sem_names.adb
+++ b/src/vhdl/vhdl-sem_names.adb
@@ -962,6 +962,7 @@ package body Vhdl.Sem_Names is
       Parent : Iir;
    begin
       if Get_Kind (Base) in Iir_Kinds_Dereference then
+         --  A dereferenced object is never static.
          return None;
       end if;
 
@@ -1039,6 +1040,11 @@ package body Vhdl.Sem_Names is
          then
             Prefix := Function_Declaration_To_Call (Prefix);
          end if;
+         if not Is_Object_Name (Prefix) then
+            Error_Msg_Sem_Relaxed
+              (Attr, Warnid_Attribute,
+               "prefix of array attribute must be an object name");
+         end if;
       end if;
       Set_Prefix (Attr, Prefix);
 
diff --git a/src/vhdl/vhdl-utils.adb b/src/vhdl/vhdl-utils.adb
index d11b17a2b..421bf4474 100644
--- a/src/vhdl/vhdl-utils.adb
+++ b/src/vhdl/vhdl-utils.adb
@@ -393,6 +393,10 @@ package body Vhdl.Utils is
          when Iir_Kind_Slice_Name
            | Iir_Kind_Indexed_Name
            | Iir_Kind_Selected_Element =>
+            if Name_To_Object (Get_Prefix (Name)) = Null_Iir then
+               --  The prefix may not be an object.
+               return Null_Iir;
+            end if;
             return Name;
 
          --  An object designated by a value of an access type
@@ -1034,20 +1038,25 @@ package body Vhdl.Utils is
    is
       Ent : Iir;
    begin
-      if Get_Kind (Name) in Iir_Kinds_Denoting_Name then
-         Ent := Get_Named_Entity (Name);
-         case Get_Kind (Ent) is
-            when Iir_Kind_Type_Declaration =>
-               return Get_Type_Definition (Ent);
-            when Iir_Kind_Subtype_Declaration
-              | Iir_Kind_Base_Attribute =>
-               return Get_Type (Ent);
-            when others =>
-               return Null_Iir;
-         end case;
-      else
-         return Null_Iir;
-      end if;
+      case Get_Kind (Name) is
+         when Iir_Kinds_Denoting_Name
+           | Iir_Kind_Attribute_Name =>
+            Ent := Get_Named_Entity (Name);
+            case Get_Kind (Ent) is
+               when Iir_Kind_Type_Declaration =>
+                  return Get_Type_Definition (Ent);
+               when Iir_Kind_Subtype_Declaration
+                 | Iir_Kind_Base_Attribute
+                 | Iir_Kind_Subtype_Attribute =>
+                  return Get_Type (Ent);
+               when others =>
+                  return Null_Iir;
+            end case;
+         when Iir_Kind_Subtype_Attribute =>
+            return Get_Type (Ent);
+         when others =>
+            return Null_Iir;
+      end case;
    end Is_Type_Name;
 
    function Get_Type_Of_Subtype_Indication (Ind : Iir) return Iir is
-- 
cgit v1.2.3