ada: Reduce generated code duplication for streaming and Put_Image subprograms

In the case of an untagged composite type, the compiler does not generate
streaming-related subprograms or a Put_Image procedure when the type is
declared. Instead, these subprograms are declared "on demand" when a
corresponding attribute reference is encountered. In this case, hoist the
declaration of the implicitly declared subprogram out as far as possible
in order to maximize the chances that it can be reused (as opposed to
generating an identical second subprogram) in the case where a second
reference to the same attribute is encountered. Also relax some
privacy-related rules to allow these procedures to do what they need to do
even when constructed in a scope where some of those actions would
normally be illegal.

gcc/ada/

	* exp_attr.adb: Change name of package Cached_Streaming_Ops to
	reflect the fact that it is now also used for Put_Image
	procedures. Similarly change other "Streaming_Op" names therein.
	Add Validate_Cached_Candidate procedure to detect case where a
	subprogram found in the cache cannot be reused. Add new generic
	procedure Build_And_Insert_Type_Attr_Subp; the "Build" part is
	handled by just calling a formal procedure; the bulk of this
	(generic) procedure's code has to with deciding where in the tree
	to insert the newly-constructed subprogram. Replace each later
	"Build" call (and the following Insert_Action or
	Compile_Stream_Body_In_Scope call) with a declare block that
	instantiates and then calls this generic procedure. Delete the
	now-unused procedure Compile_Stream_Body_In_Scope. A constructed
	subprogram is entered in the appropriate cache if the
	corresponding type is untagged; this replaces more complex tests.
	A new function Interunit_Ref_OK is added to determine whether an
	attribute reference occuring in one unit can safely refer to a
	cached subprogram declared in another unit.
	* exp_ch3.adb (Build_Predefined_Primitive_Bodies): A formal
	parameter was deleted, so delete the corresponding actual in a
	call.
	* exp_put_image.adb (Build_Array_Put_Image_Procedure): Because the
	procedure being built may be referenced more than once, the
	generated procedure takes its source position info from the type
	declaration instead of the (first) attribute reference.
	(Build_Record_Put_Image_Procedure): Likewise.
	* exp_put_image.ads (Build_Array_Put_Image_Procedure): Eliminate
	now-unused Nod parameter.
	(Build_Record_Put_Image_Procedure): Eliminate now-unused Loc parameter.
	* sem_ch3.adb (Constrain_Discriminated_Type): For declaring a
	subtype with a discriminant constraint, ignore privacy if
	Comes_From_Source is false (as is already done if Is_Instance is
	true).
	* sem_res.adb (Resolve): When passed two type entities that have
	the same underlying base type, Sem_Type.Covers may return False in
	some cases because of privacy. [This can happen even if
	Is_Private_Type returns False both for Etype (N) and for Typ;
	Covers calls Base_Type, which can take a non-private argument and
	yield a private result.] If Comes_From_Source (N) is False
	(e.g., for a compiler-generated Put_Image or streaming subprogram), then
	avoid that scenario by not calling Covers. Covers already has tests for
	doing this sort of thing (see the calls therein to Full_View_Covers),
	but the Comes_From_Source test is too coarse to apply there. So instead
	we handle the problem here at the call site.
	(Original_Implementation_Base_Type): A new function. Same as
	Implementation_Base_Type except if the Original_Node attribute of
	a non-derived type declaration indicates that it once was a derived
	type declaration. Needed for looking through privacy.
	(Valid Conversion): Ignore privacy when converting between different views
	of the same type if Comes_From_Source is False for the conversion.
	(Valid_Tagged_Conversion): An ancestor-to-descendant conversion is not an
	illegal downward conversion if there is no type extension involved
	(because the derivation was from an untagged view of the parent type).

1 files changed, 74 insertions, 5 deletions

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index dc48b0b..85795ba 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -162,6 +162,10 @@ package body Sem_Res is
    --  a call, so such an operator is not treated as predefined by this
    --  predicate.
 
