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, 396 insertions, 231 deletions

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 809116d..b727711 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -80,12 +80,12 @@ with GNAT.HTable;
 
 package body Exp_Attr is
 
-   package Cached_Streaming_Ops is
+   package Cached_Attribute_Ops is
 
       Map_Size : constant := 63;
       subtype Header_Num is Integer range 0 .. Map_Size - 1;
 
-      function Streaming_Op_Hash (Id : Entity_Id) return Header_Num is
+      function Attribute_Op_Hash (Id : Entity_Id) return Header_Num is
         (Header_Num (Id mod Map_Size));
 
       --  Cache used to avoid building duplicate subprograms for a single
@@ -96,7 +96,7 @@ package body Exp_Attr is
          Key        => Entity_Id,
          Element    => Entity_Id,
          No_Element => Empty,
-         Hash       => Streaming_Op_Hash,
+         Hash       => Attribute_Op_Hash,
          Equal      => "=");
 
       package Write_Map is new GNAT.HTable.Simple_HTable
@@ -104,7 +104,7 @@ package body Exp_Attr is
          Key        => Entity_Id,
          Element    => Entity_Id,
          No_Element => Empty,
-         Hash       => Streaming_Op_Hash,
+         Hash       => Attribute_Op_Hash,
          Equal      => "=");
 
       package Input_Map is new GNAT.HTable.Simple_HTable
@@ -112,7 +112,7 @@ package body Exp_Attr is
          Key        => Entity_Id,
          Element    => Entity_Id,
          No_Element => Empty,
-         Hash       => Streaming_Op_Hash,
+         Hash       => Attribute_Op_Hash,
          Equal      => "=");
 
       package Output_Map is new GNAT.HTable.Simple_HTable
@@ -120,10 +120,25 @@ package body Exp_Attr is
          Key        => Entity_Id,
          Element    => Entity_Id,
          No_Element => Empty,
-         Hash       => Streaming_Op_Hash,
+         Hash       => Attribute_Op_Hash,
          Equal      => "=");
 
-   end Cached_Streaming_Ops;
+      package Put_Image_Map is new GNAT.HTable.Simple_HTable
+        (Header_Num => Header_Num,
+         Key        => Entity_Id,
+         Element    => Entity_Id,
+         No_Element => Empty,
+         Hash       => Attribute_Op_Hash,
+         Equal      => "=");
+
+      procedure Validate_Cached_Candidate
+        (Subp     : in out Entity_Id;
+         Attr_Ref : Node_Id);
+      --  If Subp is non-empty but it is not callable from the point of
+      --  Attr_Ref (perhaps because it is not visible from that point),
+      --  then Subp is set to Empty. Otherwise, do nothing.
+
+   end Cached_Attribute_Ops;
 
    -----------------------
    -- Local Subprograms --
@@ -163,32 +178,6 @@ package body Exp_Attr is
    --
    --    * Rec_Typ - the record type whose internals are to be validated
 
-   procedure Compile_Stream_Body_In_Scope
-     (N     : Node_Id;
-      Decl  : Node_Id;
-      Arr   : Entity_Id);
-   --  The body for a stream subprogram may be generated outside of the scope
-   --  of the type. If the type is fully private, it may depend on the full
-   --  view of other types (e.g. indexes) that are currently private as well.
-   --  We install the declarations of the package in which the type is declared
-   --  before compiling the body in what is its proper environment. The Check
-   --  parameter indicates if checks are to be suppressed for the stream body.
-   --  We suppress checks for array/record reads, since the rule is that these
-   --  are like assignments, out of range values due to uninitialized storage,
-   --  or other invalid values do NOT cause a Constraint_Error to be raised.
-   --  If we are within an instance body all visibility has been established
-   --  already and there is no need to install the package.
-
-   --  This mechanism is now extended to the component types of the array type,
-   --  when the component type is not in scope and is private, to handle
-   --  properly the case when the full view has defaulted discriminants.
-
-   --  This special processing is ultimately caused by the fact that the
-   --  compiler lacks a well-defined phase when full views are visible
-   --  everywhere. Having such a separate pass would remove much of the
-   --  special-case code that shuffles partial and full views in the middle
-   --  of semantic analysis and expansion.
-
    function Default_Streaming_Unavailable (Typ : Entity_Id) return Boolean;
    --
    --  In most cases, references to unavailable streaming attributes
