mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-13 12:31:16 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2013-01-03  Hristian Kirtchev  <kirtchev@adacore.com>

	* aspects.adb, aspects.ads: Add Aspect_Abstract_State to all the
	relevant tables.
	* einfo.ads, einfo.adb: Add Integrity_Level and Refined_State to
	the description of fields (Abstract_States): New routine.
	(Integrity_Level): New routine.
	(Has_Property): New routine.
	(Is_Input_State): New routine.
	(Is_Null_State): New routine.
	(Is_Output_State): New routine.
	(Is_Volatile_State): New routine.
	(Refined_State): New routine.
	(Set_Abstract_States): New routine.
	(Set_Integrity_Level): New routine.
	(Set_Refined_State): New routine.
	(Write_Field8_Name): Add proper output for E_Abstract_State.
	(Write_Field9_Name): Add proper output for E_Abstract_State.
	(Write_Field25_Name): Add proper output for E_Package.
	* lib-xref.ads: Add new letter for an abstract state.
	* par-prag.adb: Add pragma Abstract_State to the list of pragma
	that do not need special processing by the parser.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Convert
	aspect Abstract_State into a pragma without any form
	of legality checks. The work is done by Analyze_Pragma.
	(Check_Aspect_At_Freeze_Point): Aspect Abstract_State does not
	require delayed analysis.
	* sem_prag.adb: Add a value for pragma Abstract_State in table
	Sig_Flags.
	(Analyze_Pragma): Add legality checks for pragma
	Abstract_State. Analysis of individual states introduces a state
	abstraction entity into the visibility chain.
	* snames.ads-tmpl: Add new names for abstract state and
	integrity. Add new pragma id for abstract state.

2013-01-03  Bob Duff  <duff@adacore.com>

	* table.adb (Reallocate): Calculate new Length in
	Long_Integer to avoid overflow.

2013-01-03  Thomas Quinot  <quinot@adacore.com>

	* sem_ch3.adb, sinfo.ads, freeze.adb, sem_ch4.adb, exp_aggr.adb
	(Sem_Ch3.Analyze_Object_Declaration): Set Ekind early so that
	it is set properly when expanding the initialization expression.
	(Freeze.Check_Address_Clause): Transfer initialization expression
	to an assignment in the freeze actions, so that the object is
	initialized only after being elaborated by GIGI.
	(Sinfo (comments), Sem_Ch4.Analyze_Expression_With_Actions): Allow
	a Null_Statement as the expression in an Expression_With_Actions.
	(Exp_Aggr.Collect_Initialization_Statements): New subprogram
	shared by expansion of record and array aggregates, used to
	capture statements for an aggregate used to initalize an object
	into an Expression_With_Actions (which acts as a container for
	a list of actions).
	(Exp_Aggr.Convert_Aggr_In_Obj_Decl): Use the above to
	capture initialization statements, instead of the previously
	existing loop which left freeze nodes out of the capturing
	construct (causing out of order elaboration crashes in GIGI).
	(Exp_Aggr.Expand_Array_Aggregate):  Use the above to capture
	initialization statements (this was previously not done for
	arrays).  Also do not unconditionally prevent in place expansion
	for an object with address clause.

From-SVN: r194851
This commit is contained in:
Arnaud Charlet 2013-01-03 14:06:45 +01:00
parent 90bb7d7ab2
commit cf6956bba3
16 changed files with 718 additions and 101 deletions

64
gcc/ada/ChangeLog

@ -1,3 +1,67 @@
2013-01-03 Hristian Kirtchev <kirtchev@adacore.com>
* aspects.adb, aspects.ads: Add Aspect_Abstract_State to all the
relevant tables.
* einfo.ads, einfo.adb: Add Integrity_Level and Refined_State to
the description of fields (Abstract_States): New routine.
(Integrity_Level): New routine.
(Has_Property): New routine.
(Is_Input_State): New routine.
(Is_Null_State): New routine.
(Is_Output_State): New routine.
(Is_Volatile_State): New routine.
(Refined_State): New routine.
(Set_Abstract_States): New routine.
(Set_Integrity_Level): New routine.
(Set_Refined_State): New routine.
(Write_Field8_Name): Add proper output for E_Abstract_State.
(Write_Field9_Name): Add proper output for E_Abstract_State.
(Write_Field25_Name): Add proper output for E_Package.
* lib-xref.ads: Add new letter for an abstract state.
* par-prag.adb: Add pragma Abstract_State to the list of pragma
that do not need special processing by the parser.
* sem_ch13.adb (Analyze_Aspect_Specifications): Convert
aspect Abstract_State into a pragma without any form
of legality checks. The work is done by Analyze_Pragma.
(Check_Aspect_At_Freeze_Point): Aspect Abstract_State does not
require delayed analysis.
* sem_prag.adb: Add a value for pragma Abstract_State in table
Sig_Flags.
(Analyze_Pragma): Add legality checks for pragma
Abstract_State. Analysis of individual states introduces a state
abstraction entity into the visibility chain.
* snames.ads-tmpl: Add new names for abstract state and
integrity. Add new pragma id for abstract state.
2013-01-03 Bob Duff <duff@adacore.com>
* table.adb (Reallocate): Calculate new Length in
Long_Integer to avoid overflow.
2013-01-03 Thomas Quinot <quinot@adacore.com>
* sem_ch3.adb, sinfo.ads, freeze.adb, sem_ch4.adb, exp_aggr.adb
(Sem_Ch3.Analyze_Object_Declaration): Set Ekind early so that
it is set properly when expanding the initialization expression.
(Freeze.Check_Address_Clause): Transfer initialization expression
to an assignment in the freeze actions, so that the object is
initialized only after being elaborated by GIGI.
(Sinfo (comments), Sem_Ch4.Analyze_Expression_With_Actions): Allow
a Null_Statement as the expression in an Expression_With_Actions.
(Exp_Aggr.Collect_Initialization_Statements): New subprogram
shared by expansion of record and array aggregates, used to
capture statements for an aggregate used to initalize an object
into an Expression_With_Actions (which acts as a container for
a list of actions).
(Exp_Aggr.Convert_Aggr_In_Obj_Decl): Use the above to
capture initialization statements, instead of the previously
existing loop which left freeze nodes out of the capturing
construct (causing out of order elaboration crashes in GIGI).
(Exp_Aggr.Expand_Array_Aggregate): Use the above to capture
initialization statements (this was previously not done for
arrays). Also do not unconditionally prevent in place expansion
for an object with address clause.
2013-01-03 Thomas Quinot <quinot@adacore.com>
* gnat_rm.texi, freeze.adb (Check_Component_Storage_Order): Check that

