+2014-08-04 Robert Dewar <dewar@adacore.com>
+
+ * prj-strt.adb, prj-strt.ads, sem_attr.adb: Minor reformatting.
+
+2014-08-04 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * aspects.adb Add an entry in table Canonical_Aspect for
+ Default_Initial_Condition.
+ * aspects.ads Add an entry in tables Aspect_Id, Aspect_Argument,
+ Aspect_Names and Aspect_Delay for Default_Initial_Condition.
+ * einfo.adb Flag3 is now Has_Default_Init_Cond. Flag132
+ is now Is_Default_Init_Cond_ Procedure. Flag133 is now
+ Has_Inherited_Default_Init_Cond.
+ (Default_Init_Cond_Procedure): New routine.
+ (Has_Default_Init_Cond): New routine.
+ (Has_Inherited_Default_Init_Cond): New routine.
+ (Is_Default_Init_Cond_Procedure): New routine.
+ (Set_Default_Init_Cond_Procedure): New routine.
+ (Set_Has_Default_Init_Cond): New routine.
+ (Set_Has_Inherited_Default_Init_Cond): New routine.
+ (Set_Is_Default_Init_Cond_Procedure): New routine.
+ (Write_Entity_Flags): Output all the new flags.
+ * einfo.ads New attributes Default_Init_Cond_Procedure,
+ Has_Inherited_Default_Init_Cond and Is_Default_Init_Cond_Procedure
+ along with usage in nodes.
+ (Default_Init_Cond_Procedure): New routine.
+ (Has_Default_Init_Cond): New routine and pragma Inline.
+ (Has_Inherited_Default_Init_Cond): New routine and
+ pragma Inline.
+ (Is_Default_Init_Cond_Procedure): New routine and
+ pragma Inline.
+ (Set_Default_Init_Cond_Procedure): New routine.
+ (Set_Has_Default_Init_Cond): New routine and pragma Inline.
+ (Set_Has_Inherited_Default_Init_Cond): New routine and pragma Inline.
+ (Set_Is_Default_Init_Cond_Procedure): New routine and pragma Inline.
+ * exp_ch3.adb (Expand_N_Object_Declaration): New constant
+ Next_N. Generate a call to the default initial condition procedure
+ if the object's type is subject to the pragma. (Freeze_Type):
+ Generate the body of the default initial condition procedure or
+ inherit the spec from a parent type.
+ * exp_ch7.adb Add with and use clause for Exp_Prag.
+ (Expand_Pragma_Initial_Condition): Removed.
+ * exp_prag.ads, exp_prag.adb (Expand_Pragma_Initial_Condition): New
+ routine.
+ * par-prag.adb (Prag): Pragma Default_Initial_Condition does
+ not need special treatment by the parser.
+ * sem_ch3.adb (Build_Derived_Record_Type): Propagate the
+ attributes related to pragma Default_Initial_Condition to the
+ derived type.
+ (Process_Full_View): Propagate the attributes
+ related to pragma Default_Initial_Condition to the full view.
+ * sem_ch7.adb (Analyze_Package_Specification): Build the
+ declaration of the default initial condition procedure for all
+ types that qualify or inherit the one from the parent type.
+ * sem_ch13.adb (Analyze_Aspect_Specifications):
+ Add processing for aspect Default_Initial_Condition.
+ (Check_Aspect_At_Freeze_Point): Aspect
+ Default_Initial_Condition does not require delayed analysis.
+ (Replace_Type_References_Generic): Moved to spec.
+ * sem_ch13.ads (Replace_Type_References_Generic): Moved from body.
+ * sem_prag.adb Add an entry in table Sif_Glags for
+ Default_Initial_Condition.
+ (Analyze_Pragma): Pragma
+ Default_Initial_Condition is now part of assertion
+ policy. Add processing for pragma Default_Initial_Condition.
+ (Is_Valid_Assertion_Kind): Pragma Default_Initial_Condition is
+ now recognized as a proper assertion policy.
+ * sem_util.ads, sem_util.adb (Build_Default_Init_Cond_Call): New
+ routine.
+ (Build_Default_Init_Cond_Procedure_Body): New routine.
+ (Build_Default_Init_Cond_Procedure_Declaration): New routine.
+ (Inherit_Default_Init_Cond_Procedure): New routine.
+ * snames.ads-tmpl Add new predefined name and pragma id for
+ Default_Initial_Condition.
+
2014-08-04 Vincent Celier <celier@adacore.com>
* prj-dect.adb (Parse_Case_Construction): It is no longer
Aspect_Convention => Aspect_Convention,
Aspect_CPU => Aspect_CPU,
Aspect_Default_Component_Value => Aspect_Default_Component_Value,
+ Aspect_Default_Initial_Condition => Aspect_Default_Initial_Condition,
Aspect_Default_Iterator => Aspect_Default_Iterator,
Aspect_Default_Value => Aspect_Default_Value,
Aspect_Depends => Aspect_Depends,
Aspect_Convention,
Aspect_CPU,
Aspect_Default_Component_Value,
+ Aspect_Default_Initial_Condition, -- GNAT
Aspect_Default_Iterator,
Aspect_Default_Value,
Aspect_Depends, -- GNAT
-- The following array indicates what argument type is required
Aspect_Argument : constant array (Aspect_Id) of Aspect_Expression :=
- (No_Aspect => Optional_Expression,
- Aspect_Abstract_State => Expression,
- Aspect_Address => Expression,
- Aspect_Alignment => Expression,
- Aspect_Annotate => Expression,
- Aspect_Attach_Handler => Expression,
- Aspect_Bit_Order => Expression,
- Aspect_Component_Size => Expression,
- Aspect_Constant_Indexing => Name,
- Aspect_Contract_Cases => Expression,
- Aspect_Convention => Name,
- Aspect_CPU => Expression,
- Aspect_Default_Component_Value => Expression,
- Aspect_Default_Iterator => Name,
- Aspect_Default_Value => Expression,
- Aspect_Depends => Expression,
- Aspect_Dimension => Expression,
- Aspect_Dimension_System => Expression,
- Aspect_Dispatching_Domain => Expression,
- Aspect_Dynamic_Predicate => Expression,
- Aspect_External_Name => Expression,
- Aspect_External_Tag => Expression,
- Aspect_Global => Expression,
- Aspect_Implicit_Dereference => Name,
- Aspect_Initial_Condition => Expression,
- Aspect_Initializes => Expression,
- Aspect_Input => Name,
- Aspect_Interrupt_Priority => Expression,
- Aspect_Invariant => Expression,
- Aspect_Iterable => Expression,
- Aspect_Iterator_Element => Name,
- Aspect_Link_Name => Expression,
- Aspect_Linker_Section => Expression,
- Aspect_Machine_Radix => Expression,
- Aspect_Object_Size => Expression,
- Aspect_Output => Name,
- Aspect_Part_Of => Expression,
- Aspect_Post => Expression,
- Aspect_Postcondition => Expression,
- Aspect_Pre => Expression,
- Aspect_Precondition => Expression,
- Aspect_Predicate => Expression,
- Aspect_Priority => Expression,
- Aspect_Read => Name,
- Aspect_Refined_Depends => Expression,
- Aspect_Refined_Global => Expression,
- Aspect_Refined_Post => Expression,
- Aspect_Refined_State => Expression,
- Aspect_Relative_Deadline => Expression,
- Aspect_Scalar_Storage_Order => Expression,
- Aspect_Simple_Storage_Pool => Name,
- Aspect_Size => Expression,
- Aspect_Small => Expression,
- Aspect_SPARK_Mode => Optional_Name,
- Aspect_Static_Predicate => Expression,
- Aspect_Storage_Pool => Name,
- Aspect_Storage_Size => Expression,
- Aspect_Stream_Size => Expression,
- Aspect_Suppress => Name,
- Aspect_Synchronization => Name,
- Aspect_Test_Case => Expression,
- Aspect_Type_Invariant => Expression,
- Aspect_Unsuppress => Name,
- Aspect_Value_Size => Expression,
- Aspect_Variable_Indexing => Name,
- Aspect_Warnings => Name,
- Aspect_Write => Name,
-
- Boolean_Aspects => Optional_Expression,
- Library_Unit_Aspects => Optional_Expression);
+ (No_Aspect => Optional_Expression,
+ Aspect_Abstract_State => Expression,
+ Aspect_Address => Expression,
+ Aspect_Alignment => Expression,
+ Aspect_Annotate => Expression,
+ Aspect_Attach_Handler => Expression,
+ Aspect_Bit_Order => Expression,
+ Aspect_Component_Size => Expression,
+ Aspect_Constant_Indexing => Name,
+ Aspect_Contract_Cases => Expression,
+ Aspect_Convention => Name,
+ Aspect_CPU => Expression,
+ Aspect_Default_Component_Value => Expression,
+ Aspect_Default_Initial_Condition => Optional_Expression,
+ Aspect_Default_Iterator => Name,
+ Aspect_Default_Value => Expression,
+ Aspect_Depends => Expression,
+ Aspect_Dimension => Expression,
+ Aspect_Dimension_System => Expression,
+ Aspect_Dispatching_Domain => Expression,
+ Aspect_Dynamic_Predicate => Expression,
+ Aspect_External_Name => Expression,
+ Aspect_External_Tag => Expression,
+ Aspect_Global => Expression,
+ Aspect_Implicit_Dereference => Name,
+ Aspect_Initial_Condition => Expression,
+ Aspect_Initializes => Expression,
+ Aspect_Input => Name,
+ Aspect_Interrupt_Priority => Expression,
+ Aspect_Invariant => Expression,
+ Aspect_Iterable => Expression,
+ Aspect_Iterator_Element => Name,
+ Aspect_Link_Name => Expression,
+ Aspect_Linker_Section => Expression,
+ Aspect_Machine_Radix => Expression,
+ Aspect_Object_Size => Expression,
+ Aspect_Output => Name,
+ Aspect_Part_Of => Expression,
+ Aspect_Post => Expression,
+ Aspect_Postcondition => Expression,
+ Aspect_Pre => Expression,
+ Aspect_Precondition => Expression,
+ Aspect_Predicate => Expression,
+ Aspect_Priority => Expression,
+ Aspect_Read => Name,
+ Aspect_Refined_Depends => Expression,
+ Aspect_Refined_Global => Expression,
+ Aspect_Refined_Post => Expression,
+ Aspect_Refined_State => Expression,
+ Aspect_Relative_Deadline => Expression,
+ Aspect_Scalar_Storage_Order => Expression,
+ Aspect_Simple_Storage_Pool => Name,
+ Aspect_Size => Expression,
+ Aspect_Small => Expression,
+ Aspect_SPARK_Mode => Optional_Name,
+ Aspect_Static_Predicate => Expression,
+ Aspect_Storage_Pool => Name,
+ Aspect_Storage_Size => Expression,
+ Aspect_Stream_Size => Expression,
+ Aspect_Suppress => Name,
+ Aspect_Synchronization => Name,
+ Aspect_Test_Case => Expression,
+ Aspect_Type_Invariant => Expression,
+ Aspect_Unsuppress => Name,
+ Aspect_Value_Size => Expression,
+ Aspect_Variable_Indexing => Name,
+ Aspect_Warnings => Name,
+ Aspect_Write => Name,
+
+ Boolean_Aspects => Optional_Expression,
+ Library_Unit_Aspects => Optional_Expression);
-----------------------------------------
-- Table Linking Names and Aspect_Id's --
Aspect_Contract_Cases => Name_Contract_Cases,
Aspect_Convention => Name_Convention,
Aspect_CPU => Name_CPU,
+ Aspect_Default_Component_Value => Name_Default_Component_Value,
+ Aspect_Default_Initial_Condition => Name_Default_Initial_Condition,
Aspect_Default_Iterator => Name_Default_Iterator,
Aspect_Default_Value => Name_Default_Value,
- Aspect_Default_Component_Value => Name_Default_Component_Value,
Aspect_Depends => Name_Depends,
Aspect_Dimension => Name_Dimension,
Aspect_Dimension_System => Name_Dimension_System,
Aspect_Async_Writers => Never_Delay,
Aspect_Contract_Cases => Never_Delay,
Aspect_Convention => Never_Delay,
+ Aspect_Default_Initial_Condition => Never_Delay,
Aspect_Depends => Never_Delay,
Aspect_Dimension => Never_Delay,
Aspect_Dimension_System => Never_Delay,
-- Is_Inlined_Always Flag1
-- Is_Hidden_Non_Overridden_Subpgm Flag2
+ -- Has_Default_Init_Cond Flag3
-- Is_Frozen Flag4
-- Has_Discriminants Flag5
-- Is_Dispatching_Operation Flag6
-- Is_Generic_Instance Flag130
-- No_Pool_Assigned Flag131
+ -- Is_Default_Init_Cond_Procedure Flag132
+ -- Has_Inherited_Default_Init_Cond Flag133
-- Has_Aliased_Components Flag135
-- No_Strict_Aliasing Flag136
-- Is_Machine_Code_Subprogram Flag137
-- No_Predicate_On_Actual Flag275
-- No_Dynamic_Predicate_On_Actual Flag276
- -- (unused) Flag3
-
- -- (unused) Flag132
- -- (unused) Flag133
-- (unused) Flag134
-- (unused) Flag275
return Flag39 (Base_Type (Id));
end Has_Default_Aspect;
+ function Has_Default_Init_Cond (Id : E) return B is
+ begin
+ return Flag3 (Id);
+ end Has_Default_Init_Cond;
+
function Has_Delayed_Aspects (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag248 (Id);
end Has_Inheritable_Invariants;
+ function Has_Inherited_Default_Init_Cond (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag133 (Id);
+ end Has_Inherited_Default_Init_Cond;
+
function Has_Initial_Value (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Variable or else Is_Formal (Id));
return Flag74 (Id);
end Is_CPP_Class;
+ function Is_Default_Init_Cond_Procedure (Id : E) return B is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ return Flag132 (Id);
+ end Is_Default_Init_Cond_Procedure;
+
function Is_Descendent_Of_Address (Id : E) return B is
begin
return Flag223 (Id);
function Is_Invariant_Procedure (Id : E) return B is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Flag257 (Id);
end Is_Invariant_Procedure;
Set_Flag39 (Id, V);
end Set_Has_Default_Aspect;
+ procedure Set_Has_Default_Init_Cond (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag3 (Id, V);
+ end Set_Has_Default_Init_Cond;
+
procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag248 (Id, V);
end Set_Has_Inheritable_Invariants;
+ procedure Set_Has_Inherited_Default_Init_Cond (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag133 (Id, V);
+ end Set_Has_Inherited_Default_Init_Cond;
+
procedure Set_Has_Initial_Value (Id : E; V : B := True) is
begin
pragma Assert (Ekind_In (Id, E_Variable, E_Out_Parameter));
Set_Flag74 (Id, V);
end Set_Is_CPP_Class;
+ procedure Set_Is_Default_Init_Cond_Procedure (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Procedure);
+ Set_Flag132 (Id, V);
+ end Set_Is_Default_Init_Cond_Procedure;
+
procedure Set_Is_Descendent_Of_Address (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
procedure Set_Is_Invariant_Procedure (Id : E; V : B := True) is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind (Id) = E_Procedure);
Set_Flag257 (Id, V);
end Set_Is_Invariant_Procedure;
end loop;
end Declaration_Node;
+ ---------------------------------
+ -- Default_Init_Cond_Procedure --
+ ---------------------------------
+
+ function Default_Init_Cond_Procedure (Id : E) return E is
+ S : Entity_Id;
+
+ begin
+ pragma Assert
+ (Is_Type (Id)
+ and then (Has_Default_Init_Cond (Id)
+ or Has_Inherited_Default_Init_Cond (Id)));
+
+ S := Subprograms_For_Type (Id);
+ while Present (S) loop
+ if Is_Default_Init_Cond_Procedure (S) then
+ return S;
+ end if;
+
+ S := Subprograms_For_Type (S);
+ end loop;
+
+ return Empty;
+ end Default_Init_Cond_Procedure;
+
---------------------
-- Designated_Type --
---------------------
end case;
end Set_Component_Alignment;
+ -------------------------------------
+ -- Set_Default_Init_Cond_Procedure --
+ -------------------------------------
+
+ procedure Set_Default_Init_Cond_Procedure (Id : E; V : E) is
+ S : Entity_Id;
+
+ begin
+ pragma Assert
+ (Is_Type (Id)
+ and then (Has_Default_Init_Cond (Id)
+ or Has_Inherited_Default_Init_Cond (Id)));
+
+ S := Subprograms_For_Type (Id);
+ Set_Subprograms_For_Type (Id, V);
+ Set_Subprograms_For_Type (V, S);
+
+ -- Check for a duplicate procedure
+
+ while Present (S) loop
+ if Is_Default_Init_Cond_Procedure (S) then
+ raise Program_Error;
+ end if;
+
+ S := Subprograms_For_Type (S);
+ end loop;
+ end Set_Default_Init_Cond_Procedure;
+
-----------------------------
-- Set_Invariant_Procedure --
-----------------------------
W ("Has_Controlling_Result", Flag98 (Id));
W ("Has_Convention_Pragma", Flag119 (Id));
W ("Has_Default_Aspect", Flag39 (Id));
+ W ("Has_Default_Init_Cond", Flag3 (Id));
W ("Has_Delayed_Aspects", Flag200 (Id));
W ("Has_Delayed_Freeze", Flag18 (Id));
W ("Has_Delayed_Rep_Aspects", Flag261 (Id));
W ("Has_Implicit_Dereference", Flag251 (Id));
W ("Has_Independent_Components", Flag34 (Id));
W ("Has_Inheritable_Invariants", Flag248 (Id));
+ W ("Has_Inherited_Default_Init_Cond", Flag133 (Id));
W ("Has_Initial_Value", Flag219 (Id));
W ("Has_Invariants", Flag232 (Id));
W ("Has_Loop_Entry_Attributes", Flag260 (Id));
W ("In_Private_Part", Flag45 (Id));
W ("In_Use", Flag8 (Id));
W ("Is_Abstract_Subprogram", Flag19 (Id));
- W ("Is_Abstract_Type", Flag146 (Id));
- W ("Is_Local_Anonymous_Access", Flag194 (Id));
+ W ("Is_Abstract_Type", Flag146 (Id));
W ("Is_Access_Constant", Flag69 (Id));
W ("Is_Ada_2005_Only", Flag185 (Id));
W ("Is_Ada_2012_Only", Flag199 (Id));
W ("Is_Constructor", Flag76 (Id));
W ("Is_Controlled", Flag42 (Id));
W ("Is_Controlling_Formal", Flag97 (Id));
+ W ("Is_Default_Init_Cond_Procedure", Flag132 (Id));
W ("Is_Descendent_Of_Address", Flag223 (Id));
W ("Is_Discrim_SO_Function", Flag176 (Id));
W ("Is_Discriminant_Check_Function", Flag264 (Id));
W ("Is_Limited_Composite", Flag106 (Id));
W ("Is_Limited_Interface", Flag197 (Id));
W ("Is_Limited_Record", Flag25 (Id));
+ W ("Is_Local_Anonymous_Access", Flag194 (Id));
W ("Is_Machine_Code_Subprogram", Flag137 (Id));
W ("Is_Non_Static_Subtype", Flag109 (Id));
W ("Is_Null_Init_Proc", Flag178 (Id));
-- default expressions (see Freeze.Process_Default_Expressions), which
-- would not only waste time, but also generate false error messages.
+-- Default_Init_Cond_Procedure (synthesized)
+-- Defined in all types. Set for private [sub]types subject to pragma
+-- Default_Initial_Condition, their corresponding full views and derived
+-- types with at least one parent subject to the pragma. Contains the
+-- entity of the procedure which takes a single argument of the given
+-- type and verifies the assumption of the pragma.
+--
+-- Note: the reason this is marked as a synthesized attribute is that the
+-- way this is stored is as an element of the Subprograms_For_Type field.
+
-- Default_Value (Node20)
-- Defined in formal parameters. Points to the node representing the
-- expression for the default value for the parameter. Empty if the
-- Convention, Import, or Export has been given. Used to prevent more
-- than one such pragma appearing for a given entity (RM B.1(45)).
+-- Has_Default_Aspect (Flag39) [base type only]
+-- Defined in entities for types and subtypes, set for scalar types with
+-- a Default_Value aspect and array types with a Default_Component_Value
+-- apsect. If this flag is set, then a corresponding aspect specification
+-- node will be present on the rep item chain for the entity.
+
+-- Has_Default_Init_Cond (Flag3)
+-- Defined in type and subtype entities. Set if pragma Default_Initial_
+-- Condition applies to the type or subtype. This flag must be mutually
+-- exclusive with Has_Inherited_Default_Init_Cond.
+
-- Has_Delayed_Aspects (Flag200)
-- Defined in all entities. Set if the Rep_Item chain for the entity has
-- one or more N_Aspect_Definition nodes chained which are not to be
-- node must be generated for the entity at its freezing point. See
-- separate section ("Delayed Freezing and Elaboration") for details.
--- Has_Default_Aspect (Flag39) [base type only]
--- Defined in entities for types and subtypes, set for scalar types with
--- a Default_Value aspect and array types with a Default_Component_Value
--- apsect. If this flag is set, then a corresponding aspect specification
--- node will be present on the rep item chain for the entity.
-
-- Has_Delayed_Rep_Aspects (Flag261)
-- Defined in all type and subtypes. This flag is set if there is at
-- least one aspect for a representation characteristic that has to be
-- type which has inheritable invariants, and in this case the flag will
-- also be set in the private type.
+-- Has_Inherited_Default_Init_Cond (Flag133)
+-- Defined in type and subtype entities. Set if a derived type inherits
+-- pragma Default_Initial_Condition from its parent type. This flag must
+-- be mutually exclusive with Had_Default_Init_Cond.
+
-- Has_Initial_Value (Flag219)
-- Defined in entities for variables and out parameters. Set if there
-- is an explicit initial value expression in the declaration of the
-- Applies to all type entities, true for decimal fixed point
-- types and subtypes.
+-- Is_Default_Init_Cond_Procedure (Flag132)
+-- Defined in functions and procedures. Set for a generated procedure
+-- which verifies the assumption of pragma Default_Initial_Condition.
+
-- Is_Descendent_Of_Address (Flag223)
-- Defined in all entities. True if the entity is type System.Address,
-- or (recursively) a subtype or derived type of System.Address.
-- Has_Constrained_Partial_View (Flag187)
-- Has_Controlled_Component (Flag43) (base type only)
-- Has_Default_Aspect (Flag39) (base type only)
+ -- Has_Default_Init_Cond (Flag3)
-- Has_Delayed_Rep_Aspects (Flag261)
-- Has_Discriminants (Flag5)
-- Has_Dynamic_Predicate_Aspect (Flag258)
-- Has_Independent_Components (Flag34) (base type only)
-- Has_Inheritable_Invariants (Flag248)
+ -- Has_Inherited_Default_Init_Cond (Flag133)
-- Has_Invariants (Flag232)
-- Has_Non_Standard_Rep (Flag75) (base type only)
-- Has_Object_Size_Clause (Flag172)
-- Alignment_Clause (synth)
-- Base_Type (synth)
+ -- Default_Init_Cond_Procedure (synth)
-- Implementation_Base_Type (synth)
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
-- Is_Asynchronous (Flag81)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
+ -- Is_Default_Init_Cond_Procedure (Flag132) (non-generic case only)
-- Is_Eliminated (Flag124)
-- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only)
-- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only)
function Has_Controlling_Result (Id : E) return B;
function Has_Convention_Pragma (Id : E) return B;
function Has_Default_Aspect (Id : E) return B;
+ function Has_Default_Init_Cond (Id : E) return B;
function Has_Delayed_Aspects (Id : E) return B;
function Has_Delayed_Freeze (Id : E) return B;
function Has_Delayed_Rep_Aspects (Id : E) return B;
function Has_Implicit_Dereference (Id : E) return B;
function Has_Independent_Components (Id : E) return B;
function Has_Inheritable_Invariants (Id : E) return B;
+ function Has_Inherited_Default_Init_Cond (Id : E) return B;
function Has_Initial_Value (Id : E) return B;
function Has_Interrupt_Handler (Id : E) return B;
function Has_Invariants (Id : E) return B;
function Is_Constructor (Id : E) return B;
function Is_Controlled (Id : E) return B;
function Is_Controlling_Formal (Id : E) return B;
+ function Is_Default_Init_Cond_Procedure (Id : E) return B;
function Is_Descendent_Of_Address (Id : E) return B;
function Is_Discrim_SO_Function (Id : E) return B;
function Is_Discriminant_Check_Function (Id : E) return B;
procedure Set_Has_Controlling_Result (Id : E; V : B := True);
procedure Set_Has_Convention_Pragma (Id : E; V : B := True);
procedure Set_Has_Default_Aspect (Id : E; V : B := True);
+ procedure Set_Has_Default_Init_Cond (Id : E; V : B := True);
procedure Set_Has_Delayed_Aspects (Id : E; V : B := True);
procedure Set_Has_Delayed_Freeze (Id : E; V : B := True);
procedure Set_Has_Delayed_Rep_Aspects (Id : E; V : B := True);
procedure Set_Has_Implicit_Dereference (Id : E; V : B := True);
procedure Set_Has_Independent_Components (Id : E; V : B := True);
procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True);
+ procedure Set_Has_Inherited_Default_Init_Cond (Id : E; V : B := True);
procedure Set_Has_Initial_Value (Id : E; V : B := True);
procedure Set_Has_Invariants (Id : E; V : B := True);
procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True);
procedure Set_Is_Constructor (Id : E; V : B := True);
procedure Set_Is_Controlled (Id : E; V : B := True);
procedure Set_Is_Controlling_Formal (Id : E; V : B := True);
+ procedure Set_Is_Default_Init_Cond_Procedure (Id : E; V : B := True);
procedure Set_Is_Descendent_Of_Address (Id : E; V : B := True);
procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True);
procedure Set_Is_Discriminant_Check_Function (Id : E; V : B := True);
-- Access to Subprograms in Subprograms_For_Type --
---------------------------------------------------
- function Invariant_Procedure (Id : E) return N;
- function Predicate_Function (Id : E) return N;
- function Predicate_Function_M (Id : E) return N;
+ function Default_Init_Cond_Procedure (Id : E) return E;
+ function Invariant_Procedure (Id : E) return E;
+ function Predicate_Function (Id : E) return E;
+ function Predicate_Function_M (Id : E) return E;
+ procedure Set_Default_Init_Cond_Procedure (Id : E; V : E);
procedure Set_Invariant_Procedure (Id : E; V : E);
procedure Set_Predicate_Function (Id : E; V : E);
procedure Set_Predicate_Function_M (Id : E; V : E);
pragma Inline (Has_Controlling_Result);
pragma Inline (Has_Convention_Pragma);
pragma Inline (Has_Default_Aspect);
+ pragma Inline (Has_Default_Init_Cond);
pragma Inline (Has_Delayed_Aspects);
pragma Inline (Has_Delayed_Freeze);
pragma Inline (Has_Delayed_Rep_Aspects);
pragma Inline (Has_Implicit_Dereference);
pragma Inline (Has_Independent_Components);
pragma Inline (Has_Inheritable_Invariants);
+ pragma Inline (Has_Inherited_Default_Init_Cond);
pragma Inline (Has_Initial_Value);
pragma Inline (Has_Invariants);
pragma Inline (Has_Loop_Entry_Attributes);
pragma Inline (Is_Controlled);
pragma Inline (Is_Controlling_Formal);
pragma Inline (Is_Decimal_Fixed_Point_Type);
+ pragma Inline (Is_Default_Init_Cond_Procedure);
pragma Inline (Is_Descendent_Of_Address);
pragma Inline (Is_Digits_Type);
pragma Inline (Is_Discrete_Or_Fixed_Point_Type);
pragma Inline (Set_Has_Controlling_Result);
pragma Inline (Set_Has_Convention_Pragma);
pragma Inline (Set_Has_Default_Aspect);
+ pragma Inline (Set_Has_Default_Init_Cond);
pragma Inline (Set_Has_Delayed_Aspects);
pragma Inline (Set_Has_Delayed_Freeze);
pragma Inline (Set_Has_Delayed_Rep_Aspects);
pragma Inline (Set_Has_Implicit_Dereference);
pragma Inline (Set_Has_Independent_Components);
pragma Inline (Set_Has_Inheritable_Invariants);
+ pragma Inline (Set_Has_Inherited_Default_Init_Cond);
pragma Inline (Set_Has_Initial_Value);
pragma Inline (Set_Has_Invariants);
pragma Inline (Set_Has_Loop_Entry_Attributes);
pragma Inline (Set_Is_Constructor);
pragma Inline (Set_Is_Controlled);
pragma Inline (Set_Is_Controlling_Formal);
+ pragma Inline (Set_Is_Default_Init_Cond_Procedure);
pragma Inline (Set_Is_Descendent_Of_Address);
pragma Inline (Set_Is_Discrim_SO_Function);
pragma Inline (Set_Is_Discriminant_Check_Function);
-- needed after an initialization. Typ is the component type, and Proc_Id
-- the initialization procedure for the enclosing composite type.
- procedure Expand_Tagged_Root (T : Entity_Id);
- -- Add a field _Tag at the beginning of the record. This field carries
- -- the value of the access to the Dispatch table. This procedure is only
- -- called on root type, the _Tag field being inherited by the descendants.
-
procedure Expand_Freeze_Array_Type (N : Node_Id);
-- Freeze an array type. Deals with building the initialization procedure,
-- creating the packed array type for a packed array and also with the
-- applies only to E_Record_Type entities, not to class wide types,
-- record subtypes, or private types.
+ procedure Expand_Tagged_Root (T : Entity_Id);
+ -- Add a field _Tag at the beginning of the record. This field carries
+ -- the value of the access to the Dispatch table. This procedure is only
+ -- called on root type, the _Tag field being inherited by the descendants.
+
procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id);
-- Treat user-defined stream operations as renaming_as_body if the
-- subprogram they rename is not frozen when the type is frozen.
return New_List (
Make_Implicit_Loop_Statement (Nod,
- Identifier => Empty,
+ Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Index,
+ Defining_Identifier => Index,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
+ Prefix =>
+ Make_Identifier (Loc, Name_uInit),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, N))))),
- Statements => Init_One_Dimension (N + 1)));
+ Statements => Init_One_Dimension (N + 1)));
end if;
end Init_One_Dimension;
------------------------------------
procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
-
procedure Build_Master (Ptr_Typ : Entity_Id);
-- Create the master associated with Ptr_Typ
-- Local variables
+ Next_N : constant Node_Id := Next (N);
Id_Ref : Node_Id;
New_Ref : Node_Id;
-- by
-- Tmp : T := Obj;
-- type Ityp is not null access I'Class;
- -- CW : I'Class renames Ityp(Tmp.I_Tag'Address).all;
+ -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all;
if Comes_From_Source (Expr_N)
and then Nkind (Expr_N) = N_Identifier
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'D'),
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Name => Convert_Tag_To_Interface (Typ, Tag_Comp)));
+ Name =>
+ Convert_Tag_To_Interface (Typ, Tag_Comp)));
-- If the original entity comes from source, then mark the
-- new entity as needing debug information, even though it's
end;
end if;
+ -- At this point the object is fully initialized by either invoking the
+ -- related type init proc, routine [Deep_]Initialize or performing in-
+ -- place assingments for an array object. If the related type is subject
+ -- to pragma Default_Initial_Condition, add a runtime check to verify
+ -- the assumption of the pragma. Generate:
+
+ -- <Base_Typ>Default_Init_Cond (<Base_Typ> (Def_Id));
+
+ -- Note that the check is generated for source objects only
+
+ if Comes_From_Source (Def_Id)
+ and then (Has_Default_Init_Cond (Base_Typ)
+ or else Has_Inherited_Default_Init_Cond (Base_Typ))
+ then
+ declare
+ DIC_Call : constant Node_Id :=
+ Build_Default_Init_Cond_Call (Loc, Def_Id, Base_Typ);
+ begin
+ if Present (Next_N) then
+ Insert_Before_And_Analyze (Next_N, DIC_Call);
+
+ -- The object declaration is the last node in a declarative or a
+ -- statement list.
+
+ else
+ Append_To (List_Containing (N), DIC_Call);
+ Analyze (DIC_Call);
+ end if;
+ end;
+ end if;
+
-- Exception on library entity not available
exception
end loop;
end;
- if RACW_Seen then
-
- -- If there are RACWs designating this type, make stubs now
+ -- If there are RACWs designating this type, make stubs now
+ if RACW_Seen then
Remote_Types_Tagged_Full_View_Encountered (Def_Id);
end if;
end if;
+ -- If the type is subject to pragma Default_Initial_Condition, generate
+ -- the body of the procedure which verifies the assertion of the pragma
+ -- at runtime.
+
+ if Has_Default_Init_Cond (Def_Id) then
+ Build_Default_Init_Cond_Procedure_Body (Def_Id);
+
+ -- A derived type inherits the default initial condition procedure from
+ -- its parent type.
+
+ elsif Has_Inherited_Default_Init_Cond (Def_Id) then
+ Inherit_Default_Init_Cond_Procedure (Def_Id);
+ end if;
+
-- Freeze processing for record types
if Is_Record_Type (Def_Id) then
with Exp_Dbug; use Exp_Dbug;
with Exp_Dist; use Exp_Dist;
with Exp_Disp; use Exp_Disp;
+with Exp_Prag; use Exp_Prag;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
-- Given an arbitrary entity, traverse the scope chain looking for the
-- first enclosing function. Return Empty if no function was found.
- procedure Expand_Pragma_Initial_Condition (N : Node_Id);
- -- Subsidiary to the expansion of package specs and bodies. Generate a
- -- runtime check needed to verify the assumption introduced by pragma
- -- Initial_Condition. N denotes the package spec or body.
-
function Make_Call
(Loc : Source_Ptr;
Proc_Id : Entity_Id;
end if;
end Expand_N_Package_Declaration;
- -------------------------------------
- -- Expand_Pragma_Initial_Condition --
- -------------------------------------
-
- procedure Expand_Pragma_Initial_Condition (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Check : Node_Id;
- Expr : Node_Id;
- Init_Cond : Node_Id;
- List : List_Id;
- Pack_Id : Entity_Id;
-
- begin
- if Nkind (N) = N_Package_Body then
- Pack_Id := Corresponding_Spec (N);
-
- if Present (Handled_Statement_Sequence (N)) then
- List := Statements (Handled_Statement_Sequence (N));
-
- -- The package body lacks statements, create an empty list
-
- else
- List := New_List;
-
- Set_Handled_Statement_Sequence (N,
- Make_Handled_Sequence_Of_Statements (Loc, Statements => List));
- end if;
-
- elsif Nkind (N) = N_Package_Declaration then
- Pack_Id := Defining_Entity (N);
-
- if Present (Visible_Declarations (Specification (N))) then
- List := Visible_Declarations (Specification (N));
-
- -- The package lacks visible declarations, create an empty list
-
- else
- List := New_List;
-
- Set_Visible_Declarations (Specification (N), List);
- end if;
-
- -- This routine should not be used on anything other than packages
-
- else
- raise Program_Error;
- end if;
-
- Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition);
-
- -- The caller should check whether the package is subject to pragma
- -- Initial_Condition.
-
- pragma Assert (Present (Init_Cond));
-
- Expr :=
- Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond)));
-
- -- The assertion expression was found to be illegal, do not generate the
- -- runtime check as it will repeat the illegality.
-
- if Error_Posted (Init_Cond) or else Error_Posted (Expr) then
- return;
- end if;
-
- -- Generate:
- -- pragma Check (Initial_Condition, <Expr>);
-
- Check :=
- Make_Pragma (Loc,
- Chars => Name_Check,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression => Make_Identifier (Loc, Name_Initial_Condition)),
-
- Make_Pragma_Argument_Association (Loc,
- Expression => New_Copy_Tree (Expr))));
-
- Append_To (List, Check);
- Analyze (Check);
- end Expand_Pragma_Initial_Condition;
-
-----------------------------
-- Find_Node_To_Be_Wrapped --
-----------------------------
-- Insert the pragma
Insert_After_And_Analyze (N,
- Make_Pragma (Loc,
- Chars => Name_Machine_Attribute,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Iloc,
- Expression => New_Copy_Tree (Internal)),
- Make_Pragma_Argument_Association (Eloc,
- Expression =>
- Make_String_Literal (Sloc => Ploc,
- Strval => "common_object")),
- Make_Pragma_Argument_Association (Ploc,
- Expression => New_Copy_Tree (Psect)))));
+ Make_Pragma (Loc,
+ Chars => Name_Machine_Attribute,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Iloc,
+ Expression => New_Copy_Tree (Internal)),
+ Make_Pragma_Argument_Association (Eloc,
+ Expression =>
+ Make_String_Literal (Sloc => Ploc,
+ Strval => "common_object")),
+ Make_Pragma_Argument_Association (Ploc,
+ Expression => New_Copy_Tree (Psect)))));
end Expand_Pragma_Common_Object;
---------------------------------------
end if;
end Expand_Pragma_Import_Or_Interface;
+ -------------------------------------
+ -- Expand_Pragma_Initial_Condition --
+ -------------------------------------
+
+ procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Spec_Or_Body);
+ Check : Node_Id;
+ Expr : Node_Id;
+ Init_Cond : Node_Id;
+ List : List_Id;
+ Pack_Id : Entity_Id;
+
+ begin
+ if Nkind (Spec_Or_Body) = N_Package_Body then
+ Pack_Id := Corresponding_Spec (Spec_Or_Body);
+
+ if Present (Handled_Statement_Sequence (Spec_Or_Body)) then
+ List := Statements (Handled_Statement_Sequence (Spec_Or_Body));
+
+ -- The package body lacks statements, create an empty list
+
+ else
+ List := New_List;
+
+ Set_Handled_Statement_Sequence (Spec_Or_Body,
+ Make_Handled_Sequence_Of_Statements (Loc, Statements => List));
+ end if;
+
+ elsif Nkind (Spec_Or_Body) = N_Package_Declaration then
+ Pack_Id := Defining_Entity (Spec_Or_Body);
+
+ if Present (Visible_Declarations (Specification (Spec_Or_Body))) then
+ List := Visible_Declarations (Specification (Spec_Or_Body));
+
+ -- The package lacks visible declarations, create an empty list
+
+ else
+ List := New_List;
+
+ Set_Visible_Declarations (Specification (Spec_Or_Body), List);
+ end if;
+
+ -- This routine should not be used on anything other than packages
+
+ else
+ raise Program_Error;
+ end if;
+
+ Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition);
+
+ -- The caller should check whether the package is subject to pragma
+ -- Initial_Condition.
+
+ pragma Assert (Present (Init_Cond));
+
+ Expr :=
+ Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond)));
+
+ -- The assertion expression was found to be illegal, do not generate the
+ -- runtime check as it will repeat the illegality.
+
+ if Error_Posted (Init_Cond) or else Error_Posted (Expr) then
+ return;
+ end if;
+
+ -- Generate:
+ -- pragma Check (Initial_Condition, <Expr>);
+
+ Check :=
+ Make_Pragma (Loc,
+ Chars => Name_Check,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Name_Initial_Condition)),
+
+ Make_Pragma_Argument_Association (Loc,
+ Expression => New_Copy_Tree (Expr))));
+
+ Append_To (List, Check);
+ Analyze (Check);
+ end Expand_Pragma_Initial_Condition;
+
------------------------------------
-- Expand_Pragma_Inspection_Point --
------------------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Subp_Id's body. All generated code is added to list Stmts. If Stmts is
-- No_List on entry, a new list is created.
+ procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id);
+ -- Generate a runtime check needed to verify the assumption of introduced
+ -- by pragma Initial_Condition. Spec_Or_Body denotes the spec or body of
+ -- the package where the pragma appears. The check is inserted according
+ -- to the following precedence rules:
+ -- 1) If the package has a body with a statement sequence, the check is
+ -- inserted at the end of the statments.
+ -- 2) If the package has a body, the check is inserted at the end of the
+ -- body declarations.
+ -- 3) The check is inserted at the end of the visible declarations.
+
end Exp_Prag;
Pragma_Debug_Policy |
Pragma_Depends |
Pragma_Detect_Blocking |
+ Pragma_Default_Initial_Condition |
Pragma_Default_Scalar_Storage_Order |
Pragma_Default_Storage_Pool |
Pragma_Disable_Atomic_Synchronization |
---------------------------
procedure End_Case_Construction
- (Check_All_Labels : Boolean;
- Case_Location : Source_Ptr;
- Flags : Processing_Flags;
- String_Type : Boolean)
+ (Check_All_Labels : Boolean;
+ Case_Location : Source_Ptr;
+ Flags : Processing_Flags;
+ String_Type : Boolean)
is
- Non_Used : Natural := 0;
+ Non_Used : Natural := 0;
First_Non_Used : Choice_Node_Id := First_Choice_Node_Id;
+
begin
- -- First, if Check_All_Labels is True, check if all values
- -- of the string type have been used.
+ -- First, if Check_All_Labels is True, check if all values of the string
+ -- type have been used.
if Check_All_Labels then
if String_Type then
Error_Msg
(Flags, "?value %% is not used as label", Case_Location);
- -- If several are not used, report a warning for each one of
- -- them.
+ -- If several are not used, report a warning for each one of them
elsif Non_Used > 1 then
Error_Msg
Choices.Set_Last (First_Choice_Node_Id);
Choice_First := 0;
- elsif Choice_Lasts.Last = 2 then
-
- -- This is the second case construction, set the tables to the first
+ -- Second case construction, set the tables to the first
+ elsif Choice_Lasts.Last = 2 then
Choice_Lasts.Set_Last (1);
Choices.Set_Last (Choice_Lasts.Table (1));
Choice_First := 1;
+ -- Third or more case construction, set the tables to the previous one
else
- -- This is the 3rd or more case construction, set the tables to the
- -- previous one.
-
Choice_Lasts.Decrement_Last;
Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last));
Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1;
Scan (In_Tree);
case Token is
-
when Tok_Right_Paren =>
if Ext_List then
Error_Msg (Flags, "`,` expected", Token_Ptr);
Set_String_Value_Of (Current_Choice, In_Tree, To => Choice_String);
if String_Type then
+
-- Check if the label is part of the string type and if it has not
-- been already used.
procedure Start_New_Case_Construction
(In_Tree : Project_Node_Tree_Ref;
String_Type : Project_Node_Id);
- -- This procedure is called at the beginning of a case construction The
+ -- This procedure is called at the beginning of a case construction. The
-- parameter String_Type is the node for the string type of the case label
-- variable. The different literal strings of the string type are stored
- -- into a table to be checked against the case labels of the case
- -- construction.
+ -- into a table to be checked against the labels of the case construction.
procedure End_Case_Construction
- (Check_All_Labels : Boolean;
- Case_Location : Source_Ptr;
- Flags : Processing_Flags;
- String_Type : Boolean);
- -- This procedure is called at the end of a case construction to remove the
- -- case labels and to restore the previous state. In particular, in the
+ (Check_All_Labels : Boolean;
+ Case_Location : Source_Ptr;
+ Flags : Processing_Flags;
+ String_Type : Boolean);
+ -- This procedure is called at the end of a case construction to remove
+ -- the case labels and to restore the previous state. In particular, in the
-- case of nested case constructions, the case labels of the enclosing case
- -- construction are restored. When When_Others is False and we are not in
+ -- construction are restored. If When_Others is False and we are not in
-- quiet output, a warning is emitted for each value of the case variable
-- string type that has not been specified.
-- Default_Bit_Order --
-----------------------
- when Attribute_Default_Bit_Order => Default_Bit_Order :
- declare
+ when Attribute_Default_Bit_Order => Default_Bit_Order : declare
Target_Default_Bit_Order : System.Bit_Order;
+
begin
Check_Standard_Prefix;
when Attribute_Default_Scalar_Storage_Order => Default_SSO : declare
RE_Default_SSO : RE_Id;
+
begin
Check_Standard_Prefix;
else
RE_Default_SSO := RE_Low_Order_First;
end if;
+
when 'H' =>
RE_Default_SSO := RE_High_Order_First;
+
when 'L' =>
RE_Default_SSO := RE_Low_Order_First;
+
when others =>
raise Program_Error;
end case;
-- renaming_as_body. For tagged types, the specification is one of the
-- primitive specs.
- generic
- with procedure Replace_Type_Reference (N : Node_Id);
- procedure Replace_Type_References_Generic (N : Node_Id; T : Entity_Id);
- -- This is used to scan an expression for a predicate or invariant aspect
- -- replacing occurrences of the name of the subtype to which the aspect
- -- applies with appropriate references to the parameter of the predicate
- -- function or invariant procedure. The procedure passed as a generic
- -- parameter does the actual replacement of node N, which is either a
- -- simple direct reference to T, or a selected component that represents
- -- an appropriately qualified occurrence of T.
-
procedure Resolve_Iterable_Operation
(N : Node_Id;
Cursor : Entity_Id;
goto Continue;
end Abstract_State;
+ -- Aspect Default_Internal_Condition is never delayed because
+ -- it is equivalent to a source pragma which appears after the
+ -- related private type. To deal with forward references, the
+ -- generated pragma is stored in the rep chain of the related
+ -- private type as types do not carry contracts. The pragma is
+ -- wrapped inside of a procedure at the freeze point of the
+ -- private type's full view.
+
+ when Aspect_Default_Initial_Condition =>
+ Make_Aitem_Pragma
+ (Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Relocate_Node (Expr))),
+ Pragma_Name =>
+ Name_Default_Initial_Condition);
+
+ Decorate (Aspect, Aitem);
+ Insert_Pragma (Aitem);
+ goto Continue;
+
-- Depends
-- Aspect Depends is never delayed because it is equivalent to
-- Here is the list of aspects that don't require delay analysis
- when Aspect_Abstract_State |
- Aspect_Annotate |
- Aspect_Contract_Cases |
- Aspect_Dimension |
- Aspect_Dimension_System |
- Aspect_Implicit_Dereference |
- Aspect_Initial_Condition |
- Aspect_Initializes |
- Aspect_Part_Of |
- Aspect_Post |
- Aspect_Postcondition |
- Aspect_Pre |
- Aspect_Precondition |
- Aspect_Refined_Depends |
- Aspect_Refined_Global |
- Aspect_Refined_Post |
- Aspect_Refined_State |
- Aspect_SPARK_Mode |
- Aspect_Test_Case =>
+ when Aspect_Abstract_State |
+ Aspect_Annotate |
+ Aspect_Contract_Cases |
+ Aspect_Default_Initial_Condition |
+ Aspect_Dimension |
+ Aspect_Dimension_System |
+ Aspect_Implicit_Dereference |
+ Aspect_Initial_Condition |
+ Aspect_Initializes |
+ Aspect_Part_Of |
+ Aspect_Post |
+ Aspect_Postcondition |
+ Aspect_Pre |
+ Aspect_Precondition |
+ Aspect_Refined_Depends |
+ Aspect_Refined_Global |
+ Aspect_Refined_Post |
+ Aspect_Refined_State |
+ Aspect_SPARK_Mode |
+ Aspect_Test_Case =>
raise Program_Error;
end case;
(Rep_Item : Node_Id) return Boolean
is
begin
- return Nkind (Rep_Item) = N_Pragma
- or else Present_In_Rep_Item
- (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item));
+ return
+ Nkind (Rep_Item) = N_Pragma
+ or else Present_In_Rep_Item
+ (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item));
end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item;
-- Start of processing for Inherit_Aspects_At_Freeze_Point
end loop;
end if;
- -- Continue for any other node kind
+ -- Continue for any other node kind
else
return OK;
-- type. Returns False if no such error occurs. If this error does occur,
-- appropriate error messages are posted on node N, and True is returned.
+ generic
+ with procedure Replace_Type_Reference (N : Node_Id);
+ procedure Replace_Type_References_Generic (N : Node_Id; T : Entity_Id);
+ -- This is used to scan an expression for a predicate or invariant aspect
+ -- replacing occurrences of the name of the subtype to which the aspect
+ -- applies with appropriate references to the parameter of the predicate
+ -- function or invariant procedure. The procedure passed as a generic
+ -- parameter does the actual replacement of node N, which is either a
+ -- simple direct reference to T, or a selected component that represents
+ -- an appropriately qualified occurrence of T.
+
function Rep_Item_Too_Late
(T : Entity_Id;
N : Node_Id;
-- record type.
procedure Analyze_Object_Contract (Obj_Id : Entity_Id);
- -- Analyze all delayed aspects chained on the contract of object Obj_Id as
- -- if they appeared at the end of the declarative region. The aspects to be
+ -- Analyze all delayed pragmas chained on the contract of object Obj_Id as
+ -- if they appeared at the end of the declarative region. The pragmas to be
-- considered are:
-- Async_Readers
-- Async_Writers
end if;
Check_Function_Writable_Actuals (N);
+
+ -- Propagate the attributes related to pragma Default_Initial_Condition
+ -- from the parent type to the private extension. A derived type always
+ -- inherits the default initial condition flag from the parent type. If
+ -- the derived type carries its own Default_Initial_Condition pragma,
+ -- the flag is later reset in Analyze_Pragma. Note that both flags are
+ -- mutually exclusive.
+
+ if Has_Inherited_Default_Init_Cond (Parent_Type)
+ or else Present (Get_Pragma
+ (Parent_Type, Pragma_Default_Initial_Condition))
+ then
+ Set_Has_Inherited_Default_Init_Cond (Derived_Type);
+
+ elsif Has_Default_Init_Cond (Parent_Type) then
+ Set_Has_Default_Init_Cond (Derived_Type);
+ end if;
end Build_Derived_Record_Type;
------------------------
Set_Has_Specified_Stream_Output (Full_T);
end if;
+ -- Propagate the attributes related to pragma Default_Initial_Condition
+ -- from the private to the full view. Note that both flags are mutually
+ -- exclusive.
+
+ if Has_Inherited_Default_Init_Cond (Priv_T) then
+ Set_Has_Inherited_Default_Init_Cond (Full_T);
+ Set_Default_Init_Cond_Procedure
+ (Full_T, Default_Init_Cond_Procedure (Priv_T));
+
+ elsif Has_Default_Init_Cond (Priv_T) then
+ Set_Has_Default_Init_Cond (Full_T);
+ Set_Default_Init_Cond_Procedure
+ (Full_T, Default_Init_Cond_Procedure (Priv_T));
+ end if;
+
-- Propagate invariants to full type
if Has_Invariants (Priv_T) then
Analyze_Declarations (Vis_Decls);
end if;
- -- Verify that incomplete types have received full declarations and
- -- also build invariant procedures for any types with invariants.
+ -- Inspect the entities defined in the package and ensure that all
+ -- incomplete types have received full declarations. Build default
+ -- initial condition and invariant procedures for all types that
+ -- qualify.
E := First_Entity (Id);
while Present (E) loop
Error_Msg_N ("no declaration in visible part for incomplete}", E);
end if;
- -- Build invariant procedures
+ if Is_Type (E) then
- if Is_Type (E) and then Has_Invariants (E) then
- Build_Invariant_Procedure (E, N);
+ -- Each private type subject to pragma Default_Initial_Condition
+ -- declares a specialized procedure which verifies the assumption
+ -- of the pragma. The declaration appears in the visible part of
+ -- the package to allow for being called from the outside.
+
+ if Has_Default_Init_Cond (E) then
+ Build_Default_Init_Cond_Procedure_Declaration (E);
+
+ -- A private extension inherits the default initial condition
+ -- procedure from its parent type.
+
+ elsif Has_Inherited_Default_Init_Cond (E) then
+ Inherit_Default_Init_Cond_Procedure (E);
+ end if;
+
+ if Has_Invariants (E) then
+ Build_Invariant_Procedure (E, N);
+ end if;
end if;
Next_Entity (E);
-- final place yet. A direct analysis may generate side effects and this
-- is not desired at this point.
- Preanalyze_And_Resolve (Expr, Standard_Boolean);
+ Preanalyze_Assert_Expression (Expr, Standard_Boolean);
end Analyze_Initial_Condition_In_Decl_Part;
--------------------------------------
-- Type_Invariant |
-- Type_Invariant'Class
- -- ID_ASSERTION_KIND ::= Assert_And_Cut |
- -- Assume |
- -- Contract_Cases |
- -- Debug |
- -- Initial_Condition |
- -- Loop_Invariant |
- -- Loop_Variant |
- -- Postcondition |
- -- Precondition |
- -- Predicate |
- -- Refined_Post |
+ -- ID_ASSERTION_KIND ::= Assert_And_Cut |
+ -- Assume |
+ -- Contract_Cases |
+ -- Debug |
+ -- Default_Initial_Condition |
+ -- Initial_Condition |
+ -- Loop_Invariant |
+ -- Loop_Variant |
+ -- Postcondition |
+ -- Precondition |
+ -- Predicate |
+ -- Refined_Post |
-- Statement_Assertions
-- Note: The RM_ASSERTION_KIND list is language-defined, and the
Expression => Get_Pragma_Arg (Arg1)))));
Analyze (N);
- -------------
- -- Depends --
- -------------
-
- -- pragma Depends (DEPENDENCY_RELATION);
-
- -- DEPENDENCY_RELATION ::=
- -- null
- -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
-
- -- DEPENDENCY_CLAUSE ::=
- -- OUTPUT_LIST =>[+] INPUT_LIST
- -- | NULL_DEPENDENCY_CLAUSE
-
- -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
-
- -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
-
- -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
-
- -- OUTPUT ::= NAME | FUNCTION_RESULT
- -- INPUT ::= NAME
+ --------------------------------------
+ -- Pragma_Default_Initial_Condition --
+ --------------------------------------
- -- where FUNCTION_RESULT is a function Result attribute_reference
+ -- pragma Pragma_Default_Initial_Condition
+ -- [ (null | boolean_EXPRESSION) ];
- when Pragma_Depends => Depends : declare
- Subp_Decl : Node_Id;
+ when Pragma_Default_Initial_Condition => Default_Init_Cond : declare
+ Discard : Boolean;
+ Stmt : Node_Id;
+ Typ : Entity_Id;
begin
GNAT_Pragma;
- Check_Arg_Count (1);
- Ensure_Aggregate_Form (Arg1);
-
- -- Ensure the proper placement of the pragma. Depends must be
- -- associated with a subprogram declaration or a body that acts
- -- as a spec.
-
- Subp_Decl :=
- Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
-
- if Nkind (Subp_Decl) = N_Subprogram_Declaration then
- null;
-
- -- Body acts as spec
+ Check_At_Most_N_Arguments (1);
- elsif Nkind (Subp_Decl) = N_Subprogram_Body
- and then No (Corresponding_Spec (Subp_Decl))
- then
- null;
+ Stmt := Prev (N);
+ while Present (Stmt) loop
- -- Body stub acts as spec
+ -- Skip prior pragmas, but check for duplicates
- elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
- and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
- then
- null;
+ 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);
+ end if;
- else
- Pragma_Misplaced;
- return;
- end if;
+ -- Skip internally generated code
- -- When the pragma appears on a subprogram body, perform the full
- -- analysis now.
+ elsif not Comes_From_Source (Stmt) then
+ null;
- if Nkind (Subp_Decl) = N_Subprogram_Body then
- Analyze_Depends_In_Decl_Part (N);
+ -- The associated private type [extension] has been found, stop
+ -- the search.
- -- When Depends applies to a subprogram compilation unit, the
- -- corresponding pragma is placed after the unit's declaration
- -- node and needs to be analyzed immediately.
+ elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
+ N_Private_Type_Declaration)
+ then
+ Typ := Defining_Entity (Stmt);
+ exit;
- elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
- and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
- then
- Analyze_Depends_In_Decl_Part (N);
- end if;
+ -- The pragma does not apply to a legal construct, issue an
+ -- error and stop the analysis.
- -- Chain the pragma on the contract for further processing
+ else
+ Pragma_Misplaced;
+ return;
+ end if;
- Add_Contract_Item (N, Defining_Entity (Subp_Decl));
- end Depends;
+ Stmt := Prev (Stmt);
+ end loop;
- ---------------------
- -- Detect_Blocking --
- ---------------------
+ Set_Has_Default_Init_Cond (Typ);
+ Set_Has_Inherited_Default_Init_Cond (Typ, False);
- -- pragma Detect_Blocking;
+ -- Chain the pragma on the rep item chain for further processing
- when Pragma_Detect_Blocking =>
- Ada_2005_Pragma;
- Check_Arg_Count (0);
- Check_Valid_Configuration_Pragma;
- Detect_Blocking := True;
+ Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
+ end Default_Init_Cond;
----------------------------------
-- Default_Scalar_Storage_Order --
Default_Pool := Expression (Arg1);
+ -------------
+ -- Depends --
+ -------------
+
+ -- pragma Depends (DEPENDENCY_RELATION);
+
+ -- DEPENDENCY_RELATION ::=
+ -- null
+ -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
+
+ -- DEPENDENCY_CLAUSE ::=
+ -- OUTPUT_LIST =>[+] INPUT_LIST
+ -- | NULL_DEPENDENCY_CLAUSE
+
+ -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
+
+ -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
+
+ -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
+
+ -- OUTPUT ::= NAME | FUNCTION_RESULT
+ -- INPUT ::= NAME
+
+ -- where FUNCTION_RESULT is a function Result attribute_reference
+
+ when Pragma_Depends => Depends : declare
+ Subp_Decl : Node_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Ensure_Aggregate_Form (Arg1);
+
+ -- Ensure the proper placement of the pragma. Depends must be
+ -- associated with a subprogram declaration or a body that acts
+ -- as a spec.
+
+ Subp_Decl :=
+ Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
+
+ if Nkind (Subp_Decl) = N_Subprogram_Declaration then
+ null;
+
+ -- Body acts as spec
+
+ elsif Nkind (Subp_Decl) = N_Subprogram_Body
+ and then No (Corresponding_Spec (Subp_Decl))
+ then
+ null;
+
+ -- Body stub acts as spec
+
+ elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
+ and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
+ then
+ null;
+
+ else
+ Pragma_Misplaced;
+ return;
+ end if;
+
+ -- When the pragma appears on a subprogram body, perform the full
+ -- analysis now.
+
+ if Nkind (Subp_Decl) = N_Subprogram_Body then
+ Analyze_Depends_In_Decl_Part (N);
+
+ -- When Depends applies to a subprogram compilation unit, the
+ -- corresponding pragma is placed after the unit's declaration
+ -- node and needs to be analyzed immediately.
+
+ elsif Nkind (Subp_Decl) = N_Subprogram_Declaration
+ and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit
+ then
+ Analyze_Depends_In_Decl_Part (N);
+ end if;
+
+ -- Chain the pragma on the contract for further processing
+
+ Add_Contract_Item (N, Defining_Entity (Subp_Decl));
+ end Depends;
+
+ ---------------------
+ -- Detect_Blocking --
+ ---------------------
+
+ -- pragma Detect_Blocking;
+
+ when Pragma_Detect_Blocking =>
+ Ada_2005_Pragma;
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Detect_Blocking := True;
+
------------------------------------
-- Disable_Atomic_Synchronization --
------------------------------------
when Pragma_Invariant => Invariant : declare
Type_Id : Node_Id;
Typ : Entity_Id;
- PDecl : Node_Id;
Discard : Boolean;
begin
-- procedure declaration, so that calls to it can be generated
-- before the body is built (e.g. within an expression function).
- PDecl := Build_Invariant_Procedure_Declaration (Typ);
-
- Insert_After (N, PDecl);
- Analyze (PDecl);
+ Insert_After_And_Analyze
+ (N, Build_Invariant_Procedure_Declaration (Typ));
if Class_Present (N) then
Set_Has_Inheritable_Invariants (Typ);
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => -1,
+ Pragma_Default_Initial_Condition => -1,
Pragma_Default_Scalar_Storage_Order => 0,
Pragma_Default_Storage_Pool => -1,
Pragma_Depends => -1,
when
-- RM defined
- Name_Assert |
- Name_Static_Predicate |
- Name_Dynamic_Predicate |
- Name_Pre |
- Name_uPre |
- Name_Post |
- Name_uPost |
- Name_Type_Invariant |
- Name_uType_Invariant |
+ Name_Assert |
+ Name_Static_Predicate |
+ Name_Dynamic_Predicate |
+ Name_Pre |
+ Name_uPre |
+ Name_Post |
+ Name_uPost |
+ Name_Type_Invariant |
+ Name_uType_Invariant |
-- Impl defined
- Name_Assert_And_Cut |
- Name_Assume |
- Name_Contract_Cases |
- Name_Debug |
- Name_Initial_Condition |
- Name_Invariant |
- Name_uInvariant |
- Name_Loop_Invariant |
- Name_Loop_Variant |
- Name_Postcondition |
- Name_Precondition |
- Name_Predicate |
- Name_Refined_Post |
- Name_Statement_Assertions => return True;
-
- when others => return False;
+ Name_Assert_And_Cut |
+ Name_Assume |
+ Name_Contract_Cases |
+ Name_Debug |
+ Name_Default_Initial_Condition |
+ Name_Initial_Condition |
+ Name_Invariant |
+ Name_uInvariant |
+ Name_Loop_Invariant |
+ Name_Loop_Variant |
+ Name_Postcondition |
+ Name_Precondition |
+ Name_Predicate |
+ Name_Refined_Post |
+ Name_Statement_Assertions => return True;
+
+ when others => return False;
end case;
end Is_Valid_Assertion_Kind;
with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
return Decl;
end Build_Component_Subtype;
+ ----------------------------------
+ -- Build_Default_Init_Cond_Call --
+ ----------------------------------
+
+ function Build_Default_Init_Cond_Call
+ (Loc : Source_Ptr;
+ Obj_Id : Entity_Id;
+ Typ : Entity_Id) return Node_Id
+ is
+ Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
+ Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
+
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Proc_Id, Loc),
+ Parameter_Associations => New_List (
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
+ Expression => New_Occurrence_Of (Obj_Id, Loc))));
+ end Build_Default_Init_Cond_Call;
+
+ --------------------------------------------
+ -- Build_Default_Init_Cond_Procedure_Body --
+ --------------------------------------------
+
+ procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is
+ Param_Id : Entity_Id;
+ -- The entity of the formal parameter of the default initial condition
+ -- procedure.
+
+ procedure Replace_Type_Reference (N : Node_Id);
+ -- Replace a single reference to type Typ with a reference to Param_Id
+
+ ----------------------------
+ -- Replace_Type_Reference --
+ ----------------------------
+
+ procedure Replace_Type_Reference (N : Node_Id) is
+ begin
+ Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N)));
+ end Replace_Type_Reference;
+
+ procedure Replace_Type_References is
+ new Replace_Type_References_Generic (Replace_Type_Reference);
+
+ -- Local variables
+
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Prag : constant Node_Id :=
+ Get_Pragma (Typ, Pragma_Default_Initial_Condition);
+ Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
+ Spec_Decl : constant Node_Id := Unit_Declaration_Node (Proc_Id);
+ Body_Decl : Node_Id;
+ Expr : Node_Id;
+ Stmt : Node_Id;
+
+ -- Start of processing for Build_Default_Init_Cond_Procedure
+
+ begin
+ -- The procedure should be generated only for types subject to pragma
+ -- Default_Initial_Condition. Types that inherit the pragma do not get
+ -- this specialized procedure.
+
+ pragma Assert (Has_Default_Init_Cond (Typ));
+ pragma Assert (Present (Prag));
+ pragma Assert (Present (Proc_Id));
+
+ -- Nothing to do if the body was already built
+
+ if Present (Corresponding_Body (Spec_Decl)) then
+ return;
+ end if;
+
+ Param_Id := First_Formal (Proc_Id);
+
+ -- The pragma has an argument. Note that the argument is analyzed after
+ -- all references to the current instance of the type are replaced.
+
+ if Present (Pragma_Argument_Associations (Prag)) then
+ Expr := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
+
+ if Nkind (Expr) = N_Null then
+ Stmt := Make_Null_Statement (Loc);
+
+ -- Preserve the original argument of the pragma by replicating it.
+ -- Replace all references to the current instance of the type with
+ -- references to the formal parameter.
+
+ else
+ Expr := New_Copy_Tree (Expr);
+ Replace_Type_References (Expr, Typ);
+
+ -- Generate:
+ -- pragma Check (Default_Initial_Condition, <Expr>);
+
+ Stmt :=
+ Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Loc, Name_Check),
+
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression =>
+ Make_Identifier (Loc, Name_Default_Initial_Condition)),
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Expr)));
+ end if;
+
+ -- Otherwise the pragma appears without an argument
+
+ else
+ Stmt := Make_Null_Statement (Loc);
+ end if;
+
+ -- Generate:
+ -- procedure <Typ>Default_Init_Cond (I : <Typ>) is
+ -- begin
+ -- <Stmt>;
+ -- end <Typ>Default_Init_Cond;
+
+ Body_Decl :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Copy_Separate_Tree (Specification (Spec_Decl)),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Stmt)));
+
+ -- Link the spec and body of the default initial condition procedure
+ -- to prevent the generation of a duplicate body in case there is an
+ -- attempt to freeze the related type again.
+
+ Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl));
+ Set_Corresponding_Spec (Body_Decl, Proc_Id);
+
+ Append_Freeze_Action (Typ, Body_Decl);
+ end Build_Default_Init_Cond_Procedure_Body;
+
+ ---------------------------------------------------
+ -- Build_Default_Init_Cond_Procedure_Declaration --
+ ---------------------------------------------------
+
+ procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Prag : constant Node_Id :=
+ Get_Pragma (Typ, Pragma_Default_Initial_Condition);
+ Proc_Id : Entity_Id;
+
+ begin
+ -- The procedure should be generated only for types subject to pragma
+ -- Default_Initial_Condition. Types that inherit the pragma do not get
+ -- this specialized procedure.
+
+ pragma Assert (Has_Default_Init_Cond (Typ));
+ pragma Assert (Present (Prag));
+
+ Proc_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Default_Init_Cond"));
+
+ -- Associate the default initial condition procedure with the private
+ -- type.
+
+ Set_Ekind (Proc_Id, E_Procedure);
+ Set_Is_Default_Init_Cond_Procedure (Proc_Id);
+ Set_Default_Init_Cond_Procedure (Typ, Proc_Id);
+
+ -- Generate:
+ -- procedure <Typ>Default_Init_Cond (Inn : <Typ>);
+
+ Insert_After_And_Analyze (Prag,
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Id,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'I'),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))))));
+ end Build_Default_Init_Cond_Procedure_Declaration;
+
---------------------------
-- Build_Default_Subtype --
---------------------------
return Empty;
end Incomplete_Or_Private_View;
+ -----------------------------------------
+ -- Inherit_Default_Init_Cond_Procedure --
+ -----------------------------------------
+
+ procedure Inherit_Default_Init_Cond_Procedure (Typ : Entity_Id) is
+ Par_Typ : constant Entity_Id := Etype (Typ);
+
+ begin
+ -- A derived type inherits the default initial condition procedure of
+ -- its parent type.
+
+ if No (Default_Init_Cond_Procedure (Typ)) then
+ Set_Default_Init_Cond_Procedure
+ (Typ, Default_Init_Cond_Procedure (Par_Typ));
+ end if;
+ end Inherit_Default_Init_Cond_Procedure;
+
---------------------------------
-- Insert_Explicit_Dereference --
---------------------------------
-- Determine whether a selected component has a type that depends on
-- discriminants, and build actual subtype for it if so.
+ function Build_Default_Init_Cond_Call
+ (Loc : Source_Ptr;
+ Obj_Id : Entity_Id;
+ Typ : Entity_Id) return Node_Id;
+ -- Build a call to the default initial condition procedure of type Typ with
+ -- Obj_Id as the actual parameter.
+
+ procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id);
+ -- If private type Typ is subject to pragma Default_Initial_Condition,
+ -- build the body of the procedure which verifies the assumption of the
+ -- pragma at runtime. The generated body is added to the freeze actions
+ -- of the type.
+
+ procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id);
+ -- If private type Typ is subject to pragma Default_Initial_Condition,
+ -- build the declaration of the procedure which verifies the assumption
+ -- of the pragma at runtime. The declaration is inserted after the related
+ -- pragma.
+
function Build_Default_Subtype
(T : Entity_Id;
N : Node_Id) return Entity_Id;
-- the same type. Note that Typ may not have a partial view to begin with,
-- in that case the function returns Empty.
+ procedure Inherit_Default_Init_Cond_Procedure (Typ : Entity_Id);
+ -- Inherit the default initial condition procedure from the parent type of
+ -- derived type Typ.
+
procedure Insert_Explicit_Dereference (N : Node_Id);
-- In a context that requires a composite or subprogram type and where a
-- prefix is an access type, rewrite the access type node N (which is the
-- (e.g. target of assignment, or out parameter), and to False if the
-- modification is only potential (e.g. address of entity taken).
+ function Object_Access_Level (Obj : Node_Id) return Uint;
+ -- Return the accessibility level of the view of the object Obj. For
+ -- convenience, qualified expressions applied to object names are also
+ -- allowed as actuals for this function.
+
function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id;
-- [Ada 2012: AI05-0125-1]: If S is an inherited dispatching primitive S2,
-- or overrides an inherited dispatching primitive S2, the original
-- corresponding operation of S is the original corresponding operation of
-- S2. Otherwise, it is S itself.
- function Object_Access_Level (Obj : Node_Id) return Uint;
- -- Return the accessibility level of the view of the object Obj. For
- -- convenience, qualified expressions applied to object names are also
- -- allowed as actuals for this function.
-
function Original_Aspect_Name (N : Node_Id) return Name_Id;
-- N is a pragma node or aspect specification node. This function returns
-- the name of the pragma or aspect in original source form, taking into
-- pragma.
Name_Debug : constant Name_Id := N + $; -- GNAT
+ Name_Default_Initial_Condition : constant Name_Id := N + $; -- GNAT
Name_Depends : constant Name_Id := N + $; -- GNAT
Name_Effective_Reads : constant Name_Id := N + $; -- GNAT
Name_Effective_Writes : constant Name_Id := N + $; -- GNAT
Pragma_CPP_Virtual,
Pragma_CPP_Vtable,
Pragma_Debug,
+ Pragma_Default_Initial_Condition,
Pragma_Depends,
Pragma_Effective_Reads,
Pragma_Effective_Writes,
projects / thirdparty / gcc.git / commitdiff