@@ -286,6 +275,76 @@ package body Exp_Attr is
    --  expansion. Typically used for rounding and truncation attributes that
    --  appear directly inside a conversion to integer.
 
+   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 (Body_Required (Attr_Ref_Unit)
+                       and not Body_Required (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
+
+      -------------------------------
+      -- Validate_Cached_Candidate --
+      -------------------------------
+
+      procedure Validate_Cached_Candidate
+        (Subp     : in out Entity_Id;
+         Attr_Ref : Node_Id) is
+      begin
+         if No (Subp) then
+            return;
+         end if;
+
+         declare
+            Subp_Comp_Unit     : constant Node_Id :=
+              Enclosing_Comp_Unit_Node (Subp);
+            Attr_Ref_Comp_Unit : constant Node_Id :=
+              Enclosing_Comp_Unit_Node (Attr_Ref);
+
+            --  The preceding Enclosing_Comp_Unit_Node calls are needed
+            --  (as opposed to changing Interunit_Ref_OK so that it could
+            --  be passed Subp and Attr_Ref) because the games we play
+            --  with source position info for these conjured-up routines can
+            --  confuse In_Same_Extended_Unit (which is called from in
+            --  Interunit_Ref_OK) in the case where one of these
+            --  conjured-up routines contains an attribute reference
+            --  denoting another such routine (e.g., if the Put_Image routine
+            --  for a composite type contains a Some_Component_Type'Put_Image
+            --  attribute reference). Calling Enclosing_Comp_Unit_Node first
+            --  avoids the case where In_Same_Extended_Unit gets confused.
+
+         begin
+            if Interunit_Ref_OK (Subp_Comp_Unit, Attr_Ref_Comp_Unit)
+              and then (Is_Library_Level_Entity (Subp)
+                        or else Enclosing_Dynamic_Scope (Subp) =
+                                Enclosing_Lib_Unit_Entity (Subp))
+            then
+               return;
+            end if;
+         end;
+
+         --  We have previously tried being more ambitious here in hopes of
+         --  referencing subprograms declared in other units (as opposed
+         --  to generating a new copy for the current unit) if they are
+         --  visible from the point of Attr_Ref. Unfortunately,
+         --  we ran into problems with generating inconsistent linknames
+         --  (e.g., a procedure declared with a name ending in "_304PI" being
+         --  unsuccessfully referenced from another unit via a name ending in
+         --  "_305PI"). So, after a fair amount of unsuccessful debugging,
+         --   it was decided to abandon the effort.
+
+         Subp := Empty;
+      end Validate_Cached_Candidate;
+   end Cached_Attribute_Ops;
+
    -------------------------
    -- Build_Array_VS_Func --
    -------------------------
@@ -907,91 +966,6 @@ package body Exp_Attr is
       return Func_Id;
    end Build_Record_VS_Func;
 
-   ----------------------------------
-   -- Compile_Stream_Body_In_Scope --
-   ----------------------------------
-
-   procedure Compile_Stream_Body_In_Scope
-     (N     : Node_Id;
-      Decl  : Node_Id;
-      Arr   : Entity_Id)
-   is
-      C_Type  : constant Entity_Id := Base_Type (Component_Type (Arr));
-      Curr    : constant Entity_Id := Current_Scope;
-      Install : Boolean := False;
-      Scop    : Entity_Id := Scope (Arr);
-
-   begin
-      if Is_Hidden (Arr)
-        and then not In_Open_Scopes (Scop)
-        and then Ekind (Scop) = E_Package
-      then
-         Install := True;
-
-      else
-         --  The component type may be private, in which case we install its
-         --  full view to compile the subprogram.
-
-         --  The component type may be private, in which case we install its
-         --  full view to compile the subprogram. We do not do this if the
-         --  type has a Stream_Convert pragma, which indicates that there are
-         --  special stream-processing operations for that type (for example
-         --  Unbounded_String and its wide varieties).
-
-         --  We don't install the package either if array type and element
-         --  type come from the same package, and the original array type is
-         --  private, because in this case the underlying type Arr is
-         --  itself a full view, which carries the full view of the component.
-
-         Scop := Scope (C_Type);
-
-         if Is_Private_Type (C_Type)
-           and then Present (Full_View (C_Type))
-           and then not In_Open_Scopes (Scop)
-           and then Ekind (Scop) = E_Package
-           and then No (Get_Stream_Convert_Pragma (C_Type))
-         then
-            if Scope (Arr) = Scope (C_Type)
-              and then Is_Private_Type (Etype (Prefix (N)))
-              and then Full_View (Etype (Prefix (N))) = Arr
-            then
-               null;
-
-            else
-               Install := True;
-            end if;
-         end if;
-      end if;
-
-      --  If we are within an instance body, then all visibility has been
-      --  established already and there is no need to install the package.
-
-      if Install and then not In_Instance_Body then
-         Push_Scope (Scop);
-         Install_Visible_Declarations (Scop);
-         Install_Private_Declarations (Scop);
-
-         --  The entities in the package are now visible, but the generated
-         --  stream entity must appear in the current scope (usually an
-         --  enclosing stream function) so that itypes all have their proper
-         --  scopes.
-
-         Push_Scope (Curr);
-      else
-         Install := False;
-      end if;
-
-      Insert_Action (N, Decl);
-
-      if Install then
-
-         --  Remove extra copy of current scope, and package itself
-
-         Pop_Scope;
-         End_Package_Scope (Scop);
-      end if;
-   end Compile_Stream_Body_In_Scope;
-
    -----------------------------------
    -- Default_Streaming_Unavailable --
    -----------------------------------
@@ -1898,6 +1872,25 @@ package body Exp_Attr is
       Pref  : constant Node_Id    := Prefix (N);
       Exprs : constant List_Id    := Expressions (N);
 
+      generic
+         with procedure Build_Type_Attr_Subprogram
+                (Typ  : Entity_Id;
+                 Decl : out Node_Id;
+                 Subp : out Entity_Id);
+      procedure Build_And_Insert_Type_Attr_Subp
+                  (Typ      : Entity_Id;
+                   Decl     : out Node_Id;
+                   Subp     : out Entity_Id;
+                   Attr_Ref : Node_Id);
+
+      --  If we have two calls to (for example)
+      --  Some_Untagged_Record_Type'Put_Image, we'd like
+      --  to generate just one procedure and call it twice (as opposed to
+      --  generating two effectively-identical procedures). Hoisting the
+      --  declaration of the procedure ensures that a second such attribute
+      --  reference in the current library unit will not need to generate a
+      --  second procedure.
+
       function Get_Integer_Type (Typ : Entity_Id) return Entity_Id;
       --  Return a small integer type appropriate for the enumeration type
 
@@ -1906,6 +1899,94 @@ package body Exp_Attr is
       --  call to the appropriate TSS procedure. Pname is the entity for the
       --  procedure to call.
 
+      -------------------------------------
+      -- Build_And_Insert_Type_Attr_Subp --
+      -------------------------------------
+
+      procedure Build_And_Insert_Type_Attr_Subp
+        (Typ      : Entity_Id;
+         Decl     : out Node_Id;
+         Subp     : out Entity_Id;
+         Attr_Ref : Node_Id)
+      is
+         procedure Build;
+         procedure Build is
+         begin
+            Build_Type_Attr_Subprogram
+              (Typ  => Typ,
+               Decl => Decl,
+               Subp => Subp);
+         end Build;
+
+         Ancestor        : Node_Id := Attr_Ref;
+         Insertion_Scope : Entity_Id := Empty;
+         Insertion_Point : Node_Id := Empty;
+         Insert_Before   : Boolean := False;
+         Typ_Comp_Unit   : Node_Id := Enclosing_Comp_Unit_Node (Typ);
+      begin
+         --  handle no-enclosing-comp-unit cases
+         if No (Typ_Comp_Unit) then
+            if Is_Itype (Typ) then
+               Typ_Comp_Unit := Enclosing_Comp_Unit_Node
+                                  (Associated_Node_For_Itype (Typ));
+            elsif Sloc (Typ) <= Standard_Location then
+               Typ_Comp_Unit := Typ; -- not a comp unit node, but that's ok
+            end if;
+            pragma Assert (Present (Typ_Comp_Unit));
+         end if;
+
+         if Interunit_Ref_OK (Typ_Comp_Unit,
+                              Enclosing_Comp_Unit_Node (Attr_Ref))
+            --  See comment accompanying earlier call to Interunit_Ref_OK
+            --  for discussion of these Enclosing_Comp_Unit_Node calls.
+         then
+            --  Typ is declared in the current unit, so
+            --  we want to hoist to the same scope as Typ.
+
+            Insertion_Scope := Scope (Typ);
+            Insertion_Point := Freeze_Node (Typ);
+         else
+            --  Typ is declared in a different unit, so
+            --  hoist to library level.
+
+            pragma Assert (Is_Library_Level_Entity (Typ));
+
+            while Present (Ancestor) loop
+               if Is_List_Member (Ancestor) then
+                  Insertion_Point := Ancestor;
+               end if;
+               Ancestor := Parent (Ancestor);
+            end loop;
+
+            if Present (Insertion_Point) then
+               Insert_Before := True;
+               Insertion_Scope :=
+                 Find_Enclosing_Scope (Insertion_Point);
+            end if;
+         end if;
+
+         if Present (Insertion_Point)
+           and Present (Insertion_Scope)
+         then
+            Push_Scope (Insertion_Scope);
+            Build;
+            if Insert_Before then
+               Insert_Action
+                 (Insertion_Point, Ins_Action => Decl);
+            else
+               Insert_Action_After
+                 (Insertion_Point, Ins_Action => Decl);
+            end if;
+            Pop_Scope;
+         else
+            --  Hoisting was unsuccessful, so no need to
+            --  Push/Pop a scope.
+
+            Build;
+            Insert_Action (Attr_Ref, Ins_Action => Decl);
+         end if;
+      end Build_And_Insert_Type_Attr_Subp;
+
       ----------------------
       -- Get_Integer_Type --
       ----------------------
@@ -1988,11 +2069,13 @@ package body Exp_Attr is
            and then not Is_Class_Wide_Type (Etype (Item))
            and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
          then
-            --  Perform a view conversion when either the argument or the
-            --  formal parameter are of a private type.
+            --  Perform an unchecked conversion when either the argument or
+            --  the formal parameter are of a private type.
 
-            if Is_Private_Type (Base_Type (Formal_Typ))
-              or else Is_Private_Type (Base_Type (Item_Typ))
+            if (Is_Private_Type (Base_Type (Formal_Typ))
+                or else Is_Private_Type (Base_Type (Item_Typ)))
+              and then (Is_By_Reference_Type (Formal_Typ) or else
+                        not Is_Written)
             then
                Rewrite (Item,
                  Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
@@ -4176,7 +4259,6 @@ package body Exp_Attr is
          B_Type  : constant Entity_Id := Base_Type (P_Type);
          U_Type  : constant Entity_Id := Underlying_Type (P_Type);
          Strm    : constant Node_Id   := First (Exprs);
-         Has_TSS : Boolean := False;
          Fname   : Entity_Id;
          Decl    : Node_Id;
          Call    : Node_Id;
@@ -4252,10 +4334,8 @@ package body Exp_Attr is
 
          Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input, N);
 
-         if Present (Fname) then
-            Has_TSS := True;
+         if not Present (Fname) then
 
-         else
             --  If there is a Stream_Convert pragma, use it, we rewrite
 
             --     sourcetyp'Input (stream)
@@ -4324,8 +4404,17 @@ package body Exp_Attr is
             --  Array type case
 
             elsif Is_Array_Type (U_Type) then
-               Build_Array_Input_Function (U_Type, Decl, Fname);
-               Compile_Stream_Body_In_Scope (N, Decl, U_Type);
+               declare
+                  procedure Build_And_Insert_Array_Input_Func is
+                    new Build_And_Insert_Type_Attr_Subp
+                          (Build_Array_Input_Function);
+               begin
+                  Build_And_Insert_Array_Input_Func
+                    (Typ      => Full_Base (U_Type),
+                     Decl     => Decl,
+                     Subp     => Fname,
+                     Attr_Ref => N);
+               end;
 
             --  Dispatching case with class-wide type
 
@@ -4451,10 +4540,23 @@ package body Exp_Attr is
                --  Build the type's Input function, passing the subtype rather
                --  than its base type, because checks are needed in the case of
                --  constrained discriminants (see Ada 2012 AI05-0192).
+               --
+               --  ??? Is this correct in the case where the prefix of the
+               --  attribute is a constrained subtype of a type whose
+               --  first named subtype is unconstrained? Shouldn't we be
+               --  passing in the first named subtype of the type?
 
-               Build_Record_Or_Elementary_Input_Function
-                 (U_Type, Decl, Fname);
-               Insert_Action (N, Decl);
+               declare
+                  procedure Build_And_Insert_Record_Input_Func is
+                    new Build_And_Insert_Type_Attr_Subp
+                          (Build_Record_Or_Elementary_Input_Function);
+               begin
+                  Build_And_Insert_Record_Input_Func
+                    (Typ      => U_Type,
+                     Decl     => Decl,
+                     Subp     => Fname,
+                     Attr_Ref => N);
+               end;
 
                if Nkind (Parent (N)) = N_Object_Declaration
                  and then Is_Record_Type (U_Type)
@@ -4502,8 +4604,8 @@ package body Exp_Attr is
             Freeze_Stream_Subprogram (Fname);
          end if;
 
-         if not Has_TSS then
-            Cached_Streaming_Ops.Input_Map.Set (P_Type, Fname);
+         if not Is_Tagged_Type (P_Type) then
+            Cached_Attribute_Ops.Input_Map.Set (P_Type, Fname);
          end if;
       end Input;
 
@@ -5289,7 +5391,6 @@ package body Exp_Attr is
       when Attribute_Output => Output : declare
          P_Type  : constant Entity_Id := Entity (Pref);
          U_Type  : constant Entity_Id := Underlying_Type (P_Type);
-         Has_TSS : Boolean := False;
          Pname   : Entity_Id;
          Decl    : Node_Id;
          Prag    : Node_Id;
@@ -5321,10 +5422,8 @@ package body Exp_Attr is
 
          Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output, N);
 
-         if Present (Pname) then
-            Has_TSS := True;
+         if not Present (Pname) then
 
-         else
             --  If there is a Stream_Convert pragma, use it, we rewrite
 
             --     sourcetyp'Output (stream, Item)
@@ -5397,8 +5496,17 @@ package body Exp_Attr is
             --  Array type case
 
             elsif Is_Array_Type (U_Type) then
-               Build_Array_Output_Procedure (U_Type, Decl, Pname);
-               Compile_Stream_Body_In_Scope (N, Decl, U_Type);
+               declare
+                  procedure Build_And_Insert_Array_Output_Proc is
+                    new Build_And_Insert_Type_Attr_Subp
+                          (Build_Array_Output_Procedure);
+               begin
+                  Build_And_Insert_Array_Output_Proc
+                    (Typ      => Full_Base (U_Type),
+                     Decl     => Decl,
+                     Subp     => Pname,
+                     Attr_Ref => N);
+               end;
 
             --  Class-wide case, first output external tag, then dispatch
             --  to the appropriate primitive Output function (RM 13.13.2(31)).
@@ -5507,9 +5615,17 @@ package body Exp_Attr is
                   return;
                end if;
 
-               Build_Record_Or_Elementary_Output_Procedure
-                 (Base_Type (U_Type), Decl, Pname);
-               Insert_Action (N, Decl);
+               declare
+                  procedure Build_And_Insert_Record_Output_Proc is
+                    new Build_And_Insert_Type_Attr_Subp
+                          (Build_Record_Or_Elementary_Output_Procedure);
+               begin
+                  Build_And_Insert_Record_Output_Proc
+                    (Typ      => Base_Type (U_Type),
+                     Decl     => Decl,
+                     Subp     => Pname,
+                     Attr_Ref => N);
+               end;
             end if;
          end if;
 
@@ -5517,8 +5633,8 @@ package body Exp_Attr is
 
          Rewrite_Attribute_Proc_Call (Pname);
 
-         if not Has_TSS then
-            Cached_Streaming_Ops.Output_Map.Set (P_Type, Pname);
+         if not Is_Tagged_Type (P_Type) then
+            Cached_Attribute_Ops.Output_Map.Set (P_Type, Pname);
          end if;
       end Output;
 
@@ -5879,8 +5995,25 @@ package body Exp_Attr is
                return;
 
             elsif Is_Array_Type (U_Type) then
-               Build_Array_Put_Image_Procedure (N, U_Type, Decl, Pname);
-               Insert_Action (N, Decl);
+               Pname := Cached_Attribute_Ops.Put_Image_Map.Get (U_Type);
+               Cached_Attribute_Ops.Validate_Cached_Candidate
+                 (Pname, Attr_Ref => N);
+               if not Present (Pname) then
+                  declare
+                     procedure Build_And_Insert_Array_Put_Image_Proc is
+                       new Build_And_Insert_Type_Attr_Subp
+                             (Build_Array_Put_Image_Procedure);
+
+                  begin
+                     Build_And_Insert_Array_Put_Image_Proc
+                       (Typ      => U_Type,
+                        Decl     => Decl,
+                           Subp     => Pname,
+                           Attr_Ref => N);
+                  end;
+
+                  Cached_Attribute_Ops.Put_Image_Map.Set (U_Type, Pname);
+               end if;
 
             --  Tagged type case, use the primitive Put_Image function. Note
             --  that this will dispatch in the class-wide case which is what we
@@ -5913,9 +6046,29 @@ package body Exp_Attr is
 
             else
                pragma Assert (Is_Record_Type (U_Type));
-               Build_Record_Put_Image_Procedure
-                 (Loc, Full_Base (U_Type), Decl, Pname);
-               Insert_Action (N, Decl);
+               declare
+                  Base_Typ : constant Entity_Id := Full_Base (U_Type);
+               begin
+                  Pname := Cached_Attribute_Ops.Put_Image_Map.Get (Base_Typ);
+                  Cached_Attribute_Ops.Validate_Cached_Candidate
+                    (Pname, Attr_Ref => N);
+                  if not Present (Pname) then
+                     declare
+                        procedure Build_And_Insert_Record_Put_Image_Proc is
+                          new Build_And_Insert_Type_Attr_Subp
+                                (Build_Record_Put_Image_Procedure);
+
+                     begin
+                        Build_And_Insert_Record_Put_Image_Proc
+                          (Typ      => Base_Typ,
+                           Decl     => Decl,
+                           Subp     => Pname,
+                           Attr_Ref => N);
+                     end;
+
+                     Cached_Attribute_Ops.Put_Image_Map.Set (Base_Typ, Pname);
+                  end if;
+               end;
             end if;
          end if;
 
@@ -6166,7 +6319,6 @@ package body Exp_Attr is
          P_Type  : constant Entity_Id := Entity (Pref);
          B_Type  : constant Entity_Id := Base_Type (P_Type);
          U_Type  : constant Entity_Id := Underlying_Type (P_Type);
-         Has_TSS : Boolean := False;
          Pname   : Entity_Id;
          Decl    : Node_Id;
          Prag    : Node_Id;
@@ -6200,10 +6352,8 @@ package body Exp_Attr is
 
          Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read, N);
 
