1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 pragma Style_Checks
(All_Checks
);
27 -- Turn off subprogram body ordering check. Subprograms are in order
28 -- by RM section rather than alphabetical
30 with Sinfo
.CN
; use Sinfo
.CN
;
35 -- Local subprograms, used only in this chapter
37 function P_Defining_Designator
return Node_Id
;
38 function P_Defining_Operator_Symbol
return Node_Id
;
39 function P_Return_Object_Declaration
return Node_Id
;
41 procedure P_Return_Subtype_Indication
(Decl_Node
: Node_Id
);
42 -- Decl_Node is a N_Object_Declaration. Set the Null_Exclusion_Present and
43 -- Object_Definition fields of Decl_Node.
45 procedure Check_Junk_Semicolon_Before_Return
;
46 -- Check for common error of junk semicolon before RETURN keyword of
47 -- function specification. If present, skip over it with appropriate error
48 -- message, leaving Scan_Ptr pointing to the RETURN after. This routine
49 -- also deals with a possibly misspelled version of Return.
51 procedure No_Constraint_Maybe_Expr_Func
;
52 -- Called after scanning return subtype to check for missing constraint,
53 -- taking into account the possibility of an occurrence of an expression
54 -- function where the IS has been forgotten.
56 ----------------------------------------
57 -- Check_Junk_Semicolon_Before_Return --
58 ----------------------------------------
60 procedure Check_Junk_Semicolon_Before_Return
is
61 Scan_State
: Saved_Scan_State
;
64 if Token
= Tok_Semicolon
then
65 Save_Scan_State
(Scan_State
);
66 Scan
; -- past the semicolon
68 if Token
= Tok_Return
then
69 Restore_Scan_State
(Scan_State
);
70 Error_Msg_SC
-- CODEFIX
71 ("|extra "";"" ignored");
72 Scan
; -- rescan past junk semicolon
74 Restore_Scan_State
(Scan_State
);
77 end Check_Junk_Semicolon_Before_Return
;
79 -----------------------------------
80 -- No_Constraint_Maybe_Expr_Func --
81 -----------------------------------
83 procedure No_Constraint_Maybe_Expr_Func
is
85 -- If we have a left paren at the start of the line, then assume this is
86 -- the case of an expression function with missing IS. We do not have to
87 -- diagnose the missing IS, that is done elsewhere. We do this game in
88 -- Ada 2012 mode where expression functions are legal.
90 if Token
= Tok_Left_Paren
91 and Ada_Version
>= Ada_2012
92 and Token_Is_At_Start_Of_Line
94 -- One exception if we have "(token .." then this is a constraint
97 Scan_State
: Saved_Scan_State
;
100 Save_Scan_State
(Scan_State
);
101 Scan
; -- past left paren
102 Scan
; -- past following token
104 -- If we have "(token .." then restore scan state and treat as
105 -- unexpected constraint.
107 if Token
= Tok_Dot_Dot
then
108 Restore_Scan_State
(Scan_State
);
111 -- Otherwise we treat this as an expression function
114 Restore_Scan_State
(Scan_State
);
118 -- Otherwise use standard routine to check for no constraint present
123 end No_Constraint_Maybe_Expr_Func
;
125 -----------------------------------------------------
126 -- 6.1 Subprogram (Also 6.3, 8.5.4, 10.1.3, 12.3) --
127 -----------------------------------------------------
129 -- This routine scans out a subprogram declaration, subprogram body,
130 -- subprogram renaming declaration or subprogram generic instantiation.
131 -- It also handles the new Ada 2012 expression function form
133 -- SUBPROGRAM_DECLARATION ::=
134 -- SUBPROGRAM_SPECIFICATION
135 -- [ASPECT_SPECIFICATIONS];
137 -- ABSTRACT_SUBPROGRAM_DECLARATION ::=
138 -- SUBPROGRAM_SPECIFICATION is abstract
139 -- [ASPECT_SPECIFICATIONS];
141 -- SUBPROGRAM_SPECIFICATION ::=
142 -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
143 -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
145 -- PARAMETER_PROFILE ::= [FORMAL_PART]
147 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
149 -- SUBPROGRAM_BODY ::=
150 -- SUBPROGRAM_SPECIFICATION [ASPECT_SPECIFICATIONS] is
153 -- HANDLED_SEQUENCE_OF_STATEMENTS
156 -- SUBPROGRAM_RENAMING_DECLARATION ::=
157 -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME
158 -- [ASPECT_SPECIFICATIONS];
160 -- SUBPROGRAM_BODY_STUB ::=
161 -- SUBPROGRAM_SPECIFICATION is separate
162 -- [ASPECT_SPECIFICATIONS];
164 -- GENERIC_INSTANTIATION ::=
165 -- procedure DEFINING_PROGRAM_UNIT_NAME is
166 -- new generic_procedure_NAME [GENERIC_ACTUAL_PART]
167 -- [ASPECT_SPECIFICATIONS];
168 -- | function DEFINING_DESIGNATOR is
169 -- new generic_function_NAME [GENERIC_ACTUAL_PART]
170 -- [ASPECT_SPECIFICATIONS];
172 -- NULL_PROCEDURE_DECLARATION ::=
173 -- SUBPROGRAM_SPECIFICATION is null;
175 -- Null procedures are an Ada 2005 feature. A null procedure declaration
176 -- is classified as a basic declarative item, but it is parsed here, with
177 -- other subprogram constructs.
179 -- EXPRESSION_FUNCTION ::=
180 -- FUNCTION SPECIFICATION IS (EXPRESSION)
181 -- [ASPECT_SPECIFICATIONS];
183 -- The caller has checked that the initial token is FUNCTION, PROCEDURE,
184 -- NOT or OVERRIDING.
186 -- Error recovery: cannot raise Error_Resync
188 function P_Subprogram
(Pf_Flags
: Pf_Rec
) return Node_Id
is
190 function Contains_Import_Aspect
(Aspects
: List_Id
) return Boolean;
191 -- Return True if Aspects contains an Import aspect.
193 ----------------------------
194 -- Contains_Import_Aspect --
195 ----------------------------
197 function Contains_Import_Aspect
(Aspects
: List_Id
) return Boolean is
198 Aspect
: Node_Id
:= First
(Aspects
);
200 while Present
(Aspect
) loop
201 if Chars
(Identifier
(Aspect
)) = Name_Import
then
209 end Contains_Import_Aspect
;
211 Specification_Node
: Node_Id
;
214 Fpart_List
: List_Id
;
215 Fpart_Sloc
: Source_Ptr
;
216 Result_Not_Null
: Boolean := False;
217 Result_Node
: Node_Id
;
221 Rename_Node
: Node_Id
;
222 Absdec_Node
: Node_Id
;
224 Fproc_Sloc
: Source_Ptr
;
226 Scan_State
: Saved_Scan_State
;
228 -- Flags for optional overriding indication. Two flags are needed,
229 -- to distinguish positive and negative overriding indicators from
230 -- the absence of any indicator.
232 Is_Overriding
: Boolean := False;
233 Not_Overriding
: Boolean := False;
236 -- Set up scope stack entry. Note that the Labl field will be set later
238 SIS_Entry_Active
:= False;
239 SIS_Aspect_Import_Seen
:= False;
240 SIS_Missing_Semicolon_Message
:= No_Error_Msg
;
242 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
243 Scopes
(Scope
.Last
).Etyp
:= E_Name
;
244 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
245 Scopes
(Scope
.Last
).Lreq
:= False;
247 Aspects
:= Empty_List
;
249 -- Ada 2005: Scan leading NOT OVERRIDING indicator
251 if Token
= Tok_Not
then
254 if Token
= Tok_Overriding
then
255 Scan
; -- past OVERRIDING
256 Not_Overriding
:= True;
258 -- Overriding keyword used in non Ada 2005 mode
260 elsif Token
= Tok_Identifier
261 and then Token_Name
= Name_Overriding
263 Error_Msg_SC
("overriding indicator is an Ada 2005 extension");
264 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
265 Scan
; -- past Overriding
266 Not_Overriding
:= True;
269 Error_Msg_SC
-- CODEFIX
270 ("OVERRIDING expected!");
273 -- Ada 2005: scan leading OVERRIDING indicator
275 -- Note: in the case of OVERRIDING keyword used in Ada 95 mode, the
276 -- declaration circuit already gave an error message and changed the
277 -- token to Tok_Overriding.
279 elsif Token
= Tok_Overriding
then
280 Scan
; -- past OVERRIDING
281 Is_Overriding
:= True;
284 if Is_Overriding
or else Not_Overriding
then
286 -- Note that if we are not in Ada_2005 mode, error messages have
287 -- already been given, so no need to give another message here.
289 -- An overriding indicator is allowed for subprogram declarations,
290 -- bodies (including subunits), renamings, stubs, and instantiations.
291 -- The test against Pf_Decl_Pbod is added to account for the case of
292 -- subprograms declared in a protected type, where only subprogram
293 -- declarations and bodies can occur. The Pf_Pbod case is for
296 if Pf_Flags
/= Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
298 Pf_Flags
/= Pf_Decl_Pbod_Pexp
300 Pf_Flags
/= Pf_Pbod_Pexp
302 Error_Msg_SC
("overriding indicator not allowed here!");
304 elsif Token
not in Tok_Function | Tok_Procedure
then
305 Error_Msg_SC
-- CODEFIX
306 ("FUNCTION or PROCEDURE expected!");
310 Func
:= (Token
= Tok_Function
);
311 Fproc_Sloc
:= Token_Ptr
;
312 Scan
; -- past FUNCTION or PROCEDURE
317 Name_Node
:= P_Defining_Designator
;
319 if Nkind
(Name_Node
) = N_Defining_Operator_Symbol
320 and then Scope
.Last
= 1
322 Error_Msg_SP
("operator symbol not allowed at library level");
323 Name_Node
:= New_Entity
(N_Defining_Identifier
, Sloc
(Name_Node
));
325 -- Set name from file name, we need some junk name, and that's
326 -- as good as anything. This is only approximate, since we do
327 -- not do anything with non-standard name translations.
329 Get_Name_String
(File_Name
(Current_Source_File
));
331 for J
in 1 .. Name_Len
loop
332 if Name_Buffer
(J
) = '.' then
338 Set_Chars
(Name_Node
, Name_Find
);
339 Set_Error_Posted
(Name_Node
);
343 Name_Node
:= P_Defining_Program_Unit_Name
;
346 Scopes
(Scope
.Last
).Labl
:= Name_Node
;
347 Current_Node
:= Name_Node
;
350 -- Deal with generic instantiation, the one case in which we do not
351 -- have a subprogram specification as part of whatever we are parsing
353 if Token
= Tok_Is
then
354 Save_Scan_State
(Scan_State
); -- at the IS
355 T_Is
; -- checks for redundant IS
357 if Token
= Tok_New
then
358 if not Pf_Flags
.Gins
then
359 Error_Msg_SC
("generic instantiation not allowed here!");
365 Inst_Node
:= New_Node
(N_Function_Instantiation
, Fproc_Sloc
);
366 Set_Name
(Inst_Node
, P_Function_Name
);
368 Inst_Node
:= New_Node
(N_Procedure_Instantiation
, Fproc_Sloc
);
369 Set_Name
(Inst_Node
, P_Qualified_Simple_Name
);
372 Set_Defining_Unit_Name
(Inst_Node
, Name_Node
);
373 Set_Generic_Associations
(Inst_Node
, P_Generic_Actual_Part_Opt
);
374 P_Aspect_Specifications
(Inst_Node
);
375 Pop_Scope_Stack
; -- Don't need scope stack entry in this case
377 if Is_Overriding
then
378 Set_Must_Override
(Inst_Node
);
380 elsif Not_Overriding
then
381 Set_Must_Not_Override
(Inst_Node
);
387 Restore_Scan_State
(Scan_State
); -- to the IS
391 -- If not a generic instantiation, then we definitely have a subprogram
392 -- specification (all possibilities at this stage include one here)
394 Fpart_Sloc
:= Token_Ptr
;
396 Check_Misspelling_Of
(Tok_Return
);
398 -- Scan formal part. First a special error check. If we have an
399 -- identifier here, then we have a definite error. If this identifier
400 -- is on the same line as the designator, then we assume it is the
401 -- first formal after a missing left parenthesis
403 if Token
= Tok_Identifier
404 and then not Token_Is_At_Start_Of_Line
406 T_Left_Paren
; -- to generate message
407 Fpart_List
:= P_Formal_Part
;
409 -- Otherwise scan out an optional formal part in the usual manner
412 Fpart_List
:= P_Parameter_Profile
;
415 -- We treat what we have as a function specification if FUNCTION was
416 -- used, or if a RETURN is present. This gives better error recovery
417 -- since later RETURN statements will be valid in either case.
419 Check_Junk_Semicolon_Before_Return
;
420 Result_Node
:= Error
;
422 if Token
= Tok_Return
then
425 ("PROCEDURE should be FUNCTION", Fproc_Sloc
);
431 Result_Not_Null
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
433 -- Ada 2005 (AI-318-02)
435 if Token
= Tok_Access
then
436 Error_Msg_Ada_2005_Extension
("anonymous access result type");
438 Result_Node
:= P_Access_Definition
(Result_Not_Null
);
441 Result_Node
:= P_Subtype_Mark
;
442 No_Constraint_Maybe_Expr_Func
;
446 -- Skip extra parenthesis at end of formal part
448 Ignore
(Tok_Right_Paren
);
450 -- For function, scan result subtype
455 if Prev_Token
= Tok_Return
then
456 Result_Node
:= P_Subtype_Mark
;
462 Specification_Node
:=
463 New_Node
(N_Function_Specification
, Fproc_Sloc
);
465 Set_Null_Exclusion_Present
(Specification_Node
, Result_Not_Null
);
466 Set_Result_Definition
(Specification_Node
, Result_Node
);
469 Specification_Node
:=
470 New_Node
(N_Procedure_Specification
, Fproc_Sloc
);
473 Set_Defining_Unit_Name
(Specification_Node
, Name_Node
);
474 Set_Parameter_Specifications
(Specification_Node
, Fpart_List
);
476 if Is_Overriding
then
477 Set_Must_Override
(Specification_Node
);
479 elsif Not_Overriding
then
480 Set_Must_Not_Override
(Specification_Node
);
483 -- Error check: barriers not allowed on protected functions/procedures
485 if Token
= Tok_When
then
487 Error_Msg_SC
("barrier not allowed on function, only on entry");
489 Error_Msg_SC
("barrier not allowed on procedure, only on entry");
493 Discard_Junk_Node
(P_Expression
);
496 -- Deal with semicolon followed by IS. We want to treat this as IS
498 if Token
= Tok_Semicolon
then
499 Save_Scan_State
(Scan_State
);
500 Scan
; -- past semicolon
502 if Token
= Tok_Is
then
503 Error_Msg_SP
-- CODEFIX
504 ("extra "";"" ignored");
506 Restore_Scan_State
(Scan_State
);
510 -- Subprogram declaration ended by aspect specifications
512 if Aspect_Specifications_Present
then
513 goto Subprogram_Declaration
;
515 -- Deal with case of semicolon ending a subprogram declaration
517 elsif Token
= Tok_Semicolon
then
518 if not Pf_Flags
.Decl
then
522 Save_Scan_State
(Scan_State
);
523 Scan
; -- past semicolon
525 -- If semicolon is immediately followed by IS, then ignore the
526 -- semicolon, and go process the body.
528 if Token
= Tok_Is
then
529 Error_Msg_SP
-- CODEFIX
530 ("|extra "";"" ignored");
531 T_Is
; -- scan past IS
532 goto Subprogram_Body
;
534 -- If BEGIN follows in an appropriate column, we immediately
535 -- commence the error action of assuming that the previous
536 -- subprogram declaration should have been a subprogram body,
537 -- i.e. that the terminating semicolon should have been IS.
539 elsif Token
= Tok_Begin
540 and then Start_Column
>= Scopes
(Scope
.Last
).Ecol
542 Error_Msg_SP
-- CODEFIX
543 ("|"";"" should be IS!");
544 goto Subprogram_Body
;
547 Restore_Scan_State
(Scan_State
);
548 goto Subprogram_Declaration
;
551 -- Case of not followed by semicolon
554 -- Subprogram renaming declaration case
556 Check_Misspelling_Of
(Tok_Renames
);
558 if Token
= Tok_Renames
then
559 if not Pf_Flags
.Rnam
then
560 Error_Msg_SC
("renaming declaration not allowed here!");
564 New_Node
(N_Subprogram_Renaming_Declaration
, Token_Ptr
);
565 Scan
; -- past RENAMES
566 Set_Name
(Rename_Node
, P_Name
);
567 Set_Specification
(Rename_Node
, Specification_Node
);
568 P_Aspect_Specifications
(Rename_Node
);
573 -- Case of IS following subprogram specification
575 elsif Token
= Tok_Is
then
576 T_Is
; -- ignore redundant Is's
578 if Token_Name
= Name_Abstract
then
579 Check_95_Keyword
(Tok_Abstract
, Tok_Semicolon
);
582 -- Deal nicely with (now obsolete) use of <> in place of abstract
584 if Token
= Tok_Box
then
585 Error_Msg_SC
-- CODEFIX
586 ("ABSTRACT expected");
587 Token
:= Tok_Abstract
;
590 -- Abstract subprogram declaration case
592 if Token
= Tok_Abstract
then
594 New_Node
(N_Abstract_Subprogram_Declaration
, Token_Ptr
);
595 Set_Specification
(Absdec_Node
, Specification_Node
);
596 Pop_Scope_Stack
; -- discard unneeded entry
597 Scan
; -- past ABSTRACT
598 P_Aspect_Specifications
(Absdec_Node
);
601 -- Ada 2005 (AI-248): Parse a null procedure declaration
603 elsif Token
= Tok_Null
then
604 Error_Msg_Ada_2005_Extension
("null procedure");
609 Error_Msg_SP
("only procedures can be null");
611 Set_Null_Present
(Specification_Node
);
612 Set_Null_Statement
(Specification_Node
,
613 New_Node
(N_Null_Statement
, Prev_Token_Ptr
));
616 goto Subprogram_Declaration
;
618 -- Check for IS NEW with Formal_Part present and handle nicely
620 elsif Token
= Tok_New
then
622 ("formal part not allowed in instantiation", Fpart_Sloc
);
626 Inst_Node
:= New_Node
(N_Function_Instantiation
, Fproc_Sloc
);
629 New_Node
(N_Procedure_Instantiation
, Fproc_Sloc
);
632 Set_Defining_Unit_Name
(Inst_Node
, Name_Node
);
633 Set_Name
(Inst_Node
, P_Name
);
634 Set_Generic_Associations
(Inst_Node
, P_Generic_Actual_Part_Opt
);
636 Pop_Scope_Stack
; -- Don't need scope stack entry in this case
640 goto Subprogram_Body
;
643 -- Aspect specifications present
645 elsif Aspect_Specifications_Present
then
646 goto Subprogram_Declaration
;
648 -- Here we have a missing IS or missing semicolon
651 -- If the next token is a left paren at the start of a line, then
652 -- this is almost certainly the start of the expression for an
653 -- expression function, so in this case guess a missing IS.
655 if Token
= Tok_Left_Paren
and then Token_Is_At_Start_Of_Line
then
656 Error_Msg_AP
-- CODEFIX
659 -- In all other cases, we guess a missing semicolon, since we are
660 -- good at fixing up a semicolon which should really be an IS.
663 Error_Msg_AP
-- CODEFIX
665 SIS_Missing_Semicolon_Message
:= Get_Msg_Id
;
666 goto Subprogram_Declaration
;
671 -- Processing for stub or subprogram body or expression function
675 -- Subprogram body stub case
677 if Separate_Present
then
678 if not Pf_Flags
.Stub
then
679 Error_Msg_SC
("body stub not allowed here!");
682 if Nkind
(Name_Node
) = N_Defining_Operator_Symbol
then
684 ("operator symbol cannot be used as subunit name",
688 Scan
; -- past SEPARATE
691 New_Node
(N_Subprogram_Body_Stub
, Sloc
(Specification_Node
));
692 Set_Specification
(Stub_Node
, Specification_Node
);
694 if Is_Non_Empty_List
(Aspects
) then
696 ("aspect specifications must come after SEPARATE",
697 Sloc
(First
(Aspects
)));
700 P_Aspect_Specifications
(Stub_Node
, Semicolon
=> False);
705 -- Subprogram body or expression function case
708 Scan_Body_Or_Expression_Function
: declare
710 function Likely_Expression_Function
return Boolean;
711 -- Returns True if we have a probable case of an expression
712 -- function omitting the parentheses, if so, returns True
713 -- and emits an appropriate error message, else returns False.
715 --------------------------------
716 -- Likely_Expression_Function --
717 --------------------------------
719 function Likely_Expression_Function
return Boolean is
721 -- If currently pointing to BEGIN or a declaration keyword
722 -- or a pragma, then we definitely have a subprogram body.
723 -- This is a common case, so worth testing first.
725 if Token
in Tok_Begin | Token_Class_Declk | Tok_Pragma
then
728 -- Test for tokens which could only start an expression and
729 -- thus signal the case of a expression function.
732 Token_Class_Literal | Token_Class_Unary_Addop |
733 Tok_Left_Paren | Tok_Abs | Tok_Null | Tok_New | Tok_Not
737 -- Anything other than an identifier must be a body
739 elsif Token
/= Tok_Identifier
then
742 -- Here for an identifier
745 -- If the identifier is the first token on its line, then
746 -- let's assume that we have a missing begin and this is
747 -- intended as a subprogram body. However, if the context
748 -- is a function and the unit is a package declaration, a
749 -- body would be illegal, so try for an unparenthesized
750 -- expression function.
752 if Token_Is_At_Start_Of_Line
then
754 -- The enclosing scope entry is a subprogram spec
756 Spec_Node
: constant Node_Id
:=
758 (Scopes
(Scope
.Last
).Labl
);
759 Lib_Node
: Node_Id
:= Spec_Node
;
762 -- Check whether there is an enclosing scope that
763 -- is a package declaration.
765 if Scope
.Last
> 1 then
767 Parent
(Scopes
(Scope
.Last
- 1).Labl
);
770 if Ada_Version
>= Ada_2012
772 Nkind
(Lib_Node
) = N_Package_Specification
774 Nkind
(Spec_Node
) = N_Function_Specification
782 -- Otherwise we have to scan ahead. If the identifier is
783 -- followed by a colon or a comma, it is a declaration
784 -- and hence we have a subprogram body. Otherwise assume
785 -- a expression function.
789 Scan_State
: Saved_Scan_State
;
793 Save_Scan_State
(Scan_State
);
794 Scan
; -- past identifier
796 Restore_Scan_State
(Scan_State
);
798 if Tok
= Tok_Colon
or else Tok
= Tok_Comma
then
805 -- Fall through if we have a likely expression function.
806 -- If the starting keyword is not "function" the error
807 -- will be reported elsewhere.
811 ("expression function must be enclosed in parentheses");
815 end Likely_Expression_Function
;
817 -- Start of processing for Scan_Body_Or_Expression_Function
820 -- Expression_Function case
822 -- If likely an aggregate, check we are in Ada 2022 mode
824 if Token
= Tok_Left_Bracket
then
825 Error_Msg_Ada_2022_Feature
826 ("!aggregates as expression function", Token_Ptr
);
829 if Token
in Tok_Left_Paren | Tok_Left_Bracket
830 or else Likely_Expression_Function
832 -- Check expression function allowed here
834 if not Pf_Flags
.Pexp
then
835 Error_Msg_SC
("expression function not allowed here!");
838 -- Check we are in Ada 2012 mode
840 Error_Msg_Ada_2012_Feature
841 ("!expression function", Token_Ptr
);
843 -- Catch an illegal placement of the aspect specification
846 -- function_specification
847 -- [aspect_specification] is (expression);
849 -- This case is correctly processed by the parser because
850 -- the expression function first appears as a subprogram
851 -- declaration to the parser. The starting keyword may
852 -- not have been "function" in which case the error is
853 -- on a malformed procedure.
855 if Is_Non_Empty_List
(Aspects
) then
858 ("aspect specifications must come after "
859 & "parenthesized expression",
860 Sloc
(First
(Aspects
)));
863 ("aspect specifications must come after subprogram "
864 & "specification", Sloc
(First
(Aspects
)));
868 -- Parse out expression and build expression function
872 (N_Expression_Function
, Sloc
(Specification_Node
));
873 Set_Specification
(Body_Node
, Specification_Node
);
876 Expr
: constant Node_Id
:= P_Expression
;
878 Set_Expression
(Body_Node
, Expr
);
880 -- Check that the full expression is properly
881 -- parenthesized since we may have a left-operand that is
882 -- parenthesized but that is not one of the allowed cases
883 -- with syntactic parentheses.
885 if not (Paren_Count
(Expr
) /= 0
886 or else Nkind
(Expr
) in N_Aggregate
887 | N_Extension_Aggregate
888 | N_Quantified_Expression
)
891 ("expression function must be enclosed in "
892 & "parentheses", Sloc
(Expr
));
896 -- Expression functions can carry pre/postconditions
898 P_Aspect_Specifications
(Body_Node
);
901 -- Subprogram body case
904 -- Check body allowed here
906 if not Pf_Flags
.Pbod
then
907 Error_Msg_SP
("subprogram body not allowed here!");
910 -- Here is the test for a suspicious IS (i.e. one that
911 -- looks like it might more properly be a semicolon).
912 -- See separate section describing use of IS instead
913 -- of semicolon in package Parse.
915 if (Token
in Token_Class_Declk
917 Token
= Tok_Identifier
)
918 and then Start_Column
<= Scopes
(Scope
.Last
).Ecol
919 and then Scope
.Last
/= 1
921 Scopes
(Scope
.Last
).Etyp
:= E_Suspicious_Is
;
922 Scopes
(Scope
.Last
).S_Is
:= Prev_Token_Ptr
;
925 -- Build and return subprogram body, parsing declarations
926 -- and statement sequence that belong to the body.
929 New_Node
(N_Subprogram_Body
, Sloc
(Specification_Node
));
930 Set_Specification
(Body_Node
, Specification_Node
);
932 -- If aspects are present, the specification is parsed as
933 -- a subprogram declaration, and we jump here after seeing
934 -- the keyword IS. Attach asspects previously collected to
937 if Is_Non_Empty_List
(Aspects
) then
938 Set_Parent
(Aspects
, Body_Node
);
939 Set_Aspect_Specifications
(Body_Node
, Aspects
);
942 Parse_Decls_Begin_End
(Body_Node
);
946 end Scan_Body_Or_Expression_Function
;
949 -- Processing for subprogram declaration
951 <<Subprogram_Declaration
>>
953 New_Node
(N_Subprogram_Declaration
, Sloc
(Specification_Node
));
954 Set_Specification
(Decl_Node
, Specification_Node
);
955 Aspects
:= Get_Aspect_Specifications
(Semicolon
=> False);
957 -- Aspects may be present on a subprogram body. The source parsed
958 -- so far is that of its specification. Go parse the body and attach
959 -- the collected aspects, if any, to the body.
961 if Token
= Tok_Is
then
963 -- If the subprogram is a procedure and already has a
964 -- specification, we can't define another.
966 if Nkind
(Specification
(Decl_Node
)) = N_Procedure_Specification
967 and then Null_Present
(Specification
(Decl_Node
))
969 Error_Msg_AP
("null procedure cannot have a body");
973 goto Subprogram_Body
;
976 if Is_Non_Empty_List
(Aspects
) then
977 Set_Parent
(Aspects
, Decl_Node
);
978 Set_Aspect_Specifications
(Decl_Node
, Aspects
);
984 -- If this is a context in which a subprogram body is permitted,
985 -- set active SIS entry in case (see section titled "Handling
986 -- Semicolon Used in Place of IS" in body of Parser package)
987 -- Note that SIS_Missing_Semicolon_Message is already set properly.
991 -- Disconnect this processing if we have scanned a null procedure
992 -- or an Import aspect because in this case the spec is complete
993 -- anyway with no body.
995 and then (Nkind
(Specification_Node
) /= N_Procedure_Specification
996 or else not Null_Present
(Specification_Node
))
997 and then not Contains_Import_Aspect
(Aspects
)
999 SIS_Labl
:= Scopes
(Scope
.Last
).Labl
;
1000 SIS_Sloc
:= Scopes
(Scope
.Last
).Sloc
;
1001 SIS_Ecol
:= Scopes
(Scope
.Last
).Ecol
;
1002 SIS_Declaration_Node
:= Decl_Node
;
1003 SIS_Semicolon_Sloc
:= Prev_Token_Ptr
;
1005 -- Do not activate the entry if we have "with Import"
1007 if not SIS_Aspect_Import_Seen
then
1008 SIS_Entry_Active
:= True;
1016 ---------------------------------
1017 -- 6.1 Subprogram Declaration --
1018 ---------------------------------
1020 -- Parsed by P_Subprogram (6.1)
1022 ------------------------------------------
1023 -- 6.1 Abstract Subprogram Declaration --
1024 ------------------------------------------
1026 -- Parsed by P_Subprogram (6.1)
1028 -----------------------------------
1029 -- 6.1 Subprogram Specification --
1030 -----------------------------------
1032 -- SUBPROGRAM_SPECIFICATION ::=
1033 -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
1034 -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
1036 -- PARAMETER_PROFILE ::= [FORMAL_PART]
1038 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
1040 -- Subprogram specifications that appear in subprogram declarations
1041 -- are parsed by P_Subprogram (6.1). This routine is used in other
1042 -- contexts where subprogram specifications occur.
1044 -- Note: this routine does not affect the scope stack in any way
1046 -- Error recovery: can raise Error_Resync
1048 function P_Subprogram_Specification
return Node_Id
is
1049 Specification_Node
: Node_Id
;
1050 Result_Not_Null
: Boolean;
1051 Result_Node
: Node_Id
;
1054 if Token
= Tok_Function
then
1055 Specification_Node
:= New_Node
(N_Function_Specification
, Token_Ptr
);
1056 Scan
; -- past FUNCTION
1058 Set_Defining_Unit_Name
(Specification_Node
, P_Defining_Designator
);
1059 Set_Parameter_Specifications
1060 (Specification_Node
, P_Parameter_Profile
);
1061 Check_Junk_Semicolon_Before_Return
;
1064 Result_Not_Null
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1066 -- Ada 2005 (AI-318-02)
1068 if Token
= Tok_Access
then
1069 Error_Msg_Ada_2005_Extension
("anonymous access result type");
1071 Result_Node
:= P_Access_Definition
(Result_Not_Null
);
1074 Result_Node
:= P_Subtype_Mark
;
1075 No_Constraint_Maybe_Expr_Func
;
1078 Set_Null_Exclusion_Present
(Specification_Node
, Result_Not_Null
);
1079 Set_Result_Definition
(Specification_Node
, Result_Node
);
1080 return Specification_Node
;
1082 elsif Token
= Tok_Procedure
then
1083 Specification_Node
:= New_Node
(N_Procedure_Specification
, Token_Ptr
);
1084 Scan
; -- past PROCEDURE
1086 Set_Defining_Unit_Name
1087 (Specification_Node
, P_Defining_Program_Unit_Name
);
1088 Set_Parameter_Specifications
1089 (Specification_Node
, P_Parameter_Profile
);
1090 return Specification_Node
;
1093 Error_Msg_SC
("subprogram specification expected");
1096 end P_Subprogram_Specification
;
1098 ---------------------
1099 -- 6.1 Designator --
1100 ---------------------
1103 -- [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL
1105 -- The caller has checked that the initial token is an identifier,
1106 -- operator symbol, or string literal. Note that we don't bother to
1107 -- do much error diagnosis in this routine, since it is only used for
1108 -- the label on END lines, and the routines in package Par.Endh will
1109 -- check that the label is appropriate.
1111 -- Error recovery: cannot raise Error_Resync
1113 function P_Designator
return Node_Id
is
1114 Ident_Node
: Node_Id
;
1115 Name_Node
: Node_Id
;
1116 Prefix_Node
: Node_Id
;
1118 function Real_Dot
return Boolean;
1119 -- Tests if a current token is an interesting period, i.e. is followed
1120 -- by an identifier or operator symbol or string literal. If not, it is
1121 -- probably just incorrect punctuation to be caught by our caller. Note
1122 -- that the case of an operator symbol or string literal is also an
1123 -- error, but that is an error that we catch here. If the result is
1124 -- True, a real dot has been scanned and we are positioned past it,
1125 -- if the result is False, the scan position is unchanged.
1131 function Real_Dot
return Boolean is
1132 Scan_State
: Saved_Scan_State
;
1135 if Token
/= Tok_Dot
then
1139 Save_Scan_State
(Scan_State
);
1143 Tok_Identifier | Tok_Operator_Symbol | Tok_String_Literal
1148 Restore_Scan_State
(Scan_State
);
1154 -- Start of processing for P_Designator
1157 Ident_Node
:= Token_Node
;
1158 Scan
; -- past initial token
1160 if Prev_Token
in Tok_Operator_Symbol | Tok_String_Literal
1161 or else not Real_Dot
1168 Prefix_Node
:= Ident_Node
;
1170 -- Loop through child names, on entry to this loop, Prefix contains
1171 -- the name scanned so far, and Ident_Node is the last identifier.
1174 Name_Node
:= New_Node
(N_Selected_Component
, Prev_Token_Ptr
);
1175 Set_Prefix
(Name_Node
, Prefix_Node
);
1176 Ident_Node
:= P_Identifier
;
1177 Set_Selector_Name
(Name_Node
, Ident_Node
);
1178 Prefix_Node
:= Name_Node
;
1179 exit when not Real_Dot
;
1182 -- On exit from the loop, Ident_Node is the last identifier scanned,
1183 -- i.e. the defining identifier, and Prefix_Node is a node for the
1184 -- entire name, structured (incorrectly) as a selected component.
1186 Name_Node
:= Prefix
(Prefix_Node
);
1187 Change_Node
(Prefix_Node
, N_Designator
);
1188 Set_Name
(Prefix_Node
, Name_Node
);
1189 Set_Identifier
(Prefix_Node
, Ident_Node
);
1194 when Error_Resync
=>
1195 while Token
in Tok_Dot | Tok_Identifier
loop
1202 ------------------------------
1203 -- 6.1 Defining Designator --
1204 ------------------------------
1206 -- DEFINING_DESIGNATOR ::=
1207 -- DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL
1209 -- Error recovery: cannot raise Error_Resync
1211 function P_Defining_Designator
return Node_Id
is
1213 if Token
= Tok_Operator_Symbol
then
1214 return P_Defining_Operator_Symbol
;
1216 elsif Token
= Tok_String_Literal
then
1217 Error_Msg_SC
("invalid operator name");
1218 Scan
; -- past junk string
1222 return P_Defining_Program_Unit_Name
;
1224 end P_Defining_Designator
;
1226 -------------------------------------
1227 -- 6.1 Defining Program Unit Name --
1228 -------------------------------------
1230 -- DEFINING_PROGRAM_UNIT_NAME ::=
1231 -- [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER
1233 -- Note: PARENT_UNIT_NAME may be present only in 95 mode at the outer level
1235 -- Error recovery: cannot raise Error_Resync
1237 function P_Defining_Program_Unit_Name
return Node_Id
is
1238 Ident_Node
: Node_Id
;
1239 Name_Node
: Node_Id
;
1240 Prefix_Node
: Node_Id
;
1243 -- Set identifier casing if not already set and scan initial identifier
1245 if Token
= Tok_Identifier
1246 and then Identifier_Casing
(Current_Source_File
) = Unknown
1248 Set_Identifier_Casing
(Current_Source_File
, Determine_Token_Casing
);
1251 Ident_Node
:= P_Identifier
(C_Dot
);
1252 Merge_Identifier
(Ident_Node
, Tok_Return
);
1254 -- Normal case (not child library unit name)
1256 if Token
/= Tok_Dot
then
1257 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
1258 Warn_If_Standard_Redefinition
(Ident_Node
);
1261 -- Child library unit name case
1264 if Scope
.Last
> 1 then
1265 Error_Msg_SP
("child unit allowed only at library level");
1268 elsif Ada_Version
= Ada_83
then
1269 Error_Msg_SP
("(Ada 83) child unit not allowed!");
1273 Prefix_Node
:= Ident_Node
;
1275 -- Loop through child names, on entry to this loop, Prefix contains
1276 -- the name scanned so far, and Ident_Node is the last identifier.
1279 exit when Token
/= Tok_Dot
;
1280 Name_Node
:= New_Node
(N_Selected_Component
, Token_Ptr
);
1281 Scan
; -- past period
1282 Set_Prefix
(Name_Node
, Prefix_Node
);
1283 Ident_Node
:= P_Identifier
(C_Dot
);
1284 Set_Selector_Name
(Name_Node
, Ident_Node
);
1285 Prefix_Node
:= Name_Node
;
1288 -- On exit from the loop, Ident_Node is the last identifier scanned,
1289 -- i.e. the defining identifier, and Prefix_Node is a node for the
1290 -- entire name, structured (incorrectly) as a selected component.
1292 Name_Node
:= Prefix
(Prefix_Node
);
1293 Change_Node
(Prefix_Node
, N_Defining_Program_Unit_Name
);
1294 Set_Name
(Prefix_Node
, Name_Node
);
1295 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
1296 Warn_If_Standard_Redefinition
(Ident_Node
);
1297 Set_Defining_Identifier
(Prefix_Node
, Ident_Node
);
1299 -- All set with unit name parsed
1305 when Error_Resync
=>
1306 while Token
in Tok_Dot | Tok_Identifier
loop
1311 end P_Defining_Program_Unit_Name
;
1313 --------------------------
1314 -- 6.1 Operator Symbol --
1315 --------------------------
1317 -- OPERATOR_SYMBOL ::= STRING_LITERAL
1319 -- Operator symbol is returned by the scanner as Tok_Operator_Symbol
1321 -----------------------------------
1322 -- 6.1 Defining Operator Symbol --
1323 -----------------------------------
1325 -- DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL
1327 -- The caller has checked that the initial symbol is an operator symbol
1329 function P_Defining_Operator_Symbol
return Node_Id
is
1333 Op_Node
:= Token_Node
;
1334 Change_Operator_Symbol_To_Defining_Operator_Symbol
(Op_Node
);
1335 Scan
; -- past operator symbol
1337 end P_Defining_Operator_Symbol
;
1339 ----------------------------
1340 -- 6.1 Parameter_Profile --
1341 ----------------------------
1343 -- PARAMETER_PROFILE ::= [FORMAL_PART]
1345 -- Empty is returned if no formal part is present
1347 -- Error recovery: cannot raise Error_Resync
1349 function P_Parameter_Profile
return List_Id
is
1351 if Token
= Tok_Left_Paren
then
1352 Scan
; -- part left paren
1353 return P_Formal_Part
;
1357 end P_Parameter_Profile
;
1359 ---------------------------------------
1360 -- 6.1 Parameter And Result Profile --
1361 ---------------------------------------
1363 -- Parsed by its parent construct, which uses P_Parameter_Profile to
1364 -- parse the parameters, and P_Subtype_Mark to parse the return type.
1366 ----------------------
1367 -- 6.1 Formal part --
1368 ----------------------
1370 -- FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION})
1372 -- PARAMETER_SPECIFICATION ::=
1373 -- DEFINING_IDENTIFIER_LIST : [ALIASED] MODE [NULL_EXCLUSION]
1374 -- SUBTYPE_MARK [:= DEFAULT_EXPRESSION]
1375 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
1376 -- [:= DEFAULT_EXPRESSION]
1378 -- This scans the construct Formal_Part. The caller has already checked
1379 -- that the initial token is a left parenthesis, and skipped past it, so
1380 -- that on entry Token is the first token following the left parenthesis.
1382 -- Note: The ALIASED keyword is allowed only in Ada 2012 mode (AI 142)
1384 -- Error recovery: cannot raise Error_Resync
1386 function P_Formal_Part
return List_Id
is
1387 Specification_List
: List_Id
;
1388 Specification_Node
: Node_Id
;
1389 Scan_State
: Saved_Scan_State
;
1392 Ident_Sloc
: Source_Ptr
;
1393 Not_Null_Present
: Boolean := False;
1394 Not_Null_Sloc
: Source_Ptr
;
1396 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
1397 -- This array holds the list of defining identifiers. The upper bound
1398 -- of 4096 is intended to be essentially infinite, and we do not even
1399 -- bother to check for it being exceeded.
1402 Specification_List
:= New_List
;
1403 Specification_Loop
: loop
1405 if Token
= Tok_Pragma
then
1406 Error_Msg_SC
("pragma not allowed in formal part");
1407 Discard_Junk_Node
(P_Pragma
(Skipping
=> True));
1410 Ignore
(Tok_Left_Paren
);
1411 Ident_Sloc
:= Token_Ptr
;
1412 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
1416 exit Ident_Loop
when Token
= Tok_Colon
;
1418 -- The only valid tokens are colon and comma, so if we have
1419 -- neither do a bit of investigation to see which is the
1420 -- better choice for insertion.
1422 if Token
/= Tok_Comma
then
1424 -- Assume colon if ALIASED, IN or OUT keyword found
1426 exit Ident_Loop
when Token
= Tok_Aliased
or else
1427 Token
= Tok_In
or else
1430 -- Otherwise scan ahead
1432 Save_Scan_State
(Scan_State
);
1435 -- If we run into a semicolon, then assume that a
1436 -- colon was missing, e.g. Parms (X Y; ...). Also
1437 -- assume missing colon on EOF (a real disaster)
1438 -- and on a right paren, e.g. Parms (X Y), and also
1439 -- on an assignment symbol, e.g. Parms (X Y := ..)
1441 if Token
in Tok_Semicolon | Tok_Right_Paren |
1442 Tok_EOF | Tok_Colon_Equal
1444 Restore_Scan_State
(Scan_State
);
1447 -- If we run into a colon, assume that we had a missing
1448 -- comma, e.g. Parms (A B : ...). Also assume a missing
1449 -- comma if we hit another comma, e.g. Parms (A B, C ..)
1451 elsif Token
in Tok_Colon | Tok_Comma
then
1452 Restore_Scan_State
(Scan_State
);
1457 end loop Look_Ahead
;
1460 -- Here if a comma is present, or to be assumed
1463 Num_Idents
:= Num_Idents
+ 1;
1464 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
1465 end loop Ident_Loop
;
1467 -- Fall through the loop on encountering a colon, or deciding
1468 -- that there is a missing colon.
1472 -- If there are multiple identifiers, we repeatedly scan the
1473 -- type and initialization expression information by resetting
1474 -- the scan pointer (so that we get completely separate trees
1475 -- for each occurrence).
1477 if Num_Idents
> 1 then
1478 Save_Scan_State
(Scan_State
);
1481 -- Loop through defining identifiers in list
1485 Ident_List_Loop
: loop
1486 Specification_Node
:=
1487 New_Node
(N_Parameter_Specification
, Ident_Sloc
);
1488 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
1490 -- Scan possible ALIASED for Ada 2012 (AI-142)
1492 if Token
= Tok_Aliased
then
1493 if Ada_Version
< Ada_2012
then
1494 Error_Msg_Ada_2012_Feature
1495 ("ALIASED parameter", Token_Ptr
);
1497 Set_Aliased_Present
(Specification_Node
);
1500 Scan
; -- past ALIASED
1503 -- Scan possible NOT NULL for Ada 2005 (AI-231, AI-447)
1505 Not_Null_Sloc
:= Token_Ptr
;
1507 P_Null_Exclusion
(Allow_Anonymous_In_95
=> True);
1509 -- Case of ACCESS keyword present
1511 if Token
= Tok_Access
then
1512 Set_Null_Exclusion_Present
1513 (Specification_Node
, Not_Null_Present
);
1515 if Ada_Version
= Ada_83
then
1516 Error_Msg_SC
("(Ada 83) access parameters not allowed");
1520 (Specification_Node
,
1521 P_Access_Definition
(Not_Null_Present
));
1523 -- Case of IN or OUT present
1526 if Token
in Tok_In | Tok_Out
then
1527 if Not_Null_Present
then
1529 ("`NOT NULL` can only be used with `ACCESS`",
1532 if Token
= Tok_In
then
1534 ("\`IN` not allowed together with `ACCESS`",
1538 ("\`OUT` not allowed together with `ACCESS`",
1543 P_Mode
(Specification_Node
);
1544 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1547 Set_Null_Exclusion_Present
1548 (Specification_Node
, Not_Null_Present
);
1550 if Token
= Tok_Procedure
1552 Token
= Tok_Function
1554 Error_Msg_SC
("formal subprogram parameter not allowed");
1557 if Token
= Tok_Left_Paren
then
1558 Discard_Junk_List
(P_Formal_Part
);
1561 if Token
= Tok_Return
then
1563 Discard_Junk_Node
(P_Subtype_Mark
);
1566 Set_Parameter_Type
(Specification_Node
, Error
);
1569 Set_Parameter_Type
(Specification_Node
, P_Subtype_Mark
);
1574 Set_Expression
(Specification_Node
, Init_Expr_Opt
(True));
1577 Set_Prev_Ids
(Specification_Node
, True);
1580 if Ident
< Num_Idents
then
1581 Set_More_Ids
(Specification_Node
, True);
1584 Append
(Specification_Node
, Specification_List
);
1585 exit Ident_List_Loop
when Ident
= Num_Idents
;
1587 Restore_Scan_State
(Scan_State
);
1588 end loop Ident_List_Loop
;
1591 when Error_Resync
=>
1592 Resync_Semicolon_List
;
1595 if Token
= Tok_Semicolon
then
1596 Save_Scan_State
(Scan_State
);
1597 Scan
; -- past semicolon
1599 -- If we have RETURN or IS after the semicolon, then assume
1600 -- that semicolon should have been a right parenthesis and exit
1602 if Token
in Tok_Is | Tok_Return
then
1603 Error_Msg_SP
-- CODEFIX
1604 ("|"";"" should be "")""");
1605 exit Specification_Loop
;
1608 -- If we have a declaration keyword after the semicolon, then
1609 -- assume we had a missing right parenthesis and terminate list
1611 if Token
in Token_Class_Declk
then
1612 Error_Msg_AP
-- CODEFIX
1614 Restore_Scan_State
(Scan_State
);
1615 exit Specification_Loop
;
1618 elsif Token
= Tok_Right_Paren
then
1619 Scan
; -- past right paren
1620 exit Specification_Loop
;
1622 -- Support for aspects on formal parameters is a GNAT extension for
1625 elsif Token
= Tok_With
then
1626 Error_Msg_Ada_2022_Feature
1627 ("aspect on formal parameter", Token_Ptr
);
1629 P_Aspect_Specifications
(Specification_Node
, False);
1631 -- Set the aspect specifications for previous Ids
1633 if Has_Aspects
(Specification_Node
)
1634 and then Prev_Ids
(Specification_Node
)
1636 -- Loop through each previous id
1639 Prev_Id
: Node_Id
:= Prev
(Specification_Node
);
1642 Set_Aspect_Specifications
1643 (Prev_Id
, Aspect_Specifications
(Specification_Node
));
1645 -- Exit when we reach the first parameter in the list
1647 exit when not Prev_Ids
(Prev_Id
);
1648 Prev_Id
:= Prev
(Prev_Id
);
1653 if Token
= Tok_Right_Paren
then
1654 Scan
; -- past right paren
1655 exit Specification_Loop
;
1657 elsif Token
= Tok_Semicolon
then
1658 Save_Scan_State
(Scan_State
);
1659 Scan
; -- past semicolon
1662 -- Special check for common error of using comma instead of semicolon
1664 elsif Token
= Tok_Comma
then
1667 -- Special check for omitted separator
1669 elsif Token
= Tok_Identifier
then
1672 -- If nothing sensible, skip to next semicolon or right paren
1676 Resync_Semicolon_List
;
1678 if Token
= Tok_Semicolon
then
1679 Scan
; -- past semicolon
1682 exit Specification_Loop
;
1685 end loop Specification_Loop
;
1687 return Specification_List
;
1690 ----------------------------------
1691 -- 6.1 Parameter Specification --
1692 ----------------------------------
1694 -- Parsed by P_Formal_Part (6.1)
1700 -- MODE ::= [in] | in out | out
1702 -- There is no explicit node in the tree for the Mode. Instead the
1703 -- In_Present and Out_Present flags are set in the parent node to
1704 -- record the presence of keywords specifying the mode.
1706 -- Error_Recovery: cannot raise Error_Resync
1708 procedure P_Mode
(Node
: Node_Id
) is
1710 if Token
= Tok_In
then
1712 Set_In_Present
(Node
, True);
1714 if Style
.Mode_In_Check
and then Token
/= Tok_Out
then
1715 Error_Msg_SP
-- CODEFIX
1716 ("(style) IN should be omitted?I?");
1719 -- Since Ada 2005, formal objects can have an anonymous access type,
1720 -- and of course carry a mode indicator.
1722 if Token
= Tok_Access
1723 and then Nkind
(Node
) /= N_Formal_Object_Declaration
1725 Error_Msg_SP
("IN not allowed together with ACCESS");
1726 Scan
; -- past ACCESS
1730 if Token
= Tok_Out
then
1732 Set_Out_Present
(Node
, True);
1735 if Token
= Tok_In
then
1736 Error_Msg_SC
("IN must precede OUT in parameter mode");
1738 Set_In_Present
(Node
, True);
1742 --------------------------
1743 -- 6.3 Subprogram Body --
1744 --------------------------
1746 -- Parsed by P_Subprogram (6.1)
1748 -----------------------------------
1749 -- 6.4 Procedure Call Statement --
1750 -----------------------------------
1752 -- Parsed by P_Sequence_Of_Statements (5.1)
1754 ------------------------
1755 -- 6.4 Function Call --
1756 ------------------------
1758 -- Parsed by P_Name (4.1)
1760 --------------------------------
1761 -- 6.4 Actual Parameter Part --
1762 --------------------------------
1764 -- Parsed by P_Name (4.1)
1766 --------------------------------
1767 -- 6.4 Parameter Association --
1768 --------------------------------
1770 -- Parsed by P_Name (4.1)
1772 ------------------------------------
1773 -- 6.4 Explicit Actual Parameter --
1774 ------------------------------------
1776 -- Parsed by P_Name (4.1)
1778 ---------------------------
1779 -- 6.5 Return Statement --
1780 ---------------------------
1782 -- SIMPLE_RETURN_STATEMENT ::= return [EXPRESSION];
1784 -- EXTENDED_RETURN_STATEMENT ::=
1785 -- return DEFINING_IDENTIFIER : [aliased] RETURN_SUBTYPE_INDICATION
1787 -- [ASPECT_SPECIFICATION] [do
1788 -- HANDLED_SEQUENCE_OF_STATEMENTS
1791 -- RETURN_SUBTYPE_INDICATION ::= SUBTYPE_INDICATION | ACCESS_DEFINITION
1793 -- RETURN_STATEMENT ::= return [EXPRESSION];
1795 -- Error recovery: can raise Error_Resync
1797 procedure P_Return_Subtype_Indication
(Decl_Node
: Node_Id
) is
1799 -- Note: We don't need to check Ada_Version here, because this is
1800 -- only called in >= Ada 2005 cases anyway.
1802 Not_Null_Present
: constant Boolean := P_Null_Exclusion
;
1805 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1807 if Token
= Tok_Access
then
1808 Set_Object_Definition
1809 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1811 Set_Object_Definition
1812 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1814 end P_Return_Subtype_Indication
;
1816 -- Error recovery: can raise Error_Resync
1818 function P_Return_Object_Declaration
return Node_Id
is
1819 Return_Obj
: Node_Id
;
1820 Decl_Node
: Node_Id
;
1823 Return_Obj
:= Token_Node
;
1824 Change_Identifier_To_Defining_Identifier
(Return_Obj
);
1825 Warn_If_Standard_Redefinition
(Return_Obj
);
1826 Decl_Node
:= New_Node
(N_Object_Declaration
, Token_Ptr
);
1827 Set_Defining_Identifier
(Decl_Node
, Return_Obj
);
1829 Scan
; -- past identifier
1832 -- First an error check, if we have two identifiers in a row, a likely
1833 -- possibility is that the first of the identifiers is an incorrectly
1834 -- spelled keyword. See similar check in P_Identifier_Declarations.
1836 if Token
= Tok_Identifier
then
1838 SS
: Saved_Scan_State
;
1842 Save_Scan_State
(SS
);
1843 Scan
; -- past initial identifier
1844 I2
:= (Token
= Tok_Identifier
);
1845 Restore_Scan_State
(SS
);
1849 (Bad_Spelling_Of
(Tok_Access
) or else
1850 Bad_Spelling_Of
(Tok_Aliased
) or else
1851 Bad_Spelling_Of
(Tok_Constant
))
1858 -- We allow "constant" here (as in "return Result : constant
1859 -- T..."). This is not in the latest RM, but the ARG is considering an
1860 -- AI on the subject (see AI05-0015-1), which we expect to be approved.
1862 if Token
= Tok_Constant
then
1863 Scan
; -- past CONSTANT
1864 Set_Constant_Present
(Decl_Node
);
1866 if Token
= Tok_Aliased
then
1867 Error_Msg_SC
-- CODEFIX
1868 ("ALIASED should be before CONSTANT");
1869 Scan
; -- past ALIASED
1870 Set_Aliased_Present
(Decl_Node
);
1873 elsif Token
= Tok_Aliased
then
1874 Scan
; -- past ALIASED
1875 Set_Aliased_Present
(Decl_Node
);
1877 -- The restrictions on the use of aliased in an extended return
1878 -- are semantic, not syntactic.
1880 if Token
= Tok_Constant
then
1881 Scan
; -- past CONSTANT
1882 Set_Constant_Present
(Decl_Node
);
1886 P_Return_Subtype_Indication
(Decl_Node
);
1888 if Token
= Tok_Colon_Equal
then
1890 Set_Expression
(Decl_Node
, P_Expression_No_Right_Paren
);
1891 Set_Has_Init_Expression
(Decl_Node
);
1895 end P_Return_Object_Declaration
;
1897 -- Error recovery: can raise Error_Resync
1899 function P_Return_Statement
return Node_Id
is
1900 -- The caller has checked that the initial token is RETURN
1902 function Is_Extended
return Boolean;
1903 -- Scan state is just after RETURN (and is left that way). Determine
1904 -- whether this is a simple or extended return statement by looking
1905 -- ahead for "identifier :", which implies extended.
1911 function Is_Extended
return Boolean is
1912 Scan_State
: Saved_Scan_State
;
1913 Is_Extended
: Boolean := False;
1917 if Token
= Tok_Identifier
then
1918 Save_Scan_State
(Scan_State
); -- at identifier
1919 Scan
; -- past identifier
1921 if Token
= Tok_Colon
then
1922 Is_Extended
:= True;
1925 Restore_Scan_State
(Scan_State
); -- to identifier
1931 Ret_Sloc
: constant Source_Ptr
:= Token_Ptr
;
1932 Ret_Strt
: constant Column_Number
:= Start_Column
;
1936 -- Start of processing for P_Return_Statement
1939 Scan
; -- past RETURN
1941 -- Simple_return_statement, no expression, return an
1942 -- N_Simple_Return_Statement node with the expression field left Empty.
1944 if Token
= Tok_Semicolon
then
1946 Ret_Node
:= New_Node
(N_Simple_Return_Statement
, Ret_Sloc
);
1951 -- Extended_return_statement (Ada 2005 only -- AI-318):
1954 Error_Msg_Ada_2005_Extension
("extended return statement");
1956 Ret_Node
:= New_Node
(N_Extended_Return_Statement
, Ret_Sloc
);
1957 Decl
:= P_Return_Object_Declaration
;
1958 Set_Return_Object_Declarations
(Ret_Node
, New_List
(Decl
));
1960 if Token
= Tok_With
then
1961 P_Aspect_Specifications
(Decl
, False);
1964 if Token
= Tok_Do
then
1966 Scopes
(Scope
.Last
).Ecol
:= Ret_Strt
;
1967 Scopes
(Scope
.Last
).Etyp
:= E_Return
;
1968 Scopes
(Scope
.Last
).Labl
:= Error
;
1969 Scopes
(Scope
.Last
).Sloc
:= Ret_Sloc
;
1971 Set_Handled_Statement_Sequence
1972 (Ret_Node
, P_Handled_Sequence_Of_Statements
);
1975 -- Do we need to handle Error_Resync here???
1978 -- Simple_return_statement or Return_when_Statement
1981 -- We avoid trying to scan an expression if we are at an
1982 -- expression terminator since in that case the best error
1983 -- message is probably that we have a missing semicolon.
1986 Ret_Node
:= New_Node
(N_Simple_Return_Statement
, Ret_Sloc
);
1988 if Token
not in Token_Class_Eterm
then
1989 Set_Expression
(Ret_Node
, P_Expression_No_Right_Paren
);
1992 -- When the next token is WHEN or IF we know that we are looking
1993 -- at a Return_when_statement
1995 if Token
= Tok_When
and then not Missing_Semicolon_On_When
then
1996 Error_Msg_GNAT_Extension
("return when statement", Token_Ptr
);
1997 Mutate_Nkind
(Ret_Node
, N_Return_When_Statement
);
2000 Set_Condition
(Ret_Node
, P_Condition
);
2002 -- Allow IF instead of WHEN, giving error message
2004 elsif Token
= Tok_If
then
2005 Error_Msg_GNAT_Extension
("return when statement", Token_Ptr
);
2006 Mutate_Nkind
(Ret_Node
, N_Return_When_Statement
);
2009 Scan
; -- past IF used in place of WHEN
2010 Set_Condition
(Ret_Node
, P_Condition
);
2018 end P_Return_Statement
;