+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):
-- 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;
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);
-- 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;
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;
--------------------------
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;
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;
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;
----------------
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;
-----------
-- 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;
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;
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
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
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;
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,
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,
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;
--
-- 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;
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.
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);
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);
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:
projects / gcc.git / commitdiff