-         if Present (Pname) then
-            Has_TSS := True;
+         if not Present (Pname) then
 
-         else
             --  If there is a Stream_Convert pragma, use it, we rewrite
 
             --     sourcetyp'Read (stream, Item)
@@ -6301,8 +6451,17 @@ package body Exp_Attr is
             --  Array type case
 
             elsif Is_Array_Type (U_Type) then
-               Build_Array_Read_Procedure (U_Type, Decl, Pname);
-               Compile_Stream_Body_In_Scope (N, Decl, U_Type);
+               declare
+                  procedure Build_And_Insert_Array_Read_Proc is
+                    new Build_And_Insert_Type_Attr_Subp
+                          (Build_Array_Read_Procedure);
+               begin
+                  Build_And_Insert_Array_Read_Proc
+                    (Typ      => Full_Base (U_Type),
+                     Decl     => Decl,
+                     Subp     => Pname,
+                     Attr_Ref => N);
+               end;
 
             --  Tagged type case, use the primitive Read function. Note that
             --  this will dispatch in the class-wide case which is what we want
@@ -6333,22 +6492,43 @@ package body Exp_Attr is
                   return;
                end if;
 
-               if Has_Defaulted_Discriminants (U_Type) then
-                  Build_Mutable_Record_Read_Procedure
-                    (Full_Base (U_Type), Decl, Pname);
-               else
-                  Build_Record_Read_Procedure
-                    (Full_Base (U_Type), Decl, Pname);
-               end if;
+               declare
+                  procedure Build_Record_Read_Proc
+                    (Typ  : Entity_Id;
+                     Decl : out Node_Id;
+                     Subp : out Entity_Id);
+
+                  procedure Build_Record_Read_Proc
+                    (Typ  : Entity_Id;
+                     Decl : out Node_Id;
+                     Subp : out Entity_Id) is
+                  begin
+                     if Has_Defaulted_Discriminants (Typ) then
+                        Build_Mutable_Record_Read_Procedure
+                          (Typ, Decl, Subp);
+                     else
+                        Build_Record_Read_Procedure
+                          (Typ, Decl, Subp);
+                     end if;
+                  end Build_Record_Read_Proc;
 
