mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-03-25 12:41:01 +08:00
[multiple changes]
2017-01-13 Tristan Gingold <gingold@adacore.com> * 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 <moy@adacore.com> * checks.adb: Code cleanup. 2017-01-13 Yannick Moy <moy@adacore.com> * 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 <miranda@adacore.com> * 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 <dismukes@adacore.com> * 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 <moy@adacore.com> * 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
This commit is contained in:
Arnaud Charlet
parent
27bb794147
commit
66340e0e9a
@ -1,3 +1,48 @@
|
||||
2017-01-13 Tristan Gingold <gingold@adacore.com>
|
||||
|
||||
* 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 <moy@adacore.com>
|
||||
|
||||
* checks.adb: Code cleanup.
|
||||
|
||||
2017-01-13 Yannick Moy <moy@adacore.com>
|
||||
|
||||
* 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 <miranda@adacore.com>
|
||||
|
||||
* 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 <dismukes@adacore.com>
|
||||
|
||||
* 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 <moy@adacore.com>
|
||||
|
||||
* 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 <kirtchev@adacore.com>
|
||||
|
||||
* exp_util.adb (Add_Inherited_Tagged_DIC):
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
--------------------------
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -112,6 +112,26 @@ 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_No_Exception --
|
||||
----------------------------
|
||||
|
||||
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 --
|
||||
---------------
|
||||
@ -120,12 +140,15 @@ package body System.Mmap is
|
||||
(Filename : String;
|
||||
Use_Mmap_If_Available : Boolean := True) return Mapped_File
|
||||
is
|
||||
File : constant System_File :=
|
||||
Open_Read (Filename, Use_Mmap_If_Available);
|
||||
Res : constant Mapped_File :=
|
||||
Open_Read_No_Exception (Filename, Use_Mmap_If_Available);
|
||||
begin
|
||||
return new Mapped_File_Record'
|
||||
(Current_Region => Invalid_Mapped_Region,
|
||||
File => File);
|
||||
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;
|
||||
|
||||
-----------
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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);
|
||||
|
||||
|
||||
@ -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:
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user