1
gcc/ada/aspects.adb

@ -238,6 +238,7 @@ package body Aspects is
Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id :=
(No_Aspect => No_Aspect,
Aspect_Abstract_State => Aspect_Abstract_State,
Aspect_Ada_2005 => Aspect_Ada_2005,
Aspect_Ada_2012 => Aspect_Ada_2005,
Aspect_Address => Aspect_Address,

6
gcc/ada/aspects.ads

@ -74,6 +74,7 @@ package Aspects is
type Aspect_Id is
(No_Aspect, -- Dummy entry for no aspect
Aspect_Abstract_State, -- GNAT
Aspect_Address,
Aspect_Alignment,
Aspect_Attach_Handler,
@ -221,7 +222,8 @@ package Aspects is
-- The following array identifies all implementation defined aspects
Impl_Defined_Aspects : constant array (Aspect_Id) of Boolean :=
(Aspect_Ada_2005 => True,
(Aspect_Abstract_State => True,
Aspect_Ada_2005 => True,
Aspect_Ada_2012 => True,
Aspect_Compiler_Unit => True,
Aspect_Contract_Case => True,
@ -305,6 +307,7 @@ package Aspects is
Aspect_Argument : constant array (Aspect_Id) of Aspect_Expression :=
(No_Aspect => Optional,
Aspect_Abstract_State => Expression,
Aspect_Address => Expression,
Aspect_Alignment => Expression,
Aspect_Attach_Handler => Expression,
@ -370,6 +373,7 @@ package Aspects is
Aspect_Names : constant array (Aspect_Id) of Name_Id := (
No_Aspect => No_Name,
Aspect_Abstract_State => Name_Abstract_State,
Aspect_Ada_2005 => Name_Ada_2005,
Aspect_Ada_2012 => Name_Ada_2012,
Aspect_Address => Name_Address,

184
gcc/ada/einfo.adb

@ -76,6 +76,7 @@ package body Einfo is
-- Associated_Node_For_Itype Node8
-- Dependent_Instances Elist8
-- Hiding_Loop_Variable Node8
-- Integrity_Level Uint8
-- Mechanism Uint8 (but returns Mechanism_Type)
-- Normalized_First_Bit Uint8
-- Postcondition_Proc Node8
@ -84,6 +85,7 @@ package body Einfo is
-- Class_Wide_Type Node9
-- Current_Value Node9
-- Refined_State Node9
-- Renaming_Map Uint9
-- Direct_Primitive_Operations Elist10
@ -535,6 +537,12 @@ package body Einfo is
-- Local subprograms --
-----------------------
function Has_Property
(State : Entity_Id;
Prop_Nam : Name_Id) return Boolean;
-- Determine whether abstract state State has a particular property denoted
-- by the name Prop_Nam.
function Rep_Clause (Id : E; Rep_Name : Name_Id) return N;
-- Returns the attribute definition clause for Id whose name is Rep_Name.
-- Returns Empty if no matching attribute definition clause found for Id.
@ -549,6 +557,41 @@ package body Einfo is
return F'Val (UI_To_Int (Uint10 (Base_Type (Id))));
end Float_Rep;
------------------
-- Has_Property --
------------------
function Has_Property
(State : Entity_Id;
Prop_Nam : Name_Id) return Boolean
is
Par : constant Node_Id := Parent (State);
Prop : Node_Id;
begin
pragma Assert (Ekind (State) = E_Abstract_State);
-- States with properties appear as extension aggregates in the tree
if Nkind (Par) = N_Extension_Aggregate then
if Prop_Nam = Name_Integrity then
return Present (Component_Associations (Par));
else
Prop := First (Expressions (Par));
while Present (Prop) loop
if Chars (Prop) = Prop_Nam then
return True;
end if;
Next (Prop);
end loop;
end if;
end if;
return False;
end Has_Property;
----------------
-- Rep_Clause --
----------------
@ -575,6 +618,12 @@ package body Einfo is
-- Attribute Access Functions --
--------------------------------
function Abstract_States (Id : E) return L is
begin
pragma Assert (Ekind (Id) = E_Package);
return Elist25 (Id);
end Abstract_States;
function Accept_Address (Id : E) return L is
begin
return Elist21 (Id);
@ -1662,6 +1711,12 @@ package body Einfo is
return Node28 (Id);
end Initialization_Statements;
function Integrity_Level (Id : E) return U is
begin
pragma Assert (Ekind (Id) = E_Abstract_State);
return Uint8 (Id);
end Integrity_Level;
function Inner_Instances (Id : E) return L is
begin
return Elist23 (Id);
@ -2534,6 +2589,12 @@ package body Einfo is
return Flag227 (Id);
end Referenced_As_Out_Parameter;
function Refined_State (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Abstract_State);
return Node9 (Id);
end Refined_State;
function Register_Exception_Call (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Exception);
@ -3084,6 +3145,12 @@ package body Einfo is
-- it is possible to add assertions that specifically include the E_Void
-- possibility, but in some cases, we just omit the assertions.
procedure Set_Abstract_States (Id : E; V : L) is
begin
pragma Assert (Ekind (Id) = E_Package);
Set_Elist25 (Id, V);
end Set_Abstract_States;
procedure Set_Accept_Address (Id : E; V : L) is
begin
Set_Elist21 (Id, V);
@ -4200,6 +4267,12 @@ package body Einfo is
Set_Node28 (Id, V);
end Set_Initialization_Statements;
procedure Set_Integrity_Level (Id : E; V : Uint) is
begin
pragma Assert (Ekind (Id) = E_Abstract_State);
Set_Uint8 (Id, V);
end Set_Integrity_Level;
procedure Set_Inner_Instances (Id : E; V : L) is
begin
Set_Elist23 (Id, V);
@ -5110,6 +5183,12 @@ package body Einfo is
Set_Flag227 (Id, V);
end Set_Referenced_As_Out_Parameter;
procedure Set_Refined_State (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Abstract_State);
Set_Node9 (Id, V);
end Set_Refined_State;
procedure Set_Register_Exception_Call (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_Exception);
@ -6364,6 +6443,37 @@ package body Einfo is
and then Chars (Id) = Name_uFinalizer;
end Is_Finalizer;
--------------------
-- Is_Input_State --
--------------------
function Is_Input_State (Id : E) return B is
begin
return
Ekind (Id) = E_Abstract_State and then Has_Property (Id, Name_Input);
end Is_Input_State;
-------------------
-- Is_Null_State --
-------------------
function Is_Null_State (Id : E) return B is
begin
return
Ekind (Id) = E_Abstract_State
and then Nkind (Parent (Id)) = N_Null;
end Is_Null_State;
---------------------
-- Is_Output_State --
---------------------
function Is_Output_State (Id : E) return B is
begin
return
Ekind (Id) = E_Abstract_State and then Has_Property (Id, Name_Output);
end Is_Output_State;
-----------------------------------
-- Is_Package_Or_Generic_Package --
-----------------------------------
@ -6376,33 +6486,6 @@ package body Einfo is
Ekind (Id) = E_Generic_Package;
end Is_Package_Or_Generic_Package;
------------------------
-- Predicate_Function --
------------------------
function Predicate_Function (Id : E) return E is
S : Entity_Id;
begin
pragma Assert (Is_Type (Id));
if No (Subprograms_For_Type (Id)) then
return Empty;
else
S := Subprograms_For_Type (Id);
while Present (S) loop
if Has_Predicates (S) then
return S;
else
S := Subprograms_For_Type (S);
end if;
end loop;
return Empty;
end if;
end Predicate_Function;
---------------
-- Is_Prival --
---------------
@ -6534,6 +6617,17 @@ package body Einfo is
and then Is_Task_Type (Corresponding_Concurrent_Type (Id));
end Is_Task_Record_Type;
-----------------------
-- Is_Volatile_State --
-----------------------
function Is_Volatile_State (Id : E) return B is
begin
return
Ekind (Id) = E_Abstract_State
and then Has_Property (Id, Name_Volatile);
end Is_Volatile_State;
------------------------
-- Is_Wrapper_Package --
------------------------
@ -6917,6 +7011,33 @@ package body Einfo is
return Ekind (Id);
end Parameter_Mode;
------------------------
-- Predicate_Function --
------------------------
function Predicate_Function (Id : E) return E is
S : Entity_Id;
begin
pragma Assert (Is_Type (Id));
if No (Subprograms_For_Type (Id)) then
return Empty;
else
S := Subprograms_For_Type (Id);
while Present (S) loop
if Has_Predicates (S) then
return S;
else
S := Subprograms_For_Type (S);
end if;
end loop;
return Empty;
end if;
end Predicate_Function;
-------------------------
-- Present_In_Rep_Item --
-------------------------
@ -7835,6 +7956,9 @@ package body Einfo is
when E_Variable =>
Write_Str ("Hiding_Loop_Variable");
when E_Abstract_State =>
Write_Str ("Integrity_Level");
when Formal_Kind |
E_Function |
E_Subprogram_Body =>
@ -7868,6 +7992,9 @@ package body Einfo is
when Object_Kind =>
Write_Str ("Current_Value");
when E_Abstract_State =>
Write_Str ("Refined_State");
when E_Function |
E_Generic_Function |
E_Generic_Package |
@ -8594,6 +8721,9 @@ package body Einfo is
procedure Write_Field25_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Package =>
Write_Str ("Abstract_States");
when E_Variable =>
Write_Str ("Debug_Renaming_Link");

87
gcc/ada/einfo.ads

@ -327,6 +327,10 @@ package Einfo is
-- type, and if assertions are enabled, an attempt to set the attribute on a
-- subtype will raise an assert error.
-- Abstract_States (Elist25)
-- Defined for E_Package entities. Contains a list of all the abstract
-- states declared by the related package.
-- Accept_Address (Elist21)
-- Defined in entries. If an accept has a statement sequence, then an
-- address variable is created, which is used to hold the address of the
@ -1907,18 +1911,6 @@ package Einfo is
-- that we still have a concrete type. For entities other than types,
-- returns the entity unchanged.
-- Interface_Alias (Node25)
-- Defined in subprograms that cover a primitive operation of an abstract
-- interface type. Can be set only if the Is_Hidden flag is also set,
-- since such entities are always hidden. Points to its associated
-- interface subprogram. It is used to register the subprogram in
-- secondary dispatch table of the interface (Ada 2005: AI-251).
-- Interfaces (Elist25)
-- Defined in record types and subtypes. List of abstract interfaces
-- implemented by a tagged type that are not already implemented by the
-- ancestors (Ada 2005: AI-251).
-- In_Package_Body (Flag48)
-- Defined in package entities. Set on the entity that denotes the
-- package (the defining occurrence of the package declaration) while
@ -1943,6 +1935,18 @@ package Einfo is
-- instantiated within the given generic. Used to diagnose circular
-- instantiations.
-- Integrity_Level (Uint8)
-- Defined for E_Abstract_State entities. Contains the numerical value of
-- the integrity level state property. A value of Uint_0 designates a non
-- existent integrity.
-- Interface_Alias (Node25)
-- Defined in subprograms that cover a primitive operation of an abstract
-- interface type. Can be set only if the Is_Hidden flag is also set,
-- since such entities are always hidden. Points to its associated
-- interface subprogram. It is used to register the subprogram in
-- secondary dispatch table of the interface (Ada 2005: AI-251).
-- Interface_Name (Node21)
-- Defined in constants, variables, exceptions, functions, procedures,
-- packages, components (JGNAT only), discriminants (JGNAT only), and
@ -1967,6 +1971,11 @@ package Einfo is
-- External_Name of the imported Java field (which is generally needed,
-- because Java names are case sensitive).
-- Interfaces (Elist25)
-- Defined in record types and subtypes. List of abstract interfaces
-- implemented by a tagged type that are not already implemented by the
-- ancestors (Ada 2005: AI-251).
-- Invariant_Procedure (synthesized)
-- Defined in types and subtypes. Set for private types if one or more
-- Invariant, or Invariant'Class, or inherited Invariant'Class aspects
@ -2329,6 +2338,10 @@ package Einfo is
-- inherited by their instances. It is also set on the body entities
-- of inlined subprograms. See also Has_Pragma_Inline.
-- Is_Input_State (synthesized)
-- Applies to all entities, true for abstract states that are subject to
-- property Input.
-- Is_Instantiated (Flag126)
-- Defined in generic packages and generic subprograms. Set if the unit
-- is instantiated from somewhere in the extended main source unit. This
@ -2523,6 +2536,10 @@ package Einfo is
-- but there is no need to call such procedures within a compilation
-- unit, and this flag is used to suppress such calls.
-- Is_Null_State (synthesized)
-- Applies to all entities, true for an abstract state declared with
-- keyword null.
-- Is_Numeric_Type (synthesized)
-- Applies to all entities, true for all numeric types and subtypes
-- (integer, fixed, float).
@ -2550,6 +2567,10 @@ package Einfo is
-- Applies to all entities, true for ordinary fixed point types and
-- subtypes.
-- Is_Output_State (synthesized)
-- Applies to all entities, true for abstract states that are subject to
-- property Output.
-- Is_Package_Or_Generic_Package (synthesized)
-- Applies to all entities. True for packages and generic packages.
-- False for all other entities.
@ -2895,6 +2916,10 @@ package Einfo is
-- optimizations on volatile objects should test Treat_As_Volatile
-- rather than testing this flag.
-- Is_Volatile_State (synthesized)
-- Applies to all entities, true for abstract states that are subject to
-- property Volatile.
-- Is_Wrapper_Package (synthesized)
-- Defined in package entities. Indicates that the package has been
-- created as a wrapper for a subprogram instantiation.
@ -3441,6 +3466,10 @@ package Einfo is
-- we have a separate warning for variables that are only assigned and
-- never read, and out parameters are a special case.
-- Refined_State (Node9)
-- Defined in E_Abstract_State entities. Contains the entity of the
-- abstract state completion which is usually foung in package bodies.
-- Register_Exception_Call (Node20)
-- Defined in exception entities. When an exception is declared,
-- a call is expanded to Register_Exception. This field points to
@ -4400,11 +4429,16 @@ package Einfo is
-- A task body. This entity serves almost no function, since all
-- semantic analysis uses the protected entity (E_Task_Type).
E_Subprogram_Body
E_Subprogram_Body,
-- A subprogram body. Used when a subprogram has a separate declaration
-- to represent the entity for the body. This entity serves almost no
-- function, since all semantic analysis uses the subprogram entity
-- for the declaration (E_Function or E_Procedure).
E_Abstract_State
-- A state abstraction. Used to designate entities introduced by aspect
-- or pragma Abstract_State. The entity carries the various properties
-- of the state.
);
for Entity_Kind'Size use 8;
@ -4972,6 +5006,14 @@ package Einfo is
-- Applicable attributes by entity kind --
------------------------------------------
-- E_Abstract_State
-- Integrity_Level (Uint8)
-- Refined_State (Node9)
-- Is_Input_State (synth)
-- Is_Null_State (synth)
-- Is_Output_State (synth)
-- Is_Volatile_State (synth)
-- E_Access_Protected_Subprogram_Type
-- Equivalent_Type (Node18)
-- Directly_Designated_Type (Node20)
@ -5480,8 +5522,9 @@ package Einfo is
-- Inner_Instances (Elist23) (generic case only)
-- Limited_View (Node23) (non-generic/instance)
-- Finalizer (Node24) (non-generic case only)
-- Current_Use_Clause (Node27)
-- Abstract_States (Elist25)
-- Package_Instantiation (Node26)
-- Current_Use_Clause (Node27)
-- Delay_Subprogram_Descriptors (Flag50)
-- Body_Needed_For_SAL (Flag40)
-- Discard_Names (Flag88)
@ -6040,6 +6083,7 @@ package Einfo is
-- section contains the functions used to obtain attribute values which
-- correspond to values in fields or flags in the entity itself.
function Abstract_States (Id : E) return L;
function Accept_Address (Id : E) return L;
function Access_Disp_Table (Id : E) return L;
function Actual_Subtype (Id : E) return E;
@ -6226,6 +6270,7 @@ package Einfo is
function In_Private_Part (Id : E) return B;
function In_Use (Id : E) return B;
function Initialization_Statements (Id : E) return N;
function Integrity_Level (Id : E) return U;
function Inner_Instances (Id : E) return L;
function Interface_Alias (Id : E) return E;
function Interface_Name (Id : E) return N;
@ -6380,6 +6425,7 @@ package Einfo is
function Referenced (Id : E) return B;
function Referenced_As_LHS (Id : E) return B;
function Referenced_As_Out_Parameter (Id : E) return B;
function Refined_State (Id : E) return E;
function Register_Exception_Call (Id : E) return N;
function Related_Array_Object (Id : E) return E;
function Related_Expression (Id : E) return N;
@ -6524,6 +6570,9 @@ package Einfo is
function Is_Discriminal (Id : E) return B;
function Is_Dynamic_Scope (Id : E) return B;
function Is_Finalizer (Id : E) return B;
function Is_Input_State (Id : E) return B;
function Is_Null_State (Id : E) return B;
function Is_Output_State (Id : E) return B;
function Is_Package_Or_Generic_Package (Id : E) return B;
function Is_Prival (Id : E) return B;
function Is_Protected_Component (Id : E) return B;
@ -6534,6 +6583,7 @@ package Einfo is
function Is_Synchronized_Interface (Id : E) return B;
function Is_Task_Interface (Id : E) return B;
function Is_Task_Record_Type (Id : E) return B;
function Is_Volatile_State (Id : E) return B;
function Is_Wrapper_Package (Id : E) return B;
function Last_Formal (Id : E) return E;
function Machine_Emax_Value (Id : E) return U;
@ -6634,6 +6684,7 @@ package Einfo is
-- Attribute Set Procedures --
------------------------------
procedure Set_Abstract_States (Id : E; V : L);
procedure Set_Accept_Address (Id : E; V : L);
procedure Set_Access_Disp_Table (Id : E; V : L);
procedure Set_Actual_Subtype (Id : E; V : E);
@ -6819,6 +6870,7 @@ package Einfo is
procedure Set_In_Private_Part (Id : E; V : B := True);
procedure Set_In_Use (Id : E; V : B := True);
procedure Set_Initialization_Statements (Id : E; V : N);
procedure Set_Integrity_Level (Id : E; V : U);
procedure Set_Inner_Instances (Id : E; V : L);
procedure Set_Interface_Alias (Id : E; V : E);
procedure Set_Interface_Name (Id : E; V : N);
@ -6979,6 +7031,7 @@ package Einfo is
procedure Set_Referenced (Id : E; V : B := True);
procedure Set_Referenced_As_LHS (Id : E; V : B := True);
procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True);
procedure Set_Refined_State (Id : E; V : E);
procedure Set_Register_Exception_Call (Id : E; V : N);
procedure Set_Related_Array_Object (Id : E; V : E);
procedure Set_Related_Expression (Id : E; V : N);
@ -7317,6 +7370,7 @@ package Einfo is
-- subprograms meeting the requirements documented in the section on
-- XEINFO may be referenced in this section.
pragma Inline (Abstract_States);
pragma Inline (Accept_Address);
pragma Inline (Access_Disp_Table);
pragma Inline (Actual_Subtype);
@ -7499,6 +7553,7 @@ package Einfo is
pragma Inline (In_Package_Body);
pragma Inline (In_Private_Part);
pragma Inline (In_Use);
pragma Inline (Integrity_Level);
pragma Inline (Inner_Instances);
pragma Inline (Interface_Alias);
pragma Inline (Interface_Name);
@ -7702,6 +7757,7 @@ package Einfo is
pragma Inline (Referenced);
pragma Inline (Referenced_As_LHS);
pragma Inline (Referenced_As_Out_Parameter);
pragma Inline (Refined_State);
pragma Inline (Register_Exception_Call);
pragma Inline (Related_Array_Object);
pragma Inline (Related_Expression);
@ -7766,6 +7822,7 @@ package Einfo is
pragma Inline (Init_Esize);
pragma Inline (Init_RM_Size);
pragma Inline (Set_Abstract_States);
pragma Inline (Set_Accept_Address);
pragma Inline (Set_Access_Disp_Table);
pragma Inline (Set_Actual_Subtype);
@ -7947,6 +8004,7 @@ package Einfo is
pragma Inline (Set_In_Private_Part);
pragma Inline (Set_In_Use);
pragma Inline (Set_Inner_Instances);
pragma Inline (Set_Integrity_Level);
pragma Inline (Set_Interface_Alias);
pragma Inline (Set_Interface_Name);
pragma Inline (Set_Interfaces);
@ -8106,6 +8164,7 @@ package Einfo is
pragma Inline (Set_Referenced);
pragma Inline (Set_Referenced_As_LHS);
pragma Inline (Set_Referenced_As_Out_Parameter);
pragma Inline (Set_Refined_State);
pragma Inline (Set_Register_Exception_Call);
pragma Inline (Set_Related_Array_Object);
pragma Inline (Set_Related_Expression);

95
gcc/ada/exp_aggr.adb

@ -102,6 +102,14 @@ package body Exp_Aggr is
-- statement of variant part will usually be small and probably in near
-- sorted order.
procedure Collect_Initialization_Statements
(Obj : Entity_Id;
N : Node_Id;
Node_After : Node_Id);
-- Collect actions inserted after N until, but not including, Node_After,
-- for initialization of Obj, and move them to an expression with actions,
-- which becomes the Initialization_Statements for Obj.
------------------------------------------------------
-- Local subprograms for Record Aggregate Expansion --
------------------------------------------------------
@ -2943,6 +2951,35 @@ package body Exp_Aggr is
return L;
end Build_Record_Aggr_Code;
---------------------------------------
-- Collect_Initialization_Statements --
---------------------------------------
procedure Collect_Initialization_Statements
(Obj : Entity_Id;
N : Node_Id;
Node_After : Node_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Init_Node : Node_Id;
EA : Node_Id;
Init_Actions : constant List_Id := New_List;
begin
Init_Node := N;
while Next (Init_Node) /= Node_After loop
Append_To (Init_Actions, Remove_Next (Init_Node));
end loop;
if not Is_Empty_List (Init_Actions) then
EA := Make_Expression_With_Actions (Loc,
Actions => Init_Actions,
Expression => Make_Null_Statement (Loc));
Insert_Action_After (Init_Node, EA);
Set_Initialization_Statements (Obj, EA);
end if;
end Collect_Initialization_Statements;
-------------------------------
-- Convert_Aggr_In_Allocator --
-------------------------------
@ -3120,34 +3157,9 @@ package body Exp_Aggr is
declare
Node_After : constant Node_Id := Next (N);
Init_Node : Node_Id;
Blk : Node_Id;
Init_Actions : constant List_Id := New_List;
begin
Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
-- Move inserted, analyzed actions to Init_Actions, but skip over
-- freeze nodes as these need to remain in the proper scope.
Init_Node := N;
while Next (Init_Node) /= Node_After loop
if Nkind (Next (Init_Node)) = N_Freeze_Entity then
Next (Init_Node);
else
Append_To (Init_Actions, Remove_Next (Init_Node));
end if;
end loop;
if not Is_Empty_List (Init_Actions) then
Blk := Make_Block_Statement (Loc,
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Init_Actions));
Insert_Action_After (Init_Node, Blk);
Set_Initialization_Statements (Obj, Blk);
end if;
Collect_Initialization_Statements (Obj, N, Node_After);
end;
Set_No_Initialization (N);
Initialize_Discriminants (N, Typ);
@ -4966,23 +4978,21 @@ package body Exp_Aggr is
Build_Activation_Chain_Entity (N);
end if;
-- Perform in-place expansion of aggregate in an object declaration.
-- Note: actions generated for the aggregate will be captured in a block
-- statement so that they can be transferred to freeze actions later
-- if there is an address clause for the object.
-- Should document these individual tests ???
if not Has_Default_Init_Comps (N)
and then Comes_From_Source (Parent (N))
and then Nkind (Parent (N)) = N_Object_Declaration
and then Comes_From_Source (Parent_Node)
and then Parent_Kind = N_Object_Declaration
and then not
Must_Slide (Etype (Defining_Identifier (Parent (N))), Typ)
and then N = Expression (Parent (N))
Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ)
and then N = Expression (Parent_Node)
and then not Is_Bit_Packed_Array (Typ)
and then not Has_Controlled_Component (Typ)
-- If the aggregate is the expression in an object declaration, it
-- cannot be expanded in place. Lookahead in the current declarative
-- part to find an address clause for the object being declared. If
-- one is present, we cannot build in place. Unclear comment???
and then not Has_Following_Address_Clause (Parent (N))
then
Tmp := Defining_Identifier (Parent (N));
Set_No_Initialization (Parent (N));
@ -5101,7 +5111,16 @@ package body Exp_Aggr is
end;
if Comes_From_Source (Tmp) then
Insert_Actions_After (Parent (N), Aggr_Code);
declare
Node_After : constant Node_Id := Next (Parent_Node);
begin
Insert_Actions_After (Parent_Node, Aggr_Code);
if Parent_Kind = N_Object_Declaration then
Collect_Initialization_Statements
(Obj => Tmp, N => Parent_Node, Node_After => Node_After);
end if;
end;
else
Insert_Actions (N, Aggr_Code);

28
gcc/ada/freeze.adb

@ -87,7 +87,8 @@ package body Freeze is
procedure Check_Address_Clause (E : Entity_Id);
-- Apply legality checks to address clauses for object declarations,
-- at the point the object is frozen.
-- at the point the object is frozen. Also ensure any initialization is
-- performed only after the object has been frozen.
procedure Check_Component_Storage_Order
(Encl_Type : Entity_Id;
@ -549,10 +550,11 @@ package body Freeze is
--------------------------
procedure Check_Address_Clause (E : Entity_Id) is
Addr : constant Node_Id := Address_Clause (E);
Addr : constant Node_Id := Address_Clause (E);
Expr : Node_Id;
Decl : constant Node_Id := Declaration_Node (E);
Typ : constant Entity_Id := Etype (E);
Decl : constant Node_Id := Declaration_Node (E);
Loc : constant Source_Ptr := Sloc (Decl);
Typ : constant Entity_Id := Etype (E);
begin
if Present (Addr) then
@ -601,6 +603,24 @@ package body Freeze is
then
Warn_Overlay (Expr, Typ, Name (Addr));
end if;
if Present (Expression (Decl)) then
-- Capture initialization value at point of declaration
Remove_Side_Effects (Expression (Decl));
-- Move initialization to freeze actions (once the object has
-- been frozen, and the address clause alignment check has been
-- performed.
Append_Freeze_Action (E,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (E, Loc),
Expression => Expression (Decl)));
Set_No_Initialization (Decl);
end if;
end if;
end Check_Address_Clause;

7
gcc/ada/lib-xref.ads

@ -531,7 +531,12 @@ package Lib.Xref is
E_Protected_Object => ' ',
E_Protected_Body => ' ',
E_Task_Body => ' ',
E_Subprogram_Body => ' ');
E_Subprogram_Body => ' ',
-- ??? The following letter is added for completion, proper design and
-- implementation of abstract state cross-referencing to follow.
E_Abstract_State => ' ');
-- The following table is for information purposes. It shows the use of
-- each character appearing as an entity type.

1
gcc/ada/par-prag.adb

@ -1092,6 +1092,7 @@ begin
-- entirely in Sem_Prag, and no further checking is done by Par.
when Pragma_Abort_Defer |
Pragma_Abstract_State |
Pragma_Assertion_Policy |
Pragma_Assume |
Pragma_Assume_No_Invalid_Values |

23
gcc/ada/sem_ch13.adb

@ -1434,13 +1434,23 @@ package body Sem_Ch13 is
-- Case 2d : Aspects that correspond to a pragma with one
-- argument.
when Aspect_Abstract_State =>
Aitem :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Abstract_State),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))));
Delay_Required := False;
when Aspect_Relative_Deadline =>
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations =>
New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Relative_Deadline));
@ -6961,9 +6971,10 @@ package body Sem_Ch13 is
Aspect_Type_Invariant =>
T := Standard_Boolean;
-- Here is the list of aspects that don't require delay analysis.
-- Here is the list of aspects that don't require delay analysis
when Aspect_Contract_Case |
when Aspect_Abstract_State |
Aspect_Contract_Case |
Aspect_Contract_Cases |
Aspect_Dimension |
Aspect_Dimension_System |

