diff options
| author | Robert Dewar <dewar@adacore.com> | 2008-04-08 08:45:25 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2008-04-08 08:45:25 +0200 |
| commit | 21d279972261484650109d662caf32b73a91bf1d (patch) | |
| tree | e4cc7613e520d7e95dfe0fcf3b07c6eab2b5d99c /gcc | |
| parent | 1ed69f611a49303c68258905e067c1c5888b9248 (diff) | |
| download | gcc-21d279972261484650109d662caf32b73a91bf1d.zip gcc-21d279972261484650109d662caf32b73a91bf1d.tar.gz gcc-21d279972261484650109d662caf32b73a91bf1d.tar.bz2 | |
alloc.ads: Add entries for Obsolescent_Warnings table
2008-04-08 Robert Dewar <dewar@adacore.com>
Bob Duff <duff@adacore.com>
Gary Dismukes <dismukes@adacore.com>
Ed Schonberg <schonberg@adacore.com>
* alloc.ads: Add entries for Obsolescent_Warnings table
* einfo.ads, einfo.adb: Minor reformatting.
(Is_Discriminal): New subprogram.
(Is_Prival): New subprogram.
(Is_Protected_Component): New subprogram.
(Is_Protected_Private): Removed.
(Object_Ref, Set_Object_Ref): Removed.
(Prival, Set_Prival): Change assertion.
(Privals_Chain, Set_Privals_Chain): Removed.
(Prival_Link, Set_Prival_Link): New subprogram.
(Protected_Operation, Set_Protected_Operation): Removed.
(Protection_Object, Set_Protection_Object): New subprogram.
(Write_Field17_Name): Remove case for Object_Ref.
(Write_Field20_Name): Add case for Prival_Link.
(Write_Field22_Name): Remove case for Protected_Operation,
Privals_Chain.
Add case for Protection_Object.
(Can_Use_Internal_Rep): Make this into a [base type only] attribute,
so clients
(Overlays_Constant): New flag
(Is_Constant_Object): New predicate
(Is_Standard_Character_Type): New predicate
(Optimize_Alignment_Space): New flag
(Optimize_Alignment_Time): New flag
(Has_Postconditions): New flag
(Obsolescent_Warrning): Field removed
(Spec_PPC_List): New field
(Relative_Deadline_Variable, Set_Relative_Deadline_Variable): Add
subprograms to get and set the relative deadline associated to a task.
* exp_attr.adb (May_Be_External_Call): Account for the case where the
Access attribute is part of a named parameter association.
(Expand_Access_To_Protected_Op): Test for the attribute occurring
within an init proc and use that directly as the scope rather than
traversing up to the protected operation's enclosing scope. Only apply
assertion on Is_Open_Scopes in the case the scope traversal is done.
For the init proc case use the address of the first formal (_init) as
the protected object reference.
Implement Invalid_Value attribute
(Expand_N_Attribute_Reference): Case Attribute_Unrestricted_Access.
contents of the dispatch table there is no need to duplicate the
itypes associated with record types (i.e. the implicit full view
of private types).
Implement Enum_Val attribute
(Expand_N_Attribute_Reference, case Old): Properly handle appearence
within _Postconditions procedure
(Expand_N_Attribute_Reference, case Result): Implement new attribute
* exp_ch5.adb (Expand_N_Simple_Return_Statement): Handle case in which
a return statement calls a function that is not available in
configurable runtime.
(Analyze_If_Statement): don't optimize simple True/False cases in -O0
(Expand_Non_Function_Return): Generate call to _Postconditions proc
(Expand_Simple_Function_Return): Ditto
* frontend.adb: Add call to Sem_Aux.Initialize
* sem_aux.ads, sem_aux.adb: New file.
* par-prag.adb: Add entries for pragmas Precondition/Postcondition
Add new Pragma_Relative_Deadline.
Add support for pragmas Check and Check_Policy
* sem_attr.ads, sem_attr.adb (Check_Not_CPP_Type): New subprogram.
(Check_Stream_Attribute): Add missing check (not allowed in CPP types)
(Analyze_Attribute): In case of attributes 'Alignment and 'size add
missing check because they are not allowed in CPP tagged types.
Add Sure parameter to Note_Possible_Modification calls
Add implementation of Invalid_Value attribute
Implement new attribute Has_Tagged_Values
Implement Enum_Val attribute
(Analyze_Attribute, case Range): Set Name_Req True for prefix of
generated attributes.
(Analyze_Attribute, case Result): If prefix of the attribute is
overloaded, it always resolves to the enclosing function.
(Analyze_Attribute, case Result): Properly deal with analysis when
Postconditions are not active.
(Resolve_Attribute, case Result): Properly deal with appearence during
preanalysis in spec.
Add processing for attribute Result
* sem_ch6.ads, sem_ch6.adb (Check_Overriding_Indicator): Code cleanup
for operators.
(Analyze_Subprogram_Body): Install private_with_clauses when the body
acts as a spec.
(Check_Inline_Pragma): recognize an inline pragma that appears within
the subprogram body to which it applies.
(Analyze_Function_Return): Check that type of the expression of a return
statement in a function with a class-wide result is not declared at a
deeper level than the function.
(Process_PPCs): Deal with enabling/disabling, using PPC_Enabled flag
(Verify_Overriding_Indicator): Handle properly subprogram bodies for
user- defined operators.
(Install_Formals): Moved to spec to allow use from Sem_Prag for
analysis of precondition/postcondition pragmas.
(Analyze_Subprogram_Body.Last_Real_Spec_Entity): New name for
Last_Formal, along with lots of comments on what this is about
(Analyze_Subprogram_Body): Fix case where we move entities from the
spec to the body when there are no body entities (now possible with
precondition and postcondition pragmas).
(Process_PPCs): New procedure
(Analyze_Subprogram_Body): Add call to Process_PPCs
* sem_ch8.adb (Use_One_Type): refine warning on a redundant use_type
clause.
(Pop_Scope): Restore Check_Policy_List on scope exit
(Push_Scope): Save Check_Policy_List on scope entry
Change name In_Default_Expression => In_Spec_Expression
Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression
Change name Pre_Analyze_And_Resolve => Preanalyze_And_Resolve
(Analyze_Object_Renaming): Allow 'Reference as object
(Analyze_Pragma, case Restriction_Warnings): Call GNAT_Pragma
(Process_Restrictions_Or_Restriction_Warnings): Check for bad spelling
of restriction identifier.
Add Sure parameter to Note_Possible_Modication calls
* sem_prag.ads, sem_prag.adb (Analyze_Pragma, case Stream_Convert):
Don't check for primitive operations when calling Rep_Item_Too_Late.
(Process_Import_Or_Interface): Do not place flag on formal
subprograms.
(Analyze_Pragma, case Export): If the entity is a deferred constant,
propagate information to full view, which is the one elaborated by the
back-end.
(Make_Inline): the pragma is effective if it applies to an internally
generated subprogram declaration for a body that carries the pragma.
(Analyze_Pragma, case Optimize_Alignment): Set new flag
Optimize_Alignment_Local.
(Analyze_PPC_In_Decl_Part): New procedure
(Get_Pragma_Arg): Moved to outer level
(Check_Precondition_Postcondition): Change to allow new visibility
rules for package spec
(Analyze_Pragma, case Check_Policy): Change placement rules to be
same as pragma Suppress/Unsuppress.
Change name In_Default_Expression => In_Spec_Expression
Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression
Change name Pre_Analyze_And_Resolve => Preanalyze_And_Resolve
(Check_Precondition_Postcondition): Do proper visibility preanalysis
for the case of these pragmas appearing in the spec.
(Check_Enabled): New function
(Initialize): New procedure
(Tree_Read): New procedure
(Tree_Write): New procedure
(Check_Precondition_Postcondition): New procedure
Implement pragmas Check and Check_Policy
Merge Assert processing with Check
* sem_warn.adb (Warn_On_Known_Condition): Handle pragma Check
New warning flag -gnatw.e
* sinfo.ads, sinfo.adb (Has_Relative_Deadline_Pragma): New function
returning whether a task (or main procedure) has a pragma
Relative_Deadline.
(Set_Has_Relative_Deadline_Pragma): Procedure to indicate that a task
(or main procedure) has a pragma Relative_Deadline.
Add Next_Pragma field to N_Pragma node
(PPC_Enabled): New flag
(Next_Pragma): Now used for Pre/Postcondition processing
* snames.h, snames.ads, snames.adb: New standard name
Inherit_Source_Path
Add entry for 'Invalid_Value attribute
Add entry for new attribute Has_Tagged_Values
Add entry for Enum_Val attribute
Add new standard names Aggregate, Configuration and Library.
Add _Postconditions
Add _Result
Add Pragma_Precondition
Add Pragma_Postcondition
Add Attribute_Result
New standard name Archive_Builder_Append_Option
(Preset_Names): Add _relative_deadline and relative_deadline definitions
There was also a missing non_preemptive_within_priorities.
(Get_Pragma_Id, Is_Pragma_Name): Add support for pragma
Relative_Deadline.
Add support for pragmas Check and Check_Policy
* tree_gen.adb: Call Sem_Aux.Tree_Write
* tree_in.adb: Call Sem_Aux.Tree_Read
* exp_ch11.adb (Expand_N_Raise_Statement): New Build_Location calling
sequence
* exp_intr.adb (Expand_Source_Info): New Build_Location calling
sequence
* exp_prag.adb (Expand_Pragma_Relative_Deadline): New procedure.
(Expand_N_Pragma): Call the appropriate procedure for expanding pragma
Relative_Deadline.
(Expand_Pragma_Check): New procedure
* sinput.ads, sinput.adb (Build_Location_String): Now appends to name
buffer.
* sinfo.adb (PPC_Enabled): New flag
From-SVN: r134010
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/alloc.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 480 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 429 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 717 | ||||
| -rw-r--r-- | gcc/ada/exp_ch11.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 265 | ||||
| -rw-r--r-- | gcc/ada/exp_intr.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/exp_prag.adb | 141 | ||||
| -rw-r--r-- | gcc/ada/frontend.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/par-prag.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 349 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.ads | 27 | ||||
| -rwxr-xr-x | gcc/ada/sem_aux.adb | 62 | ||||
| -rwxr-xr-x | gcc/ada/sem_aux.ads | 86 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 544 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.ads | 25 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 142 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 862 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.ads | 29 | ||||
| -rw-r--r-- | gcc/ada/sem_warn.adb | 83 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 50 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 173 | ||||
| -rw-r--r-- | gcc/ada/sinput.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/sinput.ads | 16 | ||||
| -rw-r--r-- | gcc/ada/snames.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/snames.ads | 1530 | ||||
| -rw-r--r-- | gcc/ada/snames.h | 551 | ||||
| -rw-r--r-- | gcc/ada/tree_gen.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/tree_in.adb | 4 |
29 files changed, 4326 insertions, 2318 deletions
diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads index 3707ecf..7bfe9aa 100644 --- a/gcc/ada/alloc.ads +++ b/gcc/ada/alloc.ads @@ -99,6 +99,9 @@ package Alloc is Nodes_Initial : constant := 50_000; -- Atree Nodes_Increment : constant := 100; + Obsolescent_Warnings_Initial : constant := 50; -- Sem_Prag + Obsolescent_Warnings_Increment : constant := 200; + Orig_Nodes_Initial : constant := 50_000; -- Atree Orig_Nodes_Increment : constant := 100; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index c04680c..7374a7e 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -70,7 +70,6 @@ package body Einfo is -- Homonym Node4 -- First_Rep_Item Node6 -- Freeze_Node Node7 - -- Obsolescent_Warning Node24 -- The usage of other fields (and the entity kinds to which it applies) -- depends on the particular field (see Einfo spec for details). @@ -147,7 +146,6 @@ package body Einfo is -- Master_Id Node17 -- Modulus Uint17 -- Non_Limited_View Node17 - -- Object_Ref Node17 -- Prival Node17 -- Alias Node18 @@ -175,6 +173,7 @@ package body Einfo is -- Discriminant_Checking_Func Node20 -- Discriminant_Default_Value Node20 -- Last_Entity Node20 + -- Prival_Link Node20 -- Register_Exception_Call Node20 -- Scalar_Range Node20 @@ -198,22 +197,20 @@ package body Einfo is -- Associated_Final_Chain Node23 -- CR_Discriminant Node23 - -- Stored_Constraint Elist23 -- Entry_Cancel_Parameter Node23 + -- Enum_Pos_To_Rep Node23 -- Extra_Constrained Node23 -- Generic_Renamings Elist23 -- Inner_Instances Elist23 - -- Enum_Pos_To_Rep Node23 - -- Packed_Array_Type Node23 -- Limited_View Node23 - -- Privals_Chain Elist23 - -- Protected_Operation Node23 + -- Packed_Array_Type Node23 + -- Protection_Object Node23 + -- Stored_Constraint Elist23 - -- Obsolescent_Warning Node24 + -- Spec_PPC_List Node24 -- Abstract_Interface_Alias Node25 -- Abstract_Interfaces Elist25 - -- Current_Use_Clause Node25 -- Debug_Renaming_Link Node25 -- DT_Offset_To_Top_Func Node25 -- Task_Body_Procedure Node25 @@ -223,8 +220,10 @@ package body Einfo is -- Overridden_Operation Node26 -- Package_Instantiation Node26 -- Related_Type Node26 + -- Relative_Deadline_Variable Node26 -- Static_Initialization Node26 + -- Current_Use_Clause Node27 -- Wrapped_Entity Node27 -- Extra_Formals Node28 @@ -495,17 +494,18 @@ package body Einfo is -- Renamed_In_Spec Flag231 -- Implemented_By_Entry Flag232 -- Has_Pragma_Unmodified Flag233 - -- Is_Static_Dispatch_Table_Entity Flag234 + -- Is_Dispatch_Table_Entity Flag234 -- Is_Trivial_Subprogram Flag235 -- Warnings_Off_Used Flag236 -- Warnings_Off_Used_Unmodified Flag237 -- Warnings_Off_Used_Unreferenced Flag238 -- OK_To_Reorder_Components Flag239 + -- Has_Postconditions Flag240 + + -- Optimize_Alignment_Space Flag241 + -- Optimize_Alignment_Time Flag242 + -- Overlays_Constant Flag243 - -- (unused) Flag240 - -- (unused) Flag241 - -- (unused) Flag242 - -- (unused) Flag243 -- (unused) Flag244 -- (unused) Flag245 -- (unused) Flag246 @@ -741,8 +741,8 @@ package body Einfo is function Current_Use_Clause (Id : E) return E is begin - pragma Assert (Ekind (Id) = E_Package); - return Node25 (Id); + pragma Assert (Ekind (Id) = E_Package or else Is_Type (Id)); + return Node27 (Id); end Current_Use_Clause; function Current_Value (Id : E) return N is @@ -1043,8 +1043,8 @@ package body Einfo is function Can_Use_Internal_Rep (Id : E) return B is begin - pragma Assert (Is_Access_Subprogram_Type (Id)); - return Flag229 (Id); + pragma Assert (Is_Access_Subprogram_Type (Base_Type (Id))); + return Flag229 (Base_Type (Id)); end Can_Use_Internal_Rep; function Finalization_Chain_Entity (Id : E) return E is @@ -1319,6 +1319,12 @@ package body Einfo is return Flag188 (Id); end Has_Persistent_BSS; + function Has_Postconditions (Id : E) return B is + begin + pragma Assert (Is_Subprogram (Id)); + return Flag240 (Id); + end Has_Postconditions; + function Has_Pragma_Controlled (Id : E) return B is begin pragma Assert (Is_Access_Type (Id)); @@ -1687,16 +1693,21 @@ package body Einfo is return Flag74 (Id); end Is_CPP_Class; + function Is_Descendent_Of_Address (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag223 (Id); + end Is_Descendent_Of_Address; + function Is_Discrim_SO_Function (Id : E) return B is begin return Flag176 (Id); end Is_Discrim_SO_Function; - function Is_Descendent_Of_Address (Id : E) return B is + function Is_Dispatch_Table_Entity (Id : E) return B is begin - pragma Assert (Is_Type (Id)); - return Flag223 (Id); - end Is_Descendent_Of_Address; + return Flag234 (Id); + end Is_Dispatch_Table_Entity; function Is_Dispatching_Operation (Id : E) return B is begin @@ -2000,11 +2011,6 @@ package body Einfo is return Flag28 (Id); end Is_Statically_Allocated; - function Is_Static_Dispatch_Table_Entity (Id : E) return B is - begin - return Flag234 (Id); - end Is_Static_Dispatch_Table_Entity; - function Is_Synchronized_Interface (Id : E) return B is begin pragma Assert (Is_Interface (Id)); @@ -2270,23 +2276,30 @@ package body Einfo is return Uint10 (Id); end Normalized_Position_Max; - function Object_Ref (Id : E) return E is - begin - pragma Assert (Ekind (Id) = E_Protected_Body); - return Node17 (Id); - end Object_Ref; - - function Obsolescent_Warning (Id : E) return N is - begin - return Node24 (Id); - end Obsolescent_Warning; - function OK_To_Reorder_Components (Id : E) return B is begin pragma Assert (Is_Record_Type (Id)); return Flag239 (Base_Type (Id)); end OK_To_Reorder_Components; + function Optimize_Alignment_Space (Id : E) return B is + begin + pragma Assert + (Is_Type (Id) + or else Ekind (Id) = E_Constant + or else Ekind (Id) = E_Variable); + return Flag241 (Id); + end Optimize_Alignment_Space; + + function Optimize_Alignment_Time (Id : E) return B is + begin + pragma Assert + (Is_Type (Id) + or else Ekind (Id) = E_Constant + or else Ekind (Id) = E_Variable); + return Flag242 (Id); + end Optimize_Alignment_Time; + function Original_Array_Type (Id : E) return E is begin pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id)); @@ -2302,6 +2315,11 @@ package body Einfo is return Node22 (Id); end Original_Record_Component; + function Overlays_Constant (Id : E) return B is + begin + return Flag243 (Id); + end Overlays_Constant; + function Overridden_Operation (Id : E) return E is begin return Node26 (Id); @@ -2336,16 +2354,16 @@ package body Einfo is function Prival (Id : E) return E is begin - pragma Assert (Is_Protected_Private (Id)); + pragma Assert (Is_Protected_Component (Id)); return Node17 (Id); end Prival; - function Privals_Chain (Id : E) return L is + function Prival_Link (Id : E) return E is begin - pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Entry_Family); - return Elist23 (Id); - end Privals_Chain; + pragma Assert (Ekind (Id) = E_Constant + or else Ekind (Id) = E_Variable); + return Node20 (Id); + end Prival_Link; function Private_Dependents (Id : E) return L is begin @@ -2371,11 +2389,14 @@ package body Einfo is return Node22 (Id); end Protected_Formal; - function Protected_Operation (Id : E) return N is + function Protection_Object (Id : E) return E is begin - pragma Assert (Is_Protected_Private (Id)); + pragma Assert (Ekind (Id) = E_Entry + or else Ekind (Id) = E_Entry_Family + or else Ekind (Id) = E_Function + or else Ekind (Id) = E_Procedure); return Node23 (Id); - end Protected_Operation; + end Protection_Object; function Reachable (Id : E) return B is begin @@ -2429,6 +2450,12 @@ package body Einfo is return Node26 (Id); end Related_Type; + function Relative_Deadline_Variable (Id : E) return E is + begin + pragma Assert (Is_Task_Type (Id)); + return Node26 (Implementation_Base_Type (Id)); + end Relative_Deadline_Variable; + function Renamed_Entity (Id : E) return N is begin return Node18 (Id); @@ -2551,6 +2578,12 @@ package body Einfo is return Node19 (Id); end Spec_Entity; + function Spec_PPC_List (Id : E) return N is + begin + pragma Assert (Is_Subprogram (Id)); + return Node24 (Id); + end Spec_PPC_List; + function Storage_Size_Variable (Id : E) return E is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); @@ -3109,8 +3142,8 @@ package body Einfo is procedure Set_Current_Use_Clause (Id : E; V : E) is begin - pragma Assert (Ekind (Id) = E_Package); - Set_Node25 (Id, V); + pragma Assert (Ekind (Id) = E_Package or else Is_Type (Id)); + Set_Node27 (Id, V); end Set_Current_Use_Clause; procedure Set_Current_Value (Id : E; V : N) is @@ -3415,7 +3448,9 @@ package body Einfo is procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True) is begin - pragma Assert (Is_Access_Subprogram_Type (Id)); + pragma Assert + (Is_Access_Subprogram_Type (Id) + and then Id = Base_Type (Id)); Set_Flag229 (Id, V); end Set_Can_Use_Internal_Rep; @@ -3510,7 +3545,7 @@ package body Einfo is procedure Set_Has_Aliased_Components (Id : E; V : B := True) is begin - pragma Assert (Base_Type (Id) = Id); + pragma Assert (Id = Base_Type (Id)); Set_Flag135 (Id, V); end Set_Has_Aliased_Components; @@ -3531,14 +3566,14 @@ package body Einfo is procedure Set_Has_Atomic_Components (Id : E; V : B := True) is begin - pragma Assert (not Is_Type (Id) or else Base_Type (Id) = Id); + pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id)); Set_Flag86 (Id, V); end Set_Has_Atomic_Components; procedure Set_Has_Biased_Representation (Id : E; V : B := True) is begin pragma Assert - ((V = False) or else (Is_Discrete_Type (Id) or Is_Object (Id))); + ((V = False) or else (Is_Discrete_Type (Id) or else Is_Object (Id))); Set_Flag139 (Id, V); end Set_Has_Biased_Representation; @@ -3578,7 +3613,7 @@ package body Einfo is procedure Set_Has_Controlled_Component (Id : E; V : B := True) is begin - pragma Assert (Base_Type (Id) = Id); + pragma Assert (Id = Base_Type (Id)); Set_Flag43 (Id, V); end Set_Has_Controlled_Component; @@ -3689,7 +3724,7 @@ package body Einfo is procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is begin - pragma Assert (Base_Type (Id) = Id); + pragma Assert (Id = Base_Type (Id)); Set_Flag75 (Id, V); end Set_Has_Non_Standard_Rep; @@ -3709,6 +3744,12 @@ package body Einfo is Set_Flag188 (Id, V); end Set_Has_Persistent_BSS; + procedure Set_Has_Postconditions (Id : E; V : B := True) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Flag240 (Id, V); + end Set_Has_Postconditions; + procedure Set_Has_Pragma_Controlled (Id : E; V : B := True) is begin pragma Assert (Is_Access_Type (Id)); @@ -3850,7 +3891,7 @@ package body Einfo is procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True) is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); - pragma Assert (Base_Type (Id) = Id); + pragma Assert (Id = Base_Type (Id)); Set_Flag23 (Id, V); end Set_Has_Storage_Size_Clause; @@ -3867,7 +3908,7 @@ package body Einfo is procedure Set_Has_Task (Id : E; V : B := True) is begin - pragma Assert (Base_Type (Id) = Id); + pragma Assert (Id = Base_Type (Id)); Set_Flag30 (Id, V); end Set_Has_Task; @@ -3880,7 +3921,7 @@ package body Einfo is procedure Set_Has_Unchecked_Union (Id : E; V : B := True) is begin - pragma Assert (Base_Type (Id) = Id); + pragma Assert (Id = Base_Type (Id)); Set_Flag123 (Id, V); end Set_Has_Unchecked_Union; @@ -3892,7 +3933,7 @@ package body Einfo is procedure Set_Has_Volatile_Components (Id : E; V : B := True) is begin - pragma Assert (not Is_Type (Id) or else Base_Type (Id) = Id); + pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id)); Set_Flag87 (Id, V); end Set_Has_Volatile_Components; @@ -4095,6 +4136,11 @@ package body Einfo is Set_Flag176 (Id, V); end Set_Is_Discrim_SO_Function; + procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True) is + begin + Set_Flag234 (Id, V); + end Set_Is_Dispatch_Table_Entity; + procedure Set_Is_Dispatching_Operation (Id : E; V : B := True) is begin pragma Assert @@ -4309,7 +4355,7 @@ package body Einfo is procedure Set_Is_Packed (Id : E; V : B := True) is begin - pragma Assert (Base_Type (Id) = Id); + pragma Assert (Id = Base_Type (Id)); Set_Flag51 (Id, V); end Set_Is_Packed; @@ -4420,11 +4466,6 @@ package body Einfo is Set_Flag28 (Id, V); end Set_Is_Statically_Allocated; - procedure Set_Is_Static_Dispatch_Table_Entity (Id : E; V : B := True) is - begin - Set_Flag234 (Id, V); - end Set_Is_Static_Dispatch_Table_Entity; - procedure Set_Is_Synchronized_Interface (Id : E; V : B := True) is begin pragma Assert (Is_Interface (Id)); @@ -4467,7 +4508,7 @@ package body Einfo is procedure Set_Is_Unchecked_Union (Id : E; V : B := True) is begin - pragma Assert (Base_Type (Id) = Id); + pragma Assert (Id = Base_Type (Id)); Set_Flag117 (Id, V); end Set_Is_Unchecked_Union; @@ -4635,7 +4676,7 @@ package body Einfo is procedure Set_No_Pool_Assigned (Id : E; V : B := True) is begin - pragma Assert (Is_Access_Type (Id) and then Base_Type (Id) = Id); + pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id)); Set_Flag131 (Id, V); end Set_No_Pool_Assigned; @@ -4650,7 +4691,7 @@ package body Einfo is procedure Set_No_Strict_Aliasing (Id : E; V : B := True) is begin - pragma Assert (Is_Access_Type (Id) and then Base_Type (Id) = Id); + pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id)); Set_Flag136 (Id, V); end Set_No_Strict_Aliasing; @@ -4695,17 +4736,6 @@ package body Einfo is Set_Uint10 (Id, V); end Set_Normalized_Position_Max; - procedure Set_Object_Ref (Id : E; V : E) is - begin - pragma Assert (Ekind (Id) = E_Protected_Body); - Set_Node17 (Id, V); - end Set_Object_Ref; - - procedure Set_Obsolescent_Warning (Id : E; V : N) is - begin - Set_Node24 (Id, V); - end Set_Obsolescent_Warning; - procedure Set_OK_To_Reorder_Components (Id : E; V : B := True) is begin pragma Assert @@ -4713,6 +4743,24 @@ package body Einfo is Set_Flag239 (Id, V); end Set_OK_To_Reorder_Components; + procedure Set_Optimize_Alignment_Space (Id : E; V : B := True) is + begin + pragma Assert + (Is_Type (Id) + or else Ekind (Id) = E_Constant + or else Ekind (Id) = E_Variable); + Set_Flag241 (Id, V); + end Set_Optimize_Alignment_Space; + + procedure Set_Optimize_Alignment_Time (Id : E; V : B := True) is + begin + pragma Assert + (Is_Type (Id) + or else Ekind (Id) = E_Constant + or else Ekind (Id) = E_Variable); + Set_Flag242 (Id, V); + end Set_Optimize_Alignment_Time; + procedure Set_Original_Array_Type (Id : E; V : E) is begin pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id)); @@ -4728,6 +4776,11 @@ package body Einfo is Set_Node22 (Id, V); end Set_Original_Record_Component; + procedure Set_Overlays_Constant (Id : E; V : B := True) is + begin + Set_Flag243 (Id, V); + end Set_Overlays_Constant; + procedure Set_Overridden_Operation (Id : E; V : E) is begin Set_Node26 (Id, V); @@ -4762,16 +4815,16 @@ package body Einfo is procedure Set_Prival (Id : E; V : E) is begin - pragma Assert (Is_Protected_Private (Id)); + pragma Assert (Is_Protected_Component (Id)); Set_Node17 (Id, V); end Set_Prival; - procedure Set_Privals_Chain (Id : E; V : L) is + procedure Set_Prival_Link (Id : E; V : E) is begin - pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Entry_Family); - Set_Elist23 (Id, V); - end Set_Privals_Chain; + pragma Assert (Ekind (Id) = E_Constant + or else Ekind (Id) = E_Variable); + Set_Node20 (Id, V); + end Set_Prival_Link; procedure Set_Private_Dependents (Id : E; V : L) is begin @@ -4797,11 +4850,14 @@ package body Einfo is Set_Node22 (Id, V); end Set_Protected_Formal; - procedure Set_Protected_Operation (Id : E; V : N) is + procedure Set_Protection_Object (Id : E; V : E) is begin - pragma Assert (Is_Protected_Private (Id)); + pragma Assert (Ekind (Id) = E_Entry + or else Ekind (Id) = E_Entry_Family + or else Ekind (Id) = E_Function + or else Ekind (Id) = E_Procedure); Set_Node23 (Id, V); - end Set_Protected_Operation; + end Set_Protection_Object; procedure Set_Reachable (Id : E; V : B := True) is begin @@ -4855,6 +4911,12 @@ package body Einfo is Set_Node26 (Id, V); end Set_Related_Type; + procedure Set_Relative_Deadline_Variable (Id : E; V : E) is + begin + pragma Assert (Is_Task_Type (Id) and then Id = Base_Type (Id)); + Set_Node26 (Id, V); + end Set_Relative_Deadline_Variable; + procedure Set_Renamed_Entity (Id : E; V : N) is begin Set_Node18 (Id, V); @@ -4978,10 +5040,16 @@ package body Einfo is Set_Node19 (Id, V); end Set_Spec_Entity; + procedure Set_Spec_PPC_List (Id : E; V : N) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Node24 (Id, V); + end Set_Spec_PPC_List; + procedure Set_Storage_Size_Variable (Id : E; V : E) is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); - pragma Assert (Base_Type (Id) = Id); + pragma Assert (Id = Base_Type (Id)); Set_Node15 (Id, V); end Set_Storage_Size_Variable; @@ -5006,7 +5074,7 @@ package body Einfo is procedure Set_Strict_Alignment (Id : E; V : B := True) is begin - pragma Assert (Base_Type (Id) = Id); + pragma Assert (Id = Base_Type (Id)); Set_Flag145 (Id, V); end Set_Strict_Alignment; @@ -5062,7 +5130,7 @@ package body Einfo is procedure Set_Universal_Aliasing (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id) and then Base_Type (Id) = Id); + pragma Assert (Is_Type (Id) and then Id = Base_Type (Id)); Set_Flag216 (Id, V); end Set_Universal_Aliasing; @@ -5445,14 +5513,14 @@ package body Einfo is procedure Append_Entity (Id : Entity_Id; V : Entity_Id) is begin if Last_Entity (V) = Empty then - Set_First_Entity (V, Id); + Set_First_Entity (Id => V, V => Id); else Set_Next_Entity (Last_Entity (V), Id); end if; Set_Next_Entity (Id, Empty); Set_Scope (Id, V); - Set_Last_Entity (V, Id); + Set_Last_Entity (Id => V, V => Id); end Append_Entity; -------------------- @@ -5703,8 +5771,6 @@ package body Einfo is S := Scope (S); end if; end loop; - - return S; end Enclosing_Dynamic_Scope; ---------------------- @@ -6347,6 +6413,17 @@ package body Einfo is end if; end Is_By_Reference_Type; + ------------------------ + -- Is_Constant_Object -- + ------------------------ + + function Is_Constant_Object (Id : E) return B is + K : constant Entity_Kind := Ekind (Id); + begin + return + K = E_Constant or else K = E_In_Parameter or else K = E_Loop_Parameter; + end Is_Constant_Object; + --------------------- -- Is_Derived_Type -- --------------------- @@ -6367,8 +6444,8 @@ package body Einfo is return Present (Par) and then Nkind (Par) = N_Full_Type_Declaration - and then Nkind (Type_Definition (Par)) - = N_Derived_Type_Definition; + and then Nkind (Type_Definition (Par)) = + N_Derived_Type_Definition; end if; else @@ -6376,6 +6453,18 @@ package body Einfo is end if; end Is_Derived_Type; + -------------------- + -- Is_Discriminal -- + -------------------- + + function Is_Discriminal (Id : E) return B is + begin + return + (Ekind (Id) = E_Constant + or else Ekind (Id) = E_In_Parameter) + and then Present (Discriminal_Link (Id)); + end Is_Discriminal; + ---------------------- -- Is_Dynamic_Scope -- ---------------------- @@ -6454,6 +6543,64 @@ package body Einfo is end if; end Is_Indefinite_Subtype; + -------------------------------- + -- Is_Inherently_Limited_Type -- + -------------------------------- + + function Is_Inherently_Limited_Type (Id : E) return B is + Btype : constant Entity_Id := Base_Type (Id); + + begin + if Is_Private_Type (Btype) then + declare + Utyp : constant Entity_Id := Underlying_Type (Btype); + begin + if No (Utyp) then + return False; + else + return Is_Inherently_Limited_Type (Utyp); + end if; + end; + + elsif Is_Concurrent_Type (Btype) then + return True; + + elsif Is_Record_Type (Btype) then + if Is_Limited_Record (Btype) then + return not Is_Interface (Btype) + or else Is_Protected_Interface (Btype) + or else Is_Synchronized_Interface (Btype) + or else Is_Task_Interface (Btype); + + elsif Is_Class_Wide_Type (Btype) then + return Is_Inherently_Limited_Type (Root_Type (Btype)); + + else + declare + C : Entity_Id; + + begin + C := First_Component (Btype); + while Present (C) loop + if Is_Inherently_Limited_Type (Etype (C)) then + return True; + end if; + + C := Next_Component (C); + end loop; + end; + + return False; + end if; + + elsif Is_Array_Type (Btype) then + return Is_Inherently_Limited_Type (Component_Type (Btype)); + + else + return False; + end if; + end Is_Inherently_Limited_Type; + --------------------- -- Is_Limited_Type -- --------------------- @@ -6546,15 +6693,27 @@ package body Einfo is Ekind (Id) = E_Generic_Package; end Is_Package_Or_Generic_Package; - -------------------------- - -- Is_Protected_Private -- - -------------------------- + --------------- + -- Is_Prival -- + --------------- - function Is_Protected_Private (Id : E) return B is + function Is_Prival (Id : E) return B is begin - pragma Assert (Ekind (Id) = E_Component); - return Is_Protected_Type (Scope (Id)); - end Is_Protected_Private; + return + (Ekind (Id) = E_Constant + or else Ekind (Id) = E_Variable) + and then Present (Prival_Link (Id)); + end Is_Prival; + + ---------------------------- + -- Is_Protected_Component -- + ---------------------------- + + function Is_Protected_Component (Id : E) return B is + begin + return Ekind (Id) = E_Component + and then Is_Protected_Type (Scope (Id)); + end Is_Protected_Component; ------------------------------ -- Is_Protected_Record_Type -- @@ -6568,62 +6727,27 @@ package body Einfo is end Is_Protected_Record_Type; -------------------------------- - -- Is_Inherently_Limited_Type -- + -- Is_Standard_Character_Type -- -------------------------------- - function Is_Inherently_Limited_Type (Id : E) return B is - Btype : constant Entity_Id := Base_Type (Id); - + function Is_Standard_Character_Type (Id : E) return B is begin - if Is_Private_Type (Btype) then + if Is_Type (Id) then declare - Utyp : constant Entity_Id := Underlying_Type (Btype); + R : constant Entity_Id := Root_Type (Id); begin - if No (Utyp) then - return False; - else - return Is_Inherently_Limited_Type (Utyp); - end if; + return + R = Standard_Character + or else + R = Standard_Wide_Character + or else + R = Standard_Wide_Wide_Character; end; - elsif Is_Concurrent_Type (Btype) then - return True; - - elsif Is_Record_Type (Btype) then - if Is_Limited_Record (Btype) then - return not Is_Interface (Btype) - or else Is_Protected_Interface (Btype) - or else Is_Synchronized_Interface (Btype) - or else Is_Task_Interface (Btype); - - elsif Is_Class_Wide_Type (Btype) then - return Is_Inherently_Limited_Type (Root_Type (Btype)); - - else - declare - C : Entity_Id; - - begin - C := First_Component (Btype); - while Present (C) loop - if Is_Inherently_Limited_Type (Etype (C)) then - return True; - end if; - - C := Next_Component (C); - end loop; - end; - - return False; - end if; - - elsif Is_Array_Type (Btype) then - return Is_Inherently_Limited_Type (Component_Type (Btype)); - else return False; end if; - end Is_Inherently_Limited_Type; + end Is_Standard_Character_Type; -------------------- -- Is_String_Type -- @@ -6957,17 +7081,15 @@ package body Einfo is T := Etyp; - -- Return if there is a circularity in the inheritance chain. - -- This happens in some error situations and we do not want - -- to get stuck in this loop. + -- Return if there is a circularity in the inheritance chain. This + -- happens in some error situations and we do not want to get + -- stuck in this loop. if T = Base_Type (Id) then return T; end if; end loop; end if; - - raise Program_Error; end Root_Type; ----------------- @@ -7313,7 +7435,7 @@ package body Einfo is begin if (Is_Array_Type (Id) or else Is_Record_Type (Id)) - and then Base_Type (Id) = Id + and then Id = Base_Type (Id) then Write_Str (Prefix); Write_Str ("Component_Alignment = "); @@ -7385,6 +7507,7 @@ package body Einfo is W ("Has_Object_Size_Clause", Flag172 (Id)); W ("Has_Per_Object_Constraint", Flag154 (Id)); W ("Has_Persistent_BSS", Flag188 (Id)); + W ("Has_Postconditions", Flag240 (Id)); W ("Has_Pragma_Controlled", Flag27 (Id)); W ("Has_Pragma_Elaborate_Body", Flag150 (Id)); W ("Has_Pragma_Inline", Flag157 (Id)); @@ -7450,6 +7573,7 @@ package body Einfo is W ("Is_Controlling_Formal", Flag97 (Id)); W ("Is_Descendent_Of_Address", Flag223 (Id)); W ("Is_Discrim_SO_Function", Flag176 (Id)); + W ("Is_Dispatch_Table_Entity", Flag234 (Id)); W ("Is_Dispatching_Operation", Flag6 (Id)); W ("Is_Eliminated", Flag124 (Id)); W ("Is_Entry_Formal", Flag52 (Id)); @@ -7504,7 +7628,6 @@ package body Einfo is W ("Is_Return_Object", Flag209 (Id)); W ("Is_Shared_Passive", Flag60 (Id)); W ("Is_Synchronized_Interface", Flag199 (Id)); - W ("Is_Static_Dispatch_Table_Entity", Flag234 (Id)); W ("Is_Statically_Allocated", Flag28 (Id)); W ("Is_Tag", Flag78 (Id)); W ("Is_Tagged_Type", Flag55 (Id)); @@ -7538,6 +7661,9 @@ package body Einfo is W ("Non_Binary_Modulus", Flag58 (Id)); W ("Nonzero_Is_True", Flag162 (Id)); W ("OK_To_Reorder_Components", Flag239 (Id)); + W ("Optimize_Alignment_Space", Flag241 (Id)); + W ("Optimize_Alignment_Time", Flag242 (Id)); + W ("Overlays_Constant", Flag243 (Id)); W ("Reachable", Flag49 (Id)); W ("Referenced", Flag156 (Id)); W ("Referenced_As_LHS", Flag36 (Id)); @@ -8096,9 +8222,6 @@ package body Einfo is when Array_Kind => Write_Str ("First_Index"); - when E_Protected_Body => - Write_Str ("Object_Ref"); - when Enumeration_Kind => Write_Str ("First_Literal"); @@ -8246,6 +8369,10 @@ package body Einfo is when E_Component => Write_Str ("Discriminant_Checking_Func"); + when E_Constant | + E_Variable => + Write_Str ("Prival_Link"); + when E_Discriminant => Write_Str ("Discriminant_Default_Value"); @@ -8402,9 +8529,6 @@ package body Einfo is when E_Block => Write_Str ("Entry_Cancel_Parameter"); - when E_Component => - Write_Str ("Protected_Operation"); - when E_Discriminant => Write_Str ("CR_Discriminant"); @@ -8429,7 +8553,13 @@ package body Einfo is when E_Function | E_Procedure => - Write_Str ("Generic_Renamings"); + if Present (Scope (Id)) + and then Is_Protected_Type (Scope (Id)) + then + Write_Str ("Protection_Object"); + else + Write_Str ("Generic_Renamings"); + end if; when E_Package => if Is_Generic_Instance (Id) then @@ -8438,10 +8568,8 @@ package body Einfo is Write_Str ("Limited_View"); end if; - -- What about Privals_Chain for protected operations ??? - when Entry_Kind => - Write_Str ("Privals_Chain"); + Write_Str ("Protection_Object"); when others => Write_Str ("Field23??"); @@ -8453,9 +8581,14 @@ package body Einfo is ------------------------ procedure Write_Field24_Name (Id : Entity_Id) is - pragma Warnings (Off, Id); begin - Write_Str ("Obsolescent_Warning"); + case Ekind (Id) is + when Subprogram_Kind => + Write_Str ("Spec_PPC_List"); + + when others => + Write_Str ("???"); + end case; end Write_Field24_Name; ------------------------ @@ -8472,9 +8605,6 @@ package body Einfo is E_Function => Write_Str ("Abstract_Interface_Alias"); - when E_Package => - Write_Str ("Current_Use_Clause"); - when E_Record_Type | E_Record_Subtype | E_Record_Type_With_Private | @@ -8525,6 +8655,9 @@ package body Einfo is E_Variable => Write_Str ("Last_Assignment"); + when Task_Kind => + Write_Str ("Relative_Deadline_Variable"); + when others => Write_Str ("Field26??"); end case; @@ -8540,6 +8673,9 @@ package body Einfo is when E_Procedure => Write_Str ("Wrapped_Entity"); + when E_Package | Type_Kind => + Write_Str ("Current_Use_Clause"); + when others => Write_Str ("Field27??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 145a262..10d7deb 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -284,13 +284,13 @@ package Einfo is -- attribute on other than the base type, and if assertions are enabled, -- an attempt to set the attribute on a subtype will raise an assert error. --- Other attributes are noted as applying the implementation base type only. --- These are representation attributes which must always apply to a full --- non-private type, and where the attributes are always on the full type. --- The attribute can be referenced on a subtype (and automatically retries --- the value from the implementation base type). However, it is an error --- to try to set the attribute on other than the implementation base type, --- and if assertions are enabled, an attempt to set the attribute on a +-- Other attributes are noted as applying to the [implementation base type +-- only]. These are representation attributes which must always apply to a +-- full non-private type, and where the attributes are always on the full +-- type. The attribute can be referenced on a subtype (and automatically +-- retries the value from the implementation base type). However, it is an +-- error to try to set the attribute on other than the implementation base +-- type, and if assertions are enabled, an attempt to set the attribute on a -- subtype will raise an assert error. -- Abstract_Interfaces (Elist25) @@ -638,10 +638,12 @@ package Einfo is -- created at the same time as the discriminal, and used to replace -- occurrences of the discriminant within the type declaration. --- Current_Use_Clause (Node25) --- Present in packages. Indicates the use clause currently in scope --- that makes the package use_visible. Used to detect redundant use --- clauses for the same package. +-- Current_Use_Clause (Node27) +-- Present in packages and in types. For packages, denotes the use +-- package clause currently in scope that makes the package use_visible. +-- For types, it denotes the use_type clause that makes the operators of +-- the type visible. Used for more precise warning messages on redundant +-- use clauses. -- Current_Value (Node9) -- Present in all object entities. Set in E_Variable, E_Constant, formal @@ -992,12 +994,12 @@ package Einfo is -- Equivalent_Type (Node18) -- Present in class wide types and subtypes, access to protected --- subprogram types, and in exception_types. For a classwide type, it +-- subprogram types, and in exception types. For a classwide type, it -- is always Empty. For a class wide subtype, it points to an entity -- created by the expander which gives Gigi an easily understandable -- equivalent of the class subtype with a known size (given by an -- initial value). See Exp_Util.Expand_Class_Wide_Subtype for further --- details. For E_exception_type, this points to the record containing +-- details. For E_Exception_Type, this points to the record containing -- the data necessary to represent exceptions (for further details, see -- System.Standard_Library. For access_to_protected subprograms, it -- denotes a record that holds pointers to the operation and to the @@ -1078,7 +1080,7 @@ package Einfo is -- must be retrieved through the entity designed by this field instead of -- being computed. --- Can_Use_Internal_Rep (Flag229) +-- Can_Use_Internal_Rep (Flag229) [base type only] -- Present in Access_Subprogram_Kind nodes. This flag is set by the -- front end and used by the back end. False means that the back end -- must represent the type in the same way as Convention-C types (and @@ -1536,11 +1538,11 @@ package Einfo is -- error exeption is correctly raised in this case at runtime. -- Has_Up_Level_Access (Flag215) --- Present in E_Variable and E_Constant entities. Set if the entity is --- declared in a local procedure p and is accessed in a procedure nested --- inside p. Only set when VM_Target /= No_VM currently. --- Why only set it under those conditions, sounds reasonable to always --- set this flag when appropriate ??? +-- Present in E_Variable and E_Constant entities. Set if the entity +-- is a local variable declared in a subprogram p and is accessed in +-- a subprogram nested inside p. Currently this flag is only set when +-- VM_Target /= No_VM, for efficiency, since only the .NET back-end +-- makes use of it to generate proper code for up-level references. -- Has_Nested_Block_With_Handler (Flag101) -- Present in scope entities. Set if there is a nested block within the @@ -1587,6 +1589,10 @@ package Einfo is -- to which the pragma applies, as well as the unit entity itself, for -- convenience in propagating the flag to contained entities. +-- Has_Postconditions (Flag240) +-- Present in subprogram entities. Set if postconditions are active for +-- the procedure, and a _postconditions procedure has been generated. + -- Has_Pragma_Controlled (Flag27) [implementation base type only] -- Present in access type entities. It is set if a pragma Controlled -- applies to the access type. @@ -2002,6 +2008,10 @@ package Einfo is -- Applies to all entities, true for task types and subtypes and for -- protected types and subtypes. +-- Is_Constant_Object (synthesized) +-- Applies to all entities, true for E_Constant, E_Loop_Parameter, and +-- E_In_Parameter entities. + -- Is_Constrained (Flag12) -- Present in types or subtypes which may have index, discriminant -- or range constraint (i.e. array types and subtypes, record types @@ -2061,6 +2071,14 @@ package Einfo is -- Present in all entities. Set only in E_Function entities that Layout -- creates to compute discriminant-dependent dynamic size/offset values. +-- Is_Discriminal (synthesized) +-- Applies to all entities, true for renamings of discriminants. Such +-- entities appear as constants or in parameters. + +-- Is_Dispatch_Table_Entity (Flag234) +-- Applies to all entities. Set to indicate to the backend that this +-- entity is associated with a dispatch table. + -- Is_Dispatching_Operation (Flag6) -- Present in all entities. Set true for procedures, functions, -- generic procedures and generic functions if the corresponding @@ -2506,6 +2524,10 @@ package Einfo is -- primitive wrappers. which are generated by the expander to wrap -- entries of protected or task types implementing a limited interface. +-- Is_Prival (synthesized) +-- Applies to all entities, true for renamings of private protected +-- components. Such entities appear as constants or variables. + -- Is_Private_Composite (Flag107) -- Present in composite types that have a private component. Used to -- enforce the rule that operations on the composite type that depend @@ -2522,6 +2544,10 @@ package Einfo is -- Applies to all entities, true for private types and subtypes, -- as well as for record with private types as subtypes +-- Is_Protected_Component (synthesized) +-- Applicable to all entities, true if the entity denotes a private +-- component of a protected type. + -- Is_Protected_Interface (Flag198) -- Present in types that are interfaces. True if interface is declared -- protected, or is derived from protected interfaces. @@ -2536,10 +2562,6 @@ package Einfo is -- example in the case of a variable name, then Gigi will generate an -- appropriate external name for use by the linker. --- Is_Protected_Private (synthesized) --- Applies to a record component. Returns true if this component --- is used to represent a private declaration of a protected type. - -- Is_Protected_Record_Type (synthesized) -- Applies to all entities, true if Is_Concurrent_Record_Type -- Corresponding_Concurrent_Type is a protected type. @@ -2560,8 +2582,8 @@ package Einfo is -- freeze time if the access type has a storage pool. -- Is_Raised (Flag224) --- Present in entities which denote exceptions. Set if the exception is --- thrown by a raise statement. +-- Present in exception entities. Set if the entity is referenced by a +-- a raise statement. -- Is_Real_Type (synthesized) -- Applies to all entities, true for real types and subtypes @@ -2607,6 +2629,11 @@ package Einfo is -- entities to which a pragma Shared_Passive is applied, and also in -- all entities within such packages. +-- Is_Standard_Character_Type (synthesized) +-- Applies to all entities, true for types and subtypes whose root type +-- is one of the standard character types (Character, Wide_Character, +-- Wide_Wide_Character). + -- Is_Statically_Allocated (Flag28) -- Present in all entities. This can only be set True for exception, -- variable, constant, and type/subtype entities. If the flag is set, @@ -2623,20 +2650,16 @@ package Einfo is -- flag set (since to allocate the object statically, its type must -- also be elaborated globally). --- Is_Static_Dispatch_Table_Entity (Flag234) --- Applies to all entities. Set to indicate to the backend that this --- entity is associated with an statically allocated dispatch table. - --- Is_Subprogram (synthesized) --- Applies to all entities, true for function, procedure and operator --- entities. - -- Is_String_Type (synthesized) -- Applies to all type entities. Determines if the given type is a -- string type, i.e. it is directly a string type or string subtype, -- or a string slice type, or an array type with one dimension and a -- component type that is a character type. +-- Is_Subprogram (synthesized) +-- Applies to all entities, true for function, procedure and operator +-- entities. + -- Is_Synchronized_Interface (Flag199) -- Present in types that are interfaces. True if interface is declared -- synchronized, task, or protected, or is derived from a synchronized @@ -2644,16 +2667,16 @@ package Einfo is -- Is_Tag (Flag78) -- Present in E_Component and E_Constant entities. For regular tagged --- type this flag is set on the tag component (whose name is Name_uTag) --- and for CPP_Class tagged types, this flag marks the pointer to the --- main vtable (i.e. the one to be extended by derivation). +-- type this flag is set on the tag component (whose name is Name_uTag). +-- For CPP_Class tagged types, this flag marks the pointer to the main +-- vtable (i.e. the one to be extended by derivation). -- Is_Tagged_Type (Flag55) -- Present in all entities. Set for an entity for a tagged type. -- Is_Task_Interface (Flag200) --- Present in types that are interfaces. True is interface is declared --- as such, or if it is derived from task interfaces. +-- Present in types that are interfaces. True if interface is declared as +-- a task interface, or if it is derived from task interfaces. -- Is_Task_Record_Type (synthesized) -- Applies to all entities. True if Is_Concurrent_Record_Type @@ -3094,11 +3117,21 @@ package Einfo is -- Applies to subprograms and subprogram types. Yields the number of -- formals as a value of type Pos. --- Obsolescent_Warning (Node24) --- Present in all entities. Set non-empty only if a pragma Obsolescent --- applying to the entity had a string argument, in which case it records --- the contents of the corresponding string literal node. This field is --- only accessed if the flag Is_Obsolescent is set. +-- Optimize_Alignment_Space (Flag241) +-- A flag present in type, subtype, variable, and constant entities. This +-- flag records that the type or object is to be layed out in a manner +-- consistent with Optimize_Alignment (Space) mode. The compiler and +-- binder ensure a consistent view of any given type or object. If pragma +-- Optimize_Alignment (Off) mode applies to the type/object, then neither +-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set. + +-- Optimize_Alignment_Time (Flag242) +-- A flag present in type, subtype, variable, and constant entities. This +-- flag records that the type or object is to be layed out in a manner +-- consistent with Optimize_Alignment (Time) mode. The compiler and +-- binder ensure a consistent view of any given type or object. If pragma +-- Optimize_Alignment (Off) mode applies to the type/object, then neither +-- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set. -- Original_Array_Type (Node21) -- Present in modular types and array types and subtypes. Set only @@ -3107,11 +3140,6 @@ package Einfo is -- points to the original array type for which this is the packed -- array implementation type. --- Object_Ref (Node17) --- Present in protected bodies. This is an implicit prival for the --- Protection object associated with a protected object. See Prival --- for further details on the use of privals. - -- OK_To_Reorder_Components (Flag239) [base type only] -- Present in record types. Set if the back end is permitted to reorder -- the components. If not set, the record must be layed out in the order @@ -3138,6 +3166,10 @@ package Einfo is -- In subtypes (tagged and untagged): -- Points to the component in the base type. +-- Overlays_Constant (Flag243) +-- Present in all entities. Set only for a variable for which there is +-- an address clause which causes the variable to overlay a constant. + -- Overridden_Operation (Node26) -- Present in subprograms. For overriding operations, points to the -- user-defined parent subprogram that is being overridden. @@ -3182,6 +3214,15 @@ package Einfo is -- is an error to reference the primitive operations field of a type -- that is not tagged). +-- Prival (Node17) +-- Present in private components of protected types. Refers to the entity +-- of the component renaming declaration generated inside protected +-- subprograms, entries or barrier functions. + +-- Prival_Link (Node20) +-- Present in constants and variables which rename private components of +-- protected types. Set to the original private component. + -- Private_Dependents (Elist18) -- Present in private (sub)types. Records the subtypes of the -- private type, derivations from it, and records and arrays @@ -3202,20 +3243,6 @@ package Einfo is -- declaration of the type is seen. Subprograms that have such an -- access parameter are also placed in the list of private_dependents. --- Prival (Node17) --- Present in components. Used for representing private declarations --- of protected objects (private formal: by analogy to Discriminal_Link). --- Empty unless the synthesized Is_Protected_Private attribute is --- true. The entity used as a formal parameter that corresponds to --- the to the private declaration in protected operations. See --- "Private data in protected objects" for details. - --- Privals_Chain (Elist23) --- Present in protected operations (subprograms and entries). Links --- all occurrences of the Privals in the body of the operation, in --- order to patch their types at the end of their expansion. See --- "Private data in protected objects" for details. - -- Private_View (Node22) -- For each private type, three entities are allocated, the private view, -- the full view, and the shadow entity. The shadow entity contains a @@ -3237,16 +3264,10 @@ package Einfo is -- Present in protected operations. References the entity for the -- subprogram which implements the body of the operation. --- Protected_Operation (Node23) --- Present in components. Used for representing private declarations --- of protected objects. Empty unless the synthesized attribute --- Is_Protected_Private is True. This is the entity corresponding --- to the body of the protected operation currently being analyzed, --- and which will eventually use the current Prival associated with --- this component to refer to the renaming of a private object --- component. As soon as the expander generates this renaming, this --- attribute is changed to refer to the next protected subprogram. --- See "Private data in protected objects" for details. +-- Protection_Object (Node23) +-- Applies to protected entries, entry families and subprograms. Denotes +-- the entity which is used to rename the _object component of protected +-- types. -- Reachable (Flag49) -- Present in labels. The flag is set over the range of statements in @@ -3304,6 +3325,12 @@ package Einfo is -- Set to point to the entity of the associated tagged type or interface -- type. +-- Relative_Deadline_Variable (Node26) [implementation base type only] +-- Present in task type entities. This flag is set if a valid and +-- effective pragma Relative_Deadline applies to the base type. Points +-- to the entity for a variable that is created to hold the value given +-- in a Relative_Deadline pragma for a task type. + -- Renamed_Entity (Node18) -- Present in exceptions, packages, subprograms and generic units. Set -- for entities that are defined by a renaming declaration. Denotes the @@ -3487,7 +3514,7 @@ package Einfo is -- size of objects of the type is known at compile time. This flag is -- used to optimize some generated code sequences, and also to enable -- some error checks (e.g. disallowing component clauses on variable --- length objects. It is set conservatively (i.e. if it is True, the +-- length objects). It is set conservatively (i.e. if it is True, the -- size is certainly known at compile time, if it is False, then the -- size may or may not be known at compile time, but the code will -- assume that it is not known). @@ -3503,6 +3530,12 @@ package Einfo is -- case where there is a separate spec, where this field references -- the corresponding parameter entities in the spec. +-- Spec_PPC_List (Node24) +-- Present in subprogram entities. Points to a list of Precondition +-- and Postcondition N_Pragma nodes for preconditions and postconditions +-- declared in the spec. The last pragma encountered is at the head of +-- this list, so it is in reverse order of textual appearence. + -- Storage_Size_Variable (Node15) [implementation base type only] -- Present in access types and task type entities. This flag is set -- if a valid and effective pragma Storage_Size applies to the base @@ -3595,6 +3628,10 @@ package Einfo is -- checks associated with declared volatile variables, but if the test -- is for the purposes of suppressing optimizations, then the front -- end should test Treat_As_Volatile rather than Is_Volatile. +-- +-- Note: before testing Treat_As_Volatile, consider whether it would +-- be more appropriate to use Exp_Util.Is_Volatile_Reference instead, +-- which catches more cases of volatile references. -- Type_High_Bound (synthesized) -- Applies to scalar types. Returns the tree node (Node_Id) that contains @@ -4509,7 +4546,6 @@ package Einfo is -- Etype (Node5) -- First_Rep_Item (Node6) -- Freeze_Node (Node7) - -- Obsolescent_Warning (Node24) -- Address_Taken (Flag104) -- Can_Never_Be_Null (Flag38) @@ -4544,6 +4580,7 @@ package Einfo is -- Is_Compilation_Unit (Flag149) -- Is_Completely_Hidden (Flag103) -- Is_Discrim_SO_Function (Flag176) + -- Is_Dispatch_Table_Entity (Flag234) -- Is_Dispatching_Operation (Flag6) -- Is_Entry_Formal (Flag52) -- Is_Exported (Flag99) @@ -4574,7 +4611,6 @@ package Einfo is -- Is_Remote_Types (Flag61) -- Is_Renaming_Of_Object (Flag112) -- Is_Shared_Passive (Flag60) - -- Is_Static_Dispatch_Table_Entity (Flag234) -- Is_Statically_Allocated (Flag28) -- Is_Tagged_Type (Flag55) -- Is_Trivial_Subprogram (Flag235) @@ -4589,6 +4625,7 @@ package Einfo is -- Needs_Debug_Info (Flag147) -- Never_Set_In_Source (Flag115) -- No_Return (Flag113) + -- Overlays_Constant (Flag243) -- Referenced (Flag156) -- Referenced_As_LHS (Flag36) -- Referenced_As_Out_Parameter (Flag227) @@ -4608,6 +4645,7 @@ package Einfo is -- Is_Derived_Type (synth) -- Is_Dynamic_Scope (synth) -- Is_Limited_Type (synth) + -- Is_Standard_Character_Type (synth) -- Underlying_Type (synth) -- all classification attributes (synth) @@ -4671,6 +4709,8 @@ package Einfo is -- Known_To_Have_Preelab_Init (Flag207) -- Must_Be_On_Byte_Boundary (Flag183) -- Must_Have_Preelab_Init (Flag208) + -- Optimize_Alignment_Space (Flag241) + -- Optimize_Alignment_Time (Flag242) -- Size_Depends_On_Discriminant (Flag177) -- Size_Known_At_Compile_Time (Flag92) -- Strict_Alignment (Flag145) (base type only) @@ -4700,14 +4740,14 @@ package Einfo is -- Directly_Designated_Type (Node20) -- Needs_No_Actuals (Flag22) -- Can_Use_Internal_Rep (Flag229) - -- (plus type attributes) + -- (plus type attributes) -- E_Access_Subprogram_Type -- Equivalent_Type (Node18) (remote types only) -- Directly_Designated_Type (Node20) -- Needs_No_Actuals (Flag22) -- Can_Use_Internal_Rep (Flag229) - -- (plus type attributes) + -- (plus type attributes) -- E_Access_Type -- E_Access_Subtype @@ -4802,7 +4842,6 @@ package Einfo is -- Discriminant_Checking_Func (Node20) -- Interface_Name (Node21) (JGNAT usage only) -- Original_Record_Component (Node22) - -- Protected_Operation (Node23) -- DT_Offset_To_Top_Func (Node25) -- Related_Type (Node26) -- Has_Biased_Representation (Flag139) @@ -4812,7 +4851,6 @@ package Einfo is -- Is_Volatile (Flag16) -- Treat_As_Volatile (Flag41) -- Is_Return_Object (Flag209) - -- Is_Protected_Private (synth) -- Next_Component (synth) -- Next_Component_Or_Discriminant (synth) -- Next_Tag_Component (synth) @@ -4827,6 +4865,7 @@ package Einfo is -- Actual_Subtype (Node17) -- Renamed_Object (Node18) -- Size_Check_Code (Node19) (constants only) + -- Prival_Link (Node20) (privals only) -- Interface_Name (Node21) -- Related_Type (Node26) (constants only) -- Has_Alignment_Clause (Flag46) @@ -4839,10 +4878,12 @@ package Einfo is -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) + -- Is_Return_Object (Flag209) -- Is_True_Constant (Flag163) -- Is_Volatile (Flag16) + -- Optimize_Alignment_Space (Flag241) (constants only) + -- Optimize_Alignment_Time (Flag242) (constants only) -- Treat_As_Volatile (Flag41) - -- Is_Return_Object (Flag209) -- Address_Clause (synth) -- Alignment_Clause (synth) -- Constant_Value (synth) @@ -4893,7 +4934,7 @@ package Einfo is -- Last_Entity (Node20) -- Accept_Address (Elist21) -- Scope_Depth_Value (Uint22) - -- Privals_Chain (Elist23) (for a protected entry) + -- Protection_Object (Node23) (protected kind) -- Default_Expressions_Processed (Flag108) -- Entry_Accepted (Flag152) -- Is_AST_Entry (Flag132) (for entry only) @@ -4976,7 +5017,7 @@ package Einfo is -- Scope_Depth_Value (Uint22) -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic function only) - -- Privals_Chain (Elist23) (protected func only) + -- Protection_Object (Node23) (for concurrent kind) -- Abstract_Interface_Alias (Node25) -- Overridden_Operation (Node26) -- Extra_Formals (Node28) @@ -4992,6 +5033,7 @@ package Einfo is -- Has_Master_Entity (Flag21) -- Has_Missing_Return (Flag142) -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Postconditions (Flag240) -- Has_Recursive_Call (Flag143) -- Has_Subprogram_Descriptor (Flag93) -- Implemented_By_Entry (Flag232) (non-generic case only) @@ -5064,7 +5106,6 @@ package Einfo is -- Extra_Formal (Node15) -- Unset_Reference (Node16) -- Actual_Subtype (Node17) - -- Renamed_Object (Node18) -- Spec_Entity (Node19) -- Default_Value (Node20) @@ -5124,6 +5165,7 @@ package Einfo is -- First_Entity (Node17) -- Alias (Node18) -- Last_Entity (Node20) + -- Has_Postconditions (Flag240) -- Is_Machine_Code_Subprogram (Flag137) -- Is_Pure (Flag44) -- Is_Intrinsic_Subprogram (Flag64) @@ -5131,6 +5173,8 @@ package Einfo is -- Is_Primitive (Flag218) -- Is_Thunk (Flag225) -- Default_Expressions_Processed (Flag108) + -- Aren't there more flags and fields? seems like this list should be + -- more similar to the E_Function list, which is much longer ??? -- E_Ordinary_Fixed_Point_Type -- E_Ordinary_Fixed_Point_Subtype @@ -5162,7 +5206,7 @@ package Einfo is -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic case only) -- Limited_View (Node23) (non-generic/instance) - -- Current_Use_Clause (Node25) + -- Current_Use_Clause (Node27) -- Package_Instantiation (Node26) -- Delay_Subprogram_Descriptors (Flag50) -- Body_Needed_For_SAL (Flag40) @@ -5233,7 +5277,8 @@ package Einfo is -- Scope_Depth_Value (Uint22) -- Generic_Renamings (Elist23) (for instance) -- Inner_Instances (Elist23) (for generic proc) - -- Privals_Chain (Elist23) (for protected proc) + -- Protection_Object (Node23) (for concurrent kind) + -- Spec_PPC_List (Node24) (non-generic case only) -- Abstract_Interface_Alias (Node25) -- Static_Initialization (Node26) (init_proc only) -- Overridden_Operation (Node26) @@ -5251,6 +5296,7 @@ package Einfo is -- Has_Completion (Flag26) -- Has_Master_Entity (Flag21) -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Postconditions (Flag240) -- Has_Subprogram_Descriptor (Flag93) -- Implemented_By_Entry (Flag232) (non-generic case only) -- Is_Visible_Child_Unit (Flag116) @@ -5280,11 +5326,8 @@ package Einfo is -- First_Formal (synth) -- First_Formal_With_Extras (synth) -- Number_Formals (synth) - -- Delay_Cleanups (Flag114) - -- Discard_Names (Flag88) -- E_Protected_Body - -- Object_Ref (Node17) -- (any others??? First/Last Entity, Scope_Depth???) -- E_Protected_Object @@ -5438,6 +5481,7 @@ package Einfo is -- Sec_Stack_Needed_For_Return (Flag167) ??? -- Has_Entries (synth) -- Number_Entries (synth) + -- Relative_Deadline_Variable (Node26) (base type only) -- (plus type attributes) -- E_Variable @@ -5451,6 +5495,7 @@ package Einfo is -- Actual_Subtype (Node17) -- Renamed_Object (Node18) -- Size_Check_Code (Node19) + -- Prival_Link (Node20) -- Interface_Name (Node21) -- Shared_Var_Assign_Proc (Node22) -- Extra_Constrained (Node23) @@ -5461,15 +5506,17 @@ package Einfo is -- Has_Biased_Representation (Flag139) -- Has_Initial_Value (Flag219) -- Has_Size_Clause (Flag29) + -- Has_Up_Level_Access (Flag215) -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) -- Is_Shared_Passive (Flag60) -- Is_True_Constant (Flag163) -- Is_Volatile (Flag16) - -- Treat_As_Volatile (Flag41) -- Is_Return_Object (Flag209) - -- Has_Up_Level_Access (Flag215) + -- Optimize_Alignment_Space (Flag241) + -- Optimize_Alignment_Time (Flag242) + -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) -- Alignment_Clause (synth) -- Constant_Value (synth) @@ -5562,9 +5609,10 @@ package Einfo is -- general manner, like any other variables: -- In initialization expressions for records. Note that the expressions - -- used in Priority, Storage_Size, and Task_Info pragmas are effectively - -- in this category, since these pragmas are converted to initialized - -- record fields in the Corresponding_Record_Type. + -- used in Priority, Storage_Size, Task_Info and Relative_Deadline + -- pragmas are effectively in this category, since these pragmas are + -- converted to initialized record fields in the Corresponding_Record_ + -- Type. -- In task and protected bodies, where the discriminant values may be -- referenced freely within these bodies. Discriminants can also appear @@ -5574,12 +5622,12 @@ package Einfo is -- objects. The following approach is used to simplify and minimize the -- special processing that is required. - -- When a record type with discriminants is processed, the semantic - -- processing creates the entities for the discriminants. It also creates - -- an additional set of entities, called discriminals, one for each of - -- the discriminants, and the Discriminal field of the discriminant entity - -- points to this additional entity, which is initially created as an - -- uninitialized (E_Void) entity. + -- When a record type with discriminants is analyzed, semantic processing + -- creates the entities for the discriminants. It also creates additional + -- sets of entities called discriminals, one for each of the discriminants, + -- and the Discriminal field of the discriminant entity points to this + -- additional entity, which is initially created as an uninitialized + -- (E_Void) entity. -- During expansion of expressions, any discriminant reference is replaced -- by a reference to the corresponding discriminal. When the initialization @@ -5590,17 +5638,17 @@ package Einfo is -- have already been replaced by references to these discriminals, which -- are now the formal parameters corresponding to the required objects. - -- In the case of a task or protected body, the semantics similarly - -- creates a set of discriminals for the discriminants of the task or - -- protected type. When the procedure is created for the task body, - -- the parameter passed in is a reference to the task value type, which - -- contains the required discriminant values. The expander creates a - -- set of declarations of the form: + -- In the case of a task or protected body, the semantics similarly creates + -- a set of discriminals for the discriminants of the task or protected + -- type. When the procedure is created for the task body, the parameter + -- passed in is a reference to the task value type, which contains the + -- required discriminant values. The expander creates a set of declarations + -- of the form: - -- discriminal : constant dtype renames _Task.discriminant; + -- discr_nameD : constant disrc_type renames _task.discr_name; - -- where discriminal is the discriminal entity referenced by the task - -- discriminant, and _Task is the task value passed in as the parameter. + -- where discr_nameD is the discriminal entity referenced by the task + -- discriminant, and _task is the task value passed in as the parameter. -- Again, any references to discriminants in the task body have been -- replaced by the discriminal reference, which is now an object that -- contains the required value. @@ -5613,15 +5661,15 @@ package Einfo is -- The one bit of trickiness arises in making sure that the right set of -- discriminals is used at the right time. First the task definition is -- processed. Any references to discriminants here are replaced by the - -- the corresponding *task* discriminals (the record type doesn't even - -- exist yet, since it is constructed as part of the expansion of the - -- task declaration, which happens after the semantic processing of the - -- task definition). The discriminants to be used for the corresponding - -- record are created at the same time as the other discriminals, and - -- held in the CR_Discriminant field of the discriminant. A use of the - -- discriminant in a bound for an entry family is replaced with the CR_ - -- discriminant because it controls the bound of the entry queue array - -- which is a component of the corresponding record. + -- corresponding *task* discriminals (the record type doesn't even exist + -- yet, since it is constructed as part of the expansion of the task + -- declaration, which happens after the semantic processing of the task + -- definition). The discriminants to be used for the corresponding record + -- are created at the same time as the other discriminals, and held in the + -- CR_Discriminant field of the discriminant. A use of the discriminant in + -- a bound for an entry family is replaced with the CR_Discriminant because + -- it controls the bound of the entry queue array which is a component of + -- the corresponding record. -- Just before the record initialization routine is constructed, the -- expander exchanges the task and record discriminals. This has two @@ -5634,57 +5682,52 @@ package Einfo is -- task body, and also for the discriminal declarations at the start of -- the task body. - --------------------------------------- - -- Private data in protected objects -- - --------------------------------------- - - -- Private object declarations in protected types pose problems - -- similar to those of discriminants. They are expanded to components - -- of a record which is passed as the parameter "_object" to expanded - -- forms of all protected operations. As with discriminants, timing - -- of this expansion is a problem. The sequence of statements for a - -- protected operation is expanded before the operation itself, so the - -- formal parameter for the record object containing the private data - -- does not exist when the references to that data are expanded. - - -- For this reason, private data is handled in the same way as - -- discriminants, expanding references to private data in protected - -- operations (which appear as components) to placeholders which will - -- eventually become renamings of the private selected components - -- of the "_object" formal parameter. These placeholders are called - -- "privals", by analogy to the "discriminals" used to implement - -- discriminants. They are attached to the component declaration nodes - -- representing the private object declarations of the protected type. - - -- As with discriminals, each protected subprogram needs a unique set - -- of privals, since they must refer to renamings of components of a - -- formal parameter of that operation. Entry bodies need another set, - -- which they all share and which is associated with renamings in the - -- Service_Entries procedure for the protected type (this is not yet - -- implemented???). This means that we must associate a new set of - -- privals (and discriminals) with the private declarations after - -- the body of a protected subprogram is processed. - - -- The last complication is the presence of discriminants and discriminated - -- components. In the corresponding record, the components are constrained - -- by the discriminants of the record, but within each protected operation - -- they are constrained by the discriminants of the actual. The actual - -- subtypes of those components are constructed as for other unconstrained - -- formals, but the privals are created before the formal object is added - -- to the parameter list of the protected operation, so they carry the - -- nominal subtype of the original component. After the protected operation - -- is actually created (in the expansion of the protected body) we must - -- patch the types of each prival occurrence with the proper actual subtype - -- which is by now set. The Privals_Chain is used for this patching. + --------------------------------------------------- + -- Handling of private data in protected objects -- + --------------------------------------------------- + + -- Private components in protected types pose problems similar to those + -- of discriminants. Private data is visible and can be directly referenced + -- from protected bodies. However, when protected entries and subprograms + -- are expanded into corresponding bodies and barrier functions, private + -- components lose their original context and visibility. + + -- To remedy this side effect of expansion, private components are expanded + -- into renamings called "privals", by analogy with "discriminals". + + -- private_comp : comp_type renames _object.private_comp; + + -- Prival declarations are inserted during the analysis of subprogram and + -- entry bodies to ensure proper visibility for any subsequent expansion. + -- _Object is the formal parameter of the generated corresponding body or + -- a local renaming which denotes the protected object obtained from entry + -- parameter _O. Privals receive minimal decoration upon creation and are + -- categorized as either E_Variable for the general case or E_Constant when + -- they appear in functions. + + -- Along with the local declarations, each private component carries a + -- placeholder which references the prival entity in the current body. This + -- form of indirection is used to resolve name clashes of privals and other + -- locally visible entities such as parameters, local objects, entry family + -- indexes or identifiers used in the barrier condition. + + -- When analyzing the statements of a protected subprogram or entry, any + -- reference to a private component must resolve to the locally declared + -- prival through normal visibility. In case of name conflicts (the cases + -- above), the prival is marked as hidden and acts as a weakly declared + -- entity. As a result, the reference points to the correct entity. When a + -- private component is denoted by an expanded name (prot_type.comp for + -- example), the expansion mechanism uses the placeholder of the component + -- to correct the Entity and Etype of the reference. ------------------- -- Type Synonyms -- ------------------- -- The following type synonyms are used to tidy up the function and - -- procedure declarations that follow, and also to make it possible - -- to meet the requirement for the XEINFO utility that all function - -- specs must fit on a single source line. + -- procedure declarations that follow, and also to make it possible to meet + -- the requirement for the XEINFO utility that all function specs must fit + -- on a single source line. subtype B is Boolean; subtype C is Component_Alignment_Kind; @@ -5837,6 +5880,7 @@ package Einfo is function Has_Object_Size_Clause (Id : E) return B; function Has_Per_Object_Constraint (Id : E) return B; function Has_Persistent_BSS (Id : E) return B; + function Has_Postconditions (Id : E) return B; function Has_Pragma_Controlled (Id : E) return B; function Has_Pragma_Elaborate_Body (Id : E) return B; function Has_Pragma_Inline (Id : E) return B; @@ -5901,6 +5945,7 @@ package Einfo is function Is_Controlled (Id : E) return B; function Is_Controlling_Formal (Id : E) return B; function Is_Discrim_SO_Function (Id : E) return B; + function Is_Dispatch_Table_Entity (Id : E) return B; function Is_Dispatching_Operation (Id : E) return B; function Is_Eliminated (Id : E) return B; function Is_Entry_Formal (Id : E) return B; @@ -5951,7 +5996,6 @@ package Einfo is function Is_Renaming_Of_Object (Id : E) return B; function Is_Return_Object (Id : E) return B; function Is_Shared_Passive (Id : E) return B; - function Is_Static_Dispatch_Table_Entity (Id : E) return B; function Is_Statically_Allocated (Id : E) return B; function Is_Synchronized_Interface (Id : E) return B; function Is_Tag (Id : E) return B; @@ -5998,23 +6042,24 @@ package Einfo is function Normalized_First_Bit (Id : E) return U; function Normalized_Position (Id : E) return U; function Normalized_Position_Max (Id : E) return U; - function Object_Ref (Id : E) return E; - function Obsolescent_Warning (Id : E) return N; function OK_To_Reorder_Components (Id : E) return B; + function Optimize_Alignment_Space (Id : E) return B; + function Optimize_Alignment_Time (Id : E) return B; function Original_Array_Type (Id : E) return E; function Original_Record_Component (Id : E) return E; + function Overlays_Constant (Id : E) return B; function Overridden_Operation (Id : E) return E; function Package_Instantiation (Id : E) return N; function Packed_Array_Type (Id : E) return E; function Parent_Subtype (Id : E) return E; function Primitive_Operations (Id : E) return L; function Prival (Id : E) return E; - function Privals_Chain (Id : E) return L; + function Prival_Link (Id : E) return E; function Private_Dependents (Id : E) return L; function Private_View (Id : E) return N; function Protected_Body_Subprogram (Id : E) return E; function Protected_Formal (Id : E) return E; - function Protected_Operation (Id : E) return E; + function Protection_Object (Id : E) return E; function RM_Size (Id : E) return U; function Reachable (Id : E) return B; function Referenced (Id : E) return B; @@ -6025,6 +6070,7 @@ package Einfo is function Related_Array_Object (Id : E) return E; function Related_Instance (Id : E) return E; function Related_Type (Id : E) return E; + function Relative_Deadline_Variable (Id : E) return E; function Renamed_Entity (Id : E) return N; function Renamed_In_Spec (Id : E) return B; function Renamed_Object (Id : E) return N; @@ -6046,6 +6092,7 @@ package Einfo is function Size_Depends_On_Discriminant (Id : E) return B; function Small_Value (Id : E) return R; function Spec_Entity (Id : E) return E; + function Spec_PPC_List (Id : E) return N; function Storage_Size_Variable (Id : E) return E; function Static_Elaboration_Desired (Id : E) return B; function Static_Initialization (Id : E) return N; @@ -6162,14 +6209,18 @@ package Einfo is function Is_Boolean_Type (Id : E) return B; function Is_By_Copy_Type (Id : E) return B; function Is_By_Reference_Type (Id : E) return B; + function Is_Constant_Object (Id : E) return B; function Is_Derived_Type (Id : E) return B; + function Is_Discriminal (Id : E) return B; function Is_Dynamic_Scope (Id : E) return B; function Is_Indefinite_Subtype (Id : E) return B; function Is_Limited_Type (Id : E) return B; function Is_Package_Or_Generic_Package (Id : E) return B; - function Is_Protected_Private (Id : E) return B; + function Is_Prival (Id : E) return B; + function Is_Protected_Component (Id : E) return B; function Is_Protected_Record_Type (Id : E) return B; function Is_Inherently_Limited_Type (Id : E) return B; + function Is_Standard_Character_Type (Id : E) return B; function Is_String_Type (Id : E) return B; function Is_Task_Record_Type (Id : E) return B; function Is_Wrapper_Package (Id : E) return B; @@ -6386,6 +6437,7 @@ package Einfo is procedure Set_Has_Object_Size_Clause (Id : E; V : B := True); procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True); procedure Set_Has_Persistent_BSS (Id : E; V : B := True); + procedure Set_Has_Postconditions (Id : E; V : B := True); procedure Set_Has_Pragma_Controlled (Id : E; V : B := True); procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True); procedure Set_Has_Pragma_Inline (Id : E; V : B := True); @@ -6453,6 +6505,7 @@ package Einfo is procedure Set_Is_Controlling_Formal (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_Dispatch_Table_Entity (Id : E; V : B := True); procedure Set_Is_Dispatching_Operation (Id : E; V : B := True); procedure Set_Is_Eliminated (Id : E; V : B := True); procedure Set_Is_Entry_Formal (Id : E; V : B := True); @@ -6508,7 +6561,6 @@ package Einfo is procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True); procedure Set_Is_Return_Object (Id : E; V : B := True); procedure Set_Is_Shared_Passive (Id : E; V : B := True); - procedure Set_Is_Static_Dispatch_Table_Entity (Id : E; V : B := True); procedure Set_Is_Statically_Allocated (Id : E; V : B := True); procedure Set_Is_Synchronized_Interface (Id : E; V : B := True); procedure Set_Is_Tag (Id : E; V : B := True); @@ -6555,23 +6607,24 @@ package Einfo is procedure Set_Normalized_First_Bit (Id : E; V : U); procedure Set_Normalized_Position (Id : E; V : U); procedure Set_Normalized_Position_Max (Id : E; V : U); - procedure Set_Object_Ref (Id : E; V : E); - procedure Set_Obsolescent_Warning (Id : E; V : N); procedure Set_OK_To_Reorder_Components (Id : E; V : B := True); + procedure Set_Optimize_Alignment_Space (Id : E; V : B := True); + procedure Set_Optimize_Alignment_Time (Id : E; V : B := True); procedure Set_Original_Array_Type (Id : E; V : E); procedure Set_Original_Record_Component (Id : E; V : E); + procedure Set_Overlays_Constant (Id : E; V : B := True); procedure Set_Overridden_Operation (Id : E; V : E); procedure Set_Package_Instantiation (Id : E; V : N); procedure Set_Packed_Array_Type (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E); procedure Set_Primitive_Operations (Id : E; V : L); procedure Set_Prival (Id : E; V : E); - procedure Set_Privals_Chain (Id : E; V : L); + procedure Set_Prival_Link (Id : E; V : E); procedure Set_Private_Dependents (Id : E; V : L); procedure Set_Private_View (Id : E; V : N); procedure Set_Protected_Body_Subprogram (Id : E; V : E); procedure Set_Protected_Formal (Id : E; V : E); - procedure Set_Protected_Operation (Id : E; V : N); + procedure Set_Protection_Object (Id : E; V : E); procedure Set_RM_Size (Id : E; V : U); procedure Set_Reachable (Id : E; V : B := True); procedure Set_Referenced (Id : E; V : B := True); @@ -6582,6 +6635,7 @@ package Einfo is procedure Set_Related_Array_Object (Id : E; V : E); procedure Set_Related_Instance (Id : E; V : E); procedure Set_Related_Type (Id : E; V : E); + procedure Set_Relative_Deadline_Variable (Id : E; V : E); procedure Set_Renamed_Entity (Id : E; V : N); procedure Set_Renamed_In_Spec (Id : E; V : B := True); procedure Set_Renamed_Object (Id : E; V : N); @@ -6603,6 +6657,7 @@ package Einfo is procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True); procedure Set_Small_Value (Id : E; V : R); procedure Set_Spec_Entity (Id : E; V : E); + procedure Set_Spec_PPC_List (Id : E; V : N); procedure Set_Storage_Size_Variable (Id : E; V : E); procedure Set_Static_Elaboration_Desired (Id : E; V : B); procedure Set_Static_Initialization (Id : E; V : N); @@ -7029,6 +7084,7 @@ package Einfo is pragma Inline (Has_Object_Size_Clause); pragma Inline (Has_Per_Object_Constraint); pragma Inline (Has_Persistent_BSS); + pragma Inline (Has_Postconditions); pragma Inline (Has_Pragma_Controlled); pragma Inline (Has_Pragma_Elaborate_Body); pragma Inline (Has_Pragma_Inline); @@ -7110,6 +7166,7 @@ package Einfo is pragma Inline (Is_Descendent_Of_Address); pragma Inline (Is_Discrete_Or_Fixed_Point_Type); pragma Inline (Is_Discrete_Type); + pragma Inline (Is_Dispatch_Table_Entity); pragma Inline (Is_Dispatching_Operation); pragma Inline (Is_Elementary_Type); pragma Inline (Is_Eliminated); @@ -7189,7 +7246,6 @@ package Einfo is pragma Inline (Is_Scalar_Type); pragma Inline (Is_Shared_Passive); pragma Inline (Is_Signed_Integer_Type); - pragma Inline (Is_Static_Dispatch_Table_Entity); pragma Inline (Is_Statically_Allocated); pragma Inline (Is_Subprogram); pragma Inline (Is_Synchronized_Interface); @@ -7240,11 +7296,12 @@ package Einfo is pragma Inline (Normalized_First_Bit); pragma Inline (Normalized_Position); pragma Inline (Normalized_Position_Max); - pragma Inline (Object_Ref); - pragma Inline (Obsolescent_Warning); pragma Inline (OK_To_Reorder_Components); + pragma Inline (Optimize_Alignment_Space); + pragma Inline (Optimize_Alignment_Time); pragma Inline (Original_Array_Type); pragma Inline (Original_Record_Component); + pragma Inline (Overlays_Constant); pragma Inline (Overridden_Operation); pragma Inline (Package_Instantiation); pragma Inline (Packed_Array_Type); @@ -7252,12 +7309,12 @@ package Einfo is pragma Inline (Parent_Subtype); pragma Inline (Primitive_Operations); pragma Inline (Prival); - pragma Inline (Privals_Chain); + pragma Inline (Prival_Link); pragma Inline (Private_Dependents); pragma Inline (Private_View); pragma Inline (Protected_Body_Subprogram); pragma Inline (Protected_Formal); - pragma Inline (Protected_Operation); + pragma Inline (Protection_Object); pragma Inline (RM_Size); pragma Inline (Reachable); pragma Inline (Referenced); @@ -7268,6 +7325,7 @@ package Einfo is pragma Inline (Related_Array_Object); pragma Inline (Related_Instance); pragma Inline (Related_Type); + pragma Inline (Relative_Deadline_Variable); pragma Inline (Renamed_Entity); pragma Inline (Renamed_In_Spec); pragma Inline (Renamed_Object); @@ -7289,6 +7347,7 @@ package Einfo is pragma Inline (Size_Known_At_Compile_Time); pragma Inline (Small_Value); pragma Inline (Spec_Entity); + pragma Inline (Spec_PPC_List); pragma Inline (Storage_Size_Variable); pragma Inline (Static_Elaboration_Desired); pragma Inline (Static_Initialization); @@ -7362,6 +7421,7 @@ package Einfo is pragma Inline (Set_DT_Entry_Count); pragma Inline (Set_DT_Offset_To_Top_Func); pragma Inline (Set_DT_Position); + pragma Inline (Set_Relative_Deadline_Variable); pragma Inline (Set_Default_Expr_Function); pragma Inline (Set_Default_Expressions_Processed); pragma Inline (Set_Default_Value); @@ -7449,6 +7509,7 @@ package Einfo is pragma Inline (Set_Has_Object_Size_Clause); pragma Inline (Set_Has_Per_Object_Constraint); pragma Inline (Set_Has_Persistent_BSS); + pragma Inline (Set_Has_Postconditions); pragma Inline (Set_Has_Pragma_Controlled); pragma Inline (Set_Has_Pragma_Elaborate_Body); pragma Inline (Set_Has_Pragma_Inline); @@ -7517,6 +7578,7 @@ package Einfo is pragma Inline (Set_Is_Controlling_Formal); pragma Inline (Set_Is_Descendent_Of_Address); pragma Inline (Set_Is_Discrim_SO_Function); + pragma Inline (Set_Is_Dispatch_Table_Entity); pragma Inline (Set_Is_Dispatching_Operation); pragma Inline (Set_Is_Eliminated); pragma Inline (Set_Is_Entry_Formal); @@ -7572,7 +7634,6 @@ package Einfo is pragma Inline (Set_Is_Renaming_Of_Object); pragma Inline (Set_Is_Return_Object); pragma Inline (Set_Is_Shared_Passive); - pragma Inline (Set_Is_Static_Dispatch_Table_Entity); pragma Inline (Set_Is_Statically_Allocated); pragma Inline (Set_Is_Synchronized_Interface); pragma Inline (Set_Is_Tag); @@ -7619,23 +7680,24 @@ package Einfo is pragma Inline (Set_Normalized_First_Bit); pragma Inline (Set_Normalized_Position); pragma Inline (Set_Normalized_Position_Max); - pragma Inline (Set_Object_Ref); - pragma Inline (Set_Obsolescent_Warning); pragma Inline (Set_OK_To_Reorder_Components); + pragma Inline (Set_Optimize_Alignment_Space); + pragma Inline (Set_Optimize_Alignment_Time); pragma Inline (Set_Original_Array_Type); pragma Inline (Set_Original_Record_Component); + pragma Inline (Set_Overlays_Constant); pragma Inline (Set_Overridden_Operation); pragma Inline (Set_Package_Instantiation); pragma Inline (Set_Packed_Array_Type); pragma Inline (Set_Parent_Subtype); pragma Inline (Set_Primitive_Operations); pragma Inline (Set_Prival); - pragma Inline (Set_Privals_Chain); + pragma Inline (Set_Prival_Link); pragma Inline (Set_Private_Dependents); pragma Inline (Set_Private_View); pragma Inline (Set_Protected_Body_Subprogram); pragma Inline (Set_Protected_Formal); - pragma Inline (Set_Protected_Operation); + pragma Inline (Set_Protection_Object); pragma Inline (Set_RM_Size); pragma Inline (Set_Reachable); pragma Inline (Set_Referenced); @@ -7667,6 +7729,7 @@ package Einfo is pragma Inline (Set_Size_Known_At_Compile_Time); pragma Inline (Set_Small_Value); pragma Inline (Set_Spec_Entity); + pragma Inline (Set_Spec_PPC_List); pragma Inline (Set_Storage_Size_Variable); pragma Inline (Set_Static_Elaboration_Desired); pragma Inline (Set_Static_Initialization); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index bf5e9d7..b6d4ae8 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -30,6 +30,8 @@ with Einfo; use Einfo; with Elists; use Elists; with Exp_Atag; use Exp_Atag; with Exp_Ch2; use Exp_Ch2; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch6; use Exp_Ch6; with Exp_Ch9; use Exp_Ch9; with Exp_Imgv; use Exp_Imgv; with Exp_Pakd; use Exp_Pakd; @@ -37,6 +39,7 @@ with Exp_Strm; use Exp_Strm; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Exp_VFpt; use Exp_VFpt; +with Fname; use Fname; with Freeze; use Freeze; with Gnatvsn; use Gnatvsn; with Itypes; use Itypes; @@ -251,12 +254,20 @@ package body Exp_Attr is function May_Be_External_Call return Boolean is Subp : Entity_Id; + Par : Node_Id := Parent (N); + begin - if (Nkind (Parent (N)) = N_Procedure_Call_Statement - or else Nkind (Parent (N)) = N_Function_Call) - and then Is_Entity_Name (Name (Parent (N))) + -- Account for the case where the Access attribute is part of a + -- named parameter association. + + if Nkind (Par) = N_Parameter_Association then + Par := Parent (Par); + end if; + + if Nkind_In (Par, N_Procedure_Call_Statement, N_Function_Call) + and then Is_Entity_Name (Name (Par)) then - Subp := Entity (Name (Parent (N))); + Subp := Entity (Name (Par)); return not In_Open_Scopes (Scope (Subp)); else return False; @@ -272,8 +283,6 @@ package body Exp_Attr is -- current enclosing operation. if Is_Entity_Name (Pref) then - pragma Assert (In_Open_Scopes (Scope (Entity (Pref)))); - if May_Be_External_Call then Sub := New_Occurrence_Of @@ -284,10 +293,18 @@ package body Exp_Attr is (Protected_Body_Subprogram (Entity (Pref)), Loc); end if; + -- Don't traverse the scopes when the attribute occurs within an init + -- proc, because we directly use the _init formal of the init proc in + -- that case. + Curr := Current_Scope; - while Scope (Curr) /= Scope (Entity (Pref)) loop - Curr := Scope (Curr); - end loop; + if not Is_Init_Proc (Curr) then + pragma Assert (In_Open_Scopes (Scope (Entity (Pref)))); + + while Scope (Curr) /= Scope (Entity (Pref)) loop + Curr := Scope (Curr); + end loop; + end if; -- In case of protected entries the first formal of its Protected_ -- Body_Subprogram is the address of the object. @@ -298,6 +315,15 @@ package body Exp_Attr is (First_Formal (Protected_Body_Subprogram (Curr)), Loc); + -- If the current scope is an init proc, then use the address of the + -- _init formal as the object reference. + + elsif Is_Init_Proc (Curr) then + Obj_Ref := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (First_Formal (Curr), Loc), + Attribute_Name => Name_Address); + -- In case of protected subprograms the first formal of its -- Protected_Body_Subprogram is the object and we get its address. @@ -464,6 +490,7 @@ package body Exp_Attr is Typ : constant Entity_Id := Etype (N); Btyp : constant Entity_Id := Base_Type (Typ); Pref : constant Node_Id := Prefix (N); + Ptyp : constant Entity_Id := Etype (Pref); Exprs : constant List_Id := Expressions (N); Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); @@ -595,6 +622,19 @@ package body Exp_Attr is end; end if; + -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in- + -- place function, then a temporary return object needs to be created + -- and access to it must be passed to the function. Currently we limit + -- such functions to those with inherently limited result subtypes, but + -- eventually we plan to expand the functions that are treated as + -- build-in-place to include other composite result types. + + if Ada_Version >= Ada_05 + and then Is_Build_In_Place_Function_Call (Pref) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Pref); + end if; + -- Remaining processing depends on specific attribute case Id is @@ -620,111 +660,79 @@ package body Exp_Attr is if Id = Attribute_Unrestricted_Access and then Is_Subprogram (Directly_Designated_Type (Typ)) then - -- The following assertion ensures that this special management + -- The following conditions ensure that this special management -- is done only for "Address!(Prim'Unrestricted_Access)" nodes. -- At this stage other cases in which the designated type is -- still a subprogram (instead of an E_Subprogram_Type) are -- wrong because the semantics must have overridden the type of -- the node with the type imposed by the context. - pragma Assert (Nkind (Parent (N)) = N_Unchecked_Type_Conversion - and then Etype (Parent (N)) = RTE (RE_Address)); - - declare - Subp : constant Entity_Id := Directly_Designated_Type (Typ); - - Extra : Entity_Id := Empty; - New_Formal : Entity_Id; - Old_Formal : Entity_Id := First_Formal (Subp); - Subp_Typ : Entity_Id; + if Nkind (Parent (N)) = N_Unchecked_Type_Conversion + and then Etype (Parent (N)) = RTE (RE_Prim_Ptr) + then + Set_Etype (N, RTE (RE_Prim_Ptr)); - begin - Subp_Typ := Create_Itype (E_Subprogram_Type, N); - Set_Etype (Subp_Typ, Etype (Subp)); - Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); + else + declare + Subp : constant Entity_Id := + Directly_Designated_Type (Typ); + Etyp : Entity_Id; + Extra : Entity_Id := Empty; + New_Formal : Entity_Id; + Old_Formal : Entity_Id := First_Formal (Subp); + Subp_Typ : Entity_Id; - if Present (Old_Formal) then - New_Formal := New_Copy (Old_Formal); - Set_First_Entity (Subp_Typ, New_Formal); + begin + Subp_Typ := Create_Itype (E_Subprogram_Type, N); + Set_Etype (Subp_Typ, Etype (Subp)); + Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); - loop - Set_Scope (New_Formal, Subp_Typ); + if Present (Old_Formal) then + New_Formal := New_Copy (Old_Formal); + Set_First_Entity (Subp_Typ, New_Formal); - -- Handle itypes + loop + Set_Scope (New_Formal, Subp_Typ); + Etyp := Etype (New_Formal); - if Is_Itype (Etype (New_Formal)) then - Extra := New_Copy (Etype (New_Formal)); + -- Handle itypes. There is no need to duplicate + -- here the itypes associated with record types + -- (i.e the implicit full view of private types). - if Ekind (Extra) = E_Record_Subtype - or else Ekind (Extra) = E_Class_Wide_Subtype + if Is_Itype (Etyp) + and then Ekind (Base_Type (Etyp)) /= E_Record_Type then - Set_Cloned_Subtype (Extra, - Etype (New_Formal)); + Extra := New_Copy (Etyp); + Set_Parent (Extra, New_Formal); + Set_Etype (New_Formal, Extra); + Set_Scope (Extra, Subp_Typ); end if; - Set_Etype (New_Formal, Extra); - Set_Scope (Etype (New_Formal), Subp_Typ); - end if; - - Extra := New_Formal; - Next_Formal (Old_Formal); - exit when No (Old_Formal); - - Set_Next_Entity (New_Formal, - New_Copy (Old_Formal)); - Next_Entity (New_Formal); - end loop; + Extra := New_Formal; + Next_Formal (Old_Formal); + exit when No (Old_Formal); - Set_Next_Entity (New_Formal, Empty); - Set_Last_Entity (Subp_Typ, Extra); - end if; - - -- Now that the explicit formals have been duplicated, - -- any extra formals needed by the subprogram must be - -- created. - - if Present (Extra) then - Set_Extra_Formal (Extra, Empty); - end if; + Set_Next_Entity (New_Formal, + New_Copy (Old_Formal)); + Next_Entity (New_Formal); + end loop; - Create_Extra_Formals (Subp_Typ); - Set_Directly_Designated_Type (Typ, Subp_Typ); + Set_Next_Entity (New_Formal, Empty); + Set_Last_Entity (Subp_Typ, Extra); + end if; - -- Complete decoration of access-to-subprogram itype to - -- indicate to the backend that this itype corresponds to - -- a statically allocated dispatch table. + -- Now that the explicit formals have been duplicated, + -- any extra formals needed by the subprogram must be + -- created. - -- ??? more comments on structure here, three level parent - -- references are worrisome! + if Present (Extra) then + Set_Extra_Formal (Extra, Empty); + end if; - if Nkind (Ref_Object) in N_Has_Entity - and then Is_Dispatching_Operation (Entity (Ref_Object)) - and then Present (Parent (Parent (N))) - and then Nkind (Parent (Parent (N))) = N_Aggregate - and then Present (Parent (Parent (Parent (N)))) - then - declare - P : constant Node_Id := - Parent (Parent (Parent (N))); - Prim : constant Entity_Id := Entity (Ref_Object); - - begin - Set_Is_Static_Dispatch_Table_Entity (Typ, - (Is_Predefined_Dispatching_Operation (Prim) - and then Nkind (P) = N_Object_Declaration - and then Is_Static_Dispatch_Table_Entity - (Defining_Identifier (P))) - or else - (not Is_Predefined_Dispatching_Operation (Prim) - and then Nkind (P) = N_Aggregate - and then Present (Parent (P)) - and then Nkind (Parent (P)) - = N_Object_Declaration - and then Is_Static_Dispatch_Table_Entity - (Defining_Identifier (Parent (P))))); - end; - end if; - end; + Create_Extra_Formals (Subp_Typ); + Set_Directly_Designated_Type (Typ, Subp_Typ); + end; + end if; end if; if Is_Access_Protected_Subprogram_Type (Btyp) then @@ -897,12 +905,12 @@ package body Exp_Attr is if Is_Entity_Name (Pref) and then Is_Task_Type (Entity (Pref)) then - Task_Proc := Next_Entity (Root_Type (Etype (Pref))); + Task_Proc := Next_Entity (Root_Type (Ptyp)); while Present (Task_Proc) loop exit when Ekind (Task_Proc) = E_Procedure and then Etype (First_Formal (Task_Proc)) = - Corresponding_Record_Type (Etype (Pref)); + Corresponding_Record_Type (Ptyp); Next_Entity (Task_Proc); end loop; @@ -924,8 +932,8 @@ package body Exp_Attr is External_Subprogram (Entity (Selector_Name (Pref))), Loc)); elsif Nkind (Pref) = N_Explicit_Dereference - and then Ekind (Etype (Pref)) = E_Subprogram_Type - and then Convention (Etype (Pref)) = Convention_Protected + and then Ekind (Ptyp) = E_Subprogram_Type + and then Convention (Ptyp) = Convention_Protected then -- The prefix is be a dereference of an access_to_protected_ -- subprogram. The desired address is the second component of @@ -957,8 +965,8 @@ package body Exp_Attr is -- This processing is not needed in the VM case, where dispatching -- issues are taken care of by the virtual machine. - elsif Is_Class_Wide_Type (Etype (Pref)) - and then Is_Interface (Etype (Pref)) + elsif Is_Class_Wide_Type (Ptyp) + and then Is_Interface (Ptyp) and then VM_Target = No_VM and then not (Nkind (Pref) in N_Has_Entity and then Is_Subprogram (Entity (Pref))) @@ -972,7 +980,8 @@ package body Exp_Attr is return; end if; - -- Deal with packed array reference, other cases are handled by gigi + -- Deal with packed array reference, other cases are handled by + -- the back end. if Involves_Packed_Array_Reference (Pref) then Expand_Packed_Address_Reference (N); @@ -984,7 +993,6 @@ package body Exp_Attr is --------------- when Attribute_Alignment => Alignment : declare - Ptyp : constant Entity_Id := Etype (Pref); New_Node : Node_Id; begin @@ -1109,9 +1117,9 @@ package body Exp_Attr is -- Bit_Position -- ------------------ - -- We compute this if a component clause was present, otherwise - -- we leave the computation up to Gigi, since we don't know what - -- layout will be chosen. + -- We compute this if a component clause was present, otherwise we leave + -- the computation up to the back end, since we don't know what layout + -- will be chosen. -- Note that the attribute can apply to a naked record component -- in generated code (i.e. the prefix is an identifier that @@ -1278,9 +1286,9 @@ package body Exp_Attr is -- callable (Task_Id (Pref._disp_get_task_id)); if Ada_Version >= Ada_05 - and then Ekind (Etype (Pref)) = E_Class_Wide_Type - and then Is_Interface (Etype (Pref)) - and then Is_Task_Interface (Etype (Pref)) + and then Ekind (Ptyp) = E_Class_Wide_Type + and then Is_Interface (Ptyp) + and then Is_Task_Interface (Ptyp) then Rewrite (N, Make_Function_Call (Loc, @@ -1343,10 +1351,9 @@ package body Exp_Attr is Unchecked_Convert_To (Id_Kind, Make_Function_Call (Loc, Name => Name, - Parameter_Associations => New_List - (New_Reference_To ( - Object_Ref - (Corresponding_Body (Parent (Conctype))), Loc))))); + Parameter_Associations => New_List ( + New_Reference_To + (Find_Protection_Object (Current_Scope), Loc))))); -- Task case @@ -1376,8 +1383,8 @@ package body Exp_Attr is Rewrite (N, Unchecked_Convert_To (Id_Kind, Make_Function_Call (Loc, - Name => New_Reference_To ( - RTE (RE_Task_Entry_Caller), Loc), + Name => + New_Reference_To (RTE (RE_Task_Entry_Caller), Loc), Parameter_Associations => New_List ( Make_Integer_Literal (Loc, Intval => Int (Nest_Depth)))))); @@ -1408,7 +1415,6 @@ package body Exp_Attr is when Attribute_Constrained => Constrained : declare Formal_Ent : constant Entity_Id := Param_Entity (Pref); - Typ : constant Entity_Id := Etype (Pref); function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean; -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a @@ -1427,7 +1433,6 @@ package body Exp_Attr is if Present (Renamed_Object (E)) then return Is_Constrained_Aliased_View (Renamed_Object (E)); - else return Is_Aliased (E) and then Is_Constrained (Etype (E)); end if; @@ -1503,8 +1508,8 @@ package body Exp_Attr is end if; -- If the prefix is not a variable or is aliased, then - -- definitely true; if it's a formal parameter without - -- an associated extra formal, then treat it as constrained. + -- definitely true; if it's a formal parameter without an + -- associated extra formal, then treat it as constrained. -- Ada 2005 (AI-363): An aliased prefix must be known to be -- constrained in order to set the attribute to True. @@ -1518,10 +1523,9 @@ package body Exp_Attr is then Res := True; - -- Variable case, just look at type to see if it is - -- constrained. Note that the one case where this is - -- not accurate (the procedure formal case), has been - -- handled above. + -- Variable case, look at type to see if it is constrained. + -- Note that the one case where this is not accurate (the + -- procedure formal case), has been handled above. -- We use the Underlying_Type here (and below) in case the -- type is private without discriminants, but the full type @@ -1536,11 +1540,10 @@ package body Exp_Attr is New_Reference_To (Boolean_Literals (Res), Loc)); end; - -- Prefix is not an entity name. These are also cases where - -- we can always tell at compile time by looking at the form - -- and type of the prefix. If an explicit dereference of an - -- object with constrained partial view, this is unconstrained - -- (Ada 2005 AI-363). + -- Prefix is not an entity name. These are also cases where we can + -- always tell at compile time by looking at the form and type of the + -- prefix. If an explicit dereference of an object with constrained + -- partial view, this is unconstrained (Ada 2005 AI-363). else Rewrite (N, @@ -1550,8 +1553,8 @@ package body Exp_Attr is or else (Nkind (Pref) = N_Explicit_Dereference and then - not Has_Constrained_Partial_View (Base_Type (Typ))) - or else Is_Constrained (Underlying_Type (Typ))), + not Has_Constrained_Partial_View (Base_Type (Ptyp))) + or else Is_Constrained (Underlying_Type (Ptyp))), Loc)); end if; @@ -1574,13 +1577,13 @@ package body Exp_Attr is -- Transforms 'Count attribute into a call to the Count function - when Attribute_Count => Count : - declare - Entnam : Node_Id; - Index : Node_Id; - Name : Node_Id; - Call : Node_Id; - Conctyp : Entity_Id; + when Attribute_Count => Count : declare + Call : Node_Id; + Conctyp : Entity_Id; + Entnam : Node_Id; + Entry_Id : Entity_Id; + Index : Node_Id; + Name : Node_Id; begin -- If the prefix is a member of an entry family, retrieve both @@ -1594,6 +1597,8 @@ package body Exp_Attr is Index := Empty; end if; + Entry_Id := Entity (Entnam); + -- Find the concurrent type in which this attribute is referenced -- (there had better be one). @@ -1605,7 +1610,6 @@ package body Exp_Attr is -- Protected case if Is_Protected_Type (Conctyp) then - case Corresponding_Runtime_Package (Conctyp) is when System_Tasking_Protected_Objects_Entries => Name := New_Reference_To (RTE (RE_Protected_Count), Loc); @@ -1614,26 +1618,24 @@ package body Exp_Attr is Make_Function_Call (Loc, Name => Name, Parameter_Associations => New_List ( - New_Reference_To ( - Object_Ref ( - Corresponding_Body (Parent (Conctyp))), Loc), - Entry_Index_Expression (Loc, - Entity (Entnam), Index, Scope (Entity (Entnam))))); + New_Reference_To + (Find_Protection_Object (Current_Scope), Loc), + Entry_Index_Expression + (Loc, Entry_Id, Index, Scope (Entry_Id)))); when System_Tasking_Protected_Objects_Single_Entry => - Name := New_Reference_To - (RTE (RE_Protected_Count_Entry), Loc); + Name := + New_Reference_To (RTE (RE_Protected_Count_Entry), Loc); Call := Make_Function_Call (Loc, Name => Name, Parameter_Associations => New_List ( - New_Reference_To ( - Object_Ref ( - Corresponding_Body (Parent (Conctyp))), Loc))); + New_Reference_To + (Find_Protection_Object (Current_Scope), Loc))); + when others => raise Program_Error; - end case; -- Task case @@ -1643,8 +1645,8 @@ package body Exp_Attr is Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Task_Count), Loc), Parameter_Associations => New_List ( - Entry_Index_Expression - (Loc, Entity (Entnam), Index, Scope (Entity (Entnam))))); + Entry_Index_Expression (Loc, + Entry_Id, Index, Scope (Entry_Id)))); end if; -- The call returns type Natural but the context is universal integer @@ -1774,11 +1776,11 @@ package body Exp_Attr is -- Elaborated -- ---------------- - -- Elaborated is always True for preelaborated units, predefined - -- units, pure units and units which have Elaborate_Body pragmas. - -- These units have no elaboration entity. + -- Elaborated is always True for preelaborated units, predefined units, + -- pure units and units which have Elaborate_Body pragmas. These units + -- have no elaboration entity. - -- Note: The Elaborated attribute is never passed through to Gigi + -- Note: The Elaborated attribute is never passed to the back end when Attribute_Elaborated => Elaborated : declare Ent : constant Entity_Id := Entity (Pref); @@ -1802,12 +1804,12 @@ package body Exp_Attr is -- target-type (Y) - -- This is simply a direct conversion from the enumeration type - -- to the target integer type, which is treated by Gigi as a normal - -- integer conversion, treating the enumeration type as an integer, - -- which is exactly what we want! We set Conversion_OK to make sure - -- that the analyzer does not complain about what otherwise might - -- be an illegal conversion. + -- This is simply a direct conversion from the enumeration type to + -- the target integer type, which is treated by the back end as a + -- normal integer conversion, treating the enumeration type as an + -- integer, which is exactly what we want! We set Conversion_OK to + -- make sure that the analyzer does not complain about what otherwise + -- might be an illegal conversion. if Is_Non_Empty_List (Exprs) then Rewrite (N, @@ -1843,10 +1845,44 @@ package body Exp_Attr is Set_Etype (N, Typ); Analyze_And_Resolve (N, Typ); - end Enum_Rep; -------------- + -- Enum_Val -- + -------------- + + when Attribute_Enum_Val => Enum_Val : declare + Expr : Node_Id; + Btyp : constant Entity_Id := Base_Type (Ptyp); + + begin + -- X'Enum_Val (Y) expands to + + -- [constraint_error when _rep_to_pos (Y, False) = -1, msg] + -- X!(Y); + + Expr := Unchecked_Convert_To (Ptyp, First (Exprs)); + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Reference_To (TSS (Btyp, TSS_Rep_To_Pos), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Duplicate_Subexpr (Expr)), + New_Occurrence_Of (Standard_False, Loc))), + + Right_Opnd => Make_Integer_Literal (Loc, -1)), + Reason => CE_Range_Check_Failed)); + + Rewrite (N, Expr); + Analyze_And_Resolve (N, Ptyp); + end Enum_Val; + + -------------- -- Exponent -- -------------- @@ -1879,15 +1915,13 @@ package body Exp_Attr is -- First -- ----------- - when Attribute_First => declare - Ptyp : constant Entity_Id := Etype (Pref); + when Attribute_First => - begin -- If the prefix type is a constrained packed array type which -- already has a Packed_Array_Type representation defined, then -- replace this attribute with a direct reference to 'First of the - -- appropriate index subtype (since otherwise Gigi will try to give - -- us the value of 'First for this implementation type). + -- appropriate index subtype (since otherwise the back end will try + -- to give us the value of 'First for this implementation type). if Is_Constrained_Packed_Array (Ptyp) then Rewrite (N, @@ -1899,18 +1933,16 @@ package body Exp_Attr is elsif Is_Access_Type (Ptyp) then Apply_Access_Check (N); end if; - end; --------------- -- First_Bit -- --------------- - -- We compute this if a component clause was present, otherwise - -- we leave the computation up to Gigi, since we don't know what + -- Compute this if component clause was present, otherwise we leave the + -- computation to be completed in the back-end, since we don't know what -- layout will be chosen. - when Attribute_First_Bit => First_Bit : - declare + when Attribute_First_Bit => First_Bit : declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin @@ -1938,10 +1970,10 @@ package body Exp_Attr is -- fixtype(integer-value) - -- we do all the required analysis of the conversion here, because - -- we do not want this to go through the fixed-point conversion - -- circuits. Note that gigi always treats fixed-point as equivalent - -- to the corresponding integer type anyway. + -- We do all the required analysis of the conversion here, because we do + -- not want this to go through the fixed-point conversion circuits. Note + -- that the back end always treats fixed-point as equivalent to the + -- corresponding integer type anyway. when Attribute_Fixed_Value => Fixed_Value : begin @@ -1985,11 +2017,7 @@ package body Exp_Attr is -- Note that we know that the type is a non-static subtype, or Fore -- would have itself been computed dynamically in Eval_Attribute. - when Attribute_Fore => Fore : - declare - Ptyp : constant Entity_Id := Etype (Pref); - - begin + when Attribute_Fore => Fore : begin Rewrite (N, Convert_To (Typ, Make_Function_Call (Loc, @@ -2037,7 +2065,7 @@ package body Exp_Attr is Id_Kind : Entity_Id; begin - if Etype (Pref) = Standard_Exception_Type then + if Ptyp = Standard_Exception_Type then Id_Kind := RTE (RE_Exception_Id); if Present (Renamed_Object (Entity (Pref))) then @@ -2054,9 +2082,9 @@ package body Exp_Attr is -- attributes applied to interfaces. if Ada_Version >= Ada_05 - and then Ekind (Etype (Pref)) = E_Class_Wide_Type - and then Is_Interface (Etype (Pref)) - and then Is_Task_Interface (Etype (Pref)) + and then Ekind (Ptyp) = E_Class_Wide_Type + and then Is_Interface (Ptyp) + and then Is_Task_Interface (Ptyp) then Rewrite (N, Unchecked_Convert_To (Id_Kind, @@ -2094,7 +2122,7 @@ package body Exp_Attr is begin Rewrite (N, Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Etype (Pref), Loc), + Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Image, Expressions => New_List (Relocate_Node (Pref)))); @@ -2184,10 +2212,9 @@ package body Exp_Attr is -- sourcetyp (streamread (strmtyp'Input (stream))); - -- where stmrearead is the given Read function that converts - -- an argument of type strmtyp to type sourcetyp or a type - -- from which it is derived. The extra conversion is required - -- for the derived case. + -- where stmrearead is the given Read function that converts an + -- argument of type strmtyp to type sourcetyp or a type from which + -- it is derived (extra conversion required for the derived case). Prag := Get_Stream_Convert_Pragma (P_Type); @@ -2322,10 +2349,9 @@ package body Exp_Attr is pragma Assert (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type)); - -- Ada 2005 (AI-216): Program_Error is raised when executing - -- the default implementation of the Input attribute of an - -- unchecked union type if the type lacks default discriminant - -- values. + -- Ada 2005 (AI-216): Program_Error is raised executing default + -- implementation of the Input attribute of an unchecked union + -- type if the type lacks default discriminant values. if Is_Unchecked_Union (Base_Type (U_Type)) and then No (Discriminant_Constraint (U_Type)) @@ -2400,10 +2426,10 @@ package body Exp_Attr is -- inttype(integer-value)) - -- we do all the required analysis of the conversion here, because - -- we do not want this to go through the fixed-point conversion - -- circuits. Note that gigi always treats fixed-point as equivalent - -- to the corresponding integer type anyway. + -- we do all the required analysis of the conversion here, because we do + -- not want this to go through the fixed-point conversion circuits. Note + -- that the back end always treats fixed-point as equivalent to the + -- corresponding integer type anyway. when Attribute_Integer_Value => Integer_Value : begin @@ -2421,19 +2447,24 @@ package body Exp_Attr is Apply_Type_Conversion_Checks (N); end Integer_Value; + ------------------- + -- Invalid_Value -- + ------------------- + + when Attribute_Invalid_Value => + Rewrite (N, Get_Simple_Init_Val (Ptyp, N)); + ---------- -- Last -- ---------- - when Attribute_Last => declare - Ptyp : constant Entity_Id := Etype (Pref); + when Attribute_Last => - begin -- If the prefix type is a constrained packed array type which -- already has a Packed_Array_Type representation defined, then -- replace this attribute with a direct reference to 'Last of the - -- appropriate index subtype (since otherwise Gigi will try to give - -- us the value of 'Last for this implementation type). + -- appropriate index subtype (since otherwise the back end will try + -- to give us the value of 'Last for this implementation type). if Is_Constrained_Packed_Array (Ptyp) then Rewrite (N, @@ -2445,18 +2476,16 @@ package body Exp_Attr is elsif Is_Access_Type (Ptyp) then Apply_Access_Check (N); end if; - end; -------------- -- Last_Bit -- -------------- - -- We compute this if a component clause was present, otherwise - -- we leave the computation up to Gigi, since we don't know what - -- layout will be chosen. + -- We compute this if a component clause was present, otherwise we leave + -- the computation up to the back end, since we don't know what layout + -- will be chosen. - when Attribute_Last_Bit => Last_Bit : - declare + when Attribute_Last_Bit => Last_Bit : declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin @@ -2482,7 +2511,7 @@ package body Exp_Attr is -- Transforms 'Leading_Part into a call to the floating-point attribute -- function Leading_Part in Fat_xxx (where xxx is the root type) - -- Note: strictly, we should have special case code to deal with + -- Note: strictly, we should generate special case code to deal with -- absurdly large positive arguments (greater than Integer'Last), which -- result in returning the first argument unchanged, but it hardly seems -- worth the effort. We raise constraint error for absurdly negative @@ -2496,7 +2525,6 @@ package body Exp_Attr is ------------ when Attribute_Length => declare - Ptyp : constant Entity_Id := Etype (Pref); Ityp : Entity_Id; Xnum : Uint; @@ -2506,15 +2534,15 @@ package body Exp_Attr is if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then Ityp := Get_Index_Subtype (N); - -- If the index type, Ityp, is an enumeration type with - -- holes, then we calculate X'Length explicitly using + -- If the index type, Ityp, is an enumeration type with holes, + -- then we calculate X'Length explicitly using -- Typ'Max -- (0, Ityp'Pos (X'Last (N)) - -- Ityp'Pos (X'First (N)) + 1); - -- Since the bounds in the template are the representation - -- values and gigi would get the wrong value. + -- Since the bounds in the template are the representation values + -- and the back end would get the wrong value. if Is_Enumeration_Type (Ityp) and then Present (Enum_Pos_To_Rep (Base_Type (Ityp))) @@ -2568,8 +2596,9 @@ package body Exp_Attr is -- If the prefix type is a constrained packed array type which -- already has a Packed_Array_Type representation defined, then -- replace this attribute with a direct reference to 'Range_Length - -- of the appropriate index subtype (since otherwise Gigi will try - -- to give us the value of 'Length for this implementation type). + -- of the appropriate index subtype (since otherwise the back end + -- will try to give us the value of 'Length for this + -- implementation type). elsif Is_Constrained (Ptyp) then Rewrite (N, @@ -2579,23 +2608,21 @@ package body Exp_Attr is Analyze_And_Resolve (N, Typ); end if; - -- If we have a packed array that is not bit packed, which was - -- Access type case elsif Is_Access_Type (Ptyp) then Apply_Access_Check (N); - -- If the designated type is a packed array type, then we - -- convert the reference to: + -- If the designated type is a packed array type, then we convert + -- the reference to: -- typ'Max (0, 1 + -- xtyp'Pos (Pref'Last (Expr)) - -- xtyp'Pos (Pref'First (Expr))); - -- This is a bit complex, but it is the easiest thing to do - -- that works in all cases including enum types with holes - -- xtyp here is the appropriate index type. + -- This is a bit complex, but it is the easiest thing to do that + -- works in all cases including enum types with holes xtyp here + -- is the appropriate index type. declare Dtyp : constant Entity_Id := Designated_Type (Ptyp); @@ -2642,7 +2669,7 @@ package body Exp_Attr is end if; end; - -- Otherwise leave it to gigi + -- Otherwise leave it to the back end else Apply_Universal_Integer_Attribute_Checks (N); @@ -2678,7 +2705,7 @@ package body Exp_Attr is ------------------ -- Machine_Size is equivalent to Object_Size, so transform it into - -- Object_Size and that way Gigi never sees Machine_Size. + -- Object_Size and that way the back end never sees Machine_Size. when Attribute_Machine_Size => Rewrite (N, @@ -2693,8 +2720,8 @@ package body Exp_Attr is -------------- -- The only case that can get this far is the dynamic case of the old - -- Ada 83 Mantissa attribute for the fixed-point case. For this case, we - -- expand: + -- Ada 83 Mantissa attribute for the fixed-point case. For this case, + -- we expand: -- typ'Mantissa @@ -2704,10 +2731,7 @@ package body Exp_Attr is -- (Integer'Integer_Value (typ'First), -- Integer'Integer_Value (typ'Last))); - when Attribute_Mantissa => Mantissa : declare - Ptyp : constant Entity_Id := Etype (Pref); - - begin + when Attribute_Mantissa => Mantissa : begin Rewrite (N, Convert_To (Typ, Make_Function_Call (Loc, @@ -2860,12 +2884,17 @@ package body Exp_Attr is Asn_Stm : Node_Id; begin + -- Find the nearest subprogram body, ignoring _Preconditions + Subp := N; loop Subp := Parent (Subp); - exit when Nkind (Subp) = N_Subprogram_Body; + exit when Nkind (Subp) = N_Subprogram_Body + and then Chars (Defining_Entity (Subp)) /= Name_uPostconditions; end loop; + -- Insert the assignment at the start of the declarations + Asn_Stm := Make_Object_Declaration (Loc, Defining_Identifier => Tnn, @@ -3098,7 +3127,7 @@ package body Exp_Attr is --------- -- For enumeration types with a standard representation, Pos is - -- handled by Gigi. + -- handled by the back end. -- For enumeration types, with a non-standard representation we -- generate a call to the _Rep_To_Pos function created when the @@ -3162,9 +3191,9 @@ package body Exp_Attr is -- Position -- -------------- - -- We compute this if a component clause was present, otherwise - -- we leave the computation up to Gigi, since we don't know what - -- layout will be chosen. + -- We compute this if a component clause was present, otherwise we leave + -- the computation up to the back end, since we don't know what layout + -- will be chosen. when Attribute_Position => Position : declare @@ -3192,9 +3221,10 @@ package body Exp_Attr is when Attribute_Pred => Pred : declare - Ptyp : constant Entity_Id := Base_Type (Etype (Pref)); + Etyp : constant Entity_Id := Base_Type (Ptyp); begin + -- For enumeration types with non-standard representations, we -- expand typ'Pred (x) into @@ -3202,11 +3232,14 @@ package body Exp_Attr is -- If the representation is contiguous, we compute instead -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations. + -- The conversion function Enum_Pos_To_Rep is defined on the + -- base type, not the subtype, so we have to use the base type + -- explicitly for this and other enumeration attributes. if Is_Enumeration_Type (Ptyp) - and then Present (Enum_Pos_To_Rep (Ptyp)) + and then Present (Enum_Pos_To_Rep (Etyp)) then - if Has_Contiguous_Rep (Ptyp) then + if Has_Contiguous_Rep (Etyp) then Rewrite (N, Unchecked_Convert_To (Ptyp, Make_Op_Add (Loc, @@ -3217,7 +3250,7 @@ package body Exp_Attr is Make_Function_Call (Loc, Name => New_Reference_To - (TSS (Ptyp, TSS_Rep_To_Pos), Loc), + (TSS (Etyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => New_List ( @@ -3238,13 +3271,16 @@ package body Exp_Attr is Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); Rewrite (N, Make_Indexed_Component (Loc, - Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc), + Prefix => + New_Reference_To + (Enum_Pos_To_Rep (Etyp), Loc), Expressions => New_List ( Make_Op_Subtract (Loc, Left_Opnd => Make_Function_Call (Loc, Name => - New_Reference_To (TSS (Ptyp, TSS_Rep_To_Pos), Loc), + New_Reference_To + (TSS (Etyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => Exprs), Right_Opnd => Make_Integer_Literal (Loc, 1))))); end if; @@ -3333,8 +3369,6 @@ package body Exp_Attr is New_Itype := Create_Itype (E_Access_Type, N); Set_Etype (New_Itype, New_Itype); - Init_Esize (New_Itype); - Init_Size_Align (New_Itype); Set_Directly_Designated_Type (New_Itype, Corresponding_Record_Type (Conctyp)); Freeze_Itype (New_Itype, N); @@ -3400,10 +3434,7 @@ package body Exp_Attr is -- Range_Length -- ------------------ - when Attribute_Range_Length => Range_Length : declare - P_Type : constant Entity_Id := Etype (Pref); - - begin + when Attribute_Range_Length => Range_Length : begin -- The only special processing required is for the case where -- Range_Length is applied to an enumeration type with holes. -- In this case we transform @@ -3417,8 +3448,8 @@ package body Exp_Attr is -- So that the result reflects the proper Pos values instead -- of the underlying representations. - if Is_Enumeration_Type (P_Type) - and then Has_Non_Standard_Rep (P_Type) + if Is_Enumeration_Type (Ptyp) + and then Has_Non_Standard_Rep (Ptyp) then Rewrite (N, Make_Op_Add (Loc, @@ -3427,28 +3458,29 @@ package body Exp_Attr is Left_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Pos, - Prefix => New_Occurrence_Of (P_Type, Loc), + Prefix => New_Occurrence_Of (Ptyp, Loc), Expressions => New_List ( Make_Attribute_Reference (Loc, Attribute_Name => Name_Last, - Prefix => New_Occurrence_Of (P_Type, Loc)))), + Prefix => New_Occurrence_Of (Ptyp, Loc)))), Right_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Pos, - Prefix => New_Occurrence_Of (P_Type, Loc), + Prefix => New_Occurrence_Of (Ptyp, Loc), Expressions => New_List ( Make_Attribute_Reference (Loc, Attribute_Name => Name_First, - Prefix => New_Occurrence_Of (P_Type, Loc))))), + Prefix => New_Occurrence_Of (Ptyp, Loc))))), Right_Opnd => Make_Integer_Literal (Loc, 1))); Analyze_And_Resolve (N, Typ); - -- For all other cases, attribute is handled by Gigi, but we need - -- to deal with the case of the range check on a universal integer. + -- For all other cases, the attribute is handled by the back end, but + -- we need to deal with the case of the range check on a universal + -- integer. else Apply_Universal_Integer_Attribute_Checks (N); @@ -3631,6 +3663,20 @@ package body Exp_Attr is when Attribute_Remainder => Expand_Fpt_Attribute_RR (N); + ------------ + -- Result -- + ------------ + + -- Transform 'Result into reference to _Result formal. At the point + -- where a legal 'Result attribute is expanded, we know that we are in + -- the context of a _Postcondition function with a _Result parameter. + + when Attribute_Result => + Rewrite (N, + Make_Identifier (Loc, + Chars => Name_uResult)); + Analyze_And_Resolve (N, Typ); + ----------- -- Round -- ----------- @@ -3705,7 +3751,6 @@ package body Exp_Attr is Attribute_VADS_Size => Size : declare - Ptyp : constant Entity_Id := Etype (Pref); Siz : Uint; New_Node : Node_Id; @@ -3751,19 +3796,16 @@ package body Exp_Attr is else if (not Is_Entity_Name (Pref) or else not Is_Type (Entity (Pref))) - and then (Is_Scalar_Type (Etype (Pref)) - or else Is_Constrained (Etype (Pref))) + and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp)) then - Rewrite (Pref, New_Occurrence_Of (Etype (Pref), Loc)); + Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc)); end if; -- For a scalar type for which no size was explicitly given, -- VADS_Size means Object_Size. This is the other respect in -- which VADS_Size differs from Size. - if Is_Scalar_Type (Etype (Pref)) - and then No (Size_Clause (Etype (Pref))) - then + if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then Set_Attribute_Name (N, Name_Object_Size); -- In all other cases, Size and VADS_Size are the sane @@ -3774,9 +3816,9 @@ package body Exp_Attr is end if; end if; - -- For class-wide types, X'Class'Size is transformed into a - -- direct reference to the Size of the class type, so that gigi - -- does not have to deal with the X'Class'Size reference. + -- For class-wide types, X'Class'Size is transformed into a direct + -- reference to the Size of the class type, so that the back end does + -- not have to deal with the X'Class'Size reference. if Is_Entity_Name (Pref) and then Is_Class_Wide_Type (Entity (Pref)) @@ -3873,7 +3915,7 @@ package body Exp_Attr is end if; end; - -- All other cases are handled by Gigi + -- All other cases are handled by the back end else Apply_Universal_Integer_Attribute_Checks (N); @@ -3883,8 +3925,8 @@ package body Exp_Attr is if Is_Entity_Name (Pref) and then Is_Formal (Entity (Pref)) - and then Is_Array_Type (Etype (Pref)) - and then Is_Packed (Etype (Pref)) + and then Is_Array_Type (Ptyp) + and then Is_Packed (Ptyp) then Rewrite (N, Make_Attribute_Reference (Loc, @@ -3895,13 +3937,13 @@ package body Exp_Attr is end if; -- If Size applies to a dereference of an access to unconstrained - -- packed array, GIGI needs to see its unconstrained nominal type, - -- but also a hint to the actual constrained type. + -- packed array, the back end needs to see its unconstrained + -- nominal type, but also a hint to the actual constrained type. if Nkind (Pref) = N_Explicit_Dereference - and then Is_Array_Type (Etype (Pref)) - and then not Is_Constrained (Etype (Pref)) - and then Is_Packed (Etype (Pref)) + and then Is_Array_Type (Ptyp) + and then not Is_Constrained (Ptyp) + and then Is_Packed (Ptyp) then Set_Actual_Designated_Subtype (Pref, Get_Actual_Subtype (Pref)); @@ -3954,11 +3996,8 @@ package body Exp_Attr is -- Storage_Size -- ------------------ - when Attribute_Storage_Size => Storage_Size : - declare - Ptyp : constant Entity_Id := Etype (Pref); + when Attribute_Storage_Size => Storage_Size : begin - begin -- Access type case, always go to the root type -- The case of access types results in a value of zero for the case @@ -4086,7 +4125,6 @@ package body Exp_Attr is ----------------- when Attribute_Stream_Size => Stream_Size : declare - Ptyp : constant Entity_Id := Etype (Pref); Size : Int; begin @@ -4115,9 +4153,10 @@ package body Exp_Attr is when Attribute_Succ => Succ : declare - Ptyp : constant Entity_Id := Base_Type (Etype (Pref)); + Etyp : constant Entity_Id := Base_Type (Ptyp); begin + -- For enumeration types with non-standard representations, we -- expand typ'Succ (x) into @@ -4127,9 +4166,9 @@ package body Exp_Attr is -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations. if Is_Enumeration_Type (Ptyp) - and then Present (Enum_Pos_To_Rep (Ptyp)) + and then Present (Enum_Pos_To_Rep (Etyp)) then - if Has_Contiguous_Rep (Ptyp) then + if Has_Contiguous_Rep (Etyp) then Rewrite (N, Unchecked_Convert_To (Ptyp, Make_Op_Add (Loc, @@ -4140,7 +4179,7 @@ package body Exp_Attr is Make_Function_Call (Loc, Name => New_Reference_To - (TSS (Ptyp, TSS_Rep_To_Pos), Loc), + (TSS (Etyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => New_List ( @@ -4160,14 +4199,16 @@ package body Exp_Attr is Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc)); Rewrite (N, Make_Indexed_Component (Loc, - Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc), + Prefix => + New_Reference_To + (Enum_Pos_To_Rep (Etyp), Loc), Expressions => New_List ( Make_Op_Add (Loc, Left_Opnd => Make_Function_Call (Loc, Name => New_Reference_To - (TSS (Ptyp, TSS_Rep_To_Pos), Loc), + (TSS (Etyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => Exprs), Right_Opnd => Make_Integer_Literal (Loc, 1))))); end if; @@ -4210,7 +4251,7 @@ package body Exp_Attr is Ttyp := Entity (Pref); Prefix_Is_Type := True; else - Ttyp := Etype (Pref); + Ttyp := Ptyp; Prefix_Is_Type := False; end if; @@ -4284,9 +4325,9 @@ package body Exp_Attr is -- terminated (Task_Id (Pref._disp_get_task_id)); if Ada_Version >= Ada_05 - and then Ekind (Etype (Pref)) = E_Class_Wide_Type - and then Is_Interface (Etype (Pref)) - and then Is_Task_Interface (Etype (Pref)) + and then Ekind (Ptyp) = E_Class_Wide_Type + and then Is_Interface (Ptyp) + and then Is_Task_Interface (Ptyp) then Rewrite (N, Make_Function_Call (Loc, @@ -4410,8 +4451,8 @@ package body Exp_Attr is --------- -- For enumeration types with a standard representation, and for all - -- other types, Val is handled by Gigi. For enumeration types with - -- a non-standard representation we use the _Pos_To_Rep array that + -- other types, Val is handled by the back end. For enumeration types + -- with a non-standard representation we use the _Pos_To_Rep array that -- was created when the type was frozen. when Attribute_Val => Val : @@ -4473,8 +4514,7 @@ package body Exp_Attr is when Attribute_Valid => Valid : declare - Ptyp : constant Entity_Id := Etype (Pref); - Btyp : Entity_Id := Base_Type (Ptyp); + Btyp : Entity_Id := Base_Type (Ptyp); Tst : Node_Id; Save_Validity_Checks_On : constant Boolean := Validity_Checks_On; @@ -4555,7 +4595,7 @@ package body Exp_Attr is -- Non VAX float case else - Find_Fat_Info (Etype (Pref), Ftp, Pkg); + Find_Fat_Info (Ptyp, Ftp, Pkg); -- If the floating-point object might be unaligned, we need -- to call the special routine Unaligned_Valid, which makes @@ -5029,11 +5069,11 @@ package body Exp_Attr is Rewrite_Stream_Proc_Call (Pname); end Write; - -- Component_Size is handled by Gigi, unless the component size is known - -- at compile time, which is always true in the packed array case. It is - -- important that the packed array case is handled in the front end (see - -- Eval_Attribute) since Gigi would otherwise get confused by the - -- equivalent packed array type. + -- Component_Size is handled by the back end, unless the component size + -- is known at compile time, which is always true in the packed array + -- case. It is important that the packed array case is handled in the + -- front end (see Eval_Attribute) since the back end would otherwise get + -- confused by the equivalent packed array type. when Attribute_Component_Size => null; @@ -5053,7 +5093,7 @@ package body Exp_Attr is -- static cases have already been evaluated during semantic processing, -- but in any case the back end should not count on this). - -- Gigi also handles the non-class-wide cases of Size + -- The back end also handles the non-class-wide cases of Size when Attribute_Bit_Order | Attribute_Code_Address | @@ -5063,8 +5103,8 @@ package body Exp_Attr is Attribute_Pool_Address => null; - -- The following attributes are also handled by Gigi, but return a - -- universal integer result, so may need a conversion for checking + -- The following attributes are also handled by the back end, but return + -- a universal integer result, so may need a conversion for checking -- that the result is in range. when Attribute_Aft | @@ -5091,6 +5131,7 @@ package body Exp_Attr is Attribute_Fast_Math | Attribute_Has_Access_Values | Attribute_Has_Discriminants | + Attribute_Has_Tagged_Values | Attribute_Large | Attribute_Machine_Emax | Attribute_Machine_Emin | @@ -5126,8 +5167,8 @@ package body Exp_Attr is raise Program_Error; -- The Asm_Input and Asm_Output attributes are not expanded at this - -- stage, but will be eliminated in the expansion of the Asm call, - -- see Exp_Intr for details. So Gigi will never see these either. + -- stage, but will be eliminated in the expansion of the Asm call, see + -- Exp_Intr for details. So the back end will never see these either. when Attribute_Asm_Input | Attribute_Asm_Output => @@ -5274,11 +5315,79 @@ package body Exp_Attr is Nam : TSS_Name_Type) return Entity_Id is Ent : constant Entity_Id := TSS (Typ, Nam); + begin if Present (Ent) then return Ent; end if; + -- Stream attributes for strings are expanded into library calls. The + -- following checks are disabled when the run-time is not available or + -- when compiling predefined types due to bootstrap issues. As a result, + -- the compiler will generate in-place stream routines for string types + -- that appear in GNAT's library, but will generate calls via rtsfind + -- to library routines for user code. + -- ??? For now, disable this code for JVM, since this generates a + -- VerifyError exception at run-time on e.g. c330001. + -- This is disabled for AAMP, to avoid making dependences on files not + -- supported in the AAMP library (such as s-fileio.adb). + + if VM_Target /= JVM_Target + and then not AAMP_On_Target + and then + not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) + then + + -- String as defined in package Ada + + if Typ = Standard_String then + if Nam = TSS_Stream_Input then + return RTE (RE_String_Input); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_String_Output); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_String_Read); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_String_Write); + end if; + + -- Wide_String as defined in package Ada + + elsif Typ = Standard_Wide_String then + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_String_Input); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_String_Output); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_String_Read); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_String_Write); + end if; + + -- Wide_Wide_String as defined in package Ada + + elsif Typ = Standard_Wide_Wide_String then + if Nam = TSS_Stream_Input then + return RTE (RE_Wide_Wide_String_Input); + + elsif Nam = TSS_Stream_Output then + return RTE (RE_Wide_Wide_String_Output); + + elsif Nam = TSS_Stream_Read then + return RTE (RE_Wide_Wide_String_Read); + + else pragma Assert (Nam = TSS_Stream_Write); + return RTE (RE_Wide_Wide_String_Write); + end if; + end if; + end if; + if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index dbe3ebe..ac35901 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -1463,6 +1463,7 @@ package body Exp_Ch11 is Id : Entity_Id := Entity (Name (N)); begin + Name_Len := 0; Build_Location_String (Loc); -- If the exception is a renaming, use the exception that it diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 24e7a7f..68965c7 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -109,9 +109,8 @@ package body Exp_Ch5 is -- statements. procedure Expand_Simple_Function_Return (N : Node_Id); - -- Expand simple return from function. Called by - -- Expand_N_Simple_Return_Statement in case we're returning from a function - -- body. + -- Expand simple return from function. In the case where we are returning + -- from a function body this is called by Expand_N_Simple_Return_Statement. function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id; -- Generate the necessary code for controlled and tagged assignment, @@ -3207,54 +3206,59 @@ package body Exp_Ch5 is -- return not (expression); - if Nkind (N) = N_If_Statement - and then No (Elsif_Parts (N)) - and then Present (Else_Statements (N)) - and then List_Length (Then_Statements (N)) = 1 - and then List_Length (Else_Statements (N)) = 1 - then - declare - Then_Stm : constant Node_Id := First (Then_Statements (N)); - Else_Stm : constant Node_Id := First (Else_Statements (N)); + -- Only do these optimizations if we are at least at -O1 level - begin - if Nkind (Then_Stm) = N_Simple_Return_Statement - and then - Nkind (Else_Stm) = N_Simple_Return_Statement - then - declare - Then_Expr : constant Node_Id := Expression (Then_Stm); - Else_Expr : constant Node_Id := Expression (Else_Stm); + if Optimization_Level > 0 then + if Nkind (N) = N_If_Statement + and then No (Elsif_Parts (N)) + and then Present (Else_Statements (N)) + and then List_Length (Then_Statements (N)) = 1 + and then List_Length (Else_Statements (N)) = 1 + then + declare + Then_Stm : constant Node_Id := First (Then_Statements (N)); + Else_Stm : constant Node_Id := First (Else_Statements (N)); - begin - if Nkind (Then_Expr) = N_Identifier - and then - Nkind (Else_Expr) = N_Identifier - then - if Entity (Then_Expr) = Standard_True - and then Entity (Else_Expr) = Standard_False - then - Rewrite (N, - Make_Simple_Return_Statement (Loc, - Expression => Relocate_Node (Condition (N)))); - Analyze (N); - return; - - elsif Entity (Then_Expr) = Standard_False - and then Entity (Else_Expr) = Standard_True + begin + if Nkind (Then_Stm) = N_Simple_Return_Statement + and then + Nkind (Else_Stm) = N_Simple_Return_Statement + then + declare + Then_Expr : constant Node_Id := Expression (Then_Stm); + Else_Expr : constant Node_Id := Expression (Else_Stm); + + begin + if Nkind (Then_Expr) = N_Identifier + and then + Nkind (Else_Expr) = N_Identifier then - Rewrite (N, - Make_Simple_Return_Statement (Loc, - Expression => - Make_Op_Not (Loc, - Right_Opnd => Relocate_Node (Condition (N))))); - Analyze (N); - return; + if Entity (Then_Expr) = Standard_True + and then Entity (Else_Expr) = Standard_False + then + Rewrite (N, + Make_Simple_Return_Statement (Loc, + Expression => Relocate_Node (Condition (N)))); + Analyze (N); + return; + + elsif Entity (Then_Expr) = Standard_False + and then Entity (Else_Expr) = Standard_True + then + Rewrite (N, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Op_Not (Loc, + Right_Opnd => + Relocate_Node (Condition (N))))); + Analyze (N); + return; + end if; end if; - end if; - end; - end if; - end; + end; + end if; + end; + end if; end if; end Expand_N_If_Statement; @@ -3463,6 +3467,15 @@ package body Exp_Ch5 is procedure Expand_N_Simple_Return_Statement (N : Node_Id) is begin + -- Defend agains previous errors (ie. the return statement calls a + -- function that is not available in configurable runtime). + + if Present (Expression (N)) + and then Nkind (Expression (N)) = N_Empty + then + return; + end if; + -- Distinguish the function and non-function cases: case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is @@ -3504,6 +3517,16 @@ package body Exp_Ch5 is Lab_Node : Node_Id; begin + -- Call postconditions procedure if procedure with active postconditions + + if Ekind (Scope_Id) = E_Procedure + and then Has_Postconditions (Scope_Id) + then + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => Make_Identifier (Loc, Name_uPostconditions))); + end if; + -- If it is a return from a procedure do no extra steps if Kind = E_Procedure or else Kind = E_Generic_Procedure then @@ -3572,16 +3595,15 @@ package body Exp_Ch5 is elsif Is_Protected_Type (Scope_Id) then Call := Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To - (RTE (RE_Complete_Entry_Body), Loc), - Parameter_Associations => New_List - (Make_Attribute_Reference (Loc, + Name => + New_Reference_To (RTE (RE_Complete_Entry_Body), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, Prefix => New_Reference_To - (Object_Ref - (Corresponding_Body (Parent (Scope_Id))), - Loc), - Attribute_Name => Name_Unchecked_Access))); + (Find_Protection_Object (Current_Scope), Loc), + Attribute_Name => + Name_Unchecked_Access))); Insert_Before (N, Call); Analyze (Call); @@ -3614,28 +3636,30 @@ package body Exp_Ch5 is -- The type of the expression (not necessarily the same as R_Type) begin - -- We rewrite "return <expression>;" to be: + -- For the case of a simple return that does not come from an extended + -- return, in the case of Ada 2005 where we are returning a limited + -- type, we rewrite "return <expression>;" to be: -- return _anon_ : <return_subtype> := <expression> -- The expansion produced by Expand_N_Extended_Return_Statement will -- contain simple return statements (for example, a block containing -- simple return of the return object), which brings us back here with - -- Comes_From_Extended_Return_Statement set. To avoid infinite - -- recursion, we do not transform into an extended return if - -- Comes_From_Extended_Return_Statement is True. + -- Comes_From_Extended_Return_Statement set. The reason for the barrier + -- checking for a simple return that does not come from an extended + -- return is to avoid this infinite recursion. -- The reason for this design is that for Ada 2005 limited returns, we -- need to reify the return object, so we can build it "in place", and -- we need a block statement to hang finalization and tasking stuff. -- ??? In order to avoid disruption, we avoid translating to extended - -- return except in the cases where we really need to (Ada 2005 - -- inherently limited). We would prefer eventually to do this - -- translation in all cases except perhaps for the case of Ada 95 - -- inherently limited, in order to fully exercise the code in - -- Expand_N_Extended_Return_Statement, and in order to do - -- build-in-place for efficiency when it is not required. + -- return except in the cases where we really need to (Ada 2005 for + -- inherently limited). We might prefer to do this translation in all + -- cases (except perhaps for the case of Ada 95 inherently limited), + -- in order to fully exercise the Expand_N_Extended_Return_Statement + -- code. This would also allow us to to the build-in-place optimization + -- for efficiency even in cases where it is semantically not required. -- As before, we check the type of the return expression rather than the -- return type of the function, because the latter may be a limited @@ -3644,7 +3668,7 @@ package body Exp_Ch5 is if not Comes_From_Extended_Return_Statement (N) and then Is_Inherently_Limited_Type (Etype (Expression (N))) - and then Ada_Version >= Ada_05 -- ??? + and then Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L then declare @@ -3845,7 +3869,7 @@ package body Exp_Ch5 is -- secondary stack. else - Set_Storage_Pool (N, RTE (RE_SS_Pool)); + Set_Storage_Pool (N, RTE (RE_SS_Pool)); -- If we are generating code for the VM do not use -- SS_Allocate since everything is heap-allocated anyway. @@ -3987,6 +4011,113 @@ package body Exp_Ch5 is Reason => PE_Accessibility_Check_Failed)); end; end if; + + -- Generate call to postcondition checks if they are present + + if Ekind (Scope_Id) = E_Function + and then Has_Postconditions (Scope_Id) + then + -- We are going to reference the returned value twice in this case, + -- once in the call to _Postconditions, and once in the actual return + -- statement, but we can't have side effects happening twice, and in + -- any case for efficiency we don't want to do the computation twice. + + -- If the returned expression is an entity name, we don't need to + -- worry since it is efficient and safe to reference it twice, that's + -- also true for literals other than string literals, and for the + -- case of X.all where X is an entity name. + + if Is_Entity_Name (Exp) + or else Nkind_In (Exp, N_Character_Literal, + N_Integer_Literal, + N_Real_Literal) + or else (Nkind (Exp) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Exp))) + then + null; + + -- Otherwise we are going to need a temporary to capture the value + + else + declare + Tnn : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('T')); + + begin + -- For a complex expression of an elementary type, capture + -- value in the temporary and use it as the reference. + + if Is_Elementary_Type (R_Type) then + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (R_Type, Loc), + Expression => Relocate_Node (Exp)), + Suppress => All_Checks); + + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + + -- If we have something we can rename, generate a renaming of + -- the object and replace the expression with a reference + + elsif Is_Object_Reference (Exp) then + Insert_Action (Exp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Tnn, + Subtype_Mark => New_Occurrence_Of (R_Type, Loc), + Name => Relocate_Node (Exp)), + Suppress => All_Checks); + + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + + -- Otherwise we have something like a string literal or an + -- aggregate. We could copy the value, but that would be + -- inefficient. Instead we make a reference to the value and + -- capture this reference with a renaming, the expression is + -- then replaced by a dereference of this renaming. + + else + -- For now, copy the value, since the code below does not + -- seem to work correctly ??? + + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (R_Type, Loc), + Expression => Relocate_Node (Exp)), + Suppress => All_Checks); + + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + + -- Insert_Action (Exp, + -- Make_Object_Renaming_Declaration (Loc, + -- Defining_Identifier => Tnn, + -- Access_Definition => + -- Make_Access_Definition (Loc, + -- All_Present => True, + -- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)), + -- Name => + -- Make_Reference (Loc, + -- Prefix => Relocate_Node (Exp))), + -- Suppress => All_Checks); + + -- Rewrite (Exp, + -- Make_Explicit_Dereference (Loc, + -- Prefix => New_Occurrence_Of (Tnn, Loc))); + end if; + end; + end if; + + -- Generate call to _postconditions + + Insert_Action (Exp, + Make_Procedure_Call_Statement (Loc, + Name => Make_Identifier (Loc, Name_uPostconditions), + Parameter_Associations => New_List (Duplicate_Subexpr (Exp)))); + end if; end Expand_Simple_Function_Return; ------------------------------ diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 49cdfe0..6f29b37 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -659,6 +659,8 @@ package body Exp_Intr is -- String cases else + Name_Len := 0; + case Nam is when Name_File => Get_Decoded_Name_String @@ -668,12 +670,10 @@ package body Exp_Intr is Build_Location_String (Loc); when Name_Enclosing_Entity => - Name_Len := 0; - - Ent := Current_Scope; -- Skip enclosing blocks to reach enclosing unit + Ent := Current_Scope; while Present (Ent) loop exit when Ekind (Ent) /= E_Block and then Ekind (Ent) /= E_Loop; @@ -682,7 +682,6 @@ package body Exp_Intr is -- Ent now points to the relevant defining entity - Name_Len := 0; Write_Entity_Name (Ent); when others => @@ -690,7 +689,8 @@ package body Exp_Intr is end case; Rewrite (N, - Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); Analyze_And_Resolve (N, Standard_String); end if; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 3da72eb..3cb421b 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -40,7 +40,6 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; -with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -60,16 +59,18 @@ package body Exp_Prag is function Arg1 (N : Node_Id) return Node_Id; function Arg2 (N : Node_Id) return Node_Id; + function Arg3 (N : Node_Id) return Node_Id; -- Obtain specified pragma argument expression procedure Expand_Pragma_Abort_Defer (N : Node_Id); - procedure Expand_Pragma_Assert (N : Node_Id); + procedure Expand_Pragma_Check (N : Node_Id); procedure Expand_Pragma_Common_Object (N : Node_Id); procedure Expand_Pragma_Import_Or_Interface (N : Node_Id); procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); procedure Expand_Pragma_Psect_Object (N : Node_Id); + procedure Expand_Pragma_Relative_Deadline (N : Node_Id); ---------- -- Arg1 -- @@ -93,9 +94,11 @@ package body Exp_Prag is function Arg2 (N : Node_Id) return Node_Id is Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + begin if No (Arg1) then return Empty; + else declare Arg : constant Node_Id := Next (Arg1); @@ -111,6 +114,39 @@ package body Exp_Prag is end if; end Arg2; + ---------- + -- Arg3 -- + ---------- + + function Arg3 (N : Node_Id) return Node_Id is + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + + begin + if No (Arg1) then + return Empty; + + else + declare + Arg : Node_Id := Next (Arg1); + begin + if No (Arg) then + return Empty; + + else + Next (Arg); + + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + return Expression (Arg); + else + return Arg; + end if; + end if; + end; + end if; + end Arg3; + --------------------- -- Expand_N_Pragma -- --------------------- @@ -130,8 +166,8 @@ package body Exp_Prag is when Pragma_Abort_Defer => Expand_Pragma_Abort_Defer (N); - when Pragma_Assert => - Expand_Pragma_Assert (N); + when Pragma_Check => + Expand_Pragma_Check (N); when Pragma_Common_Object => Expand_Pragma_Common_Object (N); @@ -157,6 +193,9 @@ package body Exp_Prag is when Pragma_Psect_Object => Expand_Pragma_Psect_Object (N); + when Pragma_Relative_Deadline => + Expand_Pragma_Relative_Deadline (N); + -- All other pragmas need no expander action when others => null; @@ -227,25 +266,25 @@ package body Exp_Prag is end Expand_Pragma_Abort_Defer; -------------------------- - -- Expand_Pragma_Assert -- + -- Expand_Pragma_Check -- -------------------------- - procedure Expand_Pragma_Assert (N : Node_Id) is + procedure Expand_Pragma_Check (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Cond : constant Node_Id := Arg1 (N); - Msg : String_Id; + Cond : constant Node_Id := Arg2 (N); + Nam : constant Name_Id := Chars (Arg1 (N)); + Msg : Node_Id; begin - -- We already know that assertions are enabled, because otherwise - -- the semantic pass dealt with rewriting the assertion (see Sem_Prag) - - pragma Assert (Assertions_Enabled); + -- We already know that this check is enabled, because otherwise the + -- semantic pass dealt with rewriting the assertion (see Sem_Prag) - -- Since assertions are on, we rewrite the pragma with its + -- Since this check is enabled, we rewrite the pragma into a -- corresponding if statement, and then analyze the statement + -- The normal case expansion transforms: - -- pragma Assert (condition [,message]); + -- pragma Check (name, condition [,message]); -- into @@ -254,7 +293,9 @@ package body Exp_Prag is -- end if; -- where Str is the message if one is present, or the default of - -- file:line if no message is given. + -- name failed at file:line if no message is given (the "name failed + -- at" is omitted for name = Assertion, since it is redundant, given + -- that the name of the exception is Assert_Failure. -- An alternative expansion is used when the No_Exception_Propagation -- restriction is active and there is a local Assert_Failure handler. @@ -281,7 +322,7 @@ package body Exp_Prag is -- Case where we generate a direct raise if (Debug_Flag_Dot_G - or else Restriction_Active (No_Exception_Propagation)) + or else Restriction_Active (No_Exception_Propagation)) and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)) then Rewrite (N, @@ -297,13 +338,29 @@ package body Exp_Prag is -- Case where we call the procedure else - -- First, we need to prepare the string literal + -- First, we need to prepare the string argument + + -- If we have a message given, use it + + if Present (Arg3 (N)) then + Msg := Arg3 (N); + + -- Otherwise string is "name failed at location" except in the case + -- of Assertion where "name failed at" is omitted. - if Present (Arg2 (N)) then - Msg := Strval (Expr_Value_S (Arg2 (N))); else + if Nam = Name_Assertion then + Name_Len := 0; + else + Get_Name_String (Nam); + Set_Casing (Identifier_Casing (Current_Source_File)); + Add_Str_To_Name_Buffer (" failed at "); + end if; + Build_Location_String (Loc); - Msg := String_From_Name_Buffer; + Msg := + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer); end if; -- Now rewrite as an if statement @@ -317,8 +374,7 @@ package body Exp_Prag is Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), - Parameter_Associations => New_List ( - Make_String_Literal (Loc, Msg)))))); + Parameter_Associations => New_List (Msg))))); end if; Analyze (N); @@ -336,11 +392,13 @@ package body Exp_Prag is and then Entity (Original_Node (Cond)) = Standard_False then return; - else + elsif Nam = Name_Assertion then Error_Msg_N ("?assertion will fail at run-time", N); + else + Error_Msg_N ("?check will fail at run time", N); end if; end if; - end Expand_Pragma_Assert; + end Expand_Pragma_Check; --------------------------------- -- Expand_Pragma_Common_Object -- @@ -737,4 +795,39 @@ package body Exp_Prag is procedure Expand_Pragma_Psect_Object (N : Node_Id) renames Expand_Pragma_Common_Object; + ------------------------------------- + -- Expand_Pragma_Relative_Deadline -- + ------------------------------------- + + procedure Expand_Pragma_Relative_Deadline (N : Node_Id) is + P : constant Node_Id := Parent (N); + Loc : constant Source_Ptr := Sloc (N); + + begin + -- Expand the pragma only in the case of the main subprogram. For tasks + -- the expansion is done in exp_ch9. Generate a call to Set_Deadline + -- at Clock plus the relative deadline specified in the pragma. Time + -- values are translated into Duration to allow for non-private + -- addition operation. + + if Nkind (P) = N_Subprogram_Body then + Rewrite + (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Set_Deadline), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RO_RT_Time), + Make_Op_Add (Loc, + Left_Opnd => + Make_Function_Call (Loc, + New_Reference_To (RTE (RO_RT_To_Duration), Loc), + New_List (Make_Function_Call (Loc, + New_Reference_To (RTE (RE_Clock), Loc)))), + Right_Opnd => + Unchecked_Convert_To (Standard_Duration, Arg1 (N))))))); + + Analyze (N); + end if; + end Expand_Pragma_Relative_Deadline; + end Exp_Prag; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index b6fde43..c01e8ef 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -47,6 +47,7 @@ with Rtsfind; with Sprint; with Scn; use Scn; with Sem; use Sem; +with Sem_Aux; with Sem_Ch8; use Sem_Ch8; with Sem_Elab; use Sem_Elab; with Sem_Prag; use Sem_Prag; @@ -75,7 +76,9 @@ begin Nlists.Initialize; Elists.Initialize; Lib.Load.Initialize; + Sem_Aux.Initialize; Sem_Ch8.Initialize; + Sem_Prag.Initialize; Fname.UF.Initialize; Checks.Initialize; Sem_Warn.Initialize; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 2037542..5067f02 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1053,7 +1053,9 @@ begin Pragma_Atomic | Pragma_Atomic_Components | Pragma_Attach_Handler | + Pragma_Check | Pragma_Check_Name | + Pragma_Check_Policy | Pragma_CIL_Constructor | Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning | @@ -1141,6 +1143,8 @@ begin Pragma_Preelaborable_Initialization | Pragma_Polling | Pragma_Persistent_BSS | + Pragma_Postcondition | + Pragma_Precondition | Pragma_Preelaborate | Pragma_Preelaborate_05 | Pragma_Priority | @@ -1153,6 +1157,7 @@ begin Pragma_Pure_05 | Pragma_Pure_Function | Pragma_Queuing_Policy | + Pragma_Relative_Deadline | Pragma_Remote_Call_Interface | Pragma_Remote_Types | Pragma_Restricted_Run_Time | diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 114df98..ae84ffb 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -250,7 +250,7 @@ package body Sem_Attr is procedure Check_Enum_Image; -- If the prefix type is an enumeration type, set all its literals -- as referenced, since the image function could possibly end up - -- referencing any of the literals indirectly. + -- referencing any of the literals indirectly. Same for Enum_Val. procedure Check_Fixed_Point_Type; -- Verify that prefix of attribute N is a fixed type @@ -275,8 +275,8 @@ package body Sem_Attr is -- two attribute expressions are present procedure Legal_Formal_Attribute; - -- Common processing for attributes Definite, Has_Access_Values, - -- and Has_Discriminants + -- Common processing for attributes Definite and Has_Discriminants. + -- Checks that prefix is generic indefinite formal type. procedure Check_Integer_Type; -- Verify that prefix of attribute N is an integer type @@ -287,6 +287,10 @@ package body Sem_Attr is procedure Check_Modular_Integer_Type; -- Verify that prefix of attribute N is a modular integer type + procedure Check_Not_CPP_Type; + -- Check that P (the prefix of the attribute) is not an CPP type + -- for which no Ada predefined primitive is available. + procedure Check_Not_Incomplete_Type; -- Check that P (the prefix of the attribute) is not an incomplete -- type or a private type for which no full view has been given. @@ -371,9 +375,9 @@ package body Sem_Attr is -- type that is constructed is returned as the result. procedure Build_Access_Subprogram_Type (P : Node_Id); - -- Build an access to subprogram whose designated type is - -- the type of the prefix. If prefix is overloaded, so it the - -- node itself. The result is stored in Acc_Type. + -- Build an access to subprogram whose designated type is the type of + -- the prefix. If prefix is overloaded, so is the node itself. The + -- result is stored in Acc_Type. function OK_Self_Reference return Boolean; -- An access reference whose prefix is a type can legally appear @@ -392,7 +396,6 @@ package body Sem_Attr is (E_Access_Attribute_Type, Current_Scope, Loc, 'A'); begin Set_Etype (Typ, Typ); - Init_Size_Align (Typ); Set_Is_Itype (Typ); Set_Associated_Node_For_Itype (Typ, N); Set_Directly_Designated_Type (Typ, DT); @@ -577,14 +580,16 @@ package body Sem_Attr is if Aname = Name_Unrestricted_Access then -- Do not kill values on nodes initializing dispatch tables - -- slots. The construct Address!(Prim'Unrestricted_Access) + -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access) -- is currently generated by the expander only for this -- purpose. Done to keep the quality of warnings currently -- generated by the compiler (otherwise any declaration of -- a tagged type cleans constant indications from its scope). if Nkind (Parent (N)) = N_Unchecked_Type_Conversion - and then Etype (Parent (N)) = RTE (RE_Address) + and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr) + or else + Etype (Parent (N)) = RTE (RE_Size_Ptr)) and then Is_Dispatching_Operation (Directly_Designated_Type (Etype (N))) then @@ -658,12 +663,12 @@ package body Sem_Attr is ("current instance prefix must be a direct name", P); end if; - -- If a current instance attribute appears within a - -- a component constraint it must appear alone; other - -- contexts (default expressions, within a task body) - -- are not subject to this restriction. + -- If a current instance attribute appears in a component + -- constraint it must appear alone; other contexts (spec- + -- expressions, within a task body) are not subject to this + -- restriction. - if not In_Default_Expression + if not In_Spec_Expression and then not Has_Completion (Scop) and then not Nkind_In (Parent (N), N_Discriminant_Association, @@ -1263,6 +1268,20 @@ package body Sem_Attr is end if; end Check_Modular_Integer_Type; + ------------------------ + -- Check_Not_CPP_Type -- + ------------------------ + + procedure Check_Not_CPP_Type is + begin + if Is_Tagged_Type (Etype (P)) + and then Convention (Etype (P)) = Convention_CPP + and then Is_CPP_Class (Root_Type (Etype (P))) + then + Error_Attr_P ("invalid use of % attribute with CPP tagged type"); + end if; + end Check_Not_CPP_Type; + ------------------------------- -- Check_Not_Incomplete_Type -- ------------------------------- @@ -1323,7 +1342,7 @@ package body Sem_Attr is if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) - or else In_Default_Expression + or else In_Spec_Expression then return; else @@ -1531,6 +1550,8 @@ package body Sem_Attr is Resolve (E2, P_Type); end if; + + Check_Not_CPP_Type; end Check_Stream_Attribute; ----------------------- @@ -1865,6 +1886,7 @@ package body Sem_Attr is and then Aname /= Name_Access and then Aname /= Name_Address and then Aname /= Name_Code_Address + and then Aname /= Name_Result and then Aname /= Name_Unchecked_Access then -- Ada 2005 (AI-345): Since protected and task types have primitive @@ -2055,6 +2077,7 @@ package body Sem_Attr is Check_E0; Check_Not_Incomplete_Type; + Check_Not_CPP_Type; Set_Etype (N, Universal_Integer); --------------- @@ -2082,7 +2105,7 @@ package body Sem_Attr is end if; end if; - Note_Possible_Modification (E2); + Note_Possible_Modification (E2, Sure => True); Set_Etype (N, RTE (RE_Asm_Output_Operand)); --------------- @@ -2109,11 +2132,19 @@ package body Sem_Attr is -- is set True for the entry family case). In the True case, -- makes sure that Is_AST_Entry is set on the entry. + ------------------- + -- Bad_AST_Entry -- + ------------------- + procedure Bad_AST_Entry is begin Error_Attr_P ("prefix for % attribute must be task entry"); end Bad_AST_Entry; + -------------- + -- OK_Entry -- + -------------- + function OK_Entry (E : Entity_Id) return Boolean is Result : Boolean; @@ -2796,6 +2827,38 @@ package body Sem_Attr is Set_Etype (N, Universal_Integer); end Enum_Rep; + -------------- + -- Enum_Val -- + -------------- + + when Attribute_Enum_Val => Enum_Val : begin + Check_E1; + Check_Type; + + if not Is_Enumeration_Type (P_Type) then + Error_Attr_P ("prefix of % attribute must be enumeration type"); + end if; + + -- If the enumeration type has a standard representation, the effect + -- is the same as 'Val, so rewrite the attribute as a 'Val. + + if not Has_Non_Standard_Rep (P_Base_Type) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Prefix (N)), + Attribute_Name => Name_Val, + Expressions => New_List (Relocate_Node (E1)))); + Analyze_And_Resolve (N, P_Base_Type); + + -- Non-standard representation case (enumeration with holes) + + else + Check_Enum_Image; + Resolve (E1, Any_Integer); + Set_Etype (N, P_Base_Type); + end if; + end Enum_Val; + ------------- -- Epsilon -- ------------- @@ -2901,6 +2964,15 @@ package body Sem_Attr is Set_Etype (N, Standard_Boolean); ----------------------- + -- Has_Tagged_Values -- + ----------------------- + + when Attribute_Has_Tagged_Values => + Check_Type; + Check_E0; + Set_Etype (N, Standard_Boolean); + + ----------------------- -- Has_Discriminants -- ----------------------- @@ -3017,6 +3089,16 @@ package body Sem_Attr is Set_Etype (N, P_Base_Type); + ------------------- + -- Invalid_Value -- + ------------------- + + when Attribute_Invalid_Value => + Check_E0; + Check_Scalar_Type; + Set_Etype (N, P_Base_Type); + Invalid_Value_Used := True; + ----------- -- Large -- ----------- @@ -3560,6 +3642,69 @@ package body Sem_Attr is ("(Ada 83) % attribute not allowed for scalar type", P); end if; + ------------ + -- Result -- + ------------ + + when Attribute_Result => Result : declare + CS : constant Entity_Id := Current_Scope; + PS : constant Entity_Id := Scope (CS); + + begin + -- If we are in the scope of a function and in Spec_Expression mode, + -- this is likely the prescan of the postcondition pragma, and we + -- just set the proper type. If there is an error it will be caught + -- when the real Analyze call is done. + + if Ekind (CS) = E_Function + and then In_Spec_Expression + then + -- Check OK prefix + + if Chars (CS) /= Chars (P) then + Error_Msg_NE + ("incorrect prefix for % attribute, expected &", P, CS); + Error_Attr; + end if; + + Set_Etype (N, Etype (CS)); + + -- If several functions with that name are visible, + -- the intended one is the current scope. + + if Is_Overloaded (P) then + Set_Entity (P, CS); + Set_Is_Overloaded (P, False); + end if; + + -- Body case, where we must be inside a generated _Postcondition + -- procedure, or the attribute use is definitely misplaced. + + elsif Chars (CS) = Name_uPostconditions + and then Ekind (PS) = E_Function + then + -- Check OK prefix + + if Nkind (P) /= N_Identifier + or else Chars (P) /= Chars (PS) + then + Error_Msg_NE + ("incorrect prefix for % attribute, expected &", P, PS); + Error_Attr; + end if; + + Rewrite (N, + Make_Identifier (Sloc (N), + Chars => Name_uResult)); + Analyze_And_Resolve (N, Etype (PS)); + + else + Error_Attr + ("% attribute can only appear in function Postcondition pragma", + P); + end if; + end Result; + ------------------ -- Range_Length -- ------------------ @@ -3578,7 +3723,7 @@ package body Sem_Attr is Check_Stream_Attribute (TSS_Stream_Read); Set_Etype (N, Standard_Void_Type); Resolve (N, Standard_Void_Type); - Note_Possible_Modification (E2); + Note_Possible_Modification (E2, Sure => True); --------------- -- Remainder -- @@ -3737,6 +3882,7 @@ package body Sem_Attr is end if; Check_Not_Incomplete_Type; + Check_Not_CPP_Type; Set_Etype (N, Universal_Integer); end Size; @@ -5020,7 +5166,7 @@ package body Sem_Attr is -- Definite must be folded if the prefix is not a generic type, -- that is to say if we are within an instantiation. Same processing -- applies to the GNAT attributes Has_Discriminants, Type_Class, - -- and Unconstrained_Array. + -- Has_Tagged_Value, and Unconstrained_Array. elsif (Id = Attribute_Definite or else @@ -5028,6 +5174,8 @@ package body Sem_Attr is or else Id = Attribute_Has_Discriminants or else + Id = Attribute_Has_Tagged_Values + or else Id = Attribute_Type_Class or else Id = Attribute_Unconstrained_Array) @@ -5130,9 +5278,9 @@ package body Sem_Attr is -- since we can't do anything with unconstrained arrays. In addition, -- only the First, Last and Length attributes are possibly static. - -- Definite, Has_Access_Values, Has_Discriminants, Type_Class, and - -- Unconstrained_Array are again exceptions, because they apply as - -- well to unconstrained types. + -- Definite, Has_Access_Values, Has_Discriminants, Has_Tagged_Values, + -- Type_Class, and Unconstrained_Array are again exceptions, because + -- they apply as well to unconstrained types. -- In addition Component_Size is an exception since it is possibly -- foldable, even though it is never static, and it does apply to @@ -5145,6 +5293,8 @@ package body Sem_Attr is or else Id = Attribute_Has_Discriminants or else + Id = Attribute_Has_Tagged_Values + or else Id = Attribute_Type_Class or else Id = Attribute_Unconstrained_Array @@ -5477,6 +5627,36 @@ package body Sem_Attr is Fold_Uint (N, Expr_Value (E1), Static); end if; + -------------- + -- Enum_Val -- + -------------- + + when Attribute_Enum_Val => Enum_Val : declare + Lit : Node_Id; + + begin + -- We have something like Enum_Type'Enum_Val (23), so search for a + -- corresponding value in the list of Enum_Rep values for the type. + + Lit := First_Literal (P_Base_Type); + loop + if Enumeration_Rep (Lit) = Expr_Value (E1) then + Fold_Uint (N, Enumeration_Pos (Lit), Static); + exit; + end if; + + Next_Literal (Lit); + + if No (Lit) then + Apply_Compile_Time_Constraint_Error + (N, "no representation value matches", + CE_Range_Check_Failed, + Warn => not Static); + exit; + end if; + end loop; + end Enum_Val; + ------------- -- Epsilon -- ------------- @@ -5564,6 +5744,15 @@ package body Sem_Attr is Boolean_Literals (Has_Discriminants (P_Entity)), Loc)); Analyze_And_Resolve (N, Standard_Boolean); + ----------------------- + -- Has_Tagged_Values -- + ----------------------- + + when Attribute_Has_Tagged_Values => + Rewrite (N, New_Occurrence_Of + (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc)); + Analyze_And_Resolve (N, Standard_Boolean); + -------------- -- Identity -- -------------- @@ -5615,9 +5804,21 @@ package body Sem_Attr is -- Integer_Value -- ------------------- + -- We never try to fold Integer_Value (though perhaps we could???) + when Attribute_Integer_Value => null; + ------------------- + -- Invalid_Value -- + ------------------- + + -- Invalid_Value is a scalar attribute that is never static, because + -- the value is by design out of range. + + when Attribute_Invalid_Value => + null; + ----------- -- Large -- ----------- @@ -6785,10 +6986,8 @@ package body Sem_Attr is else declare R : constant Entity_Id := Root_Type (P_Type); - Lo : constant Uint := - Expr_Value (Type_Low_Bound (P_Type)); - Hi : constant Uint := - Expr_Value (Type_High_Bound (P_Type)); + Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type)); + Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type)); W : Nat; Wt : Nat; T : Uint; @@ -6804,10 +7003,7 @@ package body Sem_Attr is -- Width for types derived from Standard.Character -- and Standard.Wide_[Wide_]Character. - elsif R = Standard_Character - or else R = Standard_Wide_Character - or else R = Standard_Wide_Wide_Character - then + elsif Is_Standard_Character_Type (P_Type) then W := 0; -- Set W larger if needed @@ -6978,6 +7174,7 @@ package body Sem_Attr is Attribute_Position | Attribute_Priority | Attribute_Read | + Attribute_Result | Attribute_Storage_Pool | Attribute_Storage_Size | Attribute_Storage_Unit | @@ -7172,7 +7369,7 @@ package body Sem_Attr is Access_Attribute : begin if Is_Variable (P) then - Note_Possible_Modification (P); + Note_Possible_Modification (P, Sure => False); end if; if Is_Entity_Name (P) then @@ -7202,7 +7399,10 @@ package body Sem_Attr is -- If it is an object, complete its resolution. elsif Is_Overloadable (Entity (P)) then - if not In_Default_Expression then + + -- Avoid insertion of freeze actions in spec expression mode + + if not In_Spec_Expression then Insert_Actions (N, Freeze_Entity (Entity (P), Loc)); end if; @@ -7760,7 +7960,7 @@ package body Sem_Attr is -- it may be modified via this address, so note modification. if Is_Variable (P) then - Note_Possible_Modification (P); + Note_Possible_Modification (P, Sure => False); end if; if Nkind (P) in N_Subexpr @@ -7927,35 +8127,6 @@ package body Sem_Attr is LB : Node_Id; HB : Node_Id; - function Check_Discriminated_Prival - (N : Node_Id) - return Node_Id; - -- The range of a private component constrained by a - -- discriminant is rewritten to make the discriminant - -- explicit. This solves some complex visibility problems - -- related to the use of privals. - - -------------------------------- - -- Check_Discriminated_Prival -- - -------------------------------- - - function Check_Discriminated_Prival - (N : Node_Id) - return Node_Id - is - begin - if Is_Entity_Name (N) - and then Ekind (Entity (N)) = E_In_Parameter - and then not Within_Init_Proc - then - return Make_Identifier (Sloc (N), Chars (Entity (N))); - else - return Duplicate_Subexpr (N); - end if; - end Check_Discriminated_Prival; - - -- Start of processing for Range_Attribute - begin if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) @@ -7963,39 +8134,18 @@ package body Sem_Attr is Resolve (P); end if; - -- Check whether prefix is (renaming of) private component - -- of protected type. + HB := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr (P, Name_Req => True), + Attribute_Name => Name_Last, + Expressions => Expressions (N)); - if Is_Entity_Name (P) - and then Comes_From_Source (N) - and then Is_Array_Type (Etype (P)) - and then Number_Dimensions (Etype (P)) = 1 - and then (Ekind (Scope (Entity (P))) = E_Protected_Type - or else - Ekind (Scope (Scope (Entity (P)))) = - E_Protected_Type) - then - LB := - Check_Discriminated_Prival - (Type_Low_Bound (Etype (First_Index (Etype (P))))); - - HB := - Check_Discriminated_Prival - (Type_High_Bound (Etype (First_Index (Etype (P))))); - - else - HB := - Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (P), - Attribute_Name => Name_Last, - Expressions => Expressions (N)); - - LB := - Make_Attribute_Reference (Loc, - Prefix => P, - Attribute_Name => Name_First, - Expressions => Expressions (N)); - end if; + LB := + Make_Attribute_Reference (Loc, + Prefix => P, + Attribute_Name => Name_First, + Expressions => Expressions (N)); -- If the original was marked as Must_Not_Freeze (see code -- in Sem_Ch3.Make_Index), then make sure the rewriting @@ -8031,6 +8181,17 @@ package body Sem_Attr is return; end Range_Attribute; + ------------ + -- Result -- + ------------ + + -- We will only come here during the prescan of a spec expression + -- containing a Result attribute. In that case the proper Etype has + -- already been set, and nothing more needs to be done here. + + when Attribute_Result => + null; + ----------------- -- UET_Address -- ----------------- diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index 45cb8e0..d0b74f5 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -210,6 +210,21 @@ package Sem_Attr is -- absence of an enumeration representation clause. This is a static -- attribute (i.e. the result is static if the argument is static). + -------------- + -- Enum_Val -- + -------------- + + Attribute_Enum_Val => True, + -- For every enumeration subtype S, S'Enum_Val denotes a function + -- with the following specification: + -- + -- function S'Enum_Val (Arg : universal_integer) return S'Base; + -- + -- This function performs the inverse transformation to Enum_Rep. Given + -- a representation value for the type, it returns the corresponding + -- enumeration value. Constraint_Error is raised if no value of the + -- enumeration type corresponds to the given integer value. + ----------------- -- Fixed_Value -- ----------------- @@ -276,6 +291,16 @@ package Sem_Attr is -- attribute is primarily intended for use in implementation of the -- standard input-output functions for fixed-point values. + Attribute_Invalid_Value => True, + -- For every scalar type, S'Invalid_Value designates an undefined value + -- of the type. If possible this value is an invalid value, and in fact + -- is identical to the value that would be set if Initialize_Scalars + -- mode were in effect (including the behavior of its value on + -- environment variables or binder switches). The intended use is + -- to set a value where intialization is required (e.g. as a result of + -- the coding standards in use), but logically no initialization is + -- needed, and the value should never be accessed. + ------------------ -- Machine_Size -- ------------------ diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb new file mode 100755 index 0000000..58b5b5c --- /dev/null +++ b/gcc/ada/sem_aux.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2008, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Sem_Aux is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Obsolescent_Warnings.Init; + end Initialize; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Obsolescent_Warnings.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Obsolescent_Warnings.Tree_Write; + end Tree_Write; + +end Sem_Aux; diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads new file mode 100755 index 0000000..d9d7482 --- /dev/null +++ b/gcc/ada/sem_aux.ads @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2008, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Package containing utility procedures used throughout the compiler, +-- and also by ASIS so dependencies are limited to ASIS included packages. + +-- Note: contents are minimal for now, the intent is to move stuff from +-- Sem_Util that meets the ASIS dependency requirements, and also stuff +-- from Einfo, where Einfo had excessive semantic knowledge of the tree. + +with Alloc; use Alloc; +with Table; +with Types; use Types; + +package Sem_Aux is + + -------------------------------- + -- Obsolescent Warnings Table -- + -------------------------------- + + -- This table records entities for which a pragma Obsolescent with a + -- message argument has been processed. + + type OWT_Record is record + Ent : Entity_Id; + -- The entity to which the pragma applies + + Msg : String_Id; + -- The string containing the message + end record; + + package Obsolescent_Warnings is new Table.Table ( + Table_Component_Type => OWT_Record, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => Alloc.Obsolescent_Warnings_Initial, + Table_Increment => Alloc.Obsolescent_Warnings_Increment, + Table_Name => "Obsolescent_Warnings"); + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Called at the start of compilation of each new main source file to + -- initialize the allocation of the Obsolescent_Warnings table. Note that + -- Initialize must not be called if Tree_Read is used. + + procedure Tree_Read; + -- Initializes internal tables from current tree file using the relevant + -- Table.Tree_Read routines. + + procedure Tree_Write; + -- Writes out internal tables to current tree file using the relevant + -- Table.Tree_Write routines. + +end Sem_Aux; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 8c03865..759607e 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -32,6 +32,7 @@ with Errout; use Errout; with Expander; use Expander; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; +with Exp_Ch9; use Exp_Ch9; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; @@ -138,16 +139,6 @@ package body Sem_Ch6 is -- against a formal access-to-subprogram type so Get_Instance_Of must -- be called. - procedure Check_Overriding_Indicator - (Subp : Entity_Id; - Overridden_Subp : Entity_Id; - Is_Primitive : Boolean); - -- Verify the consistency of an overriding_indicator given for subprogram - -- declaration, body, renaming, or instantiation. Overridden_Subp is set - -- if the scope where we are introducing the subprogram contains a - -- type-conformant subprogram that becomes hidden by the new subprogram. - -- Is_Primitive indicates whether the subprogram is primitive. - procedure Check_Subprogram_Order (N : Node_Id); -- N is the N_Subprogram_Body node for a subprogram. This routine applies -- the alpha ordering rule for N if this ordering requirement applicable. @@ -174,11 +165,6 @@ package body Sem_Ch6 is procedure Install_Entity (E : Entity_Id); -- Make single entity visible. Used for generic formals as well - procedure Install_Formals (Id : Entity_Id); - -- On entry to a subprogram body, make the formals visible. Note that - -- simply placing the subprogram on the scope stack is not sufficient: - -- the formals must become the current entities for their names. - function Is_Non_Overriding_Operation (Prev_E : Entity_Id; New_E : Entity_Id) return Boolean; @@ -196,6 +182,16 @@ package body Sem_Ch6 is -- Flag functions that can be called without parameters, i.e. those that -- have no parameters, or those for which defaults exist for all parameters + procedure Process_PPCs + (N : Node_Id; + Spec_Id : Entity_Id; + Body_Id : Entity_Id); + -- Called from Analyze_Body to deal with scanning post conditions for the + -- body and assembling and inserting the _postconditions procedure. N is + -- the node for the subprogram body and Body_Id/Spec_Id are the entities + -- for the body and separate spec (if there is no separate spec, Spec_Id + -- is Empty). + procedure Set_Formal_Validity (Formal_Id : Entity_Id); -- Formal_Id is an formal parameter entity. This procedure deals with -- setting the proper validity status for this entity, which depends @@ -562,9 +558,22 @@ package body Sem_Ch6 is end if; -- Subtype_indication case; check that the types are the same, and - -- statically match if appropriate: + -- statically match if appropriate. A null exclusion may be present + -- on the return type, on the function specification, on the object + -- declaration or on the subtype itself. elsif Base_Type (R_Stm_Type) = Base_Type (R_Type) then + if Is_Access_Type (R_Type) + and then + (Can_Never_Be_Null (R_Type) + or else Null_Exclusion_Present (Parent (Scope_Id))) /= + Can_Never_Be_Null (R_Stm_Type) + then + Error_Msg_N + ("subtype must statically match function result subtype", + Subtype_Ind); + end if; + if Is_Constrained (R_Type) then if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then Error_Msg_N @@ -653,9 +662,13 @@ package body Sem_Ch6 is end; end if; - -- Case of Expr present (Etype check defends against previous errors) + -- Case of Expr present if Present (Expr) + + -- Defend against previous errors + + and then Nkind (Expr) /= N_Empty and then Present (Etype (Expr)) then -- Apply constraint check. Note that this is done before the implicit @@ -676,6 +689,22 @@ package body Sem_Ch6 is Analyze_And_Resolve (Expr, R_Type); end if; + -- If the result type is class-wide, then check that the return + -- expression's type is not declared at a deeper level than the + -- function (RM05-6.5(5.6/2)). + + if Ada_Version >= Ada_05 + and then Is_Class_Wide_Type (R_Type) + then + if Type_Access_Level (Etype (Expr)) > + Subprogram_Access_Level (Scope_Id) + then + Error_Msg_N + ("level of return expression type is deeper than " & + "class-wide function!", Expr); + end if; + end if; + if (Is_Class_Wide_Type (Etype (Expr)) or else Is_Dynamically_Tagged (Expr)) and then not Is_Class_Wide_Type (R_Type) @@ -1232,14 +1261,33 @@ package body Sem_Ch6 is Body_Id : Entity_Id := Defining_Entity (Body_Spec); Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); Body_Deleted : constant Boolean := False; - - HSS : Node_Id; - Spec_Id : Entity_Id; - Spec_Decl : Node_Id := Empty; - Last_Formal : Entity_Id := Empty; Conformant : Boolean; + HSS : Node_Id; Missing_Ret : Boolean; P_Ent : Entity_Id; + Prot_Typ : Entity_Id := Empty; + Spec_Id : Entity_Id; + Spec_Decl : Node_Id := Empty; + + Last_Real_Spec_Entity : Entity_Id := Empty; + -- When we analyze a separate spec, the entity chain ends up containing + -- the formals, as well as any itypes generated during analysis of the + -- default expressions for parameters, or the arguments of associated + -- precondition/postcondition pragmas (which are analyzed in the context + -- of the spec since they have visibility on formals). + -- + -- These entities belong with the spec and not the body. However we do + -- the analysis of the body in the context of the spec (again to obtain + -- visibility to the formals), and all the entities generated during + -- this analysis end up also chained to the entity chain of the spec. + -- But they really belong to the body, and there is circuitry to move + -- them from the spec to the body. + -- + -- However, when we do this move, we don't want to move the real spec + -- entities (first para above) to the body. The Last_Real_Spec_Entity + -- variable points to the last real spec entity, so we only move those + -- chained beyond that point. It is initialized to Empty to deal with + -- the case where there is no separate spec. procedure Check_Anonymous_Return; -- (Ada 2005): if a function returns an access type that denotes a task, @@ -1254,11 +1302,8 @@ package body Sem_Ch6 is -- unconditionally, otherwise only if Front_End_Inlining is requested. -- If the body acts as a spec, and inlining is required, we create a -- subprogram declaration for it, in order to attach the body to inline. - - procedure Copy_Parameter_List (Plist : List_Id); - -- Utility to create a parameter profile for a new subprogram spec, - -- when the subprogram has a body that acts as spec. This is done for - -- some cases of inlining, and for private protected ops. + -- If pragma does not appear after the body, check whether there is + -- an inline pragma before any local declarations. procedure Set_Trivial_Subprogram (N : Node_Id); -- Sets the Is_Trivial_Subprogram flag in both spec and body of the @@ -1323,6 +1368,30 @@ package body Sem_Ch6 is Prag : Node_Id; Plist : List_Id; + function Is_Inline_Pragma (N : Node_Id) return Boolean; + -- Simple predicate, used twice. + + ----------------------- + -- Is_Inline_Pragma -- + ----------------------- + + function Is_Inline_Pragma (N : Node_Id) return Boolean is + begin + return + Nkind (N) = N_Pragma + and then + (Pragma_Name (N) = Name_Inline_Always + or else + (Front_End_Inlining + and then Pragma_Name (N) = Name_Inline)) + and then + Chars + (Expression (First (Pragma_Argument_Associations (N)))) + = Chars (Body_Id); + end Is_Inline_Pragma; + + -- Start of processing for Check_Inline_Pragma + begin if not Expander_Active then return; @@ -1330,25 +1399,16 @@ package body Sem_Ch6 is if Is_List_Member (N) and then Present (Next (N)) - and then Nkind (Next (N)) = N_Pragma + and then Is_Inline_Pragma (Next (N)) then Prag := Next (N); - if Nkind (Prag) = N_Pragma - and then - (Pragma_Name (Prag) = Name_Inline_Always - or else - (Front_End_Inlining - and then Pragma_Name (Prag) = Name_Inline)) - and then - Chars - (Expression (First (Pragma_Argument_Associations (Prag)))) - = Chars (Body_Id) - then - Prag := Next (N); - else - Prag := Empty; - end if; + elsif Nkind (N) /= N_Subprogram_Body_Stub + and then Present (Declarations (N)) + and then Is_Inline_Pragma (First (Declarations (N))) + then + Prag := First (Declarations (N)); + else Prag := Empty; end if; @@ -1374,8 +1434,7 @@ package body Sem_Ch6 is Set_Defining_Unit_Name (Specification (Decl), Subp); if Present (First_Formal (Body_Id)) then - Plist := New_List; - Copy_Parameter_List (Plist); + Plist := Copy_Parameter_List (Body_Id); Set_Parameter_Specifications (Specification (Decl), Plist); end if; @@ -1387,8 +1446,7 @@ package body Sem_Ch6 is if Pragma_Name (Prag) = Name_Inline_Always then Set_Is_Inlined (Subp); - Set_Next_Rep_Item (Prag, First_Rep_Item (Subp)); - Set_First_Rep_Item (Subp, Prag); + Set_Has_Pragma_Inline_Always (Subp); end if; Spec := Subp; @@ -1397,34 +1455,6 @@ package body Sem_Ch6 is end if; end Check_Inline_Pragma; - ------------------------- - -- Copy_Parameter_List -- - ------------------------- - - procedure Copy_Parameter_List (Plist : List_Id) is - Formal : Entity_Id; - - begin - Formal := First_Formal (Body_Id); - - while Present (Formal) loop - Append - (Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Sloc (Formal), - Chars => Chars (Formal)), - In_Present => In_Present (Parent (Formal)), - Out_Present => Out_Present (Parent (Formal)), - Parameter_Type => - New_Reference_To (Etype (Formal), Loc), - Expression => - New_Copy_Tree (Expression (Parent (Formal)))), - Plist); - - Next_Formal (Formal); - end loop; - end Copy_Parameter_List; - ---------------------------- -- Set_Trivial_Subprogram -- ---------------------------- @@ -1455,11 +1485,16 @@ package body Sem_Ch6 is procedure Verify_Overriding_Indicator is begin - if Must_Override (Body_Spec) - and then not Is_Overriding_Operation (Spec_Id) - then - Error_Msg_NE - ("subprogram& is not overriding", Body_Spec, Spec_Id); + if Must_Override (Body_Spec) then + if Nkind (Spec_Id) = N_Defining_Operator_Symbol + and then Operator_Matches_Spec (Spec_Id, Spec_Id) + then + null; + + elsif not Is_Overriding_Operation (Spec_Id) then + Error_Msg_NE + ("subprogram& is not overriding", Body_Spec, Spec_Id); + end if; elsif Must_Not_Override (Body_Spec) then if Is_Overriding_Operation (Spec_Id) then @@ -1467,6 +1502,13 @@ package body Sem_Ch6 is ("subprogram& overrides inherited operation", Body_Spec, Spec_Id); + elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol + and then Operator_Matches_Spec (Spec_Id, Spec_Id) + then + Error_Msg_NE + ("subprogram & overrides predefined operator ", + Body_Spec, Spec_Id); + -- If this is not a primitive operation the overriding indicator -- is altogether illegal. @@ -1625,14 +1667,11 @@ package body Sem_Ch6 is if Present (Formal) or else Expander_Active then - Plist := New_List; - + Plist := Copy_Parameter_List (Body_Id); else Plist := No_List; end if; - Copy_Parameter_List (Plist); - if Nkind (Body_Spec) = N_Procedure_Specification then New_Spec := Make_Procedure_Specification (Loc, @@ -1715,12 +1754,13 @@ package body Sem_Ch6 is if Is_Abstract_Subprogram (Spec_Id) then Error_Msg_N ("an abstract subprogram cannot have a body", N); return; + else Set_Convention (Body_Id, Convention (Spec_Id)); Set_Has_Completion (Spec_Id); if Is_Protected_Type (Scope (Spec_Id)) then - Set_Privals_Chain (Spec_Id, New_Elmt_List); + Prot_Typ := Scope (Spec_Id); end if; -- If this is a body generated for a renaming, do not check for @@ -1789,8 +1829,8 @@ package body Sem_Ch6 is Present (Abstract_Interfaces (Etype (First_Entity (Spec_Id)))) and then Present - (Corresponding_Concurrent_Type - (Etype (First_Entity (Spec_Id)))) + (Corresponding_Concurrent_Type + (Etype (First_Entity (Spec_Id)))) then declare Typ : constant Entity_Id := Etype (First_Entity (Spec_Id)); @@ -1808,10 +1848,12 @@ package body Sem_Ch6 is end; end if; - -- Make the formals visible, and place subprogram on scope stack + -- Make the formals visible, and place subprogram on scope stack. + -- This is also the point at which we set Last_Real_Spec_Entity + -- to mark the entities which will not be moved to the body. Install_Formals (Spec_Id); - Last_Formal := Last_Entity (Spec_Id); + Last_Real_Spec_Entity := Last_Entity (Spec_Id); Push_Scope (Spec_Id); -- Make sure that the subprogram is immediately visible. For @@ -1931,9 +1973,10 @@ package body Sem_Ch6 is -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis -- if its specification we have to install the private withed units. + -- This holds for child units as well. if Is_Compilation_Unit (Body_Id) - and then Scope (Body_Id) = Standard_Standard + or else Nkind (Parent (N)) = N_Compilation_Unit then Install_Private_With_Clauses (Body_Id); end if; @@ -1961,9 +2004,7 @@ package body Sem_Ch6 is begin while Present (Prot_Ext_Formal) loop pragma Assert (Present (Impl_Ext_Formal)); - Set_Protected_Formal (Prot_Ext_Formal, Impl_Ext_Formal); - Next_Formal_With_Extras (Prot_Ext_Formal); Next_Formal_With_Extras (Impl_Ext_Formal); end loop; @@ -1974,9 +2015,40 @@ package body Sem_Ch6 is HSS := Handled_Statement_Sequence (N); Set_Actual_Subtypes (N, Current_Scope); + + -- Deal with preconditions and postconditions + + Process_PPCs (N, Spec_Id, Body_Id); + + -- Add a declaration for the Protection objcect, renaming declarations + -- for discriminals and privals and finally a declaration for the entry + -- family index (if applicable). This form of early expansion is done + -- when the Expander is active because Install_Private_Data_Declarations + -- references entities which were created during regular expansion. + + if Expander_Active + and then Comes_From_Source (N) + and then Present (Prot_Typ) + and then Present (Spec_Id) + and then not Is_Eliminated (Spec_Id) + then + Install_Private_Data_Declarations + (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N)); + end if; + + -- Analyze the declarations (this call will analyze the precondition + -- Check pragmas we prepended to the list, as well as the declaration + -- of the _Postconditions procedure). + Analyze_Declarations (Declarations (N)); + + -- Check completion, and analyze the statements + Check_Completion; Analyze (HSS); + + -- Deal with end of scope processing for the body + Process_End_Label (HSS, 't', Current_Scope); End_Scope; Check_Subprogram_Order (N); @@ -2000,14 +2072,35 @@ package body Sem_Ch6 is (Unit_Declaration_Node (Spec_Id), Spec_Id); end if; - if Present (Last_Formal) then - Set_Next_Entity - (Last_Entity (Body_Id), Next_Entity (Last_Formal)); - Set_Next_Entity (Last_Formal, Empty); + -- Here is where we move entities from the spec to the body + + -- Case where there are entities that stay with the spec + + if Present (Last_Real_Spec_Entity) then + + -- No body entities (happens when the only real spec entities + -- come from precondition and postcondition pragmas) + + if No (Last_Entity (Body_Id)) then + Set_First_Entity + (Body_Id, Next_Entity (Last_Real_Spec_Entity)); + + -- Body entities present (formals), so chain stuff past them + + else + Set_Next_Entity + (Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity)); + end if; + + Set_Next_Entity (Last_Real_Spec_Entity, Empty); Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); - Set_Last_Entity (Spec_Id, Last_Formal); + Set_Last_Entity (Spec_Id, Last_Real_Spec_Entity); + + -- Case where there are no spec entities, in this case there can + -- be no body entities either, so just move everything. else + pragma Assert (No (Last_Entity (Body_Id))); Set_First_Entity (Body_Id, First_Entity (Spec_Id)); Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); Set_First_Entity (Spec_Id, Empty); @@ -2337,9 +2430,9 @@ package body Sem_Ch6 is function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is Designator : constant Entity_Id := Defining_Entity (N); + Formals : constant List_Id := Parameter_Specifications (N); Formal : Entity_Id; Formal_Typ : Entity_Id; - Formals : constant List_Id := Parameter_Specifications (N); -- Start of processing for Analyze_Subprogram_Specification @@ -2406,13 +2499,14 @@ package body Sem_Ch6 is if Is_Abstract_Type (Etype (Designator)) and then not Is_Interface (Etype (Designator)) - and then Nkind (Parent (N)) - /= N_Abstract_Subprogram_Declaration - and then (Nkind (Parent (N))) - /= N_Formal_Abstract_Subprogram_Declaration - and then (Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration - or else not Is_Entity_Name (Name (Parent (N))) - or else not Is_Abstract_Subprogram + and then Nkind (Parent (N)) /= + N_Abstract_Subprogram_Declaration + and then + (Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration + and then + (Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration + or else not Is_Entity_Name (Name (Parent (N))) + or else not Is_Abstract_Subprogram (Entity (Name (Parent (N))))) then Error_Msg_N @@ -3315,7 +3409,7 @@ package body Sem_Ch6 is if NewD then Push_Scope (New_Id); - Analyze_Per_Use_Expression + Preanalyze_Spec_Expression (Default_Value (New_Formal), Etype (New_Formal)); End_Scope; end if; @@ -3709,7 +3803,7 @@ package body Sem_Ch6 is -- expanded, so expand now to check conformance. if NewD then - Analyze_Per_Use_Expression + Preanalyze_Spec_Expression (Expression (New_Discr), New_Discr_Type); end if; @@ -3852,6 +3946,9 @@ package body Sem_Ch6 is Error_Msg_NE ("subprogram & overrides inherited operation #", Spec, Subp); end if; + + elsif Is_Subprogram (Subp) then + Set_Is_Overriding_Operation (Subp); end if; -- If Subp is an operator, it may override a predefined operation. @@ -3860,26 +3957,38 @@ package body Sem_Ch6 is -- signature of Subp matches that of a predefined operator. Note that -- first argument provides the name of the operator, and the second -- argument the signature that may match that of a standard operation. + -- If the indicator is overriding, then the operator must match a + -- predefined signature, because we know already that there is no + -- explicit overridden operation. - elsif Nkind (Subp) = N_Defining_Operator_Symbol - and then Must_Not_Override (Spec) - then - if Operator_Matches_Spec (Subp, Subp) then - Error_Msg_NE - ("subprogram & overrides predefined operator ", - Spec, Subp); - end if; + elsif Nkind (Subp) = N_Defining_Operator_Symbol then - elsif Must_Override (Spec) then - if Ekind (Subp) = E_Entry then - Error_Msg_NE ("entry & is not overriding", Spec, Subp); + if Must_Not_Override (Spec) then + if not Is_Primitive then + Error_Msg_N + ("overriding indicator only allowed " + & "if subprogram is primitive", Subp); - elsif Nkind (Subp) = N_Defining_Operator_Symbol then - if not Operator_Matches_Spec (Subp, Subp) then + elsif Operator_Matches_Spec (Subp, Subp) then Error_Msg_NE - ("subprogram & is not overriding", Spec, Subp); + ("subprogram & overrides predefined operator ", Spec, Subp); end if; + elsif Is_Overriding_Operation (Subp) then + null; + + elsif Must_Override (Spec) then + if not Operator_Matches_Spec (Subp, Subp) then + Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); + + else + Set_Is_Overriding_Operation (Subp); + end if; + end if; + + elsif Must_Override (Spec) then + if Ekind (Subp) = E_Entry then + Error_Msg_NE ("entry & is not overriding", Spec, Subp); else Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); end if; @@ -3897,7 +4006,6 @@ package body Sem_Ch6 is Error_Msg_N ("overriding indicator only allowed if subprogram is primitive", Subp); - return; end if; end Check_Overriding_Indicator; @@ -4964,7 +5072,6 @@ package body Sem_Ch6 is begin Set_Directly_Designated_Type (Formal_Type, Result_Subt); Set_Etype (Formal_Type, Formal_Type); - Init_Size_Align (Formal_Type); Set_Depends_On_Private (Formal_Type, Has_Private_Component (Formal_Type)); Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type))); @@ -6838,9 +6945,9 @@ package body Sem_Ch6 is Default : Node_Id; Ptype : Entity_Id; - -- The following are used for setting Is_Only_Out_ Num_Out_Params : Nat := 0; First_Out_Param : Entity_Id := Empty; + -- Used for setting Is_Only_Out_Parameter function Is_Class_Wide_Default (D : Node_Id) return Boolean; -- Check whether the default has a class-wide type. After analysis the @@ -7000,7 +7107,7 @@ package body Sem_Ch6 is -- Do the special preanalysis of the expression (see section on -- "Handling of Default Expressions" in the spec of package Sem). - Analyze_Per_Use_Expression (Default, Formal_Type); + Preanalyze_Spec_Expression (Default, Formal_Type); -- An access to constant cannot be the default for -- an access parameter that is an access to variable. @@ -7098,6 +7205,193 @@ package body Sem_Ch6 is end if; end Process_Formals; + ------------------ + -- Process_PPCs -- + ------------------ + + procedure Process_PPCs + (N : Node_Id; + Spec_Id : Entity_Id; + Body_Id : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Prag : Node_Id; + Plist : List_Id := No_List; + Subp : Entity_Id; + Parms : List_Id; + + function Grab_PPC (Nam : Name_Id) return Node_Id; + -- Prag contains an analyzed precondition or postcondition pragma. + -- This function copies the pragma, changes it to the corresponding + -- Check pragma and returns the Check pragma as the result. The + -- argument Nam is either Name_Precondition or Name_Postcondition. + + -------------- + -- Grab_PPC -- + -------------- + + function Grab_PPC (Nam : Name_Id) return Node_Id is + CP : constant Node_Id := New_Copy_Tree (Prag); + + begin + -- Set Analyzed to false, since we want to reanalyze the check + -- procedure. Note that it is only at the outer level that we + -- do this fiddling, for the spec cases, the already preanalyzed + -- parameters are not affected. + + Set_Analyzed (CP, False); + + -- Change pragma into corresponding pragma Check + + Prepend_To (Pragma_Argument_Associations (CP), + Make_Pragma_Argument_Association (Sloc (Prag), + Expression => + Make_Identifier (Loc, + Chars => Nam))); + Set_Pragma_Identifier (CP, + Make_Identifier (Sloc (Prag), + Chars => Name_Check)); + + return CP; + end Grab_PPC; + + -- Start of processing for Process_PPCs + + begin + -- Grab preconditions from spec + + if Present (Spec_Id) then + + -- Loop through PPC pragmas from spec. Note that preconditions from + -- the body will be analyzed and converted when we scan the body + -- declarations below. + + Prag := Spec_PPC_List (Spec_Id); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Precondition + and then PPC_Enabled (Prag) + then + -- Add pragma Check at the start of the declarations of N. + -- Note that this processing reverses the order of the list, + -- which is what we want since new entries were chained to + -- the head of the list. + + Prepend (Grab_PPC (Name_Precondition), Declarations (N)); + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + + -- Build postconditions procedure if needed and prepend the following + -- declaration to the start of the declarations for the subprogram. + + -- procedure _postconditions [(_Result : resulttype)] is + -- begin + -- pragma Check (Postcondition, condition [,message]); + -- pragma Check (Postcondition, condition [,message]); + -- ... + -- end; + + -- First we deal with the postconditions in the body + + if Is_Non_Empty_List (Declarations (N)) then + + -- Loop through declarations + + Prag := First (Declarations (N)); + while Present (Prag) loop + if Nkind (Prag) = N_Pragma then + + -- If pragma, capture if enabled postcondition, else ignore + + if Pragma_Name (Prag) = Name_Postcondition + and then Check_Enabled (Name_Postcondition) + then + if Plist = No_List then + Plist := Empty_List; + end if; + + Analyze (Prag); + Append (Grab_PPC (Name_Postcondition), Plist); + end if; + + Next (Prag); + + -- Not a pragma, if comes from source, then end scan + + elsif Comes_From_Source (Prag) then + exit; + + -- Skip stuff not coming from source + + else + Next (Prag); + end if; + end loop; + end if; + + -- Now deal with any postconditions from the spec + + if Present (Spec_Id) then + + -- Loop through PPC pragmas from spec + + Prag := Spec_PPC_List (Spec_Id); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Postcondition + and then PPC_Enabled (Prag) + then + if Plist = No_List then + Plist := Empty_List; + end if; + + Append (Grab_PPC (Name_Postcondition), Plist); + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + + -- If we had any postconditions, build the procedure + + if Present (Plist) then + Subp := Defining_Entity (N); + + if Etype (Subp) /= Standard_Void_Type then + Parms := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Name_uResult), + Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc))); + else + Parms := No_List; + end if; + + Prepend_To (Declarations (N), + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_uPostconditions), + Parameter_Specifications => Parms), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Plist))); + + if Present (Spec_Id) then + Set_Has_Postconditions (Spec_Id); + else + Set_Has_Postconditions (Body_Id); + end if; + end if; + end Process_PPCs; + ---------------------------- -- Reference_Body_Formals -- ---------------------------- diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index 071aa75..a195945 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -100,6 +100,16 @@ package Sem_Ch6 is -- formal access-to-subprogram type, indicating that mapping of types -- is needed. + procedure Check_Overriding_Indicator + (Subp : Entity_Id; + Overridden_Subp : Entity_Id; + Is_Primitive : Boolean); + -- Verify the consistency of an overriding_indicator given for subprogram + -- declaration, body, renaming, or instantiation. Overridden_Subp is set + -- if the scope where we are introducing the subprogram contains a + -- type-conformant subprogram that becomes hidden by the new subprogram. + -- Is_Primitive indicates whether the subprogram is primitive. + procedure Check_Subtype_Conformant (New_Id : Entity_Id; Old_Id : Entity_Id; @@ -146,18 +156,23 @@ package Sem_Ch6 is function Fully_Conformant_Expressions (Given_E1 : Node_Id; - Given_E2 : Node_Id) - return Boolean; + Given_E2 : Node_Id) return Boolean; -- Determines if two (non-empty) expressions are fully conformant -- as defined by (RM 6.3.1(18-21)) function Fully_Conformant_Discrete_Subtypes (Given_S1 : Node_Id; - Given_S2 : Node_Id) - return Boolean; + Given_S2 : Node_Id) return Boolean; -- Determines if two subtype definitions are fully conformant. Used -- for entry family conformance checks (RM 6.3.1 (24)). + procedure Install_Formals (Id : Entity_Id); + -- On entry to a subprogram body, make the formals visible. Note that + -- simply placing the subprogram on the scope stack is not sufficient: + -- the formals must become the current entities for their names. This + -- procedure is also used to get visibility to the formals when analyzing + -- preconditions and postconditions appearing in the spec. + function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; -- Determine whether two callable entities (subprograms, entries, -- literals) are mode conformant (RM 6.3.1(15)) diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index b732d50..ad03cdb 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -848,10 +848,8 @@ package body Sem_Ch8 is and then Nkind (Nam) in N_Has_Entity then declare - Error_Node : Node_Id; Nam_Decl : Node_Id; Nam_Ent : Entity_Id; - Subtyp_Decl : Node_Id; begin if Nkind (Nam) = N_Attribute_Reference then @@ -861,7 +859,6 @@ package body Sem_Ch8 is end if; Nam_Decl := Parent (Nam_Ent); - Subtyp_Decl := Parent (Etype (Nam_Ent)); if Has_Null_Exclusion (N) and then not Has_Null_Exclusion (Nam_Decl) @@ -876,32 +873,17 @@ package body Sem_Ch8 is if Is_Formal_Object (Nam_Ent) and then In_Generic_Scope (Id) then - if Present (Subtype_Mark (Nam_Decl)) then - Error_Node := Subtype_Mark (Nam_Decl); - else - pragma Assert - (Ada_Version >= Ada_05 - and then Present (Access_Definition (Nam_Decl))); - - Error_Node := Access_Definition (Nam_Decl); - end if; - - Error_Msg_N - ("`NOT NULL` required in formal object declaration", - Error_Node); - Error_Msg_Sloc := Sloc (N); Error_Msg_N - ("\because of renaming # (RM 8.5.4(4))", Error_Node); + ("renamed formal does not exclude `NULL` " + & "(RM 8.5.1(4.6/2))", N); -- Ada 2005 (AI-423): Otherwise, the subtype of the object name -- shall exclude null. - elsif Nkind (Subtyp_Decl) = N_Subtype_Declaration - and then not Has_Null_Exclusion (Subtyp_Decl) - then + elsif not Can_Never_Be_Null (Etype (Nam_Ent)) then Error_Msg_N - ("`NOT NULL` required for subtype & (RM 8.5.1(4.6/2))", - Defining_Identifier (Subtyp_Decl)); + ("renamed object does not exclude `NULL` " + & "(RM 8.5.1(4.6/2))", N); end if; end if; end; @@ -964,6 +946,11 @@ package body Sem_Ch8 is then null; + -- Allow internally generated x'Reference expression + + elsif Nkind (Nam) = N_Reference then + null; + else Error_Msg_N ("expect object name in renaming", Nam); end if; @@ -3205,6 +3192,8 @@ package body Sem_Ch8 is elsif not Redundant_Use (Id) then Set_In_Use (T, False); Set_In_Use (Base_Type (T), False); + Set_Current_Use_Clause (T, Empty); + Set_Current_Use_Clause (Base_Type (T), Empty); Op_List := Collect_Primitive_Operations (T); Elmt := First_Elmt (Op_List); @@ -3582,15 +3571,12 @@ package body Sem_Ch8 is declare Case_Stm : constant Node_Id := Parent (Parent (N)); Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm)); - Case_Rtp : constant Entity_Id := Root_Type (Case_Typ); Lit : Node_Id; begin if Is_Enumeration_Type (Case_Typ) - and then Case_Rtp /= Standard_Character - and then Case_Rtp /= Standard_Wide_Character - and then Case_Rtp /= Standard_Wide_Wide_Character + and then not Is_Standard_Character_Type (Case_Typ) then Lit := First_Literal (Case_Typ); Get_Name_String (Chars (Lit)); @@ -4121,6 +4107,17 @@ package body Sem_Ch8 is if Is_Object (E) and then Present (Renamed_Object (E)) then Generate_Reference (E, N); + -- If the renamed entity is a private protected component, + -- reference the original component as well. This needs to be + -- done because the private renamings are installed before any + -- analysis has occured. Reference to a private component will + -- resolve to the renaming and the original component will be + -- left unreferenced, hence the following. + + if Is_Prival (E) then + Generate_Reference (Prival_Link (E), N); + end if; + -- One odd case is that we do not want to set the Referenced flag -- if the entity is a label, and the identifier is the label in -- the source, since this is not a reference from the point of @@ -4149,8 +4146,8 @@ package body Sem_Ch8 is -- (because implicit derefences cannot be identified prior to -- full type resolution). -- - -- ??? The Is_Actual_Parameter routine takes care of one of these - -- cases but there are others probably + -- The Is_Actual_Parameter routine takes care of one of these + -- cases but there are others probably ??? else if not Is_Actual_Parameter then @@ -4170,7 +4167,10 @@ package body Sem_Ch8 is -- processing a generic spec or body, because the discriminal -- has not been not generated in this case. - if not In_Default_Expression + -- The replacement is also skipped if we are in special + -- spec-expression mode. Why is this skipped in this case ??? + + if not In_Spec_Expression or else Ekind (E) /= E_Discriminant or else Inside_A_Generic then @@ -4531,7 +4531,7 @@ package body Sem_Ch8 is else Error_Msg_N ("limited withed package can only be used to access " - & " incomplete types", + & "incomplete types", N); end if; end if; @@ -5535,14 +5535,10 @@ package body Sem_Ch8 is end if; Id := First_Entity (P); - while Present (Id) and then Id /= Priv_Id loop - if Is_Character_Type (Id) - and then (Root_Type (Id) = Standard_Character - or else Root_Type (Id) = Standard_Wide_Character - or else Root_Type (Id) = Standard_Wide_Wide_Character) + if Is_Standard_Character_Type (Id) and then Id = Base_Type (Id) then -- We replace the node with the literal itself, resolve as a @@ -6163,8 +6159,9 @@ package body Sem_Ch8 is Write_Info; end if; - Scope_Suppress := SST.Save_Scope_Suppress; + Scope_Suppress := SST.Save_Scope_Suppress; Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top; + Check_Policy_List := SST.Save_Check_Policy_List; if Debug_Flag_W then Write_Str ("--> exiting scope: "); @@ -6236,6 +6233,7 @@ package body Sem_Ch8 is SST.Entity := S; SST.Save_Scope_Suppress := Scope_Suppress; SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top; + SST.Save_Check_Policy_List := Check_Policy_List; if Scope_Stack.Last > Scope_Stack.First then SST.Component_Alignment_Default := Scope_Stack.Table @@ -6965,6 +6963,7 @@ package body Sem_Ch8 is elsif not Redundant_Use (Id) then Set_In_Use (T); + Set_Current_Use_Clause (T, Parent (Id)); Op_List := Collect_Primitive_Operations (T); Elmt := First_Elmt (Op_List); @@ -7000,9 +6999,72 @@ package body Sem_Ch8 is -- The type already has a use clause if In_Use (T) then - Error_Msg_NE - ("& is already use-visible through previous use type clause?", - Id, Id); + if Present (Current_Use_Clause (T)) then + declare + Clause1 : constant Node_Id := Parent (Id); + Clause2 : constant Node_Id := Current_Use_Clause (T); + Err_No : Node_Id; + Unit1 : Node_Id; + Unit2 : Node_Id; + + begin + if Nkind (Parent (Clause1)) = N_Compilation_Unit + and then Nkind (Parent (Clause2)) = N_Compilation_Unit + then + -- There is a redundant use type clause in a child unit. + -- Determine which of the units is more deeply nested. + + Unit1 := Defining_Entity (Unit (Parent (Clause1))); + Unit2 := Defining_Entity (Unit (Parent (Clause2))); + + if Scope (Unit2) = Standard_Standard then + Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); + Err_No := Clause1; + + elsif Scope (Unit1) = Standard_Standard then + Error_Msg_Sloc := Sloc (Id); + Err_No := Clause2; + + else + -- Determine which is the descendant unit + + declare + S1, S2 : Entity_Id; + + begin + S1 := Scope (Unit1); + S2 := Scope (Unit2); + while S1 /= Standard_Standard + and then S2 /= Standard_Standard + loop + S1 := Scope (S1); + S2 := Scope (S2); + end loop; + + if S1 = Standard_Standard then + Error_Msg_Sloc := Sloc (Id); + Err_No := Clause2; + else + Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); + Err_No := Clause1; + end if; + end; + end if; + + Error_Msg_NE + ("& is already use-visible through previous " + & "use_type_clause #?", Err_No, Id); + else + Error_Msg_NE + ("& is already use-visible through previous use type " + & "clause?", Id, Id); + end if; + end; + else + Error_Msg_NE + ("& is already use-visible through previous use type " + & "clause?", Id, Id); + end if; -- The package where T is declared is already used diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 251805d..4dba98d 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -40,7 +40,6 @@ with Exp_Dist; use Exp_Dist; with Lib; use Lib; with Lib.Writ; use Lib.Writ; with Lib.Xref; use Lib.Xref; -with Namet; use Namet; with Namet.Sp; use Namet.Sp; with Nlists; use Nlists; with Nmake; use Nmake; @@ -50,7 +49,9 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Dist; use Sem_Dist; @@ -173,6 +174,14 @@ package body Sem_Prag is -- (the original one, following the renaming chain) is returned. -- Otherwise the entity is returned unchanged. Should be in Einfo??? + function Get_Pragma_Arg (Arg : Node_Id) return Node_Id; + -- All the routines that check pragma arguments take either a pragma + -- argument association (in which case the expression of the argument + -- association is checked), or the expression directly. The function + -- Get_Pragma_Arg is a utility used to deal with these two cases. If Arg + -- is a pragma argument association node, then its expression is returned, + -- otherwise Arg is returned unchanged. + procedure rv; -- This is a dummy function called by the processing for pragma Reviewable. -- It is there for assisting front end debugging. By placing a Reviewable @@ -230,6 +239,41 @@ package body Sem_Prag is end if; end Adjust_External_Name_Case; + ------------------------------ + -- Analyze_PPC_In_Decl_Part -- + ------------------------------ + + procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (N)); + Arg2 : constant Node_Id := Next (Arg1); + + begin + -- Install formals and push subprogram spec onto scope stack + -- so that we can see the formals from the pragma. + + Install_Formals (S); + Push_Scope (S); + + -- Preanalyze the boolean expression, we treat this as a + -- spec expression (i.e. similar to a default expression). + + Preanalyze_Spec_Expression + (Get_Pragma_Arg (Arg1), Standard_Boolean); + + -- If there is a message argument, analyze it the same way + + if Present (Arg2) then + Preanalyze_Spec_Expression + (Get_Pragma_Arg (Arg2), Standard_String); + end if; + + -- Remove the subprogram from the scope stack now that the + -- pre-analysis of the precondition/postcondition is done. + + End_Scope; + end Analyze_PPC_In_Decl_Part; + -------------------- -- Analyze_Pragma -- -------------------- @@ -312,6 +356,7 @@ package body Sem_Prag is procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id); + procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3, N4 : Name_Id); -- Check the specified argument Arg to make sure that it is an -- identifier whose name matches either N1 or N2 (or N3 if present). -- If not then give error and raise Pragma_Exit. @@ -364,7 +409,7 @@ package body Sem_Prag is procedure Check_In_Main_Program; -- Common checks for pragmas that appear within a main program - -- (Priority, Main_Storage, Time_Slice). + -- (Priority, Main_Storage, Time_Slice, Relative_Deadline). procedure Check_Interrupt_Or_Attach_Handler; -- Common processing for first argument of pragma Interrupt_Handler @@ -397,6 +442,30 @@ package body Sem_Prag is -- In this version of the procedure, the identifier name is given as -- a string with lower case letters. + procedure Check_Precondition_Postcondition (In_Body : out Boolean); + -- Called to process a precondition or postcondition pragma. There are + -- three cases: + -- + -- The pragma appears after a subprogram spec + -- + -- If the corresponding check is not enabled, the pragma is analyzed + -- but otherwise ignored and control returns with In_Body set False. + -- + -- If the check is enabled, then the first step is to analyze the + -- pragma, but this is skipped if the subprogram spec appears within + -- a package specification (because this is the case where we delay + -- analysis till the end of the spec). Then (whether or not it was + -- analyzed), the pragma is chained to the subprogram in question + -- (using Spec_PPC_List and Next_Pragma) and control returns to the + -- caller with In_Body set False. + -- + -- The pragma appears at the start of subprogram body declarations + -- + -- In this case an immediate return to the caller is made with + -- In_Body set True, and the pragma is NOT analyzed. + -- + -- In all other cases, an error message for bad placement is given + procedure Check_Static_Constraint (Constr : Node_Id); -- Constr is a constraint from an N_Subtype_Indication node from a -- component constraint in an Unchecked_Union type. This routine checks @@ -484,14 +553,6 @@ package body Sem_Prag is -- optional identifiers when it returns). An entry in Args is Empty -- on return if the corresponding argument is not present. - function Get_Pragma_Arg (Arg : Node_Id) return Node_Id; - -- All the routines that check pragma arguments take either a pragma - -- argument association (in which case the expression of the argument - -- association is checked), or the expression directly. The function - -- Get_Pragma_Arg is a utility used to deal with these two cases. If - -- Arg is a pragma argument association node, then its expression is - -- returned, otherwise Arg is returned unchanged. - procedure GNAT_Pragma; -- Called for all GNAT defined pragmas to check the relevant restriction -- (No_Implementation_Pragmas). @@ -856,6 +917,24 @@ package body Sem_Prag is end if; end Check_Arg_Is_One_Of; + procedure Check_Arg_Is_One_Of + (Arg : Node_Id; + N1, N2, N3, N4 : Name_Id) + is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Check_Arg_Is_Identifier (Argx); + + if Chars (Argx) /= N1 + and then Chars (Argx) /= N2 + and then Chars (Argx) /= N3 + and then Chars (Argx) /= N4 + then + Error_Pragma_Arg ("invalid argument for pragma%", Argx); + end if; + end Check_Arg_Is_One_Of; + --------------------------------- -- Check_Arg_Is_Queuing_Policy -- --------------------------------- @@ -1256,6 +1335,91 @@ package body Sem_Prag is Check_Optional_Identifier (Arg, Name_Find); end Check_Optional_Identifier; + -------------------------------------- + -- Check_Precondition_Postcondition -- + -------------------------------------- + + procedure Check_Precondition_Postcondition (In_Body : out Boolean) is + P : Node_Id; + S : Entity_Id; + PO : Node_Id; + + begin + if not Is_List_Member (N) then + Pragma_Misplaced; + end if; + + -- Record whether pragma is enabled + + Set_PPC_Enabled (N, Check_Enabled (Pname)); + + -- Search prior declarations + + P := N; + while Present (Prev (P)) loop + P := Prev (P); + PO := Original_Node (P); + + -- Skip past prior pragma + + if Nkind (PO) = N_Pragma then + null; + + -- Skip stuff not coming from source + + elsif not Comes_From_Source (PO) then + null; + + -- Here if we hit a subprogram declaration + + elsif Nkind (PO) = N_Subprogram_Declaration then + S := Defining_Unit_Name (Specification (PO)); + + -- Analyze the pragma unless it appears within a package spec, + -- which is the case where we delay the analysis of the PPC + -- until the end of the package declarations (for details, + -- see Analyze_Package_Specification.Analyze_PPCs). + + if Ekind (Scope (S)) /= E_Package + and then + Ekind (Scope (S)) /= E_Generic_Package + then + Analyze_PPC_In_Decl_Part (N, S); + end if; + + -- Chain spec PPC pragma to list for subprogram + + Set_Next_Pragma (N, Spec_PPC_List (S)); + Set_Spec_PPC_List (S, N); + + -- Return indicating spec case + + In_Body := False; + return; + + -- If we encounter any other declaration moving back, misplaced + + else + Pragma_Misplaced; + end if; + end loop; + + -- If we fall through loop, pragma is at start of list, so see if + -- it is at the start of declarations of a subprogram body. + + if Nkind (Parent (N)) = N_Subprogram_Body + and then List_Containing (N) = Declarations (Parent (N)) + then + In_Body := True; + return; + + -- If not, it was misplaced + + else + Pragma_Misplaced; + end if; + end Check_Precondition_Postcondition; + ----------------------------- -- Check_Static_Constraint -- ----------------------------- @@ -1267,13 +1431,13 @@ package body Sem_Prag is procedure Check_Static_Constraint (Constr : Node_Id) is + procedure Require_Static (E : Node_Id); + -- Require given expression to be static expression + -------------------- -- Require_Static -- -------------------- - procedure Require_Static (E : Node_Id); - -- Require given expression to be static expression - procedure Require_Static (E : Node_Id) is begin if not Is_OK_Static_Expression (E) then @@ -1743,19 +1907,6 @@ package body Sem_Prag is end loop; end Gather_Associations; - -------------------- - -- Get_Pragma_Arg -- - -------------------- - - function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is - begin - if Nkind (Arg) = N_Pragma_Argument_Association then - return Expression (Arg); - else - return Arg; - end if; - end Get_Pragma_Arg; - ----------------- -- GNAT_Pragma -- ----------------- @@ -1895,10 +2046,10 @@ package body Sem_Prag is Utyp : Entity_Id; procedure Set_Atomic (E : Entity_Id); - -- Set given type as atomic, and if no explicit alignment was - -- given, set alignment to unknown, since back end knows what - -- the alignment requirements are for atomic arrays. Note that - -- this step is necessary for derived types. + -- Set given type as atomic, and if no explicit alignment was given, + -- set alignment to unknown, since back end knows what the alignment + -- requirements are for atomic arrays. Note: this step is necessary + -- for derived types. ---------------- -- Set_Atomic -- @@ -1946,9 +2097,8 @@ package body Sem_Prag is Set_Atomic (Base_Type (E)); end if; - -- Attribute belongs on the base type. If the - -- view of the type is currently private, it also - -- belongs on the underlying type. + -- Attribute belongs on the base type. If the view of the type is + -- currently private, it also belongs on the underlying type. Set_Is_Volatile (Base_Type (E)); Set_Is_Volatile (Underlying_Type (E)); @@ -1967,10 +2117,9 @@ package body Sem_Prag is if Prag_Id /= Pragma_Volatile then Set_Is_Atomic (E); - -- If the object declaration has an explicit - -- initialization, a temporary may have to be - -- created to hold the expression, to insure - -- that access to the object remain atomic. + -- If the object declaration has an explicit initialization, a + -- temporary may have to be created to hold the expression, to + -- ensure that access to the object remain atomic. if Nkind (Parent (E)) = N_Object_Declaration and then Present (Expression (Parent (E))) @@ -2389,8 +2538,12 @@ package body Sem_Prag is E1 := Homonym (E1); exit when No (E1) or else Scope (E1) /= Current_Scope; + -- Do not set the pragma on inherited operations or on + -- formal subprograms. + if Comes_From_Source (E1) and then Comp_Unit = Get_Source_Unit (E1) + and then not Is_Formal_Subprogram (E1) and then Nkind (Original_Node (Parent (E1))) /= N_Full_Type_Declaration then @@ -2617,7 +2770,7 @@ package body Sem_Prag is "\no initialization allowed for & declared#", Arg1); else Set_Imported (Def_Id); - Note_Possible_Modification (Arg_Internal); + Note_Possible_Modification (Arg_Internal, Sure => False); end if; end if; end Process_Extended_Import_Export_Object_Pragma; @@ -3126,7 +3279,7 @@ package body Sem_Prag is begin Process_Convention (C, Def_Id); Kill_Size_Check_Code (Def_Id); - Note_Possible_Modification (Expression (Arg2)); + Note_Possible_Modification (Expression (Arg2), Sure => False); if Ekind (Def_Id) = E_Variable or else @@ -3470,29 +3623,36 @@ package body Sem_Prag is return; -- Here we have a candidate for inlining, but we must exclude - -- derived operations. Otherwise we will end up trying to - -- inline a phantom declaration, and the result would be to - -- drag in a body which has no direct inlining associated with - -- it. That would not only be inefficient but would also result - -- in the backend doing cross-unit inlining in cases where it - -- was definitely inappropriate to do so. - - -- However, a simple Comes_From_Source test is insufficient, - -- since we do want to allow inlining of generic instances, - -- which also do not come from source. Predefined operators do - -- not come from source but are not inlineable either. + -- derived operations. Otherwise we would end up trying to inline + -- a phantom declaration, and the result would be to drag in a + -- body which has no direct inlining associated with it. That + -- would not only be inefficient but would also result in the + -- backend doing cross-unit inlining in cases where it was + -- definitely inappropriate to do so. + + -- However, a simple Comes_From_Source test is insufficient, since + -- we do want to allow inlining of generic instances which also do + -- not come from source. We also need to recognize specs + -- generated by the front-end for bodies that carry the pragma. + -- Finally, predefined operators do not come from source but are + -- not inlineable either. + + elsif Is_Generic_Instance (Subp) + or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration + then + null; elsif not Comes_From_Source (Subp) - and then not Is_Generic_Instance (Subp) and then Scope (Subp) /= Standard_Standard then Applies := True; return; + end if; -- The referenced entity must either be the enclosing entity, -- or an entity declared within the current open scope. - elsif Present (Scope (Subp)) + if Present (Scope (Subp)) and then Scope (Subp) /= Current_Scope and then Subp /= Current_Scope then @@ -3884,13 +4044,40 @@ package body Sem_Prag is (Process_Restriction_Synonyms (Expr)); if R_Id not in All_Boolean_Restrictions then - Error_Pragma_Arg - ("invalid restriction identifier", Arg); + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("invalid restriction identifier&", Get_Pragma_Arg (Arg)); + + -- Check for possible misspelling + + for J in Restriction_Id loop + declare + Rnm : constant String := Restriction_Id'Image (J); + + begin + Name_Buffer (1 .. Rnm'Length) := Rnm; + Name_Len := Rnm'Length; + Set_Casing (All_Lower_Case); + + if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then + Set_Casing + (Identifier_Casing (Current_Source_File)); + Error_Msg_String (1 .. Rnm'Length) := + Name_Buffer (1 .. Name_Len); + Error_Msg_Strlen := Rnm'Length; + Error_Msg_N + ("\possible misspelling of ""~""", + Get_Pragma_Arg (Arg)); + exit; + end if; + end; + end loop; + + raise Pragma_Exit; end if; if Implementation_Restriction (R_Id) then - Check_Restriction - (No_Implementation_Restrictions, Arg); + Check_Restriction (No_Implementation_Restrictions, Arg); end if; -- If this is a warning, then set the warning unless we already @@ -4840,7 +5027,7 @@ package body Sem_Prag is when Pragma_Assert => Assert : declare Expr : Node_Id; - Eloc : Source_Ptr; + Newa : List_Id; begin Ada_2005_Pragma; @@ -4849,71 +5036,33 @@ package body Sem_Prag is Check_Arg_Order ((Name_Check, Name_Message)); Check_Optional_Identifier (Arg1, Name_Check); - if Arg_Count > 1 then - Check_Optional_Identifier (Arg2, Name_Message); - Check_Arg_Is_Static_Expression (Arg2, Standard_String); - end if; - - -- If expansion is active and assertions are inactive, then - -- we rewrite the Assertion as: + -- We treat pragma Assert as equivalent to: - -- if False and then condition then - -- null; - -- end if; + -- pragma Check (Assertion, condition [, msg]); - -- The reason we do this rewriting during semantic analysis rather - -- than as part of normal expansion is that we cannot analyze and - -- expand the code for the boolean expression directly, or it may - -- cause insertion of actions that would escape the attempt to - -- suppress the assertion code. + -- So rewrite pragma in this manner, and analyze the result - -- Note that the Sloc for the if statement corresponds to the - -- argument condition, not the pragma itself. The reason for this - -- is that we may generate a warning if the condition is False at - -- compile time, and we do not want to delete this warning when we - -- delete the if statement. + Expr := Get_Pragma_Arg (Arg1); + Newa := New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Loc, + Chars => Name_Assertion)), - Expr := Expression (Arg1); - Eloc := Sloc (Expr); + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Expr)); - if Expander_Active and not Assertions_Enabled then - Rewrite (N, - Make_If_Statement (Eloc, - Condition => - Make_And_Then (Eloc, - Left_Opnd => New_Occurrence_Of (Standard_False, Eloc), - Right_Opnd => Expr), - Then_Statements => New_List ( - Make_Null_Statement (Eloc)))); - - Analyze (N); - - -- Otherwise (if assertions are enabled, or if we are not - -- operating with expansion active), then we just analyze - -- and resolve the expression. - - else - Analyze_And_Resolve (Expr, Any_Boolean); + if Arg_Count > 1 then + Check_Optional_Identifier (Arg2, Name_Message); + Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String); + Append_To (Newa, Relocate_Node (Arg2)); end if; - -- If assertion is of the form (X'First = literal), where X is - -- formal parameter, then set Low_Bound_Known flag on this formal. - - if Nkind (Expr) = N_Op_Eq then - declare - Right : constant Node_Id := Right_Opnd (Expr); - Left : constant Node_Id := Left_Opnd (Expr); - begin - if Nkind (Left) = N_Attribute_Reference - and then Attribute_Name (Left) = Name_First - and then Is_Entity_Name (Prefix (Left)) - and then Is_Formal (Entity (Prefix (Left))) - and then Nkind (Right) = N_Integer_Literal - then - Set_Low_Bound_Known (Entity (Prefix (Left))); - end if; - end; - end if; + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check, + Pragma_Argument_Associations => Newa)); + Analyze (N); end Assert; ---------------------- @@ -4922,11 +5071,44 @@ package body Sem_Prag is -- pragma Assertion_Policy (Check | Ignore) - when Pragma_Assertion_Policy => + when Pragma_Assertion_Policy => Assertion_Policy : declare + Policy : Node_Id; + + begin Ada_2005_Pragma; + Check_Valid_Configuration_Pragma; Check_Arg_Count (1); + Check_No_Identifiers; Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore); - Assertions_Enabled := Chars (Expression (Arg1)) = Name_Check; + + -- We treat pragma Assertion_Policy as equivalent to: + + -- pragma Check_Policy (Assertion, policy) + + -- So rewrite the pragma in that manner and link on to the chain + -- of Check_Policy pragmas, marking the pragma as analyzed. + + Policy := Get_Pragma_Arg (Arg1); + + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check_Policy, + + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Loc, + Chars => Name_Assertion)), + + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Sloc (Policy), + Chars => Chars (Policy)))))); + + Set_Analyzed (N); + Set_Next_Pragma (N, Opt.Check_Policy_List); + Opt.Check_Policy_List := N; + end Assertion_Policy; --------------- -- AST_Entry -- @@ -5237,7 +5419,7 @@ package body Sem_Prag is New_Copy_Tree (Expression (Arg2)); begin Set_Parent (Temp, N); - Pre_Analyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); + Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); end; else @@ -5285,6 +5467,97 @@ package body Sem_Prag is end if; end C_Pass_By_Copy; + ----------- + -- Check -- + ----------- + + -- pragma Check ([Name =>] Identifier, + -- [Check =>] Boolean_Expression + -- [,[Message =>] String_Expression]); + + when Pragma_Check => Check : declare + Expr : Node_Id; + Eloc : Source_Ptr; + + Check_On : Boolean; + -- Set True if category of assertions referenced by Name enabled + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (3); + Check_Optional_Identifier (Arg1, Name_Name); + Check_Optional_Identifier (Arg2, Name_Check); + + if Arg_Count = 3 then + Check_Optional_Identifier (Arg3, Name_Message); + Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String); + end if; + + Check_Arg_Is_Identifier (Arg1); + Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1))); + + -- If expansion is active and the check is not enabled then we + -- rewrite the Check as: + + -- if False and then condition then + -- null; + -- end if; + + -- The reason we do this rewriting during semantic analysis rather + -- than as part of normal expansion is that we cannot analyze and + -- expand the code for the boolean expression directly, or it may + -- cause insertion of actions that would escape the attempt to + -- suppress the check code. + + -- Note that the Sloc for the if statement corresponds to the + -- argument condition, not the pragma itself. The reason for this + -- is that we may generate a warning if the condition is False at + -- compile time, and we do not want to delete this warning when we + -- delete the if statement. + + Expr := Expression (Arg2); + + if Expander_Active and then not Check_On then + Eloc := Sloc (Expr); + + Rewrite (N, + Make_If_Statement (Eloc, + Condition => + Make_And_Then (Eloc, + Left_Opnd => New_Occurrence_Of (Standard_False, Eloc), + Right_Opnd => Expr), + Then_Statements => New_List ( + Make_Null_Statement (Eloc)))); + + Analyze (N); + + -- Check is active + + else + Analyze_And_Resolve (Expr, Any_Boolean); + end if; + + -- If assertion is of the form (X'First = literal), where X is + -- a formal, then set Low_Bound_Known flag on this formal. + + if Nkind (Expr) = N_Op_Eq then + declare + Right : constant Node_Id := Right_Opnd (Expr); + Left : constant Node_Id := Left_Opnd (Expr); + begin + if Nkind (Left) = N_Attribute_Reference + and then Attribute_Name (Left) = Name_First + and then Is_Entity_Name (Prefix (Left)) + and then Is_Formal (Entity (Prefix (Left))) + and then Nkind (Right) = N_Integer_Literal + then + Set_Low_Bound_Known (Entity (Prefix (Left))); + end if; + end; + end if; + end Check; + ---------------- -- Check_Name -- ---------------- @@ -5311,6 +5584,38 @@ package body Sem_Prag is Check_Names.Append (Nam); end; + ------------------ + -- Check_Policy -- + ------------------ + + -- pragma Check_Policy ([Name =>] IDENTIFIER, + -- POLICY_IDENTIFIER; + + -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE + + -- Note: this is a configuration pragma, but it is allowed to + -- appear anywhere else. + + when Pragma_Check_Policy => + GNAT_Pragma; + Check_Arg_Count (2); + Check_No_Identifier (Arg2); + Check_Optional_Identifier (Arg1, Name_Name); + Check_Arg_Is_One_Of + (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore); + + -- A Check_Policy pragma can appear either as a configuration + -- pragma, or in a declarative part or a package spec (see RM + -- 11.5(5) for rules for Suppress/Unsuppress which are also + -- followed for Check_Policy). + + if not Is_Configuration_Pragma then + Check_Is_In_Decl_Part_Or_Package_Spec; + end if; + + Set_Next_Pragma (N, Opt.Check_Policy_List); + Opt.Check_Policy_List := N; + --------------------- -- CIL_Constructor -- --------------------- @@ -6219,11 +6524,27 @@ package body Sem_Prag is Process_Convention (C, Def_Id); if Ekind (Def_Id) /= E_Constant then - Note_Possible_Modification (Expression (Arg2)); + Note_Possible_Modification (Expression (Arg2), Sure => False); end if; Process_Interface_Name (Def_Id, Arg3, Arg4); Set_Exported (Def_Id, Arg2); + + -- If the entity is a deferred constant, propagate the + -- information to the full view, because gigi elaborates + -- the full view only. + + if Ekind (Def_Id) = E_Constant + and then Present (Full_View (Def_Id)) + then + declare + Id2 : constant Entity_Id := Full_View (Def_Id); + begin + Set_Is_Exported (Id2, Is_Exported (Def_Id)); + Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id)); + Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id)); + end; + end if; end Export; ---------------------- @@ -6611,7 +6932,7 @@ package body Sem_Prag is Check_At_Least_N_Arguments (2); Check_At_Most_N_Arguments (4); Process_Convention (C, Def_Id); - Note_Possible_Modification (Expression (Arg2)); + Note_Possible_Modification (Expression (Arg2), Sure => False); Process_Interface_Name (Def_Id, Arg3, Arg4); Set_Exported (Def_Id, Arg2); end External; @@ -7431,12 +7752,12 @@ package body Sem_Prag is Def_Id := Entity (Id); end if; - -- Special DEC-compatible processing for the object case, - -- forces object to be imported. + -- Special DEC-compatible processing for the object case, forces + -- object to be imported. if Ekind (Def_Id) = E_Variable then Kill_Size_Check_Code (Def_Id); - Note_Possible_Modification (Id); + Note_Possible_Modification (Id, Sure => False); -- Initialization is not allowed for imported variable @@ -7543,7 +7864,7 @@ package body Sem_Prag is -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. - Analyze_Per_Use_Expression (Arg, RTE (RE_Interrupt_Priority)); + Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority)); end if; if Nkind (P) /= N_Task_Definition @@ -8065,22 +8386,20 @@ package body Sem_Prag is Check_No_Identifiers; Check_Arg_Count (1); Check_Is_In_Decl_Part_Or_Package_Spec; + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Start_String (Strval (Expr_Value_S (Expression (Arg1)))); + + Arg := Arg2; + while Present (Arg) loop + Check_Arg_Is_Static_Expression (Arg, Standard_String); + Store_String_Char (ASCII.NUL); + Store_String_Chars (Strval (Expr_Value_S (Expression (Arg)))); + Arg := Next (Arg); + end loop; if Operating_Mode = Generate_Code and then In_Extended_Main_Source_Unit (N) then - Check_Arg_Is_Static_Expression (Arg1, Standard_String); - Start_String (Strval (Expr_Value_S (Expression (Arg1)))); - - Arg := Arg2; - while Present (Arg) loop - Check_Arg_Is_Static_Expression (Arg, Standard_String); - Store_String_Char (ASCII.NUL); - Store_String_Chars - (Strval (Expr_Value_S (Expression (Arg)))); - Arg := Next (Arg); - end loop; - Store_Linker_Option_String (End_String); end if; end Linker_Options; @@ -8372,7 +8691,7 @@ package body Sem_Prag is -- it was misplaced. when Pragma_No_Body => - Error_Pragma ("misplaced pragma %"); + Pragma_Misplaced; --------------- -- No_Return -- @@ -8549,7 +8868,8 @@ package body Sem_Prag is end if; end loop; - Set_Obsolescent_Warning (Ent, Expression (Arg1)); + Obsolescent_Warnings.Append + ((Ent => Ent, Msg => Strval (Expression (Arg1)))); -- Check for Ada_05 parameter @@ -8760,6 +9080,12 @@ package body Sem_Prag is end case; end; + -- Set indication that mode is set locally. If we are in fact in a + -- configuration pragma file, this setting is harmless since the + -- switch will get reset anyway at the start of each unit. + + Optimize_Alignment_Local := True; + ---------- -- Pack -- ---------- @@ -9019,6 +9345,82 @@ package body Sem_Prag is end if; end Persistent_BSS; + ------------------- + -- Postcondition -- + ------------------- + + -- pragma Postcondition ([Check =>] Boolean_Expression + -- [,[Message =>] String_Expression]); + + when Pragma_Postcondition => Postcondition : declare + In_Body : Boolean; + pragma Warnings (Off, In_Body); + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); + Check_Optional_Identifier (Arg1, Name_Check); + + -- All we need to do here is call the common check procedure, + -- the remainder of the processing is found in Sem_Ch6/Sem_Ch7. + + Check_Precondition_Postcondition (In_Body); + end Postcondition; + + ------------------ + -- Precondition -- + ------------------ + + -- pragma Precondition ([Check =>] Boolean_Expression + -- [,[Message =>] String_Expression]); + + when Pragma_Precondition => Precondition : declare + In_Body : Boolean; + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); + Check_Optional_Identifier (Arg1, Name_Check); + + Check_Precondition_Postcondition (In_Body); + + -- If in spec, nothing to do. If in body, then we convert the + -- pragma to pragma Check (Precondition, cond [, msg]). Note we + -- do this whether or not precondition checks are enabled. That + -- works fine since pragma Check will do this check. + + if In_Body then + if Arg_Count = 2 then + Check_Optional_Identifier (Arg3, Name_Message); + Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String); + end if; + + Analyze_And_Resolve (Get_Pragma_Arg (Arg1), Standard_Boolean); + + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Loc, + Chars => Name_Precondition)), + + Make_Pragma_Argument_Association (Sloc (Arg1), + Expression => Relocate_Node (Get_Pragma_Arg (Arg1)))))); + + if Arg_Count = 2 then + Append_To (Pragma_Argument_Associations (N), + Make_Pragma_Argument_Association (Sloc (Arg2), + Expression => Relocate_Node (Get_Pragma_Arg (Arg2)))); + end if; + + Analyze (N); + end if; + end Precondition; + ------------------ -- Preelaborate -- ------------------ @@ -9172,7 +9574,7 @@ package body Sem_Prag is -- described in "Handling of Default and Per-Object -- Expressions" in sem.ads. - Analyze_Per_Use_Expression (Arg, Standard_Integer); + Preanalyze_Spec_Expression (Arg, Standard_Integer); if not Is_Static_Expression (Arg) then Check_Restriction (Static_Priorities, Arg); @@ -9339,7 +9741,7 @@ package body Sem_Prag is -- pragma Profile (profile_IDENTIFIER); - -- profile_IDENTIFIER => Protected | Ravenscar + -- profile_IDENTIFIER => Restricted | Ravenscar when Pragma_Profile => Ada_2005_Pragma; @@ -9365,7 +9767,7 @@ package body Sem_Prag is -- pragma Profile_Warnings (profile_IDENTIFIER); - -- profile_IDENTIFIER => Protected | Ravenscar + -- profile_IDENTIFIER => Restricted | Ravenscar when Pragma_Profile_Warnings => GNAT_Pragma; @@ -9699,6 +10101,55 @@ package body Sem_Prag is end if; end; + ----------------------- + -- Relative_Deadline -- + ----------------------- + + -- pragma Relative_Deadline (time_span_EXPRESSION); + + when Pragma_Relative_Deadline => Relative_Deadline : declare + P : constant Node_Id := Parent (N); + Arg : Node_Id; + + begin + Ada_2005_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + + Arg := Expression (Arg1); + + -- The expression must be analyzed in the special manner described + -- in "Handling of Default and Per-Object Expressions" in sem.ads. + + Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); + + -- Subprogram case + + if Nkind (P) = N_Subprogram_Body then + Check_In_Main_Program; + + -- Tasks + + elsif Nkind (P) = N_Task_Definition then + null; + + -- Anything else is incorrect + + else + Pragma_Misplaced; + end if; + + if Has_Relative_Deadline_Pragma (P) then + Error_Pragma ("duplicate pragma% not allowed"); + else + Set_Has_Relative_Deadline_Pragma (P, True); + + if Nkind (P) = N_Task_Definition then + Record_Rep_Item (Defining_Identifier (Parent (P)), N); + end if; + end if; + end Relative_Deadline; + --------------------------- -- Remote_Call_Interface -- --------------------------- @@ -9832,6 +10283,7 @@ package body Sem_Prag is -- | restriction_parameter_IDENTIFIER => EXPRESSION when Pragma_Restriction_Warnings => + GNAT_Pragma; Process_Restrictions_Or_Restriction_Warnings (Warn => True); ---------------- @@ -10025,13 +10477,11 @@ package body Sem_Prag is Check_No_Identifiers; Check_Arg_Count (1); - -- The expression must be analyzed in the special manner - -- described in "Handling of Default Expressions" in sem.ads. - - -- Set In_Default_Expression for per-object case ??? + -- The expression must be analyzed in the special manner described + -- in "Handling of Default Expressions" in sem.ads. Arg := Expression (Arg1); - Analyze_Per_Use_Expression (Arg, Any_Integer); + Preanalyze_Spec_Expression (Arg, Any_Integer); if not Is_Static_Expression (Arg) then Check_Restriction (Static_Storage_Size, Arg); @@ -10137,24 +10587,35 @@ package body Sem_Prag is Write : constant Entity_Id := Entity (Expression (Arg3)); begin - if Etype (Typ) = Any_Type - or else - Etype (Read) = Any_Type + Check_First_Subtype (Arg1); + + -- Check for too early or too late. Note that we don't enforce + -- the rule about primitive operations in this case, since, as + -- is the case for explicit stream attributes themselves, these + -- restrictions are not appropriate. Note that the chaining of + -- the pragma by Rep_Item_Too_Late is actually the critical + -- processing done for this pragma. + + if Rep_Item_Too_Early (Typ, N) or else - Etype (Write) = Any_Type + Rep_Item_Too_Late (Typ, N, FOnly => True) then return; end if; - Check_First_Subtype (Arg1); + -- Return if previous error - if Rep_Item_Too_Early (Typ, N) + if Etype (Typ) = Any_Type + or else + Etype (Read) = Any_Type or else - Rep_Item_Too_Late (Typ, N) + Etype (Write) = Any_Type then return; end if; + -- Error checks + if Underlying_Type (Etype (Read)) /= Typ then Error_Pragma_Arg ("incorrect return type for function&", Arg2); @@ -10477,8 +10938,6 @@ package body Sem_Prag is -- pragma Task_Name (string_EXPRESSION); when Pragma_Task_Name => Task_Name : declare - -- pragma Priority (EXPRESSION); - P : constant Node_Id := Parent (N); Arg : Node_Id; @@ -11361,6 +11820,39 @@ package body Sem_Prag is when Pragma_Exit => null; end Analyze_Pragma; + ------------------- + -- Check_Enabled -- + ------------------- + + function Check_Enabled (Nam : Name_Id) return Boolean is + PP : Node_Id; + + begin + PP := Opt.Check_Policy_List; + loop + if No (PP) then + return Assertions_Enabled; + + elsif + Nam = Chars (Expression (First (Pragma_Argument_Associations (PP)))) + then + case + Chars (Expression (Last (Pragma_Argument_Associations (PP)))) + is + when Name_On | Name_Check => + return True; + when Name_Off | Name_Ignore => + return False; + when others => + raise Program_Error; + end case; + + else + PP := Next_Pragma (PP); + end if; + end loop; + end Check_Enabled; + --------------------------------- -- Delay_Config_Pragma_Analyze -- --------------------------------- @@ -11396,6 +11888,28 @@ package body Sem_Prag is return Result; end Get_Base_Subprogram; + -------------------- + -- Get_Pragma_Arg -- + -------------------- + + function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is + begin + if Nkind (Arg) = N_Pragma_Argument_Association then + return Expression (Arg); + else + return Arg; + end if; + end Get_Pragma_Arg; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Externals.Init; + end Initialize; + ----------------------------- -- Is_Config_Static_String -- ----------------------------- @@ -11466,8 +11980,11 @@ package body Sem_Prag is -- than appearence as any argument is insignificant, a positive value -- indicates that appearence in that parameter position is significant. - Sig_Flags : constant array (Pragma_Id) of Int := + -- A value of 99 flags a special case requiring a special check (this is + -- used for cases not covered by this standard encoding, e.g. pragma Check + -- where the first argument is not significant, but the others are). + Sig_Flags : constant array (Pragma_Id) of Int := (Pragma_AST_Entry => -1, Pragma_Abort_Defer => -1, Pragma_Ada_83 => -1, @@ -11482,7 +11999,9 @@ package body Sem_Prag is Pragma_Atomic => 0, Pragma_Atomic_Components => 0, Pragma_Attach_Handler => -1, + Pragma_Check => 99, Pragma_Check_Name => 0, + Pragma_Check_Policy => 0, Pragma_CIL_Constructor => -1, Pragma_CPP_Class => 0, Pragma_CPP_Constructor => 0, @@ -11574,6 +12093,8 @@ package body Sem_Prag is Pragma_Preelaborable_Initialization => -1, Pragma_Polling => -1, Pragma_Persistent_BSS => 0, + Pragma_Postcondition => -1, + Pragma_Precondition => -1, Pragma_Preelaborate => -1, Pragma_Preelaborate_05 => -1, Pragma_Priority => -1, @@ -11587,6 +12108,7 @@ package body Sem_Prag is Pragma_Pure_Function => -1, Pragma_Queuing_Policy => -1, Pragma_Ravenscar => -1, + Pragma_Relative_Deadline => -1, Pragma_Remote_Call_Interface => -1, Pragma_Remote_Types => -1, Pragma_Restricted_Run_Time => -1, @@ -11636,9 +12158,10 @@ package body Sem_Prag is Unknown_Pragma => 0); function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is - P : Node_Id; - C : Int; - A : Node_Id; + Id : Pragma_Id; + P : Node_Id; + C : Int; + A : Node_Id; begin P := Parent (N); @@ -11647,7 +12170,8 @@ package body Sem_Prag is return False; else - C := Sig_Flags (Get_Pragma_Id (Parent (P))); + Id := Get_Pragma_Id (Parent (P)); + C := Sig_Flags (Id); case C is when -1 => @@ -11656,6 +12180,21 @@ package body Sem_Prag is when 0 => return True; + when 99 => + case Id is + + -- For pragma Check, the first argument is not significant, + -- the second and the third (if present) arguments are + -- significant. + + when Pragma_Check => + return + P = First (Pragma_Argument_Associations (Parent (P))); + + when others => + raise Program_Error; + end case; + when others => A := First (Pragma_Argument_Associations (Parent (P))); for J in 1 .. C - 1 loop @@ -11666,7 +12205,7 @@ package body Sem_Prag is Next (A); end loop; - return A = P; + return A = P; -- is this wrong way round ??? end case; end if; end Is_Non_Significant_Pragma_Reference; @@ -11920,4 +12459,5 @@ package body Sem_Prag is Set_Entity (Pref, Scop); end if; end Set_Unit_Name; + end Sem_Prag; diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index 5da2a9f..7218ff6 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -26,13 +26,36 @@ -- Pragma handling is isolated in a separate package -- (logically this processing belongs in chapter 4) +with Namet; use Namet; with Types; use Types; package Sem_Prag is + ----------------- + -- Subprograms -- + ----------------- + + procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id); + -- Special analyze routine for precondition/postcondition pragma that + -- appears within a declarative part where the pragma is associated + -- with a subprogram specification. N is the pragma node, and S is the + -- entity for the related subprogram. This procedure does a preanalysis + -- of the expressions in the pragma as "spec expressions" (see section + -- in Sem "Handling of Default and Per-Object Expressions..."). + procedure Analyze_Pragma (N : Node_Id); -- Analyze procedure for pragma reference node N + function Check_Enabled (Nam : Name_Id) return Boolean; + -- This function is used in connection with pragmas Assertion, Check, + -- Precondition, and Postcondition to determine if Check pragmas (or + -- corresponding Assert, Precondition, or Postcondition pragmas) are + -- currently active, as determined by the presence of -gnata on the + -- command line (which sets the default), and the appearence of pragmas + -- Check_Policy and Assertion_Policy as configuration pragmas either in + -- a configuration pragma file, or at the start of the current unit. + -- True is returned if the specified check is enabled. + function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean; -- N is a pragma appearing in a configuration pragma file. Most such -- pragmas are analyzed when the file is read, before parsing and analyzing @@ -43,6 +66,10 @@ package Sem_Prag is -- True have their analysis delayed until after the main program is parsed -- and analyzed. + procedure Initialize; + -- Initializes data structures used for pragma processing. Must be called + -- before analyzing each new main source program. + function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean; -- The node N is a node for an entity and the issue is whether the -- occurrence is a reference for the purposes of giving warnings about diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 81d866f..b9b81ab 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -36,6 +36,7 @@ with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; +with Sem_Aux; use Sem_Aux; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -2680,31 +2681,15 @@ package body Sem_Warn is -- Output additional warning if present - declare - W : constant Node_Id := Obsolescent_Warning (E); - - begin - if Present (W) then - - -- This is a warning continuation to start on a new line - Name_Buffer (1) := '\'; - Name_Buffer (2) := '\'; - Name_Buffer (3) := '?'; - Name_Len := 3; - - -- Add characters to message, and output message. Note that - -- we quote every character of the message since we don't - -- want to process any insertions. - - for J in 1 .. String_Length (Strval (W)) loop - Add_Char_To_Name_Buffer ('''); - Add_Char_To_Name_Buffer - (Get_Character (Get_String_Char (Strval (W), J))); - end loop; - - Error_Msg_N (Name_Buffer (1 .. Name_Len), N); + for J in Obsolescent_Warnings.First .. Obsolescent_Warnings.Last loop + if Obsolescent_Warnings.Table (J).Ent = E then + String_To_Name_Buffer (Obsolescent_Warnings.Table (J).Msg); + Error_Msg_Strlen := Name_Len; + Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + Error_Msg_N ("\\?~", N); + exit; end if; - end; + end loop; end Output_Obsolescent_Entity_Warnings; ---------------------------------- @@ -2838,12 +2823,50 @@ package body Sem_Warn is when 'C' => Warn_On_Unrepped_Components := False; + when 'e' => + Address_Clause_Overlay_Warnings := True; + Check_Unreferenced := True; + Check_Unreferenced_Formals := True; + Check_Withs := True; + Constant_Condition_Warnings := True; + Elab_Warnings := True; + Implementation_Unit_Warnings := True; + Ineffective_Inline_Warnings := True; + Warn_On_Ada_2005_Compatibility := True; + Warn_On_All_Unread_Out_Parameters := True; + Warn_On_Assertion_Failure := True; + Warn_On_Assumed_Low_Bound := True; + Warn_On_Bad_Fixed_Value := True; + Warn_On_Constant := True; + Warn_On_Deleted_Code := True; + Warn_On_Dereference := True; + Warn_On_Export_Import := True; + Warn_On_Hiding := True; + Ineffective_Inline_Warnings := True; + Warn_On_Modified_Unread := True; + Warn_On_No_Value_Assigned := True; + Warn_On_Non_Local_Exception := True; + Warn_On_Object_Renames_Function := True; + Warn_On_Obsolescent_Feature := True; + Warn_On_Questionable_Missing_Parens := True; + Warn_On_Redundant_Constructs := True; + Warn_On_Unchecked_Conversion := True; + Warn_On_Unrecognized_Pragma := True; + Warn_On_Unrepped_Components := True; + Warn_On_Warnings_Off := True; + when 'o' => Warn_On_All_Unread_Out_Parameters := True; when 'O' => Warn_On_All_Unread_Out_Parameters := False; + when 'p' => + Warn_On_Parameter_Order := True; + + when 'P' => + Warn_On_Parameter_Order := False; + when 'r' => Warn_On_Object_Renames_Function := True; @@ -2892,10 +2915,11 @@ package body Sem_Warn is Warn_On_Modified_Unread := True; Warn_On_No_Value_Assigned := True; Warn_On_Non_Local_Exception := True; + Warn_On_Object_Renames_Function := True; Warn_On_Obsolescent_Feature := True; + Warn_On_Parameter_Order := True; Warn_On_Questionable_Missing_Parens := True; Warn_On_Redundant_Constructs := True; - Warn_On_Object_Renames_Function := True; Warn_On_Unchecked_Conversion := True; Warn_On_Unrecognized_Pragma := True; Warn_On_Unrepped_Components := True; @@ -2922,6 +2946,7 @@ package body Sem_Warn is Warn_On_Non_Local_Exception := False; Warn_On_Obsolescent_Feature := False; Warn_On_All_Unread_Out_Parameters := False; + Warn_On_Parameter_Order := False; Warn_On_Questionable_Missing_Parens := False; Warn_On_Redundant_Constructs := False; Warn_On_Object_Renames_Function := False; @@ -3174,13 +3199,15 @@ package body Sem_Warn is then return; - -- Don't warn in assert pragma, since presumably tests in such - -- a context are very definitely intended, and might well be + -- Don't warn in assert or check pragma, since presumably tests in + -- such a context are very definitely intended, and might well be -- known at compile time. Note that we have to test the original -- node, since assert pragmas get rewritten at analysis time. elsif Nkind (Original_Node (P)) = N_Pragma - and then Pragma_Name (Original_Node (P)) = Name_Assert + and then (Pragma_Name (Original_Node (P)) = Name_Assert + or else + Pragma_Name (Original_Node (P)) = Name_Check) then return; end if; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 528d7f4..534023f 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1415,6 +1415,15 @@ package body Sinfo is return Flag11 (N); end Has_Private_View; + function Has_Relative_Deadline_Pragma + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Definition); + return Flag9 (N); + end Has_Relative_Deadline_Pragma; + function Has_Self_Reference (N : Node_Id) return Boolean is begin @@ -1980,6 +1989,14 @@ package body Sinfo is return Node4 (N); end Next_Named_Actual; + function Next_Pragma + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Node1 (N); + end Next_Pragma; + function Next_Rep_Item (N : Node_Id) return Node_Id is begin @@ -2184,6 +2201,14 @@ package body Sinfo is return Node4 (N); end Parent_Spec; + function PPC_Enabled + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag5 (N); + end PPC_Enabled; + function Position (N : Node_Id) return Node_Id is begin @@ -4154,6 +4179,15 @@ package body Sinfo is Set_Flag11 (N, Val); end Set_Has_Private_View; + procedure Set_Has_Relative_Deadline_Pragma + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body + or else NT (N).Nkind = N_Task_Definition); + Set_Flag9 (N, Val); + end Set_Has_Relative_Deadline_Pragma; + procedure Set_Has_Self_Reference (N : Node_Id; Val : Boolean := True) is begin @@ -4719,6 +4753,14 @@ package body Sinfo is Set_Node4 (N, Val); -- semantic field, no parent set end Set_Next_Named_Actual; + procedure Set_Next_Pragma + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Node1 (N, Val); -- semantic field, no parent set + end Set_Next_Pragma; + procedure Set_Next_Rep_Item (N : Node_Id; Val : Node_Id) is begin @@ -4923,6 +4965,14 @@ package body Sinfo is Set_Node4 (N, Val); -- semantic field, no parent set end Set_Parent_Spec; + procedure Set_PPC_Enabled + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag5 (N, Val); + end Set_PPC_Enabled; + procedure Set_Position (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 5c13146..edbd481 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -581,11 +581,11 @@ package Sinfo is -- elements. -- All_Others (Flag11-Sem) - -- Present in an N_Others_Choice node. This flag is set in the case of an - -- others exception where all exceptions are to be caught, even those - -- that are not normally handled (in particular the tasking abort - -- signal). This is used for translation of the at end handler into a - -- normal exception handler. + -- Present in an N_Others_Choice node. This flag is set for an others + -- exception where all exceptions are to be caught, even those that are + -- not normally handled (in particular the tasking abort signal). This + -- is used for translation of the at end handler into a normal exception + -- handler. -- Assignment_OK (Flag15-Sem) -- This flag is set in a subexpression node for an object, indicating @@ -596,32 +596,32 @@ package Sinfo is -- limited type objects (such as tasks), setting discriminant fields, -- setting tag values, etc. N_Object_Declaration nodes also have this -- flag defined. Here it is used to indicate that an initialization - -- expression is valid, even where it would normally not be allowed (e.g. - -- where the type involved is limited). + -- expression is valid, even where it would normally not be allowed + -- (e.g. where the type involved is limited). -- Associated_Node (Node4-Sem) -- Present in nodes that can denote an entity: identifiers, character -- literals, operator symbols, expanded names, operator nodes, and - -- attribute reference nodes (all these nodes have an Entity field). This - -- field is also present in N_Aggregate, N_Selected_Component, and + -- attribute reference nodes (all these nodes have an Entity field). + -- This field is also present in N_Aggregate, N_Selected_Component, and -- N_Extension_Aggregate nodes. This field is used in generic processing - -- to create links between the generic template and the generic copy. See - -- Sem_Ch12.Get_Associated_Node for full details. Note that this field - -- overlaps Entity, which is fine, since, as explained in Sem_Ch12, the - -- normal function of Entity is not required at the point where the + -- to create links between the generic template and the generic copy. + -- See Sem_Ch12.Get_Associated_Node for full details. Note that this + -- field overlaps Entity, which is fine, since, as explained in Sem_Ch12, + -- the normal function of Entity is not required at the point where the -- Associated_Node is set. Note also, that in generic templates, this -- means that the Entity field does not necessarily point to an Entity. -- Since the back end is expected to ignore generic templates, this is -- harmless. -- At_End_Proc (Node1) - -- This field is present in an N_Handled_Sequence_Of_Statements node. It - -- contains an identifier reference for the cleanup procedure to be + -- This field is present in an N_Handled_Sequence_Of_Statements node. + -- It contains an identifier reference for the cleanup procedure to be -- called. See description of this node for further details. -- Backwards_OK (Flag6-Sem) - -- A flag present in the N_Assignment_Statement node. It is used only if - -- the type being assigned is an array type, and is set if analysis + -- A flag present in the N_Assignment_Statement node. It is used only + -- if the type being assigned is an array type, and is set if analysis -- determines that it is definitely safe to do the copy backwards, i.e. -- starting at the highest addressed element. Note that if neither of the -- flags Forwards_OK or Backwards_OK is set, it means that the front end @@ -637,8 +637,8 @@ package Sinfo is -- which is used directly in later calls to the original subprogram. -- Body_Required (Flag13-Sem) - -- A flag that appears in the N_Compilation_Unit node indicating that the - -- corresponding unit requires a body. For the package case, this + -- A flag that appears in the N_Compilation_Unit node indicating that + -- the corresponding unit requires a body. For the package case, this -- indicates that a completion is required. In Ada 95, if the flag is not -- set for the package case, then a body may not be present. In Ada 83, -- if the flag is not set for the package case, then body is optional. @@ -647,10 +647,9 @@ package Sinfo is -- permitted (in Ada 83 or Ada 95). -- By_Ref (Flag5-Sem) - -- A flag present in N_Simple_Return_Statement and - -- N_Extended_Return_Statement. - -- It is set when the returned expression is already allocated on the - -- secondary stack and thus the result is passed by reference rather + -- Present in N_Simple_Return_Statement and N_Extended_Return_Statement, + -- this flag is set when the returned expression is already allocated on + -- the secondary stack and thus the result is passed by reference rather -- than copied another time. -- Check_Address_Alignment (Flag11-Sem) @@ -668,8 +667,8 @@ package Sinfo is -- Comes_From_Extended_Return_Statement (Flag18-Sem) -- Present in N_Simple_Return_Statement nodes. True if this node was - -- constructed as part of the expansion of an - -- N_Extended_Return_Statement. + -- constructed as part of the N_Extended_Return_Statement expansion. + -- . -- Compile_Time_Known_Aggregate (Flag18-Sem) -- Present in N_Aggregate nodes. Set for aggregates which can be fully @@ -681,28 +680,28 @@ package Sinfo is -- Condition_Actions (List3-Sem) -- This field appears in else-if nodes and in the iteration scheme node -- for while loops. This field is only used during semantic processing to - -- temporarily hold actions inserted into the tree. In the tree passed to - -- gigi, the condition actions field is always set to No_List. For + -- temporarily hold actions inserted into the tree. In the tree passed + -- to gigi, the condition actions field is always set to No_List. For -- details on how this field is used, see the routine Insert_Actions in -- package Exp_Util, and also the expansion routines for the relevant -- nodes. -- Controlling_Argument (Node1-Sem) - -- This field is set in procedure and function call nodes if the call is - -- a dispatching call (it is Empty for a non-dispatching call). It + -- This field is set in procedure and function call nodes if the call + -- is a dispatching call (it is Empty for a non-dispatching call). It -- indicates the source of the call's controlling tag. For procedure -- calls, the Controlling_Argument is one of the actuals. For function -- that has a dispatching result, it is an entity in the context of the - -- call that can provide a tag, or else it is the tag of the root type of - -- the class. It can also specify a tag directly rather than being a + -- call that can provide a tag, or else it is the tag of the root type + -- of the class. It can also specify a tag directly rather than being a -- tagged object. The latter is needed by the implementations of AI-239 -- and AI-260. -- Conversion_OK (Flag14-Sem) - -- A flag set on type conversion nodes to indicate that the conversion is - -- to be considered as being valid, even though it is the case that the - -- conversion is not valid Ada. This is used for Enum_Rep, Fixed_Value - -- and Integer_Value attributes, for internal conversions done for + -- A flag set on type conversion nodes to indicate that the conversion + -- is to be considered as being valid, even though it is the case that + -- the conversion is not valid Ada. This is used for attributes Enum_Rep, + -- Fixed_Value and Integer_Value, for internal conversions done for -- fixed-point operations, and for certain conversions for calls to -- initialization procedures. If Conversion_OK is set, then Etype must be -- set (the analyzer assumes that Etype has been set). For the case of @@ -740,11 +739,11 @@ package Sinfo is -- Corresponding_Spec (Node5-Sem) -- This field is set in subprogram, package, task, and protected body -- nodes, where it points to the defining entity in the corresponding - -- spec. The attribute is also set in N_With_Clause nodes, where it - -- points to the defining entity for the with'ed spec, and in a - -- subprogram renaming declaration when it is a Renaming_As_Body. The - -- field is Empty if there is no corresponding spec, as in the case of a - -- subprogram body that serves as its own spec. + -- spec. The attribute is also set in N_With_Clause nodes where it points + -- to the defining entity for the with'ed spec, and in a subprogram + -- renaming declaration when it is a Renaming_As_Body. The field is Empty + -- if there is no corresponding spec, as in the case of a subprogram body + -- that serves as its own spec. -- Corresponding_Stub (Node3-Sem) -- This field is present in an N_Subunit node. It holds the node in @@ -812,10 +811,9 @@ package Sinfo is -- range. -- Do_Range_Check (Flag9-Sem) - -- This flag is set on an expression which appears in a context where - -- a range check is required. The target type is clear from the - -- context. The contexts in which this flag can appear are limited to - -- the following. + -- This flag is set on an expression which appears in a context where a + -- range check is required. The target type is clear from the context. + -- The contexts in which this flag can appear are the following: -- Right side of an assignment. In this case the target type is -- taken from the left side of the assignment, which is referenced @@ -885,11 +883,11 @@ package Sinfo is -- desirable for correct elaboration for this unit. -- Elaboration_Boolean (Node2-Sem) - -- This field is present in function and procedure specification - -- nodes. If set, it points to the entity for a Boolean flag that - -- must be tested for certain calls to check for access before - -- elaboration. See body of Sem_Elab for further details. This - -- field is Empty if no elaboration boolean is required. + -- This field is present in function and procedure specification nodes. + -- If set, it points to the entity for a Boolean flag that must be tested + -- for certain calls to check for access before elaboration. See body of + -- Sem_Elab for further details. This field is Empty if no elaboration + -- boolean is required. -- Else_Actions (List3-Sem) -- This field is present in conditional expression nodes. During code @@ -903,10 +901,10 @@ package Sinfo is -- always set to No_List. -- Enclosing_Variant (Node2-Sem) - -- This field is present in the N_Variant node and identifies the - -- Node_Id corresponding to the immediately enclosing variant when - -- the variant is nested, and N_Empty otherwise. Set during semantic - -- processing of the variant part of a record type. + -- This field is present in the N_Variant node and identifies the Node_Id + -- corresponding to the immediately enclosing variant when the variant is + -- nested, and N_Empty otherwise. Set during semantic processing of the + -- variant part of a record type. -- Entity (Node4-Sem) -- Appears in all direct names (identifiers, character literals, and @@ -989,11 +987,11 @@ package Sinfo is -- left-hand side of individual assignment to each sub-component. -- First_Inlined_Subprogram (Node3-Sem) - -- Present in the N_Compilation_Unit node for the main program. Points to - -- a chain of entities for subprograms that are to be inlined. The + -- Present in the N_Compilation_Unit node for the main program. Points + -- to a chain of entities for subprograms that are to be inlined. The -- Next_Inlined_Subprogram field of these entities is used as a link - -- pointer with Empty marking the end of the list. This field is Empty if - -- there are no inlined subprograms or inlining is not active. + -- pointer with Empty marking the end of the list. This field is Empty + -- if there are no inlined subprograms or inlining is not active. -- First_Named_Actual (Node4-Sem) -- Present in procedure call statement and function call nodes, and also @@ -1014,8 +1012,8 @@ package Sinfo is -- First_Subtype_Link (Node5-Sem) -- Present in N_Freeze_Entity node for an anonymous base type that is - -- implicitly created by the declaration of a first subtype. It points to - -- the entity for the first subtype. + -- implicitly created by the declaration of a first subtype. It points + -- to the entity for the first subtype. -- Float_Truncate (Flag11-Sem) -- A flag present in type conversion nodes. This is used for float to @@ -1024,8 +1022,8 @@ package Sinfo is -- with rounding (see Expand_N_Type_Conversion). -- Forwards_OK (Flag5-Sem) - -- A flag present in the N_Assignment_Statement node. It is used only if - -- the type being assigned is an array type, and is set if analysis + -- A flag present in the N_Assignment_Statement node. It is used only + -- if the type being assigned is an array type, and is set if analysis -- determines that it is definitely safe to do the copy forwards, i.e. -- starting at the lowest addressed element. Note that if neither of the -- flags Forwards_OK or Backwards_OK is set, it means that the front end @@ -1103,6 +1101,10 @@ package Sinfo is -- declarations if the visibility at instantiation is different from the -- visibility at generic definition. + -- Has_Relative_Deadline_Pragma (Flag9-Sem) + -- A flag present in N_Subprogram_Body and N_Task_Definition nodes to + -- flag the presence of a pragma Relative_Deadline. + -- Has_Self_Reference (Flag13-Sem) -- Present in N_Aggregate and N_Extension_Aggregate. Indicates that one -- of the expressions contains an access attribute reference to the @@ -1365,6 +1367,17 @@ package Sinfo is -- points to the explicit actual parameter itself, not to the -- N_Parameter_Association node (its parent). + -- Next_Pragma (Node1-Sem) + -- Present in N_Pragma nodes. Used to create a linked list of pragma + -- nodes. Curently used for two purposes: + -- + -- Create a list of linked Check_Policy pragmas. The head of this list + -- is stored in Opt.Check_Policy_List (which has further details). + -- + -- Used by processing for Pre/Postcondition pragmas to store a list of + -- pragmas associated with the spec of a subprogram (see Sem_Prag for + -- details). + -- Next_Rep_Item (Node5-Sem) -- Present in pragma nodes and attribute definition nodes. Used to link -- representation items that apply to an entity. See description of @@ -1467,6 +1480,11 @@ package Sinfo is -- package specification. This field is Empty for library bodies (the -- parent spec in this case can be found from the corresponding spec). + -- PPC_Enabled (Flag5-Sem) + -- Present in N_Pragma nodes. This flag is relevant only for precondition + -- and postcondition nodes. It is true if the check corresponding to the + -- pragma type is enabled at the point where the pragma appears. + -- Present_Expr (Uint3-Sem) -- Present in an N_Variant node. This has a meaningful value only after -- Gigi has back annotated the tree with representation information. At @@ -1883,10 +1901,12 @@ package Sinfo is -- N_Pragma -- Sloc points to pragma identifier + -- Next_Pragma (Node1-Sem) -- Pragma_Argument_Associations (List2) (set to No_List if none) -- Debug_Statement (Node3) (set to Empty if not Debug, Assert) -- Pragma_Identifier (Node4) -- Next_Rep_Item (Node5-Sem) + -- PPC_Enabled (Flag5-Sem) -- Note: we should have a section on what pragmas are passed on to -- the back end to be processed. This section should note that pragma @@ -4274,6 +4294,7 @@ package Sinfo is -- Is_Entry_Barrier_Function (Flag8-Sem) -- Is_Task_Master (Flag5-Sem) -- Was_Originally_Stub (Flag13-Sem) + -- Has_Relative_Deadline_Pragma (Flag9-Sem) ----------------------------------- -- 6.4 Procedure Call Statement -- @@ -4730,6 +4751,7 @@ package Sinfo is -- Has_Storage_Size_Pragma (Flag5-Sem) -- Has_Task_Info_Pragma (Flag7-Sem) -- Has_Task_Name_Pragma (Flag8-Sem) + -- Has_Relative_Deadline_Pragma (Flag9-Sem) -------------------- -- 9.1 Task Item -- @@ -7130,7 +7152,7 @@ package Sinfo is N_Null_Statement, N_Raise_Statement, N_Requeue_Statement, - N_Return_Statement, -- renamed as N_Simple_Return_Statement in Sem_Util + N_Return_Statement, -- renamed as N_Simple_Return_Statement below N_Extended_Return_Statement, N_Selective_Accept, N_Timed_Entry_Call, @@ -7848,6 +7870,9 @@ package Sinfo is function Has_Private_View (N : Node_Id) return Boolean; -- Flag11 + function Has_Relative_Deadline_Pragma + (N : Node_Id) return Boolean; -- Flag9 + function Has_Self_Reference (N : Node_Id) return Boolean; -- Flag13 @@ -8028,6 +8053,9 @@ package Sinfo is function Next_Named_Actual (N : Node_Id) return Node_Id; -- Node4 + function Next_Pragma + (N : Node_Id) return Node_Id; -- Node1 + function Next_Rep_Item (N : Node_Id) return Node_Id; -- Node5 @@ -8088,6 +8116,9 @@ package Sinfo is function Parent_Spec (N : Node_Id) return Node_Id; -- Node4 + function PPC_Enabled + (N : Node_Id) return Boolean; -- Flag5 + function Position (N : Node_Id) return Node_Id; -- Node2 @@ -8718,6 +8749,9 @@ package Sinfo is procedure Set_Has_Private_View (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Has_Relative_Deadline_Pragma + (N : Node_Id; Val : Boolean := True); -- Flag9 + procedure Set_Has_Self_Reference (N : Node_Id; Val : Boolean := True); -- Flag13 @@ -8898,6 +8932,9 @@ package Sinfo is procedure Set_Next_Named_Actual (N : Node_Id; Val : Node_Id); -- Node4 + procedure Set_Next_Pragma + (N : Node_Id; Val : Node_Id); -- Node1 + procedure Set_Next_Rep_Item (N : Node_Id; Val : Node_Id); -- Node5 @@ -8958,6 +8995,9 @@ package Sinfo is procedure Set_Parent_Spec (N : Node_Id; Val : Node_Id); -- Node4 + procedure Set_PPC_Enabled + (N : Node_Id; Val : Boolean := True); -- Flag5 + procedure Set_Position (N : Node_Id; Val : Node_Id); -- Node2 @@ -9304,7 +9344,7 @@ package Sinfo is 5 => False), -- Etype (Node5-Sem) N_Pragma => - (1 => True, -- Chars (Name1) + (1 => False, -- Next_Pragma (Node1-Sem) 2 => True, -- Pragma_Argument_Associations (List2) 3 => True, -- Debug_Statement (Node3) 4 => True, -- Pragma_Identifier (Node4) @@ -10941,6 +10981,7 @@ package Sinfo is pragma Inline (Has_No_Elaboration_Code); pragma Inline (Has_Priority_Pragma); pragma Inline (Has_Private_View); + pragma Inline (Has_Relative_Deadline_Pragma); pragma Inline (Has_Storage_Size_Pragma); pragma Inline (Has_Task_Info_Pragma); pragma Inline (Has_Task_Name_Pragma); @@ -11000,6 +11041,7 @@ package Sinfo is pragma Inline (Names); pragma Inline (Next_Entity); pragma Inline (Next_Named_Actual); + pragma Inline (Next_Pragma); pragma Inline (Next_Rep_Item); pragma Inline (Next_Use_Clause); pragma Inline (No_Ctrl_Actions); @@ -11020,6 +11062,7 @@ package Sinfo is pragma Inline (Parameter_List_Truncated); pragma Inline (Parameter_Type); pragma Inline (Parent_Spec); + pragma Inline (PPC_Enabled); pragma Inline (Position); pragma Inline (Pragma_Argument_Associations); pragma Inline (Pragma_Identifier); @@ -11227,6 +11270,7 @@ package Sinfo is pragma Inline (Set_Has_No_Elaboration_Code); pragma Inline (Set_Has_Priority_Pragma); pragma Inline (Set_Has_Private_View); + pragma Inline (Set_Has_Relative_Deadline_Pragma); pragma Inline (Set_Has_Storage_Size_Pragma); pragma Inline (Set_Has_Task_Info_Pragma); pragma Inline (Set_Has_Task_Name_Pragma); @@ -11287,6 +11331,8 @@ package Sinfo is pragma Inline (Set_Names); pragma Inline (Set_Next_Entity); pragma Inline (Set_Next_Named_Actual); + pragma Inline (Set_Next_Pragma); + pragma Inline (Set_Next_Rep_Item); pragma Inline (Set_Next_Use_Clause); pragma Inline (Set_No_Ctrl_Actions); pragma Inline (Set_No_Elaboration_Check); @@ -11306,6 +11352,7 @@ package Sinfo is pragma Inline (Set_Parameter_List_Truncated); pragma Inline (Set_Parameter_Type); pragma Inline (Set_Parent_Spec); + pragma Inline (Set_PPC_Enabled); pragma Inline (Set_Position); pragma Inline (Set_Pragma_Argument_Associations); pragma Inline (Set_Pragma_Identifier); diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index bafde45..957dfae 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -221,8 +221,6 @@ package body Sinput is Ptr : Source_Ptr; begin - Name_Len := 0; - -- Loop through instantiations Ptr := Loc; @@ -765,17 +763,20 @@ package body Sinput is null; else + -- Free the buffer, we use Free here, because we used malloc + -- or realloc directly to allocate the tables. That is + -- because we were playing the big array trick. We need to + -- suppress the warning for freeing from an empty pool! + -- We have to recreate a proper pointer to the actual array -- from the zero origin pointer stored in the source table. Tmp1 := To_Source_Buffer_Ptr (S.Source_Text (S.Source_First)'Address); + pragma Warnings (Off); Free_Ptr (Tmp1); - - -- Note: we are using free here, because we used malloc - -- or realloc directly to allocate the tables. That is - -- because we were playing the big array trick. + pragma Warnings (On); if S.Lines_Table /= null then Memory.Free (To_Address (S.Lines_Table)); diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index db240ff..90c54f5 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -465,13 +465,13 @@ package Sinput is -- that there definitely is a previous line in the source buffer. procedure Build_Location_String (Loc : Source_Ptr); - -- This function builds a string literal of the form "name:line", - -- where name is the file name corresponding to Loc, and line is - -- the line number. In the event that instantiations are involved, - -- additional suffixes of the same form are appended after the - -- separating string " instantiated at ". The returned string is - -- stored in Name_Buffer, terminated by ASCII.Nul, with Name_Length - -- indicating the length not including the terminating Nul. + -- This function builds a string literal of the form "name:line", where + -- name is the file name corresponding to Loc, and line is the line number. + -- In the event that instantiations are involved, additional suffixes of + -- the same form are appended after the separating string " instantiated at + -- ". The returned string is appended to the Name_Buffer, terminated by + -- ASCII.NUL, with Name_Length indicating the length not including the + -- terminating Nul. function Get_Column_Number (P : Source_Ptr) return Column_Number; -- The ones-origin column number of the specified Source_Ptr value is diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 95fc9b1..3132f23 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -78,8 +78,11 @@ package body Snames is "_local_final_list#" & "_master#" & "_object#" & + "_postconditions#" & "_priority#" & "_process_atsd#" & + "_relative_deadline#" & + "_result#" & "_secondary_stack#" & "_service#" & "_size#" & @@ -145,7 +148,6 @@ package body Snames is "_call#" & "rci_name#" & "receiver#" & - "result#" & "rpc#" & "subp_id#" & "operation#" & @@ -182,6 +184,7 @@ package body Snames is "assertion_policy#" & "c_pass_by_copy#" & "check_name#" & + "check_policy#" & "compile_time_error#" & "compile_time_warning#" & "compiler_unit#" & @@ -207,8 +210,8 @@ package body Snames is "no_strict_aliasing#" & "normalize_scalars#" & "optimize_alignment#" & - "polling#" & "persistent_bss#" & + "polling#" & "priority_specific_dispatching#" & "profile#" & "profile_warnings#" & @@ -239,6 +242,7 @@ package body Snames is "atomic#" & "atomic_components#" & "attach_handler#" & + "check#" & "cil_constructor#" & "comment#" & "common_object#" & @@ -299,6 +303,8 @@ package body Snames is "pack#" & "page#" & "passive#" & + "postcondition#" & + "precondition#" & "preelaborable_initialization#" & "preelaborate#" & "preelaborate_05#" & @@ -306,6 +312,7 @@ package body Snames is "pure#" & "pure_05#" & "pure_function#" & + "relative_deadline#" & "remote_call_interface#" & "remote_types#" & "share_generic#" & @@ -351,10 +358,10 @@ package body Snames is "dll#" & "win32#" & "as_is#" & + "assertion#" & "attribute_name#" & "body_file_name#" & "boolean_entry_barriers#" & - "check#" & "casing#" & "code#" & "component#" & @@ -458,6 +465,7 @@ package body Snames is "emax#" & "enabled#" & "enum_rep#" & + "enum_val#" & "epsilon#" & "exponent#" & "external_tag#" & @@ -468,9 +476,11 @@ package body Snames is "fore#" & "has_access_values#" & "has_discriminants#" & + "has_tagged_values#" & "identity#" & "img#" & "integer_value#" & + "invalid_value#" & "large#" & "last#" & "last_bit#" & @@ -505,6 +515,7 @@ package body Snames is "priority#" & "range#" & "range_length#" & + "result#" & "round#" & "safe_emax#" & "safe_first#" & @@ -576,6 +587,7 @@ package body Snames is "priority_queuing#" & "edf_across_priorities#" & "fifo_within_priorities#" & + "non_preemptive_within_priorities#" & "round_robin_within_priorities#" & "access_check#" & "accessibility_check#" & @@ -679,7 +691,9 @@ package body Snames is "tagged#" & "raise_exception#" & "ada_roots#" & + "aggregate#" & "archive_builder#" & + "archive_builder_append_option#" & "archive_indexer#" & "archive_suffix#" & "binder#" & @@ -695,6 +709,7 @@ package body Snames is "config_file_unique#" & "config_spec_file_name#" & "config_spec_file_name_pattern#" & + "configuration#" & "cross_reference#" & "default_language#" & "default_switches#" & @@ -720,9 +735,11 @@ package body Snames is "include_switches#" & "include_path#" & "include_path_file#" & + "inherit_source_path#" & "language_kind#" & "language_processing#" & "languages#" & + "library#" & "library_ali_dir#" & "library_auto_init#" & "library_auto_init_supported#" & @@ -941,6 +958,8 @@ package body Snames is return Pragma_Interface; elsif N = Name_Priority then return Pragma_Priority; + elsif N = Name_Relative_Deadline then + return Pragma_Relative_Deadline; elsif N = Name_Storage_Size then return Pragma_Storage_Size; elsif N = Name_Storage_Unit then @@ -1130,6 +1149,7 @@ package body Snames is or else N = Name_AST_Entry or else N = Name_Fast_Math or else N = Name_Interface + or else N = Name_Relative_Deadline or else N = Name_Priority or else N = Name_Storage_Size or else N = Name_Storage_Unit; diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 6a6d0ce..696603a 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -161,152 +161,154 @@ package Snames is Name_uLocal_Final_List : constant Name_Id := N + 017; Name_uMaster : constant Name_Id := N + 018; Name_uObject : constant Name_Id := N + 019; - Name_uPriority : constant Name_Id := N + 020; - Name_uProcess_ATSD : constant Name_Id := N + 021; - Name_uSecondary_Stack : constant Name_Id := N + 022; - Name_uService : constant Name_Id := N + 023; - Name_uSize : constant Name_Id := N + 024; - Name_uStack : constant Name_Id := N + 025; - Name_uTags : constant Name_Id := N + 026; - Name_uTask : constant Name_Id := N + 027; - Name_uTask_Id : constant Name_Id := N + 028; - Name_uTask_Info : constant Name_Id := N + 029; - Name_uTask_Name : constant Name_Id := N + 030; - Name_uTrace_Sp : constant Name_Id := N + 031; + Name_uPostconditions : constant Name_Id := N + 020; + Name_uPriority : constant Name_Id := N + 021; + Name_uProcess_ATSD : constant Name_Id := N + 022; + Name_uRelative_Deadline : constant Name_Id := N + 023; + Name_uResult : constant Name_Id := N + 024; + Name_uSecondary_Stack : constant Name_Id := N + 025; + Name_uService : constant Name_Id := N + 026; + Name_uSize : constant Name_Id := N + 027; + Name_uStack : constant Name_Id := N + 028; + Name_uTags : constant Name_Id := N + 029; + Name_uTask : constant Name_Id := N + 030; + Name_uTask_Id : constant Name_Id := N + 031; + Name_uTask_Info : constant Name_Id := N + 032; + Name_uTask_Name : constant Name_Id := N + 033; + Name_uTrace_Sp : constant Name_Id := N + 034; -- Names of predefined primitives used in the expansion of dispatching -- requeue and select statements, Abort, 'Callable and 'Terminated. - Name_uDisp_Asynchronous_Select : constant Name_Id := N + 032; - Name_uDisp_Conditional_Select : constant Name_Id := N + 033; - Name_uDisp_Get_Prim_Op_Kind : constant Name_Id := N + 034; - Name_uDisp_Get_Task_Id : constant Name_Id := N + 035; - Name_uDisp_Requeue : constant Name_Id := N + 036; - Name_uDisp_Timed_Select : constant Name_Id := N + 037; + Name_uDisp_Asynchronous_Select : constant Name_Id := N + 035; + Name_uDisp_Conditional_Select : constant Name_Id := N + 036; + Name_uDisp_Get_Prim_Op_Kind : constant Name_Id := N + 037; + Name_uDisp_Get_Task_Id : constant Name_Id := N + 038; + Name_uDisp_Requeue : constant Name_Id := N + 039; + Name_uDisp_Timed_Select : constant Name_Id := N + 040; -- Names of routines in Ada.Finalization, needed by expander - Name_Initialize : constant Name_Id := N + 038; - Name_Adjust : constant Name_Id := N + 039; - Name_Finalize : constant Name_Id := N + 040; + Name_Initialize : constant Name_Id := N + 041; + Name_Adjust : constant Name_Id := N + 042; + Name_Finalize : constant Name_Id := N + 043; -- Names of fields declared in System.Finalization_Implementation, -- needed by the expander when generating code for finalization. - Name_Next : constant Name_Id := N + 041; - Name_Prev : constant Name_Id := N + 042; + Name_Next : constant Name_Id := N + 044; + Name_Prev : constant Name_Id := N + 045; -- Names of TSS routines for implementation of DSA over PolyORB - Name_uTypeCode : constant Name_Id := N + 043; - Name_uFrom_Any : constant Name_Id := N + 044; - Name_uTo_Any : constant Name_Id := N + 045; + Name_uTypeCode : constant Name_Id := N + 046; + Name_uFrom_Any : constant Name_Id := N + 047; + Name_uTo_Any : constant Name_Id := N + 048; -- Names of allocation routines, also needed by expander - Name_Allocate : constant Name_Id := N + 046; - Name_Deallocate : constant Name_Id := N + 047; - Name_Dereference : constant Name_Id := N + 048; + Name_Allocate : constant Name_Id := N + 049; + Name_Deallocate : constant Name_Id := N + 050; + Name_Dereference : constant Name_Id := N + 051; -- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge) - First_Text_IO_Package : constant Name_Id := N + 049; - Name_Decimal_IO : constant Name_Id := N + 049; - Name_Enumeration_IO : constant Name_Id := N + 050; - Name_Fixed_IO : constant Name_Id := N + 051; - Name_Float_IO : constant Name_Id := N + 052; - Name_Integer_IO : constant Name_Id := N + 053; - Name_Modular_IO : constant Name_Id := N + 054; - Last_Text_IO_Package : constant Name_Id := N + 054; + First_Text_IO_Package : constant Name_Id := N + 052; + Name_Decimal_IO : constant Name_Id := N + 052; + Name_Enumeration_IO : constant Name_Id := N + 053; + Name_Fixed_IO : constant Name_Id := N + 054; + Name_Float_IO : constant Name_Id := N + 055; + Name_Integer_IO : constant Name_Id := N + 056; + Name_Modular_IO : constant Name_Id := N + 057; + Last_Text_IO_Package : constant Name_Id := N + 057; subtype Text_IO_Package_Name is Name_Id range First_Text_IO_Package .. Last_Text_IO_Package; -- Some miscellaneous names used for error detection/recovery - Name_Const : constant Name_Id := N + 055; - Name_Error : constant Name_Id := N + 056; - Name_Go : constant Name_Id := N + 057; - Name_Put : constant Name_Id := N + 058; - Name_Put_Line : constant Name_Id := N + 059; - Name_To : constant Name_Id := N + 060; + Name_Const : constant Name_Id := N + 058; + Name_Error : constant Name_Id := N + 059; + Name_Go : constant Name_Id := N + 060; + Name_Put : constant Name_Id := N + 061; + Name_Put_Line : constant Name_Id := N + 062; + Name_To : constant Name_Id := N + 063; -- Names for packages that are treated specially by the compiler - Name_Exception_Traces : constant Name_Id := N + 061; - Name_Finalization : constant Name_Id := N + 062; - Name_Finalization_Root : constant Name_Id := N + 063; - Name_Interfaces : constant Name_Id := N + 064; - Name_Most_Recent_Exception : constant Name_Id := N + 065; - Name_Standard : constant Name_Id := N + 066; - Name_System : constant Name_Id := N + 067; - Name_Text_IO : constant Name_Id := N + 068; - Name_Wide_Text_IO : constant Name_Id := N + 069; - Name_Wide_Wide_Text_IO : constant Name_Id := N + 070; + Name_Exception_Traces : constant Name_Id := N + 064; + Name_Finalization : constant Name_Id := N + 065; + Name_Finalization_Root : constant Name_Id := N + 066; + Name_Interfaces : constant Name_Id := N + 067; + Name_Most_Recent_Exception : constant Name_Id := N + 068; + Name_Standard : constant Name_Id := N + 069; + Name_System : constant Name_Id := N + 070; + Name_Text_IO : constant Name_Id := N + 071; + Name_Wide_Text_IO : constant Name_Id := N + 072; + Name_Wide_Wide_Text_IO : constant Name_Id := N + 073; -- Names of implementations of the distributed systems annex - First_PCS_Name : constant Name_Id := N + 071; - Name_No_DSA : constant Name_Id := N + 071; - Name_GARLIC_DSA : constant Name_Id := N + 072; - Name_PolyORB_DSA : constant Name_Id := N + 073; - Last_PCS_Name : constant Name_Id := N + 073; + First_PCS_Name : constant Name_Id := N + 074; + Name_No_DSA : constant Name_Id := N + 074; + Name_GARLIC_DSA : constant Name_Id := N + 075; + Name_PolyORB_DSA : constant Name_Id := N + 076; + Last_PCS_Name : constant Name_Id := N + 076; subtype PCS_Names is Name_Id range First_PCS_Name .. Last_PCS_Name; -- Names of identifiers used in expanding distribution stubs - Name_Addr : constant Name_Id := N + 074; - Name_Async : constant Name_Id := N + 075; - Name_Get_Active_Partition_ID : constant Name_Id := N + 076; - Name_Get_RCI_Package_Receiver : constant Name_Id := N + 077; - Name_Get_RCI_Package_Ref : constant Name_Id := N + 078; - Name_Origin : constant Name_Id := N + 079; - Name_Params : constant Name_Id := N + 080; - Name_Partition : constant Name_Id := N + 081; - Name_Partition_Interface : constant Name_Id := N + 082; - Name_Ras : constant Name_Id := N + 083; - Name_uCall : constant Name_Id := N + 084; - Name_RCI_Name : constant Name_Id := N + 085; - Name_Receiver : constant Name_Id := N + 086; - Name_Result : constant Name_Id := N + 087; - Name_Rpc : constant Name_Id := N + 088; - Name_Subp_Id : constant Name_Id := N + 089; - Name_Operation : constant Name_Id := N + 090; - Name_Argument : constant Name_Id := N + 091; - Name_Arg_Modes : constant Name_Id := N + 092; - Name_Handler : constant Name_Id := N + 093; - Name_Target : constant Name_Id := N + 094; - Name_Req : constant Name_Id := N + 095; - Name_Obj_TypeCode : constant Name_Id := N + 096; - Name_Stub : constant Name_Id := N + 097; + Name_Addr : constant Name_Id := N + 077; + Name_Async : constant Name_Id := N + 078; + Name_Get_Active_Partition_ID : constant Name_Id := N + 079; + Name_Get_RCI_Package_Receiver : constant Name_Id := N + 080; + Name_Get_RCI_Package_Ref : constant Name_Id := N + 081; + Name_Origin : constant Name_Id := N + 082; + Name_Params : constant Name_Id := N + 083; + Name_Partition : constant Name_Id := N + 084; + Name_Partition_Interface : constant Name_Id := N + 085; + Name_Ras : constant Name_Id := N + 086; + Name_uCall : constant Name_Id := N + 087; + Name_RCI_Name : constant Name_Id := N + 088; + Name_Receiver : constant Name_Id := N + 089; + Name_Rpc : constant Name_Id := N + 090; + Name_Subp_Id : constant Name_Id := N + 091; + Name_Operation : constant Name_Id := N + 092; + Name_Argument : constant Name_Id := N + 093; + Name_Arg_Modes : constant Name_Id := N + 094; + Name_Handler : constant Name_Id := N + 095; + Name_Target : constant Name_Id := N + 096; + Name_Req : constant Name_Id := N + 097; + Name_Obj_TypeCode : constant Name_Id := N + 098; + Name_Stub : constant Name_Id := N + 099; -- Operator Symbol entries. The actual names have an upper case O at -- the start in place of the Op_ prefix (e.g. the actual name that -- corresponds to Name_Op_Abs is "Oabs". - First_Operator_Name : constant Name_Id := N + 098; - Name_Op_Abs : constant Name_Id := N + 098; -- "abs" - Name_Op_And : constant Name_Id := N + 099; -- "and" - Name_Op_Mod : constant Name_Id := N + 100; -- "mod" - Name_Op_Not : constant Name_Id := N + 101; -- "not" - Name_Op_Or : constant Name_Id := N + 102; -- "or" - Name_Op_Rem : constant Name_Id := N + 103; -- "rem" - Name_Op_Xor : constant Name_Id := N + 104; -- "xor" - Name_Op_Eq : constant Name_Id := N + 105; -- "=" - Name_Op_Ne : constant Name_Id := N + 106; -- "/=" - Name_Op_Lt : constant Name_Id := N + 107; -- "<" - Name_Op_Le : constant Name_Id := N + 108; -- "<=" - Name_Op_Gt : constant Name_Id := N + 109; -- ">" - Name_Op_Ge : constant Name_Id := N + 110; -- ">=" - Name_Op_Add : constant Name_Id := N + 111; -- "+" - Name_Op_Subtract : constant Name_Id := N + 112; -- "-" - Name_Op_Concat : constant Name_Id := N + 113; -- "&" - Name_Op_Multiply : constant Name_Id := N + 114; -- "*" - Name_Op_Divide : constant Name_Id := N + 115; -- "/" - Name_Op_Expon : constant Name_Id := N + 116; -- "**" - Last_Operator_Name : constant Name_Id := N + 116; + First_Operator_Name : constant Name_Id := N + 100; + Name_Op_Abs : constant Name_Id := N + 100; -- "abs" + Name_Op_And : constant Name_Id := N + 101; -- "and" + Name_Op_Mod : constant Name_Id := N + 102; -- "mod" + Name_Op_Not : constant Name_Id := N + 103; -- "not" + Name_Op_Or : constant Name_Id := N + 104; -- "or" + Name_Op_Rem : constant Name_Id := N + 105; -- "rem" + Name_Op_Xor : constant Name_Id := N + 106; -- "xor" + Name_Op_Eq : constant Name_Id := N + 107; -- "=" + Name_Op_Ne : constant Name_Id := N + 108; -- "/=" + Name_Op_Lt : constant Name_Id := N + 109; -- "<" + Name_Op_Le : constant Name_Id := N + 110; -- "<=" + Name_Op_Gt : constant Name_Id := N + 111; -- ">" + Name_Op_Ge : constant Name_Id := N + 112; -- ">=" + Name_Op_Add : constant Name_Id := N + 113; -- "+" + Name_Op_Subtract : constant Name_Id := N + 114; -- "-" + Name_Op_Concat : constant Name_Id := N + 115; -- "&" + Name_Op_Multiply : constant Name_Id := N + 116; -- "*" + Name_Op_Divide : constant Name_Id := N + 117; -- "/" + Name_Op_Expon : constant Name_Id := N + 118; -- "**" + Last_Operator_Name : constant Name_Id := N + 118; -- Names for all pragmas recognized by GNAT. The entries with the comment -- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95. @@ -329,31 +331,31 @@ package Snames is -- only in GNAT for the AAMP. They are ignored in other versions with -- appropriate warnings. - First_Pragma_Name : constant Name_Id := N + 117; + First_Pragma_Name : constant Name_Id := N + 119; -- Configuration pragmas are grouped at start - Name_Ada_83 : constant Name_Id := N + 117; -- GNAT - Name_Ada_95 : constant Name_Id := N + 118; -- GNAT - Name_Ada_05 : constant Name_Id := N + 119; -- GNAT - Name_Ada_2005 : constant Name_Id := N + 120; -- GNAT - Name_Assertion_Policy : constant Name_Id := N + 121; -- Ada 05 - Name_C_Pass_By_Copy : constant Name_Id := N + 122; -- GNAT - Name_Check_Name : constant Name_Id := N + 123; -- GNAT - Name_Compile_Time_Error : constant Name_Id := N + 124; -- GNAT - Name_Compile_Time_Warning : constant Name_Id := N + 125; -- GNAT - Name_Compiler_Unit : constant Name_Id := N + 126; -- GNAT - Name_Component_Alignment : constant Name_Id := N + 127; -- GNAT - Name_Convention_Identifier : constant Name_Id := N + 128; -- GNAT - Name_Debug_Policy : constant Name_Id := N + 129; -- GNAT - Name_Detect_Blocking : constant Name_Id := N + 130; -- Ada 05 - Name_Discard_Names : constant Name_Id := N + 131; - Name_Elaboration_Checks : constant Name_Id := N + 132; -- GNAT - Name_Eliminate : constant Name_Id := N + 133; -- GNAT - Name_Extend_System : constant Name_Id := N + 134; -- GNAT - Name_Extensions_Allowed : constant Name_Id := N + 135; -- GNAT - Name_External_Name_Casing : constant Name_Id := N + 136; -- GNAT - Name_Favor_Top_Level : constant Name_Id := N + 137; -- GNAT + Name_Ada_83 : constant Name_Id := N + 119; -- GNAT + Name_Ada_95 : constant Name_Id := N + 120; -- GNAT + Name_Ada_05 : constant Name_Id := N + 121; -- GNAT + Name_Ada_2005 : constant Name_Id := N + 122; -- GNAT + Name_Assertion_Policy : constant Name_Id := N + 123; -- Ada 05 + Name_C_Pass_By_Copy : constant Name_Id := N + 124; -- GNAT + Name_Check_Name : constant Name_Id := N + 125; -- GNAT + Name_Check_Policy : constant Name_Id := N + 126; -- GNAT + Name_Compile_Time_Error : constant Name_Id := N + 127; -- GNAT + Name_Compile_Time_Warning : constant Name_Id := N + 128; -- GNAT + Name_Compiler_Unit : constant Name_Id := N + 129; -- GNAT + Name_Component_Alignment : constant Name_Id := N + 130; -- GNAT + Name_Convention_Identifier : constant Name_Id := N + 131; -- GNAT + Name_Debug_Policy : constant Name_Id := N + 132; -- GNAT + Name_Detect_Blocking : constant Name_Id := N + 133; -- Ada 05 + Name_Discard_Names : constant Name_Id := N + 134; + Name_Elaboration_Checks : constant Name_Id := N + 135; -- GNAT + Name_Eliminate : constant Name_Id := N + 136; -- GNAT + Name_Extend_System : constant Name_Id := N + 137; -- GNAT + Name_Extensions_Allowed : constant Name_Id := N + 138; -- GNAT + Name_External_Name_Casing : constant Name_Id := N + 139; -- GNAT -- Note: Fast_Math is not in this list because its name matches -- GNAT -- the name of the corresponding attribute. However, it is @@ -361,48 +363,49 @@ package Snames is -- functions Get_Pragma_Id, Is_[Configuration_]Pragma_Id, and -- correctly recognize and process Fast_Math. - Name_Float_Representation : constant Name_Id := N + 138; -- GNAT - Name_Implicit_Packing : constant Name_Id := N + 139; -- GNAT - Name_Initialize_Scalars : constant Name_Id := N + 140; -- GNAT - Name_Interrupt_State : constant Name_Id := N + 141; -- GNAT - Name_License : constant Name_Id := N + 142; -- GNAT - Name_Locking_Policy : constant Name_Id := N + 143; - Name_Long_Float : constant Name_Id := N + 144; -- VMS - Name_No_Run_Time : constant Name_Id := N + 145; -- GNAT - Name_No_Strict_Aliasing : constant Name_Id := N + 146; -- GNAT - Name_Normalize_Scalars : constant Name_Id := N + 147; - Name_Optimize_Alignment : constant Name_Id := N + 148; -- GNAT - Name_Polling : constant Name_Id := N + 149; -- GNAT - Name_Persistent_BSS : constant Name_Id := N + 150; -- GNAT - Name_Priority_Specific_Dispatching : constant Name_Id := N + 151; -- Ada 05 - Name_Profile : constant Name_Id := N + 152; -- Ada 05 - Name_Profile_Warnings : constant Name_Id := N + 153; -- GNAT - Name_Propagate_Exceptions : constant Name_Id := N + 154; -- GNAT - Name_Queuing_Policy : constant Name_Id := N + 155; - Name_Ravenscar : constant Name_Id := N + 156; -- GNAT - Name_Restricted_Run_Time : constant Name_Id := N + 157; -- GNAT - Name_Restrictions : constant Name_Id := N + 158; - Name_Restriction_Warnings : constant Name_Id := N + 159; -- GNAT - Name_Reviewable : constant Name_Id := N + 160; - Name_Source_File_Name : constant Name_Id := N + 161; -- GNAT - Name_Source_File_Name_Project : constant Name_Id := N + 162; -- GNAT - Name_Style_Checks : constant Name_Id := N + 163; -- GNAT - Name_Suppress : constant Name_Id := N + 164; - Name_Suppress_Exception_Locations : constant Name_Id := N + 165; -- GNAT - Name_Task_Dispatching_Policy : constant Name_Id := N + 166; - Name_Universal_Data : constant Name_Id := N + 167; -- AAMP - Name_Unsuppress : constant Name_Id := N + 168; -- GNAT - Name_Use_VADS_Size : constant Name_Id := N + 169; -- GNAT - Name_Validity_Checks : constant Name_Id := N + 170; -- GNAT - Name_Warnings : constant Name_Id := N + 171; -- GNAT - Name_Wide_Character_Encoding : constant Name_Id := N + 172; -- GNAT - Last_Configuration_Pragma_Name : constant Name_Id := N + 172; + Name_Favor_Top_Level : constant Name_Id := N + 140; -- GNAT + Name_Float_Representation : constant Name_Id := N + 141; -- GNAT + Name_Implicit_Packing : constant Name_Id := N + 142; -- GNAT + Name_Initialize_Scalars : constant Name_Id := N + 143; -- GNAT + Name_Interrupt_State : constant Name_Id := N + 144; -- GNAT + Name_License : constant Name_Id := N + 145; -- GNAT + Name_Locking_Policy : constant Name_Id := N + 146; + Name_Long_Float : constant Name_Id := N + 147; -- VMS + Name_No_Run_Time : constant Name_Id := N + 148; -- GNAT + Name_No_Strict_Aliasing : constant Name_Id := N + 149; -- GNAT + Name_Normalize_Scalars : constant Name_Id := N + 150; + Name_Optimize_Alignment : constant Name_Id := N + 151; -- GNAT + Name_Persistent_BSS : constant Name_Id := N + 152; -- GNAT + Name_Polling : constant Name_Id := N + 153; -- GNAT + Name_Priority_Specific_Dispatching : constant Name_Id := N + 154; -- Ada 05 + Name_Profile : constant Name_Id := N + 155; -- Ada 05 + Name_Profile_Warnings : constant Name_Id := N + 156; -- GNAT + Name_Propagate_Exceptions : constant Name_Id := N + 157; -- GNAT + Name_Queuing_Policy : constant Name_Id := N + 158; + Name_Ravenscar : constant Name_Id := N + 159; -- GNAT + Name_Restricted_Run_Time : constant Name_Id := N + 160; -- GNAT + Name_Restrictions : constant Name_Id := N + 161; + Name_Restriction_Warnings : constant Name_Id := N + 162; -- GNAT + Name_Reviewable : constant Name_Id := N + 163; + Name_Source_File_Name : constant Name_Id := N + 164; -- GNAT + Name_Source_File_Name_Project : constant Name_Id := N + 165; -- GNAT + Name_Style_Checks : constant Name_Id := N + 166; -- GNAT + Name_Suppress : constant Name_Id := N + 167; + Name_Suppress_Exception_Locations : constant Name_Id := N + 168; -- GNAT + Name_Task_Dispatching_Policy : constant Name_Id := N + 169; + Name_Universal_Data : constant Name_Id := N + 170; -- AAMP + Name_Unsuppress : constant Name_Id := N + 171; -- GNAT + Name_Use_VADS_Size : constant Name_Id := N + 172; -- GNAT + Name_Validity_Checks : constant Name_Id := N + 173; -- GNAT + Name_Warnings : constant Name_Id := N + 174; -- GNAT + Name_Wide_Character_Encoding : constant Name_Id := N + 175; -- GNAT + Last_Configuration_Pragma_Name : constant Name_Id := N + 175; -- Remaining pragma names - Name_Abort_Defer : constant Name_Id := N + 173; -- GNAT - Name_All_Calls_Remote : constant Name_Id := N + 174; - Name_Annotate : constant Name_Id := N + 175; -- GNAT + Name_Abort_Defer : constant Name_Id := N + 176; -- GNAT + Name_All_Calls_Remote : constant Name_Id := N + 177; + Name_Annotate : constant Name_Id := N + 178; -- GNAT -- Note: AST_Entry is not in this list because its name matches -- VMS -- the name of the corresponding attribute. However, it is @@ -410,74 +413,77 @@ package Snames is -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize -- and process Name_AST_Entry. - Name_Assert : constant Name_Id := N + 176; -- Ada 05 - Name_Asynchronous : constant Name_Id := N + 177; - Name_Atomic : constant Name_Id := N + 178; - Name_Atomic_Components : constant Name_Id := N + 179; - Name_Attach_Handler : constant Name_Id := N + 180; - Name_CIL_Constructor : constant Name_Id := N + 181; -- GNAT - Name_Comment : constant Name_Id := N + 182; -- GNAT - Name_Common_Object : constant Name_Id := N + 183; -- GNAT - Name_Complete_Representation : constant Name_Id := N + 184; -- GNAT - Name_Complex_Representation : constant Name_Id := N + 185; -- GNAT - Name_Controlled : constant Name_Id := N + 186; - Name_Convention : constant Name_Id := N + 187; - Name_CPP_Class : constant Name_Id := N + 188; -- GNAT - Name_CPP_Constructor : constant Name_Id := N + 189; -- GNAT - Name_CPP_Virtual : constant Name_Id := N + 190; -- GNAT - Name_CPP_Vtable : constant Name_Id := N + 191; -- GNAT - Name_Debug : constant Name_Id := N + 192; -- GNAT - Name_Elaborate : constant Name_Id := N + 193; -- Ada 83 - Name_Elaborate_All : constant Name_Id := N + 194; - Name_Elaborate_Body : constant Name_Id := N + 195; - Name_Export : constant Name_Id := N + 196; - Name_Export_Exception : constant Name_Id := N + 197; -- VMS - Name_Export_Function : constant Name_Id := N + 198; -- GNAT - Name_Export_Object : constant Name_Id := N + 199; -- GNAT - Name_Export_Procedure : constant Name_Id := N + 200; -- GNAT - Name_Export_Value : constant Name_Id := N + 201; -- GNAT - Name_Export_Valued_Procedure : constant Name_Id := N + 202; -- GNAT - Name_External : constant Name_Id := N + 203; -- GNAT - Name_Finalize_Storage_Only : constant Name_Id := N + 204; -- GNAT - Name_Ident : constant Name_Id := N + 205; -- VMS - Name_Implemented_By_Entry : constant Name_Id := N + 206; -- Ada 05 - Name_Import : constant Name_Id := N + 207; - Name_Import_Exception : constant Name_Id := N + 208; -- VMS - Name_Import_Function : constant Name_Id := N + 209; -- GNAT - Name_Import_Object : constant Name_Id := N + 210; -- GNAT - Name_Import_Procedure : constant Name_Id := N + 211; -- GNAT - Name_Import_Valued_Procedure : constant Name_Id := N + 212; -- GNAT - Name_Inline : constant Name_Id := N + 213; - Name_Inline_Always : constant Name_Id := N + 214; -- GNAT - Name_Inline_Generic : constant Name_Id := N + 215; -- GNAT - Name_Inspection_Point : constant Name_Id := N + 216; - Name_Interface_Name : constant Name_Id := N + 217; -- GNAT - Name_Interrupt_Handler : constant Name_Id := N + 218; - Name_Interrupt_Priority : constant Name_Id := N + 219; - Name_Java_Constructor : constant Name_Id := N + 220; -- GNAT - Name_Java_Interface : constant Name_Id := N + 221; -- GNAT - Name_Keep_Names : constant Name_Id := N + 222; -- GNAT - Name_Link_With : constant Name_Id := N + 223; -- GNAT - Name_Linker_Alias : constant Name_Id := N + 224; -- GNAT - Name_Linker_Constructor : constant Name_Id := N + 225; -- GNAT - Name_Linker_Destructor : constant Name_Id := N + 226; -- GNAT - Name_Linker_Options : constant Name_Id := N + 227; - Name_Linker_Section : constant Name_Id := N + 228; -- GNAT - Name_List : constant Name_Id := N + 229; - Name_Machine_Attribute : constant Name_Id := N + 230; -- GNAT - Name_Main : constant Name_Id := N + 231; -- GNAT - Name_Main_Storage : constant Name_Id := N + 232; -- GNAT - Name_Memory_Size : constant Name_Id := N + 233; -- Ada 83 - Name_No_Body : constant Name_Id := N + 234; -- GNAT - Name_No_Return : constant Name_Id := N + 235; -- GNAT - Name_Obsolescent : constant Name_Id := N + 236; -- GNAT - Name_Optimize : constant Name_Id := N + 237; - Name_Pack : constant Name_Id := N + 238; - Name_Page : constant Name_Id := N + 239; - Name_Passive : constant Name_Id := N + 240; -- GNAT - Name_Preelaborable_Initialization : constant Name_Id := N + 241; -- Ada 05 - Name_Preelaborate : constant Name_Id := N + 242; - Name_Preelaborate_05 : constant Name_Id := N + 243; -- GNAT + Name_Assert : constant Name_Id := N + 179; -- Ada 05 + Name_Asynchronous : constant Name_Id := N + 180; + Name_Atomic : constant Name_Id := N + 181; + Name_Atomic_Components : constant Name_Id := N + 182; + Name_Attach_Handler : constant Name_Id := N + 183; + Name_Check : constant Name_Id := N + 184; -- GNAT + Name_CIL_Constructor : constant Name_Id := N + 185; -- GNAT + Name_Comment : constant Name_Id := N + 186; -- GNAT + Name_Common_Object : constant Name_Id := N + 187; -- GNAT + Name_Complete_Representation : constant Name_Id := N + 188; -- GNAT + Name_Complex_Representation : constant Name_Id := N + 189; -- GNAT + Name_Controlled : constant Name_Id := N + 190; + Name_Convention : constant Name_Id := N + 191; + Name_CPP_Class : constant Name_Id := N + 192; -- GNAT + Name_CPP_Constructor : constant Name_Id := N + 193; -- GNAT + Name_CPP_Virtual : constant Name_Id := N + 194; -- GNAT + Name_CPP_Vtable : constant Name_Id := N + 195; -- GNAT + Name_Debug : constant Name_Id := N + 196; -- GNAT + Name_Elaborate : constant Name_Id := N + 197; -- Ada 83 + Name_Elaborate_All : constant Name_Id := N + 198; + Name_Elaborate_Body : constant Name_Id := N + 199; + Name_Export : constant Name_Id := N + 200; + Name_Export_Exception : constant Name_Id := N + 201; -- VMS + Name_Export_Function : constant Name_Id := N + 202; -- GNAT + Name_Export_Object : constant Name_Id := N + 203; -- GNAT + Name_Export_Procedure : constant Name_Id := N + 204; -- GNAT + Name_Export_Value : constant Name_Id := N + 205; -- GNAT + Name_Export_Valued_Procedure : constant Name_Id := N + 206; -- GNAT + Name_External : constant Name_Id := N + 207; -- GNAT + Name_Finalize_Storage_Only : constant Name_Id := N + 208; -- GNAT + Name_Ident : constant Name_Id := N + 209; -- VMS + Name_Implemented_By_Entry : constant Name_Id := N + 210; -- Ada 05 + Name_Import : constant Name_Id := N + 211; + Name_Import_Exception : constant Name_Id := N + 212; -- VMS + Name_Import_Function : constant Name_Id := N + 213; -- GNAT + Name_Import_Object : constant Name_Id := N + 214; -- GNAT + Name_Import_Procedure : constant Name_Id := N + 215; -- GNAT + Name_Import_Valued_Procedure : constant Name_Id := N + 216; -- GNAT + Name_Inline : constant Name_Id := N + 217; + Name_Inline_Always : constant Name_Id := N + 218; -- GNAT + Name_Inline_Generic : constant Name_Id := N + 219; -- GNAT + Name_Inspection_Point : constant Name_Id := N + 220; + Name_Interface_Name : constant Name_Id := N + 221; -- GNAT + Name_Interrupt_Handler : constant Name_Id := N + 222; + Name_Interrupt_Priority : constant Name_Id := N + 223; + Name_Java_Constructor : constant Name_Id := N + 224; -- GNAT + Name_Java_Interface : constant Name_Id := N + 225; -- GNAT + Name_Keep_Names : constant Name_Id := N + 226; -- GNAT + Name_Link_With : constant Name_Id := N + 227; -- GNAT + Name_Linker_Alias : constant Name_Id := N + 228; -- GNAT + Name_Linker_Constructor : constant Name_Id := N + 229; -- GNAT + Name_Linker_Destructor : constant Name_Id := N + 230; -- GNAT + Name_Linker_Options : constant Name_Id := N + 231; + Name_Linker_Section : constant Name_Id := N + 232; -- GNAT + Name_List : constant Name_Id := N + 233; + Name_Machine_Attribute : constant Name_Id := N + 234; -- GNAT + Name_Main : constant Name_Id := N + 235; -- GNAT + Name_Main_Storage : constant Name_Id := N + 236; -- GNAT + Name_Memory_Size : constant Name_Id := N + 237; -- Ada 83 + Name_No_Body : constant Name_Id := N + 238; -- GNAT + Name_No_Return : constant Name_Id := N + 239; -- GNAT + Name_Obsolescent : constant Name_Id := N + 240; -- GNAT + Name_Optimize : constant Name_Id := N + 241; + Name_Pack : constant Name_Id := N + 242; + Name_Page : constant Name_Id := N + 243; + Name_Passive : constant Name_Id := N + 244; -- GNAT + Name_Postcondition : constant Name_Id := N + 245; -- GNAT + Name_Precondition : constant Name_Id := N + 246; -- GNAT + Name_Preelaborable_Initialization : constant Name_Id := N + 247; -- Ada 05 + Name_Preelaborate : constant Name_Id := N + 248; + Name_Preelaborate_05 : constant Name_Id := N + 249; -- GNAT -- Note: Priority is not in this list because its name matches -- the name of the corresponding attribute. However, it is @@ -485,15 +491,16 @@ package Snames is -- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize -- and process Priority. Priority is a standard Ada 95 pragma. - Name_Psect_Object : constant Name_Id := N + 244; -- VMS - Name_Pure : constant Name_Id := N + 245; - Name_Pure_05 : constant Name_Id := N + 246; -- GNAT - Name_Pure_Function : constant Name_Id := N + 247; -- GNAT - Name_Remote_Call_Interface : constant Name_Id := N + 248; - Name_Remote_Types : constant Name_Id := N + 249; - Name_Share_Generic : constant Name_Id := N + 250; -- GNAT - Name_Shared : constant Name_Id := N + 251; -- Ada 83 - Name_Shared_Passive : constant Name_Id := N + 252; + Name_Psect_Object : constant Name_Id := N + 250; -- VMS + Name_Pure : constant Name_Id := N + 251; + Name_Pure_05 : constant Name_Id := N + 252; -- GNAT + Name_Pure_Function : constant Name_Id := N + 253; -- GNAT + Name_Relative_Deadline : constant Name_Id := N + 254; -- Ada 05 + Name_Remote_Call_Interface : constant Name_Id := N + 255; + Name_Remote_Types : constant Name_Id := N + 256; + Name_Share_Generic : constant Name_Id := N + 257; -- GNAT + Name_Shared : constant Name_Id := N + 258; -- Ada 83 + Name_Shared_Passive : constant Name_Id := N + 259; -- Note: Storage_Size is not in this list because its name -- matches the name of the corresponding attribute. However, @@ -504,30 +511,30 @@ package Snames is -- Note: Storage_Unit is also omitted from the list because -- of a clash with an attribute name, and is treated similarly. - Name_Source_Reference : constant Name_Id := N + 253; -- GNAT - Name_Static_Elaboration_Desired : constant Name_Id := N + 254; -- GNAT - Name_Stream_Convert : constant Name_Id := N + 255; -- GNAT - Name_Subtitle : constant Name_Id := N + 256; -- GNAT - Name_Suppress_All : constant Name_Id := N + 257; -- GNAT - Name_Suppress_Debug_Info : constant Name_Id := N + 258; -- GNAT - Name_Suppress_Initialization : constant Name_Id := N + 259; -- GNAT - Name_System_Name : constant Name_Id := N + 260; -- Ada 83 - Name_Task_Info : constant Name_Id := N + 261; -- GNAT - Name_Task_Name : constant Name_Id := N + 262; -- GNAT - Name_Task_Storage : constant Name_Id := N + 263; -- VMS - Name_Time_Slice : constant Name_Id := N + 264; -- GNAT - Name_Title : constant Name_Id := N + 265; -- GNAT - Name_Unchecked_Union : constant Name_Id := N + 266; -- GNAT - Name_Unimplemented_Unit : constant Name_Id := N + 267; -- GNAT - Name_Universal_Aliasing : constant Name_Id := N + 268; -- GNAT - Name_Unmodified : constant Name_Id := N + 269; -- GNAT - Name_Unreferenced : constant Name_Id := N + 270; -- GNAT - Name_Unreferenced_Objects : constant Name_Id := N + 271; -- GNAT - Name_Unreserve_All_Interrupts : constant Name_Id := N + 272; -- GNAT - Name_Volatile : constant Name_Id := N + 273; - Name_Volatile_Components : constant Name_Id := N + 274; - Name_Weak_External : constant Name_Id := N + 275; -- GNAT - Last_Pragma_Name : constant Name_Id := N + 275; + Name_Source_Reference : constant Name_Id := N + 260; -- GNAT + Name_Static_Elaboration_Desired : constant Name_Id := N + 261; -- GNAT + Name_Stream_Convert : constant Name_Id := N + 262; -- GNAT + Name_Subtitle : constant Name_Id := N + 263; -- GNAT + Name_Suppress_All : constant Name_Id := N + 264; -- GNAT + Name_Suppress_Debug_Info : constant Name_Id := N + 265; -- GNAT + Name_Suppress_Initialization : constant Name_Id := N + 266; -- GNAT + Name_System_Name : constant Name_Id := N + 267; -- Ada 83 + Name_Task_Info : constant Name_Id := N + 268; -- GNAT + Name_Task_Name : constant Name_Id := N + 269; -- GNAT + Name_Task_Storage : constant Name_Id := N + 270; -- VMS + Name_Time_Slice : constant Name_Id := N + 271; -- GNAT + Name_Title : constant Name_Id := N + 272; -- GNAT + Name_Unchecked_Union : constant Name_Id := N + 273; -- GNAT + Name_Unimplemented_Unit : constant Name_Id := N + 274; -- GNAT + Name_Universal_Aliasing : constant Name_Id := N + 275; -- GNAT + Name_Unmodified : constant Name_Id := N + 276; -- GNAT + Name_Unreferenced : constant Name_Id := N + 277; -- GNAT + Name_Unreferenced_Objects : constant Name_Id := N + 278; -- GNAT + Name_Unreserve_All_Interrupts : constant Name_Id := N + 279; -- GNAT + Name_Volatile : constant Name_Id := N + 280; + Name_Volatile_Components : constant Name_Id := N + 281; + Name_Weak_External : constant Name_Id := N + 282; -- GNAT + Last_Pragma_Name : constant Name_Id := N + 282; -- Language convention names for pragma Convention/Export/Import/Interface -- Note that Name_C is not included in this list, since it was already @@ -538,119 +545,119 @@ package Snames is -- Entry and Protected, this is because these conventions cannot be -- specified by a pragma. - First_Convention_Name : constant Name_Id := N + 276; - Name_Ada : constant Name_Id := N + 276; - Name_Assembler : constant Name_Id := N + 277; - Name_CIL : constant Name_Id := N + 278; - Name_COBOL : constant Name_Id := N + 279; - Name_CPP : constant Name_Id := N + 280; - Name_Fortran : constant Name_Id := N + 281; - Name_Intrinsic : constant Name_Id := N + 282; - Name_Java : constant Name_Id := N + 283; - Name_Stdcall : constant Name_Id := N + 284; - Name_Stubbed : constant Name_Id := N + 285; - Last_Convention_Name : constant Name_Id := N + 285; + First_Convention_Name : constant Name_Id := N + 283; + Name_Ada : constant Name_Id := N + 283; + Name_Assembler : constant Name_Id := N + 284; + Name_CIL : constant Name_Id := N + 285; + Name_COBOL : constant Name_Id := N + 286; + Name_CPP : constant Name_Id := N + 287; + Name_Fortran : constant Name_Id := N + 288; + Name_Intrinsic : constant Name_Id := N + 289; + Name_Java : constant Name_Id := N + 290; + Name_Stdcall : constant Name_Id := N + 291; + Name_Stubbed : constant Name_Id := N + 292; + Last_Convention_Name : constant Name_Id := N + 292; -- The following names are preset as synonyms for Assembler - Name_Asm : constant Name_Id := N + 286; - Name_Assembly : constant Name_Id := N + 287; + Name_Asm : constant Name_Id := N + 293; + Name_Assembly : constant Name_Id := N + 294; -- The following names are preset as synonyms for C - Name_Default : constant Name_Id := N + 288; + Name_Default : constant Name_Id := N + 295; -- Name_Exernal (previously defined as pragma) -- The following names are preset as synonyms for CPP - Name_C_Plus_Plus : constant Name_Id := N + 289; + Name_C_Plus_Plus : constant Name_Id := N + 296; -- The following names are present as synonyms for Stdcall - Name_DLL : constant Name_Id := N + 290; - Name_Win32 : constant Name_Id := N + 291; + Name_DLL : constant Name_Id := N + 297; + Name_Win32 : constant Name_Id := N + 298; -- Other special names used in processing pragmas - Name_As_Is : constant Name_Id := N + 292; - Name_Attribute_Name : constant Name_Id := N + 293; - Name_Body_File_Name : constant Name_Id := N + 294; - Name_Boolean_Entry_Barriers : constant Name_Id := N + 295; - Name_Check : constant Name_Id := N + 296; - Name_Casing : constant Name_Id := N + 297; - Name_Code : constant Name_Id := N + 298; - Name_Component : constant Name_Id := N + 299; - Name_Component_Size_4 : constant Name_Id := N + 300; - Name_Copy : constant Name_Id := N + 301; - Name_D_Float : constant Name_Id := N + 302; - Name_Descriptor : constant Name_Id := N + 303; - Name_Dot_Replacement : constant Name_Id := N + 304; - Name_Dynamic : constant Name_Id := N + 305; - Name_Entity : constant Name_Id := N + 306; - Name_Entry_Count : constant Name_Id := N + 307; - Name_External_Name : constant Name_Id := N + 308; - Name_First_Optional_Parameter : constant Name_Id := N + 309; - Name_Form : constant Name_Id := N + 310; - Name_G_Float : constant Name_Id := N + 311; - Name_Gcc : constant Name_Id := N + 312; - Name_Gnat : constant Name_Id := N + 313; - Name_GPL : constant Name_Id := N + 314; - Name_IEEE_Float : constant Name_Id := N + 315; - Name_Ignore : constant Name_Id := N + 316; - Name_Info : constant Name_Id := N + 317; - Name_Internal : constant Name_Id := N + 318; - Name_Link_Name : constant Name_Id := N + 319; - Name_Lowercase : constant Name_Id := N + 320; - Name_Max_Entry_Queue_Depth : constant Name_Id := N + 321; - Name_Max_Entry_Queue_Length : constant Name_Id := N + 322; - Name_Max_Size : constant Name_Id := N + 323; - Name_Mechanism : constant Name_Id := N + 324; - Name_Message : constant Name_Id := N + 325; - Name_Mixedcase : constant Name_Id := N + 326; - Name_Modified_GPL : constant Name_Id := N + 327; - Name_Name : constant Name_Id := N + 328; - Name_NCA : constant Name_Id := N + 329; - Name_No : constant Name_Id := N + 330; - Name_No_Dependence : constant Name_Id := N + 331; - Name_No_Dynamic_Attachment : constant Name_Id := N + 332; - Name_No_Dynamic_Interrupts : constant Name_Id := N + 333; - Name_No_Requeue : constant Name_Id := N + 334; - Name_No_Requeue_Statements : constant Name_Id := N + 335; - Name_No_Task_Attributes : constant Name_Id := N + 336; - Name_No_Task_Attributes_Package : constant Name_Id := N + 337; - Name_On : constant Name_Id := N + 338; - Name_Parameter_Types : constant Name_Id := N + 339; - Name_Reference : constant Name_Id := N + 340; - Name_Restricted : constant Name_Id := N + 341; - Name_Result_Mechanism : constant Name_Id := N + 342; - Name_Result_Type : constant Name_Id := N + 343; - Name_Runtime : constant Name_Id := N + 344; - Name_SB : constant Name_Id := N + 345; - Name_Secondary_Stack_Size : constant Name_Id := N + 346; - Name_Section : constant Name_Id := N + 347; - Name_Semaphore : constant Name_Id := N + 348; - Name_Simple_Barriers : constant Name_Id := N + 349; - Name_Spec_File_Name : constant Name_Id := N + 350; - Name_State : constant Name_Id := N + 351; - Name_Static : constant Name_Id := N + 352; - Name_Stack_Size : constant Name_Id := N + 353; - Name_Subunit_File_Name : constant Name_Id := N + 354; - Name_Task_Stack_Size_Default : constant Name_Id := N + 355; - Name_Task_Type : constant Name_Id := N + 356; - Name_Time_Slicing_Enabled : constant Name_Id := N + 357; - Name_Top_Guard : constant Name_Id := N + 358; - Name_UBA : constant Name_Id := N + 359; - Name_UBS : constant Name_Id := N + 360; - Name_UBSB : constant Name_Id := N + 361; - Name_Unit_Name : constant Name_Id := N + 362; - Name_Unknown : constant Name_Id := N + 363; - Name_Unrestricted : constant Name_Id := N + 364; - Name_Uppercase : constant Name_Id := N + 365; - Name_User : constant Name_Id := N + 366; - Name_VAX_Float : constant Name_Id := N + 367; - Name_VMS : constant Name_Id := N + 368; - Name_Vtable_Ptr : constant Name_Id := N + 369; - Name_Working_Storage : constant Name_Id := N + 370; + Name_As_Is : constant Name_Id := N + 299; + Name_Assertion : constant Name_Id := N + 300; + Name_Attribute_Name : constant Name_Id := N + 301; + Name_Body_File_Name : constant Name_Id := N + 302; + Name_Boolean_Entry_Barriers : constant Name_Id := N + 303; + Name_Casing : constant Name_Id := N + 304; + Name_Code : constant Name_Id := N + 305; + Name_Component : constant Name_Id := N + 306; + Name_Component_Size_4 : constant Name_Id := N + 307; + Name_Copy : constant Name_Id := N + 308; + Name_D_Float : constant Name_Id := N + 309; + Name_Descriptor : constant Name_Id := N + 310; + Name_Dot_Replacement : constant Name_Id := N + 311; + Name_Dynamic : constant Name_Id := N + 312; + Name_Entity : constant Name_Id := N + 313; + Name_Entry_Count : constant Name_Id := N + 314; + Name_External_Name : constant Name_Id := N + 315; + Name_First_Optional_Parameter : constant Name_Id := N + 316; + Name_Form : constant Name_Id := N + 317; + Name_G_Float : constant Name_Id := N + 318; + Name_Gcc : constant Name_Id := N + 319; + Name_Gnat : constant Name_Id := N + 320; + Name_GPL : constant Name_Id := N + 321; + Name_IEEE_Float : constant Name_Id := N + 322; + Name_Ignore : constant Name_Id := N + 323; + Name_Info : constant Name_Id := N + 324; + Name_Internal : constant Name_Id := N + 325; + Name_Link_Name : constant Name_Id := N + 326; + Name_Lowercase : constant Name_Id := N + 327; + Name_Max_Entry_Queue_Depth : constant Name_Id := N + 328; + Name_Max_Entry_Queue_Length : constant Name_Id := N + 329; + Name_Max_Size : constant Name_Id := N + 330; + Name_Mechanism : constant Name_Id := N + 331; + Name_Message : constant Name_Id := N + 332; + Name_Mixedcase : constant Name_Id := N + 333; + Name_Modified_GPL : constant Name_Id := N + 334; + Name_Name : constant Name_Id := N + 335; + Name_NCA : constant Name_Id := N + 336; + Name_No : constant Name_Id := N + 337; + Name_No_Dependence : constant Name_Id := N + 338; + Name_No_Dynamic_Attachment : constant Name_Id := N + 339; + Name_No_Dynamic_Interrupts : constant Name_Id := N + 340; + Name_No_Requeue : constant Name_Id := N + 341; + Name_No_Requeue_Statements : constant Name_Id := N + 342; + Name_No_Task_Attributes : constant Name_Id := N + 343; + Name_No_Task_Attributes_Package : constant Name_Id := N + 344; + Name_On : constant Name_Id := N + 345; + Name_Parameter_Types : constant Name_Id := N + 346; + Name_Reference : constant Name_Id := N + 347; + Name_Restricted : constant Name_Id := N + 348; + Name_Result_Mechanism : constant Name_Id := N + 349; + Name_Result_Type : constant Name_Id := N + 350; + Name_Runtime : constant Name_Id := N + 351; + Name_SB : constant Name_Id := N + 352; + Name_Secondary_Stack_Size : constant Name_Id := N + 353; + Name_Section : constant Name_Id := N + 354; + Name_Semaphore : constant Name_Id := N + 355; + Name_Simple_Barriers : constant Name_Id := N + 356; + Name_Spec_File_Name : constant Name_Id := N + 357; + Name_State : constant Name_Id := N + 358; + Name_Static : constant Name_Id := N + 359; + Name_Stack_Size : constant Name_Id := N + 360; + Name_Subunit_File_Name : constant Name_Id := N + 361; + Name_Task_Stack_Size_Default : constant Name_Id := N + 362; + Name_Task_Type : constant Name_Id := N + 363; + Name_Time_Slicing_Enabled : constant Name_Id := N + 364; + Name_Top_Guard : constant Name_Id := N + 365; + Name_UBA : constant Name_Id := N + 366; + Name_UBS : constant Name_Id := N + 367; + Name_UBSB : constant Name_Id := N + 368; + Name_Unit_Name : constant Name_Id := N + 369; + Name_Unknown : constant Name_Id := N + 370; + Name_Unrestricted : constant Name_Id := N + 371; + Name_Uppercase : constant Name_Id := N + 372; + Name_User : constant Name_Id := N + 373; + Name_VAX_Float : constant Name_Id := N + 374; + Name_VMS : constant Name_Id := N + 375; + Name_Vtable_Ptr : constant Name_Id := N + 376; + Name_Working_Storage : constant Name_Id := N + 377; -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These @@ -664,171 +671,175 @@ package Snames is -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. - First_Attribute_Name : constant Name_Id := N + 371; - Name_Abort_Signal : constant Name_Id := N + 371; -- GNAT - Name_Access : constant Name_Id := N + 372; - Name_Address : constant Name_Id := N + 373; - Name_Address_Size : constant Name_Id := N + 374; -- GNAT - Name_Aft : constant Name_Id := N + 375; - Name_Alignment : constant Name_Id := N + 376; - Name_Asm_Input : constant Name_Id := N + 377; -- GNAT - Name_Asm_Output : constant Name_Id := N + 378; -- GNAT - Name_AST_Entry : constant Name_Id := N + 379; -- VMS - Name_Bit : constant Name_Id := N + 380; -- GNAT - Name_Bit_Order : constant Name_Id := N + 381; - Name_Bit_Position : constant Name_Id := N + 382; -- GNAT - Name_Body_Version : constant Name_Id := N + 383; - Name_Callable : constant Name_Id := N + 384; - Name_Caller : constant Name_Id := N + 385; - Name_Code_Address : constant Name_Id := N + 386; -- GNAT - Name_Component_Size : constant Name_Id := N + 387; - Name_Compose : constant Name_Id := N + 388; - Name_Constrained : constant Name_Id := N + 389; - Name_Count : constant Name_Id := N + 390; - Name_Default_Bit_Order : constant Name_Id := N + 391; -- GNAT - Name_Definite : constant Name_Id := N + 392; - Name_Delta : constant Name_Id := N + 393; - Name_Denorm : constant Name_Id := N + 394; - Name_Digits : constant Name_Id := N + 395; - Name_Elaborated : constant Name_Id := N + 396; -- GNAT - Name_Emax : constant Name_Id := N + 397; -- Ada 83 - Name_Enabled : constant Name_Id := N + 398; -- GNAT - Name_Enum_Rep : constant Name_Id := N + 399; -- GNAT - Name_Epsilon : constant Name_Id := N + 400; -- Ada 83 - Name_Exponent : constant Name_Id := N + 401; - Name_External_Tag : constant Name_Id := N + 402; - Name_Fast_Math : constant Name_Id := N + 403; -- GNAT - Name_First : constant Name_Id := N + 404; - Name_First_Bit : constant Name_Id := N + 405; - Name_Fixed_Value : constant Name_Id := N + 406; -- GNAT - Name_Fore : constant Name_Id := N + 407; - Name_Has_Access_Values : constant Name_Id := N + 408; -- GNAT - Name_Has_Discriminants : constant Name_Id := N + 409; -- GNAT - Name_Identity : constant Name_Id := N + 410; - Name_Img : constant Name_Id := N + 411; -- GNAT - Name_Integer_Value : constant Name_Id := N + 412; -- GNAT - Name_Large : constant Name_Id := N + 413; -- Ada 83 - Name_Last : constant Name_Id := N + 414; - Name_Last_Bit : constant Name_Id := N + 415; - Name_Leading_Part : constant Name_Id := N + 416; - Name_Length : constant Name_Id := N + 417; - Name_Machine_Emax : constant Name_Id := N + 418; - Name_Machine_Emin : constant Name_Id := N + 419; - Name_Machine_Mantissa : constant Name_Id := N + 420; - Name_Machine_Overflows : constant Name_Id := N + 421; - Name_Machine_Radix : constant Name_Id := N + 422; - Name_Machine_Rounding : constant Name_Id := N + 423; -- Ada 05 - Name_Machine_Rounds : constant Name_Id := N + 424; - Name_Machine_Size : constant Name_Id := N + 425; -- GNAT - Name_Mantissa : constant Name_Id := N + 426; -- Ada 83 - Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 427; - Name_Maximum_Alignment : constant Name_Id := N + 428; -- GNAT - Name_Mechanism_Code : constant Name_Id := N + 429; -- GNAT - Name_Mod : constant Name_Id := N + 430; -- Ada 05 - Name_Model_Emin : constant Name_Id := N + 431; - Name_Model_Epsilon : constant Name_Id := N + 432; - Name_Model_Mantissa : constant Name_Id := N + 433; - Name_Model_Small : constant Name_Id := N + 434; - Name_Modulus : constant Name_Id := N + 435; - Name_Null_Parameter : constant Name_Id := N + 436; -- GNAT - Name_Object_Size : constant Name_Id := N + 437; -- GNAT - Name_Old : constant Name_Id := N + 438; -- GNAT - Name_Partition_ID : constant Name_Id := N + 439; - Name_Passed_By_Reference : constant Name_Id := N + 440; -- GNAT - Name_Pool_Address : constant Name_Id := N + 441; - Name_Pos : constant Name_Id := N + 442; - Name_Position : constant Name_Id := N + 443; - Name_Priority : constant Name_Id := N + 444; -- Ada 05 - Name_Range : constant Name_Id := N + 445; - Name_Range_Length : constant Name_Id := N + 446; -- GNAT - Name_Round : constant Name_Id := N + 447; - Name_Safe_Emax : constant Name_Id := N + 448; -- Ada 83 - Name_Safe_First : constant Name_Id := N + 449; - Name_Safe_Large : constant Name_Id := N + 450; -- Ada 83 - Name_Safe_Last : constant Name_Id := N + 451; - Name_Safe_Small : constant Name_Id := N + 452; -- Ada 83 - Name_Scale : constant Name_Id := N + 453; - Name_Scaling : constant Name_Id := N + 454; - Name_Signed_Zeros : constant Name_Id := N + 455; - Name_Size : constant Name_Id := N + 456; - Name_Small : constant Name_Id := N + 457; - Name_Storage_Size : constant Name_Id := N + 458; - Name_Storage_Unit : constant Name_Id := N + 459; -- GNAT - Name_Stream_Size : constant Name_Id := N + 460; -- Ada 05 - Name_Tag : constant Name_Id := N + 461; - Name_Target_Name : constant Name_Id := N + 462; -- GNAT - Name_Terminated : constant Name_Id := N + 463; - Name_To_Address : constant Name_Id := N + 464; -- GNAT - Name_Type_Class : constant Name_Id := N + 465; -- GNAT - Name_UET_Address : constant Name_Id := N + 466; -- GNAT - Name_Unbiased_Rounding : constant Name_Id := N + 467; - Name_Unchecked_Access : constant Name_Id := N + 468; - Name_Unconstrained_Array : constant Name_Id := N + 469; - Name_Universal_Literal_String : constant Name_Id := N + 470; -- GNAT - Name_Unrestricted_Access : constant Name_Id := N + 471; -- GNAT - Name_VADS_Size : constant Name_Id := N + 472; -- GNAT - Name_Val : constant Name_Id := N + 473; - Name_Valid : constant Name_Id := N + 474; - Name_Value_Size : constant Name_Id := N + 475; -- GNAT - Name_Version : constant Name_Id := N + 476; - Name_Wchar_T_Size : constant Name_Id := N + 477; -- GNAT - Name_Wide_Wide_Width : constant Name_Id := N + 478; -- Ada 05 - Name_Wide_Width : constant Name_Id := N + 479; - Name_Width : constant Name_Id := N + 480; - Name_Word_Size : constant Name_Id := N + 481; -- GNAT + First_Attribute_Name : constant Name_Id := N + 378; + Name_Abort_Signal : constant Name_Id := N + 378; -- GNAT + Name_Access : constant Name_Id := N + 379; + Name_Address : constant Name_Id := N + 380; + Name_Address_Size : constant Name_Id := N + 381; -- GNAT + Name_Aft : constant Name_Id := N + 382; + Name_Alignment : constant Name_Id := N + 383; + Name_Asm_Input : constant Name_Id := N + 384; -- GNAT + Name_Asm_Output : constant Name_Id := N + 385; -- GNAT + Name_AST_Entry : constant Name_Id := N + 386; -- VMS + Name_Bit : constant Name_Id := N + 387; -- GNAT + Name_Bit_Order : constant Name_Id := N + 388; + Name_Bit_Position : constant Name_Id := N + 389; -- GNAT + Name_Body_Version : constant Name_Id := N + 390; + Name_Callable : constant Name_Id := N + 391; + Name_Caller : constant Name_Id := N + 392; + Name_Code_Address : constant Name_Id := N + 393; -- GNAT + Name_Component_Size : constant Name_Id := N + 394; + Name_Compose : constant Name_Id := N + 395; + Name_Constrained : constant Name_Id := N + 396; + Name_Count : constant Name_Id := N + 397; + Name_Default_Bit_Order : constant Name_Id := N + 398; -- GNAT + Name_Definite : constant Name_Id := N + 399; + Name_Delta : constant Name_Id := N + 400; + Name_Denorm : constant Name_Id := N + 401; + Name_Digits : constant Name_Id := N + 402; + Name_Elaborated : constant Name_Id := N + 403; -- GNAT + Name_Emax : constant Name_Id := N + 404; -- Ada 83 + Name_Enabled : constant Name_Id := N + 405; -- GNAT + Name_Enum_Rep : constant Name_Id := N + 406; -- GNAT + Name_Enum_Val : constant Name_Id := N + 407; -- GNAT + Name_Epsilon : constant Name_Id := N + 408; -- Ada 83 + Name_Exponent : constant Name_Id := N + 409; + Name_External_Tag : constant Name_Id := N + 410; + Name_Fast_Math : constant Name_Id := N + 411; -- GNAT + Name_First : constant Name_Id := N + 412; + Name_First_Bit : constant Name_Id := N + 413; + Name_Fixed_Value : constant Name_Id := N + 414; -- GNAT + Name_Fore : constant Name_Id := N + 415; + Name_Has_Access_Values : constant Name_Id := N + 416; -- GNAT + Name_Has_Discriminants : constant Name_Id := N + 417; -- GNAT + Name_Has_Tagged_Values : constant Name_Id := N + 418; -- GNAT + Name_Identity : constant Name_Id := N + 419; + Name_Img : constant Name_Id := N + 420; -- GNAT + Name_Integer_Value : constant Name_Id := N + 421; -- GNAT + Name_Invalid_Value : constant Name_Id := N + 422; -- GNAT + Name_Large : constant Name_Id := N + 423; -- Ada 83 + Name_Last : constant Name_Id := N + 424; + Name_Last_Bit : constant Name_Id := N + 425; + Name_Leading_Part : constant Name_Id := N + 426; + Name_Length : constant Name_Id := N + 427; + Name_Machine_Emax : constant Name_Id := N + 428; + Name_Machine_Emin : constant Name_Id := N + 429; + Name_Machine_Mantissa : constant Name_Id := N + 430; + Name_Machine_Overflows : constant Name_Id := N + 431; + Name_Machine_Radix : constant Name_Id := N + 432; + Name_Machine_Rounding : constant Name_Id := N + 433; -- Ada 05 + Name_Machine_Rounds : constant Name_Id := N + 434; + Name_Machine_Size : constant Name_Id := N + 435; -- GNAT + Name_Mantissa : constant Name_Id := N + 436; -- Ada 83 + Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 437; + Name_Maximum_Alignment : constant Name_Id := N + 438; -- GNAT + Name_Mechanism_Code : constant Name_Id := N + 439; -- GNAT + Name_Mod : constant Name_Id := N + 440; -- Ada 05 + Name_Model_Emin : constant Name_Id := N + 441; + Name_Model_Epsilon : constant Name_Id := N + 442; + Name_Model_Mantissa : constant Name_Id := N + 443; + Name_Model_Small : constant Name_Id := N + 444; + Name_Modulus : constant Name_Id := N + 445; + Name_Null_Parameter : constant Name_Id := N + 446; -- GNAT + Name_Object_Size : constant Name_Id := N + 447; -- GNAT + Name_Old : constant Name_Id := N + 448; -- GNAT + Name_Partition_ID : constant Name_Id := N + 449; + Name_Passed_By_Reference : constant Name_Id := N + 450; -- GNAT + Name_Pool_Address : constant Name_Id := N + 451; + Name_Pos : constant Name_Id := N + 452; + Name_Position : constant Name_Id := N + 453; + Name_Priority : constant Name_Id := N + 454; -- Ada 05 + Name_Range : constant Name_Id := N + 455; + Name_Range_Length : constant Name_Id := N + 456; -- GNAT + Name_Result : constant Name_Id := N + 457; -- GNAT + Name_Round : constant Name_Id := N + 458; + Name_Safe_Emax : constant Name_Id := N + 459; -- Ada 83 + Name_Safe_First : constant Name_Id := N + 460; + Name_Safe_Large : constant Name_Id := N + 461; -- Ada 83 + Name_Safe_Last : constant Name_Id := N + 462; + Name_Safe_Small : constant Name_Id := N + 463; -- Ada 83 + Name_Scale : constant Name_Id := N + 464; + Name_Scaling : constant Name_Id := N + 465; + Name_Signed_Zeros : constant Name_Id := N + 466; + Name_Size : constant Name_Id := N + 467; + Name_Small : constant Name_Id := N + 468; + Name_Storage_Size : constant Name_Id := N + 469; + Name_Storage_Unit : constant Name_Id := N + 470; -- GNAT + Name_Stream_Size : constant Name_Id := N + 471; -- Ada 05 + Name_Tag : constant Name_Id := N + 472; + Name_Target_Name : constant Name_Id := N + 473; -- GNAT + Name_Terminated : constant Name_Id := N + 474; + Name_To_Address : constant Name_Id := N + 475; -- GNAT + Name_Type_Class : constant Name_Id := N + 476; -- GNAT + Name_UET_Address : constant Name_Id := N + 477; -- GNAT + Name_Unbiased_Rounding : constant Name_Id := N + 478; + Name_Unchecked_Access : constant Name_Id := N + 479; + Name_Unconstrained_Array : constant Name_Id := N + 480; + Name_Universal_Literal_String : constant Name_Id := N + 481; -- GNAT + Name_Unrestricted_Access : constant Name_Id := N + 482; -- GNAT + Name_VADS_Size : constant Name_Id := N + 483; -- GNAT + Name_Val : constant Name_Id := N + 484; + Name_Valid : constant Name_Id := N + 485; + Name_Value_Size : constant Name_Id := N + 486; -- GNAT + Name_Version : constant Name_Id := N + 487; + Name_Wchar_T_Size : constant Name_Id := N + 488; -- GNAT + Name_Wide_Wide_Width : constant Name_Id := N + 489; -- Ada 05 + Name_Wide_Width : constant Name_Id := N + 490; + Name_Width : constant Name_Id := N + 491; + Name_Word_Size : constant Name_Id := N + 492; -- GNAT -- Attributes that designate attributes returning renamable functions, -- i.e. functions that return other than a universal value and that -- have non-universal arguments. - First_Renamable_Function_Attribute : constant Name_Id := N + 482; - Name_Adjacent : constant Name_Id := N + 482; - Name_Ceiling : constant Name_Id := N + 483; - Name_Copy_Sign : constant Name_Id := N + 484; - Name_Floor : constant Name_Id := N + 485; - Name_Fraction : constant Name_Id := N + 486; - Name_Image : constant Name_Id := N + 487; - Name_Input : constant Name_Id := N + 488; - Name_Machine : constant Name_Id := N + 489; - Name_Max : constant Name_Id := N + 490; - Name_Min : constant Name_Id := N + 491; - Name_Model : constant Name_Id := N + 492; - Name_Pred : constant Name_Id := N + 493; - Name_Remainder : constant Name_Id := N + 494; - Name_Rounding : constant Name_Id := N + 495; - Name_Succ : constant Name_Id := N + 496; - Name_Truncation : constant Name_Id := N + 497; - Name_Value : constant Name_Id := N + 498; - Name_Wide_Image : constant Name_Id := N + 499; - Name_Wide_Wide_Image : constant Name_Id := N + 500; - Name_Wide_Value : constant Name_Id := N + 501; - Name_Wide_Wide_Value : constant Name_Id := N + 502; - Last_Renamable_Function_Attribute : constant Name_Id := N + 502; + First_Renamable_Function_Attribute : constant Name_Id := N + 493; + Name_Adjacent : constant Name_Id := N + 493; + Name_Ceiling : constant Name_Id := N + 494; + Name_Copy_Sign : constant Name_Id := N + 495; + Name_Floor : constant Name_Id := N + 496; + Name_Fraction : constant Name_Id := N + 497; + Name_Image : constant Name_Id := N + 498; + Name_Input : constant Name_Id := N + 499; + Name_Machine : constant Name_Id := N + 500; + Name_Max : constant Name_Id := N + 501; + Name_Min : constant Name_Id := N + 502; + Name_Model : constant Name_Id := N + 503; + Name_Pred : constant Name_Id := N + 504; + Name_Remainder : constant Name_Id := N + 505; + Name_Rounding : constant Name_Id := N + 506; + Name_Succ : constant Name_Id := N + 507; + Name_Truncation : constant Name_Id := N + 508; + Name_Value : constant Name_Id := N + 509; + Name_Wide_Image : constant Name_Id := N + 510; + Name_Wide_Wide_Image : constant Name_Id := N + 511; + Name_Wide_Value : constant Name_Id := N + 512; + Name_Wide_Wide_Value : constant Name_Id := N + 513; + Last_Renamable_Function_Attribute : constant Name_Id := N + 513; -- Attributes that designate procedures - First_Procedure_Attribute : constant Name_Id := N + 503; - Name_Output : constant Name_Id := N + 503; - Name_Read : constant Name_Id := N + 504; - Name_Write : constant Name_Id := N + 505; - Last_Procedure_Attribute : constant Name_Id := N + 505; + First_Procedure_Attribute : constant Name_Id := N + 514; + Name_Output : constant Name_Id := N + 514; + Name_Read : constant Name_Id := N + 515; + Name_Write : constant Name_Id := N + 516; + Last_Procedure_Attribute : constant Name_Id := N + 516; -- Remaining attributes are ones that return entities - First_Entity_Attribute_Name : constant Name_Id := N + 506; - Name_Elab_Body : constant Name_Id := N + 506; -- GNAT - Name_Elab_Spec : constant Name_Id := N + 507; -- GNAT - Name_Storage_Pool : constant Name_Id := N + 508; + First_Entity_Attribute_Name : constant Name_Id := N + 517; + Name_Elab_Body : constant Name_Id := N + 517; -- GNAT + Name_Elab_Spec : constant Name_Id := N + 518; -- GNAT + Name_Storage_Pool : constant Name_Id := N + 519; -- These attributes are the ones that return types - First_Type_Attribute_Name : constant Name_Id := N + 509; - Name_Base : constant Name_Id := N + 509; - Name_Class : constant Name_Id := N + 510; - Name_Stub_Type : constant Name_Id := N + 511; - Last_Type_Attribute_Name : constant Name_Id := N + 511; - Last_Entity_Attribute_Name : constant Name_Id := N + 511; - Last_Attribute_Name : constant Name_Id := N + 511; + First_Type_Attribute_Name : constant Name_Id := N + 520; + Name_Base : constant Name_Id := N + 520; + Name_Class : constant Name_Id := N + 521; + Name_Stub_Type : constant Name_Id := N + 522; + Last_Type_Attribute_Name : constant Name_Id := N + 522; + Last_Entity_Attribute_Name : constant Name_Id := N + 522; + Last_Attribute_Name : constant Name_Id := N + 522; -- Names of recognized locking policy identifiers @@ -836,10 +847,10 @@ package Snames is -- name (e.g. C for Ceiling_Locking). If new policy names are added, -- the first character must be distinct. - First_Locking_Policy_Name : constant Name_Id := N + 512; - Name_Ceiling_Locking : constant Name_Id := N + 512; - Name_Inheritance_Locking : constant Name_Id := N + 513; - Last_Locking_Policy_Name : constant Name_Id := N + 513; + First_Locking_Policy_Name : constant Name_Id := N + 523; + Name_Ceiling_Locking : constant Name_Id := N + 523; + Name_Inheritance_Locking : constant Name_Id := N + 524; + Last_Locking_Policy_Name : constant Name_Id := N + 524; -- Names of recognized queuing policy identifiers @@ -847,10 +858,10 @@ package Snames is -- name (e.g. F for FIFO_Queuing). If new policy names are added, -- the first character must be distinct. - First_Queuing_Policy_Name : constant Name_Id := N + 514; - Name_FIFO_Queuing : constant Name_Id := N + 514; - Name_Priority_Queuing : constant Name_Id := N + 515; - Last_Queuing_Policy_Name : constant Name_Id := N + 515; + First_Queuing_Policy_Name : constant Name_Id := N + 525; + Name_FIFO_Queuing : constant Name_Id := N + 525; + Name_Priority_Queuing : constant Name_Id := N + 526; + Last_Queuing_Policy_Name : constant Name_Id := N + 526; -- Names of recognized task dispatching policy identifiers @@ -858,275 +869,279 @@ package Snames is -- name (e.g. F for FIFO_Within_Priorities). If new policy names -- are added, the first character must be distinct. - First_Task_Dispatching_Policy_Name : constant Name_Id := N + 516; - Name_EDF_Across_Priorities : constant Name_Id := N + 516; - Name_FIFO_Within_Priorities : constant Name_Id := N + 517; - Name_Non_Preemptive_Within_Priorities - : constant Name_Id := N + 513; - Name_Round_Robin_Within_Priorities : constant Name_Id := N + 518; - Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 518; + First_Task_Dispatching_Policy_Name : constant Name_Id := N + 527; + Name_EDF_Across_Priorities : constant Name_Id := N + 527; + Name_FIFO_Within_Priorities : constant Name_Id := N + 528; + Name_Non_Preemptive_Within_Priorities : constant Name_Id := N + 529; + Name_Round_Robin_Within_Priorities : constant Name_Id := N + 530; + Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 530; -- Names of recognized checks for pragma Suppress - First_Check_Name : constant Name_Id := N + 519; - Name_Access_Check : constant Name_Id := N + 519; - Name_Accessibility_Check : constant Name_Id := N + 520; - Name_Alignment_Check : constant Name_Id := N + 521; -- GNAT - Name_Discriminant_Check : constant Name_Id := N + 522; - Name_Division_Check : constant Name_Id := N + 523; - Name_Elaboration_Check : constant Name_Id := N + 524; - Name_Index_Check : constant Name_Id := N + 525; - Name_Length_Check : constant Name_Id := N + 526; - Name_Overflow_Check : constant Name_Id := N + 527; - Name_Range_Check : constant Name_Id := N + 528; - Name_Storage_Check : constant Name_Id := N + 529; - Name_Tag_Check : constant Name_Id := N + 530; - Name_Validity_Check : constant Name_Id := N + 531; -- GNAT - Name_All_Checks : constant Name_Id := N + 532; - Last_Check_Name : constant Name_Id := N + 532; + First_Check_Name : constant Name_Id := N + 531; + Name_Access_Check : constant Name_Id := N + 531; + Name_Accessibility_Check : constant Name_Id := N + 532; + Name_Alignment_Check : constant Name_Id := N + 533; -- GNAT + Name_Discriminant_Check : constant Name_Id := N + 534; + Name_Division_Check : constant Name_Id := N + 535; + Name_Elaboration_Check : constant Name_Id := N + 536; + Name_Index_Check : constant Name_Id := N + 537; + Name_Length_Check : constant Name_Id := N + 538; + Name_Overflow_Check : constant Name_Id := N + 539; + Name_Range_Check : constant Name_Id := N + 540; + Name_Storage_Check : constant Name_Id := N + 541; + Name_Tag_Check : constant Name_Id := N + 542; + Name_Validity_Check : constant Name_Id := N + 543; -- GNAT + Name_All_Checks : constant Name_Id := N + 544; + Last_Check_Name : constant Name_Id := N + 544; -- Names corresponding to reserved keywords, excluding those already -- declared in the attribute list (Access, Delta, Digits, Mod, Range). - Name_Abort : constant Name_Id := N + 533; - Name_Abs : constant Name_Id := N + 534; - Name_Accept : constant Name_Id := N + 535; - Name_And : constant Name_Id := N + 536; - Name_All : constant Name_Id := N + 537; - Name_Array : constant Name_Id := N + 538; - Name_At : constant Name_Id := N + 539; - Name_Begin : constant Name_Id := N + 540; - Name_Body : constant Name_Id := N + 541; - Name_Case : constant Name_Id := N + 542; - Name_Constant : constant Name_Id := N + 543; - Name_Declare : constant Name_Id := N + 544; - Name_Delay : constant Name_Id := N + 545; - Name_Do : constant Name_Id := N + 546; - Name_Else : constant Name_Id := N + 547; - Name_Elsif : constant Name_Id := N + 548; - Name_End : constant Name_Id := N + 549; - Name_Entry : constant Name_Id := N + 550; - Name_Exception : constant Name_Id := N + 551; - Name_Exit : constant Name_Id := N + 552; - Name_For : constant Name_Id := N + 553; - Name_Function : constant Name_Id := N + 554; - Name_Generic : constant Name_Id := N + 555; - Name_Goto : constant Name_Id := N + 556; - Name_If : constant Name_Id := N + 557; - Name_In : constant Name_Id := N + 558; - Name_Is : constant Name_Id := N + 559; - Name_Limited : constant Name_Id := N + 560; - Name_Loop : constant Name_Id := N + 561; - Name_New : constant Name_Id := N + 562; - Name_Not : constant Name_Id := N + 563; - Name_Null : constant Name_Id := N + 564; - Name_Of : constant Name_Id := N + 565; - Name_Or : constant Name_Id := N + 566; - Name_Others : constant Name_Id := N + 567; - Name_Out : constant Name_Id := N + 568; - Name_Package : constant Name_Id := N + 569; - Name_Pragma : constant Name_Id := N + 570; - Name_Private : constant Name_Id := N + 571; - Name_Procedure : constant Name_Id := N + 572; - Name_Raise : constant Name_Id := N + 573; - Name_Record : constant Name_Id := N + 574; - Name_Rem : constant Name_Id := N + 575; - Name_Renames : constant Name_Id := N + 576; - Name_Return : constant Name_Id := N + 577; - Name_Reverse : constant Name_Id := N + 578; - Name_Select : constant Name_Id := N + 579; - Name_Separate : constant Name_Id := N + 580; - Name_Subtype : constant Name_Id := N + 581; - Name_Task : constant Name_Id := N + 582; - Name_Terminate : constant Name_Id := N + 583; - Name_Then : constant Name_Id := N + 584; - Name_Type : constant Name_Id := N + 585; - Name_Use : constant Name_Id := N + 586; - Name_When : constant Name_Id := N + 587; - Name_While : constant Name_Id := N + 588; - Name_With : constant Name_Id := N + 589; - Name_Xor : constant Name_Id := N + 590; + Name_Abort : constant Name_Id := N + 545; + Name_Abs : constant Name_Id := N + 546; + Name_Accept : constant Name_Id := N + 547; + Name_And : constant Name_Id := N + 548; + Name_All : constant Name_Id := N + 549; + Name_Array : constant Name_Id := N + 550; + Name_At : constant Name_Id := N + 551; + Name_Begin : constant Name_Id := N + 552; + Name_Body : constant Name_Id := N + 553; + Name_Case : constant Name_Id := N + 554; + Name_Constant : constant Name_Id := N + 555; + Name_Declare : constant Name_Id := N + 556; + Name_Delay : constant Name_Id := N + 557; + Name_Do : constant Name_Id := N + 558; + Name_Else : constant Name_Id := N + 559; + Name_Elsif : constant Name_Id := N + 560; + Name_End : constant Name_Id := N + 561; + Name_Entry : constant Name_Id := N + 562; + Name_Exception : constant Name_Id := N + 563; + Name_Exit : constant Name_Id := N + 564; + Name_For : constant Name_Id := N + 565; + Name_Function : constant Name_Id := N + 566; + Name_Generic : constant Name_Id := N + 567; + Name_Goto : constant Name_Id := N + 568; + Name_If : constant Name_Id := N + 569; + Name_In : constant Name_Id := N + 570; + Name_Is : constant Name_Id := N + 571; + Name_Limited : constant Name_Id := N + 572; + Name_Loop : constant Name_Id := N + 573; + Name_New : constant Name_Id := N + 574; + Name_Not : constant Name_Id := N + 575; + Name_Null : constant Name_Id := N + 576; + Name_Of : constant Name_Id := N + 577; + Name_Or : constant Name_Id := N + 578; + Name_Others : constant Name_Id := N + 579; + Name_Out : constant Name_Id := N + 580; + Name_Package : constant Name_Id := N + 581; + Name_Pragma : constant Name_Id := N + 582; + Name_Private : constant Name_Id := N + 583; + Name_Procedure : constant Name_Id := N + 584; + Name_Raise : constant Name_Id := N + 585; + Name_Record : constant Name_Id := N + 586; + Name_Rem : constant Name_Id := N + 587; + Name_Renames : constant Name_Id := N + 588; + Name_Return : constant Name_Id := N + 589; + Name_Reverse : constant Name_Id := N + 590; + Name_Select : constant Name_Id := N + 591; + Name_Separate : constant Name_Id := N + 592; + Name_Subtype : constant Name_Id := N + 593; + Name_Task : constant Name_Id := N + 594; + Name_Terminate : constant Name_Id := N + 595; + Name_Then : constant Name_Id := N + 596; + Name_Type : constant Name_Id := N + 597; + Name_Use : constant Name_Id := N + 598; + Name_When : constant Name_Id := N + 599; + Name_While : constant Name_Id := N + 600; + Name_With : constant Name_Id := N + 601; + Name_Xor : constant Name_Id := N + 602; -- Names of intrinsic subprograms -- Note: Asm is missing from this list, since Asm is a legitimate -- convention name. So is To_Adress, which is a GNAT attribute. - First_Intrinsic_Name : constant Name_Id := N + 591; - Name_Divide : constant Name_Id := N + 591; - Name_Enclosing_Entity : constant Name_Id := N + 592; - Name_Exception_Information : constant Name_Id := N + 593; - Name_Exception_Message : constant Name_Id := N + 594; - Name_Exception_Name : constant Name_Id := N + 595; - Name_File : constant Name_Id := N + 596; - Name_Generic_Dispatching_Constructor : constant Name_Id := N + 597; - Name_Import_Address : constant Name_Id := N + 598; - Name_Import_Largest_Value : constant Name_Id := N + 599; - Name_Import_Value : constant Name_Id := N + 600; - Name_Is_Negative : constant Name_Id := N + 601; - Name_Line : constant Name_Id := N + 602; - Name_Rotate_Left : constant Name_Id := N + 603; - Name_Rotate_Right : constant Name_Id := N + 604; - Name_Shift_Left : constant Name_Id := N + 605; - Name_Shift_Right : constant Name_Id := N + 606; - Name_Shift_Right_Arithmetic : constant Name_Id := N + 607; - Name_Source_Location : constant Name_Id := N + 608; - Name_Unchecked_Conversion : constant Name_Id := N + 609; - Name_Unchecked_Deallocation : constant Name_Id := N + 610; - Name_To_Pointer : constant Name_Id := N + 611; - Last_Intrinsic_Name : constant Name_Id := N + 611; + First_Intrinsic_Name : constant Name_Id := N + 603; + Name_Divide : constant Name_Id := N + 603; + Name_Enclosing_Entity : constant Name_Id := N + 604; + Name_Exception_Information : constant Name_Id := N + 605; + Name_Exception_Message : constant Name_Id := N + 606; + Name_Exception_Name : constant Name_Id := N + 607; + Name_File : constant Name_Id := N + 608; + Name_Generic_Dispatching_Constructor : constant Name_Id := N + 609; + Name_Import_Address : constant Name_Id := N + 610; + Name_Import_Largest_Value : constant Name_Id := N + 611; + Name_Import_Value : constant Name_Id := N + 612; + Name_Is_Negative : constant Name_Id := N + 613; + Name_Line : constant Name_Id := N + 614; + Name_Rotate_Left : constant Name_Id := N + 615; + Name_Rotate_Right : constant Name_Id := N + 616; + Name_Shift_Left : constant Name_Id := N + 617; + Name_Shift_Right : constant Name_Id := N + 618; + Name_Shift_Right_Arithmetic : constant Name_Id := N + 619; + Name_Source_Location : constant Name_Id := N + 620; + Name_Unchecked_Conversion : constant Name_Id := N + 621; + Name_Unchecked_Deallocation : constant Name_Id := N + 622; + Name_To_Pointer : constant Name_Id := N + 623; + Last_Intrinsic_Name : constant Name_Id := N + 623; -- Names used in processing intrinsic calls - Name_Free : constant Name_Id := N + 612; + Name_Free : constant Name_Id := N + 624; -- Reserved words used only in Ada 95 - First_95_Reserved_Word : constant Name_Id := N + 613; - Name_Abstract : constant Name_Id := N + 613; - Name_Aliased : constant Name_Id := N + 614; - Name_Protected : constant Name_Id := N + 615; - Name_Until : constant Name_Id := N + 616; - Name_Requeue : constant Name_Id := N + 617; - Name_Tagged : constant Name_Id := N + 618; - Last_95_Reserved_Word : constant Name_Id := N + 618; + First_95_Reserved_Word : constant Name_Id := N + 625; + Name_Abstract : constant Name_Id := N + 625; + Name_Aliased : constant Name_Id := N + 626; + Name_Protected : constant Name_Id := N + 627; + Name_Until : constant Name_Id := N + 628; + Name_Requeue : constant Name_Id := N + 629; + Name_Tagged : constant Name_Id := N + 630; + Last_95_Reserved_Word : constant Name_Id := N + 630; subtype Ada_95_Reserved_Words is Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word; -- Miscellaneous names used in semantic checking - Name_Raise_Exception : constant Name_Id := N + 619; + Name_Raise_Exception : constant Name_Id := N + 631; -- Additional reserved words and identifiers used in GNAT Project Files -- Note that Name_External is already previously declared - Name_Ada_Roots : constant Name_Id := N + 620; - Name_Archive_Builder : constant Name_Id := N + 621; - Name_Archive_Indexer : constant Name_Id := N + 622; - Name_Archive_Suffix : constant Name_Id := N + 623; - Name_Binder : constant Name_Id := N + 624; - Name_Binder_Prefix : constant Name_Id := N + 625; - Name_Body_Suffix : constant Name_Id := N + 626; - Name_Builder : constant Name_Id := N + 627; - Name_Builder_Switches : constant Name_Id := N + 628; - Name_Compiler : constant Name_Id := N + 629; - Name_Compiler_Kind : constant Name_Id := N + 630; - Name_Config_Body_File_Name : constant Name_Id := N + 631; - Name_Config_Body_File_Name_Pattern : constant Name_Id := N + 632; - Name_Config_File_Switches : constant Name_Id := N + 633; - Name_Config_File_Unique : constant Name_Id := N + 634; - Name_Config_Spec_File_Name : constant Name_Id := N + 635; - Name_Config_Spec_File_Name_Pattern : constant Name_Id := N + 636; - Name_Cross_Reference : constant Name_Id := N + 637; - Name_Default_Language : constant Name_Id := N + 638; - Name_Default_Switches : constant Name_Id := N + 639; - Name_Dependency_Driver : constant Name_Id := N + 640; - Name_Dependency_File_Kind : constant Name_Id := N + 641; - Name_Dependency_Switches : constant Name_Id := N + 642; - Name_Driver : constant Name_Id := N + 643; - Name_Excluded_Source_Dirs : constant Name_Id := N + 644; - Name_Excluded_Source_Files : constant Name_Id := N + 645; - Name_Exec_Dir : constant Name_Id := N + 646; - Name_Executable : constant Name_Id := N + 647; - Name_Executable_Suffix : constant Name_Id := N + 648; - Name_Extends : constant Name_Id := N + 649; - Name_Externally_Built : constant Name_Id := N + 650; - Name_Finder : constant Name_Id := N + 651; - Name_Global_Configuration_Pragmas : constant Name_Id := N + 652; - Name_Global_Config_File : constant Name_Id := N + 653; - Name_Gnatls : constant Name_Id := N + 654; - Name_Gnatstub : constant Name_Id := N + 655; - Name_Implementation : constant Name_Id := N + 656; - Name_Implementation_Exceptions : constant Name_Id := N + 657; - Name_Implementation_Suffix : constant Name_Id := N + 658; - Name_Include_Switches : constant Name_Id := N + 659; - Name_Include_Path : constant Name_Id := N + 660; - Name_Include_Path_File : constant Name_Id := N + 661; - Name_Language_Kind : constant Name_Id := N + 662; - Name_Language_Processing : constant Name_Id := N + 663; - Name_Languages : constant Name_Id := N + 664; - Name_Library_Ali_Dir : constant Name_Id := N + 665; - Name_Library_Auto_Init : constant Name_Id := N + 666; - Name_Library_Auto_Init_Supported : constant Name_Id := N + 667; - Name_Library_Builder : constant Name_Id := N + 668; - Name_Library_Dir : constant Name_Id := N + 669; - Name_Library_GCC : constant Name_Id := N + 670; - Name_Library_Interface : constant Name_Id := N + 671; - Name_Library_Kind : constant Name_Id := N + 672; - Name_Library_Name : constant Name_Id := N + 673; - Name_Library_Major_Minor_Id_Supported : constant Name_Id := N + 674; - Name_Library_Options : constant Name_Id := N + 675; - Name_Library_Partial_Linker : constant Name_Id := N + 676; - Name_Library_Reference_Symbol_File : constant Name_Id := N + 677; - Name_Library_Src_Dir : constant Name_Id := N + 678; - Name_Library_Support : constant Name_Id := N + 679; - Name_Library_Symbol_File : constant Name_Id := N + 680; - Name_Library_Symbol_Policy : constant Name_Id := N + 681; - Name_Library_Version : constant Name_Id := N + 682; - Name_Library_Version_Switches : constant Name_Id := N + 683; - Name_Linker : constant Name_Id := N + 684; - Name_Linker_Executable_Option : constant Name_Id := N + 685; - Name_Linker_Lib_Dir_Option : constant Name_Id := N + 686; - Name_Linker_Lib_Name_Option : constant Name_Id := N + 687; - Name_Local_Config_File : constant Name_Id := N + 688; - Name_Local_Configuration_Pragmas : constant Name_Id := N + 689; - Name_Locally_Removed_Files : constant Name_Id := N + 690; - Name_Mapping_File_Switches : constant Name_Id := N + 691; - Name_Mapping_Spec_Suffix : constant Name_Id := N + 692; - Name_Mapping_Body_Suffix : constant Name_Id := N + 693; - Name_Metrics : constant Name_Id := N + 694; - Name_Naming : constant Name_Id := N + 695; - Name_Objects_Path : constant Name_Id := N + 696; - Name_Objects_Path_File : constant Name_Id := N + 697; - Name_Object_Dir : constant Name_Id := N + 698; - Name_Pic_Option : constant Name_Id := N + 699; - Name_Pretty_Printer : constant Name_Id := N + 700; - Name_Prefix : constant Name_Id := N + 701; - Name_Project : constant Name_Id := N + 702; - Name_Roots : constant Name_Id := N + 703; - Name_Required_Switches : constant Name_Id := N + 704; - Name_Run_Path_Option : constant Name_Id := N + 705; - Name_Runtime_Project : constant Name_Id := N + 706; - Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 707; - Name_Shared_Library_Prefix : constant Name_Id := N + 708; - Name_Shared_Library_Suffix : constant Name_Id := N + 709; - Name_Separate_Suffix : constant Name_Id := N + 710; - Name_Source_Dirs : constant Name_Id := N + 711; - Name_Source_Files : constant Name_Id := N + 712; - Name_Source_List_File : constant Name_Id := N + 713; - Name_Spec : constant Name_Id := N + 714; - Name_Spec_Suffix : constant Name_Id := N + 715; - Name_Specification : constant Name_Id := N + 716; - Name_Specification_Exceptions : constant Name_Id := N + 717; - Name_Specification_Suffix : constant Name_Id := N + 718; - Name_Stack : constant Name_Id := N + 719; - Name_Switches : constant Name_Id := N + 720; - Name_Symbolic_Link_Supported : constant Name_Id := N + 721; - Name_Sync : constant Name_Id := N + 722; - Name_Synchronize : constant Name_Id := N + 723; - Name_Toolchain_Description : constant Name_Id := N + 724; - Name_Toolchain_Version : constant Name_Id := N + 725; - Name_Runtime_Library_Dir : constant Name_Id := N + 726; + Name_Ada_Roots : constant Name_Id := N + 632; + Name_Aggregate : constant Name_Id := N + 633; + Name_Archive_Builder : constant Name_Id := N + 634; + Name_Archive_Builder_Append_Option : constant Name_Id := N + 635; + Name_Archive_Indexer : constant Name_Id := N + 636; + Name_Archive_Suffix : constant Name_Id := N + 637; + Name_Binder : constant Name_Id := N + 638; + Name_Binder_Prefix : constant Name_Id := N + 639; + Name_Body_Suffix : constant Name_Id := N + 640; + Name_Builder : constant Name_Id := N + 641; + Name_Builder_Switches : constant Name_Id := N + 642; + Name_Compiler : constant Name_Id := N + 643; + Name_Compiler_Kind : constant Name_Id := N + 644; + Name_Config_Body_File_Name : constant Name_Id := N + 645; + Name_Config_Body_File_Name_Pattern : constant Name_Id := N + 646; + Name_Config_File_Switches : constant Name_Id := N + 647; + Name_Config_File_Unique : constant Name_Id := N + 648; + Name_Config_Spec_File_Name : constant Name_Id := N + 649; + Name_Config_Spec_File_Name_Pattern : constant Name_Id := N + 650; + Name_Configuration : constant Name_Id := N + 651; + Name_Cross_Reference : constant Name_Id := N + 652; + Name_Default_Language : constant Name_Id := N + 653; + Name_Default_Switches : constant Name_Id := N + 654; + Name_Dependency_Driver : constant Name_Id := N + 655; + Name_Dependency_File_Kind : constant Name_Id := N + 656; + Name_Dependency_Switches : constant Name_Id := N + 657; + Name_Driver : constant Name_Id := N + 658; + Name_Excluded_Source_Dirs : constant Name_Id := N + 659; + Name_Excluded_Source_Files : constant Name_Id := N + 660; + Name_Exec_Dir : constant Name_Id := N + 661; + Name_Executable : constant Name_Id := N + 662; + Name_Executable_Suffix : constant Name_Id := N + 663; + Name_Extends : constant Name_Id := N + 664; + Name_Externally_Built : constant Name_Id := N + 665; + Name_Finder : constant Name_Id := N + 666; + Name_Global_Configuration_Pragmas : constant Name_Id := N + 667; + Name_Global_Config_File : constant Name_Id := N + 668; + Name_Gnatls : constant Name_Id := N + 669; + Name_Gnatstub : constant Name_Id := N + 670; + Name_Implementation : constant Name_Id := N + 671; + Name_Implementation_Exceptions : constant Name_Id := N + 672; + Name_Implementation_Suffix : constant Name_Id := N + 673; + Name_Include_Switches : constant Name_Id := N + 674; + Name_Include_Path : constant Name_Id := N + 675; + Name_Include_Path_File : constant Name_Id := N + 676; + Name_Inherit_Source_Path : constant Name_Id := N + 677; + Name_Language_Kind : constant Name_Id := N + 678; + Name_Language_Processing : constant Name_Id := N + 679; + Name_Languages : constant Name_Id := N + 680; + Name_Library : constant Name_Id := N + 681; + Name_Library_Ali_Dir : constant Name_Id := N + 682; + Name_Library_Auto_Init : constant Name_Id := N + 683; + Name_Library_Auto_Init_Supported : constant Name_Id := N + 684; + Name_Library_Builder : constant Name_Id := N + 685; + Name_Library_Dir : constant Name_Id := N + 686; + Name_Library_GCC : constant Name_Id := N + 687; + Name_Library_Interface : constant Name_Id := N + 688; + Name_Library_Kind : constant Name_Id := N + 689; + Name_Library_Name : constant Name_Id := N + 690; + Name_Library_Major_Minor_Id_Supported : constant Name_Id := N + 691; + Name_Library_Options : constant Name_Id := N + 692; + Name_Library_Partial_Linker : constant Name_Id := N + 693; + Name_Library_Reference_Symbol_File : constant Name_Id := N + 694; + Name_Library_Src_Dir : constant Name_Id := N + 695; + Name_Library_Support : constant Name_Id := N + 696; + Name_Library_Symbol_File : constant Name_Id := N + 697; + Name_Library_Symbol_Policy : constant Name_Id := N + 698; + Name_Library_Version : constant Name_Id := N + 699; + Name_Library_Version_Switches : constant Name_Id := N + 700; + Name_Linker : constant Name_Id := N + 701; + Name_Linker_Executable_Option : constant Name_Id := N + 702; + Name_Linker_Lib_Dir_Option : constant Name_Id := N + 703; + Name_Linker_Lib_Name_Option : constant Name_Id := N + 704; + Name_Local_Config_File : constant Name_Id := N + 705; + Name_Local_Configuration_Pragmas : constant Name_Id := N + 706; + Name_Locally_Removed_Files : constant Name_Id := N + 707; + Name_Mapping_File_Switches : constant Name_Id := N + 708; + Name_Mapping_Spec_Suffix : constant Name_Id := N + 709; + Name_Mapping_Body_Suffix : constant Name_Id := N + 710; + Name_Metrics : constant Name_Id := N + 711; + Name_Naming : constant Name_Id := N + 712; + Name_Objects_Path : constant Name_Id := N + 713; + Name_Objects_Path_File : constant Name_Id := N + 714; + Name_Object_Dir : constant Name_Id := N + 715; + Name_Pic_Option : constant Name_Id := N + 716; + Name_Pretty_Printer : constant Name_Id := N + 717; + Name_Prefix : constant Name_Id := N + 718; + Name_Project : constant Name_Id := N + 719; + Name_Roots : constant Name_Id := N + 720; + Name_Required_Switches : constant Name_Id := N + 721; + Name_Run_Path_Option : constant Name_Id := N + 722; + Name_Runtime_Project : constant Name_Id := N + 723; + Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 724; + Name_Shared_Library_Prefix : constant Name_Id := N + 725; + Name_Shared_Library_Suffix : constant Name_Id := N + 726; + Name_Separate_Suffix : constant Name_Id := N + 727; + Name_Source_Dirs : constant Name_Id := N + 728; + Name_Source_Files : constant Name_Id := N + 729; + Name_Source_List_File : constant Name_Id := N + 730; + Name_Spec : constant Name_Id := N + 731; + Name_Spec_Suffix : constant Name_Id := N + 732; + Name_Specification : constant Name_Id := N + 733; + Name_Specification_Exceptions : constant Name_Id := N + 734; + Name_Specification_Suffix : constant Name_Id := N + 735; + Name_Stack : constant Name_Id := N + 736; + Name_Switches : constant Name_Id := N + 737; + Name_Symbolic_Link_Supported : constant Name_Id := N + 738; + Name_Sync : constant Name_Id := N + 739; + Name_Synchronize : constant Name_Id := N + 740; + Name_Toolchain_Description : constant Name_Id := N + 741; + Name_Toolchain_Version : constant Name_Id := N + 742; + Name_Runtime_Library_Dir : constant Name_Id := N + 743; -- Other miscellaneous names used in front end - Name_Unaligned_Valid : constant Name_Id := N + 727; + Name_Unaligned_Valid : constant Name_Id := N + 744; -- Ada 2005 reserved words - First_2005_Reserved_Word : constant Name_Id := N + 728; - Name_Interface : constant Name_Id := N + 728; - Name_Overriding : constant Name_Id := N + 729; - Name_Synchronized : constant Name_Id := N + 730; - Last_2005_Reserved_Word : constant Name_Id := N + 730; + First_2005_Reserved_Word : constant Name_Id := N + 745; + Name_Interface : constant Name_Id := N + 745; + Name_Overriding : constant Name_Id := N + 746; + Name_Synchronized : constant Name_Id := N + 747; + Last_2005_Reserved_Word : constant Name_Id := N + 747; subtype Ada_2005_Reserved_Words is Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word; -- Mark last defined name for consistency check in Snames body - Last_Predefined_Name : constant Name_Id := N + 730; + Last_Predefined_Name : constant Name_Id := N + 747; --------------------------------------- -- Subtypes Defining Name Categories -- @@ -1172,6 +1187,7 @@ package Snames is Attribute_Emax, Attribute_Enabled, Attribute_Enum_Rep, + Attribute_Enum_Val, Attribute_Epsilon, Attribute_Exponent, Attribute_External_Tag, @@ -1182,9 +1198,11 @@ package Snames is Attribute_Fore, Attribute_Has_Access_Values, Attribute_Has_Discriminants, + Attribute_Has_Tagged_Values, Attribute_Identity, Attribute_Img, Attribute_Integer_Value, + Attribute_Invalid_Value, Attribute_Large, Attribute_Last, Attribute_Last_Bit, @@ -1219,6 +1237,7 @@ package Snames is Attribute_Priority, Attribute_Range, Attribute_Range_Length, + Attribute_Result, Attribute_Round, Attribute_Safe_Emax, Attribute_Safe_First, @@ -1353,6 +1372,10 @@ package Snames is -- Configuration pragmas + -- Note: This list is in the GNAT users guide, so be sure that if any + -- additions or deletions are made to the following list, they are + -- properly reflected in the users guide. + Pragma_Ada_83, Pragma_Ada_95, Pragma_Ada_05, @@ -1360,6 +1383,7 @@ package Snames is Pragma_Assertion_Policy, Pragma_C_Pass_By_Copy, Pragma_Check_Name, + Pragma_Check_Policy, Pragma_Compile_Time_Error, Pragma_Compile_Time_Warning, Pragma_Compiler_Unit, @@ -1385,8 +1409,8 @@ package Snames is Pragma_No_Strict_Aliasing, Pragma_Normalize_Scalars, Pragma_Optimize_Alignment, - Pragma_Polling, Pragma_Persistent_BSS, + Pragma_Polling, Pragma_Priority_Specific_Dispatching, Pragma_Profile, Pragma_Profile_Warnings, @@ -1420,6 +1444,7 @@ package Snames is Pragma_Atomic, Pragma_Atomic_Components, Pragma_Attach_Handler, + Pragma_Check, Pragma_CIL_Constructor, Pragma_Comment, Pragma_Common_Object, @@ -1480,6 +1505,8 @@ package Snames is Pragma_Pack, Pragma_Page, Pragma_Passive, + Pragma_Postcondition, + Pragma_Precondition, Pragma_Preelaborable_Initialization, Pragma_Preelaborate, Pragma_Preelaborate_05, @@ -1487,6 +1514,7 @@ package Snames is Pragma_Pure, Pragma_Pure_05, Pragma_Pure_Function, + Pragma_Relative_Deadline, Pragma_Remote_Call_Interface, Pragma_Remote_Types, Pragma_Share_Generic, diff --git a/gcc/ada/snames.h b/gcc/ada/snames.h index 2f282edf..80ed039 100644 --- a/gcc/ada/snames.h +++ b/gcc/ada/snames.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2007, Free Software Foundation, Inc. * + * Copyright (C) 1992-2008, 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- * @@ -73,118 +73,122 @@ extern unsigned char Get_Attribute_Id (int); #define Attr_Emax 26 #define Attr_Enabled 27 #define Attr_Enum_Rep 28 -#define Attr_Epsilon 29 -#define Attr_Exponent 30 -#define Attr_External_Tag 31 -#define Attr_Fast_Math 32 -#define Attr_First 33 -#define Attr_First_Bit 34 -#define Attr_Fixed_Value 35 -#define Attr_Fore 36 -#define Attr_Has_Access_Values 37 -#define Attr_Has_Discriminants 38 -#define Attr_Identity 39 -#define Attr_Img 40 -#define Attr_Integer_Value 41 -#define Attr_Large 42 -#define Attr_Last 43 -#define Attr_Last_Bit 44 -#define Attr_Leading_Part 45 -#define Attr_Length 46 -#define Attr_Machine_Emax 47 -#define Attr_Machine_Emin 48 -#define Attr_Machine_Mantissa 49 -#define Attr_Machine_Overflows 50 -#define Attr_Machine_Radix 51 -#define Attr_Machine_Rounding 52 -#define Attr_Machine_Rounds 53 -#define Attr_Machine_Size 54 -#define Attr_Mantissa 55 -#define Attr_Max_Size_In_Storage_Elements 56 -#define Attr_Maximum_Alignment 57 -#define Attr_Mechanism_Code 58 -#define Attr_Mod 59 -#define Attr_Model_Emin 60 -#define Attr_Model_Epsilon 61 -#define Attr_Model_Mantissa 62 -#define Attr_Model_Small 63 -#define Attr_Modulus 64 -#define Attr_Null_Parameter 65 -#define Attr_Object_Size 66 -#define Attr_Old 67 -#define Attr_Partition_ID 68 -#define Attr_Passed_By_Reference 69 -#define Attr_Pool_Address 70 -#define Attr_Pos 71 -#define Attr_Position 72 -#define Attr_Priority 73 -#define Attr_Range 74 -#define Attr_Range_Length 75 -#define Attr_Round 76 -#define Attr_Safe_Emax 77 -#define Attr_Safe_First 78 -#define Attr_Safe_Large 79 -#define Attr_Safe_Last 80 -#define Attr_Safe_Small 81 -#define Attr_Scale 82 -#define Attr_Scaling 83 -#define Attr_Signed_Zeros 84 -#define Attr_Size 85 -#define Attr_Small 86 -#define Attr_Storage_Size 87 -#define Attr_Storage_Unit 88 -#define Attr_Stream_Size 89 -#define Attr_Tag 90 -#define Attr_Target_Name 91 -#define Attr_Terminated 92 -#define Attr_To_Address 93 -#define Attr_Type_Class 94 -#define Attr_UET_Address 95 -#define Attr_Unbiased_Rounding 96 -#define Attr_Unchecked_Access 97 -#define Attr_Unconstrained_Array 98 -#define Attr_Universal_Literal_String 99 -#define Attr_Unrestricted_Access 100 -#define Attr_VADS_Size 101 -#define Attr_Val 102 -#define Attr_Valid 103 -#define Attr_Value_Size 104 -#define Attr_Version 105 -#define Attr_Wchar_T_Size 106 -#define Attr_Wide_Wide_Width 107 -#define Attr_Wide_Width 108 -#define Attr_Width 109 -#define Attr_Word_Size 110 -#define Attr_Adjacent 111 -#define Attr_Ceiling 112 -#define Attr_Copy_Sign 113 -#define Attr_Floor 114 -#define Attr_Fraction 115 -#define Attr_Image 116 -#define Attr_Input 117 -#define Attr_Machine 118 -#define Attr_Max 119 -#define Attr_Min 120 -#define Attr_Model 121 -#define Attr_Pred 122 -#define Attr_Remainder 123 -#define Attr_Rounding 124 -#define Attr_Succ 125 -#define Attr_Truncation 126 -#define Attr_Value 127 -#define Attr_Wide_Image 128 -#define Attr_Wide_Wide_Image 129 -#define Attr_Wide_Value 130 -#define Attr_Wide_Wide_Value 131 -#define Attr_Output 132 -#define Attr_Read 133 -#define Attr_Write 134 -#define Attr_Elab_Body 135 -#define Attr_Elab_Spec 136 -#define Attr_Storage_Pool 137 -#define Attr_Base 138 -#define Attr_Class 139 -#define Attr_Stub_Type 140 +#define Attr_Enum_Val 29 +#define Attr_Epsilon 30 +#define Attr_Exponent 31 +#define Attr_External_Tag 32 +#define Attr_Fast_Math 33 +#define Attr_First 34 +#define Attr_First_Bit 35 +#define Attr_Fixed_Value 36 +#define Attr_Fore 37 +#define Attr_Has_Access_Values 38 +#define Attr_Has_Discriminants 39 +#define Attr_Has_Tagged_Values 40 +#define Attr_Identity 41 +#define Attr_Img 42 +#define Attr_Integer_Value 43 +#define Attr_Invalid_Value 44 +#define Attr_Large 45 +#define Attr_Last 46 +#define Attr_Last_Bit 47 +#define Attr_Leading_Part 48 +#define Attr_Length 49 +#define Attr_Machine_Emax 50 +#define Attr_Machine_Emin 51 +#define Attr_Machine_Mantissa 52 +#define Attr_Machine_Overflows 53 +#define Attr_Machine_Radix 54 +#define Attr_Machine_Rounding 55 +#define Attr_Machine_Rounds 56 +#define Attr_Machine_Size 57 +#define Attr_Mantissa 58 +#define Attr_Max_Size_In_Storage_Elements 59 +#define Attr_Maximum_Alignment 60 +#define Attr_Mechanism_Code 61 +#define Attr_Mod 62 +#define Attr_Model_Emin 63 +#define Attr_Model_Epsilon 64 +#define Attr_Model_Mantissa 65 +#define Attr_Model_Small 66 +#define Attr_Modulus 67 +#define Attr_Null_Parameter 68 +#define Attr_Object_Size 69 +#define Attr_Old 70 +#define Attr_Partition_ID 71 +#define Attr_Passed_By_Reference 72 +#define Attr_Pool_Address 73 +#define Attr_Pos 74 +#define Attr_Position 75 +#define Attr_Priority 76 +#define Attr_Range 77 +#define Attr_Range_Length 78 +#define Attr_Result 79 +#define Attr_Round 80 +#define Attr_Safe_Emax 81 +#define Attr_Safe_First 82 +#define Attr_Safe_Large 83 +#define Attr_Safe_Last 84 +#define Attr_Safe_Small 85 +#define Attr_Scale 86 +#define Attr_Scaling 87 +#define Attr_Signed_Zeros 88 +#define Attr_Size 89 +#define Attr_Small 90 +#define Attr_Storage_Size 91 +#define Attr_Storage_Unit 92 +#define Attr_Stream_Size 93 +#define Attr_Tag 94 +#define Attr_Target_Name 95 +#define Attr_Terminated 96 +#define Attr_To_Address 97 +#define Attr_Type_Class 98 +#define Attr_UET_Address 99 +#define Attr_Unbiased_Rounding 100 +#define Attr_Unchecked_Access 101 +#define Attr_Unconstrained_Array 102 +#define Attr_Universal_Literal_String 103 +#define Attr_Unrestricted_Access 104 +#define Attr_VADS_Size 105 +#define Attr_Val 106 +#define Attr_Valid 107 +#define Attr_Value_Size 108 +#define Attr_Version 109 +#define Attr_Wchar_T_Size 110 +#define Attr_Wide_Wide_Width 111 +#define Attr_Wide_Width 112 +#define Attr_Width 113 +#define Attr_Word_Size 114 +#define Attr_Adjacent 115 +#define Attr_Ceiling 116 +#define Attr_Copy_Sign 117 +#define Attr_Floor 118 +#define Attr_Fraction 119 +#define Attr_Image 120 +#define Attr_Input 121 +#define Attr_Machine 122 +#define Attr_Max 123 +#define Attr_Min 124 +#define Attr_Model 125 +#define Attr_Pred 126 +#define Attr_Remainder 127 +#define Attr_Rounding 128 +#define Attr_Succ 129 +#define Attr_Truncation 130 +#define Attr_Value 131 +#define Attr_Wide_Image 132 +#define Attr_Wide_Wide_Image 133 +#define Attr_Wide_Value 134 +#define Attr_Wide_Wide_Value 135 +#define Attr_Output 136 +#define Attr_Read 137 +#define Attr_Write 138 +#define Attr_Elab_Body 139 +#define Attr_Elab_Spec 140 +#define Attr_Storage_Pool 141 +#define Attr_Base 142 +#define Attr_Class 143 +#define Attr_Stub_Type 144 /* Define the numeric values for the conventions. */ @@ -224,163 +228,168 @@ extern unsigned char Get_Pragma_Id (int); #define Pragma_Assertion_Policy 4 #define Pragma_C_Pass_By_Copy 5 #define Pragma_Check_Name 6 -#define Pragma_Compile_Time_Error 7 -#define Pragma_Compile_Time_Warning 8 -#define Pragma_Compiler_Unit 9 -#define Pragma_Component_Alignment 10 -#define Pragma_Convention_Identifier 11 -#define Pragma_Debug_Policy 12 -#define Pragma_Detect_Blocking 13 -#define Pragma_Discard_Names 14 -#define Pragma_Elaboration_Checks 15 -#define Pragma_Eliminate 16 -#define Pragma_Extend_System 17 -#define Pragma_Extensions_Allowed 18 -#define Pragma_External_Name_Casing 19 -#define Pragma_Favor_Top_Level 20 -#define Pragma_Float_Representation 21 -#define Pragma_Implicit_Packing 22 -#define Pragma_Initialize_Scalars 23 -#define Pragma_Interrupt_State 24 -#define Pragma_License 25 -#define Pragma_Locking_Policy 26 -#define Pragma_Long_Float 27 -#define Pragma_No_Run_Time 28 -#define Pragma_No_Strict_Aliasing 29 -#define Pragma_Normalize_Scalars 30 -#define Pragma_Optimize_Alignment 31 -#define Pragma_Polling 32 -#define Pragma_Persistent_BSS 33 -#define Pragma_Priority_Specific_Dispatching 34 -#define Pragma_Profile 35 -#define Pragma_Profile_Warnings 36 -#define Pragma_Propagate_Exceptions 37 -#define Pragma_Queuing_Policy 38 -#define Pragma_Ravenscar 39 -#define Pragma_Restricted_Run_Time 40 -#define Pragma_Restrictions 41 -#define Pragma_Restriction_Warnings 42 -#define Pragma_Reviewable 43 -#define Pragma_Source_File_Name 44 -#define Pragma_Source_File_Name_Project 45 -#define Pragma_Style_Checks 46 -#define Pragma_Suppress 47 -#define Pragma_Suppress_Exception_Locations 48 -#define Pragma_Task_Dispatching_Policy 49 -#define Pragma_Universal_Data 50 -#define Pragma_Unsuppress 51 -#define Pragma_Use_VADS_Size 52 -#define Pragma_Validity_Checks 53 -#define Pragma_Warnings 54 -#define Pragma_Wide_Character_Encoding 55 -#define Pragma_Abort_Defer 56 -#define Pragma_All_Calls_Remote 57 -#define Pragma_Annotate 58 -#define Pragma_Assert 59 -#define Pragma_Asynchronous 60 -#define Pragma_Atomic 61 -#define Pragma_Atomic_Components 62 -#define Pragma_Attach_Handler 63 -#define Pragma_CIL_Constructor 64 -#define Pragma_Comment 65 -#define Pragma_Common_Object 66 -#define Pragma_Complete_Representation 67 -#define Pragma_Complex_Representation 68 -#define Pragma_Controlled 69 -#define Pragma_Convention 70 -#define Pragma_CPP_Class 71 -#define Pragma_CPP_Constructor 72 -#define Pragma_CPP_Virtual 73 -#define Pragma_CPP_Vtable 74 -#define Pragma_Debug 75 -#define Pragma_Elaborate 76 -#define Pragma_Elaborate_All 77 -#define Pragma_Elaborate_Body 78 -#define Pragma_Export 79 -#define Pragma_Export_Exception 80 -#define Pragma_Export_Function 81 -#define Pragma_Export_Object 82 -#define Pragma_Export_Procedure 83 -#define Pragma_Export_Value 84 -#define Pragma_Export_Valued_Procedure 85 -#define Pragma_External 86 -#define Pragma_Finalize_Storage_Only 87 -#define Pragma_Ident 88 -#define Pragma_Implemented_By_Entry 89 -#define Pragma_Import 90 -#define Pragma_Import_Exception 91 -#define Pragma_Import_Function 92 -#define Pragma_Import_Object 93 -#define Pragma_Import_Procedure 94 -#define Pragma_Import_Valued_Procedure 95 -#define Pragma_Inline 96 -#define Pragma_Inline_Always 97 -#define Pragma_Inline_Generic 98 -#define Pragma_Inspection_Point 99 -#define Pragma_Interface_Name 100 -#define Pragma_Interrupt_Handler 101 -#define Pragma_Interrupt_Priority 102 -#define Pragma_Java_Constructor 103 -#define Pragma_Java_Interface 104 -#define Pragma_Keep_Names 105 -#define Pragma_Link_With 106 -#define Pragma_Linker_Alias 107 -#define Pragma_Linker_Constructor 108 -#define Pragma_Linker_Destructor 109 -#define Pragma_Linker_Options 110 -#define Pragma_Linker_Section 111 -#define Pragma_List 112 -#define Pragma_Machine_Attribute 113 -#define Pragma_Main 114 -#define Pragma_Main_Storage 115 -#define Pragma_Memory_Size 116 -#define Pragma_No_Body 117 -#define Pragma_No_Return 118 -#define Pragma_Obsolescent 119 -#define Pragma_Optimize 120 -#define Pragma_Pack 121 -#define Pragma_Page 122 -#define Pragma_Passive 123 -#define Pragma_Preelaborable_Initialization 124 -#define Pragma_Preelaborate 125 -#define Pragma_Preelaborate_05 126 -#define Pragma_Psect_Object 127 -#define Pragma_Pure 128 -#define Pragma_Pure_05 129 -#define Pragma_Pure_Function 130 -#define Pragma_Remote_Call_Interface 131 -#define Pragma_Remote_Types 132 -#define Pragma_Share_Generic 133 -#define Pragma_Shared 134 -#define Pragma_Shared_Passive 135 -#define Pragma_Source_Reference 136 -#define Pragma_Static_Elaboration_Desired 137 -#define Pragma_Stream_Convert 138 -#define Pragma_Subtitle 139 -#define Pragma_Suppress_All 140 -#define Pragma_Suppress_Debug_Info 141 -#define Pragma_Suppress_Initialization 142 -#define Pragma_System_Name 143 -#define Pragma_Task_Info 144 -#define Pragma_Task_Name 145 -#define Pragma_Task_Storage 146 -#define Pragma_Time_Slice 147 -#define Pragma_Title 148 -#define Pragma_Unchecked_Union 149 -#define Pragma_Unimplemented_Unit 150 -#define Pragma_Universal_Aliasing 151 -#define Pragma_Unmodified 152 -#define Pragma_Unreferenced 153 -#define Pragma_Unreferenced_Objects 154 -#define Pragma_Unreserve_All_Interrupts 155 -#define Pragma_Volatile 156 -#define Pragma_Volatile_Components 157 -#define Pragma_Weak_External 158 -#define Pragma_AST_Entry 159 -#define Pragma_Fast_Math 160 -#define Pragma_Interface 161 -#define Pragma_Priority 162 -#define Pragma_Storage_Size 163 -#define Pragma_Storage_Unit 164 +#define Pragma_Check_Policy 7 +#define Pragma_Compile_Time_Error 8 +#define Pragma_Compile_Time_Warning 9 +#define Pragma_Compiler_Unit 10 +#define Pragma_Component_Alignment 11 +#define Pragma_Convention_Identifier 12 +#define Pragma_Debug_Policy 13 +#define Pragma_Detect_Blocking 14 +#define Pragma_Discard_Names 15 +#define Pragma_Elaboration_Checks 16 +#define Pragma_Eliminate 17 +#define Pragma_Extend_System 18 +#define Pragma_Extensions_Allowed 19 +#define Pragma_External_Name_Casing 20 +#define Pragma_Favor_Top_Level 21 +#define Pragma_Float_Representation 22 +#define Pragma_Implicit_Packing 23 +#define Pragma_Initialize_Scalars 24 +#define Pragma_Interrupt_State 25 +#define Pragma_License 26 +#define Pragma_Locking_Policy 27 +#define Pragma_Long_Float 28 +#define Pragma_No_Run_Time 29 +#define Pragma_No_Strict_Aliasing 30 +#define Pragma_Normalize_Scalars 31 +#define Pragma_Optimize_Alignment 32 +#define Pragma_Polling 33 +#define Pragma_Persistent_BSS 34 +#define Pragma_Priority_Specific_Dispatching 35 +#define Pragma_Profile 36 +#define Pragma_Profile_Warnings 37 +#define Pragma_Propagate_Exceptions 38 +#define Pragma_Queuing_Policy 39 +#define Pragma_Ravenscar 40 +#define Pragma_Restricted_Run_Time 41 +#define Pragma_Restrictions 42 +#define Pragma_Restriction_Warnings 43 +#define Pragma_Reviewable 44 +#define Pragma_Source_File_Name 45 +#define Pragma_Source_File_Name_Project 46 +#define Pragma_Style_Checks 47 +#define Pragma_Suppress 48 +#define Pragma_Suppress_Exception_Locations 49 +#define Pragma_Task_Dispatching_Policy 50 +#define Pragma_Universal_Data 51 +#define Pragma_Unsuppress 52 +#define Pragma_Use_VADS_Size 53 +#define Pragma_Validity_Checks 54 +#define Pragma_Warnings 55 +#define Pragma_Wide_Character_Encoding 56 +#define Pragma_Abort_Defer 57 +#define Pragma_All_Calls_Remote 58 +#define Pragma_Annotate 59 +#define Pragma_Assert 60 +#define Pragma_Asynchronous 61 +#define Pragma_Atomic 62 +#define Pragma_Atomic_Components 63 +#define Pragma_Attach_Handler 64 +#define Pragma_Check 65 +#define Pragma_CIL_Constructor 66 +#define Pragma_Comment 67 +#define Pragma_Common_Object 68 +#define Pragma_Complete_Representation 69 +#define Pragma_Complex_Representation 70 +#define Pragma_Controlled 71 +#define Pragma_Convention 72 +#define Pragma_CPP_Class 73 +#define Pragma_CPP_Constructor 74 +#define Pragma_CPP_Virtual 75 +#define Pragma_CPP_Vtable 76 +#define Pragma_Debug 77 +#define Pragma_Elaborate 78 +#define Pragma_Elaborate_All 79 +#define Pragma_Elaborate_Body 80 +#define Pragma_Export 81 +#define Pragma_Export_Exception 82 +#define Pragma_Export_Function 83 +#define Pragma_Export_Object 84 +#define Pragma_Export_Procedure 85 +#define Pragma_Export_Value 86 +#define Pragma_Export_Valued_Procedure 87 +#define Pragma_External 88 +#define Pragma_Finalize_Storage_Only 89 +#define Pragma_Ident 90 +#define Pragma_Implemented_By_Entry 91 +#define Pragma_Import 92 +#define Pragma_Import_Exception 93 +#define Pragma_Import_Function 94 +#define Pragma_Import_Object 95 +#define Pragma_Import_Procedure 96 +#define Pragma_Import_Valued_Procedure 97 +#define Pragma_Inline 98 +#define Pragma_Inline_Always 99 +#define Pragma_Inline_Generic 100 +#define Pragma_Inspection_Point 101 +#define Pragma_Interface_Name 102 +#define Pragma_Interrupt_Handler 103 +#define Pragma_Interrupt_Priority 104 +#define Pragma_Java_Constructor 105 +#define Pragma_Java_Interface 106 +#define Pragma_Keep_Names 107 +#define Pragma_Link_With 108 +#define Pragma_Linker_Alias 109 +#define Pragma_Linker_Constructor 110 +#define Pragma_Linker_Destructor 111 +#define Pragma_Linker_Options 112 +#define Pragma_Linker_Section 113 +#define Pragma_List 114 +#define Pragma_Machine_Attribute 115 +#define Pragma_Main 116 +#define Pragma_Main_Storage 117 +#define Pragma_Memory_Size 118 +#define Pragma_No_Body 119 +#define Pragma_No_Return 120 +#define Pragma_Obsolescent 121 +#define Pragma_Optimize 122 +#define Pragma_Pack 123 +#define Pragma_Page 124 +#define Pragma_Passive 125 +#define Pragma_Postcondition 126 +#define Pragma_Precondition 127 +#define Pragma_Preelaborable_Initialization 128 +#define Pragma_Preelaborate 129 +#define Pragma_Preelaborate_05 130 +#define Pragma_Psect_Object 131 +#define Pragma_Pure 132 +#define Pragma_Pure_05 133 +#define Pragma_Pure_Function 134 +#define Pragma_Relative_Deadline 135 +#define Pragma_Remote_Call_Interface 136 +#define Pragma_Remote_Types 137 +#define Pragma_Share_Generic 138 +#define Pragma_Shared 139 +#define Pragma_Shared_Passive 140 +#define Pragma_Source_Reference 141 +#define Pragma_Static_Elaboration_Desired 142 +#define Pragma_Stream_Convert 143 +#define Pragma_Subtitle 144 +#define Pragma_Suppress_All 145 +#define Pragma_Suppress_Debug_Info 146 +#define Pragma_Suppress_Initialization 147 +#define Pragma_System_Name 148 +#define Pragma_Task_Info 149 +#define Pragma_Task_Name 150 +#define Pragma_Task_Storage 151 +#define Pragma_Time_Slice 152 +#define Pragma_Title 153 +#define Pragma_Unchecked_Union 154 +#define Pragma_Unimplemented_Unit 155 +#define Pragma_Universal_Aliasing 156 +#define Pragma_Unmodified 157 +#define Pragma_Unreferenced 158 +#define Pragma_Unreferenced_Objects 159 +#define Pragma_Unreserve_All_Interrupts 160 +#define Pragma_Volatile 161 +#define Pragma_Volatile_Components 162 +#define Pragma_Weak_External 163 +#define Pragma_AST_Entry 164 +#define Pragma_Fast_Math 165 +#define Pragma_Interface 166 +#define Pragma_Priority 167 +#define Pragma_Storage_Size 168 +#define Pragma_Storage_Unit 169 /* End of snames.h (C version of Snames package spec) */ diff --git a/gcc/ada/tree_gen.adb b/gcc/ada/tree_gen.adb index 918ae29..901d373 100644 --- a/gcc/ada/tree_gen.adb +++ b/gcc/ada/tree_gen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -32,12 +32,19 @@ with Nlists; with Opt; with Osint.C; with Repinfo; +with Sem_Aux; with Sinput; with Stand; with Stringt; with Uintp; with Urealp; +with Tree_In; +pragma Warnings (Off, Tree_In); +-- We do not use Tree_In in the compiler, but it is small, and worth including +-- so that we get the proper license check for Tree_In when the compiler is +-- built. This will avoid adding bad dependencies to Tree_In and blowing ASIS. + procedure Tree_Gen is begin if Opt.Tree_Output then @@ -49,6 +56,7 @@ begin Lib.Tree_Write; Namet.Tree_Write; Nlists.Tree_Write; + Sem_Aux.Tree_Write; Sinput.Tree_Write; Stand.Tree_Write; Stringt.Tree_Write; diff --git a/gcc/ada/tree_in.adb b/gcc/ada/tree_in.adb index d9c6e77..605c6b1 100644 --- a/gcc/ada/tree_in.adb +++ b/gcc/ada/tree_in.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-1999, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -40,6 +40,7 @@ with Namet; with Nlists; with Opt; with Repinfo; +with Sem_Aux; with Sinput; with Stand; with Stringt; @@ -57,6 +58,7 @@ begin Lib.Tree_Read; Namet.Tree_Read; Nlists.Tree_Read; + Sem_Aux.Tree_Read; Sinput.Tree_Read; Stand.Tree_Read; Stringt.Tree_Read; |