-               Insert_Action (N, Decl);
+                  procedure Build_And_Insert_Record_Read_Proc is
+                    new Build_And_Insert_Type_Attr_Subp
+                          (Build_Record_Read_Proc);
+               begin
+                  Build_And_Insert_Record_Read_Proc
+                    (Typ      => Full_Base (U_Type),
+                     Decl     => Decl,
+                     Subp     => Pname,
+                     Attr_Ref => N);
+               end;
             end if;
          end if;
 
          Rewrite_Attribute_Proc_Call (Pname);
 
-         if not Has_TSS then
-            Cached_Streaming_Ops.Read_Map.Set (P_Type, Pname);
+         if not Is_Tagged_Type (P_Type) then
+            Cached_Attribute_Ops.Read_Map.Set (P_Type, Pname);
          end if;
       end Read;
 
@@ -7856,7 +8036,6 @@ package body Exp_Attr is
       when Attribute_Write => Write : declare
          P_Type  : constant Entity_Id := Entity (Pref);
          U_Type  : constant Entity_Id := Underlying_Type (P_Type);
-         Has_TSS : Boolean := False;
          Pname   : Entity_Id;
          Decl    : Node_Id;
          Prag    : Node_Id;
@@ -7888,10 +8067,8 @@ package body Exp_Attr is
 
          Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write, N);
 
