OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r213552
This commit is contained in:
Arnaud Charlet 2014-08-04 11:59:56 +02:00
parent dc549f34cb
commit e477d718a3
21 changed files with 1017 additions and 392 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
gcc/ada/ChangeLog
View File

@ -1,3 +1,78 @@
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

1
gcc/ada/aspects.adb
View File

@ -509,6 +509,7 @@ package body Aspects is
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,

144
gcc/ada/aspects.ads
View File

@ -86,6 +86,7 @@ package Aspects is
Aspect_Convention,
Aspect_CPU,
Aspect_Default_Component_Value,
Aspect_Default_Initial_Condition, -- GNAT
Aspect_Default_Iterator,
Aspect_Default_Value,
Aspect_Depends, -- GNAT
@ -296,76 +297,77 @@ package Aspects is
-- 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,
(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);
Boolean_Aspects => Optional_Expression,
Library_Unit_Aspects => Optional_Expression);
-----------------------------------------
-- Table Linking Names and Aspect_Id's --
@ -392,9 +394,10 @@ package Aspects is
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,
@ -675,6 +678,7 @@ package Aspects is
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,

106
gcc/ada/einfo.adb
View File

@ -270,6 +270,7 @@ package body Einfo is
-- 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
@ -411,6 +412,8 @@ package body Einfo is
-- 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
@ -569,10 +572,6 @@ package body Einfo is
-- No_Predicate_On_Actual Flag275
-- No_Dynamic_Predicate_On_Actual Flag276
-- (unused) Flag3
-- (unused) Flag132
-- (unused) Flag133
-- (unused) Flag134
-- (unused) Flag275
@ -1394,6 +1393,11 @@ package body Einfo is
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);
@ -1478,6 +1482,12 @@ package body Einfo is
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));
@ -1975,6 +1985,12 @@ package body Einfo is
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);
@ -2137,7 +2153,7 @@ package body Einfo is
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;
@ -4140,6 +4156,12 @@ package body Einfo is
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);
@ -4226,6 +4248,12 @@ package body Einfo is
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));
@ -4748,6 +4776,12 @@ package body Einfo is
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));
@ -4920,7 +4954,7 @@ package body Einfo is
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;
@ -6410,6 +6444,31 @@ package body Einfo is
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 --
---------------------
@ -7913,6 +7972,34 @@ package body Einfo is
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 --
-----------------------------
@ -8252,6 +8339,7 @@ package body Einfo is
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));
@ -8267,6 +8355,7 @@ package body Einfo is
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));
@ -8327,8 +8416,7 @@ package body Einfo is
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));
@ -8350,6 +8438,7 @@ package body Einfo is
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));
@ -8388,6 +8477,7 @@ package body Einfo is
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));

60
gcc/ada/einfo.ads
View File

@ -772,6 +772,16 @@ package Einfo is
-- 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
@ -1474,6 +1484,17 @@ package Einfo is
-- 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
@ -1486,12 +1507,6 @@ package Einfo is
-- 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
@ -1605,6 +1620,11 @@ package Einfo is
-- 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
@ -2255,6 +2275,10 @@ package Einfo is
-- 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.
@ -5230,11 +5254,13 @@ package Einfo is
-- 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)
@ -5286,6 +5312,7 @@ package Einfo is
-- Alignment_Clause (synth)
-- Base_Type (synth)
-- Default_Init_Cond_Procedure (synth)
-- Implementation_Base_Type (synth)
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
@ -5953,6 +5980,7 @@ package Einfo is
-- 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)
@ -6550,6 +6578,7 @@ package Einfo is
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;
@ -6565,6 +6594,7 @@ package Einfo is
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;
@ -6655,6 +6685,7 @@ package Einfo is
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;
@ -7183,6 +7214,7 @@ package Einfo is
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);
@ -7198,6 +7230,7 @@ package Einfo is
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);
@ -7288,6 +7321,7 @@ package Einfo is
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);
@ -7502,10 +7536,12 @@ package Einfo is
-- 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);
@ -7929,6 +7965,7 @@ package Einfo is
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);
@ -7944,6 +7981,7 @@ package Einfo is
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);
@ -8044,6 +8082,7 @@ package Einfo is
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);
@ -8409,6 +8448,7 @@ package Einfo is
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);
@ -8424,6 +8464,7 @@ package Einfo is
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);
@ -8513,6 +8554,7 @@ package Einfo is
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);

