diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6ef186d2a3ee..f7cf5b7d76d7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,67 @@ +2013-01-03 Hristian Kirtchev + + * 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 + + * table.adb (Reallocate): Calculate new Length in + Long_Integer to avoid overflow. + +2013-01-03 Thomas Quinot + + * 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 * gnat_rm.texi, freeze.adb (Check_Component_Storage_Order): Check that diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index dcc731447090..5156b9dd106f 100644 --- a/gcc/ada/aspects.adb +++ b/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, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 7d64feee66a8..c2e3d67bb009 100644 --- a/gcc/ada/aspects.ads +++ b/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, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 3eb514404f5b..a0d07c27fa0f 100644 --- a/gcc/ada/einfo.adb +++ b/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"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 55acb34dedee..2f8e96dd18a7 100644 --- a/gcc/ada/einfo.ads +++ b/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); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 7476a84a4e29..6a5eabebc267 100644 --- a/gcc/ada/exp_aggr.adb +++ b/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); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 03011fe54135..fdf8ac477911 100644 --- a/gcc/ada/freeze.adb +++ b/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; diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index faf715aabff0..00d72c12a050 100644 --- a/gcc/ada/lib-xref.ads +++ b/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. diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 579dd374a138..0427a5b7cd49 100644 --- a/gcc/ada/par-prag.adb +++ b/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 | diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 1af5e34e2db9..0a2ac51a6588 100644 --- a/gcc/ada/sem_ch13.adb +++ b/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 | diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 5764223cd060..49020fa73b9b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/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); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index bd14f37a3b9f..cb761f21965d 100644 --- a/gcc/ada/sem_ch4.adb +++ b/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; --------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0610128fd7b9..a6490bfacf4b 100644 --- a/gcc/ada/sem_prag.adb +++ b/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, diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index e44a7ef80cd6..d3e7d7188cbe 100644 --- a/gcc/ada/sinfo.ads +++ b/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 -- -------------------- diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 2cb296dd1be4..2968830f93f2 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/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, diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb index 3bf4eb69c879..0f73e639e819 100644 --- a/gcc/ada/table.adb +++ b/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;