-         if Present (Pname) then
-            Has_TSS := True;
+         if not Present (Pname) then
 
-         else
             --  If there is a Stream_Convert pragma, use it, we rewrite
 
             --     sourcetyp'Output (stream, Item)
@@ -7949,8 +8126,17 @@ package body Exp_Attr is
             --  Array type case
 
             elsif Is_Array_Type (U_Type) then
-               Build_Array_Write_Procedure (U_Type, Decl, Pname);
-               Compile_Stream_Body_In_Scope (N, Decl, U_Type);
+               declare
+                  procedure Build_And_Insert_Array_Write_Proc is
+                    new Build_And_Insert_Type_Attr_Subp
+                          (Build_Array_Write_Procedure);
+               begin
+                  Build_And_Insert_Array_Write_Proc
+                    (Typ      => Full_Base (U_Type),
+                     Decl     => Decl,
+                     Subp     => Pname,
+                     Attr_Ref => N);
+               end;
 
             --  Tagged type case, use the primitive Write function. Note that
             --  this will dispatch in the class-wide case which is what we want
@@ -7988,15 +8174,36 @@ package body Exp_Attr is
                   end if;
                end if;
 
-               if Has_Defaulted_Discriminants (U_Type) then
-                  Build_Mutable_Record_Write_Procedure
-                    (Full_Base (U_Type), Decl, Pname);
-               else
-                  Build_Record_Write_Procedure
-                    (Full_Base (U_Type), Decl, Pname);
-               end if;
+               declare
+                  procedure Build_Record_Write_Proc
+                    (Typ  : Entity_Id;
+                     Decl : out Node_Id;
+                     Subp : out Entity_Id);
+
+                  procedure Build_Record_Write_Proc
+                    (Typ  : Entity_Id;
+                     Decl : out Node_Id;
+                     Subp : out Entity_Id) is
+                  begin
+                     if Has_Defaulted_Discriminants (Typ) then
+                        Build_Mutable_Record_Write_Procedure
+                          (Typ, Decl, Subp);
+                     else
+                        Build_Record_Write_Procedure
+                          (Typ, Decl, Subp);
+                     end if;
+                  end Build_Record_Write_Proc;
 