+   function Original_Implementation_Base_Type
+     (Id : Entity_Id) return Entity_Id;
+   --  Like Implementation_Base_Type, but looks at Original_Node.
+
    procedure Preanalyze_And_Resolve
      (N             : Node_Id;
       T             : Entity_Id;
@@ -2013,6 +2017,38 @@ package body Sem_Res is
       return Kind;
    end Operator_Kind;
 
+   ---------------------------------------
+   -- Original_Implementation_Base_Type --
+   ---------------------------------------
+
+   function Original_Implementation_Base_Type
+     (Id : Entity_Id) return Entity_Id
+   is
+      IBT       : constant Entity_Id := Implementation_Base_Type (Id);
+      IBT_Decl  : constant Node_Id := Parent (IBT);
+      Parent_Id : Node_Id;
+   begin
+      if Nkind (IBT_Decl) = N_Full_Type_Declaration
+        and then Original_Node (IBT_Decl) /= IBT_Decl
+        and then Nkind (Original_Node (IBT_Decl)) =
+                 N_Full_Type_Declaration
+        and then Nkind (Type_Definition (Original_Node (IBT_Decl)))
+                 = N_Derived_Type_Definition
+      then
+         Parent_Id := Subtype_Indication (Type_Definition
+                        (Original_Node (IBT_Decl)));
+
+         if Nkind (Parent_Id) = N_Subtype_Indication then
+            Parent_Id := Subtype_Mark (Parent_Id);
+         end if;
+
+         return Original_Implementation_Base_Type
+                  (Etype (Parent_Id));
+      else
+         return IBT;
+      end if;
+   end Original_Implementation_Base_Type;
+
    ----------------------------
    -- Preanalyze_And_Resolve --
    ----------------------------
@@ -2501,9 +2537,16 @@ package body Sem_Res is
          if Nkind (N) in N_Op and then No (Entity (N)) then
             pragma Assert (Ada_Version >= Ada_2022);
             Found := False;
+         elsif not Comes_From_Source (N) and then
+            Original_Implementation_Base_Type (Typ) =
+              Original_Implementation_Base_Type (Etype (N))
+         then
+            --  Ignore privacy for streaming or Put_Image routines
+            Found := True;
          else
             Found := Covers (Typ, Etype (N));
          end if;
+
          Expr_Type := Etype (N);
 
       --  In the overloaded case, we must select the interpretation that
@@ -13788,6 +13831,13 @@ package body Sem_Res is
          elsif Covers (Opnd_Type, Target_Type)
            or else Is_Ancestor (Opnd_Type, Target_Type)
          then
+            --  Deal with non-extension derivation involving an
+            --  untagged view of a tagged type.
+
+            if not Is_Tagged_Type (Target_Type) then
+               return True;
+            end if;
+
             return
               Conversion_Check (False,
                 "downward conversion of tagged objects not allowed");
@@ -14075,6 +14125,13 @@ package body Sem_Res is
            or else Opnd_Type = Any_Composite
            or else Opnd_Type = Any_String
          then
+            if not Comes_From_Source (N)
+              and then Implementation_Base_Type (Target_Type) =
+                       Implementation_Base_Type (Opnd_Type)
+            then
+               return True;
+            end if;
+
             Conversion_Error_N
               ("illegal operand for array conversion", Operand);
             return False;
@@ -14636,11 +14693,22 @@ package body Sem_Res is
       elsif In_Instance_Body then
          return True;
 
+      --  Ignore privacy for streaming or Put_Image routines
+
+      elsif not Comes_From_Source (N)
+        and then Original_Implementation_Base_Type (Target_Type) =
+                 Original_Implementation_Base_Type (Opnd_Type)
+      then
+         return True;
+
       --  If both are tagged types, check legality of view conversions
 
-      elsif Is_Tagged_Type (Target_Type)
-              and then
-            Is_Tagged_Type (Opnd_Type)
+      elsif (Is_Tagged_Type (Target_Type) and then Is_Tagged_Type (Opnd_Type))
+         or else (not Comes_From_Source (N)
+                  and then
+                    Is_Tagged_Type (Implementation_Base_Type (Target_Type))
+                  and then
+                    Is_Tagged_Type (Implementation_Base_Type (Opnd_Type)))
       then
          return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
 
@@ -14650,9 +14718,10 @@ package body Sem_Res is
          return True;
 
       --  In an instance or an inlined body, there may be inconsistent views of
-      --  the same type, or of types derived from a common root.
+      --  the same type, or of types derived from a common root. Similarly
+      --  for compiler-generated streaming or Put_Image subprograms.
 
-      elsif (In_Instance or In_Inlined_Body)
+      elsif (In_Instance or In_Inlined_Body or not Comes_From_Source (N))
         and then
           Root_Type (Underlying_Type (Target_Type)) =
           Root_Type (Underlying_Type (Opnd_Type))