From: Steve Baird <baird@adacore.com>
Date: Wed, 3 Sep 2025 19:21:10 +0000 (-0700)
Subject: ada: Compiler crashes on subunits with Streaming/Put_Image attribute references
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=d832626b1a076eac6232a5b74deee98dd83002f4;p=thirdparty%2Fgcc.git

ada: Compiler crashes on subunits with Streaming/Put_Image attribute references

When necessary, the compiler builds subprograms to implement the streaming
attributes (or the Put_Image attribute) for a type. In some cases involving
separate subunits, these compiler-generated subprograms were inserted at the
wrong point in the tree, resulting in internal compiler errors.

gcc/ada/ChangeLog:

	* exp_attr.adb (Interunit_Ref_OK): Treat a subunit like a body.
	(Build_And_Insert_Type_Attr_Subp): When climbing up the
	tree, go from an N_Subunit node to its stub (instead of to the
	subunit's N_Compilation_Unit node).
---

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index a7255da9018..a0a550ddbd7 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -265,6 +265,15 @@ package body Exp_Attr is
    --  the implementation base type of this type (Typ). If found, return the
    --  pragma node, otherwise return Empty if no pragma is found.
 
+   function Interunit_Ref_OK
+     (Subp_Unit, Attr_Ref_Unit : Node_Id) return Boolean;
+   --  Returns True if it is ok to refer to a cached subprogram declared in
+   --  Subp_Unit from the point of an attribute reference occurring in
+   --  Attr_Ref_Unit. Both arguments are usually N_Compilation_Nodes,
+   --  although there are cases where Subp_Unit might be a type declared in
+   --  package Standard (in which case the In_Same_Extended_Unit call will
+   --  return False).
+
    function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
    --  Utility for array attributes, returns true on packed constrained
    --  arrays, and on access to same.
@@ -279,20 +288,6 @@ package body Exp_Attr is
    --  Returns True if Typ is a user-defined enumeration type, in the sense
    --  that its literals are declared in the source.
 
-   function Interunit_Ref_OK
-     (Subp_Unit, Attr_Ref_Unit : Node_Id) return Boolean is
-       (In_Same_Extended_Unit (Subp_Unit, Attr_Ref_Unit)
-         --  If subp declared in unit body, then we don't want to refer
-         --  to it from within unit spec so return False in that case.
-         and then not (not Is_Body (Unit (Attr_Ref_Unit))
-                       and Is_Body (Unit (Subp_Unit))));
-   --  Returns True if it is ok to refer to a cached subprogram declared in
-   --  Subp_Unit from the point of an attribute reference occurring in
-   --  Attr_Ref_Unit. Both arguments are usually N_Compilation_Nodes,
-   --  although there are cases where Subp_Unit might be a type declared in
-   --  package Standard (in which case the In_Same_Extended_Unit call will
-   --  return False).
-
    package body Cached_Attribute_Ops is
 
       -------------------------------
@@ -2020,7 +2015,12 @@ package body Exp_Attr is
 
                   pragma Assert (Present (Insertion_Point));
                end if;
-               Ancestor := Parent (Ancestor);
+
+               if Nkind (Ancestor) = N_Subunit then
+                  Ancestor := Corresponding_Stub (Ancestor);
+               else
+                  Ancestor := Parent (Ancestor);
+               end if;
             end loop;
 
             if Present (Insertion_Point) then
@@ -9600,6 +9600,31 @@ package body Exp_Attr is
       return Empty;
    end Get_Stream_Convert_Pragma;
 
+   ----------------------
+   -- Interunit_Ref_OK --
+   ----------------------
+
+   function Interunit_Ref_OK
+     (Subp_Unit, Attr_Ref_Unit : Node_Id) return Boolean is
+
+      function Unit_Is_Body_Or_Subunit (U : Node_Id) return Boolean is
+        (Is_Body (Unit (U)) or else Nkind (Unit (U)) = N_Subunit);
+   begin
+      if not In_Same_Extended_Unit (Subp_Unit, Attr_Ref_Unit) then
+         return False;
+
+      --  If subp declared in unit body, then we don't want to refer
+      --  to it from within unit spec so return False in that case.
+
+      elsif Unit_Is_Body_Or_Subunit (Subp_Unit)
+        and then not Unit_Is_Body_Or_Subunit (Attr_Ref_Unit)
+      then
+         return False;
+      end if;
+
+      return True;
+   end Interunit_Ref_OK;
+
    ---------------------------------
    -- Is_Constrained_Packed_Array --
    ---------------------------------