76
gcc/ada/exp_ch3.adb
View File

@ -165,11 +165,6 @@ package body Exp_Ch3 is
-- 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
@ -193,6 +188,11 @@ package body Exp_Ch3 is
-- 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.
@ -632,19 +632,20 @@ package body Exp_Ch3 is
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;
@ -4664,7 +4665,6 @@ package body Exp_Ch3 is
------------------------------------
procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
procedure Build_Master (Ptr_Typ : Entity_Id);
-- Create the master associated with Ptr_Typ
@ -5313,6 +5313,7 @@ package body Exp_Ch3 is
-- Local variables
Next_N : constant Node_Id := Next (N);
Id_Ref : Node_Id;
New_Ref : Node_Id;
@ -5563,7 +5564,7 @@ package body Exp_Ch3 is
-- 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
@ -5672,7 +5673,8 @@ package body Exp_Ch3 is
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
@ -6026,6 +6028,37 @@ package body Exp_Ch3 is
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
@ -7357,14 +7390,27 @@ package body Exp_Ch3 is
end loop;
end;
-- If there are RACWs designating this type, make stubs now
if RACW_Seen then
-- If there are RACWs designating this type, make stubs now
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

88
gcc/ada/exp_ch7.adb
View File

@ -38,6 +38,7 @@ with Exp_Ch11; use Exp_Ch11;
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;
@ -379,11 +380,6 @@ package body Exp_Ch7 is
-- 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;
@ -4263,88 +4259,6 @@ package body Exp_Ch7 is
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 --
-----------------------------

104
gcc/ada/exp_prag.adb
View File

@ -1152,17 +1152,17 @@ package body Exp_Prag is
-- 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;
---------------------------------------
@ -1283,6 +1283,88 @@ package body Exp_Prag is
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 --
------------------------------------

13
gcc/ada/exp_prag.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -42,4 +42,15 @@ package Exp_Prag is
-- 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;

1
gcc/ada/par-prag.adb
View File

@ -1186,6 +1186,7 @@ begin
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 |

29
gcc/ada/prj-strt.adb
View File

@ -295,16 +295,17 @@ package body Prj.Strt is
---------------------------
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
@ -325,8 +326,7 @@ package body Prj.Strt is
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
@ -355,18 +355,15 @@ package body Prj.Strt is
Choices.Set_Last (First_Choice_Node_Id);
Choice_First := 0;
-- Second case construction, set the tables to the first
elsif Choice_Lasts.Last = 2 then
-- This is the second case construction, set the tables to the first
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;
@ -440,7 +437,6 @@ package body Prj.Strt is
Scan (In_Tree);
case Token is
when Tok_Right_Paren =>
if Ext_List then
Error_Msg (Flags, "`,` expected", Token_Ptr);
@ -529,6 +525,7 @@ package body Prj.Strt is
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.

19
gcc/ada/prj-strt.ads
View File

@ -50,21 +50,20 @@ private package Prj.Strt is
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.

8
gcc/ada/sem_attr.adb
View File

@ -3191,9 +3191,9 @@ package body Sem_Attr is
-- 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;
@ -3217,6 +3217,7 @@ package body Sem_Attr is
when Attribute_Default_Scalar_Storage_Order => Default_SSO : declare
RE_Default_SSO : RE_Id;
begin
Check_Standard_Prefix;
@ -3227,10 +3228,13 @@ package body Sem_Attr is
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;

79
gcc/ada/sem_ch13.adb
View File

@ -182,17 +182,6 @@ package body Sem_Ch13 is
-- 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;
@ -2221,6 +2210,26 @@ package body Sem_Ch13 is
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
@ -8737,25 +8746,26 @@ package body Sem_Ch13 is
-- 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;
@ -10555,9 +10565,10 @@ package body Sem_Ch13 is
(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
@ -11746,7 +11757,7 @@ package body Sem_Ch13 is
end loop;
end if;
-- Continue for any other node kind
-- Continue for any other node kind
else
return OK;

11
gcc/ada/sem_ch13.ads
View File

@ -144,6 +144,17 @@ package Sem_Ch13 is
-- 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;

36
gcc/ada/sem_ch3.adb
View File

@ -92,8 +92,8 @@ package body Sem_Ch3 is
-- 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
@ -8508,6 +8508,23 @@ package body Sem_Ch3 is
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;
------------------------
@ -18945,6 +18962,21 @@ package body Sem_Ch3 is
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

28
gcc/ada/sem_ch7.adb
View File

@ -1350,8 +1350,10 @@ package body Sem_Ch7 is
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
@ -1367,10 +1369,26 @@ package body Sem_Ch7 is
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);