14
gcc/ada/sem_ch3.adb

@ -3171,7 +3171,14 @@ package body Sem_Ch3 is
Set_Has_Completion (Id);
end if;
-- Set type and resolve (type may be overridden later on)
-- Set kind (expansion of E may need it) and type now, and resolve.
-- Type might be overridden later on.
if Constant_Present (N) then
Set_Ekind (Id, E_Constant);
else
Set_Ekind (Id, E_Variable);
end if;
Set_Etype (Id, T);
Resolve (E, T);
@ -3513,11 +3520,12 @@ package body Sem_Ch3 is
Set_Never_Set_In_Source (Id, True);
-- Now establish the proper kind and type of the object
-- Now establish the proper kind (if not already set) and type of the
-- object.
if Constant_Present (N) then
Set_Ekind (Id, E_Constant);
Set_Is_True_Constant (Id, True);
Set_Ekind (Id, E_Constant);
else
Set_Ekind (Id, E_Variable);

8
gcc/ada/sem_ch4.adb

@ -1902,8 +1902,12 @@ package body Sem_Ch4 is
exit when No (A);
end loop;
Analyze_Expression (Expression (N));
Set_Etype (N, Etype (Expression (N)));
if Nkind (Expression (N)) = N_Null_Statement then
Set_Etype (N, Standard_Void_Type);
else
Analyze_Expression (Expression (N));
Set_Etype (N, Etype (Expression (N)));
end if;
end Analyze_Expression_With_Actions;
---------------------------

