1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 pragma Style_Checks
(All_Checks
);
30 -- Turn off subprogram body ordering check. Subprograms are in order
31 -- by RM section rather than alphabetical
33 with Sinfo
.CN
; use Sinfo
.CN
;
38 -- Local subprograms, used only in this chapter
40 function P_Defining_Designator
return Node_Id
;
41 function P_Defining_Operator_Symbol
return Node_Id
;
43 procedure Check_Junk_Semicolon_Before_Return
;
44 -- Check for common error of junk semicolon before RETURN keyword of
45 -- function specification. If present, skip over it with appropriate
46 -- error message, leaving Scan_Ptr pointing to the RETURN after. This
47 -- routine also deals with a possibly misspelled version of Return.
49 ----------------------------------------
50 -- Check_Junk_Semicolon_Before_Return --
51 ----------------------------------------
53 procedure Check_Junk_Semicolon_Before_Return
is
54 Scan_State
: Saved_Scan_State
;
57 if Token
= Tok_Semicolon
then
58 Save_Scan_State
(Scan_State
);
59 Scan
; -- past the semicolon
61 if Token
= Tok_Return
then
62 Restore_Scan_State
(Scan_State
);
63 Error_Msg_SC
("Unexpected semicolon ignored");
64 Scan
; -- rescan past junk semicolon
67 Restore_Scan_State
(Scan_State
);
70 elsif Bad_Spelling_Of
(Tok_Return
) then
73 end Check_Junk_Semicolon_Before_Return
;
75 -----------------------------------------------------
76 -- 6.1 Subprogram (Also 6.3, 8.5.4, 10.1.3, 12.3) --
77 -----------------------------------------------------
79 -- This routine scans out a subprogram declaration, subprogram body,
80 -- subprogram renaming declaration or subprogram generic instantiation.
82 -- SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION;
84 -- ABSTRACT_SUBPROGRAM_DECLARATION ::=
85 -- SUBPROGRAM_SPECIFICATION is abstract;
87 -- SUBPROGRAM_SPECIFICATION ::=
88 -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
89 -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
91 -- PARAMETER_PROFILE ::= [FORMAL_PART]
93 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
95 -- SUBPROGRAM_BODY ::=
96 -- SUBPROGRAM_SPECIFICATION is
99 -- HANDLED_SEQUENCE_OF_STATEMENTS
102 -- SUBPROGRAM_RENAMING_DECLARATION ::=
103 -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME;
105 -- SUBPROGRAM_BODY_STUB ::=
106 -- SUBPROGRAM_SPECIFICATION is separate;
108 -- GENERIC_INSTANTIATION ::=
109 -- procedure DEFINING_PROGRAM_UNIT_NAME is
110 -- new generic_procedure_NAME [GENERIC_ACTUAL_PART];
111 -- | function DEFINING_DESIGNATOR is
112 -- new generic_function_NAME [GENERIC_ACTUAL_PART];
114 -- The value in Pf_Flags indicates which of these possible declarations
115 -- is acceptable to the caller:
117 -- Pf_Flags.Decl Set if declaration OK
118 -- Pf_Flags.Gins Set if generic instantiation OK
119 -- Pf_Flags.Pbod Set if proper body OK
120 -- Pf_Flags.Rnam Set if renaming declaration OK
121 -- Pf_Flags.Stub Set if body stub OK
123 -- If an inappropriate form is encountered, it is scanned out but an
124 -- error message indicating that it is appearing in an inappropriate
125 -- context is issued. The only possible values for Pf_Flags are those
126 -- defined as constants in the Par package.
128 -- The caller has checked that the initial token is FUNCTION or PROCEDURE
130 -- Error recovery: cannot raise Error_Resync
132 function P_Subprogram
(Pf_Flags
: Pf_Rec
) return Node_Id
is
133 Specification_Node
: Node_Id
;
135 Fpart_List
: List_Id
;
136 Fpart_Sloc
: Source_Ptr
;
137 Return_Node
: Node_Id
;
141 Rename_Node
: Node_Id
;
142 Absdec_Node
: Node_Id
;
144 Fproc_Sloc
: Source_Ptr
;
146 Scan_State
: Saved_Scan_State
;
149 -- Set up scope stack entry. Note that the Labl field will be set later
151 SIS_Entry_Active
:= False;
152 SIS_Missing_Semicolon_Message
:= No_Error_Msg
;
154 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
155 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
156 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
157 Scope
.Table
(Scope
.Last
).Lreq
:= False;
159 Func
:= (Token
= Tok_Function
);
160 Fproc_Sloc
:= Token_Ptr
;
161 Scan
; -- past FUNCTION or PROCEDURE
166 Name_Node
:= P_Defining_Designator
;
168 if Nkind
(Name_Node
) = N_Defining_Operator_Symbol
169 and then Scope
.Last
= 1
171 Error_Msg_SP
("operator symbol not allowed at library level");
172 Name_Node
:= New_Entity
(N_Defining_Identifier
, Sloc
(Name_Node
));
174 -- Set name from file name, we need some junk name, and that's
175 -- as good as anything. This is only approximate, since we do
176 -- not do anything with non-standard name translations.
178 Get_Name_String
(File_Name
(Current_Source_File
));
180 for J
in 1 .. Name_Len
loop
181 if Name_Buffer
(J
) = '.' then
187 Set_Chars
(Name_Node
, Name_Find
);
188 Set_Error_Posted
(Name_Node
);
192 Name_Node
:= P_Defining_Program_Unit_Name
;
195 Scope
.Table
(Scope
.Last
).Labl
:= Name_Node
;
197 if Token
= Tok_Colon
then
198 Error_Msg_SC
("redundant colon ignored");
202 -- Deal with generic instantiation, the one case in which we do not
203 -- have a subprogram specification as part of whatever we are parsing
205 if Token
= Tok_Is
then
206 Save_Scan_State
(Scan_State
); -- at the IS
207 T_Is
; -- checks for redundant IS's
209 if Token
= Tok_New
then
210 if not Pf_Flags
.Gins
then
211 Error_Msg_SC
("generic instantation not allowed here!");
217 Inst_Node
:= New_Node
(N_Function_Instantiation
, Fproc_Sloc
);
218 Set_Name
(Inst_Node
, P_Function_Name
);
220 Inst_Node
:= New_Node
(N_Procedure_Instantiation
, Fproc_Sloc
);
221 Set_Name
(Inst_Node
, P_Qualified_Simple_Name
);
224 Set_Defining_Unit_Name
(Inst_Node
, Name_Node
);
225 Set_Generic_Associations
(Inst_Node
, P_Generic_Actual_Part_Opt
);
227 Pop_Scope_Stack
; -- Don't need scope stack entry in this case
231 Restore_Scan_State
(Scan_State
); -- to the IS
235 -- If not a generic instantiation, then we definitely have a subprogram
236 -- specification (all possibilities at this stage include one here)
238 Fpart_Sloc
:= Token_Ptr
;
240 Check_Misspelling_Of
(Tok_Return
);
242 -- Scan formal part. First a special error check. If we have an
243 -- identifier here, then we have a definite error. If this identifier
244 -- is on the same line as the designator, then we assume it is the
245 -- first formal after a missing left parenthesis
247 if Token
= Tok_Identifier
248 and then not Token_Is_At_Start_Of_Line
250 T_Left_Paren
; -- to generate message
251 Fpart_List
:= P_Formal_Part
;
253 -- Otherwise scan out an optional formal part in the usual manner
256 Fpart_List
:= P_Parameter_Profile
;
259 -- We treat what we have as a function specification if FUNCTION was
260 -- used, or if a RETURN is present. This gives better error recovery
261 -- since later RETURN statements will be valid in either case.
263 Check_Junk_Semicolon_Before_Return
;
264 Return_Node
:= Error
;
266 if Token
= Tok_Return
then
268 Error_Msg
("PROCEDURE should be FUNCTION", Fproc_Sloc
);
273 Return_Node
:= P_Subtype_Mark
;
278 Ignore
(Tok_Right_Paren
);
284 Specification_Node
:=
285 New_Node
(N_Function_Specification
, Fproc_Sloc
);
286 Set_Subtype_Mark
(Specification_Node
, Return_Node
);
289 Specification_Node
:=
290 New_Node
(N_Procedure_Specification
, Fproc_Sloc
);
293 Set_Defining_Unit_Name
(Specification_Node
, Name_Node
);
294 Set_Parameter_Specifications
(Specification_Node
, Fpart_List
);
296 -- Error check: barriers not allowed on protected functions/procedures
298 if Token
= Tok_When
then
300 Error_Msg_SC
("barrier not allowed on function, only on entry");
302 Error_Msg_SC
("barrier not allowed on procedure, only on entry");
306 Discard_Junk_Node
(P_Expression
);
309 -- Deal with case of semicolon ending a subprogram declaration
311 if Token
= Tok_Semicolon
then
312 if not Pf_Flags
.Decl
then
316 Scan
; -- past semicolon
318 -- If semicolon is immediately followed by IS, then ignore the
319 -- semicolon, and go process the body.
321 if Token
= Tok_Is
then
322 Error_Msg_SP
("unexpected semicolon ignored");
323 T_Is
; -- ignroe redundant IS's
324 goto Subprogram_Body
;
326 -- If BEGIN follows in an appropriate column, we immediately
327 -- commence the error action of assuming that the previous
328 -- subprogram declaration should have been a subprogram body,
329 -- i.e. that the terminating semicolon should have been IS.
331 elsif Token
= Tok_Begin
332 and then Start_Column
>= Scope
.Table
(Scope
.Last
).Ecol
334 Error_Msg_SP
(""";"" should be IS!");
335 goto Subprogram_Body
;
338 goto Subprogram_Declaration
;
341 -- Case of not followed by semicolon
344 -- Subprogram renaming declaration case
346 Check_Misspelling_Of
(Tok_Renames
);
348 if Token
= Tok_Renames
then
349 if not Pf_Flags
.Rnam
then
350 Error_Msg_SC
("renaming declaration not allowed here!");
354 New_Node
(N_Subprogram_Renaming_Declaration
, Token_Ptr
);
355 Scan
; -- past RENAMES
356 Set_Name
(Rename_Node
, P_Name
);
357 Set_Specification
(Rename_Node
, Specification_Node
);
362 -- Case of IS following subprogram specification
364 elsif Token
= Tok_Is
then
365 T_Is
; -- ignore redundant Is's
367 if Token_Name
= Name_Abstract
then
368 Check_95_Keyword
(Tok_Abstract
, Tok_Semicolon
);
371 -- Deal nicely with (now obsolete) use of <> in place of abstract
373 if Token
= Tok_Box
then
374 Error_Msg_SC
("ABSTRACT expected");
375 Token
:= Tok_Abstract
;
378 -- Abstract subprogram declaration case
380 if Token
= Tok_Abstract
then
382 New_Node
(N_Abstract_Subprogram_Declaration
, Token_Ptr
);
383 Set_Specification
(Absdec_Node
, Specification_Node
);
384 Pop_Scope_Stack
; -- discard unneeded entry
385 Scan
; -- past ABSTRACT
389 -- Check for IS NEW with Formal_Part present and handle nicely
391 elsif Token
= Tok_New
then
393 ("formal part not allowed in instantiation", Fpart_Sloc
);
397 Inst_Node
:= New_Node
(N_Function_Instantiation
, Fproc_Sloc
);
400 New_Node
(N_Procedure_Instantiation
, Fproc_Sloc
);
403 Set_Defining_Unit_Name
(Inst_Node
, Name_Node
);
404 Set_Name
(Inst_Node
, P_Name
);
405 Set_Generic_Associations
(Inst_Node
, P_Generic_Actual_Part_Opt
);
407 Pop_Scope_Stack
; -- Don't need scope stack entry in this case
411 goto Subprogram_Body
;
414 -- Here we have a missing IS or missing semicolon, we always guess
415 -- a missing semicolon, since we are pretty good at fixing up a
416 -- semicolon which should really be an IS
419 Error_Msg_AP
("missing "";""");
420 SIS_Missing_Semicolon_Message
:= Get_Msg_Id
;
421 goto Subprogram_Declaration
;
425 -- Processing for subprogram body
428 if not Pf_Flags
.Pbod
then
429 Error_Msg_SP
("subprogram body not allowed here!");
432 -- Subprogram body stub case
434 if Separate_Present
then
435 if not Pf_Flags
.Stub
then
436 Error_Msg_SC
("body stub not allowed here!");
439 if Nkind
(Name_Node
) = N_Defining_Operator_Symbol
then
441 ("operator symbol cannot be used as subunit name",
446 New_Node
(N_Subprogram_Body_Stub
, Sloc
(Specification_Node
));
447 Set_Specification
(Stub_Node
, Specification_Node
);
448 Scan
; -- past SEPARATE
453 -- Subprogram body case
456 -- Here is the test for a suspicious IS (i.e. one that looks
457 -- like it might more properly be a semicolon). See separate
458 -- section discussing use of IS instead of semicolon in
461 if (Token
in Token_Class_Declk
463 Token
= Tok_Identifier
)
464 and then Start_Column
<= Scope
.Table
(Scope
.Last
).Ecol
465 and then Scope
.Last
/= 1
467 Scope
.Table
(Scope
.Last
).Etyp
:= E_Suspicious_Is
;
468 Scope
.Table
(Scope
.Last
).S_Is
:= Prev_Token_Ptr
;
472 New_Node
(N_Subprogram_Body
, Sloc
(Specification_Node
));
473 Set_Specification
(Body_Node
, Specification_Node
);
474 Parse_Decls_Begin_End
(Body_Node
);
478 -- Processing for subprogram declaration
480 <<Subprogram_Declaration
>>
482 New_Node
(N_Subprogram_Declaration
, Sloc
(Specification_Node
));
483 Set_Specification
(Decl_Node
, Specification_Node
);
485 -- If this is a context in which a subprogram body is permitted,
486 -- set active SIS entry in case (see section titled "Handling
487 -- Semicolon Used in Place of IS" in body of Parser package)
488 -- Note that SIS_Missing_Semicolon_Message is already set properly.
490 if Pf_Flags
.Pbod
then
491 SIS_Labl
:= Scope
.Table
(Scope
.Last
).Labl
;
492 SIS_Sloc
:= Scope
.Table
(Scope
.Last
).Sloc
;
493 SIS_Ecol
:= Scope
.Table
(Scope
.Last
).Ecol
;
494 SIS_Declaration_Node
:= Decl_Node
;
495 SIS_Semicolon_Sloc
:= Prev_Token_Ptr
;
496 SIS_Entry_Active
:= True;
504 ---------------------------------
505 -- 6.1 Subprogram Declaration --
506 ---------------------------------
508 -- Parsed by P_Subprogram (6.1)
510 ------------------------------------------
511 -- 6.1 Abstract Subprogram Declaration --
512 ------------------------------------------
514 -- Parsed by P_Subprogram (6.1)
516 -----------------------------------
517 -- 6.1 Subprogram Specification --
518 -----------------------------------
520 -- SUBPROGRAM_SPECIFICATION ::=
521 -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
522 -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
524 -- PARAMETER_PROFILE ::= [FORMAL_PART]
526 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
528 -- Subprogram specifications that appear in subprogram declarations
529 -- are parsed by P_Subprogram (6.1). This routine is used in other
530 -- contexts where subprogram specifications occur.
532 -- Note: this routine does not affect the scope stack in any way
534 -- Error recovery: can raise Error_Resync
536 function P_Subprogram_Specification
return Node_Id
is
537 Specification_Node
: Node_Id
;
540 if Token
= Tok_Function
then
541 Specification_Node
:= New_Node
(N_Function_Specification
, Token_Ptr
);
542 Scan
; -- past FUNCTION
544 Set_Defining_Unit_Name
(Specification_Node
, P_Defining_Designator
);
545 Set_Parameter_Specifications
546 (Specification_Node
, P_Parameter_Profile
);
547 Check_Junk_Semicolon_Before_Return
;
549 Set_Subtype_Mark
(Specification_Node
, P_Subtype_Mark
);
551 return Specification_Node
;
553 elsif Token
= Tok_Procedure
then
554 Specification_Node
:= New_Node
(N_Procedure_Specification
, Token_Ptr
);
555 Scan
; -- past PROCEDURE
557 Set_Defining_Unit_Name
558 (Specification_Node
, P_Defining_Program_Unit_Name
);
559 Set_Parameter_Specifications
560 (Specification_Node
, P_Parameter_Profile
);
561 return Specification_Node
;
564 Error_Msg_SC
("subprogram specification expected");
567 end P_Subprogram_Specification
;
569 ---------------------
571 ---------------------
574 -- [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL
576 -- The caller has checked that the initial token is an identifier,
577 -- operator symbol, or string literal. Note that we don't bother to
578 -- do much error diagnosis in this routine, since it is only used for
579 -- the label on END lines, and the routines in package Par.Endh will
580 -- check that the label is appropriate.
582 -- Error recovery: cannot raise Error_Resync
584 function P_Designator
return Node_Id
is
585 Ident_Node
: Node_Id
;
587 Prefix_Node
: Node_Id
;
589 function Real_Dot
return Boolean;
590 -- Tests if a current token is an interesting period, i.e. is followed
591 -- by an identifier or operator symbol or string literal. If not, it is
592 -- probably just incorrect punctuation to be caught by our caller. Note
593 -- that the case of an operator symbol or string literal is also an
594 -- error, but that is an error that we catch here. If the result is
595 -- True, a real dot has been scanned and we are positioned past it,
596 -- if the result is False, the scan position is unchanged.
598 function Real_Dot
return Boolean is
599 Scan_State
: Saved_Scan_State
;
602 if Token
/= Tok_Dot
then
606 Save_Scan_State
(Scan_State
);
609 if Token
= Tok_Identifier
610 or else Token
= Tok_Operator_Symbol
611 or else Token
= Tok_String_Literal
616 Restore_Scan_State
(Scan_State
);
622 -- Start of processing for P_Designator
625 Ident_Node
:= Token_Node
;
626 Scan
; -- past initial token
628 if Prev_Token
= Tok_Operator_Symbol
629 or else Prev_Token
= Tok_String_Literal
637 Prefix_Node
:= Ident_Node
;
639 -- Loop through child names, on entry to this loop, Prefix contains
640 -- the name scanned so far, and Ident_Node is the last identifier.
643 Name_Node
:= New_Node
(N_Selected_Component
, Prev_Token_Ptr
);
644 Set_Prefix
(Name_Node
, Prefix_Node
);
645 Ident_Node
:= P_Identifier
;
646 Set_Selector_Name
(Name_Node
, Ident_Node
);
647 Prefix_Node
:= Name_Node
;
648 exit when not Real_Dot
;
651 -- On exit from the loop, Ident_Node is the last identifier scanned,
652 -- i.e. the defining identifier, and Prefix_Node is a node for the
653 -- entire name, structured (incorrectly!) as a selected component.
655 Name_Node
:= Prefix
(Prefix_Node
);
656 Change_Node
(Prefix_Node
, N_Designator
);
657 Set_Name
(Prefix_Node
, Name_Node
);
658 Set_Identifier
(Prefix_Node
, Ident_Node
);
664 while Token
= Tok_Dot
or else Token
= Tok_Identifier
loop
671 ------------------------------
672 -- 6.1 Defining Designator --
673 ------------------------------
675 -- DEFINING_DESIGNATOR ::=
676 -- DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL
678 -- Error recovery: cannot raise Error_Resync
680 function P_Defining_Designator
return Node_Id
is
682 if Token
= Tok_Operator_Symbol
then
683 return P_Defining_Operator_Symbol
;
685 elsif Token
= Tok_String_Literal
then
686 Error_Msg_SC
("invalid operator name");
687 Scan
; -- past junk string
691 return P_Defining_Program_Unit_Name
;
693 end P_Defining_Designator
;
695 -------------------------------------
696 -- 6.1 Defining Program Unit Name --
697 -------------------------------------
699 -- DEFINING_PROGRAM_UNIT_NAME ::=
700 -- [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER
702 -- Note: PARENT_UNIT_NAME may be present only in 95 mode at the outer level
704 -- Error recovery: cannot raise Error_Resync
706 function P_Defining_Program_Unit_Name
return Node_Id
is
707 Ident_Node
: Node_Id
;
709 Prefix_Node
: Node_Id
;
712 -- Set identifier casing if not already set and scan initial identifier
714 if Token
= Tok_Identifier
715 and then Identifier_Casing
(Current_Source_File
) = Unknown
717 Set_Identifier_Casing
(Current_Source_File
, Determine_Token_Casing
);
720 Ident_Node
:= P_Identifier
;
721 Merge_Identifier
(Ident_Node
, Tok_Return
);
723 -- Normal case (not child library unit name)
725 if Token
/= Tok_Dot
then
726 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
729 -- Child library unit name case
732 if Scope
.Last
> 1 then
733 Error_Msg_SP
("child unit allowed only at library level");
737 Error_Msg_SP
("(Ada 83) child unit not allowed!");
741 Prefix_Node
:= Ident_Node
;
743 -- Loop through child names, on entry to this loop, Prefix contains
744 -- the name scanned so far, and Ident_Node is the last identifier.
747 exit when Token
/= Tok_Dot
;
748 Name_Node
:= New_Node
(N_Selected_Component
, Token_Ptr
);
750 Set_Prefix
(Name_Node
, Prefix_Node
);
751 Ident_Node
:= P_Identifier
;
752 Set_Selector_Name
(Name_Node
, Ident_Node
);
753 Prefix_Node
:= Name_Node
;
756 -- On exit from the loop, Ident_Node is the last identifier scanned,
757 -- i.e. the defining identifier, and Prefix_Node is a node for the
758 -- entire name, structured (incorrectly!) as a selected component.
760 Name_Node
:= Prefix
(Prefix_Node
);
761 Change_Node
(Prefix_Node
, N_Defining_Program_Unit_Name
);
762 Set_Name
(Prefix_Node
, Name_Node
);
763 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
764 Set_Defining_Identifier
(Prefix_Node
, Ident_Node
);
766 -- All set with unit name parsed
773 while Token
= Tok_Dot
or else Token
= Tok_Identifier
loop
778 end P_Defining_Program_Unit_Name
;
780 --------------------------
781 -- 6.1 Operator Symbol --
782 --------------------------
784 -- OPERATOR_SYMBOL ::= STRING_LITERAL
786 -- Operator symbol is returned by the scanner as Tok_Operator_Symbol
788 -----------------------------------
789 -- 6.1 Defining Operator Symbol --
790 -----------------------------------
792 -- DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL
794 -- The caller has checked that the initial symbol is an operator symbol
796 function P_Defining_Operator_Symbol
return Node_Id
is
800 Op_Node
:= Token_Node
;
801 Change_Operator_Symbol_To_Defining_Operator_Symbol
(Op_Node
);
802 Scan
; -- past operator symbol
804 end P_Defining_Operator_Symbol
;
806 ----------------------------
807 -- 6.1 Parameter_Profile --
808 ----------------------------
810 -- PARAMETER_PROFILE ::= [FORMAL_PART]
812 -- Empty is returned if no formal part is present
814 -- Error recovery: cannot raise Error_Resync
816 function P_Parameter_Profile
return List_Id
is
818 if Token
= Tok_Left_Paren
then
819 Scan
; -- part left paren
820 return P_Formal_Part
;
824 end P_Parameter_Profile
;
826 ---------------------------------------
827 -- 6.1 Parameter And Result Profile --
828 ---------------------------------------
830 -- Parsed by its parent construct, which uses P_Parameter_Profile to
831 -- parse the parameters, and P_Subtype_Mark to parse the return type.
833 ----------------------
834 -- 6.1 Formal part --
835 ----------------------
837 -- FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION})
839 -- PARAMETER_SPECIFICATION ::=
840 -- DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK
841 -- [:= DEFAULT_EXPRESSION]
842 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
843 -- [:= DEFAULT_EXPRESSION]
845 -- This scans the construct Formal_Part. The caller has already checked
846 -- that the initial token is a left parenthesis, and skipped past it, so
847 -- that on entry Token is the first token following the left parenthesis.
849 -- Error recovery: cannot raise Error_Resync
851 function P_Formal_Part
return List_Id
is
852 Specification_List
: List_Id
;
853 Specification_Node
: Node_Id
;
854 Scan_State
: Saved_Scan_State
;
857 Ident_Sloc
: Source_Ptr
;
859 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
860 -- This array holds the list of defining identifiers. The upper bound
861 -- of 4096 is intended to be essentially infinite, and we do not even
862 -- bother to check for it being exceeded.
865 Specification_List
:= New_List
;
867 Specification_Loop
: loop
869 if Token
= Tok_Pragma
then
873 Ignore
(Tok_Left_Paren
);
874 Ident_Sloc
:= Token_Ptr
;
875 Idents
(1) := P_Defining_Identifier
;
879 exit Ident_Loop
when Token
= Tok_Colon
;
881 -- The only valid tokens are colon and comma, so if we have
882 -- neither do a bit of investigation to see which is the
883 -- better choice for insertion.
885 if Token
/= Tok_Comma
then
887 -- Assume colon if IN or OUT keyword found
889 exit Ident_Loop
when Token
= Tok_In
or else Token
= Tok_Out
;
891 -- Otherwise scan ahead
893 Save_Scan_State
(Scan_State
);
896 -- If we run into a semicolon, then assume that a
897 -- colon was missing, e.g. Parms (X Y; ...). Also
898 -- assume missing colon on EOF (a real disaster!)
899 -- and on a right paren, e.g. Parms (X Y), and also
900 -- on an assignment symbol, e.g. Parms (X Y := ..)
902 if Token
= Tok_Semicolon
903 or else Token
= Tok_Right_Paren
904 or else Token
= Tok_EOF
905 or else Token
= Tok_Colon_Equal
907 Restore_Scan_State
(Scan_State
);
910 -- If we run into a colon, assume that we had a missing
911 -- comma, e.g. Parms (A B : ...). Also assume a missing
912 -- comma if we hit another comma, e.g. Parms (A B, C ..)
914 elsif Token
= Tok_Colon
915 or else Token
= Tok_Comma
917 Restore_Scan_State
(Scan_State
);
925 -- Here if a comma is present, or to be assumed
928 Num_Idents
:= Num_Idents
+ 1;
929 Idents
(Num_Idents
) := P_Defining_Identifier
;
932 -- Fall through the loop on encountering a colon, or deciding
933 -- that there is a missing colon.
937 -- If there are multiple identifiers, we repeatedly scan the
938 -- type and initialization expression information by resetting
939 -- the scan pointer (so that we get completely separate trees
940 -- for each occurrence).
942 if Num_Idents
> 1 then
943 Save_Scan_State
(Scan_State
);
946 -- Loop through defining identifiers in list
950 Ident_List_Loop
: loop
951 Specification_Node
:=
952 New_Node
(N_Parameter_Specification
, Ident_Sloc
);
953 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
955 if Token
= Tok_Access
then
957 Error_Msg_SC
("(Ada 83) access parameters not allowed");
961 (Specification_Node
, P_Access_Definition
);
964 P_Mode
(Specification_Node
);
966 if Token
= Tok_Procedure
970 Error_Msg_SC
("formal subprogram parameter not allowed");
973 if Token
= Tok_Left_Paren
then
974 Discard_Junk_List
(P_Formal_Part
);
977 if Token
= Tok_Return
then
979 Discard_Junk_Node
(P_Subtype_Mark
);
982 Set_Parameter_Type
(Specification_Node
, Error
);
985 Set_Parameter_Type
(Specification_Node
, P_Subtype_Mark
);
990 Set_Expression
(Specification_Node
, Init_Expr_Opt
(True));
993 Set_Prev_Ids
(Specification_Node
, True);
996 if Ident
< Num_Idents
then
997 Set_More_Ids
(Specification_Node
, True);
1000 Append
(Specification_Node
, Specification_List
);
1001 exit Ident_List_Loop
when Ident
= Num_Idents
;
1003 Restore_Scan_State
(Scan_State
);
1004 end loop Ident_List_Loop
;
1007 when Error_Resync
=>
1008 Resync_Semicolon_List
;
1011 if Token
= Tok_Semicolon
then
1012 Scan
; -- past semicolon
1014 -- If we have RETURN or IS after the semicolon, then assume
1015 -- that semicolon should have been a right parenthesis and exit
1017 if Token
= Tok_Is
or else Token
= Tok_Return
then
1018 Error_Msg_SP
("expected "")"" in place of "";""");
1019 exit Specification_Loop
;
1022 elsif Token
= Tok_Right_Paren
then
1023 Scan
; -- past right paren
1024 exit Specification_Loop
;
1026 -- Special check for common error of using comma instead of semicolon
1028 elsif Token
= Tok_Comma
then
1032 -- Special check for omitted separator
1034 elsif Token
= Tok_Identifier
then
1037 -- If nothing sensible, skip to next semicolon or right paren
1041 Resync_Semicolon_List
;
1043 if Token
= Tok_Semicolon
then
1044 Scan
; -- past semicolon
1047 exit Specification_Loop
;
1050 end loop Specification_Loop
;
1052 return Specification_List
;
1055 ----------------------------------
1056 -- 6.1 Parameter Specification --
1057 ----------------------------------
1059 -- Parsed by P_Formal_Part (6.1)
1065 -- MODE ::= [in] | in out | out
1067 -- There is no explicit node in the tree for the Mode. Instead the
1068 -- In_Present and Out_Present flags are set in the parent node to
1069 -- record the presence of keywords specifying the mode.
1071 -- Error_Recovery: cannot raise Error_Resync
1073 procedure P_Mode
(Node
: Node_Id
) is
1075 if Token
= Tok_In
then
1077 Set_In_Present
(Node
, True);
1080 if Token
= Tok_Out
then
1082 Set_Out_Present
(Node
, True);
1085 if Token
= Tok_In
then
1086 Error_Msg_SC
("IN must preceed OUT in parameter mode");
1088 Set_In_Present
(Node
, True);
1092 --------------------------
1093 -- 6.3 Subprogram Body --
1094 --------------------------
1096 -- Parsed by P_Subprogram (6.1)
1098 -----------------------------------
1099 -- 6.4 Procedure Call Statement --
1100 -----------------------------------
1102 -- Parsed by P_Sequence_Of_Statements (5.1)
1104 ------------------------
1105 -- 6.4 Function Call --
1106 ------------------------
1108 -- Parsed by P_Call_Or_Name (4.1)
1110 --------------------------------
1111 -- 6.4 Actual Parameter Part --
1112 --------------------------------
1114 -- Parsed by P_Call_Or_Name (4.1)
1116 --------------------------------
1117 -- 6.4 Parameter Association --
1118 --------------------------------
1120 -- Parsed by P_Call_Or_Name (4.1)
1122 ------------------------------------
1123 -- 6.4 Explicit Actual Parameter --
1124 ------------------------------------
1126 -- Parsed by P_Call_Or_Name (4.1)
1128 ---------------------------
1129 -- 6.5 Return Statement --
1130 ---------------------------
1132 -- RETURN_STATEMENT ::= return [EXPRESSION];
1134 -- The caller has checked that the initial token is RETURN
1136 -- Error recovery: can raise Error_Resync
1138 function P_Return_Statement
return Node_Id
is
1139 Return_Node
: Node_Id
;
1142 Return_Node
:= New_Node
(N_Return_Statement
, Token_Ptr
);
1144 -- Sloc points to RETURN
1147 Scan
; -- past RETURN
1149 if Token
/= Tok_Semicolon
then
1151 -- If no semicolon, then scan an expression, except that
1152 -- we avoid trying to scan an expression if we are at an
1153 -- expression terminator since in that case the best error
1154 -- message is probably that we have a missing semicolon.
1156 if Token
not in Token_Class_Eterm
then
1157 Set_Expression
(Return_Node
, P_Expression_No_Right_Paren
);
1163 end P_Return_Statement
;