+2017-04-25 Arnaud Charlet <charlet@adacore.com>
+
+ * a-cfinve.ads, a-cofove.ads (Empty_Vector): add Global contract.
+
+2017-04-25 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch3.adb (Analyze_Declarations): Minor
+ correction to comments, move out large conditional and scope
+ traversal into a predicate.
+ (Uses_Unseen_Lib_Unit_Priv): Predicate function made from extracted
+ logic.
+
+2017-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Analyze_Selected_Component): Refine analysis
+ of prefix whose type is a current instance of a synchronized
+ type. If the prefix is an object this is an external call (or
+ requeue) that can only access public operations of the object. The
+ previous predicate was too restrictive, and did not allow public
+ protected operations, only task entries.
+
+2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch5.adb, fname.adb: Minor reformatting.
+
+2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb (Is_Anonymous_Access_Type): New routine.
+ * einfo.ads Update the placement of
+ E_Anonymous_Access_Subprogram_Type along with all subtypes that
+ mention the ekind.
+ (Is_Anonymous_Access_Type): New routine.
+ * exp_ch7.adb (Allows_Finalization_Master): Do not generate a
+ master for an access type subject to pragma No_Heap_Finalization.
+ * exp_util.adb (Build_Allocate_Deallocate_Proc): An object being
+ allocated or deallocated does not finalization actions if the
+ associated access type is subject to pragma No_Heap_Finalization.
+ * opt.ads Add new global variable No_Heap_Finalization_Pragma.
+ * par-prag.adb Pragma No_Heap_Finalization does not need special
+ processing from the parser.
+ * sem_ch6.adb (Check_Return_Subtype_Indication): Remove ancient
+ ??? comments. Use the new predicate Is_Anonymous_Access_Type.
+ * sem_prag.adb Add an entry in table Sig_Flags for pragma
+ No_Heap_Finalization.
+ (Analyze_Pragma): Add processing for
+ pragma No_Heap_Finalization. Update various error messages to
+ use Duplication_Error.
+ * sem_util.ads, sem_util.adb (No_Heap_Finalization): New routine.
+ * snames.ads-tmpl: Add new predefined name No_Heap_Finalization
+ and corresponding pragma id.
+
2017-04-25 Bob Duff <duff@adacore.com>
* freeze.adb (Freeze_Record_Type): Use the
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
type Vector (Capacity : Capacity_Range) is limited private with
Default_Initial_Condition;
- function Empty_Vector return Vector;
+ function Empty_Vector return Vector with
+ Global => null;
function "=" (Left, Right : Vector) return Boolean with
Global => null;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- unbounded case; you can't assign from one object to another if the
-- Capacity is different.
- function Empty_Vector return Vector;
+ function Empty_Vector return Vector with
+ Global => null;
function "=" (Left, Right : Vector) return Boolean with
Global => null;
return Ekind (Id) in Aggregate_Kind;
end Is_Aggregate_Type;
+ function Is_Anonymous_Access_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Anonymous_Access_Kind;
+ end Is_Anonymous_Access_Type;
+
function Is_Array_Type (Id : E) return B is
begin
return Ekind (Id) in Array_Kind;
-- An access to subprogram type, created by an access to subprogram
-- declaration.
- E_Anonymous_Access_Subprogram_Type,
- -- An anonymous access to subprogram type, created by an access to
- -- subprogram declaration, or generated for a current instance of
- -- a type name appearing within a component definition that has an
- -- anonymous access to subprogram type.
-
E_Access_Protected_Subprogram_Type,
-- An access to a protected subprogram, created by the corresponding
-- declaration. Values of such a type denote both a protected object
-- An anonymous access to protected subprogram type, created by an
-- access to subprogram declaration.
+ E_Anonymous_Access_Subprogram_Type,
+ -- An anonymous access to subprogram type, created by an access to
+ -- subprogram declaration, or generated for a current instance of
+ -- a type name appearing within a component definition that has an
+ -- anonymous access to subprogram type.
+
E_Anonymous_Access_Type,
-- An anonymous access type created by an access parameter or access
-- discriminant.
-- E_Allocator_Type
-- E_General_Access_Type
-- E_Access_Subprogram_Type
- -- E_Anonymous_Access_Subprogram_Type
-- E_Access_Protected_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
+ -- E_Anonymous_Access_Subprogram_Type
E_Anonymous_Access_Type;
subtype Access_Subprogram_Kind is Entity_Kind range
E_Access_Subprogram_Type ..
- -- E_Anonymous_Access_Subprogram_Type
-- E_Access_Protected_Subprogram_Type
- E_Anonymous_Access_Protected_Subprogram_Type;
+ -- E_Anonymous_Access_Protected_Subprogram_Type
+ E_Anonymous_Access_Subprogram_Type;
subtype Access_Protected_Kind is Entity_Kind range
E_Access_Protected_Subprogram_Type ..
-- E_Record_Type
E_Record_Subtype;
+ subtype Anonymous_Access_Kind is Entity_Kind range
+ E_Anonymous_Access_Protected_Subprogram_Type ..
+ -- E_Anonymous_Subprogram_Type
+ E_Anonymous_Access_Type;
+
subtype Array_Kind is Entity_Kind range
E_Array_Type ..
-- E_Array_Subtype
-- E_General_Access_Type
-- E_Access_Subprogram_Type
-- E_Access_Protected_Subprogram_Type
- -- E_Anonymous_Access_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
+ -- E_Anonymous_Access_Subprogram_Type
E_Anonymous_Access_Type;
subtype Enumeration_Kind is Entity_Kind range
-- E_General_Access_Type
-- E_Access_Subprogram_Type,
-- E_Access_Protected_Subprogram_Type
- -- E_Anonymous_Access_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
+ -- E_Anonymous_Access_Subprogram_Type
-- E_Anonymous_Access_Type
-- E_Array_Type
-- E_Array_Subtype
function Is_Access_Protected_Subprogram_Type (Id : E) return B;
function Is_Access_Subprogram_Type (Id : E) return B;
function Is_Aggregate_Type (Id : E) return B;
+ function Is_Anonymous_Access_Type (Id : E) return B;
function Is_Array_Type (Id : E) return B;
function Is_Assignable (Id : E) return B;
function Is_Class_Wide_Type (Id : E) return B;
then
return False;
- -- Do not consider types that return on the secondary stack
+ -- Do not consider an access type which return on the secondary stack
elsif Present (Associated_Storage_Pool (Ptr_Typ))
and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
then
return False;
- -- Do not consider types which may never allocate an object
+ -- Do not consider an access type which may never allocate an object
elsif No_Pool_Assigned (Ptr_Typ) then
return False;
- -- Do not consider access types coming from Ada.Unchecked_Deallocation
- -- instances. Even though the designated type may be controlled, the
- -- access type will never participate in allocation.
+ -- Do not consider an access type coming from an Unchecked_Deallocation
+ -- instance. Even though the designated type may be controlled, the
+ -- access type will never participate in any allocations.
elsif In_Deallocation_Instance (Ptr_Typ) then
return False;
- -- Do not consider non-library access types when restriction
- -- No_Nested_Finalization is in effect since masters are controlled
- -- objects.
+ -- Do not consider a non-library access type when No_Nested_Finalization
+ -- is in effect since finalization masters are controlled objects and if
+ -- created will violate the restriction.
elsif Restriction_Active (No_Nested_Finalization)
and then not Is_Library_Level_Entity (Ptr_Typ)
then
return False;
+ -- Do not consider an access type subject to pragma No_Heap_Finalization
+ -- because objects allocated through such a type are not to be finalized
+ -- when the access type goes out of scope.
+
+ elsif No_Heap_Finalization (Ptr_Typ) then
+ return False;
+
-- Do not create finalization masters in GNATprove mode because this
-- causes unwanted extra expansion. A compilation in this mode must
-- keep the tree as close as possible to the original sources.
(N : Node_Id;
Is_Allocate : Boolean)
is
- Desig_Typ : Entity_Id;
- Expr : Node_Id;
- Pool_Id : Entity_Id;
- Proc_To_Call : Node_Id := Empty;
- Ptr_Typ : Entity_Id;
-
function Find_Object (E : Node_Id) return Node_Id;
-- Given an arbitrary expression of an allocator, try to find an object
-- reference in it, otherwise return the original expression.
return False;
end Is_Allocate_Deallocate_Proc;
+ -- Local variables
+
+ Desig_Typ : Entity_Id;
+ Expr : Node_Id;
+ Needs_Fin : Boolean;
+ Pool_Id : Entity_Id;
+ Proc_To_Call : Node_Id := Empty;
+ Ptr_Typ : Entity_Id;
+
-- Start of processing for Build_Allocate_Deallocate_Proc
begin
return;
end if;
- if Needs_Finalization (Desig_Typ) then
+ -- Finalization actions are required when the object to be allocated or
+ -- deallocated needs these actions and the associated access type is not
+ -- subject to pragma No_Heap_Finalization.
+
+ Needs_Fin :=
+ Needs_Finalization (Desig_Typ)
+ and then not No_Heap_Finalization (Ptr_Typ);
+
+ if Needs_Fin then
-- Certain run-time configurations and targets do not provide support
-- for controlled types.
-- c) Finalization master
- if Needs_Finalization (Desig_Typ) then
+ if Needs_Fin then
Fin_Mas_Id := Finalization_Master (Ptr_Typ);
Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc);
-- Primitive Finalize_Address is never generated in CodePeer mode
-- since it contains an Unchecked_Conversion.
- if Needs_Finalization (Desig_Typ) and then not CodePeer_Mode then
+ if Needs_Fin and then not CodePeer_Mode then
Fin_Addr_Id := Finalize_Address (Desig_Typ);
pragma Assert (Present (Fin_Addr_Id));
-- h) Is_Controlled
- if Needs_Finalization (Desig_Typ) then
- declare
+ if Needs_Fin then
+ Is_Controlled : declare
Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
Flag_Expr : Node_Id;
Param : Node_Id;
Expression => Flag_Expr));
Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc));
- end;
+ end Is_Controlled;
-- The object is not controlled
Insert_Action (N,
Make_Subprogram_Body (Loc,
- Specification =>
+ Specification =>
-- procedure Pnn
Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Proc_Id,
+ Defining_Unit_Name => Proc_Id,
Parameter_Specifications => New_List (
-- P : Root_Storage_Pool
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Temporary (Loc, 'P'),
- Parameter_Type =>
+ Parameter_Type =>
New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)),
-- A : [out] Address
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Storage_Count), Loc)))),
- Declarations => No_List,
+ Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Proc_To_Call, Loc),
+ Name =>
+ New_Occurrence_Of (Proc_To_Call, Loc),
Parameter_Associations => Actuals)))));
-- The newly generated Allocate / Deallocate becomes the default
-- Class-wide types are treated as controlled because derivations
-- from the root type can introduce controlled components.
- return Is_Class_Wide_Type (T)
+ return
+ Is_Class_Wide_Type (T)
or else Is_Controlled (T)
or else Has_Some_Controlled_Component (T)
or else
Renamings_Included : Boolean := True) return Boolean
is
Result : constant Boolean :=
- Is_Predefined_File_Name
- (Get_Name_String (Fname), Renamings_Included);
+ Is_Predefined_File_Name
+ (Get_Name_String (Fname), Renamings_Included);
begin
return Result;
end Is_Predefined_File_Name;
-- in the spec of the extended main unit. Used to determine if we need to
-- do special tests for violation of this aspect.
+ No_Heap_Finalization_Pragma : Node_Id := Empty;
+ -- GNAT
+ -- Set to point to a No_Heap_Finalization pragma defined in a configuration
+ -- file.
+
No_Main_Subprogram : Boolean := False;
-- GNATMAKE, GNATBIND
-- Set to True if compilation/binding of a program without main
| Pragma_Memory_Size
| Pragma_No_Body
| Pragma_No_Elaboration_Code_All
+ | Pragma_No_Heap_Finalization
| Pragma_No_Inline
| Pragma_No_Return
| Pragma_No_Run_Time
-- Utility to resolve the expressions of aspects at the end of a list of
-- declarations.
+ function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean;
+ -- Check if an inner package has entities within it that rely on library
+ -- level private types where the full view has not been seen.
+
-----------------
-- Adjust_Decl --
-----------------
end loop;
end Resolve_Aspects;
+ -------------------------------
+ -- Uses_Unseen_Lib_Unit_Priv --
+ -------------------------------
+
+ function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean is
+ Curr : Entity_Id;
+
+ begin
+ -- Avoid looking through scopes that do not meet the precondition of
+ -- Pkg not being within a library unit spec.
+
+ if not Is_Compilation_Unit (Pkg)
+ and then not Is_Generic_Instance (Pkg)
+ and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg))
+ then
+ -- Loop through all entities in the current scope to identify
+ -- an entity that depends on a private type.
+
+ Curr := First_Entity (Pkg);
+ loop
+ if Nkind (Curr) in N_Entity
+ and then Depends_On_Private (Curr)
+ then
+ return True;
+ end if;
+
+ exit when Last_Entity (Current_Scope) = Curr;
+ Curr := Next_Entity (Curr);
+ end loop;
+ end if;
+
+ return False;
+ end Uses_Unseen_Lib_Unit_Priv;
+
-- Local variables
Context : Node_Id := Empty;
Body_Seen : Boolean := False;
-- Flag set when the first body [stub] is encountered
- Ignore_Freezing : Boolean;
- -- Flag set when deciding to freeze an expression function in the
- -- current scope.
-
-- Start of processing for Analyze_Declarations
begin
-- care to attach the bodies at a proper place in the tree so as to
-- not cause unwanted freezing at that point.
- elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) then
-
- -- Check for an edge case that may cause premature freezing of
- -- a private type. If there is a type which depends on another
- -- private type from an enclosing package that is in the same
- -- scope as a non-completing expression function then we cannot
- -- freeze here.
+ -- It is also necessary to check for a case where both an expression
+ -- function is used and the current scope depends on an unseen
+ -- private type from a library unit, otherwise premature freezing of
+ -- the private type will occur.
- Ignore_Freezing := False;
-
- if Nkind (Next_Decl) = N_Subprogram_Body
- and then Was_Expression_Function (Next_Decl)
- and then not Is_Compilation_Unit (Current_Scope)
- and then not Is_Generic_Instance (Current_Scope)
- and then not In_Package_Body
- (Enclosing_Lib_Unit_Entity (Current_Scope))
+ elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl)
+ and then ((Nkind (Next_Decl) /= N_Subprogram_Body
+ or else not Was_Expression_Function (Next_Decl))
+ or else not Uses_Unseen_Lib_Unit_Priv (Current_Scope))
+ then
+ -- When a controlled type is frozen, the expander generates stream
+ -- and controlled-type support routines. If the freeze is caused
+ -- by the stand-alone body of Initialize, Adjust, or Finalize, the
+ -- expander will end up using the wrong version of these routines,
+ -- as the body has not been processed yet. To remedy this, detect
+ -- a late controlled primitive and create a proper spec for it.
+ -- This ensures that the primitive will override its inherited
+ -- counterpart before the freeze takes place.
+
+ -- If the declaration we just processed is a body, do not attempt
+ -- to examine Next_Decl as the late primitive idiom can only apply
+ -- to the first encountered body.
+
+ -- The spec of the late primitive is not generated in ASIS mode to
+ -- ensure a consistent list of primitives that indicates the true
+ -- semantic structure of the program (which is not relevant when
+ -- generating executable code).
+
+ -- ??? A cleaner approach may be possible and/or this solution
+ -- could be extended to general-purpose late primitives, TBD.
+
+ if not ASIS_Mode
+ and then not Body_Seen
+ and then not Is_Body (Decl)
then
- -- Loop through all entities in the current scope to identify
- -- an instance of the edge case outlined above and ignore
- -- freezing if it is detected.
-
- declare
- Curr : Entity_Id := First_Entity (Current_Scope);
- begin
- loop
- if Nkind (Curr) in N_Entity
- and then Depends_On_Private (Curr)
- then
- Ignore_Freezing := True;
- exit;
- end if;
-
- exit when Last_Entity (Current_Scope) = Curr;
- Curr := Next_Entity (Curr);
- end loop;
- end;
- end if;
-
- if not Ignore_Freezing then
-
- -- When a controlled type is frozen, the expander generates
- -- stream and controlled-type support routines. If the freeze
- -- is caused by the stand-alone body of Initialize, Adjust, or
- -- Finalize, the expander will end up using the wrong version
- -- of these routines, as the body has not been processed yet.
- -- To remedy this, detect a late controlled primitive and
- -- create a proper spec for it. This ensures that the primitive
- -- will override its inherited counterpart before the freeze
- -- takes place.
-
- -- If the declaration we just processed is a body, do not
- -- attempt to examine Next_Decl as the late primitive idiom can
- -- only apply to the first encountered body.
-
- -- The spec of the late primitive is not generated in ASIS mode
- -- to ensure a consistent list of primitives that indicates the
- -- true semantic structure of the program (which is not
- -- relevant when generating executable code).
-
- -- ??? A cleaner approach may be possible and/or this solution
- -- could be extended to general-purpose late primitives, TBD.
-
- if not ASIS_Mode
- and then not Body_Seen
- and then not Is_Body (Decl)
- then
- Body_Seen := True;
+ Body_Seen := True;
- if Nkind (Next_Decl) = N_Subprogram_Body then
- Handle_Late_Controlled_Primitive (Next_Decl);
- end if;
+ if Nkind (Next_Decl) = N_Subprogram_Body then
+ Handle_Late_Controlled_Primitive (Next_Decl);
end if;
+ end if;
- Adjust_Decl;
+ Adjust_Decl;
- -- The generated body of an expression function does not
- -- freeze, unless it is a completion, in which case only the
- -- expression itself freezes. This is handled when the body
- -- itself is analyzed (see Freeze_Expr_Types, sem_ch6.adb).
+ -- The generated body of an expression function does not freeze,
+ -- unless it is a completion, in which case only the expression
+ -- itself freezes. This is handled when the body itself is
+ -- analyzed (see Freeze_Expr_Types, sem_ch6.adb).
- Freeze_All (Freeze_From, Decl);
- Freeze_From := Last_Entity (Current_Scope);
- end if;
+ Freeze_All (Freeze_From, Decl);
+ Freeze_From := Last_Entity (Current_Scope);
end if;
Decl := Next_Decl;
Comp : Entity_Id;
Has_Candidate : Boolean := False;
In_Scope : Boolean;
+ Is_Private_Op : Boolean;
Parent_N : Node_Id;
Pent : Entity_Id := Empty;
Prefix_Type : Entity_Id;
-- Find visible operation with given name. For a protected type,
-- the possible candidates are discriminants, entries or protected
- -- procedures. For a task type, the set can only include entries or
+ -- subprograms. For a task type, the set can only include entries or
-- discriminants if the task type is not an enclosing scope. If it
-- is an enclosing scope (e.g. in an inner task) then all entities
-- are visible, but the prefix must denote the enclosing scope, i.e.
Set_Etype (Sel, Any_Type);
In_Scope := In_Open_Scopes (Prefix_Type);
+ Is_Private_Op := False;
while Present (Comp) loop
or else Comp /= First_Private_Entity (Type_To_Use))
then
Add_One_Interp (Sel, Comp, Etype (Comp));
+ if Comp = First_Private_Entity (Type_To_Use) then
+ Is_Private_Op := True;
+ end if;
-- If the prefix is tagged, the correct interpretation may
-- lie in the primitive or class-wide operations of the
then
null;
+ elsif Is_Protected_Type (Prefix_Type)
+ and then Is_Overloadable (Entity (Sel))
+ and then not Is_Private_Op
+ then
+ null;
+
else
Error_Msg_NE
("invalid reference to internal operation of some object of "
Set_Etype (R_Copy, It.Typ);
else
- Error_Msg_N
- ("ambiguous domain of iteration", R_Copy);
+ Error_Msg_N ("ambiguous domain of iteration", R_Copy);
end if;
end if;
end if;
Subtype_Ind : constant Node_Id :=
Object_Definition (Original_Node (Obj_Decl));
- R_Type_Is_Anon_Access : constant Boolean :=
- Ekind_In (R_Type,
- E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type,
- E_Anonymous_Access_Type);
- -- True if return type of the function is an anonymous access type
- -- Can't we make Is_Anonymous_Access_Type in einfo ???
-
- R_Stm_Type_Is_Anon_Access : constant Boolean :=
- Ekind_In (R_Stm_Type,
- E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type,
- E_Anonymous_Access_Type);
- -- True if type of the return object is an anonymous access type
-
procedure Error_No_Match (N : Node_Id);
-- Output error messages for case where types do not statically
-- match. N is the location for the messages.
-- "access T", and that the subtypes statically match:
-- if this is an access to subprogram the signatures must match.
- if R_Type_Is_Anon_Access then
- if R_Stm_Type_Is_Anon_Access then
- if
- Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type
+ if Is_Anonymous_Access_Type (R_Type) then
+ if Is_Anonymous_Access_Type (R_Stm_Type) then
+ if Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type
then
if Base_Type (Designated_Type (R_Stm_Type)) /=
Base_Type (Designated_Type (R_Type))
end if;
else
- -- For two anonymous access to subprogram types, the
- -- types themselves must be type conformant.
+ -- For two anonymous access to subprogram types, the types
+ -- themselves must be type conformant.
if not Conforming_Types
- (R_Stm_Type, R_Type, Fully_Conformant)
+ (R_Stm_Type, R_Type, Fully_Conformant)
then
Error_No_Match (Subtype_Ind);
end if;
-- If the return object is of an anonymous access type, then report
-- an error if the function's result type is not also anonymous.
- elsif R_Stm_Type_Is_Anon_Access then
- pragma Assert (not R_Type_Is_Anon_Access);
- Error_Msg_N ("anonymous access not allowed for function with "
- & "named access result", Subtype_Ind);
+ elsif Is_Anonymous_Access_Type (R_Stm_Type) then
+ pragma Assert (not Is_Anonymous_Access_Type (R_Type));
+ Error_Msg_N
+ ("anonymous access not allowed for function with named access "
+ & "result", Subtype_Ind);
-- Subtype indication case: check that the return object's type is
-- covered by the result type, and that the subtypes statically match
if Is_Access_Type (R_Type)
and then
- (Can_Never_Be_Null (R_Type)
- or else Null_Exclusion_Present (Parent (Scope_Id))) /=
- Can_Never_Be_Null (R_Stm_Type)
+ (Can_Never_Be_Null (R_Type)
+ or else Null_Exclusion_Present (Parent (Scope_Id))) /=
+ Can_Never_Be_Null (R_Stm_Type)
then
Error_No_Match (Subtype_Ind);
end if;
-- AI05-103: for elementary types, subtypes must statically match
- if Is_Constrained (R_Type)
- or else Is_Access_Type (R_Type)
- then
+ if Is_Constrained (R_Type) or else Is_Access_Type (R_Type) then
if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
Error_No_Match (Subtype_Ind);
end if;
if Nkind (Stmt) = N_Pragma then
if Pragma_Name (Stmt) = Pname then
- Error_Msg_Name_1 := Pname;
- Error_Msg_Sloc := Sloc (Stmt);
- Error_Msg_N ("pragma % duplicates pragma declared#", N);
+ Duplication_Error
+ (Prag => N,
+ Prev => Stmt);
+ raise Pragma_Exit;
end if;
-- Skip internally generated code. Note that derived type
if Nkind (Stmt) = N_Pragma then
if Pragma_Name (Stmt) = Pname then
- Error_Msg_Name_1 := Pname;
- Error_Msg_Sloc := Sloc (Stmt);
- Error_Msg_N ("pragma % duplicates pragma declared#", N);
+ Duplication_Error
+ (Prag => N,
+ Prev => Stmt);
+ raise Pragma_Exit;
end if;
-- Task unit declared without a definition cannot be subject to
Opt.No_Elab_Code_All_Pragma := N;
end if;
+ --------------------------
+ -- No_Heap_Finalization --
+ --------------------------
+
+ -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
+
+ when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare
+ Context : constant Node_Id := Parent (N);
+ Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
+ Prev : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_No_Identifiers;
+
+ -- The pragma appears in a configuration file
+
+ if No (Context) then
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+
+ -- Detect a duplicate pragma
+
+ if Present (No_Heap_Finalization_Pragma) then
+ Duplication_Error
+ (Prag => N,
+ Prev => No_Heap_Finalization_Pragma);
+ raise Pragma_Exit;
+ end if;
+
+ No_Heap_Finalization_Pragma := N;
+
+ -- Otherwise the pragma should be associated with a library-level
+ -- named access-to-object type.
+
+ else
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Find_Type (Typ_Arg);
+ Typ := Entity (Typ_Arg);
+
+ -- The type being subjected to the pragma is erroneous
+
+ if Typ = Any_Type then
+ Error_Pragma ("cannot find type referenced by pragma %");
+
+ -- The pragma is applied to an incomplete or generic formal
+ -- type way too early.
+
+ elsif Rep_Item_Too_Early (Typ, N) then
+ return;
+
+ else
+ Typ := Underlying_Type (Typ);
+ end if;
+
+ -- The pragma must apply to an access-to-object type
+
+ if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then
+ null;
+
+ -- Give a detailed error message on all other access type kinds
+
+ elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then
+ Error_Pragma
+ ("pragma % cannot apply to access protected subprogram "
+ & "type");
+
+ elsif Ekind (Typ) = E_Access_Subprogram_Type then
+ Error_Pragma
+ ("pragma % cannot apply to access subprogram type");
+
+ elsif Is_Anonymous_Access_Type (Typ) then
+ Error_Pragma
+ ("pragma % cannot apply to anonymous access type");
+
+ -- Give a general error message in case the pragma applies to a
+ -- non-access type.
+
+ else
+ Error_Pragma
+ ("pragma % must apply to library level access type");
+ end if;
+
+ -- At this point the argument denotes an access-to-object type.
+ -- Ensure that the type is declared at the library level.
+
+ if Is_Library_Level_Entity (Typ) then
+ null;
+
+ -- Qietly ignore an access-to-object type originally declared
+ -- at the library level within a generic, but instantiated at
+ -- a non-library level. As a result the access-to-object type
+ -- "loses" its No_Heap_Finalization property.
+
+ elsif In_Instance then
+ raise Pragma_Exit;
+
+ else
+ Error_Pragma
+ ("pragma % must apply to library level access type");
+ end if;
+
+ -- Detect a duplicate pragma
+
+ if Present (No_Heap_Finalization_Pragma) then
+ Duplication_Error
+ (Prag => N,
+ Prev => No_Heap_Finalization_Pragma);
+ raise Pragma_Exit;
+
+ else
+ Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization);
+
+ if Present (Prev) then
+ Duplication_Error
+ (Prag => N,
+ Prev => Prev);
+ raise Pragma_Exit;
+ end if;
+ end if;
+
+ Record_Rep_Item (Typ, N);
+ end if;
+ end No_Heap_Finalization;
+
---------------
-- No_Inline --
---------------
Check_Valid_Configuration_Pragma;
if Present (SPARK_Mode_Pragma) then
- Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
- Error_Msg_N ("pragma% duplicates pragma declared#", N);
+ Duplication_Error
+ (Prag => N,
+ Prev => SPARK_Mode_Pragma);
raise Pragma_Exit;
end if;
if Nkind (Stmt) = N_Pragma then
if Pragma_Name (Stmt) = Pname then
- Error_Msg_Name_1 := Pname;
- Error_Msg_Sloc := Sloc (Stmt);
- Error_Msg_N ("pragma% duplicates pragma declared#", N);
+ Duplication_Error
+ (Prag => N,
+ Prev => Stmt);
raise Pragma_Exit;
end if;
Pragma_No_Return => 0,
Pragma_No_Body => 0,
Pragma_No_Elaboration_Code_All => 0,
+ Pragma_No_Heap_Finalization => 0,
Pragma_No_Inline => 0,
Pragma_No_Run_Time => -1,
Pragma_No_Strict_Aliasing => -1,
S : constant Ureal := Small_Value (T);
M : Urealp.Save_Mark;
R : Boolean;
+
begin
M := Urealp.Mark;
R := (U = UR_Trunc (U / S) * S);
end if;
end New_Requires_Transient_Scope;
+ --------------------------
+ -- No_Heap_Finalization --
+ --------------------------
+
+ function No_Heap_Finalization (Typ : Entity_Id) return Boolean is
+ begin
+ if Ekind_In (Typ, E_Access_Type, E_General_Access_Type)
+ and then Is_Library_Level_Entity (Typ)
+ then
+ -- A global No_Heap_Finalization pragma applies to all library-level
+ -- named access-to-object types.
+
+ if Present (No_Heap_Finalization_Pragma) then
+ return True;
+
+ -- The library-level named access-to-object type itself is subject to
+ -- pragma No_Heap_Finalization.
+
+ elsif Present (Get_Pragma (Typ, Pragma_No_Heap_Finalization)) then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end No_Heap_Finalization;
+
-----------------------
-- Normalize_Actuals --
-----------------------
-- Note that the result produced is always an expression, not a parameter
-- association node, even if named notation was used.
+ function No_Heap_Finalization (Typ : Entity_Id) return Boolean;
+ -- Determine whether type Typ is subject to pragma No_Heap_Finalization
+
procedure Normalize_Actuals
(N : Node_Id;
S : Entity_Id;
Name_License : constant Name_Id := N + $; -- GNAT
Name_Locking_Policy : constant Name_Id := N + $;
Name_Loop_Optimize : constant Name_Id := N + $; -- GNAT
+ Name_No_Heap_Finalization : constant Name_Id := N + $; -- GNAT
Name_No_Run_Time : constant Name_Id := N + $; -- GNAT
Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT
Name_No_Tagged_Streams : constant Name_Id := N + $; -- GNAT
Pragma_License,
Pragma_Locking_Policy,
Pragma_Loop_Optimize,
+ Pragma_No_Heap_Finalization,
Pragma_No_Run_Time,
Pragma_No_Strict_Aliasing,
Pragma_No_Tagged_Streams,
projects / gcc.git / commitdiff