-               Insert_Action (N, Decl);
+                  procedure Build_And_Insert_Record_Write_Proc is
+                    new Build_And_Insert_Type_Attr_Subp
+                          (Build_Record_Write_Proc);
+               begin
+                  Build_And_Insert_Record_Write_Proc
+                    (Typ      => Full_Base (U_Type),
+                     Decl     => Decl,
+                     Subp     => Pname,
+                     Attr_Ref => N);
+               end;
             end if;
          end if;
 
@@ -8004,8 +8211,8 @@ package body Exp_Attr is
 
          Rewrite_Attribute_Proc_Call (Pname);
 
-         if not Has_TSS then
-            Cached_Streaming_Ops.Write_Map.Set (P_Type, Pname);
+         if not Is_Tagged_Type (P_Type) then
+            Cached_Attribute_Ops.Write_Map.Set (P_Type, Pname);
          end if;
       end Write;
 
@@ -8582,40 +8789,6 @@ package body Exp_Attr is
       Nam      : TSS_Name_Type;
       Attr_Ref : Node_Id) return Entity_Id
    is
-
-      function In_Available_Context (Ent : Entity_Id) return Boolean;
-      --  Ent is a candidate result for Find_Stream_Subprogram.
-      --  If, for example, a subprogram is declared within a case
-      --  alternative then Gigi does not want to see a call to it from
-      --  outside of the case alternative. Compare placement of Ent and
-      --  Attr_Ref to prevent this situation (by returning False).
-
-      --------------------------
-      -- In_Available_Context --
-      --------------------------
-
-      function In_Available_Context (Ent : Entity_Id) return Boolean is
-         Decl : constant Node_Id := Enclosing_Declaration (Ent);
-      begin
-         if Has_Declarations (Parent (Decl)) then
-            return In_Subtree (Attr_Ref, Root => Parent (Decl));
-         elsif Is_List_Member (Decl) then
-            declare
-               List_Elem : Node_Id := Next (Decl);
-            begin
-               while Present (List_Elem) loop
-                  if In_Subtree (Attr_Ref, Root => List_Elem) then
-                     return True;
-                  end if;
-                  Next (List_Elem);
-               end loop;
-               return False;
-            end;
-         else
-            return False; --  Can this occur ???
-         end if;
-      end In_Available_Context;
-
       --  Local declarations
 
       Base_Typ : constant Entity_Id := Base_Type (Typ);
