From patchwork Tue Oct 12 09:38:03 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 67514 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 8FA11B6F0D for ; Tue, 12 Oct 2010 20:38:32 +1100 (EST) Received: (qmail 24031 invoked by alias); 12 Oct 2010 09:38:24 -0000 Received: (qmail 23991 invoked by uid 22791); 12 Oct 2010 09:38:16 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD, WEIRD_QUOTING X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 12 Oct 2010 09:38:06 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id F01D2CB028B; Tue, 12 Oct 2010 11:38:03 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id 7sKxbt4uPPwC; Tue, 12 Oct 2010 11:38:03 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id D5320CB025D; Tue, 12 Oct 2010 11:38:03 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id B3617D9BB5; Tue, 12 Oct 2010 11:38:03 +0200 (CEST) Date: Tue, 12 Oct 2010 11:38:03 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Complete implementation of AI05-0183-1 (aspect specifications) Message-ID: <20101012093803.GA6590@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This AI is now fully implemented, the final stage in this patch is to recognize the aspect syntax in all declarations where it is allowed. The following test compiles silently with -gnat12: procedure AllAspects is type R is new Integer with Warnings => Off; function "+" (A, B : R) return R is abstract with Warnings => Off; type R55 is record I : Integer with Warnings => Off; end record; task type Rtt is entry Q with Warnings => Off; end Rtt with Warnings => Off; task body Rtt is begin accept Q; end; X : exception with Warnings => Off; package Rpkg is end with Warnings => Off; I : Integer with Warnings => Off; type Jtag is tagged null record; package P3 is type R is private with Warnings => Off; type J is null record; type JJ is new Jtag with private with Warnings => Off; private type R is new Integer; type JJ is new Jtag with record X : Integer; end record; end P3; task XXX is end with Warnings => Off; task body XXX is begin null; end; subtype Q is Integer range 1 .. 2 with Warnings => Off; procedure ppp with Warnings => Off; procedure ppp is begin null; end; generic package GP is end with Warnings => Off; package GGPP is new GP with Warnings => Off; generic procedure PG with Warnings => Off; procedure PG is begin null; end; procedure NPG is new PG with Warnings => Off; generic function FG return Integer with Warnings => Off; function FG return Integer is begin return 1; end; function FGG is new FG with Warnings => Off; generic A : Integer with Warnings => Off; type R is private with Warnings => Off; with package PPP is new GP with Warnings => Off; with procedure XXX (A : Jtag) is abstract with Warnings => Off; with procedure YYY with Warnings => Off; package PPPPP is end; protected type P is end with Warnings => Off; protected body P is end; protected PSINGLE is end with Warnings => Off; protected body PSINGLE is end; begin null; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-12 Robert Dewar * aspects.ads, aspects.adb (Move_Aspects): New procedure. * atree.ads, atree.adb: (New_Copy): Does not copy aspect specifications * sinfo.ads, par-ch3.adb, par-ch6.adb, par-ch7.adb, par-ch9.adb, par-endh.adb, par-ch13.adb, par-ch12.adb: Modify grammar to include aspect specifications. Recognize aspect specifications for all cases * par.adb: Recognize aspect specifications for all cases * sem_ch12.ads, sem_ch12.adb (Copy_Generic_Node): Copies aspect specifications. * sem_ch3.adb (Analyze_Subtype_Declaration): Improve patch to freeze generic actual types (was missing some guards before). * sem_ch9.adb (Analyze_Single_Protected_Declaration): Copy aspects to generated object (Analyze_Single_Task_Declaration): Copy aspects to generated object Index: par-ch9.adb =================================================================== --- par-ch9.adb (revision 165316) +++ par-ch9.adb (working copy) @@ -40,23 +40,33 @@ 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_Definition return Node_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. + ----------------------------- -- 9.1 Task (also 10.1.3) -- ----------------------------- -- TASK_TYPE_DECLARATION ::= -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] - -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; + -- [is [new INTERFACE_LIST with] TASK_DEFINITION] + -- [ASPECT_SPECIFICATIONS]; -- SINGLE_TASK_DECLARATION ::= -- task DEFINING_IDENTIFIER - -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; + -- [is [new INTERFACE_LIST with] TASK_DEFINITION] + -- [ASPECT_SPECIFICATIONS]; -- TASK_BODY ::= -- task body DEFINING_IDENTIFIER is @@ -143,10 +153,17 @@ package body Ch9 is end if; end if; + -- If we have aspect definitions present here, then we do not have + -- a task definition present. + + if Aspect_Specifications_Present then + P_Aspect_Specifications (Task_Node); + -- Parse optional task definition. Note that P_Task_Definition scans - -- out the semicolon as well as the task definition itself. + -- out the semicolon and possible aspect specifications as well as + -- the task definition itself. - if Token = Tok_Semicolon then + elsif Token = Tok_Semicolon then -- A little check, if the next token after semicolon is -- Entry, then surely the semicolon should really be IS @@ -156,10 +173,13 @@ package body Ch9 is if Token = Tok_Entry then Error_Msg_SP -- CODEFIX ("|"";"" should be IS"); - Set_Task_Definition (Task_Node, P_Task_Definition); + Set_Task_Definition (Task_Node, P_Task_Definition (Task_Node)); else Pop_Scope_Stack; -- Remove unused entry end if; + + -- Here we have a task definition + else TF_Is; -- must have IS if no semicolon @@ -194,7 +214,7 @@ package body Ch9 is end if; end if; - Set_Task_Definition (Task_Node, P_Task_Definition); + Set_Task_Definition (Task_Node, P_Task_Definition (Task_Node)); end if; return Task_Node; @@ -233,7 +253,7 @@ package body Ch9 is -- Error recovery: cannot raise Error_Resync - function P_Task_Definition return Node_Id is + function P_Task_Definition (Decl : Node_Id) return Node_Id is Def_Node : Node_Id; begin @@ -253,7 +273,7 @@ package body Ch9 is end loop; end if; - End_Statements (Def_Node); + End_Statements (Def_Node, Decl); return Def_Node; end P_Task_Definition; @@ -347,11 +367,13 @@ package body Ch9 is -- PROTECTED_TYPE_DECLARATION ::= -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] - -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION + -- [ASPECT_SPECIFICATIONS]; -- SINGLE_PROTECTED_DECLARATION ::= -- protected DEFINING_IDENTIFIER -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; + -- [ASPECT_SPECIFICATIONS]; -- PROTECTED_BODY ::= -- protected body DEFINING_IDENTIFIER is @@ -464,8 +486,8 @@ package body Ch9 is End_Label => Empty)); SIS_Entry_Active := False; - End_Statements (Protected_Definition (Protected_Node)); - Scan; -- past semicolon + End_Statements + (Protected_Definition (Protected_Node), Protected_Node); return Protected_Node; end if; @@ -503,7 +525,8 @@ package body Ch9 is Scan; -- past WITH end if; - Set_Protected_Definition (Protected_Node, P_Protected_Definition); + Set_Protected_Definition + (Protected_Node, P_Protected_Definition (Protected_Node)); return Protected_Node; end if; end P_Protected; @@ -538,7 +561,7 @@ package body Ch9 is -- Error recovery: cannot raise Error_Resync - function P_Protected_Definition return Node_Id is + function P_Protected_Definition (Decl : Node_Id) return Node_Id is Def_Node : Node_Id; Item_Node : Node_Id; @@ -584,7 +607,7 @@ package body Ch9 is end loop Declaration_Loop; end loop Private_Loop; - End_Statements (Def_Node); + End_Statements (Def_Node, Decl); return Def_Node; end P_Protected_Definition; Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 165316) +++ sem_ch3.adb (working copy) @@ -4150,10 +4150,16 @@ package body Sem_Ch3 is end if; end if; - -- Make sure that generic actual types are properly frozen + -- Make sure that generic actual types are properly frozen The subtype + -- is marked as a generic actual type when the enclosing instance is + -- analyzed, so here we identify the subtype from the tree structure. if Expander_Active and then Is_Generic_Actual_Type (Id) + and then In_Instance + and then not Comes_From_Source (N) + and then Nkind (Subtype_Indication (N)) /= N_Subtype_Indication + and then Is_Frozen (T) then Insert_Actions (N, Freeze_Entity (Id, N)); end if; Index: sinfo.ads =================================================================== --- sinfo.ads (revision 165316) +++ sinfo.ads (working copy) @@ -2120,7 +2120,9 @@ package Sinfo is -- FULL_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] - -- is TYPE_DEFINITION; + -- is TYPE_DEFINITION + -- [ASPECT_SPECIFICATIONS]; + -- | TASK_TYPE_DECLARATION -- | PROTECTED_TYPE_DECLARATION @@ -2227,11 +2229,14 @@ package Sinfo is -- OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] - -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]; + -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] - -- ACCESS_DEFINITION [:= EXPRESSION]; + -- ACCESS_DEFINITION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] - -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; + -- ARRAY_TYPE_DEFINITION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- | SINGLE_TASK_DECLARATION -- | SINGLE_PROTECTED_DECLARATION @@ -2841,7 +2846,8 @@ package Sinfo is -- COMPONENT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION - -- [:= DEFAULT_EXPRESSION]; + -- [:= DEFAULT_EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- Note: although the syntax does not permit a component definition to -- be an anonymous array (and the parser will diagnose such an attempt @@ -4209,7 +4215,9 @@ package Sinfo is -- 6.1 Subprogram Declaration -- --------------------------------- - -- SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION; + -- SUBPROGRAM_DECLARATION ::= + -- SUBPROGRAM_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; -- N_Subprogram_Declaration -- Sloc points to FUNCTION or PROCEDURE @@ -4223,7 +4231,8 @@ package Sinfo is ------------------------------------------ -- ABSTRACT_SUBPROGRAM_DECLARATION ::= - -- SUBPROGRAM_SPECIFICATION is abstract; + -- SUBPROGRAM_SPECIFICATION is abstract + -- [ASPECT_SPECIFICATIONS]; -- N_Abstract_Subprogram_Declaration -- Sloc points to ABSTRACT @@ -4640,7 +4649,9 @@ package Sinfo is -- 7.1 Package Declaration -- ------------------------------ - -- PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION; + -- PACKAGE_DECLARATION ::= + -- PACKAGE_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; -- Note: the activation chain entity for a package spec is used for -- all tasks declared in the package spec, or in the package body. @@ -4889,7 +4900,8 @@ package Sinfo is -- TASK_TYPE_DECLARATION ::= -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] - -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; + -- [is [new INTERFACE_LIST with] TASK_DEFINITION] + -- [ASPECT_SPECIFICATIONS]; -- N_Task_Type_Declaration -- Sloc points to TASK @@ -4906,7 +4918,8 @@ package Sinfo is -- SINGLE_TASK_DECLARATION ::= -- task DEFINING_IDENTIFIER - -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; + -- [is [new INTERFACE_LIST with] TASK_DEFINITION] + -- [ASPECT_SPECIFICATIONS]; -- N_Single_Task_Declaration -- Sloc points to TASK @@ -4973,7 +4986,8 @@ package Sinfo is -- PROTECTED_TYPE_DECLARATION ::= -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] - -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION + -- {ASPECT_SPECIFICATIONS]; -- Note: protected type declarations are not permitted in Ada 83 mode @@ -4992,7 +5006,8 @@ package Sinfo is -- SINGLE_PROTECTED_DECLARATION ::= -- protected DEFINING_IDENTIFIER - -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION + -- [ASPECT_SPECIFICATIONS]; -- Note: single protected declarations are not allowed in Ada 83 mode @@ -5733,7 +5748,8 @@ package Sinfo is -- 11.1 Exception Declaration -- --------------------------------- - -- EXCEPTION_DECLARATION ::= DEFINING_IDENTIFIER_LIST : exception; + -- EXCEPTION_DECLARATION ::= DEFINING_IDENTIFIER_LIST : exception + -- [ASPECT_SPECIFICATIONS]; -- For consistency with object declarations etc., the parser converts -- the case of multiple identifiers being declared to a series of @@ -5902,7 +5918,8 @@ package Sinfo is --------------------------------------- -- GENERIC_PACKAGE_DECLARATION ::= - -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION; + -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; -- Note: when we do generics right, the Activation_Chain_Entity entry -- for this node can be removed (since the expander won't see generic @@ -5941,13 +5958,16 @@ package Sinfo is -- GENERIC_INSTANTIATION ::= -- package DEFINING_PROGRAM_UNIT_NAME is - -- new generic_package_NAME [GENERIC_ACTUAL_PART]; + -- new generic_package_NAME [GENERIC_ACTUAL_PART] + -- [ASPECT_SPECIFICATIONS]; -- | [[not] overriding] -- procedure DEFINING_PROGRAM_UNIT_NAME is - -- new generic_procedure_NAME [GENERIC_ACTUAL_PART]; + -- new generic_procedure_NAME [GENERIC_ACTUAL_PART] + -- [ASPECT_SPECIFICATIONS]; -- | [[not] overriding] -- function DEFINING_DESIGNATOR is - -- new generic_function_NAME [GENERIC_ACTUAL_PART]; + -- new generic_function_NAME [GENERIC_ACTUAL_PART] + -- [ASPECT_SPECIFICATIONS]; -- N_Package_Instantiation -- Sloc points to PACKAGE @@ -6031,9 +6051,11 @@ package Sinfo is -- FORMAL_OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : - -- MODE [NULL_EXCLUSION] SUBTYPE_MARK [:= DEFAULT_EXPRESSION]; + -- MODE [NULL_EXCLUSION] SUBTYPE_MARK [:= DEFAULT_EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER_LIST : - -- MODE ACCESS_DEFINITION [:= DEFAULT_EXPRESSION]; + -- MODE ACCESS_DEFINITION [:= DEFAULT_EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- Although the syntax allows multiple identifiers in the list, the -- semantics is as though successive declarations were given with @@ -6061,7 +6083,8 @@ package Sinfo is -- FORMAL_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] - -- is FORMAL_TYPE_DEFINITION; + -- is FORMAL_TYPE_DEFINITION + -- [ASPECT_SPECIFICATIONS]; -- N_Formal_Type_Declaration -- Sloc points to TYPE @@ -6208,7 +6231,8 @@ package Sinfo is -------------------------------------------------- -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION ::= - -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT]; + -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT] + -- [ASPECT_SPECIFICATIONS]; -- N_Formal_Concrete_Subprogram_Declaration -- Sloc points to WITH @@ -6224,7 +6248,8 @@ package Sinfo is -------------------------------------------------- -- FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION ::= - -- with SUBPROGRAM_SPECIFICATION is abstract [SUBPROGRAM_DEFAULT]; + -- with SUBPROGRAM_SPECIFICATION is abstract [SUBPROGRAM_DEFAULT] + -- [ASPECT_SPECIFICATIONS]; -- N_Formal_Abstract_Subprogram_Declaration -- Sloc points to WITH @@ -6258,7 +6283,8 @@ package Sinfo is -- FORMAL_PACKAGE_DECLARATION ::= -- with package DEFINING_IDENTIFIER - -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART; + -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART + -- [ASPECT_SPECIFICATIONS]; -- Note: formal package declarations not allowed in Ada 83 mode @@ -6384,7 +6410,7 @@ package Sinfo is -- entry in the list of aspects. So we use this grammar instead: -- ASPECT_SPECIFICATIONS ::= - -- with ASPECT_SPECIFICATION {, ASPECT_SPECIFICATION}; + -- with ASPECT_SPECIFICATION {, ASPECT_SPECIFICATION} -- ASPECT_SPECIFICATION => -- ASPECT_MARK [=> ASPECT_DEFINITION] Index: par-ch13.adb =================================================================== --- par-ch13.adb (revision 165316) +++ par-ch13.adb (working copy) @@ -378,17 +378,19 @@ package body Ch13 is Aspect : Node_Id; A_Id : Aspect_Id; OK : Boolean; + Ptr : Source_Ptr; begin -- Check if aspect specification present if not Aspect_Specifications_Present then - T_Semicolon; + TF_Semicolon; return; end if; -- Aspect Specification is present + Ptr := Token_Ptr; Scan; -- past WITH -- Here we have an aspect specification to scan, note that we don;t @@ -511,8 +513,12 @@ package body Ch13 is -- If aspects scanned, store them if Is_Non_Empty_List (Aspects) then - Set_Parent (Aspects, Decl); - Set_Aspect_Specifications (Decl, Aspects); + if Decl = Error then + Error_Msg ("aspect specifications not allowed here", Ptr); + else + Set_Parent (Aspects, Decl); + Set_Aspect_Specifications (Decl, Aspects); + end if; end if; end P_Aspect_Specifications; Index: sem_ch9.adb =================================================================== --- sem_ch9.adb (revision 165316) +++ sem_ch9.adb (working copy) @@ -1691,6 +1691,7 @@ package body Sem_Ch9 is Defining_Identifier => O_Name, Object_Definition => Make_Identifier (Loc, Chars (T))); + Move_Aspects (N, O_Decl); Rewrite (N, T_Decl); Insert_After (N, O_Decl); Mark_Rewrite_Insertion (O_Decl); @@ -1749,13 +1750,15 @@ package body Sem_Ch9 is -- entity is the new object declaration. The single_task_declaration -- is not used further in semantics or code generation, but is scanned -- when generating debug information, and therefore needs the updated - -- Sloc information for the entity (see Sprint). + -- Sloc information for the entity (see Sprint). Aspect specifications + -- are moved from the single task node to the object declaration node. O_Decl := Make_Object_Declaration (Loc, Defining_Identifier => O_Name, Object_Definition => Make_Identifier (Loc, Chars (T))); + Move_Aspects (N, O_Decl); Rewrite (N, T_Decl); Insert_After (N, O_Decl); Mark_Rewrite_Insertion (O_Decl); Index: par-endh.adb =================================================================== --- par-endh.adb (revision 165316) +++ par-endh.adb (working copy) @@ -166,7 +166,7 @@ package body Endh is -- Check_End -- --------------- - function Check_End return Boolean is + function Check_End (Decl : Node_Id := Empty) return Boolean is Name_On_Separate_Line : Boolean; -- Set True if the name on an END line is on a separate source line -- from the END. This is highly suspicious, but is allowed. The point @@ -387,6 +387,15 @@ package body Endh is end if; end if; + -- Scan aspect specifications if permitted here + + if Aspect_Specifications_Present then + if No (Decl) then + P_Aspect_Specifications (Error); + else + P_Aspect_Specifications (Decl); + end if; + -- Except in case of END RECORD, semicolon must follow. For END -- RECORD, a semicolon does follow, but it is part of a higher level -- construct. In any case, a missing semicolon is not serious enough @@ -394,7 +403,7 @@ package body Endh is -- are dealing with (i.e. to be suspicious that it is not in fact -- the END statement we are looking for!) - if End_Type /= E_Record then + elsif End_Type /= E_Record then if Token = Tok_Semicolon then T_Semicolon; @@ -644,13 +653,15 @@ package body Endh is -- Error recovery: cannot raise Error_Resync; - procedure End_Statements (Parent : Node_Id := Empty) is + procedure End_Statements + (Parent : Node_Id := Empty; + 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. loop - if Check_End then + if Check_End (Decl) then if Present (Parent) then Set_End_Label (Parent, End_Labl); end if; Index: sem_ch12.adb =================================================================== --- sem_ch12.adb (revision 165316) +++ sem_ch12.adb (working copy) @@ -5768,6 +5768,14 @@ package body Sem_Ch12 is New_N := New_Copy (N); + -- Copy aspects if present + + if Has_Aspects (N) then + Set_Has_Aspects (New_N, False); + Set_Aspect_Specifications + (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id)); + end if; + if Instantiating then Adjust_Instantiation_Sloc (New_N, S_Adjustment); end if; Index: sem_ch12.ads =================================================================== --- sem_ch12.ads (revision 165316) +++ sem_ch12.ads (working copy) @@ -64,7 +64,9 @@ package Sem_Ch12 is -- repeatedly: once to produce a copy on which semantic analysis of -- the generic is performed, and once for each instantiation. The tree -- being copied is not semantically analyzed, except that references to - -- global entities are marked on terminal nodes. + -- global entities are marked on terminal nodes. Note that this function + -- copies any aspect specifications from the input node N to the returned + -- node, as well as the setting of the Has_Aspects flag. function Get_Instance_Of (A : Entity_Id) return Entity_Id; -- Retrieve actual associated with given generic parameter. Index: par.adb =================================================================== --- par.adb (revision 165316) +++ par.adb (working copy) @@ -754,10 +754,14 @@ function Par (Configuration_Pragmas : Bo ------------- package Ch7 is - function P_Package (Pf_Flags : Pf_Rec) return Node_Id; + function P_Package + (Pf_Flags : Pf_Rec; + Decl : Node_Id := Empty) 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. + -- 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. end Ch7; ------------- @@ -854,7 +858,9 @@ function Par (Configuration_Pragmas : Bo -- 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. + -- 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. function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id; -- Function to parse a code statement. The caller has scanned out @@ -880,7 +886,7 @@ function Par (Configuration_Pragmas : Bo -- Routines for handling end lines, including scope recovery package Endh is - function Check_End return Boolean; + function Check_End (Decl : Node_Id := Empty) return Boolean; -- Called when an end sequence is required. In the absence of an error -- situation, Token contains Tok_End on entry, but in a missing end -- case, this may not be the case. Pop_End_Context is used to determine @@ -891,6 +897,10 @@ function Par (Configuration_Pragmas : Bo -- Skip_And_Reject). Note that the END sequence includes a semicolon, -- except in the case of END RECORD, where a semicolon follows the END -- RECORD, but is not part of the record type definition itself. + -- + -- If Decl is non-empty, then aspect specifications are permitted + -- following the end, and Decl is the declaration node with which + -- these aspect specifications are to be associated. procedure End_Skip; -- Skip past an end sequence. On entry Token contains Tok_End, and we @@ -900,13 +910,19 @@ function Par (Configuration_Pragmas : Bo -- position after the end sequence. We do not issue any additional -- error messages while carrying this out. - procedure End_Statements (Parent : Node_Id := Empty); + procedure End_Statements + (Parent : Node_Id := Empty; + Decl : Node_Id := Empty); -- Called when an end is required or expected to terminate a sequence -- of statements. The caller has already made an appropriate entry in -- the Scope.Table to describe the expected form of the end. This can -- only be used in cases where the only appropriate terminator is end. -- If Parent is non-empty, then if a correct END line is encountered, -- the End_Label field of Parent is set appropriately. + -- + -- If Decl is non-null, then it is a declaration node, and aspect + -- specifications are permitted after the end statement. These aspect + -- specifications, if present, are stored in this declaration node. end Endh; -------------- Index: par-ch6.adb =================================================================== --- par-ch6.adb (revision 165316) +++ par-ch6.adb (working copy) @@ -84,10 +84,13 @@ package body Ch6 is -- subprogram renaming declaration or subprogram generic instantiation. -- It also handles the new Ada 2012 parameterized expression form - -- SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION; + -- SUBPROGRAM_DECLARATION ::= + -- SUBPROGRAM_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; -- ABSTRACT_SUBPROGRAM_DECLARATION ::= - -- SUBPROGRAM_SPECIFICATION is abstract; + -- SUBPROGRAM_SPECIFICATION is abstract + -- [ASPECT_SPECIFICATIONS]; -- SUBPROGRAM_SPECIFICATION ::= -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE @@ -445,13 +448,19 @@ package body Ch6 is end if; end if; + -- Subprogram declaration ended by aspect specifications + + if Aspect_Specifications_Present then + goto Subprogram_Declaration; + -- Deal with case of semicolon ending a subprogram declaration - if Token = Tok_Semicolon then + elsif Token = Tok_Semicolon then if not Pf_Flags.Decl then T_Is; end if; + Save_Scan_State (Scan_State); Scan; -- past semicolon -- If semicolon is immediately followed by IS, then ignore the @@ -476,6 +485,7 @@ package body Ch6 is goto Subprogram_Body; else + Restore_Scan_State (Scan_State); goto Subprogram_Declaration; end if; @@ -544,7 +554,6 @@ package body Ch6 is Set_Null_Present (Specification_Node); end if; - TF_Semicolon; goto Subprogram_Declaration; -- Check for IS NEW with Formal_Part present and handle nicely @@ -572,6 +581,11 @@ package body Ch6 is goto Subprogram_Body; end if; + -- Aspect specifications present + + elsif Aspect_Specifications_Present then + goto Subprogram_Declaration; + -- Here we have a missing IS or missing semicolon, we always guess -- a missing semicolon, since we are pretty good at fixing up a -- semicolon which should really be an IS @@ -770,6 +784,7 @@ package body Ch6 is Decl_Node := New_Node (N_Subprogram_Declaration, Sloc (Specification_Node)); Set_Specification (Decl_Node, Specification_Node); + P_Aspect_Specifications (Decl_Node); -- If this is a context in which a subprogram body is permitted, -- set active SIS entry in case (see section titled "Handling Index: aspects.adb =================================================================== --- aspects.adb (revision 165316) +++ aspects.adb (working copy) @@ -160,6 +160,20 @@ package body Aspects is end if; end Aspect_Specifications; + ------------------ + -- Move_Aspects -- + ------------------ + + procedure Move_Aspects (From : Node_Id; To : Node_Id) is + pragma Assert (not Has_Aspects (To)); + begin + if Has_Aspects (From) then + Set_Aspect_Specifications (To, Aspect_Specifications (From)); + Aspect_Specifications_Hash_Table.Remove (From); + Set_Has_Aspects (From, False); + end if; + end Move_Aspects; + ----------------------------------- -- Permits_Aspect_Specifications -- ----------------------------------- Index: aspects.ads =================================================================== --- aspects.ads (revision 165316) +++ aspects.ads (working copy) @@ -195,6 +195,12 @@ package Aspects is -- node that has its Has_Aspects flag set True on entry, or with L being an -- empty list or No_List. + procedure Move_Aspects (From : Node_Id; To : Node_Id); + -- Moves aspects from 'From' node to 'To' node. Has_Aspects (To) must be + -- False on entry. If Has_Aspects (From) is False, the call has no effect. + -- Otherwise the aspects are moved and on return Has_Aspects (To) is True, + -- and Has_Aspects (From) is False. + procedure Tree_Write; -- Writes contents of Aspect_Specifications hash table to the tree file Index: par-ch12.adb =================================================================== --- par-ch12.adb (revision 165316) +++ par-ch12.adb (working copy) @@ -61,10 +61,12 @@ package body Ch12 is -- GENERIC_SUBPROGRAM_DECLARATION | GENERIC_PACKAGE_DECLARATION -- GENERIC_SUBPROGRAM_DECLARATION ::= - -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION; + -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; -- GENERIC_PACKAGE_DECLARATION ::= - -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION; + -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; -- GENERIC_FORMAL_PART ::= -- generic {GENERIC_FORMAL_PARAMETER_DECLARATION | USE_CLAUSE} @@ -194,14 +196,14 @@ package body Ch12 is exit Decl_Loop; end if; end if; - end loop Decl_Loop; -- Generic formal part is scanned, scan out subprogram or package spec if Token = Tok_Package then Gen_Decl := New_Node (N_Generic_Package_Declaration, Gen_Sloc); - Set_Specification (Gen_Decl, P_Package (Pf_Spcn)); + Set_Specification (Gen_Decl, P_Package (Pf_Spcn, Gen_Decl)); + else Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc); @@ -213,7 +215,8 @@ package body Ch12 is then Error_Msg_SP ("child unit allowed only at library level"); end if; - TF_Semicolon; + + P_Aspect_Specifications (Gen_Decl); end if; Set_Generic_Formal_Declarations (Gen_Decl, Decls); @@ -275,8 +278,9 @@ package body Ch12 is begin -- Figure out if a generic actual part operation is present. Clearly -- there is no generic actual part if the current token is semicolon + -- or if we have apsect specifications present. - if Token = Tok_Semicolon then + if Token = Tok_Semicolon or else Aspect_Specifications_Present then return No_List; -- If we don't have a left paren, then we have an error, and the job @@ -402,9 +406,11 @@ package body Ch12 is -- FORMAL_OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : - -- MODE [NULL_EXCLUSION] SUBTYPE_MARK [:= DEFAULT_EXPRESSION]; + -- MODE [NULL_EXCLUSION] SUBTYPE_MARK [:= DEFAULT_EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER_LIST : -- MODE ACCESS_DEFINITION [:= DEFAULT_EXPRESSION]; + -- [ASPECT_SPECIFICATIONS]; -- The caller has checked that the initial token is an identifier @@ -425,7 +431,6 @@ package body Ch12 is begin Idents (1) := P_Defining_Identifier (C_Comma_Colon); Num_Idents := 1; - while Comma_Present loop Num_Idents := Num_Idents + 1; Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); @@ -479,6 +484,7 @@ package body Ch12 is No_Constraint; Set_Default_Expression (Decl_Node, Init_Expr_Opt); + P_Aspect_Specifications (Decl_Node); if Ident > 1 then Set_Prev_Ids (Decl_Node, True); @@ -494,8 +500,6 @@ package body Ch12 is Ident := Ident + 1; Restore_Scan_State (Scan_State); end loop Ident_Loop; - - TF_Semicolon; end P_Formal_Object_Declarations; ----------------------------------- @@ -504,7 +508,8 @@ package body Ch12 is -- FORMAL_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] - -- is FORMAL_TYPE_DEFINITION; + -- is FORMAL_TYPE_DEFINITION + -- [ASPECT_SPECIFICATIONS]; -- The caller has checked that the initial token is TYPE @@ -532,15 +537,20 @@ package body Ch12 is if Def_Node /= Error then Set_Formal_Type_Definition (Decl_Node, Def_Node); - TF_Semicolon; + P_Aspect_Specifications (Decl_Node); else Decl_Node := Error; + -- If we have aspect specifications, skip them + + if Aspect_Specifications_Present then + P_Aspect_Specifications (Error); + -- If we have semicolon, skip it to avoid cascaded errors - if Token = Tok_Semicolon then - Scan; + elsif Token = Tok_Semicolon then + Scan; -- past semicolon end if; end if; @@ -1078,10 +1088,12 @@ package body Ch12 is -- | FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION ::= - -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT]; + -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT] + -- [ASPECT_SPECIFICATIONS]; -- FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION ::= - -- with SUBPROGRAM_SPECIFICATION is abstract [SUBPROGRAM_DEFAULT]; + -- with SUBPROGRAM_SPECIFICATION is abstract [SUBPROGRAM_DEFAULT] + -- [ASPECT_SPECIFICATIONS]; -- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <> @@ -1122,12 +1134,14 @@ package body Ch12 is Set_Specification (Def_Node, Spec_Node); if Token = Tok_Semicolon then - Scan; -- past ";" + null; + + elsif Aspect_Specifications_Present then + null; elsif Token = Tok_Box then Set_Box_Present (Def_Node, True); Scan; -- past <> - T_Semicolon; elsif Token = Tok_Null then if Ada_Version < Ada_2005 then @@ -1143,20 +1157,18 @@ package body Ch12 is end if; Scan; -- past NULL - T_Semicolon; else Set_Default_Name (Def_Node, P_Name); - T_Semicolon; end if; else Def_Node := New_Node (N_Formal_Concrete_Subprogram_Declaration, Prev_Sloc); Set_Specification (Def_Node, Spec_Node); - T_Semicolon; end if; + P_Aspect_Specifications (Def_Node); return Def_Node; end P_Formal_Subprogram_Declaration; @@ -1178,7 +1190,8 @@ package body Ch12 is -- FORMAL_PACKAGE_DECLARATION ::= -- with package DEFINING_IDENTIFIER - -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART; + -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART + -- [ASPECT_SPECIFICATIONS]; -- FORMAL_PACKAGE_ACTUAL_PART ::= -- ([OTHERS =>] <>) | @@ -1222,7 +1235,7 @@ package body Ch12 is end if; end if; - T_Semicolon; + P_Aspect_Specifications (Def_Node); return Def_Node; end P_Formal_Package_Declaration; Index: atree.adb =================================================================== --- atree.adb (revision 165316) +++ atree.adb (working copy) @@ -1191,7 +1191,6 @@ package body Atree is begin if Source > Empty_Or_Error then - New_Id := Allocate_Initialize_Node (Source, Has_Extension (Source)); Nodes.Table (New_Id).Link := Empty_List_Or_Node; @@ -1202,6 +1201,11 @@ package body Atree is Nodes.Table (New_Id).Rewrite_Ins := False; pragma Debug (New_Node_Debugging_Output (New_Id)); + + -- Always clear Has_Aspects, the caller must take care of copying + -- aspects if this is required for the particular situation. + + Set_Has_Aspects (New_Id, False); end if; return New_Id; @@ -1659,6 +1663,7 @@ package body Atree is -- of aspect specifications if aspect specifications are present. if Has_Aspects (Sav_Node) then + Set_Has_Aspects (Sav_Node, False); Set_Aspect_Specifications (Sav_Node, Aspect_Specifications (Old_Node)); end if; Index: atree.ads =================================================================== --- atree.ads (revision 165316) +++ atree.ads (working copy) @@ -398,7 +398,10 @@ package Atree is -- The parent pointer of the destination and its list link, if any, are -- not affected by the copy. Note that parent pointers of descendents -- are not adjusted, so the descendents of the destination node after - -- the Copy_Node is completed have dubious parent pointers. + -- the Copy_Node is completed have dubious parent pointers. Note that + -- this routine does NOT copy aspect specifications, the Has_Aspects + -- flag in the returned node will always be False. The caller must deal + -- with copying aspect specifications where this is required. function New_Copy (Source : Node_Id) return Node_Id; -- This function allocates a completely new node, and then initializes Index: par-ch3.adb =================================================================== --- par-ch3.adb (revision 165316) +++ par-ch3.adb (working copy) @@ -276,7 +276,8 @@ package body Ch3 is -- | PRIVATE_EXTENSION_DECLARATION -- FULL_TYPE_DECLARATION ::= - -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION; + -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION + -- [ASPECT_SPECIFICATIONS]; -- | CONCURRENT_TYPE_DECLARATION -- INCOMPLETE_TYPE_DECLARATION ::= @@ -1260,11 +1261,14 @@ package body Ch3 is -- OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] - -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]; + -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] - -- ACCESS_DEFINITION [:= EXPRESSION]; + -- ACCESS_DEFINITION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] - -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; + -- ARRAY_TYPE_DEFINITION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- NUMBER_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION; @@ -1279,7 +1283,8 @@ package body Ch3 is -- DEFINING_IDENTIFIER : exception renames exception_NAME; -- EXCEPTION_DECLARATION ::= - -- DEFINING_IDENTIFIER_LIST : exception; + -- DEFINING_IDENTIFIER_LIST : exception + -- [ASPECT_SPECIFICATIONS]; -- Note that the ALIASED indication in an object declaration is -- marked by a flag in the parent node. @@ -3322,7 +3327,8 @@ package body Ch3 is -- COMPONENT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION - -- [:= DEFAULT_EXPRESSION]; + -- [:= DEFAULT_EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- COMPONENT_DEFINITION ::= -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION Index: par-ch7.adb =================================================================== --- par-ch7.adb (revision 165316) +++ par-ch7.adb (working copy) @@ -37,7 +37,9 @@ package body Ch7 is -- This routine scans out a package declaration, package body, or a -- renaming declaration or generic instantiation starting with PACKAGE - -- PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION; + -- PACKAGE_DECLARATION ::= + -- PACKAGE_SPECIFICATION + -- [ASPECT_SPECIFICATIONS]; -- PACKAGE_SPECIFICATION ::= -- package DEFINING_PROGRAM_UNIT_NAME is @@ -59,6 +61,11 @@ package body Ch7 is -- PACKAGE_BODY_STUB ::= -- package body DEFINING_IDENTIFIER is separate; + -- PACKAGE_INSTANTIATION ::= + -- package DEFINING_PROGRAM_UNIT_NAME is + -- new generic_package_NAME [GENERIC_ACTUAL_PART] + -- [ASPECT_SPECIFICATIONS]; + -- The value in Pf_Flags indicates which of these possible declarations -- is acceptable to the caller: @@ -85,7 +92,10 @@ package body Ch7 is -- Error recovery: cannot raise Error_Resync - function P_Package (Pf_Flags : Pf_Rec) return Node_Id is + function P_Package + (Pf_Flags : Pf_Rec; + Decl : Node_Id := Empty) return Node_Id + is Package_Node : Node_Id; Specification_Node : Node_Id; Name_Node : Node_Id; @@ -185,7 +195,7 @@ package body Ch7 is Set_Name (Package_Node, P_Qualified_Simple_Name); Set_Generic_Associations (Package_Node, P_Generic_Actual_Part_Opt); - TF_Semicolon; + P_Aspect_Specifications (Package_Node); Pop_Scope_Stack; -- Case of package declaration or package specification @@ -239,7 +249,11 @@ package body Ch7 is Discard_Junk_List (P_Sequence_Of_Statements (SS_None)); end if; - End_Statements (Specification_Node); + if Nkind (Package_Node) = N_Package_Declaration then + End_Statements (Specification_Node, Package_Node); + else + End_Statements (Specification_Node, Decl); + end if; end if; return Package_Node;