275
gcc/ada/sem_prag.adb

@ -6640,6 +6640,280 @@ package body Sem_Prag is
Pragma_Misplaced;
end if;
--------------------
-- Abstract_State --
--------------------
when Pragma_Abstract_State => Abstract_State : declare
Pack_Id : Entity_Id;
-- Flags used to verify the consistency of states
Non_Null_Seen : Boolean := False;
Null_Seen : Boolean := False;
procedure Analyze_Abstract_State (State : Node_Id);
-- Verify the legality of a single state declaration. Create and
-- decorate a state abstraction entity and introduce it into the
-- visibility chain.
----------------------------
-- Analyze_Abstract_State --
----------------------------
procedure Analyze_Abstract_State (State : Node_Id) is
procedure Check_Duplicate_Property
(Prop : Node_Id;
Status : in out Boolean);
-- Flag Status denotes whether a particular property has been
-- seen while processing a state. This routine verifies that
-- Prop is not a duplicate property and sets the flag Status.
------------------------------
-- Check_Duplicate_Property --
------------------------------
procedure Check_Duplicate_Property
(Prop : Node_Id;
Status : in out Boolean)
is
begin
if Status then
Error_Msg_N ("duplicate state property", Prop);
end if;
Status := True;
end Check_Duplicate_Property;
-- Local variables
Errors : constant Nat := Serious_Errors_Detected;
Loc : constant Source_Ptr := Sloc (State);
Assoc : Node_Id;
Id : Entity_Id;
Is_Null : Boolean := False;
Level : Uint := Uint_0;
Name : Name_Id;
Prop : Node_Id;
-- Flags used to verify the consistency of properties
Input_Seen : Boolean := False;
Integrity_Seen : Boolean := False;
Output_Seen : Boolean := False;
Volatile_Seen : Boolean := False;
-- Start of processing for Analyze_Abstract_State
begin
-- A package with a null abstract state is not allowed to
-- declare additional states.
if Null_Seen then
Error_Msg_Name_1 := Chars (Pack_Id);
Error_Msg_N ("package % has null abstract state", State);
-- Null states appear as internally generated entities
elsif Nkind (State) = N_Null then
Name := New_Internal_Name ('S');
Is_Null := True;
Null_Seen := True;
-- Catch a case where a null state appears in a list of
-- non-null states.
if Non_Null_Seen then
Error_Msg_Name_1 := Chars (Pack_Id);
Error_Msg_N
("package % has non-null abstract state", State);
end if;
-- Simple state declaration
elsif Nkind (State) = N_Identifier then
Name := Chars (State);
Non_Null_Seen := True;
-- State declaration with various properties. This construct
-- appears as an extension aggregate in the tree.
elsif Nkind (State) = N_Extension_Aggregate then
if Nkind (Ancestor_Part (State)) = N_Identifier then
Name := Chars (Ancestor_Part (State));
Non_Null_Seen := True;
else
Error_Msg_N
("state name must be an identifier",
Ancestor_Part (State));
end if;
-- Process properties Input, Output and Volatile. Ensure
-- that none of them appear more than once.
Prop := First (Expressions (State));
while Present (Prop) loop
if Nkind (Prop) = N_Identifier then
if Chars (Prop) = Name_Input then
Check_Duplicate_Property (Prop, Input_Seen);
elsif Chars (Prop) = Name_Output then
Check_Duplicate_Property (Prop, Output_Seen);
elsif Chars (Prop) = Name_Volatile then
Check_Duplicate_Property (Prop, Volatile_Seen);
else
Error_Msg_N ("invalid state property", Prop);
end if;
else
Error_Msg_N ("invalid state property", Prop);
end if;
Next (Prop);
end loop;
-- Volatile requires exactly one Input or Output
if Volatile_Seen
and then
((Input_Seen and then Output_Seen) -- both
or else
(not Input_Seen and then not Output_Seen)) -- none
then
Error_Msg_N
("property Volatile requires exactly one Input or " &
"Output", State);
end if;
-- Either Input or Output require Volatile
if (Input_Seen or else Output_Seen)
and then not Volatile_Seen
then
Error_Msg_N
("properties Input and Output require Volatile", State);
end if;
-- State property Integrity appears as a component
-- association.
Assoc := First (Component_Associations (State));
while Present (Assoc) loop
Prop := First (Choices (Assoc));
while Present (Prop) loop
if Nkind (Prop) = N_Identifier
and then Chars (Prop) = Name_Integrity
then
Check_Duplicate_Property (Prop, Integrity_Seen);
else
Error_Msg_N ("invalid state property", Prop);
end if;
Next (Prop);
end loop;
if Nkind (Expression (Assoc)) = N_Integer_Literal then
Level := Intval (Expression (Assoc));
else
Error_Msg_N
("integrity level must be an integer literal",
Expression (Assoc));
end if;
Next (Assoc);
end loop;
-- Any other attempt to declare a state is erroneous
else
Error_Msg_N ("malformed abstract state declaration", N);
end if;
-- Do not generate a state abstraction entity if it was not
-- properly declared.
if Serious_Errors_Detected > Errors then
return;
end if;
-- The generated state abstraction reuses the same characters
-- from the original state declaration. Decorate the entity.
Id := Make_Defining_Identifier (Loc, New_External_Name (Name));
Set_Comes_From_Source (Id, not Is_Null);
Set_Parent (Id, State);
Set_Ekind (Id, E_Abstract_State);
Set_Etype (Id, Standard_Void_Type);
Set_Integrity_Level (Id, Level);
Set_Refined_State (Id, Empty);
-- Every non-null state must be nameable and resolvable the
-- same way a constant is.
if not Is_Null then
Push_Scope (Pack_Id);
Enter_Name (Id);
Pop_Scope;
end if;
-- Associate the state with its related package
if No (Abstract_States (Pack_Id)) then
Set_Abstract_States (Pack_Id, New_Elmt_List);
end if;
Append_Elmt (Id, Abstract_States (Pack_Id));
end Analyze_Abstract_State;
-- Local variables
Par : Node_Id;
State : Node_Id;
-- Start of processing for Abstract_State
begin
GNAT_Pragma;
S14_Pragma;
Check_Arg_Count (1);
-- Ensure the proper placement of the pragma. Abstract states must
-- be associated with a package declaration.
if From_Aspect_Specification (N) then
Par := Parent (Corresponding_Aspect (N));
else
Par := Parent (Parent (N));
end if;
if Nkind (Par) = N_Compilation_Unit then
Par := Unit (Par);
end if;
if Nkind (Par) /= N_Package_Declaration then
Pragma_Misplaced;
return;
end if;
Pack_Id := Defining_Unit_Name (Specification (Par));
State := Expression (Arg1);
-- Multiple abstract states appear as an aggregate
if Nkind (State) = N_Aggregate then
State := First (Expressions (State));
while Present (State) loop
Analyze_Abstract_State (State);
Next (State);
end loop;
-- Various forms of a single abstract state. Note that these may
-- include malformed state declarations.
else
Analyze_Abstract_State (State);
end if;
end Abstract_State;
------------
-- Ada_83 --
------------
@ -15748,6 +16022,7 @@ package body Sem_Prag is
Sig_Flags : constant array (Pragma_Id) of Int :=
(Pragma_AST_Entry => -1,
Pragma_Abort_Defer => -1,
Pragma_Abstract_State => -1,
Pragma_Ada_83 => -1,
Pragma_Ada_95 => -1,
Pragma_Ada_05 => -1,

10
gcc/ada/sinfo.ads

@ -1546,7 +1546,8 @@ package Sinfo is
-- proc). This is needed for controlled aggregates. When the Object
-- declaration has an expression, this flag means that this expression
-- should not be taken into account (needed for in place initialization
-- with aggregates).
-- with aggregates, and for object with an address clause, which are
-- initialized with an assignment at freeze time).
-- No_Minimize_Eliminate (Flag17-Sem)
-- This flag is present in membership operator nodes (N_In/N_Not_In).
@ -7025,6 +7026,10 @@ package Sinfo is
-- declarations within the actions will definitely not be referenced
-- once elaboration of the construct is completed).
-- But we rely on freeze nodes appearing in actions being elaborated in
-- the enclosing scope (see Exp_Aggr.Collect_Initialization_
-- Statements)???
-- Sprint syntax: do
-- action;
-- action;
@ -7040,6 +7045,9 @@ package Sinfo is
-- Note: the actions list is always non-null, since we would
-- never have created this node if there weren't some actions.
-- Note: Expression may be a Null_Statement, in which case the
-- N_Expression_With_Actions has type Standard_Void_Type.
--------------------
-- Free Statement --
--------------------