@@ -8641,28 +8814,20 @@ package body Exp_Attr is
       end if;
 
       if Nam = TSS_Stream_Read then
-         Ent := Cached_Streaming_Ops.Read_Map.Get (Typ);
+         Ent := Cached_Attribute_Ops.Read_Map.Get (Typ);
       elsif Nam = TSS_Stream_Write then
-         Ent := Cached_Streaming_Ops.Write_Map.Get (Typ);
+         Ent := Cached_Attribute_Ops.Write_Map.Get (Typ);
       elsif Nam = TSS_Stream_Input then
-         Ent := Cached_Streaming_Ops.Input_Map.Get (Typ);
+         Ent := Cached_Attribute_Ops.Input_Map.Get (Typ);
       elsif Nam = TSS_Stream_Output then
-         Ent := Cached_Streaming_Ops.Output_Map.Get (Typ);
+         Ent := Cached_Attribute_Ops.Output_Map.Get (Typ);
       end if;
 
-      if Present (Ent) then
-         --  Can't reuse Ent if it is no longer in scope
+      Cached_Attribute_Ops.Validate_Cached_Candidate
+        (Subp => Ent, Attr_Ref => Attr_Ref);
 
-         if In_Open_Scopes (Scope (Ent))
-
-           --  The preceding In_Open_Scopes test may not suffice if
-           --  case alternatives are involved.
-           and then In_Available_Context (Ent)
-         then
-            return Ent;
-         else
-            Ent := Empty;
-         end if;
+      if Present (Ent) then
+         return Ent;
       end if;
 
       --  Stream attributes for strings are expanded into library calls. The