From 66340e0e9a029aa5cbba0e63f66e5319c1286ce4 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 13 Jan 2017 11:01:38 +0100 Subject: [PATCH] [multiple changes] 2017-01-13 Tristan Gingold * s-mmap.adb, s-mmap.ads (Open_Read_No_Exception): New function. (Open_Read): Re-implement using Open_Read_No_Exception. (Open_Write): Raise exception in case of error. * s-mmosin-mingw.adb (Open_Common): Do not raise exception. * s-mmosin-unix.adb (Open_Read, Open_Write): Do not reaise exception. * s-mmosin-mingw.ads, s-mmosin-unix.ads (Open_Read): Adjust comment. 2017-01-13 Yannick Moy * checks.adb: Code cleanup. 2017-01-13 Yannick Moy * freeze.adb (Check_Inherited_Conditions): Use analyzed pragma expression instead of unanalyzed aspect expression for checking the validity of inheriting an operation. Also copy the expression being passing it to Build_Class_Wide_Expression, as this call modifies its argument. * sem_util.ads Fix comment to reference correct function name New_Copy_Tree. 2017-01-13 Javier Miranda * sem_res.adb (Resolve_Generalized_Indexing): Compiling in ASIS mode, when we propagate information about the indexes back to the original indexing mode and the prefix of the index is a function call, do not remove any parameter from such call. 2017-01-13 Gary Dismukes * exp_ch6.ads (Needs_BIP_Finalization_Master): Update comment. * exp_ch6.adb (Needs_BIP_Finalization_Master): Return True for a build-in-place function whose result type is tagged. 2017-01-13 Yannick Moy * sem_ch8.adb (Analyze_Subprogram_Renaming.Build_Class_Wide_Wrapper): Do not generate a wrapper when the only candidate is a class-wide subprogram. (Analyze_Subprogram_Renaming): Do not freeze the renaming or renamed inside a generic context. From-SVN: r244399 --- gcc/ada/ChangeLog | 45 ++++++++++++++++++++++++++++++++++++++ gcc/ada/checks.adb | 22 +++++++------------ gcc/ada/exp_ch6.adb | 13 ++++++++++- gcc/ada/exp_ch6.ads | 4 +++- gcc/ada/freeze.adb | 19 ++++++++++++---- gcc/ada/s-mmap.adb | 42 +++++++++++++++++++++++++++++------ gcc/ada/s-mmap.ads | 5 +++++ gcc/ada/s-mmosin-mingw.adb | 10 ++++++--- gcc/ada/s-mmosin-mingw.ads | 4 ++-- gcc/ada/s-mmosin-unix.adb | 6 ++--- gcc/ada/s-mmosin-unix.ads | 4 ++-- gcc/ada/sem_ch8.adb | 23 ++++++++++++++++--- gcc/ada/sem_res.adb | 2 +- gcc/ada/sem_util.ads | 30 ++++++++++++------------- 14 files changed, 172 insertions(+), 57 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f9d3a503035..bb79e01b9ba 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,48 @@ +2017-01-13 Tristan Gingold + + * s-mmap.adb, s-mmap.ads (Open_Read_No_Exception): New function. + (Open_Read): Re-implement using Open_Read_No_Exception. + (Open_Write): Raise exception in case of error. + * s-mmosin-mingw.adb (Open_Common): Do not raise exception. + * s-mmosin-unix.adb (Open_Read, Open_Write): Do not + reaise exception. + * s-mmosin-mingw.ads, s-mmosin-unix.ads (Open_Read): Adjust comment. + +2017-01-13 Yannick Moy + + * checks.adb: Code cleanup. + +2017-01-13 Yannick Moy + + * freeze.adb (Check_Inherited_Conditions): Use analyzed pragma + expression instead of unanalyzed aspect expression for checking + the validity of inheriting an operation. Also copy the expression + being passing it to Build_Class_Wide_Expression, as this call + modifies its argument. + * sem_util.ads Fix comment to reference correct function name + New_Copy_Tree. + +2017-01-13 Javier Miranda + + * sem_res.adb (Resolve_Generalized_Indexing): Compiling in ASIS mode, + when we propagate information about the indexes back to the original + indexing mode and the prefix of the index is a function call, do not + remove any parameter from such call. + +2017-01-13 Gary Dismukes + + * exp_ch6.ads (Needs_BIP_Finalization_Master): Update comment. + * exp_ch6.adb (Needs_BIP_Finalization_Master): Return True for + a build-in-place function whose result type is tagged. + +2017-01-13 Yannick Moy + + * sem_ch8.adb (Analyze_Subprogram_Renaming.Build_Class_Wide_Wrapper): + Do not generate a wrapper when the only candidate is a class-wide + subprogram. + (Analyze_Subprogram_Renaming): Do not freeze the renaming or renamed + inside a generic context. + 2017-01-13 Hristian Kirtchev * exp_util.adb (Add_Inherited_Tagged_DIC): diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 6689cb56f07..6913e8fb9b4 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -337,6 +337,10 @@ package body Checks is -- Like Apply_Selected_Length_Checks, except it doesn't modify -- anything, just returns a list of nodes as described in the spec of -- this package for the Range_Check function. + -- ??? In fact it does construct the test and insert it into the tree, + -- and insert actions in various ways (calling Insert_Action directly + -- in particular) so we do not call it in GNATprove mode, contrary to + -- Selected_Range_Checks. function Selected_Range_Checks (Ck_Node : Node_Id; @@ -3085,25 +3089,18 @@ package body Checks is or else (not Length_Checks_Suppressed (Target_Typ)); begin - -- Only apply checks when generating code. In GNATprove mode, we do - -- not apply the checks, but we still call Selected_Length_Checks to - -- possibly issue errors on SPARK code when a run-time error can be - -- detected at compile time. + -- Only apply checks when generating code -- Note: this means that we lose some useful warnings if the expander -- is not active. - if not Expander_Active and not GNATprove_Mode then + if not Expander_Active then return; end if; R_Result := Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty); - if GNATprove_Mode then - return; - end if; - for J in 1 .. 2 loop R_Cno := R_Result (J); exit when No (R_Cno); @@ -9082,12 +9079,9 @@ package body Checks is -- Start of processing for Selected_Length_Checks begin - -- Checks will be applied only when generating code. In GNATprove mode, - -- we do not apply the checks, but we still call Selected_Length_Checks - -- to possibly issue errors on SPARK code when a run-time error can be - -- detected at compile time. + -- Checks will be applied only when generating code - if not Expander_Active and not GNATprove_Mode then + if not Expander_Active then return Ret_Result; end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 77b8ad2679d..04122e35f16 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -8378,9 +8378,20 @@ package body Exp_Ch6 is pragma Assert (Is_Build_In_Place_Function (Func_Id)); Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); begin + -- A formal giving the finalization master is needed for build-in-place + -- functions whose result type needs finalization or is a tagged type. + -- Tagged primitive build-in-place functions need such a formal because + -- they can be called by a dispatching call, and extensions may require + -- finalization even if the root type doesn't. This means they're also + -- needed for tagged nonprimitive build-in-place functions with tagged + -- results, since such functions can be called via access-to-function + -- types, and those can be used to call primitives, so masters have to + -- be passed to all such build-in-place functions, primitive or not. + return not Restriction_Active (No_Finalization) - and then Needs_Finalization (Func_Typ); + and then (Needs_Finalization (Func_Typ) + or else Is_Tagged_Type (Func_Typ)); end Needs_BIP_Finalization_Master; -------------------------- diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 5d23e47e743..249bf14a10b 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -201,7 +201,9 @@ package Exp_Ch6 is function Needs_BIP_Finalization_Master (Func_Id : Entity_Id) return Boolean; -- Ada 2005 (AI-318-02): Return True if the result subtype of function - -- Func_Id needs finalization actions. + -- Func_Id might need finalization actions. This includes build-in-place + -- functions with tagged result types, since they can be invoked via + -- dispatching calls, and descendant types may require finalization. function Needs_Result_Accessibility_Level (Func_Id : Entity_Id) return Boolean; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index ff7ee8cc271..a4ba0e69ff5 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1446,18 +1446,29 @@ package body Freeze is Prim := Node (Op_Node); if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then Par_Prim := Alias (Prim); - A_Pre := Find_Aspect (Par_Prim, Aspect_Pre); + + -- Analyze the contract items of the parent operation, before + -- they are rewritten when inherited. + + Analyze_Entry_Or_Subprogram_Contract (Par_Prim); + + A_Pre := Get_Pragma (Par_Prim, Pragma_Precondition); if Present (A_Pre) and then Class_Present (A_Pre) then + A_Pre := + Expression (First (Pragma_Argument_Associations (A_Pre))); Build_Class_Wide_Expression - (Expression (A_Pre), Prim, Par_Prim, Adjust_Sloc => False); + (New_Copy_Tree (A_Pre), Prim, Par_Prim, Adjust_Sloc => False); end if; - A_Post := Find_Aspect (Par_Prim, Aspect_Post); + A_Post := Get_Pragma (Par_Prim, Pragma_Postcondition); if Present (A_Post) and then Class_Present (A_Post) then + A_Post := + Expression (First (Pragma_Argument_Associations (A_Post))); Build_Class_Wide_Expression - (Expression (A_Post), Prim, Par_Prim, Adjust_Sloc => False); + (New_Copy_Tree (A_Post), + Prim, Par_Prim, Adjust_Sloc => False); end if; end if; diff --git a/gcc/ada/s-mmap.adb b/gcc/ada/s-mmap.adb index e9b2aff4201..aee0ebeaad0 100644 --- a/gcc/ada/s-mmap.adb +++ b/gcc/ada/s-mmap.adb @@ -112,20 +112,43 @@ package body System.Mmap is procedure To_Disk (Region : Mapped_Region); -- Write the region of the file back to disk if necessary, and free memory - --------------- - -- Open_Read -- - --------------- + ---------------------------- + -- Open_Read_No_Exception -- + ---------------------------- - function Open_Read + function Open_Read_No_Exception (Filename : String; Use_Mmap_If_Available : Boolean := True) return Mapped_File is File : constant System_File := Open_Read (Filename, Use_Mmap_If_Available); begin + if File = Invalid_System_File then + return Invalid_Mapped_File; + end if; + return new Mapped_File_Record' (Current_Region => Invalid_Mapped_Region, File => File); + end Open_Read_No_Exception; + + --------------- + -- Open_Read -- + --------------- + + function Open_Read + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return Mapped_File + is + Res : constant Mapped_File := + Open_Read_No_Exception (Filename, Use_Mmap_If_Available); + begin + if Res = Invalid_Mapped_File then + raise Ada.IO_Exceptions.Name_Error + with "Cannot open " & Filename; + else + return Res; + end if; end Open_Read; ---------------- @@ -139,9 +162,14 @@ package body System.Mmap is File : constant System_File := Open_Write (Filename, Use_Mmap_If_Available); begin - return new Mapped_File_Record' - (Current_Region => Invalid_Mapped_Region, - File => File); + if File = Invalid_System_File then + raise Ada.IO_Exceptions.Name_Error + with "Cannot open " & Filename; + else + return new Mapped_File_Record' + (Current_Region => Invalid_Mapped_Region, + File => File); + end if; end Open_Write; ----------- diff --git a/gcc/ada/s-mmap.ads b/gcc/ada/s-mmap.ads index 8eed3666949..00b080b02dd 100644 --- a/gcc/ada/s-mmap.ads +++ b/gcc/ada/s-mmap.ads @@ -140,6 +140,11 @@ package System.Mmap is -- Name_Error is raised if the file does not exist. -- Filename should be compatible with the filesystem. + function Open_Read_No_Exception + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return Mapped_File; + -- Like Open_Read but return Invalid_Mapped_File in case of error + function Open_Write (Filename : String; Use_Mmap_If_Available : Boolean := True) return Mapped_File; diff --git a/gcc/ada/s-mmosin-mingw.adb b/gcc/ada/s-mmosin-mingw.adb index 11051fc6909..b850630d53c 100644 --- a/gcc/ada/s-mmosin-mingw.adb +++ b/gcc/ada/s-mmosin-mingw.adb @@ -32,6 +32,11 @@ with Ada.IO_Exceptions; with System.Strings; use System.Strings; +with System.OS_Lib; +pragma Unreferenced (System.OS_Lib); +-- Only used to generate same runtime dependencies and same binder file on +-- GNU/Linux and Windows. + package body System.Mmap.OS_Interface is use Win; @@ -126,8 +131,7 @@ package body System.Mmap.OS_Interface is null, OPEN_EXISTING, Win.FILE_ATTRIBUTE_NORMAL, 0); if File_Handle = Win.INVALID_HANDLE_VALUE then - raise Ada.IO_Exceptions.Name_Error - with "Cannot open " & Filename; + return Invalid_System_File; end if; -- Compute its size @@ -135,7 +139,7 @@ package body System.Mmap.OS_Interface is Size := File_Size (Win.GetFileSize (File_Handle, SizeH'Access)); if Size = Win.INVALID_FILE_SIZE then - raise Ada.IO_Exceptions.Use_Error; + return Invalid_System_File; end if; if SizeH /= 0 and then File_Size'Size > 32 then diff --git a/gcc/ada/s-mmosin-mingw.ads b/gcc/ada/s-mmosin-mingw.ads index 76874a8fd8f..ad296c1c5dc 100644 --- a/gcc/ada/s-mmosin-mingw.ads +++ b/gcc/ada/s-mmosin-mingw.ads @@ -191,8 +191,8 @@ package System.Mmap.OS_Interface is function Open_Read (Filename : String; Use_Mmap_If_Available : Boolean := True) return System_File; - -- Open a file for reading and return the corresponding System_File. Raise - -- a Ada.IO_Exceptions.Name_Error if unsuccessful. + -- Open a file for reading and return the corresponding System_File. Return + -- Invalid_System_File if unsuccessful. function Open_Write (Filename : String; diff --git a/gcc/ada/s-mmosin-unix.adb b/gcc/ada/s-mmosin-unix.adb index a68c59f395e..634d980cb29 100644 --- a/gcc/ada/s-mmosin-unix.adb +++ b/gcc/ada/s-mmosin-unix.adb @@ -57,8 +57,7 @@ package body System.Mmap.OS_Interface is Open_Read (Filename, Binary); begin if Fd = Invalid_FD then - raise Ada.IO_Exceptions.Name_Error - with "Cannot open " & Filename; + return Invalid_System_File; end if; return (Fd => Fd, @@ -78,8 +77,7 @@ package body System.Mmap.OS_Interface is Open_Read_Write (Filename, Binary); begin if Fd = Invalid_FD then - raise Ada.IO_Exceptions.Name_Error - with "Cannot open " & Filename; + return Invalid_System_File; end if; return (Fd => Fd, diff --git a/gcc/ada/s-mmosin-unix.ads b/gcc/ada/s-mmosin-unix.ads index 01576390b65..002bf774351 100644 --- a/gcc/ada/s-mmosin-unix.ads +++ b/gcc/ada/s-mmosin-unix.ads @@ -61,8 +61,8 @@ package System.Mmap.OS_Interface is function Open_Read (Filename : String; Use_Mmap_If_Available : Boolean := True) return System_File; - -- Open a file for reading and return the corresponding System_File. Raise - -- a Ada.IO_Exceptions.Name_Error if unsuccessful. + -- Open a file for reading and return the corresponding System_File. Return + -- Invalid_System_File if unsuccessful. function Open_Write (Filename : String; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 1ba49628396..6ada187b60c 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1888,8 +1888,10 @@ package body Sem_Ch8 is -- -- This transformation applies only if there is no explicit visible -- class-wide operation at the point of the instantiation. Ren_Id is - -- the entity of the renaming declaration. Wrap_Id is the entity of - -- the generated class-wide wrapper (or Any_Id). + -- the entity of the renaming declaration. When the transformation + -- applies, Wrap_Id is the entity of the generated class-wide wrapper + -- (or Any_Id). Otherwise, Wrap_Id is the entity of the class-wide + -- operation. procedure Check_Null_Exclusion (Ren : Entity_Id; @@ -2372,6 +2374,16 @@ package body Sem_Ch8 is Set_Is_Overloaded (Name (N), False); Set_Referenced (Prim_Op); + -- Do not generate a wrapper when the only candidate is a class-wide + -- subprogram. Instead modify the renaming to directly map the actual + -- to the generic formal. + + if CW_Prim_OK and then Prim_Op = CW_Prim_Op then + Wrap_Id := Prim_Op; + Rewrite (Nam, New_Occurrence_Of (Prim_Op, Loc)); + return; + end if; + -- Step 3: Create the declaration and the body of the wrapper, insert -- all the pieces into the tree. @@ -3391,7 +3403,12 @@ package body Sem_Ch8 is Set_Alias (New_S, Empty); end if; - if Is_Actual then + -- Do not freeze the renaming nor the renamed entity when the context + -- is an enclosing generic. Freezing is an expansion activity, and in + -- addition the renamed entity may depend on the generic formals of + -- the enclosing generic. + + if Is_Actual and not Inside_A_Generic then Freeze_Before (N, Old_S); Freeze_Actual_Profile; Set_Has_Delayed_Freeze (New_S, False); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 235a535c7f9..85f74de2afd 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8112,7 +8112,7 @@ package body Sem_Res is end loop; if Nkind (Call) = N_Function_Call then - Indexes := Parameter_Associations (Call); + Indexes := New_Copy_List (Parameter_Associations (Call)); Pref := Remove_Head (Indexes); Set_Expressions (N, Indexes); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 2088e7f691e..1e84fa55c77 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1849,21 +1849,21 @@ package Sem_Util is Map : Elist_Id := No_Elist; New_Sloc : Source_Ptr := No_Location; New_Scope : Entity_Id := Empty) return Node_Id; - -- Given a node that is the root of a subtree, Copy_Tree copies the entire - -- syntactic subtree, including recursively any descendants whose parent - -- field references a copied node (descendants not linked to a copied node - -- by the parent field are not copied, instead the copied tree references - -- the same descendant as the original in this case, which is appropriate - -- for non-syntactic fields such as Etype). The parent pointers in the - -- copy are properly set. Copy_Tree (Empty/Error) returns Empty/Error. - -- The one exception to the rule of not copying semantic fields is that - -- any implicit types attached to the subtree are duplicated, so that - -- the copy contains a distinct set of implicit type entities. Thus this - -- function is used when it is necessary to duplicate an analyzed tree, - -- declared in the same or some other compilation unit. This function is - -- declared here rather than in atree because it uses semantic information - -- in particular concerning the structure of itypes and the generation of - -- public symbols. + -- Given a node that is the root of a subtree, New_Copy_Tree copies the + -- entire syntactic subtree, including recursively any descendants whose + -- parent field references a copied node (descendants not linked to a + -- copied node by the parent field are not copied, instead the copied tree + -- references the same descendant as the original in this case, which is + -- appropriate for non-syntactic fields such as Etype). The parent pointers + -- in the copy are properly set. New_Copy_Tree (Empty/Error) returns + -- Empty/Error. The one exception to the rule of not copying semantic + -- fields is that any implicit types attached to the subtree are + -- duplicated, so that the copy contains a distinct set of implicit type + -- entities. Thus this function is used when it is necessary to duplicate + -- an analyzed tree, declared in the same or some other compilation unit. + -- This function is declared here rather than in atree because it uses + -- semantic information in particular concerning the structure of itypes + -- and the generation of public symbols. -- The Map argument, if set to a non-empty Elist, specifies a set of -- mappings to be applied to entities in the tree. The map has the form: -- 2.30.2