+2010-10-12 Robert Dewar <dewar@adacore.com>
+
+ * 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
+
+2010-10-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ * usage.adb (usage): Adjust line for -gnatn switch.
+
+2010-10-12 Robert Dewar <dewar@adacore.com>
+
+ * sem_attr.adb (Eval_Attribute): Only leave change active for aspect
+ spec case.
+
+2010-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Declaration): If this is a
+ declaration of a null procedure resolve the types of the profile of the
+ generated null body now.
+
2010-10-11 Robert Dewar <dewar@adacore.com>
* debug.adb: Remove d.A flag to delay address clause (not needed any
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 --
-----------------------------------
-- 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
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;
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;
-- 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;
-- 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
-- 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}
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);
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);
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
-- 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
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);
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);
Ident := Ident + 1;
Restore_Scan_State (Scan_State);
end loop Ident_Loop;
-
- TF_Semicolon;
end P_Formal_Object_Declarations;
-----------------------------------
-- 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
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;
-- | 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 | <>
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
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;
-- 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 =>] <>) |
end if;
end if;
- T_Semicolon;
+ P_Aspect_Specifications (Def_Node);
return Def_Node;
end P_Formal_Package_Declaration;
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
-- 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;
-- | 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 ::=
-- 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;
-- 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.
-- COMPONENT_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
- -- [:= DEFAULT_EXPRESSION];
+ -- [:= DEFAULT_EXPRESSION]
+ -- [ASPECT_SPECIFICATIONS];
-- COMPONENT_DEFINITION ::=
-- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- 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
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
goto Subprogram_Body;
else
+ Restore_Scan_State (Scan_State);
goto Subprogram_Declaration;
end if;
Set_Null_Present (Specification_Node);
end if;
- TF_Semicolon;
goto Subprogram_Declaration;
-- Check for IS NEW with Formal_Part present and handle nicely
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
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
-- 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
-- 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:
-- 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;
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
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;
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
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
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
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;
-- 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
end loop;
end if;
- End_Statements (Def_Node);
+ End_Statements (Def_Node, Decl);
return Def_Node;
end P_Task_Definition;
-- 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
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;
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;
-- 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;
end loop Declaration_Loop;
end loop Private_Loop;
- End_Statements (Def_Node);
+ End_Statements (Def_Node, Decl);
return Def_Node;
end P_Protected_Definition;
-- 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
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
-- 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;
-- 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;
-------------
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;
-------------
-- 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
-- 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
-- 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
-- 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;
--------------
-- P;
-- end;
- -- which shouold print 64 rather than 32. The exclusion of non-source
+ -- which should print 64 rather than 32. The exclusion of non-source
-- constructs from this test comes from some internal usage in packed
-- arrays, which otherwise fails, could use more analysis perhaps???
- if In_Spec_Expression
- and then Comes_From_Source (N)
- and then not (Is_Entity_Name (P) and then Is_Frozen (Entity (P)))
- then
- return;
- end if;
+ declare
+ function Within_Aspect (N : Node_Id) return Boolean;
+ -- True if within aspect expression. Giant kludge, do this test only
+ -- within an aspect, since doing it more widely, even though clearly
+ -- correct, causes regressions notably in GA19-001 ???
+
+ function Within_Aspect (N : Node_Id) return Boolean
+ is
+ begin
+ if No (Parent (N)) then
+ return False;
+ elsif Nkind (N) = N_Aspect_Specification then
+ return True;
+ else
+ return Within_Aspect (Parent (N));
+ end if;
+ end Within_Aspect;
+
+ begin
+ if In_Spec_Expression
+ and then Comes_From_Source (N)
+ and then not (Is_Entity_Name (P) and then Is_Frozen (Entity (P)))
+ and then Within_Aspect (N)
+ then
+ return;
+ end if;
+ end;
-- Acquire first two expressions (at the moment, no attributes take more
-- than two expressions in any case).
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;
-- 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.
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;
Set_Defining_Identifier (Form,
Make_Defining_Identifier (Loc,
Chars (Defining_Identifier (Form))));
+
+ -- Resolve the types of the formals now, because the freeze point
+ -- may appear in a different context, e.g. an instantiation.
+
+ if Nkind (Parameter_Type (Form)) /= N_Access_Definition then
+ Find_Type (Parameter_Type (Form));
+
+ elsif
+ No (Access_To_Subprogram_Definition (Parameter_Type (Form)))
+ then
+ Find_Type (Subtype_Mark (Parameter_Type (Form)));
+
+ else
+
+ -- the case of a null procedure with a formal that is an
+ -- access_to_subprogram type, and that is used as an actual
+ -- in an instantiation is left to the enthusiastic reader.
+
+ null;
+ end if;
+
Next (Form);
end loop;
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);
-- 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);
-- FULL_TYPE_DECLARATION ::=
-- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
- -- is TYPE_DEFINITION;
+ -- is TYPE_DEFINITION
+ -- [ASPECT_SPECIFICATIONS];
+
-- | TASK_TYPE_DECLARATION
-- | PROTECTED_TYPE_DECLARATION
-- 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
-- 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
-- 6.1 Subprogram Declaration --
---------------------------------
- -- SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION;
+ -- SUBPROGRAM_DECLARATION ::=
+ -- SUBPROGRAM_SPECIFICATION
+ -- [ASPECT_SPECIFICATIONS];
-- N_Subprogram_Declaration
-- Sloc points to FUNCTION or PROCEDURE
------------------------------------------
-- ABSTRACT_SUBPROGRAM_DECLARATION ::=
- -- SUBPROGRAM_SPECIFICATION is abstract;
+ -- SUBPROGRAM_SPECIFICATION is abstract
+ -- [ASPECT_SPECIFICATIONS];
-- N_Abstract_Subprogram_Declaration
-- Sloc points to ABSTRACT
-- 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.
-- 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
-- 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
-- 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
-- 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
-- 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
---------------------------------------
-- 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
-- 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
-- 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
-- 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
--------------------------------------------------
-- 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
--------------------------------------------------
-- 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
-- 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
-- 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]
-- Line for -gnatn switch
Write_Switch_Char ("n");
- Write_Line ("Inlining of subprograms (apply pragma Inline across units)");
+ Write_Line ("Enable pragma Inline (both within and across units)");
-- Line for -gnatN switch
projects / thirdparty / gcc.git / commitdiff
