diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 39 | ||||
| -rwxr-xr-x | gcc/ada/aspects.adb | 19 | ||||
| -rwxr-xr-x | gcc/ada/aspects.ads | 43 | ||||
| -rw-r--r-- | gcc/ada/atree.ads | 25 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/par-ch12.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/par-ch13.adb | 34 | ||||
| -rw-r--r-- | gcc/ada/par-ch7.adb | 31 | ||||
| -rw-r--r-- | gcc/ada/par-ch9.adb | 56 | ||||
| -rw-r--r-- | gcc/ada/par-endh.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/par.adb | 45 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 98 | ||||
| -rw-r--r-- | gcc/ada/sem_ch7.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 35 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 59 |
19 files changed, 401 insertions, 147 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 463108a..e73a3cd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,42 @@ +2011-08-01 Robert Dewar <dewar@adacore.com> + + * par-endh.adb: Minor reformatting. + +2011-08-01 Robert Dewar <dewar@adacore.com> + + * aspects.ads, aspects.adb: Add aspects for library unit pragmas + (Pre_Post_Aspects): New subtype. + * par-ch12.adb (P_Generic): New syntax for aspects in packages + * par-ch13.adb (P_Aspect_Specifications): Add Semicolon parameter + * par-ch7.adb (P_Package): Remove Decl parameter + (P_Package): Handle new syntax for aspects (before IS) + * par-ch9.adb (P_Protected_Definition): Remove Decl parameter, handle + new aspect syntax + (P_Task_Definition): Remove Decl parameter, handle new aspect syntax + * par.adb (P_Aspect_Specifications): Add Semicolon parameter + (P_Package): Remove Decl parameter + * sem_ch13.adb (Analyze_Aspect_Specifications): Handle library unit + aspects + * sem_ch7.adb (Analyze_Package_Declaration): Analyze new format aspect + specs + * sem_util.ads, sem_util.adb (Static_Boolean): New function + * sinfo.ads: Document new syntax for aspects in packages etc. + * sprint.adb: Handle new syntax of aspects before IS in package + +2011-08-01 Thomas Quinot <quinot@adacore.com> + + * atree.ads: Minor reformatting. + * sem_prag.adb: Minor reformatting. + +2011-08-01 Robert Dewar <dewar@adacore.com> + + * exp_util.adb (Insert_Actions): Fix error in handling Actions for + case expr alternative. + +2011-08-01 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb: Fix typo. + 2011-08-01 Geert Bosch <bosch@adacore.com> * sem_prag.adb (Check_No_Link_Name): New procedure. diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index ca87c6c..3ad2469 100755 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -143,14 +143,18 @@ package body Aspects is N_Object_Declaration => True, N_Package_Declaration => True, N_Package_Instantiation => True, + N_Package_Specification => True, N_Private_Extension_Declaration => True, N_Private_Type_Declaration => True, N_Procedure_Instantiation => True, + N_Protected_Body => True, N_Protected_Type_Declaration => True, N_Single_Protected_Declaration => True, N_Single_Task_Declaration => True, + N_Subprogram_Body => True, N_Subprogram_Declaration => True, N_Subtype_Declaration => True, + N_Task_Body => True, N_Task_Type_Declaration => True, others => False); @@ -165,8 +169,8 @@ package body Aspects is -- Table used for Same_Aspect, maps aspect to canonical aspect - Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id := ( - No_Aspect => No_Aspect, + Canonical_Aspect : constant array (Aspect_Id) of Aspect_Id := + (No_Aspect => No_Aspect, Aspect_Ada_2005 => Aspect_Ada_2005, Aspect_Ada_2012 => Aspect_Ada_2005, Aspect_Address => Aspect_Address, @@ -181,6 +185,17 @@ package body Aspects is Aspect_Favor_Top_Level => Aspect_Favor_Top_Level, Aspect_Inline => Aspect_Inline, Aspect_Inline_Always => Aspect_Inline, + Aspect_All_Calls_Remote => Aspect_All_Calls_Remote, + Aspect_Compiler_Unit => Aspect_Compiler_Unit, + Aspect_Elaborate_Body => Aspect_Elaborate_Body, + Aspect_Preelaborate => Aspect_Preelaborate, + Aspect_Preelaborate_05 => Aspect_Preelaborate_05, + Aspect_Pure => Aspect_Pure, + Aspect_Pure_05 => Aspect_Pure_05, + Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface, + Aspect_Remote_Types => Aspect_Remote_Types, + Aspect_Shared_Passive => Aspect_Shared_Passive, + Aspect_Universal_Data => Aspect_Universal_Data, Aspect_Input => Aspect_Input, Aspect_Invariant => Aspect_Invariant, Aspect_Machine_Radix => Aspect_Machine_Radix, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index ed391f0..e2e7e6f 100755 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -73,9 +73,24 @@ package Aspects is Aspect_Warnings, Aspect_Write, + -- The following aspects correspond to library unit pragmas + + Aspect_All_Calls_Remote, + Aspect_Compiler_Unit, -- GNAT + Aspect_Elaborate_Body, + Aspect_Preelaborate, + Aspect_Preelaborate_05, -- GNAT + Aspect_Pure, + Aspect_Pure_05, -- GNAT + Aspect_Remote_Call_Interface, + Aspect_Remote_Types, + Aspect_Shared_Passive, + Aspect_Universal_Data, -- GNAT + -- Remaining aspects have a static boolean value that turns the aspect -- on or off. They all correspond to pragmas, and the flag Aspect_Cancel - -- is set on the pragma if the corresponding aspect is False. + -- is set on the pragma if the corresponding aspect is False. These are + -- also Boolean aspects as defined below. Aspect_Ada_2005, -- GNAT Aspect_Ada_2012, -- GNAT @@ -109,6 +124,14 @@ package Aspects is Aspect_Post => True, others => False); + -- The following subtype defines aspects corresponding to library unit + -- pragmas, these can only validly appear as aspects for library units, + -- and result in a corresponding pragma being inserted immediately after + -- the occurrence of the aspect. + + subtype Library_Unit_Aspects is + Aspect_Id range Aspect_All_Calls_Remote .. Aspect_Universal_Data; + -- The following subtype defines aspects accepting an optional static -- boolean parameter indicating if the aspect should be active or -- cancelling. If the parameter is missing the effective value is True, @@ -119,6 +142,9 @@ package Aspects is subtype Boolean_Aspects is Aspect_Id range Aspect_Ada_2005 .. Aspect_Id'Last; + subtype Pre_Post_Aspects is + Aspect_Id range Aspect_Post .. Aspect_Precondition; + -- The following type is used for indicating allowed expression forms type Aspect_Expression is @@ -158,6 +184,8 @@ package Aspects is Aspect_Value_Size => Expression, Aspect_Warnings => Name, Aspect_Write => Name, + + Library_Unit_Aspects => Optional, Boolean_Aspects => Optional); ----------------------------------------- @@ -176,12 +204,15 @@ package Aspects is (Name_Ada_2012, Aspect_Ada_2012), (Name_Address, Aspect_Address), (Name_Alignment, Aspect_Alignment), + (Name_All_Calls_Remote, Aspect_All_Calls_Remote), (Name_Atomic, Aspect_Atomic), (Name_Atomic_Components, Aspect_Atomic_Components), (Name_Bit_Order, Aspect_Bit_Order), + (Name_Compiler_Unit, Aspect_Compiler_Unit), (Name_Component_Size, Aspect_Component_Size), - (Name_Dynamic_Predicate, Aspect_Dynamic_Predicate), (Name_Discard_Names, Aspect_Discard_Names), + (Name_Dynamic_Predicate, Aspect_Dynamic_Predicate), + (Name_Elaborate_Body, Aspect_Elaborate_Body), (Name_External_Tag, Aspect_External_Tag), (Name_Favor_Top_Level, Aspect_Favor_Top_Level), (Name_Inline, Aspect_Inline), @@ -199,9 +230,16 @@ package Aspects is (Name_Precondition, Aspect_Precondition), (Name_Predicate, Aspect_Predicate), (Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization), + (Name_Preelaborate, Aspect_Preelaborate), + (Name_Preelaborate_05, Aspect_Preelaborate_05), + (Name_Pure, Aspect_Pure), + (Name_Pure_05, Aspect_Pure_05), (Name_Pure_Function, Aspect_Pure_Function), (Name_Read, Aspect_Read), + (Name_Remote_Call_Interface, Aspect_Remote_Call_Interface), + (Name_Remote_Types, Aspect_Remote_Types), (Name_Shared, Aspect_Shared), + (Name_Shared_Passive, Aspect_Shared_Passive), (Name_Size, Aspect_Size), (Name_Static_Predicate, Aspect_Static_Predicate), (Name_Storage_Pool, Aspect_Storage_Pool), @@ -212,6 +250,7 @@ package Aspects is (Name_Type_Invariant, Aspect_Type_Invariant), (Name_Unchecked_Union, Aspect_Unchecked_Union), (Name_Universal_Aliasing, Aspect_Universal_Aliasing), + (Name_Universal_Data, Aspect_Universal_Data), (Name_Unmodified, Aspect_Unmodified), (Name_Unreferenced, Aspect_Unreferenced), (Name_Unreferenced_Objects, Aspect_Unreferenced_Objects), diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 40d4d8e..ccd4ac2 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -821,7 +821,7 @@ package Atree is pragma Inline (Is_Rewrite_Insertion); -- Tests whether the given node was marked using Mark_Rewrite_Insertion. -- This is used in reconstructing the original tree (where such nodes are - -- to be eliminated from the reconstructed tree). + -- to be eliminated). procedure Rewrite (Old_Node, New_Node : Node_Id); -- This is used when a complete subtree is to be replaced. Old_Node is the @@ -889,8 +889,8 @@ package Atree is package Unchecked_Access is - -- Functions to allow interpretation of Union_Id values as Uint - -- and Ureal values + -- Functions to allow interpretation of Union_Id values as Uint and + -- Ureal values function To_Union is new Unchecked_Conversion (Uint, Union_Id); function To_Union is new Unchecked_Conversion (Ureal, Union_Id); @@ -898,8 +898,8 @@ package Atree is function From_Union is new Unchecked_Conversion (Union_Id, Uint); function From_Union is new Unchecked_Conversion (Union_Id, Ureal); - -- Functions to fetch contents of indicated field. It is an error - -- to attempt to read the value of a field which is not present. + -- Functions to fetch contents of indicated field. It is an error to + -- attempt to read the value of a field which is not present. function Field1 (N : Node_Id) return Union_Id; pragma Inline (Field1); @@ -1150,10 +1150,10 @@ package Atree is function Str3 (N : Node_Id) return String_Id; pragma Inline (Str3); - -- Note: the following Uintnn functions have a special test for - -- the Field value being Empty. If an Empty value is found then - -- Uint_0 is returned. This avoids the rather tricky requirement - -- of initializing all Uint fields in nodes and entities. + -- Note: the following Uintnn functions have a special test for the + -- Field value being Empty. If an Empty value is found then Uint_0 is + -- returned. This avoids the rather tricky requirement of initializing + -- all Uint fields in nodes and entities. function Uint2 (N : Node_Id) return Uint; pragma Inline (Uint2); @@ -3023,8 +3023,8 @@ package Atree is procedure Set_Flag254 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag254); - -- The following versions of Set_Noden also set the parent - -- pointer of the referenced node if it is non_Empty + -- The following versions of Set_Noden also set the parent pointer of + -- the referenced node if it is not Empty. procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node1_With_Parent); @@ -3042,8 +3042,7 @@ package Atree is pragma Inline (Set_Node5_With_Parent); -- The following versions of Set_Listn also set the parent pointer of - -- the referenced node if it is non_Empty. The procedures for List6 - -- to List12 can only be applied to nodes which have an extension. + -- the referenced node if it is not Empty. procedure Set_List1_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List1_With_Parent); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 57f67e4..48e2283 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2520,7 +2520,7 @@ package body Exp_Util is (Last (Actions (P)), Ins_Actions); else Set_Actions (P, Ins_Actions); - Analyze_List (Then_Actions (P)); + Analyze_List (Actions (P)); end if; return; diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index 9e80403..49962d8 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -202,7 +202,7 @@ package body Ch12 is if Token = Tok_Package then Gen_Decl := New_Node (N_Generic_Package_Declaration, Gen_Sloc); - Set_Specification (Gen_Decl, P_Package (Pf_Spcn, Gen_Decl)); + Set_Specification (Gen_Decl, P_Package (Pf_Spcn)); else Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc); diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 215174e..e3f72c7 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -381,7 +381,10 @@ package body Ch13 is -- Error recovery: cannot raise Error_Resync - procedure P_Aspect_Specifications (Decl : Node_Id) is + procedure P_Aspect_Specifications + (Decl : Node_Id; + Semicolon : Boolean := True) + is Aspects : List_Id; Aspect : Node_Id; A_Id : Aspect_Id; @@ -392,7 +395,10 @@ package body Ch13 is -- Check if aspect specification present if not Aspect_Specifications_Present then - TF_Semicolon; + if Semicolon then + TF_Semicolon; + end if; + return; end if; @@ -411,7 +417,11 @@ package body Ch13 is if Token /= Tok_Identifier then Error_Msg_SC ("aspect identifier expected"); - Resync_Past_Semicolon; + + if Semicolon then + Resync_Past_Semicolon; + end if; + return; end if; @@ -454,7 +464,10 @@ package body Ch13 is OK := False; else - Resync_Past_Semicolon; + if Semicolon then + Resync_Past_Semicolon; + end if; + return; end if; @@ -495,7 +508,10 @@ package body Ch13 is -- Test case of missing aspect definition - if Token = Tok_Comma or else Token = Tok_Semicolon then + if Token = Tok_Comma + or else Token = Tok_Semicolon + or else (not Semicolon and then Token /= Tok_Arrow) + then if Aspect_Argument (A_Id) /= Optional then Error_Msg_Node_1 := Aspect; Error_Msg_AP ("aspect& requires an aspect definition"); @@ -527,8 +543,14 @@ package body Ch13 is if Token = Tok_Comma then Scan; -- past comma + + -- Must be terminator character + else - T_Semicolon; + if Semicolon then + T_Semicolon; + end if; + exit; end if; end if; diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb index 14fedc9..45a0fb1 100644 --- a/gcc/ada/par-ch7.adb +++ b/gcc/ada/par-ch7.adb @@ -92,15 +92,17 @@ package body Ch7 is -- Error recovery: cannot raise Error_Resync - function P_Package - (Pf_Flags : Pf_Rec; - Decl : Node_Id := Empty) return Node_Id - is + function P_Package (Pf_Flags : Pf_Rec) return Node_Id is Package_Node : Node_Id; Specification_Node : Node_Id; Name_Node : Node_Id; Package_Sloc : Source_Ptr; + Dummy_Node : constant Node_Id := + New_Node (N_Package_Specification, Token_Ptr); + -- Dummy node to attach aspect specifications to until we properly + -- figure out where they eventually belong. + begin Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Name; @@ -147,8 +149,6 @@ package body Ch7 is Parse_Decls_Begin_End (Package_Node); end if; - return Package_Node; - -- Cases other than Package_Body else @@ -174,9 +174,11 @@ package body Ch7 is No_Constraint; TF_Semicolon; Pop_Scope_Stack; - return Package_Node; + + -- Generic package instantiation or package declaration else + P_Aspect_Specifications (Dummy_Node, Semicolon => False); TF_Is; -- Case of generic instantiation @@ -190,12 +192,12 @@ package body Ch7 is Scan; -- past NEW Package_Node := - New_Node (N_Package_Instantiation, Package_Sloc); + New_Node (N_Package_Instantiation, Package_Sloc); Set_Defining_Unit_Name (Package_Node, Name_Node); Set_Name (Package_Node, P_Qualified_Simple_Name); Set_Generic_Associations (Package_Node, P_Generic_Actual_Part_Opt); - P_Aspect_Specifications (Package_Node); + P_Aspect_Specifications (Error); Pop_Scope_Stack; -- Case of package declaration or package specification @@ -249,16 +251,13 @@ package body Ch7 is Discard_Junk_List (P_Sequence_Of_Statements (SS_None)); end if; - if Nkind (Package_Node) = N_Package_Declaration then - End_Statements (Specification_Node, Package_Node); - else - End_Statements (Specification_Node, Decl); - end if; + End_Statements (Specification_Node); end if; - - return Package_Node; end if; end if; + + Move_Aspects (From => Dummy_Node, To => Package_Node); + return Package_Node; end P_Package; ------------------------------ diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index 5c18adf..83233b6 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -40,19 +40,11 @@ package body Ch9 is function P_Entry_Body_Formal_Part return Node_Id; function P_Entry_Declaration return Node_Id; function P_Entry_Index_Specification return Node_Id; + function P_Protected_Definition return Node_Id; function P_Protected_Operation_Declaration_Opt return Node_Id; function P_Protected_Operation_Items return List_Id; function P_Task_Items return List_Id; - - function P_Protected_Definition (Decl : Node_Id) return Node_Id; - -- Parses protected definition and following aspect specifications if - -- present. The argument is the declaration node to which the aspect - -- specifications are to be attached. - - function P_Task_Definition (Decl : Node_Id) return Node_Id; - -- Parses task definition and following aspect specifications if present. - -- The argument is the declaration node to which the aspect specifications - -- are to be attached. + function P_Task_Definition return Node_Id; ----------------------------- -- 9.1 Task (also 10.1.3) -- @@ -60,13 +52,13 @@ package body Ch9 is -- TASK_TYPE_DECLARATION ::= -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] - -- [is [new INTERFACE_LIST with] TASK_DEFINITION] - -- [ASPECT_SPECIFICATIONS]; + -- [ASPECT_SPECIFICATIONS] + -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; -- SINGLE_TASK_DECLARATION ::= -- task DEFINING_IDENTIFIER - -- [is [new INTERFACE_LIST with] TASK_DEFINITION] - -- [ASPECT_SPECIFICATIONS]; + -- [ASPECT_SPECIFICATIONS] + -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; -- TASK_BODY ::= -- task body DEFINING_IDENTIFIER is @@ -153,27 +145,26 @@ package body Ch9 is end if; end if; - -- If we have aspect definitions present here, then we do not have - -- a task definition present. + -- Scan aspect specifications, don't eat the semicolon, since it + -- might not be there if we have an IS. - if Aspect_Specifications_Present then - P_Aspect_Specifications (Task_Node); + P_Aspect_Specifications (Task_Node, Semicolon => False); -- Parse optional task definition. Note that P_Task_Definition scans -- out the semicolon and possible aspect specifications as well as -- the task definition itself. - elsif Token = Tok_Semicolon then + if Token = Tok_Semicolon then - -- A little check, if the next token after semicolon is - -- Entry, then surely the semicolon should really be IS + -- A little check, if the next token after semicolon is Entry, + -- then surely the semicolon should really be IS Scan; -- past semicolon if Token = Tok_Entry then Error_Msg_SP -- CODEFIX ("|"";"" should be IS"); - Set_Task_Definition (Task_Node, P_Task_Definition (Task_Node)); + Set_Task_Definition (Task_Node, P_Task_Definition); else Pop_Scope_Stack; -- Remove unused entry end if; @@ -214,7 +205,7 @@ package body Ch9 is end if; end if; - Set_Task_Definition (Task_Node, P_Task_Definition (Task_Node)); + Set_Task_Definition (Task_Node, P_Task_Definition); end if; return Task_Node; @@ -253,7 +244,7 @@ package body Ch9 is -- Error recovery: cannot raise Error_Resync - function P_Task_Definition (Decl : Node_Id) return Node_Id is + function P_Task_Definition return Node_Id is Def_Node : Node_Id; begin @@ -273,7 +264,7 @@ package body Ch9 is end loop; end if; - End_Statements (Def_Node, Decl); + End_Statements (Def_Node); return Def_Node; end P_Task_Definition; @@ -367,13 +358,13 @@ package body Ch9 is -- PROTECTED_TYPE_DECLARATION ::= -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] - -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION - -- [ASPECT_SPECIFICATIONS]; + -- [ASPECT_SPECIFICATIONS] + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; -- SINGLE_PROTECTED_DECLARATION ::= -- protected DEFINING_IDENTIFIER + -- [ASPECT_SPECIFICATIONS] -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; - -- [ASPECT_SPECIFICATIONS]; -- PROTECTED_BODY ::= -- protected body DEFINING_IDENTIFIER is @@ -464,6 +455,8 @@ package body Ch9 is Scope.Table (Scope.Last).Labl := Name_Node; end if; + P_Aspect_Specifications (Protected_Node, Semicolon => False); + -- Check for semicolon not followed by IS, this is something like -- protected type r; @@ -525,8 +518,7 @@ package body Ch9 is Scan; -- past WITH end if; - Set_Protected_Definition - (Protected_Node, P_Protected_Definition (Protected_Node)); + Set_Protected_Definition (Protected_Node, P_Protected_Definition); return Protected_Node; end if; end P_Protected; @@ -561,7 +553,7 @@ package body Ch9 is -- Error recovery: cannot raise Error_Resync - function P_Protected_Definition (Decl : Node_Id) return Node_Id is + function P_Protected_Definition return Node_Id is Def_Node : Node_Id; Item_Node : Node_Id; @@ -607,7 +599,7 @@ package body Ch9 is end loop Declaration_Loop; end loop Private_Loop; - End_Statements (Def_Node, Decl); + End_Statements (Def_Node); return Def_Node; end P_Protected_Definition; diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index b250ecb..ca3506d 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -654,7 +654,8 @@ package body Endh is procedure End_Statements (Parent : Node_Id := Empty; - Decl : Node_Id := Empty) is + Decl : Node_Id := Empty) + is begin -- This loop runs more than once in the case where Check_End rejects -- the END sequence, as indicated by Check_End returning False. diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index ee05d9c..99f6806 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -762,14 +762,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is ------------- package Ch7 is - function P_Package - (Pf_Flags : Pf_Rec; - Decl : Node_Id := Empty) return Node_Id; + function P_Package (Pf_Flags : Pf_Rec) return Node_Id; -- Scans out any construct starting with the keyword PACKAGE. The -- parameter indicates which possible kinds of construct (body, spec, - -- instantiation etc.) are permissible in the current context. Decl - -- is set in the specification case to request that if there are aspect - -- specifications present, they be associated with this declaration. + -- instantiation etc.) are permissible in the current context. end Ch7; ------------- @@ -863,19 +859,30 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- rather more generous in considering something ill-formed to be an -- attempt at an aspect specification. The default is more strict for -- Ada versions before Ada 2012 (where aspect specifications are not - -- permitted). - - procedure P_Aspect_Specifications (Decl : Node_Id); - -- This subprogram is called with the current token pointing to either a - -- WITH keyword starting an aspect specification, or a semicolon. In the - -- former case, the aspect specifications are scanned out including the - -- terminating semicolon, the Has_Aspect_Specifications flag is set in - -- the given declaration node, and the list of aspect specifications is - -- constructed and associated with this declaration node using a call to - -- Set_Aspect_Specifications. If no WITH keyword is present, then this - -- call has no effect other than scanning out the semicolon. If Decl is - -- Error on entry, any scanned aspect specifications are ignored and a - -- message is output saying aspect specifications not permitted here. + -- permitted). Note: this routine never checks the terminator token + -- for aspects so it does not matter whether the aspect speficiations + -- are terminated by semicolon or some other character + + procedure P_Aspect_Specifications + (Decl : Node_Id; + Semicolon : Boolean := True); + -- This procedure scans out a series of aspect spefications. If argument + -- Semicolon is True, a terminating semicolon is also scanned. If this + -- argument is False, the scan pointer is left pointing past the aspects + -- and the caller must check for a proper terminator. + -- left pointing past the aspects, presumably pointing to a terminator. + -- + -- P_Aspect_Specification is called with the current token pointing to + -- either a WITH keyword starting an aspect specification, or an + -- instance of the terminator token. In the former case, the aspect + -- specifications are scanned out including the terminator token if it + -- it is a semicolon, and the Has_Aspect_Specifications flag is set in + -- the given declaration node. A list of aspects is built and stored for + -- this declaration node using a call to Set_Aspect_Specifications. If + -- no WITH keyword is present, then this call has no effect other than + -- scanning out the terminator if it is a semicolon. If Decl is Error on + -- entry, any scanned aspect specifications are ignored and a message is + -- output saying aspect specifications not permitted here. function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id; -- Function to parse a code statement. The caller has scanned out diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 80eacf6..697ec53 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5501,7 +5501,6 @@ package body Sem_Ch12 is and then Is_Private_Type (Designated_Type (T)) and then not Has_Private_View (N) and then Present (Full_View (Designated_Type (T))) - and then Used_As_Generic_Actual (T) then Switch_View (Designated_Type (T)); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5341eb4..59a1cb5 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -843,6 +843,47 @@ package body Sem_Ch13 is Set_Is_Delayed_Aspect (Aspect); end if; + -- Library unit aspects. These are boolean aspects, but we + -- always evaluate the expression right away if it is present + -- and just ignore the aspect if the expression is False. We + -- never delay expression evaluation in this case. + + when Library_Unit_Aspects => + if Present (Expr) + and then Is_False (Static_Boolean (Expr)) + then + goto Continue; + end if; + + -- Build corresponding pragma node + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => New_List (Ent), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Chars (Id))); + + -- This requires special handling in the case of a package + -- declaration, the pragma needs to be inserted in the list + -- of declarations for the associated package. There is no + -- issue of visibility delay for these aspects. + + if Nkind (N) = N_Package_Declaration then + if Nkind (Parent (N)) /= N_Compilation_Unit then + Error_Msg_N + ("incorrect context for library unit aspect&", Id); + else + Prepend + (Aitem, Visible_Declarations (Specification (N))); + end if; + + goto Continue; + end if; + + -- If not package declaration, no delay is required + + Delay_Required := False; + -- Aspects corresponding to attribute definition clauses when Aspect_Address | @@ -932,11 +973,7 @@ package body Sem_Ch13 is -- required pragma placement. The processing for the pragmas -- takes care of the required delay. - when Aspect_Pre | - Aspect_Precondition | - Aspect_Post | - Aspect_Postcondition => - declare + when Pre_Post_Aspects => declare Pname : Name_Id; begin @@ -1115,21 +1152,45 @@ package body Sem_Ch13 is -- If no delay required, insert the pragma/clause in the tree else - -- For Pre/Post cases, insert immediately after the entity - -- declaration, since that is the required pragma placement. + -- If this is a compilation unit, we will put the pragma in + -- the Pragmas_After list of the N_Compilation_Unit_Aux node. - if A_Id = Aspect_Pre or else - A_Id = Aspect_Post or else - A_Id = Aspect_Precondition or else - A_Id = Aspect_Postcondition - then - Insert_After (N, Aitem); + if Nkind (Parent (Ins_Node)) = N_Compilation_Unit then + declare + Aux : constant Node_Id := + Aux_Decls_Node (Parent (Ins_Node)); + + begin + pragma Assert (Nkind (Aux) = N_Compilation_Unit_Aux); + + if No (Pragmas_After (Aux)) then + Set_Pragmas_After (Aux, Empty_List); + end if; + + -- For Pre_Post put at start of list, otherwise at end + + if A_Id in Pre_Post_Aspects then + Prepend (Aitem, Pragmas_After (Aux)); + else + Append (Aitem, Pragmas_After (Aux)); + end if; + end; - -- For all other cases, insert in sequence + -- Here if not compilation unit case else - Insert_After (Ins_Node, Aitem); - Ins_Node := Aitem; + -- For Pre/Post cases, insert immediately after the entity + -- declaration, since that is the required pragma placement. + + if A_Id in Pre_Post_Aspects then + Insert_After (N, Aitem); + + -- For all other cases, insert in sequence + + else + Insert_After (Ins_Node, Aitem); + Ins_Node := Aitem; + end if; end if; end if; end; @@ -5085,6 +5146,11 @@ package body Sem_Ch13 is when No_Aspect => raise Program_Error; + -- Library unit aspects should be impossible (never delayed) + + when Library_Unit_Aspects => + raise Program_Error; + -- Aspects taking an optional boolean argument. Note that we will -- never be called with an empty expression, because such aspects -- never need to be delayed anyway. diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 324f1a9..82ff0fc 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -760,6 +760,11 @@ package body Sem_Ch7 is -- True when this package declaration is not a nested declaration begin + -- Analye aspect specifications immediately, since we need to recognize + -- things like Pure early enough to diagnose violations during analysis. + + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); + -- Ada 2005 (AI-217): Check if the package has been erroneously named -- in a limited-with clause of its own context. In this case the error -- has been previously notified by Analyze_Context. @@ -768,7 +773,7 @@ package body Sem_Ch7 is -- package Pkg is ... if From_With_Type (Id) then - goto Leave; + return; end if; if Debug_Flag_C then @@ -842,9 +847,6 @@ package body Sem_Ch7 is Write_Location (Sloc (N)); Write_Eol; end if; - - <<Leave>> - Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Package_Declaration; ----------------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 585981a..f66c8f9 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5689,10 +5689,10 @@ package body Sem_Prag is -- Preset arguments Arg_Count := 0; - Arg1 := Empty; - Arg2 := Empty; - Arg3 := Empty; - Arg4 := Empty; + Arg1 := Empty; + Arg2 := Empty; + Arg3 := Empty; + Arg4 := Empty; if Present (Pragma_Argument_Associations (N)) then Arg_Count := List_Length (Pragma_Argument_Associations (N)); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c21003e..47d10b4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11228,6 +11228,38 @@ package body Sem_Util is end Set_Size_Info; -------------------- + -- Static_Boolean -- + -------------------- + + function Static_Boolean (N : Node_Id) return Uint is + begin + Analyze_And_Resolve (N, Standard_Boolean); + + if N = Error + or else Error_Posted (N) + or else Etype (N) = Any_Type + then + return No_Uint; + end if; + + if Is_Static_Expression (N) then + if not Raises_Constraint_Error (N) then + return Expr_Value (N); + else + return No_Uint; + end if; + + elsif Etype (N) = Any_Type then + return No_Uint; + + else + Flag_Non_Static_Expr + ("static boolean expression required here", N); + return No_Uint; + end if; + end Static_Boolean; + + -------------------- -- Static_Integer -- -------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 2b7d2d0..d892a4c 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1280,6 +1280,12 @@ package Sem_Util is function Scope_Is_Transient return Boolean; -- True if the current scope is transient + function Static_Boolean (N : Node_Id) return Uint; + -- This function analyzes the given expression node and then resolves it + -- as Standard.Boolean. If the result is static, then Uint_1 or Uint_0 is + -- returned corresponding to the value, otherwise an error message is + -- output and No_Uint is returned. + function Static_Integer (N : Node_Id) return Uint; -- This function analyzes the given expression node and then resolves it -- as any integer type. If the result is static, then the value of the diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index facc045..98ffd77 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -4773,8 +4773,7 @@ package Sinfo is ------------------------------ -- PACKAGE_DECLARATION ::= - -- PACKAGE_SPECIFICATION - -- [ASPECT_SPECIFICATIONS]; + -- PACKAGE_SPECIFICATION; -- Note: the activation chain entity for a package spec is used for -- all tasks declared in the package spec, or in the package body. @@ -4791,7 +4790,9 @@ package Sinfo is -------------------------------- -- PACKAGE_SPECIFICATION ::= - -- package DEFINING_PROGRAM_UNIT_NAME is + -- package DEFINING_PROGRAM_UNIT_NAME + -- [ASPECT_SPECIFICATIONS] + -- is -- {BASIC_DECLARATIVE_ITEM} -- [private -- {BASIC_DECLARATIVE_ITEM}] @@ -4812,7 +4813,9 @@ package Sinfo is ----------------------- -- PACKAGE_BODY ::= - -- package body DEFINING_PROGRAM_UNIT_NAME is + -- package body DEFINING_PROGRAM_UNIT_NAME + -- [ASPECT_SPECIFICATIONS] + -- is -- DECLARATIVE_PART -- [begin -- HANDLED_SEQUENCE_OF_STATEMENTS] @@ -5023,8 +5026,8 @@ package Sinfo is -- TASK_TYPE_DECLARATION ::= -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] - -- [is [new INTERFACE_LIST with] TASK_DEFINITION] - -- [ASPECT_SPECIFICATIONS]; + -- [ASPECT_SPECIFICATIONS] + -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; -- N_Task_Type_Declaration -- Sloc points to TASK @@ -5041,8 +5044,8 @@ package Sinfo is -- SINGLE_TASK_DECLARATION ::= -- task DEFINING_IDENTIFIER - -- [is [new INTERFACE_LIST with] TASK_DEFINITION] - -- [ASPECT_SPECIFICATIONS]; + -- [ASPECT_SPECIFICATIONS] + -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; -- N_Single_Task_Declaration -- Sloc points to TASK @@ -5086,7 +5089,9 @@ package Sinfo is -------------------- -- TASK_BODY ::= - -- task body task_DEFINING_IDENTIFIER is + -- task body task_DEFINING_IDENTIFIER + -- [ASPECT_SPECIFICATIONS] + -- is -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS @@ -5110,8 +5115,8 @@ package Sinfo is -- PROTECTED_TYPE_DECLARATION ::= -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] - -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION - -- {ASPECT_SPECIFICATIONS]; + -- [ASPECT_SPECIFICATIONS] + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; -- Note: protected type declarations are not permitted in Ada 83 mode @@ -5130,8 +5135,8 @@ package Sinfo is -- SINGLE_PROTECTED_DECLARATION ::= -- protected DEFINING_IDENTIFIER - -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION - -- [ASPECT_SPECIFICATIONS]; + -- [ASPECT_SPECIFICATIONS] + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; -- Note: single protected declarations are not allowed in Ada 83 mode @@ -5179,7 +5184,9 @@ package Sinfo is ------------------------- -- PROTECTED_BODY ::= - -- protected body DEFINING_IDENTIFIER is + -- protected body DEFINING_IDENTIFIER + -- [ASPECT_SPECIFICATIONS]; + -- is -- {PROTECTED_OPERATION_ITEM} -- end [protected_IDENTIFIER]; diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index e984b5b..7c069165 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -183,11 +183,16 @@ package body Sprint is procedure Sprint_And_List (List : List_Id); -- Print the given list with items separated by vertical "and" - procedure Sprint_Aspect_Specifications (Node : Node_Id); + procedure Sprint_Aspect_Specifications + (Node : Node_Id; + Semicolon : Boolean); -- Node is a declaration node that has aspect specifications (Has_Aspects - -- flag set True). It is called after outputting the terminating semicolon - -- for the related node. The effect is to remove the semicolon and print - -- the aspect specifications, followed by a terminating semicolon. + -- flag set True). It outputs the aspect specifications. For the case + -- of Semicolon = True, it is called after outputting the terminating + -- semicolon for the related node. The effect is to remove the semicolon + -- and print the aspect specifications followed by a terminating semicolon. + -- For the case of Semicolon False, no semicolon is removed or output, and + -- all the aspects are printed on a single line. procedure Sprint_Bar_List (List : List_Id); -- Print the given list with items separated by vertical bars @@ -630,16 +635,24 @@ package body Sprint is -- Sprint_Aspect_Specifications -- ---------------------------------- - procedure Sprint_Aspect_Specifications (Node : Node_Id) is + procedure Sprint_Aspect_Specifications + (Node : Node_Id; + Semicolon : Boolean) + is AS : constant List_Id := Aspect_Specifications (Node); A : Node_Id; begin - Write_Erase_Char (';'); - Indent := Indent + 2; - Write_Indent; - Write_Str ("with "); - Indent := Indent + 5; + if Semicolon then + Write_Erase_Char (';'); + Indent := Indent + 2; + Write_Indent; + Write_Str ("with "); + Indent := Indent + 5; + + else + Write_Str (" with "); + end if; A := First (AS); loop @@ -658,11 +671,16 @@ package body Sprint is exit when No (A); Write_Char (','); - Write_Indent; + + if Semicolon then + Write_Indent; + end if; end loop; - Indent := Indent - 7; - Write_Char (';'); + if Semicolon then + Indent := Indent - 7; + Write_Char (';'); + end if; end Sprint_Aspect_Specifications; --------------------- @@ -2411,6 +2429,14 @@ package body Sprint is when N_Package_Specification => Write_Str_With_Col_Check_Sloc ("package "); Sprint_Node (Defining_Unit_Name (Node)); + + if Nkind (Parent (Node)) = N_Package_Declaration + and then Has_Aspects (Parent (Node)) + then + Sprint_Aspect_Specifications + (Parent (Node), Semicolon => False); + end if; + Write_Str (" is"); Sprint_Indented_List (Visible_Declarations (Node)); @@ -3176,8 +3202,11 @@ package body Sprint is end if; end case; - if Has_Aspects (Node) then - Sprint_Aspect_Specifications (Node); + -- Print aspects, except for special case of package declaration, + -- where the aspects are printed inside the package specification. + + if Has_Aspects (Node) and Nkind (Node) /= N_Package_Declaration then + Sprint_Aspect_Specifications (Node, Semicolon => True); end if; if Nkind (Node) in N_Subexpr |