@@ -77,8 +77,55 @@ with Uname; use Uname;
with Urealp; use Urealp;
with Validsw; use Validsw;
+with GNAT.HTable;
+
package body Exp_Attr is
+ package Cached_Streaming_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
+ (Header_Num (Id mod Map_Size));
+
+ -- Cache used to avoid building duplicate subprograms for a single
+ -- type/streaming-attribute pair.
+
+ package Read_Map is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Key => Entity_Id,
+ Element => Entity_Id,
+ No_Element => Empty,
+ Hash => Streaming_Op_Hash,
+ Equal => "=");
+
+ package Write_Map is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Key => Entity_Id,
+ Element => Entity_Id,
+ No_Element => Empty,
+ Hash => Streaming_Op_Hash,
+ Equal => "=");
+
+ package Input_Map is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Key => Entity_Id,
+ Element => Entity_Id,
+ No_Element => Empty,
+ Hash => Streaming_Op_Hash,
+ Equal => "=");
+
+ package Output_Map is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Key => Entity_Id,
+ Element => Entity_Id,
+ No_Element => Empty,
+ Hash => Streaming_Op_Hash,
+ Equal => "=");
+
+ end Cached_Streaming_Ops;
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -210,13 +257,15 @@ package body Exp_Attr is
-- is not a floating-point type.
function Find_Stream_Subprogram
- (Typ : Entity_Id;
- Nam : TSS_Name_Type) return Entity_Id;
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type;
+ Attr_Ref : Node_Id) return Entity_Id;
-- Returns the stream-oriented subprogram attribute for Typ. For tagged
-- types, the corresponding primitive operation is looked up, else the
-- appropriate TSS from the type itself, or from its closest ancestor
-- defining it, is returned. In both cases, inheritance of representation
- -- aspects is thus taken into account.
+ -- aspects is thus taken into account. Attr_Ref is used to identify the
+ -- point from which the function result will be referenced.
function Full_Base (T : Entity_Id) return Entity_Id;
-- The stream functions need to examine the underlying representation of
@@ -4115,18 +4164,19 @@ package body Exp_Attr is
-----------
when Attribute_Input => Input : declare
- 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);
- Strm : constant Node_Id := First (Exprs);
- Fname : Entity_Id;
- Decl : Node_Id;
- Call : Node_Id;
- Prag : Node_Id;
- Arg2 : Node_Id;
- Rfunc : Node_Id;
+ 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);
+ Strm : constant Node_Id := First (Exprs);
+ Has_TSS : Boolean := False;
+ Fname : Entity_Id;
+ Decl : Node_Id;
+ Call : Node_Id;
+ Prag : Node_Id;
+ Arg2 : Node_Id;
+ Rfunc : Node_Id;
- Cntrl : Node_Id := Empty;
+ Cntrl : Node_Id := Empty;
-- Value for controlling argument in call. Always Empty except in
-- the dispatching (class-wide type) case, where it is a reference
-- to the dummy object initialized to the right internal tag.
@@ -4192,10 +4242,10 @@ package body Exp_Attr is
-- If there is a TSS for Input, just call it
- Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
+ Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input, N);
if Present (Fname) then
- null;
+ Has_TSS := True;
else
-- If there is a Stream_Convert pragma, use it, we rewrite
@@ -4252,7 +4302,7 @@ package body Exp_Attr is
if Present (Find_Inherited_TSS (P_Type, TSS_Stream_Read)) then
Build_Record_Or_Elementary_Input_Function
- (Loc, P_Type, Decl, Fname);
+ (P_Type, Decl, Fname);
Insert_Action (N, Decl);
-- For normal cases, we call the I_xxx routine directly
@@ -4266,7 +4316,7 @@ package body Exp_Attr is
-- Array type case
elsif Is_Array_Type (U_Type) then
- Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
+ Build_Array_Input_Function (U_Type, Decl, Fname);
Compile_Stream_Body_In_Scope (N, Decl, U_Type);
-- Dispatching case with class-wide type
@@ -4395,7 +4445,7 @@ package body Exp_Attr is
-- constrained discriminants (see Ada 2012 AI05-0192).
Build_Record_Or_Elementary_Input_Function
- (Loc, U_Type, Decl, Fname);
+ (U_Type, Decl, Fname);
Insert_Action (N, Decl);
if Nkind (Parent (N)) = N_Object_Declaration
@@ -4413,7 +4463,7 @@ package body Exp_Attr is
while Present (Comp) loop
Func :=
Find_Stream_Subprogram
- (Etype (Comp), TSS_Stream_Read);
+ (Etype (Comp), TSS_Stream_Read, N);
if Present (Func) then
Freeze_Stream_Subprogram (Func);
@@ -4443,6 +4493,10 @@ package body Exp_Attr is
if Nkind (Parent (N)) = N_Object_Declaration then
Freeze_Stream_Subprogram (Fname);
end if;
+
+ if not Has_TSS then
+ Cached_Streaming_Ops.Input_Map.Set (P_Type, Fname);
+ end if;
end Input;
-------------------
@@ -5279,13 +5333,14 @@ 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);
- Pname : Entity_Id;
- Decl : Node_Id;
- Prag : Node_Id;
- Arg3 : Node_Id;
- Wfunc : Node_Id;
+ 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;
+ Arg3 : Node_Id;
+ Wfunc : Node_Id;
begin
-- If no underlying type, we have an error that will be diagnosed
@@ -5310,10 +5365,10 @@ package body Exp_Attr is
-- If TSS for Output is present, just call it
- Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
+ Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output, N);
if Present (Pname) then
- null;
+ Has_TSS := True;
else
-- If there is a Stream_Convert pragma, use it, we rewrite
@@ -5374,7 +5429,7 @@ package body Exp_Attr is
if Present (Find_Inherited_TSS (P_Type, TSS_Stream_Write)) then
Build_Record_Or_Elementary_Output_Procedure
- (Loc, P_Type, Decl, Pname);
+ (P_Type, Decl, Pname);
Insert_Action (N, Decl);
-- For normal cases, we call the W_xxx routine directly
@@ -5388,7 +5443,7 @@ package body Exp_Attr is
-- Array type case
elsif Is_Array_Type (U_Type) then
- Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
+ Build_Array_Output_Procedure (U_Type, Decl, Pname);
Compile_Stream_Body_In_Scope (N, Decl, U_Type);
-- Class-wide case, first output external tag, then dispatch
@@ -5499,7 +5554,7 @@ package body Exp_Attr is
end if;
Build_Record_Or_Elementary_Output_Procedure
- (Loc, Base_Type (U_Type), Decl, Pname);
+ (Base_Type (U_Type), Decl, Pname);
Insert_Action (N, Decl);
end if;
end if;
@@ -5507,6 +5562,10 @@ package body Exp_Attr is
-- If we fall through, Pname is the name of the procedure to call
Rewrite_Attribute_Proc_Call (Pname);
+
+ if not Has_TSS then
+ Cached_Streaming_Ops.Output_Map.Set (P_Type, Pname);
+ end if;
end Output;
---------
@@ -6171,16 +6230,17 @@ package body Exp_Attr is
----------
when Attribute_Read => Read : declare
- 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);
- Pname : Entity_Id;
- Decl : Node_Id;
- Prag : Node_Id;
- Arg2 : Node_Id;
- Rfunc : Node_Id;
- Lhs : Node_Id;
- Rhs : Node_Id;
+ 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;
+ Arg2 : Node_Id;
+ Rfunc : Node_Id;
+ Lhs : Node_Id;
+ Rhs : Node_Id;
begin
-- If no underlying type, we have an error that will be diagnosed
@@ -6205,10 +6265,10 @@ package body Exp_Attr is
-- The simple case, if there is a TSS for Read, just call it
- Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
+ Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read, N);
if Present (Pname) then
- null;
+ Has_TSS := True;
else
-- If there is a Stream_Convert pragma, use it, we rewrite
@@ -6308,7 +6368,7 @@ package body Exp_Attr is
-- Array type case
elsif Is_Array_Type (U_Type) then
- Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
+ Build_Array_Read_Procedure (U_Type, Decl, Pname);
Compile_Stream_Body_In_Scope (N, Decl, U_Type);
-- Tagged type case, use the primitive Read function. Note that
@@ -6342,10 +6402,10 @@ package body Exp_Attr is
if Has_Defaulted_Discriminants (U_Type) then
Build_Mutable_Record_Read_Procedure
- (Loc, Full_Base (U_Type), Decl, Pname);
+ (Full_Base (U_Type), Decl, Pname);
else
Build_Record_Read_Procedure
- (Loc, Full_Base (U_Type), Decl, Pname);
+ (Full_Base (U_Type), Decl, Pname);
end if;
Insert_Action (N, Decl);
@@ -6353,6 +6413,10 @@ package body Exp_Attr is
end if;
Rewrite_Attribute_Proc_Call (Pname);
+
+ if not Has_TSS then
+ Cached_Streaming_Ops.Read_Map.Set (P_Type, Pname);
+ end if;
end Read;
---------
@@ -7857,13 +7921,14 @@ 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);
- Pname : Entity_Id;
- Decl : Node_Id;
- Prag : Node_Id;
- Arg3 : Node_Id;
- Wfunc : Node_Id;
+ 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;
+ Arg3 : Node_Id;
+ Wfunc : Node_Id;
begin
-- If no underlying type, we have an error that will be diagnosed
@@ -7888,10 +7953,10 @@ package body Exp_Attr is
-- The simple case, if there is a TSS for Write, just call it
- Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
+ Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write, N);
if Present (Pname) then
- null;
+ Has_TSS := True;
else
-- If there is a Stream_Convert pragma, use it, we rewrite
@@ -7951,7 +8016,7 @@ package body Exp_Attr is
-- Array type case
elsif Is_Array_Type (U_Type) then
- Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
+ Build_Array_Write_Procedure (U_Type, Decl, Pname);
Compile_Stream_Body_In_Scope (N, Decl, U_Type);
-- Tagged type case, use the primitive Write function. Note that
@@ -7992,10 +8057,10 @@ package body Exp_Attr is
if Has_Defaulted_Discriminants (U_Type) then
Build_Mutable_Record_Write_Procedure
- (Loc, Full_Base (U_Type), Decl, Pname);
+ (Full_Base (U_Type), Decl, Pname);
else
Build_Record_Write_Procedure
- (Loc, Full_Base (U_Type), Decl, Pname);
+ (Full_Base (U_Type), Decl, Pname);
end if;
Insert_Action (N, Decl);
@@ -8005,6 +8070,10 @@ package body Exp_Attr is
-- If we fall through, Pname is the procedure to be called
Rewrite_Attribute_Proc_Call (Pname);
+
+ if not Has_TSS then
+ Cached_Streaming_Ops.Write_Map.Set (P_Type, Pname);
+ end if;
end Write;
-- The following attributes are handled by the back end (except that
@@ -8576,16 +8645,102 @@ package body Exp_Attr is
----------------------------
function Find_Stream_Subprogram
- (Typ : Entity_Id;
- Nam : TSS_Name_Type) return Entity_Id
+ (Typ : Entity_Id;
+ 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 : Node_Id := Enclosing_Declaration (Ent);
+ begin
+ -- Enclosing_Declaration does not always return a declaration;
+ -- cope with this irregularity.
+ if Decl in N_Subprogram_Specification_Id
+ and then Nkind (Parent (Decl)) in
+ N_Subprogram_Body | N_Subprogram_Declaration
+ then
+ Decl := Parent (Decl);
+ end if;
+
+ 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);
- Ent : constant Entity_Id := TSS (Typ, Nam);
+ Ent : Entity_Id := TSS (Typ, Nam);
+
+ -- Start of processing for Find_Stream_Subprogram
+
begin
if Present (Ent) then
return Ent;
end if;
+ -- Everything after this point is an optimization. In other words,
+ -- there should be no *correctness* problems if we were to
+ -- unconditionally return Empty here.
+
+ if Is_Unchecked_Union (Base_Typ) then
+ -- Conservatively avoid possible problems (e.g., Write behaves
+ -- differently for a U_U type when called by Output vs. when
+ -- called from elsewhere).
+
+ return Empty;
+ end if;
+
+ if Nam = TSS_Stream_Read then
+ Ent := Cached_Streaming_Ops.Read_Map.Get (Typ);
+ elsif Nam = TSS_Stream_Write then
+ Ent := Cached_Streaming_Ops.Write_Map.Get (Typ);
+ elsif Nam = TSS_Stream_Input then
+ Ent := Cached_Streaming_Ops.Input_Map.Get (Typ);
+ elsif Nam = TSS_Stream_Output then
+ Ent := Cached_Streaming_Ops.Output_Map.Get (Typ);
+ end if;
+
+ if Present (Ent) then
+ -- Can't reuse Ent if it is no longer in scope
+
+ 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;
+ end if;
+
-- Stream attributes for strings are expanded into library calls. The
-- following checks are disabled when the run-time is not available or
-- when compiling predefined types due to bootstrap issues. As a result,
@@ -12422,14 +12422,14 @@ package body Exp_Ch3 is
if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read)
and then No (TSS (Tag_Typ, TSS_Stream_Read))
then
- Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
+ Build_Record_Read_Procedure (Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write)
and then No (TSS (Tag_Typ, TSS_Stream_Write))
then
- Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
+ Build_Record_Write_Procedure (Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
@@ -12441,14 +12441,14 @@ package body Exp_Ch3 is
and then No (TSS (Tag_Typ, TSS_Stream_Input))
then
Build_Record_Or_Elementary_Input_Function
- (Loc, Tag_Typ, Decl, Ent);
+ (Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output)
and then No (TSS (Tag_Typ, TSS_Stream_Output))
then
- Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent);
+ Build_Record_Or_Elementary_Output_Procedure (Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
@@ -3118,8 +3118,8 @@ package body Exp_Dist is
-- Start of processing for Add_RACW_Read_Attribute
begin
- Build_Stream_Procedure (Loc,
- RACW_Type, Body_Node, Pnam, Statements, Outp => True);
+ Build_Stream_Procedure
+ (RACW_Type, Body_Node, Pnam, Statements, Outp => True);
Proc_Decl := Make_Subprogram_Declaration (Loc,
Copy_Specification (Loc, Specification (Body_Node)));
@@ -3354,7 +3354,7 @@ package body Exp_Dist is
begin
Build_Stream_Procedure
- (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
+ (RACW_Type, Body_Node, Pnam, Statements, Outp => False);
Proc_Decl := Make_Subprogram_Declaration (Loc,
Copy_Specification (Loc, Specification (Body_Node)));
@@ -5800,7 +5800,7 @@ package body Exp_Dist is
begin
Build_Stream_Procedure
- (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
+ (RACW_Type, Body_Node, Pnam, Statements, Outp => True);
Proc_Decl := Make_Subprogram_Declaration (Loc,
Copy_Specification (Loc, Specification (Body_Node)));
@@ -6103,7 +6103,7 @@ package body Exp_Dist is
begin
Build_Stream_Procedure
- (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
+ (RACW_Type, Body_Node, Pnam, Statements, Outp => False);
Proc_Decl :=
Make_Subprogram_Declaration (Loc,
@@ -51,20 +51,17 @@ package body Exp_Strm is
-----------------------
procedure Build_Array_Read_Write_Procedure
- (Nod : Node_Id;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Nam : Name_Id);
-- Common routine shared to build either an array Read procedure or an
-- array Write procedure, Nam is Name_Read or Name_Write to select which.
-- Pnam is the defining identifier for the constructed procedure. The
- -- other parameters are as for Build_Array_Read_Procedure except that
- -- the first parameter Nod supplies the Sloc to be used to generate code.
+ -- other parameters are as for Build_Array_Read_Procedure.
procedure Build_Record_Read_Write_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Nam : Name_Id);
@@ -74,8 +71,7 @@ package body Exp_Strm is
-- as for Build_Record_Read_Procedure.
procedure Build_Stream_Function
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Fnam : Entity_Id;
Decls : List_Id;
@@ -140,11 +136,11 @@ package body Exp_Strm is
-- reference, so the name must be unique.
procedure Build_Array_Input_Function
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id)
is
+ Loc : constant Source_Ptr := Sloc (Typ);
Dim : constant Pos := Number_Dimensions (Typ);
Lnam : Name_Id;
Hnam : Name_Id;
@@ -235,7 +231,7 @@ package body Exp_Strm is
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input));
- Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
+ Build_Stream_Function (Typ, Decl, Fnam, Decls, Stms);
end Build_Array_Input_Function;
----------------------------------
@@ -243,11 +239,11 @@ package body Exp_Strm is
----------------------------------
procedure Build_Array_Output_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);
Stms : List_Id;
Indx : Node_Id;
@@ -301,7 +297,7 @@ package body Exp_Strm is
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output));
- Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => False);
+ Build_Stream_Procedure (Typ, Decl, Pnam, Stms, Outp => False);
end Build_Array_Output_Procedure;
--------------------------------
@@ -309,18 +305,17 @@ package body Exp_Strm is
--------------------------------
procedure Build_Array_Read_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);
begin
Pnam :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
- Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read);
+ Build_Array_Read_Write_Procedure (Typ, Decl, Pnam, Name_Read);
end Build_Array_Read_Procedure;
--------------------------------------
@@ -345,13 +340,12 @@ package body Exp_Strm is
-- The out keyword for V is supplied in the Read case
procedure Build_Array_Read_Write_Procedure
- (Nod : Node_Id;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Nam : Name_Id)
is
- Loc : constant Source_Ptr := Sloc (Nod);
+ Loc : constant Source_Ptr := Sloc (Typ);
Ndim : constant Pos := Number_Dimensions (Typ);
Ctyp : constant Entity_Id := Component_Type (Typ);
@@ -402,7 +396,7 @@ package body Exp_Strm is
for J in 1 .. Ndim loop
Stm :=
- Make_Implicit_Loop_Statement (Nod,
+ Make_Implicit_Loop_Statement (Typ,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
@@ -424,7 +418,7 @@ package body Exp_Strm is
end loop;
Build_Stream_Procedure
- (Loc, Typ, Decl, Pnam, New_List (Stm), Outp => Nam = Name_Read);
+ (Typ, Decl, Pnam, New_List (Stm), Outp => Nam = Name_Read);
end Build_Array_Read_Write_Procedure;
---------------------------------
@@ -432,17 +426,16 @@ package body Exp_Strm is
---------------------------------
procedure Build_Array_Write_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);
begin
Pnam :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
- Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write);
+ Build_Array_Read_Write_Procedure (Typ, Decl, Pnam, Name_Write);
end Build_Array_Write_Procedure;
---------------------------------
@@ -894,11 +887,12 @@ package body Exp_Strm is
-----------------------------------------
procedure Build_Mutable_Record_Read_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);
+
Out_Formal : Node_Id;
-- Expression denoting the out formal parameter
@@ -951,7 +945,7 @@ package body Exp_Strm is
Make_Raise_Program_Error (Loc,
Reason => PE_Unchecked_Union_Restriction));
- Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => True);
+ Build_Stream_Procedure (Typ, Decl, Pnam, Stms, Outp => True);
return;
end if;
@@ -1007,7 +1001,7 @@ package body Exp_Strm is
-- Generate reads for the components of the record (including those
-- that depend on discriminants).
- Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
+ Build_Record_Read_Write_Procedure (Typ, Decl, Pnam, Name_Read);
-- Save original statement sequence for component assignments, and
-- replace it with Stms.
@@ -1066,11 +1060,11 @@ package body Exp_Strm is
------------------------------------------
procedure Build_Mutable_Record_Write_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);
Stms : List_Id;
Disc : Entity_Id;
D_Ref : Node_Id;
@@ -1111,7 +1105,7 @@ package body Exp_Strm is
Pnam :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
- Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
+ Build_Record_Read_Write_Procedure (Typ, Decl, Pnam, Name_Write);
-- Write the discriminants before the rest of the components, so
-- that discriminant values are properly set of variants, etc.
@@ -1152,11 +1146,11 @@ package body Exp_Strm is
-- an elementary type, then no Cn constants are defined.
procedure Build_Record_Or_Elementary_Input_Function
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id)
is
+ Loc : constant Source_Ptr := Sloc (Typ);
B_Typ : constant Entity_Id := Underlying_Type (Base_Type (Typ));
Cn : Name_Id;
Constr : List_Id;
@@ -1288,7 +1282,7 @@ package body Exp_Strm is
Fnam := Make_Stream_Subprogram_Name (Loc, B_Typ, TSS_Stream_Input);
- Build_Stream_Function (Loc, B_Typ, Decl, Fnam, Decls, Stms);
+ Build_Stream_Function (B_Typ, Decl, Fnam, Decls, Stms);
end Build_Record_Or_Elementary_Input_Function;
-------------------------------------------------
@@ -1296,11 +1290,11 @@ package body Exp_Strm is
-------------------------------------------------
procedure Build_Record_Or_Elementary_Output_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);
Stms : List_Id;
Disc : Entity_Id;
Disc_Ref : Node_Id;
@@ -1356,7 +1350,7 @@ package body Exp_Strm is
Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output);
- Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => False);
+ Build_Stream_Procedure (Typ, Decl, Pnam, Stms, Outp => False);
end Build_Record_Or_Elementary_Output_Procedure;
---------------------------------
@@ -1364,14 +1358,14 @@ package body Exp_Strm is
---------------------------------
procedure Build_Record_Read_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);
begin
Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read);
- Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
+ Build_Record_Read_Write_Procedure (Typ, Decl, Pnam, Name_Read);
end Build_Record_Read_Procedure;
---------------------------------------
@@ -1407,12 +1401,12 @@ package body Exp_Strm is
-- The out keyword for V is supplied in the Read case
procedure Build_Record_Read_Write_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Nam : Name_Id)
is
+ Loc : constant Source_Ptr := Sloc (Typ);
Rdef : Node_Id;
Stms : List_Id;
Typt : Entity_Id;
@@ -1616,7 +1610,7 @@ package body Exp_Strm is
end if;
Build_Stream_Procedure
- (Loc, Typ, Decl, Pnam, Stms, Outp => Nam = Name_Read);
+ (Typ, Decl, Pnam, Stms, Outp => Nam = Name_Read);
end Build_Record_Read_Write_Procedure;
----------------------------------
@@ -1624,14 +1618,14 @@ package body Exp_Strm is
----------------------------------
procedure Build_Record_Write_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);
begin
Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write);
- Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
+ Build_Record_Read_Write_Procedure (Typ, Decl, Pnam, Name_Write);
end Build_Record_Write_Procedure;
-------------------------------
@@ -1674,13 +1668,13 @@ package body Exp_Strm is
---------------------------
procedure Build_Stream_Function
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Fnam : Entity_Id;
Decls : List_Id;
Stms : List_Id)
is
+ Loc : constant Source_Ptr := Sloc (Typ);
Spec : Node_Id;
begin
@@ -1719,13 +1713,13 @@ package body Exp_Strm is
----------------------------
procedure Build_Stream_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Stms : List_Id;
Outp : Boolean)
is
+ Loc : constant Source_Ptr := Sloc (Typ);
Spec : Node_Id;
begin
@@ -57,38 +57,31 @@ package Exp_Strm is
-- results are the declaration and name (entity) of the subprogram.
procedure Build_Array_Input_Function
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id);
-- Build function for Input attribute for array type
procedure Build_Array_Output_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id);
-- Build procedure for Output attribute for array type
procedure Build_Array_Read_Procedure
- (Nod : Node_Id;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id);
- -- Build procedure for Read attribute for array type. Nod provides the
- -- Sloc value for generated code.
+ -- Build procedure for Read attribute for array type.
procedure Build_Array_Write_Procedure
- (Nod : Node_Id;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id);
- -- Build procedure for Write attribute for array type. Nod provides the
- -- Sloc value for generated code.
+ -- Build procedure for Write attribute for array type.
procedure Build_Mutable_Record_Read_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id);
-- Build procedure to Read a record with default discriminants.
@@ -96,8 +89,7 @@ package Exp_Strm is
-- same manner as is done for 'Input.
procedure Build_Mutable_Record_Write_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id);
-- Build procedure to write a record with default discriminants.
@@ -105,8 +97,7 @@ package Exp_Strm is
-- the same manner as is done for 'Output.
procedure Build_Record_Or_Elementary_Input_Function
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id);
-- Build function for Input attribute for record type or for an elementary
@@ -115,8 +106,7 @@ package Exp_Strm is
-- runtime library routine directly).
procedure Build_Record_Or_Elementary_Output_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id);
-- Build procedure for Output attribute for record type or for an
@@ -125,22 +115,19 @@ package Exp_Strm is
-- Output calls the appropriate runtime library routine directly.
procedure Build_Record_Read_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id);
-- Build procedure for Read attribute for record type
procedure Build_Record_Write_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id);
-- Build procedure for Write attribute for record type
procedure Build_Stream_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Stms : List_Id;