@@ -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
@@ -12559,7 +12559,7 @@ package body Exp_Ch3 is
and then not No_Run_Time_Mode
and then RTE_Available (RE_Root_Buffer_Type)
then
- Build_Record_Put_Image_Procedure (Loc, Tag_Typ, Decl, Ent);
+ Build_Record_Put_Image_Procedure (Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
@@ -82,12 +82,11 @@ package body Exp_Put_Image is
-------------------------------------
procedure Build_Array_Put_Image_Procedure
- (Nod : Node_Id;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id)
is
- Loc : constant Source_Ptr := Sloc (Nod);
+ Loc : constant Source_Ptr := Sloc (Typ);
function Wrap_In_Loop
(Stms : List_Id;
@@ -132,7 +131,7 @@ package body Exp_Put_Image is
Expressions => New_List (
Make_Integer_Literal (Loc, Dim))));
Loop_Stm : constant Node_Id :=
- Make_Implicit_Loop_Statement (Nod, Statements => Stms);
+ Make_Implicit_Loop_Statement (Typ, Statements => Stms);
Exit_Stm : constant Node_Id :=
Make_Exit_Statement (Loc,
Condition =>
@@ -549,11 +548,11 @@ package body Exp_Put_Image is
-- end Put_Image;
procedure Build_Record_Put_Image_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id)
is
+ Loc : constant Source_Ptr := Sloc (Typ);
Btyp : constant Entity_Id := Base_Type (Typ);
pragma Assert (not Is_Class_Wide_Type (Btyp));
pragma Assert (not Is_Unchecked_Union (Btyp));
@@ -1349,6 +1348,8 @@ package body Exp_Put_Image is
begin
if Is_Array_Type (E) and then Is_First_Subtype (E) then
return E;
+ elsif Is_Private_Type (Base_Type (E)) and not Is_Private_Type (E) then
+ return Implementation_Base_Type (E);
else
return Base_Type (E);
end if;
@@ -70,18 +70,14 @@ package Exp_Put_Image is
-- the declaration and name (entity) of the procedure.
procedure Build_Array_Put_Image_Procedure
- (Nod : Node_Id;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id);
- -- Nod provides the Sloc value for the generated code
procedure Build_Record_Put_Image_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id);
- -- Loc is the location of the subprogram declaration
function Build_Unknown_Put_Image_Call (N : Node_Id) return Node_Id;
-- Build a call to Put_Image_Unknown
@@ -14539,8 +14539,11 @@ package body Sem_Ch3 is
-- In an instance it may be necessary to retrieve the full view of a
-- type with unknown discriminants, or a full view with defaulted
-- discriminants. In other contexts the constraint is illegal.
+ -- This relaxation of legality checking may also be needed in
+ -- compiler-generated Put_Image or streaming subprograms (hence
+ -- the Comes_From_Source test).
- if In_Instance
+ if (In_Instance or not Comes_From_Source (S))
and then Is_Private_Type (T)
and then Present (Full_View (T))
and then
@@ -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))
From: Steve Baird <baird@adacore.com> 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). Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_attr.adb | 627 ++++++++++++++++++++++++-------------- gcc/ada/exp_ch3.adb | 2 +- gcc/ada/exp_put_image.adb | 13 +- gcc/ada/exp_put_image.ads | 8 +- gcc/ada/sem_ch3.adb | 5 +- gcc/ada/sem_res.adb | 79 ++++- 6 files changed, 484 insertions(+), 250 deletions(-)