* [COMMITTED] ada: Avoid duplicated streaming subprograms
@ 2023-05-25 8:05 Marc Poulhiès
0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2023-05-25 8:05 UTC (permalink / raw)
To: gcc-patches; +Cc: Steve Baird
From: Steve Baird <baird@adacore.com>
In some common cases, a reference to Some_Type'Some_Streaming_Attribute
causes the needed subprogram to be generated "on demand". If there are
multiple such references (e.g., two calls to Some_Type'Write) then we
want to avoid generating multiple essentially-identical subprograms.
This change implies that a generated streaming subprogram may now have
multiple call sites, so we can no longer use the source position information
from the (one and only) call site. If an exception is raised during a
streaming operation, this can make a difference in the reported raise location.
gcc/ada/
* exp_attr.adb
(Cached_Streaming_Ops): A new package, providing maps to save
previously-generated Read/Write/Input/Output procedures.
(Expand_N_Attribute_Reference): When a new subprogram is generated
for a Read/Write/Input/Output attribute reference, record that
type/subp pair in the appropriate Cached_Streaming_Ops map.
(Find_Stream_Subprogram): Check the appropriate
Cached_Streaming_Ops map to see if an appropriate subprogram has
already been generated. If so, then return it. The appropriateness
test includes a call to a new nested subprogram,
In_Available_Context.
* exp_strm.ads, exp_strm.adb: Do not pass in a Loc parameter (or a
source-location-bearing Nod parameter) to the 16 procedures
provided for building streaming-related subprograms. Use the
source location of the type instead.
* exp_dist.adb, exp_ch3.adb: Adapt to Exp_Strm spec changes. For
these calls the source location of the type was already being
used.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_attr.adb | 279 +++++++++++++++++++++++++++++++++----------
gcc/ada/exp_ch3.adb | 8 +-
gcc/ada/exp_dist.adb | 10 +-
gcc/ada/exp_strm.adb | 100 ++++++++--------
gcc/ada/exp_strm.ads | 39 ++----
5 files changed, 286 insertions(+), 150 deletions(-)
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index a5791adf7dd..7235a164e0a 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -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,
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index b992a587433..e23a3fde15c 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -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;
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index 7805f74e412..8f62bef2c64 100644
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.adb
@@ -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,
diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb
index 2610584cef0..f1203ad9e97 100644
--- a/gcc/ada/exp_strm.adb
+++ b/gcc/ada/exp_strm.adb
@@ -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
diff --git a/gcc/ada/exp_strm.ads b/gcc/ada/exp_strm.ads
index e0d180aacbc..d56a5985989 100644
--- a/gcc/ada/exp_strm.ads
+++ b/gcc/ada/exp_strm.ads
@@ -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;
--
2.40.0
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-05-25 8:06 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-05-25 8:05 [COMMITTED] ada: Avoid duplicated streaming subprograms Marc Poulhiès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).