3
gcc/ada/snames.ads-tmpl

@ -446,6 +446,7 @@ package Snames is
-- Remaining pragma names
Name_Abort_Defer : constant Name_Id := N + $; -- GNAT
Name_Abstract_State : constant Name_Id := N + $; -- GNAT
Name_All_Calls_Remote : constant Name_Id := N + $;
-- Note: AST_Entry is not in this list because its name matches the name of
@ -696,6 +697,7 @@ package Snames is
Name_Ignore : constant Name_Id := N + $;
Name_Increases : constant Name_Id := N + $;
Name_Info : constant Name_Id := N + $;
Name_Integrity : constant Name_Id := N + $;
Name_Internal : constant Name_Id := N + $;
Name_Link_Name : constant Name_Id := N + $;
Name_Lowercase : constant Name_Id := N + $;
@ -1731,6 +1733,7 @@ package Snames is
-- Remaining (non-configuration) pragmas
Pragma_Abort_Defer,
Pragma_Abstract_State,
Pragma_All_Calls_Remote,
Pragma_Assert,
Pragma_Assert_And_Cut,

13
gcc/ada/table.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -172,6 +172,7 @@ package body Table is
procedure Reallocate is
New_Size : Memory.size_t;
New_Length : Long_Integer;
begin
if Max < Last_Val then
@ -186,11 +187,15 @@ package body Table is
-- the increment value or 10, which ever is larger (the reason
-- for the use of 10 here is to ensure that the table does really
-- increase in size (which would not be the case for a table of
-- length 10 increased by 3% for instance).
-- length 10 increased by 3% for instance). Do the intermediate
-- calculation in Long_Integer to avoid overflow.
while Max < Last_Val loop
Length := Int'Max (Length * (100 + Table_Increment) / 100,
Length + 10);
New_Length :=
Long_Integer (Length) *
(100 + Long_Integer (Table_Increment))
/ 100;
Length := Int'Max (Int (New_Length), Length + 10);
Max := Min + Length - 1;
end loop;