295
gcc/ada/sem_prag.adb
View File

@ -2363,7 +2363,7 @@ package body Sem_Prag is
-- 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;
--------------------------------------
@ -11016,17 +11016,18 @@ package body Sem_Prag is
-- 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
@ -12755,100 +12756,66 @@ package body Sem_Prag is
Expression => Get_Pragma_Arg (Arg1)))));
Analyze (N);
-------------
-- Depends --
-------------
--------------------------------------
-- Pragma_Default_Initial_Condition --
--------------------------------------
-- pragma Depends (DEPENDENCY_RELATION);
-- pragma Pragma_Default_Initial_Condition
-- [ (null | boolean_EXPRESSION) ];
-- 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;
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);
Check_At_Most_N_Arguments (1);
-- Ensure the proper placement of the pragma. Depends must be
-- associated with a subprogram declaration or a body that acts
-- as a spec.
Stmt := Prev (N);
while Present (Stmt) loop
Subp_Decl :=
Find_Related_Subprogram_Or_Body (N, Do_Checks => True);
-- Skip prior pragmas, but check for duplicates
if Nkind (Subp_Decl) = N_Subprogram_Declaration 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;
-- Body acts as spec
-- Skip internally generated code
elsif Nkind (Subp_Decl) = N_Subprogram_Body
and then No (Corresponding_Spec (Subp_Decl))
then
null;
elsif not Comes_From_Source (Stmt) then
null;
-- Body stub acts as spec
-- The associated private type [extension] has been found, stop
-- the search.
elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
then
null;
elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
N_Private_Type_Declaration)
then
Typ := Defining_Entity (Stmt);
exit;
else
Pragma_Misplaced;
return;
end if;
-- The pragma does not apply to a legal construct, issue an
-- error and stop the analysis.
-- When the pragma appears on a subprogram body, perform the full
-- analysis now.
else
Pragma_Misplaced;
return;
end if;
if Nkind (Subp_Decl) = N_Subprogram_Body then
Analyze_Depends_In_Decl_Part (N);
Stmt := Prev (Stmt);
end loop;
-- 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.
Set_Has_Default_Init_Cond (Typ);
Set_Has_Inherited_Default_Init_Cond (Typ, False);
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 rep item chain for further processing
-- 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;
Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
end Default_Init_Cond;
----------------------------------
-- Default_Scalar_Storage_Order --
@ -12946,6 +12913,101 @@ package body Sem_Prag is
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 --
------------------------------------
@ -15208,7 +15270,6 @@ package body Sem_Prag is
when Pragma_Invariant => Invariant : declare
Type_Id : Node_Id;
Typ : Entity_Id;
PDecl : Node_Id;
Discard : Boolean;
begin
@ -15265,10 +15326,8 @@ package body Sem_Prag is
-- 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);
@ -24719,6 +24778,7 @@ package body Sem_Prag is
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,
@ -25105,34 +25165,35 @@ package body Sem_Prag is
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;
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;
when others => return False;
end case;
end Is_Valid_Assertion_Kind;

201
gcc/ada/sem_util.adb
View File

@ -48,6 +48,7 @@ with Sem; use Sem;
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;
@ -1229,6 +1230,189 @@ package body Sem_Util is
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 --
---------------------------
@ -9066,6 +9250,23 @@ package body Sem_Util is
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 --
---------------------------------

33
gcc/ada/sem_util.ads
View File

@ -211,6 +211,25 @@ package Sem_Util is
-- 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;
@ -1065,6 +1084,10 @@ package Sem_Util is
-- 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
@ -1596,17 +1619,17 @@ package Sem_Util is
-- (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

2
gcc/ada/snames.ads-tmpl
View File

@ -479,6 +479,7 @@ package Snames is
-- 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
@ -1810,6 +1811,7 @@ package Snames is
Pragma_CPP_Virtual,
Pragma_CPP_Vtable,
Pragma_Debug,
Pragma_Default_Initial_Condition,
Pragma_Depends,
Pragma_Effective_Reads,
Pragma_Effective_Writes,