Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / ada / par-ch3.adb
blob: 08ffd7bf8261d0b19326ed410ca5ae6c0b122a2b [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P A R . C H 3 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
pragma Style_Checks (All_Checks);
-- Turn off subprogram body ordering check. Subprograms are in order
-- by RM section rather than alphabetical.
with Sinfo.CN; use Sinfo.CN;
separate (Par)
---------
-- Ch3 --
---------
package body Ch3 is
-----------------------
-- Local Subprograms --
-----------------------
function P_Component_List return Node_Id;
function P_Defining_Character_Literal return Node_Id;
function P_Delta_Constraint return Node_Id;
function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id;
function P_Digits_Constraint return Node_Id;
function P_Discriminant_Association return Node_Id;
function P_Enumeration_Literal_Specification return Node_Id;
function P_Enumeration_Type_Definition return Node_Id;
function P_Fixed_Point_Definition return Node_Id;
function P_Floating_Point_Definition return Node_Id;
function P_Index_Or_Discriminant_Constraint return Node_Id;
function P_Real_Range_Specification_Opt return Node_Id;
function P_Subtype_Declaration return Node_Id;
function P_Type_Declaration return Node_Id;
function P_Modular_Type_Definition return Node_Id;
function P_Variant return Node_Id;
function P_Variant_Part return Node_Id;
procedure Check_Restricted_Expression (N : Node_Id);
-- Check that the expression N meets the Restricted_Expression syntax.
-- The syntax is as follows:
--
-- RESTRICTED_EXPRESSION ::=
-- RESTRICTED_RELATION {and RESTRICTED_RELATION}
-- | RESTRICTED_RELATION {and then RESTRICTED_RELATION}
-- | RESTRICTED_RELATION {or RESTRICTED_RELATION}
-- | RESTRICTED_RELATION {or else RESTRICTED_RELATION}
-- | RESTRICTED_RELATION {xor RESTRICTED_RELATION}
--
-- RESTRICTED_RELATION ::=
-- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
--
-- This syntax is used for choices when extensions (and set notations)
-- are enabled, to remove the ambiguity of "when X in A | B". We consider
-- it very unlikely that this will ever arise in practice.
procedure P_Declarative_Items
(Decls : List_Id;
Done : out Boolean;
Declare_Expression : Boolean;
In_Spec : Boolean);
-- Scans out a single declarative item, or, in the case of a declaration
-- with a list of identifiers, a list of declarations, one for each of the
-- identifiers in the list. The declaration or declarations scanned are
-- appended to the given list. Done indicates whether or not there may be
-- additional declarative items to scan. If Done is True, then a decision
-- has been made that there are no more items to scan. If Done is False,
-- then there may be additional declarations to scan.
--
-- Declare_Expression is true if we are parsing a declare_expression, in
-- which case we want to suppress certain style checking.
--
-- In_Spec is true if we are scanning a package declaration, and is used to
-- generate an appropriate message if a statement is encountered in such a
-- context.
procedure P_Identifier_Declarations
(Decls : List_Id;
Done : out Boolean;
In_Spec : Boolean);
-- Scans out a set of declarations for an identifier or list of
-- identifiers, and appends them to the given list. The parameters have
-- the same significance as for P_Declarative_Items.
procedure Statement_When_Declaration_Expected
(Decls : List_Id;
Done : out Boolean;
In_Spec : Boolean);
-- Called when a statement is found at a point where a declaration was
-- expected. The parameters are as described for P_Declarative_Items.
procedure Set_Declaration_Expected;
-- Posts a "declaration expected" error messages at the start of the
-- current token, and if this is the first such message issued, saves
-- the message id in Missing_Begin_Msg, for possible later replacement.
---------------------------------
-- Check_Restricted_Expression --
---------------------------------
procedure Check_Restricted_Expression (N : Node_Id) is
begin
if Nkind (N) in N_Op_And | N_Op_Or | N_Op_Xor | N_And_Then | N_Or_Else
then
Check_Restricted_Expression (Left_Opnd (N));
Check_Restricted_Expression (Right_Opnd (N));
elsif Nkind (N) in N_In | N_Not_In
and then Paren_Count (N) = 0
then
Error_Msg_N ("|this expression must be parenthesized!", N);
end if;
end Check_Restricted_Expression;
-------------------
-- Init_Expr_Opt --
-------------------
function Init_Expr_Opt (P : Boolean := False) return Node_Id is
begin
-- For colon, assume it means := unless it is at the end of
-- a line, in which case guess that it means a semicolon.
if Token = Tok_Colon then
if Token_Is_At_End_Of_Line then
T_Semicolon;
return Empty;
end if;
-- Here if := or something that we will take as equivalent
elsif Token = Tok_Colon_Equal
or else Token = Tok_Equal
or else Token = Tok_Is
then
null;
-- Another possibility. If we have a literal followed by a semicolon,
-- we assume that we have a missing colon-equal.
elsif Token in Token_Class_Literal then
declare
Scan_State : Saved_Scan_State;
begin
Save_Scan_State (Scan_State);
Scan; -- past literal or identifier
if Token = Tok_Semicolon then
Restore_Scan_State (Scan_State);
else
Restore_Scan_State (Scan_State);
return Empty;
end if;
end;
-- Otherwise we definitely have no initialization expression
else
return Empty;
end if;
-- Merge here if we have an initialization expression
T_Colon_Equal;
if P then
return P_Expression;
else
return P_Expression_No_Right_Paren;
end if;
end Init_Expr_Opt;
----------------------------
-- 3.1 Basic Declaration --
----------------------------
-- Parsed by P_Basic_Declarative_Items (3.9)
------------------------------
-- 3.1 Defining Identifier --
------------------------------
-- DEFINING_IDENTIFIER ::= IDENTIFIER
-- Error recovery: can raise Error_Resync
function P_Defining_Identifier (C : Id_Check := None) return Node_Id is
Ident_Node : Node_Id := P_Identifier (C, True);
begin
-- If we already have a defining identifier, clean it out and make
-- a new clean identifier. This situation arises in some error cases
-- and we need to fix it.
if Nkind (Ident_Node) = N_Defining_Identifier then
Ident_Node := Make_Identifier (Sloc (Ident_Node), Chars (Ident_Node));
end if;
-- Change identifier to defining identifier if not in error
if Ident_Node /= Error then
Change_Identifier_To_Defining_Identifier (Ident_Node);
-- Warn if standard redefinition, except that we never warn on a
-- record field definition (since this is always a harmless case).
if not Inside_Record_Definition then
Warn_If_Standard_Redefinition (Ident_Node);
end if;
end if;
return Ident_Node;
end P_Defining_Identifier;
-----------------------------
-- 3.2.1 Type Declaration --
-----------------------------
-- TYPE_DECLARATION ::=
-- FULL_TYPE_DECLARATION
-- | INCOMPLETE_TYPE_DECLARATION
-- | PRIVATE_TYPE_DECLARATION
-- | PRIVATE_EXTENSION_DECLARATION
-- FULL_TYPE_DECLARATION ::=
-- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION
-- [ASPECT_SPECIFICATIONS];
-- | CONCURRENT_TYPE_DECLARATION
-- INCOMPLETE_TYPE_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
-- PRIVATE_TYPE_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
-- is [abstract] [tagged] [limited] private
-- [ASPECT_SPECIFICATIONS];
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
-- [abstract] [limited | synchronized]
-- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
-- with private [ASPECT_SPECIFICATIONS];
-- TYPE_DEFINITION ::=
-- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
-- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
-- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
-- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
-- INTEGER_TYPE_DEFINITION ::=
-- SIGNED_INTEGER_TYPE_DEFINITION
-- MODULAR_TYPE_DEFINITION
-- INTERFACE_TYPE_DEFINITION ::=
-- [limited | task | protected | synchronized ] interface
-- [and INTERFACE_LIST]
-- Error recovery: can raise Error_Resync
-- The processing for full type declarations, incomplete type declarations,
-- private type declarations and type definitions is included in this
-- function. The processing for concurrent type declarations is NOT here,
-- but rather in chapter 9 (this function handles only declarations
-- starting with TYPE).
function P_Type_Declaration return Node_Id is
Abstract_Present : Boolean := False;
Abstract_Loc : Source_Ptr := No_Location;
Decl_Node : Node_Id;
Discr_List : List_Id;
Discr_Sloc : Source_Ptr;
End_Labl : Node_Id;
Ident_Node : Node_Id;
Is_Derived_Iface : Boolean := False;
Type_Loc : Source_Ptr;
Type_Start_Col : Column_Number;
Unknown_Dis : Boolean;
Typedef_Node : Node_Id;
-- Normally holds type definition, except in the case of a private
-- extension declaration, in which case it holds the declaration itself
begin
Type_Loc := Token_Ptr;
Type_Start_Col := Start_Column;
-- If we have TYPE, then proceed ahead and scan identifier
if Token = Tok_Type then
Type_Token_Location := Type_Loc;
Scan; -- past TYPE
Ident_Node := P_Defining_Identifier (C_Is);
-- Otherwise this is an error case
else
T_Type;
Type_Token_Location := Type_Loc;
Ident_Node := P_Defining_Identifier (C_Is);
end if;
Discr_Sloc := Token_Ptr;
if P_Unknown_Discriminant_Part_Opt then
Unknown_Dis := True;
Discr_List := No_List;
else
Unknown_Dis := False;
Discr_List := P_Known_Discriminant_Part_Opt;
end if;
-- Incomplete type declaration. We complete the processing for this
-- case here and return the resulting incomplete type declaration node
if Token = Tok_Semicolon then
Scan; -- past ;
Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc);
Set_Defining_Identifier (Decl_Node, Ident_Node);
Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
Set_Discriminant_Specifications (Decl_Node, Discr_List);
return Decl_Node;
else
Decl_Node := Empty;
end if;
-- Full type declaration or private type declaration, must have IS
if Token = Tok_Equal then
TF_Is;
Scan; -- past = used in place of IS
elsif Token = Tok_Renames then
Error_Msg_SC -- CODEFIX
("RENAMES should be IS");
Scan; -- past RENAMES used in place of IS
else
TF_Is;
end if;
-- First an error check, if we have two identifiers in a row, a likely
-- possibility is that the first of the identifiers is an incorrectly
-- spelled keyword.
if Token = Tok_Identifier then
declare
SS : Saved_Scan_State;
I2 : Boolean;
begin
Save_Scan_State (SS);
Scan; -- past initial identifier
I2 := (Token = Tok_Identifier);
Restore_Scan_State (SS);
if I2
and then
(Bad_Spelling_Of (Tok_Abstract) or else
Bad_Spelling_Of (Tok_Access) or else
Bad_Spelling_Of (Tok_Aliased) or else
Bad_Spelling_Of (Tok_Constant))
then
null;
end if;
end;
end if;
-- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
if Token_Name = Name_Abstract then
Check_95_Keyword (Tok_Abstract, Tok_Tagged);
Check_95_Keyword (Tok_Abstract, Tok_New);
end if;
-- Check cases of misuse of ABSTRACT
if Token = Tok_Abstract then
Abstract_Present := True;
Abstract_Loc := Token_Ptr;
Scan; -- past ABSTRACT
-- Ada 2005 (AI-419): AARM 3.4 (2/2)
if (Ada_Version < Ada_2005 and then Token = Tok_Limited)
or else Token = Tok_Private
or else Token = Tok_Record
or else Token = Tok_Null
then
Error_Msg_AP ("TAGGED expected");
end if;
end if;
-- Check for misuse of Ada 95 keyword Tagged
if Token_Name = Name_Tagged then
Check_95_Keyword (Tok_Tagged, Tok_Private);
Check_95_Keyword (Tok_Tagged, Tok_Limited);
Check_95_Keyword (Tok_Tagged, Tok_Record);
end if;
-- Special check for misuse of Aliased
if Token = Tok_Aliased or else Token_Name = Name_Aliased then
Error_Msg_SC ("ALIASED not allowed in type definition");
Scan; -- past ALIASED
end if;
-- The following processing deals with either a private type declaration
-- or a full type declaration. In the private type case, we build the
-- N_Private_Type_Declaration node, setting its Tagged_Present and
-- Limited_Present flags, on encountering the Private keyword, and
-- leave Typedef_Node set to Empty. For the full type declaration
-- case, Typedef_Node gets set to the type definition.
Typedef_Node := Empty;
-- Switch on token following the IS. The loop normally runs once. It
-- only runs more than once if an error is detected, to try again after
-- detecting and fixing up the error.
loop
case Token is
when Tok_Access
| Tok_Not -- Ada 2005 (AI-231)
=>
Typedef_Node := P_Access_Type_Definition;
exit;
when Tok_Array =>
Typedef_Node := P_Array_Type_Definition;
exit;
when Tok_Delta =>
Typedef_Node := P_Fixed_Point_Definition;
exit;
when Tok_Digits =>
Typedef_Node := P_Floating_Point_Definition;
exit;
when Tok_In =>
Ignore (Tok_In);
when Tok_Integer_Literal =>
T_Range;
Typedef_Node := P_Signed_Integer_Type_Definition;
exit;
when Tok_Null =>
Typedef_Node := P_Record_Definition;
exit;
when Tok_Left_Paren =>
Typedef_Node := P_Enumeration_Type_Definition;
End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label (Typedef_Node, End_Labl);
exit;
when Tok_Mod =>
Typedef_Node := P_Modular_Type_Definition;
exit;
when Tok_New =>
Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
if Nkind (Typedef_Node) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Typedef_Node))
then
End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label
(Record_Extension_Part (Typedef_Node), End_Labl);
end if;
exit;
when Tok_Range =>
Typedef_Node := P_Signed_Integer_Type_Definition;
exit;
when Tok_Record =>
Typedef_Node := P_Record_Definition;
End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label (Typedef_Node, End_Labl);
exit;
when Tok_Tagged =>
Scan; -- past TAGGED
-- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
-- is a tagged incomplete type.
if Ada_Version >= Ada_2005
and then Token = Tok_Semicolon
then
Scan; -- past ;
Decl_Node :=
New_Node (N_Incomplete_Type_Declaration, Type_Loc);
Set_Defining_Identifier (Decl_Node, Ident_Node);
Set_Tagged_Present (Decl_Node);
Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
Set_Discriminant_Specifications (Decl_Node, Discr_List);
return Decl_Node;
end if;
if Token = Tok_Abstract then
Error_Msg_SC -- CODEFIX
("ABSTRACT must come before TAGGED");
Abstract_Present := True;
Abstract_Loc := Token_Ptr;
Scan; -- past ABSTRACT
end if;
if Token = Tok_Limited then
Scan; -- past LIMITED
-- TAGGED LIMITED PRIVATE case
if Token = Tok_Private then
Decl_Node :=
New_Node (N_Private_Type_Declaration, Type_Loc);
Set_Tagged_Present (Decl_Node, True);
Set_Limited_Present (Decl_Node, True);
Scan; -- past PRIVATE
-- TAGGED LIMITED RECORD
else
Typedef_Node := P_Record_Definition;
Set_Tagged_Present (Typedef_Node, True);
Set_Limited_Present (Typedef_Node, True);
End_Labl :=
Make_Identifier (Token_Ptr, Chars (Ident_Node));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label (Typedef_Node, End_Labl);
end if;
else
-- TAGGED PRIVATE
if Token = Tok_Private then
Decl_Node :=
New_Node (N_Private_Type_Declaration, Type_Loc);
Set_Tagged_Present (Decl_Node, True);
Scan; -- past PRIVATE
-- TAGGED RECORD
else
Typedef_Node := P_Record_Definition;
Set_Tagged_Present (Typedef_Node, True);
End_Labl :=
Make_Identifier (Token_Ptr, Chars (Ident_Node));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label (Typedef_Node, End_Labl);
end if;
end if;
exit;
when Tok_Limited =>
Scan; -- past LIMITED
loop
if Token = Tok_Tagged then
Error_Msg_SC -- CODEFIX
("TAGGED must come before LIMITED");
Scan; -- past TAGGED
elsif Token = Tok_Abstract then
Error_Msg_SC -- CODEFIX
("ABSTRACT must come before LIMITED");
Scan; -- past ABSTRACT
else
exit;
end if;
end loop;
-- LIMITED RECORD or LIMITED NULL RECORD
if Token = Tok_Record or else Token = Tok_Null then
if Ada_Version = Ada_83 then
Error_Msg_SP
("(Ada 83) limited record declaration not allowed!");
-- In Ada 2005, "abstract limited" can appear before "new",
-- but it cannot be part of an untagged record declaration.
elsif Abstract_Present
and then Prev_Token /= Tok_Tagged
then
Error_Msg_SP ("TAGGED expected");
end if;
Typedef_Node := P_Record_Definition;
Set_Limited_Present (Typedef_Node, True);
End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label (Typedef_Node, End_Labl);
-- Ada 2005 (AI-251): LIMITED INTERFACE
-- If we are compiling in Ada 83 or Ada 95 mode, "interface"
-- is not a reserved word but we force its analysis to
-- generate the corresponding usage error.
elsif Token = Tok_Interface
or else (Token = Tok_Identifier
and then Chars (Token_Node) = Name_Interface)
then
Typedef_Node :=
P_Interface_Type_Definition (Abstract_Present);
Abstract_Present := True;
Set_Limited_Present (Typedef_Node);
if Nkind (Typedef_Node) = N_Derived_Type_Definition then
Is_Derived_Iface := True;
end if;
-- Ada 2005 (AI-419): LIMITED NEW
elsif Token = Tok_New then
Error_Msg_Ada_2005_Extension ("LIMITED in derived type");
Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
Set_Limited_Present (Typedef_Node);
if Nkind (Typedef_Node) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Typedef_Node))
then
End_Labl :=
Make_Identifier (Token_Ptr, Chars (Ident_Node));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label
(Record_Extension_Part (Typedef_Node), End_Labl);
end if;
-- LIMITED PRIVATE is the only remaining possibility here
else
Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
Set_Limited_Present (Decl_Node, True);
T_Private; -- past PRIVATE (or complain if not there)
end if;
exit;
-- Here we have an identifier after the IS, which is certainly
-- wrong and which might be one of several different mistakes.
when Tok_Identifier =>
-- First case, if identifier is on same line, then probably we
-- have something like "type X is Integer .." and the best
-- diagnosis is a missing NEW. Note: the missing new message
-- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
if not Token_Is_At_Start_Of_Line then
Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
-- If the identifier is at the start of the line, and is in the
-- same column as the type declaration itself then we consider
-- that we had a missing type definition on the previous line
elsif Start_Column <= Type_Start_Col then
Error_Msg_AP ("type definition expected");
Typedef_Node := Error;
-- If the identifier is at the start of the line, and is in
-- a column to the right of the type declaration line, then we
-- may have something like:
-- type x is
-- r : integer
-- and the best diagnosis is a missing record keyword
else
Typedef_Node := P_Record_Definition;
end if;
exit;
-- Ada 2005 (AI-251): INTERFACE
when Tok_Interface =>
Typedef_Node := P_Interface_Type_Definition (Abstract_Present);
Abstract_Present := True;
exit;
when Tok_Private =>
Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
Scan; -- past PRIVATE
-- Check error cases of private [abstract] tagged
if Token = Tok_Abstract then
Error_Msg_SC ("`ABSTRACT TAGGED` must come before PRIVATE");
Scan; -- past ABSTRACT
if Token = Tok_Tagged then
Scan; -- past TAGGED
end if;
elsif Token = Tok_Tagged then
Error_Msg_SC ("TAGGED must come before PRIVATE");
Scan; -- past TAGGED
end if;
exit;
-- Ada 2005 (AI-345): Protected, synchronized or task interface
-- or Ada 2005 (AI-443): Synchronized private extension.
when Tok_Protected
| Tok_Synchronized
| Tok_Task
=>
declare
Saved_Token : constant Token_Type := Token;
begin
Scan; -- past TASK, PROTECTED or SYNCHRONIZED
-- Synchronized private extension
if Token = Tok_New then
Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
if Saved_Token = Tok_Synchronized then
if Nkind (Typedef_Node) =
N_Derived_Type_Definition
then
Error_Msg_N
("SYNCHRONIZED not allowed for record extension",
Typedef_Node);
else
Set_Synchronized_Present (Typedef_Node);
end if;
else
Error_Msg_SC ("invalid kind of private extension");
end if;
-- Interface
else
if Token /= Tok_Interface then
Error_Msg_SC ("NEW or INTERFACE expected");
end if;
Typedef_Node :=
P_Interface_Type_Definition (Abstract_Present);
Abstract_Present := True;
case Saved_Token is
when Tok_Task =>
Set_Task_Present (Typedef_Node);
when Tok_Protected =>
Set_Protected_Present (Typedef_Node);
when Tok_Synchronized =>
Set_Synchronized_Present (Typedef_Node);
when others =>
pragma Assert (False);
null;
end case;
end if;
end;
exit;
-- Anything else is an error
when others =>
if Bad_Spelling_Of (Tok_Access)
or else
Bad_Spelling_Of (Tok_Array)
or else
Bad_Spelling_Of (Tok_Delta)
or else
Bad_Spelling_Of (Tok_Digits)
or else
Bad_Spelling_Of (Tok_Limited)
or else
Bad_Spelling_Of (Tok_Private)
or else
Bad_Spelling_Of (Tok_Range)
or else
Bad_Spelling_Of (Tok_Record)
or else
Bad_Spelling_Of (Tok_Tagged)
then
null;
else
Error_Msg_AP ("type definition expected");
raise Error_Resync;
end if;
end case;
end loop;
-- For the private type declaration case, the private type declaration
-- node has been built, with the Tagged_Present and Limited_Present
-- flags set as needed, and Typedef_Node is left set to Empty.
if No (Typedef_Node) then
Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
Set_Abstract_Present (Decl_Node, Abstract_Present);
-- For a private extension declaration, Typedef_Node contains the
-- N_Private_Extension_Declaration node, which we now complete. Note
-- that the private extension declaration, unlike a full type
-- declaration, does permit unknown discriminants.
elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then
Decl_Node := Typedef_Node;
Set_Sloc (Decl_Node, Type_Loc);
Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
Set_Abstract_Present (Typedef_Node, Abstract_Present);
-- In the full type declaration case, Typedef_Node has the type
-- definition and here is where we build the full type declaration
-- node. This is also where we check for improper use of an unknown
-- discriminant part (not allowed for full type declaration).
else
if Nkind (Typedef_Node) = N_Record_Definition
or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Typedef_Node)))
or else Is_Derived_Iface
then
Set_Abstract_Present (Typedef_Node, Abstract_Present);
elsif Abstract_Present then
Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc);
end if;
Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc);
Set_Type_Definition (Decl_Node, Typedef_Node);
if Unknown_Dis then
Error_Msg
("full type declaration cannot have unknown discriminants",
Discr_Sloc);
end if;
end if;
-- Remaining processing is common for all three cases
Set_Defining_Identifier (Decl_Node, Ident_Node);
Set_Discriminant_Specifications (Decl_Node, Discr_List);
P_Aspect_Specifications (Decl_Node);
return Decl_Node;
end P_Type_Declaration;
----------------------------------
-- 3.2.1 Full Type Declaration --
----------------------------------
-- Parsed by P_Type_Declaration (3.2.1)
----------------------------
-- 3.2.1 Type Definition --
----------------------------
-- Parsed by P_Type_Declaration (3.2.1)
--------------------------------
-- 3.2.2 Subtype Declaration --
--------------------------------
-- SUBTYPE_DECLARATION ::=
-- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION
-- [ASPECT_SPECIFICATIONS];
-- The caller has checked that the initial token is SUBTYPE
-- Error recovery: can raise Error_Resync
function P_Subtype_Declaration return Node_Id is
Decl_Node : Node_Id;
Not_Null_Present : Boolean := False;
begin
Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
Scan; -- past SUBTYPE
Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is));
TF_Is;
if Token = Tok_New then
Error_Msg_SC -- CODEFIX
("NEW ignored (only allowed in type declaration)");
Scan; -- past NEW
end if;
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Subtype_Indication
(Decl_Node, P_Subtype_Indication (Not_Null_Present));
P_Aspect_Specifications (Decl_Node);
return Decl_Node;
end P_Subtype_Declaration;
-------------------------------
-- 3.2.2 Subtype Indication --
-------------------------------
-- SUBTYPE_INDICATION ::=
-- [not null] SUBTYPE_MARK [CONSTRAINT]
-- Error recovery: can raise Error_Resync
function P_Null_Exclusion
(Allow_Anonymous_In_95 : Boolean := False) return Boolean
is
Not_Loc : constant Source_Ptr := Token_Ptr;
-- Source position of "not", if present
begin
if Token /= Tok_Not then
return False;
else
Scan; -- past NOT
if Token = Tok_Null then
Scan; -- past NULL
-- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95,
-- except in the case of anonymous access types.
-- Allow_Anonymous_In_95 will be True if we're parsing a formal
-- parameter or discriminant, which are the only places where
-- anonymous access types occur in Ada 95. "Formal : not null
-- access ..." is legal in Ada 95, whereas "Formal : not null
-- Named_Access_Type" is not.
if Ada_Version >= Ada_2005
or else (Ada_Version >= Ada_95
and then Allow_Anonymous_In_95
and then Token = Tok_Access)
then
null; -- OK
else
Error_Msg
("`NOT NULL` access type is an Ada 2005 extension", Not_Loc);
Error_Msg
("\unit should be compiled with -gnat05 switch", Not_Loc);
end if;
else
Error_Msg_SP ("NULL expected");
end if;
if Token = Tok_New then
Error_Msg ("`NOT NULL` comes after NEW, not before", Not_Loc);
end if;
return True;
end if;
end P_Null_Exclusion;
function P_Subtype_Indication
(Not_Null_Present : Boolean := False) return Node_Id
is
Type_Node : Node_Id;
begin
if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
Type_Node := P_Subtype_Mark;
return P_Subtype_Indication (Type_Node, Not_Null_Present);
else
-- Check for error of using record definition and treat it nicely,
-- otherwise things are really messed up, so resynchronize.
if Token = Tok_Record then
Error_Msg_SC ("anonymous record definition not permitted");
Discard_Junk_Node (P_Record_Definition);
return Error;
else
Error_Msg_AP ("subtype indication expected");
raise Error_Resync;
end if;
end if;
end P_Subtype_Indication;
-- The following function is identical except that it is called with
-- the subtype mark already scanned out, and it scans out the constraint
-- Error recovery: can raise Error_Resync
function P_Subtype_Indication
(Subtype_Mark : Node_Id;
Not_Null_Present : Boolean := False) return Node_Id
is
Indic_Node : Node_Id;
Constr_Node : Node_Id;
begin
Constr_Node := P_Constraint_Opt;
if No (Constr_Node)
or else
(Nkind (Constr_Node) = N_Range_Constraint
and then Nkind (Range_Expression (Constr_Node)) = N_Error)
then
return Subtype_Mark;
else
if Not_Null_Present then
Error_Msg_SP ("`NOT NULL` not allowed if constraint given");
end if;
Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
Set_Constraint (Indic_Node, Constr_Node);
return Indic_Node;
end if;
end P_Subtype_Indication;
-------------------------
-- 3.2.2 Subtype Mark --
-------------------------
-- SUBTYPE_MARK ::= subtype_NAME;
-- Note: The subtype mark which appears after an IN or NOT IN
-- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
-- Error recovery: cannot raise Error_Resync
function P_Subtype_Mark return Node_Id is
begin
return P_Subtype_Mark_Resync;
exception
when Error_Resync =>
return Error;
end P_Subtype_Mark;
-- This routine differs from P_Subtype_Mark in that it insists that an
-- identifier be present, and if it is not, it raises Error_Resync.
-- Error recovery: can raise Error_Resync
function P_Subtype_Mark_Resync return Node_Id is
Type_Node : Node_Id;
begin
if Token = Tok_Access then
Error_Msg_SC ("anonymous access type definition not allowed here");
Scan; -- past ACCESS
end if;
if Token = Tok_Array then
Error_Msg_SC ("anonymous array definition not allowed here");
Discard_Junk_Node (P_Array_Type_Definition);
return Error;
else
Type_Node := P_Qualified_Simple_Name_Resync;
-- Check for a subtype mark attribute. The only valid possibilities
-- are 'CLASS and 'BASE. Anything else is a definite error. We may
-- as well catch it here.
if Token = Tok_Apostrophe then
return P_Subtype_Mark_Attribute (Type_Node);
else
return Type_Node;
end if;
end if;
end P_Subtype_Mark_Resync;
-- The following function is called to scan out a subtype mark attribute.
-- The caller has already scanned out the subtype mark, which is passed in
-- as the argument, and has checked that the current token is apostrophe.
-- Only a special subclass of attributes, called type attributes
-- (see Snames package) are allowed in this syntactic position.
-- Note: if the apostrophe is followed by other than an identifier, then
-- the input expression is returned unchanged, and the scan pointer is
-- left pointing to the apostrophe.
-- Error recovery: can raise Error_Resync
function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is
Attr_Node : Node_Id := Empty;
Scan_State : Saved_Scan_State;
Prefix : Node_Id;
begin
Prefix := Check_Subtype_Mark (Type_Node);
if Prefix = Error then
raise Error_Resync;
end if;
-- Loop through attributes appearing (more than one can appear as for
-- for example in X'Base'Class). We are at an apostrophe on entry to
-- this loop, and it runs once for each attribute parsed, with
-- Prefix being the current possible prefix if it is an attribute.
loop
Save_Scan_State (Scan_State); -- at Apostrophe
Scan; -- past apostrophe
if Token /= Tok_Identifier then
Restore_Scan_State (Scan_State); -- to apostrophe
return Prefix; -- no attribute after all
elsif not Is_Type_Attribute_Name (Token_Name) then
Error_Msg_N
("attribute & may not be used in a subtype mark", Token_Node);
raise Error_Resync;
else
Attr_Node :=
Make_Attribute_Reference (Prev_Token_Ptr,
Prefix => Prefix,
Attribute_Name => Token_Name);
Scan; -- past type attribute identifier
end if;
exit when Token /= Tok_Apostrophe;
Prefix := Attr_Node;
end loop;
-- Fall through here after scanning type attribute
return Attr_Node;
end P_Subtype_Mark_Attribute;
-----------------------
-- 3.2.2 Constraint --
-----------------------
-- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
-- SCALAR_CONSTRAINT ::=
-- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
-- COMPOSITE_CONSTRAINT ::=
-- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
-- If no constraint is present, this function returns Empty
-- Error recovery: can raise Error_Resync
function P_Constraint_Opt return Node_Id is
begin
if Token = Tok_Range or else Bad_Spelling_Of (Tok_Range) then
return P_Range_Constraint;
elsif Token = Tok_Digits or else Bad_Spelling_Of (Tok_Digits) then
return P_Digits_Constraint;
elsif Token = Tok_Delta or else Bad_Spelling_Of (Tok_Delta) then
return P_Delta_Constraint;
elsif Token = Tok_Left_Paren then
return P_Index_Or_Discriminant_Constraint;
elsif Token = Tok_In then
Ignore (Tok_In);
return P_Constraint_Opt;
-- One more possibility is e.g. 1 .. 10 (i.e. missing RANGE keyword)
elsif Token = Tok_Identifier or else
Token = Tok_Integer_Literal or else
Token = Tok_Real_Literal
then
declare
Scan_State : Saved_Scan_State;
begin
Save_Scan_State (Scan_State); -- at identifier or literal
Scan; -- past identifier or literal
if Token = Tok_Dot_Dot then
Restore_Scan_State (Scan_State);
Error_Msg_BC ("missing RANGE keyword");
return P_Range_Constraint;
else
Restore_Scan_State (Scan_State);
return Empty;
end if;
end;
-- Nothing worked, no constraint there
else
return Empty;
end if;
end P_Constraint_Opt;
------------------------------
-- 3.2.2 Scalar Constraint --
------------------------------
-- Parsed by P_Constraint_Opt (3.2.2)
---------------------------------
-- 3.2.2 Composite Constraint --
---------------------------------
-- Parsed by P_Constraint_Opt (3.2.2)
--------------------------------------------------------
-- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
--------------------------------------------------------
-- This routine scans out a declaration starting with an identifier:
-- OBJECT_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]
-- [ASPECT_SPECIFICATIONS];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- ACCESS_DEFINITION [:= EXPRESSION]
-- [ASPECT_SPECIFICATIONS];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- ARRAY_TYPE_DEFINITION [:= EXPRESSION]
-- [ASPECT_SPECIFICATIONS];
-- NUMBER_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
-- OBJECT_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER :
-- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME
-- [ASPECT_SPECIFICATIONS];
-- | DEFINING_IDENTIFIER :
-- ACCESS_DEFINITION renames object_NAME
-- [ASPECT_SPECIFICATIONS];
-- EXCEPTION_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER : exception renames exception_NAME
-- [ASPECT_SPECIFICATIONS];
-- EXCEPTION_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : exception
-- [ASPECT_SPECIFICATIONS];
-- Note that the ALIASED indication in an object declaration is
-- marked by a flag in the parent node.
-- The caller has checked that the initial token is an identifier
-- The value returned is a list of declarations, one for each identifier
-- in the list (as described in Sinfo, we always split up multiple
-- declarations into the equivalent sequence of single declarations
-- using the More_Ids and Prev_Ids flags to preserve the source).
-- If the identifier turns out to be a probable statement rather than
-- an identifier, then the scan is left pointing to the identifier and
-- No_List is returned.
-- Error recovery: can raise Error_Resync
procedure P_Identifier_Declarations
(Decls : List_Id;
Done : out Boolean;
In_Spec : Boolean)
is
Acc_Node : Node_Id;
Decl_Node : Node_Id;
Type_Node : Node_Id;
Ident_Sloc : Source_Ptr;
Scan_State : Saved_Scan_State;
List_OK : Boolean := True;
Ident : Nat;
Init_Expr : Node_Id;
Init_Loc : Source_Ptr;
Con_Loc : Source_Ptr;
Not_Null_Present : Boolean := False;
Idents : array (Int range 1 .. 4096) of Entity_Id;
-- Used to save identifiers in the identifier list. The upper bound
-- of 4096 is expected to be infinite in practice, and we do not even
-- bother to check if this upper bound is exceeded.
Num_Idents : Nat := 1;
-- Number of identifiers stored in Idents
procedure No_List;
-- This procedure is called in renames cases to make sure that we do
-- not have more than one identifier. If we do have more than one
-- then an error message is issued (and the declaration is split into
-- multiple declarations)
function Token_Is_Renames return Boolean;
-- Checks if current token is RENAMES, and if so, scans past it and
-- returns True, otherwise returns False. Includes checking for some
-- common error cases.
-------------
-- No_List --
-------------
procedure No_List is
begin
if Num_Idents > 1 then
Error_Msg_N
("identifier list not allowed for RENAMES",
Idents (2));
end if;
List_OK := False;
end No_List;
----------------------
-- Token_Is_Renames --
----------------------
function Token_Is_Renames return Boolean is
At_Colon : Saved_Scan_State;
begin
if Token = Tok_Colon then
Save_Scan_State (At_Colon);
Scan; -- past colon
Check_Misspelling_Of (Tok_Renames);
if Token = Tok_Renames then
Error_Msg_SP -- CODEFIX
("|extra "":"" ignored");
Scan; -- past RENAMES
return True;
else
Restore_Scan_State (At_Colon);
return False;
end if;
else
Check_Misspelling_Of (Tok_Renames);
if Token = Tok_Renames then
Scan; -- past RENAMES
return True;
else
return False;
end if;
end if;
end Token_Is_Renames;
-- Start of processing for P_Identifier_Declarations
begin
Ident_Sloc := Token_Ptr;
Save_Scan_State (Scan_State); -- at first identifier
Idents (1) := P_Defining_Identifier (C_Comma_Colon);
-- If we have a colon after the identifier, then we can assume that
-- this is in fact a valid identifier declaration and can steam ahead.
if Token = Tok_Colon then
Scan; -- past colon
-- If we have a comma, then scan out the list of identifiers
elsif Token = Tok_Comma then
while Comma_Present loop
Num_Idents := Num_Idents + 1;
Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
Save_Scan_State (Scan_State); -- at colon
T_Colon;
-- If we have identifier followed by := then we assume that what is
-- really meant is an assignment statement. The assignment statement
-- is scanned out and added to the list of declarations. An exception
-- occurs if the := is followed by the keyword constant, in which case
-- we assume it was meant to be a colon.
elsif Token = Tok_Colon_Equal then
Scan; -- past :=
if Token = Tok_Constant then
Error_Msg_SP ("colon expected");
else
Restore_Scan_State (Scan_State);
-- Reset Token_Node, because it already got changed from an
-- Identifier to a Defining_Identifier, and we don't want that
-- for a statement!
Token_Node :=
Make_Identifier (Sloc (Token_Node), Chars (Token_Node));
-- And now scan out one or more statements
Statement_When_Declaration_Expected (Decls, Done, In_Spec);
return;
end if;
-- If we have an IS keyword, then assume the TYPE keyword was missing
elsif Token = Tok_Is then
Restore_Scan_State (Scan_State);
Append_To (Decls, P_Type_Declaration);
Done := False;
return;
-- AI12-0275: Object renaming declaration without subtype_mark or
-- access_definition
elsif Token = Tok_Renames then
Error_Msg_Ada_2022_Feature
("object renaming without subtype", Token_Ptr);
Scan; -- past renames
Decl_Node :=
New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
Set_Name (Decl_Node, P_Name);
Set_Defining_Identifier (Decl_Node, Idents (1));
P_Aspect_Specifications (Decl_Node, Semicolon => False);
T_Semicolon;
Append (Decl_Node, Decls);
Done := False;
return;
-- Otherwise we have an error situation
else
Restore_Scan_State (Scan_State);
-- First case is possible misuse of PROTECTED in Ada 83 mode. If
-- so, fix the keyword and return to scan the protected declaration.
if Token_Name = Name_Protected then
Check_95_Keyword (Tok_Protected, Tok_Identifier);
Check_95_Keyword (Tok_Protected, Tok_Type);
Check_95_Keyword (Tok_Protected, Tok_Body);
if Token = Tok_Protected then
Done := False;
return;
end if;
-- Check misspelling possibilities. If so, correct the misspelling
-- and return to scan out the resulting declaration.
elsif Bad_Spelling_Of (Tok_Function)
or else Bad_Spelling_Of (Tok_Procedure)
or else Bad_Spelling_Of (Tok_Package)
or else Bad_Spelling_Of (Tok_Pragma)
or else Bad_Spelling_Of (Tok_Protected)
or else Bad_Spelling_Of (Tok_Generic)
or else Bad_Spelling_Of (Tok_Subtype)
or else Bad_Spelling_Of (Tok_Type)
or else Bad_Spelling_Of (Tok_Task)
or else Bad_Spelling_Of (Tok_Use)
or else Bad_Spelling_Of (Tok_For)
then
Done := False;
return;
-- Otherwise we definitely have an ordinary identifier with a junk
-- token after it.
else
-- If in -gnatd.2 mode, try for statements
if Debug_Flag_Dot_2 then
Restore_Scan_State (Scan_State);
-- Reset Token_Node, because it already got changed from an
-- Identifier to a Defining_Identifier, and we don't want that
-- for a statement!
Token_Node :=
Make_Identifier (Sloc (Token_Node), Chars (Token_Node));
-- And now scan out one or more statements
Statement_When_Declaration_Expected (Decls, Done, In_Spec);
return;
-- Normal case, just complain and skip to semicolon
else
Set_Declaration_Expected;
Resync_Past_Semicolon;
Done := False;
return;
end if;
end if;
end if;
-- Come here with an identifier list and colon scanned out. We now
-- build the nodes for the declarative items. One node is built for
-- each identifier in the list, with the type information being
-- repeated by rescanning the appropriate section of source.
-- First an error check, if we have two identifiers in a row, a likely
-- possibility is that the first of the identifiers is an incorrectly
-- spelled keyword.
if Token = Tok_Identifier then
declare
SS : Saved_Scan_State;
I2 : Boolean;
begin
Save_Scan_State (SS);
Scan; -- past initial identifier
I2 := (Token = Tok_Identifier);
Restore_Scan_State (SS);
if I2
and then
(Bad_Spelling_Of (Tok_Access) or else
Bad_Spelling_Of (Tok_Aliased) or else
Bad_Spelling_Of (Tok_Constant))
then
null;
end if;
end;
end if;
-- Loop through identifiers
Ident := 1;
Ident_Loop : loop
-- Check for some cases of misused Ada 95 keywords
if Token_Name = Name_Aliased then
Check_95_Keyword (Tok_Aliased, Tok_Array);
Check_95_Keyword (Tok_Aliased, Tok_Identifier);
Check_95_Keyword (Tok_Aliased, Tok_Constant);
end if;
-- Constant cases
if Token = Tok_Constant then
Con_Loc := Token_Ptr;
Scan; -- past CONSTANT
-- Number declaration, initialization required
Init_Expr := Init_Expr_Opt;
if Present (Init_Expr) then
if Not_Null_Present then
Error_Msg_SP
("`NOT NULL` not allowed in numeric expression");
end if;
Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
Set_Expression (Decl_Node, Init_Expr);
-- Constant object declaration
else
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Constant_Present (Decl_Node, True);
if Token_Name = Name_Aliased then
Check_95_Keyword (Tok_Aliased, Tok_Array);
Check_95_Keyword (Tok_Aliased, Tok_Identifier);
end if;
if Token = Tok_Aliased then
Error_Msg_SC -- CODEFIX
("ALIASED should be before CONSTANT");
Scan; -- past ALIASED
Set_Aliased_Present (Decl_Node, True);
end if;
if Token = Tok_Array then
Set_Object_Definition
(Decl_Node, P_Array_Type_Definition);
else
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
if Token = Tok_Access then
Error_Msg_Ada_2005_Extension
("generalized use of anonymous access types");
Set_Object_Definition
(Decl_Node, P_Access_Definition (Not_Null_Present));
else
Set_Object_Definition
(Decl_Node, P_Subtype_Indication (Not_Null_Present));
end if;
end if;
if Token = Tok_Renames then
Error_Msg
("CONSTANT not permitted in renaming declaration",
Con_Loc);
Scan; -- Past renames
Discard_Junk_Node (P_Name);
end if;
end if;
-- Exception cases
elsif Token = Tok_Exception then
Scan; -- past EXCEPTION
if Token_Is_Renames then
No_List;
Decl_Node :=
New_Node (N_Exception_Renaming_Declaration, Ident_Sloc);
Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync);
No_Constraint;
else
Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr);
end if;
-- Aliased case (note that an object definition is required)
elsif Token = Tok_Aliased then
Scan; -- past ALIASED
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Aliased_Present (Decl_Node, True);
if Token = Tok_Constant then
Scan; -- past CONSTANT
Set_Constant_Present (Decl_Node, True);
end if;
if Token = Tok_Array then
Set_Object_Definition
(Decl_Node, P_Array_Type_Definition);
else
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
-- Access definition (AI-406) or subtype indication
if Token = Tok_Access then
Error_Msg_Ada_2005_Extension
("generalized use of anonymous access types");
Set_Object_Definition
(Decl_Node, P_Access_Definition (Not_Null_Present));
else
Set_Object_Definition
(Decl_Node, P_Subtype_Indication (Not_Null_Present));
end if;
end if;
-- Array case
elsif Token = Tok_Array then
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
-- Ada 2005 (AI-254, AI-406)
elsif Token = Tok_Not then
-- OBJECT_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]
-- [ASPECT_SPECIFICATIONS];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- ACCESS_DEFINITION [:= EXPRESSION]
-- [ASPECT_SPECIFICATIONS];
-- OBJECT_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER :
-- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME
-- [ASPECT_SPECIFICATIONS];
-- | DEFINING_IDENTIFIER :
-- ACCESS_DEFINITION renames object_NAME
-- [ASPECT_SPECIFICATIONS];
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423)
if Token = Tok_Access then
Error_Msg_Ada_2005_Extension
("generalized use of anonymous access types");
Acc_Node := P_Access_Definition (Not_Null_Present);
if Token /= Tok_Renames then
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Object_Definition (Decl_Node, Acc_Node);
else
Scan; -- past renames
No_List;
Decl_Node :=
New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
Set_Access_Definition (Decl_Node, Acc_Node);
Set_Name (Decl_Node, P_Name);
end if;
else
Type_Node := P_Subtype_Mark;
-- Object renaming declaration
if Token_Is_Renames then
if Ada_Version < Ada_2005 then
Error_Msg_SP
("`NOT NULL` not allowed in object renaming");
raise Error_Resync;
-- Ada 2005 (AI-423): Object renaming declaration with
-- a null exclusion.
else
No_List;
Decl_Node :=
New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Subtype_Mark (Decl_Node, Type_Node);
Set_Name (Decl_Node, P_Name);
end if;
-- Object declaration
else
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Object_Definition
(Decl_Node,
P_Subtype_Indication (Type_Node, Not_Null_Present));
-- RENAMES at this point means that we had the combination
-- of a constraint on the Type_Node and renames, which is
-- illegal
if Token_Is_Renames then
Error_Msg_N
("constraint not allowed in object renaming "
& "declaration",
Constraint (Object_Definition (Decl_Node)));
raise Error_Resync;
end if;
end if;
end if;
-- Ada 2005 (AI-230): Access Definition case
elsif Token = Tok_Access then
Error_Msg_Ada_2005_Extension
("generalized use of anonymous access types");
Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
-- Object declaration with access definition, or renaming
if Token /= Tok_Renames then
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Object_Definition (Decl_Node, Acc_Node);
else
Scan; -- past renames
No_List;
Decl_Node :=
New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
Set_Access_Definition (Decl_Node, Acc_Node);
Set_Name (Decl_Node, P_Name);
end if;
-- Subtype indication case
else
Type_Node := P_Subtype_Mark;
-- Object renaming declaration
if Token_Is_Renames then
No_List;
Decl_Node :=
New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
Set_Subtype_Mark (Decl_Node, Type_Node);
Set_Name (Decl_Node, P_Name);
-- Object declaration
else
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Object_Definition
(Decl_Node,
P_Subtype_Indication (Type_Node, Not_Null_Present));
-- RENAMES at this point means that we had the combination of
-- a constraint on the Type_Node and renames, which is illegal
if Token_Is_Renames then
Error_Msg_N
("constraint not allowed in object renaming declaration",
Constraint (Object_Definition (Decl_Node)));
raise Error_Resync;
end if;
end if;
end if;
-- Scan out initialization, allowed only for object declaration
Init_Loc := Token_Ptr;
Init_Expr := Init_Expr_Opt;
if Present (Init_Expr) then
if Nkind (Decl_Node) = N_Object_Declaration then
Set_Expression (Decl_Node, Init_Expr);
Set_Has_Init_Expression (Decl_Node);
else
Error_Msg ("initialization not allowed here", Init_Loc);
end if;
end if;
Set_Defining_Identifier (Decl_Node, Idents (Ident));
P_Aspect_Specifications (Decl_Node, Semicolon => False);
-- Allow initialization expression to follow aspects (note that in
-- this case P_Aspect_Specifications already issued an error msg).
if Token = Tok_Colon_Equal then
if Is_Non_Empty_List (Aspect_Specifications (Decl_Node)) then
Error_Msg
("aspect specifications must come after initialization "
& "expression",
Sloc (First (Aspect_Specifications (Decl_Node))));
else
-- In any case, the assignment symbol doesn't belong.
Error_Msg ("misplaced assignment symbol", Scan_Ptr);
end if;
Set_Expression (Decl_Node, Init_Expr_Opt);
Set_Has_Init_Expression (Decl_Node);
end if;
-- Now scan out the semicolon, which we deferred above
T_Semicolon;
if List_OK then
if Ident < Num_Idents then
Set_More_Ids (Decl_Node, True);
end if;
if Ident > 1 then
Set_Prev_Ids (Decl_Node, True);
end if;
end if;
Append (Decl_Node, Decls);
exit Ident_Loop when Ident = Num_Idents;
Restore_Scan_State (Scan_State);
T_Colon;
Ident := Ident + 1;
end loop Ident_Loop;
Done := False;
end P_Identifier_Declarations;
-------------------------------
-- 3.3.1 Object Declaration --
-------------------------------
-- OBJECT DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- SUBTYPE_INDICATION [:= EXPRESSION];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
-- | SINGLE_TASK_DECLARATION
-- | SINGLE_PROTECTED_DECLARATION
-- Cases starting with TASK are parsed by P_Task (9.1)
-- Cases starting with PROTECTED are parsed by P_Protected (9.4)
-- All other cases are parsed by P_Identifier_Declarations (3.3)
-------------------------------------
-- 3.3.1 Defining Identifier List --
-------------------------------------
-- DEFINING_IDENTIFIER_LIST ::=
-- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
-- Always parsed by the construct in which it appears. See special
-- section on "Handling of Defining Identifier Lists" in this unit.
-------------------------------
-- 3.3.2 Number Declaration --
-------------------------------
-- Parsed by P_Identifier_Declarations (3.3)
-------------------------------------------------------------------------
-- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
-------------------------------------------------------------------------
-- DERIVED_TYPE_DEFINITION ::=
-- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
-- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
-- [abstract] [limited | synchronized]
-- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
-- with private [ASPECT_SPECIFICATIONS];
-- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
-- The caller has already scanned out the part up to the NEW, and Token
-- either contains Tok_New (or ought to, if it doesn't this procedure
-- will post an appropriate "NEW expected" message).
-- Note: the caller is responsible for filling in the Sloc field of
-- the returned node in the private extension declaration case as
-- well as the stuff relating to the discriminant part.
-- Error recovery: can raise Error_Resync;
function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is
Typedef_Node : Node_Id;
Typedecl_Node : Node_Id;
Not_Null_Present : Boolean := False;
begin
Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
if Ada_Version < Ada_2005
and then Token = Tok_Identifier
and then Token_Name = Name_Interface
then
Error_Msg_SP
("abstract interface is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
else
T_New;
end if;
if Token = Tok_Abstract then
Error_Msg_SC -- CODEFIX
("ABSTRACT must come before NEW, not after");
Scan;
end if;
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
Set_Subtype_Indication (Typedef_Node,
P_Subtype_Indication (Not_Null_Present));
-- Ada 2005 (AI-251): Deal with interfaces
if Token = Tok_And then
Scan; -- past AND
Error_Msg_Ada_2005_Extension ("abstract interface");
Set_Interface_List (Typedef_Node, New_List);
loop
Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
exit when Token /= Tok_And;
Scan; -- past AND
end loop;
if Token /= Tok_With then
Error_Msg_SC ("WITH expected");
raise Error_Resync;
end if;
end if;
-- Deal with record extension, note that we assume that a WITH is
-- missing in the case of "type X is new Y record ..." or in the
-- case of "type X is new Y null record".
-- First make sure we don't have an aspect specification. If we do
-- return now, so that our caller can check it (the WITH here is not
-- part of a type extension).
if Aspect_Specifications_Present then
return Typedef_Node;
-- OK, not an aspect specification, so continue test for extension
elsif Token = Tok_With
or else Token = Tok_Record
or else Token = Tok_Null
then
T_With; -- past WITH or give error message
if Token = Tok_Limited then
Error_Msg_SC ("LIMITED keyword not allowed in private extension");
Scan; -- ignore LIMITED
end if;
-- Private extension declaration
if Token = Tok_Private then
Scan; -- past PRIVATE
-- Throw away the type definition node and build the type
-- declaration node. Note the caller must set the Sloc,
-- Discriminant_Specifications, Unknown_Discriminants_Present,
-- and Defined_Identifier fields in the returned node.
Typedecl_Node :=
Make_Private_Extension_Declaration (No_Location,
Defining_Identifier => Empty,
Subtype_Indication => Subtype_Indication (Typedef_Node),
Abstract_Present => Abstract_Present (Typedef_Node),
Interface_List => Interface_List (Typedef_Node));
return Typedecl_Node;
-- Derived type definition with record extension part
else
Set_Record_Extension_Part (Typedef_Node, P_Record_Definition);
return Typedef_Node;
end if;
-- Derived type definition with no record extension part
else
return Typedef_Node;
end if;
end P_Derived_Type_Def_Or_Private_Ext_Decl;
---------------------------
-- 3.5 Range Constraint --
---------------------------
-- RANGE_CONSTRAINT ::= range RANGE
-- The caller has checked that the initial token is RANGE or some
-- misspelling of it, or it may be absent completely (and a message
-- has already been issued).
-- Error recovery: cannot raise Error_Resync
function P_Range_Constraint return Node_Id is
Range_Node : Node_Id;
begin
Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
-- Skip range keyword if present
if Token = Tok_Range or else Bad_Spelling_Of (Tok_Range) then
Scan; -- past RANGE
end if;
Set_Range_Expression (Range_Node, P_Range);
return Range_Node;
end P_Range_Constraint;
----------------
-- 3.5 Range --
----------------
-- RANGE ::=
-- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
-- Note: the range that appears in a membership test is parsed by
-- P_Range_Or_Subtype_Mark (3.5).
-- Error recovery: cannot raise Error_Resync
function P_Range return Node_Id is
Expr_Node : Node_Id;
Range_Node : Node_Id;
begin
Expr_Node := P_Simple_Expression_Or_Range_Attribute;
if Expr_Form = EF_Range_Attr then
return Expr_Node;
elsif Token = Tok_Dot_Dot then
Range_Node := New_Node (N_Range, Token_Ptr);
Set_Low_Bound (Range_Node, Expr_Node);
Scan; -- past ..
Expr_Node := P_Expression;
Check_Simple_Expression (Expr_Node);
Set_High_Bound (Range_Node, Expr_Node);
return Range_Node;
-- Anything else is an error
else
T_Dot_Dot; -- force missing .. message
return Error;
end if;
end P_Range;
----------------------------------
-- 3.5 P_Range_Or_Subtype_Mark --
----------------------------------
-- RANGE ::=
-- RANGE_ATTRIBUTE_REFERENCE
-- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
-- This routine scans out the range or subtype mark that forms the right
-- operand of a membership test (it is not used in any other contexts, and
-- error messages are specialized with this knowledge in mind).
-- Note: as documented in the Sinfo interface, although the syntax only
-- allows a subtype mark, we in fact allow any simple expression to be
-- returned from this routine. The semantics is responsible for issuing
-- an appropriate message complaining if the argument is not a name.
-- This simplifies the coding and error recovery processing in the
-- parser, and in any case it is preferable not to consider this a
-- syntax error and to continue with the semantic analysis.
-- Error recovery: cannot raise Error_Resync
function P_Range_Or_Subtype_Mark
(Allow_Simple_Expression : Boolean := False) return Node_Id
is
Expr_Node : Node_Id;
Range_Node : Node_Id;
Save_Loc : Source_Ptr;
-- Start of processing for P_Range_Or_Subtype_Mark
begin
-- Save location of possible junk parentheses
Save_Loc := Token_Ptr;
-- Scan out either a simple expression or a range (this accepts more
-- than is legal here, but as explained above, we like to allow more
-- with a proper diagnostic, and in the case of a membership operation
-- where sets are allowed, a simple expression is permissible anyway.
Expr_Node := P_Simple_Expression_Or_Range_Attribute;
-- Range attribute
if Expr_Form = EF_Range_Attr then
return Expr_Node;
-- Simple_Expression .. Simple_Expression
elsif Token = Tok_Dot_Dot then
Check_Simple_Expression (Expr_Node);
Range_Node := New_Node (N_Range, Token_Ptr);
Set_Low_Bound (Range_Node, Expr_Node);
Scan; -- past ..
Set_High_Bound (Range_Node, P_Simple_Expression);
return Range_Node;
-- Case of subtype mark (optionally qualified simple name or an
-- attribute whose prefix is an optionally qualified simple name)
elsif Expr_Form = EF_Simple_Name
or else Nkind (Expr_Node) = N_Attribute_Reference
then
-- Check for error of range constraint after a subtype mark
if Token = Tok_Range then
Error_Msg_SC ("range constraint not allowed in membership test");
Scan; -- past RANGE
raise Error_Resync;
-- Check for error of DIGITS or DELTA after a subtype mark
elsif Token = Tok_Digits or else Token = Tok_Delta then
Error_Msg_SC
("accuracy definition not allowed in membership test");
Scan; -- past DIGITS or DELTA
raise Error_Resync;
-- Attribute reference, may or may not be OK, but in any case we
-- will scan it out
elsif Token = Tok_Apostrophe then
return P_Subtype_Mark_Attribute (Expr_Node);
-- OK case of simple name, just return it
else
return Expr_Node;
end if;
-- Simple expression case
elsif Expr_Form = EF_Simple and then Allow_Simple_Expression then
return Expr_Node;
-- Here we have some kind of error situation. Check for junk parens
-- then return what we have, caller will deal with other errors.
else
if Nkind (Expr_Node) in N_Subexpr
and then Paren_Count (Expr_Node) /= 0
then
Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc);
Set_Paren_Count (Expr_Node, 0);
end if;
return Expr_Node;
end if;
end P_Range_Or_Subtype_Mark;
----------------------------------------
-- 3.5.1 Enumeration Type Definition --
----------------------------------------
-- ENUMERATION_TYPE_DEFINITION ::=
-- (ENUMERATION_LITERAL_SPECIFICATION
-- {, ENUMERATION_LITERAL_SPECIFICATION})
-- The caller has already scanned out the TYPE keyword
-- Error recovery: can raise Error_Resync;
function P_Enumeration_Type_Definition return Node_Id is
Typedef_Node : Node_Id;
begin
Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr);
Set_Literals (Typedef_Node, New_List);
T_Left_Paren;
loop
Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node));
exit when not Comma_Present;
end loop;
T_Right_Paren;
return Typedef_Node;
end P_Enumeration_Type_Definition;
----------------------------------------------
-- 3.5.1 Enumeration Literal Specification --
----------------------------------------------
-- ENUMERATION_LITERAL_SPECIFICATION ::=
-- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
-- Error recovery: can raise Error_Resync
function P_Enumeration_Literal_Specification return Node_Id is
begin
if Token = Tok_Char_Literal then
return P_Defining_Character_Literal;
else
return P_Defining_Identifier (C_Comma_Right_Paren);
end if;
end P_Enumeration_Literal_Specification;
---------------------------------------
-- 3.5.1 Defining_Character_Literal --
---------------------------------------
-- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
-- Error recovery: cannot raise Error_Resync
-- The caller has checked that the current token is a character literal
function P_Defining_Character_Literal return Node_Id is
Literal_Node : Node_Id;
begin
Literal_Node := Token_Node;
Change_Character_Literal_To_Defining_Character_Literal (Literal_Node);
Scan; -- past character literal
return Literal_Node;
end P_Defining_Character_Literal;
------------------------------------
-- 3.5.4 Integer Type Definition --
------------------------------------
-- Parsed by P_Type_Declaration (3.2.1)
-------------------------------------------
-- 3.5.4 Signed Integer Type Definition --
-------------------------------------------
-- SIGNED_INTEGER_TYPE_DEFINITION ::=
-- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
-- Normally the initial token on entry is RANGE, but in some
-- error conditions, the range token was missing and control is
-- passed with Token pointing to first token of the first expression.
-- Error recovery: cannot raise Error_Resync
function P_Signed_Integer_Type_Definition return Node_Id is
Typedef_Node : Node_Id;
Expr_Node : Node_Id;
begin
Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr);
if Token = Tok_Range then
Scan; -- past RANGE
end if;
Expr_Node := P_Expression_Or_Range_Attribute;
-- Range case (not permitted by the grammar, this is surprising but
-- the grammar in the RM is as quoted above, and does not allow Range).
if Expr_Form = EF_Range_Attr then
Error_Msg_N
("Range attribute not allowed here, use First .. Last", Expr_Node);
Set_Low_Bound (Typedef_Node, Expr_Node);
Set_Attribute_Name (Expr_Node, Name_First);
Set_High_Bound (Typedef_Node, Copy_Separate_Tree (Expr_Node));
Set_Attribute_Name (High_Bound (Typedef_Node), Name_Last);
-- Normal case of explicit range
else
Check_Simple_Expression (Expr_Node);
Set_Low_Bound (Typedef_Node, Expr_Node);
T_Dot_Dot;
Expr_Node := P_Expression;
Check_Simple_Expression (Expr_Node);
Set_High_Bound (Typedef_Node, Expr_Node);
end if;
return Typedef_Node;
end P_Signed_Integer_Type_Definition;
------------------------------------
-- 3.5.4 Modular Type Definition --
------------------------------------
-- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
-- The caller has checked that the initial token is MOD
-- Error recovery: cannot raise Error_Resync
function P_Modular_Type_Definition return Node_Id is
Typedef_Node : Node_Id;
begin
if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) modular types not allowed");
end if;
Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr);
Scan; -- past MOD
Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
-- Handle mod L..R cleanly
if Token = Tok_Dot_Dot then
Error_Msg_SC ("range not allowed for modular type");
Scan; -- past ..
Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
end if;
return Typedef_Node;
end P_Modular_Type_Definition;
---------------------------------
-- 3.5.6 Real Type Definition --
---------------------------------
-- Parsed by P_Type_Declaration (3.2.1)
--------------------------------------
-- 3.5.7 Floating Point Definition --
--------------------------------------
-- FLOATING_POINT_DEFINITION ::=
-- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
-- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
-- The caller has checked that the initial token is DIGITS
-- Error recovery: cannot raise Error_Resync
function P_Floating_Point_Definition return Node_Id is
Digits_Loc : constant Source_Ptr := Token_Ptr;
Def_Node : Node_Id;
Expr_Node : Node_Id;
begin
Scan; -- past DIGITS
Expr_Node := P_Expression_No_Right_Paren;
Check_Simple_Expression_In_Ada_83 (Expr_Node);
-- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
if Token = Tok_Delta then
Error_Msg_SC -- CODEFIX
("|DELTA must come before DIGITS");
Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
Scan; -- past DELTA
Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);
-- OK floating-point definition
else
Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc);
end if;
Set_Digits_Expression (Def_Node, Expr_Node);
Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
return Def_Node;
end P_Floating_Point_Definition;
-------------------------------------
-- 3.5.7 Real Range Specification --
-------------------------------------
-- REAL_RANGE_SPECIFICATION ::=
-- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
-- Error recovery: cannot raise Error_Resync
function P_Real_Range_Specification_Opt return Node_Id is
Specification_Node : Node_Id;
Expr_Node : Node_Id;
begin
if Token = Tok_Range then
Specification_Node :=
New_Node (N_Real_Range_Specification, Token_Ptr);
Scan; -- past RANGE
Expr_Node := P_Expression_No_Right_Paren;
Check_Simple_Expression (Expr_Node);
Set_Low_Bound (Specification_Node, Expr_Node);
T_Dot_Dot;
Expr_Node := P_Expression_No_Right_Paren;
Check_Simple_Expression (Expr_Node);
Set_High_Bound (Specification_Node, Expr_Node);
return Specification_Node;
else
return Empty;
end if;
end P_Real_Range_Specification_Opt;
-----------------------------------
-- 3.5.9 Fixed Point Definition --
-----------------------------------
-- FIXED_POINT_DEFINITION ::=
-- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
-- ORDINARY_FIXED_POINT_DEFINITION ::=
-- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
-- DECIMAL_FIXED_POINT_DEFINITION ::=
-- delta static_EXPRESSION
-- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
-- The caller has checked that the initial token is DELTA
-- Error recovery: cannot raise Error_Resync
function P_Fixed_Point_Definition return Node_Id is
Delta_Node : Node_Id;
Delta_Loc : Source_Ptr;
Def_Node : Node_Id;
Expr_Node : Node_Id;
begin
Delta_Loc := Token_Ptr;
Scan; -- past DELTA
Delta_Node := P_Expression_No_Right_Paren;
Check_Simple_Expression_In_Ada_83 (Delta_Node);
if Token = Tok_Digits then
if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
end if;
Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc);
Scan; -- past DIGITS
Expr_Node := P_Expression_No_Right_Paren;
Check_Simple_Expression_In_Ada_83 (Expr_Node);
Set_Digits_Expression (Def_Node, Expr_Node);
else
Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc);
-- Range is required in ordinary fixed point case
if Token /= Tok_Range then
Error_Msg_AP ("range must be given for fixed-point type");
T_Range;
end if;
end if;
Set_Delta_Expression (Def_Node, Delta_Node);
Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
return Def_Node;
end P_Fixed_Point_Definition;
--------------------------------------------
-- 3.5.9 Ordinary Fixed Point Definition --
--------------------------------------------
-- Parsed by P_Fixed_Point_Definition (3.5.9)
-------------------------------------------
-- 3.5.9 Decimal Fixed Point Definition --
-------------------------------------------
-- Parsed by P_Decimal_Point_Definition (3.5.9)
------------------------------
-- 3.5.9 Digits Constraint --
------------------------------
-- DIGITS_CONSTRAINT ::=
-- digits static_EXPRESSION [RANGE_CONSTRAINT]
-- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
-- The caller has checked that the initial token is DIGITS
function P_Digits_Constraint return Node_Id is
Constraint_Node : Node_Id;
Expr_Node : Node_Id;
begin
Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr);
Scan; -- past DIGITS
Expr_Node := P_Expression;
Check_Simple_Expression_In_Ada_83 (Expr_Node);
Set_Digits_Expression (Constraint_Node, Expr_Node);
if Token = Tok_Range then
Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
end if;
return Constraint_Node;
end P_Digits_Constraint;
-----------------------------
-- 3.5.9 Delta Constraint --
-----------------------------
-- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
-- Note: this is an obsolescent feature in Ada 95 (I.3)
-- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
-- (also true in formal modes).
-- The caller has checked that the initial token is DELTA
-- Error recovery: cannot raise Error_Resync
function P_Delta_Constraint return Node_Id is
Constraint_Node : Node_Id;
Expr_Node : Node_Id;
begin
Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr);
Scan; -- past DELTA
Expr_Node := P_Expression;
Check_Simple_Expression_In_Ada_83 (Expr_Node);
Set_Delta_Expression (Constraint_Node, Expr_Node);
if Token = Tok_Range then
Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
end if;
return Constraint_Node;
end P_Delta_Constraint;
--------------------------------
-- 3.6 Array Type Definition --
--------------------------------
-- ARRAY_TYPE_DEFINITION ::=
-- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
-- UNCONSTRAINED_ARRAY_DEFINITION ::=
-- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
-- COMPONENT_DEFINITION
-- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
-- CONSTRAINED_ARRAY_DEFINITION ::=
-- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
-- COMPONENT_DEFINITION
-- DISCRETE_SUBTYPE_DEFINITION ::=
-- DISCRETE_SUBTYPE_INDICATION | RANGE
-- COMPONENT_DEFINITION ::=
-- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- The caller has checked that the initial token is ARRAY
-- Error recovery: can raise Error_Resync
function P_Array_Type_Definition return Node_Id is
Array_Loc : Source_Ptr;
CompDef_Node : Node_Id;
Def_Node : Node_Id;
Not_Null_Present : Boolean := False;
Subs_List : List_Id;
Scan_State : Saved_Scan_State;
Aliased_Present : Boolean := False;
procedure P_Index_Subtype_Def_With_Fixed_Lower_Bound
(Subtype_Mark : Node_Id);
-- Parse an unconstrained index range with a fixed lower bound:
-- subtype_mark range <expression> .. <>
-- This procedure creates a subtype_indication node for the index.
--------------------------------------------
-- P_Index_Range_With_Fixed_Lower_Bound --
--------------------------------------------
procedure P_Index_Subtype_Def_With_Fixed_Lower_Bound
(Subtype_Mark : Node_Id)
is
Low_Expr_Node : constant Node_Id := P_Expression;
High_Expr_Node : Node_Id;
Indic_Node : Node_Id;
Constr_Node : Node_Id;
Range_Node : Node_Id;
begin
T_Dot_Dot; -- Error if no ..
-- A box is required at this point, and we'll set the upper bound to
-- the same expression as the lower bound (see further below), to
-- avoid problems with trying to analyze an Empty node. Analysis can
-- still tell that this is a fixed-lower-bound range because the
-- index is represented by a subtype_indication in an unconstrained
-- array type definition.
if Token = Tok_Box then
Scan;
High_Expr_Node := Low_Expr_Node;
-- Error if no <> was found, and try to parse an expression since
-- it's likely one was given in place of the <>.
else
Error_Msg_AP -- CODEFIX
("missing ""'<'>""");
High_Expr_Node := P_Expression;
end if;
Constr_Node := New_Node (N_Range_Constraint, Token_Ptr);
Range_Node := New_Node (N_Range, Token_Ptr);
Set_Range_Expression (Constr_Node, Range_Node);
Check_Simple_Expression (Low_Expr_Node);
Set_Low_Bound (Range_Node, Low_Expr_Node);
Set_High_Bound (Range_Node, High_Expr_Node);
Indic_Node :=
New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
Set_Constraint (Indic_Node, Constr_Node);
Append (Indic_Node, Subs_List);
end P_Index_Subtype_Def_With_Fixed_Lower_Bound;
-- Local variables
Is_Constrained_Array_Def : Boolean := True;
Subtype_Mark_Node : Node_Id;
-- Start of processing for P_Array_Type_Definition
begin
Array_Loc := Token_Ptr;
Scan; -- past ARRAY
Subs_List := New_List;
T_Left_Paren;
-- It's quite tricky to disentangle these two possibilities, so we do
-- a prescan to determine which case we have and then reset the scan.
-- The prescan skips past possible subtype mark tokens.
Save_Scan_State (Scan_State); -- just after paren
while Token in Token_Class_Desig or else
Token = Tok_Dot or else
Token = Tok_Apostrophe -- because of 'BASE, 'CLASS
loop
Scan;
end loop;
-- If we end up on RANGE <> then we have the unconstrained case. We
-- will also allow the RANGE to be omitted, just to improve error
-- handling for a case like array (integer <>) of integer;
Scan; -- past possible RANGE or <>
if (Prev_Token = Tok_Range and then Token = Tok_Box) or else
Prev_Token = Tok_Box
then
Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc);
Restore_Scan_State (Scan_State); -- to first subtype mark
Is_Constrained_Array_Def := False;
-- Now parse a sequence of indexes where each is either of form:
-- <subtype_mark> range <>
-- or
-- <subtype_mark> range <expr> .. <>
--
-- The latter syntax indicates an index with a fixed lower bound,
-- and only applies when extensions are enabled (-gnatX).
loop
Subtype_Mark_Node := P_Subtype_Mark_Resync;
T_Range;
-- Normal "subtype_mark range <>" form, so simply append
-- the subtype reference.
if Token = Tok_Box then
Append (Subtype_Mark_Node, Subs_List);
Scan;
-- Fixed-lower-bound form ("subtype_mark range <expr> .. <>")
else
P_Index_Subtype_Def_With_Fixed_Lower_Bound (Subtype_Mark_Node);
Error_Msg_GNAT_Extension ("fixed-lower-bound array");
end if;
exit when Token = Tok_Right_Paren or else Token = Tok_Of;
T_Comma;
end loop;
Set_Subtype_Marks (Def_Node, Subs_List);
-- If we don't have "range <>", then "range" will be followed by an
-- expression, for either a normal range or a fixed-lower-bound range
-- ("<exp> .. <>"), and we have to know which, in order to determine
-- whether to parse the indexes for an unconstrained or constrained
-- array definition. So we look ahead to see if "<>" follows the "..".
-- If not, then this must be a discrete_subtype_indication for a
-- constrained_array_definition, which will be processed further below.
elsif Prev_Token = Tok_Range
and then Token /= Tok_Right_Paren and then Token /= Tok_Comma
then
-- If we have an expression followed by "..", then scan farther
-- and check for "<>" to see if we have a fixed-lower-bound range.
if P_Expression_Or_Range_Attribute /= Error
and then Expr_Form /= EF_Range_Attr
and then Token = Tok_Dot_Dot
then
Scan;
-- If there's a "<>", then we know we have a fixed-lower-bound
-- index, so we can proceed with parsing an unconstrained array
-- definition.
if Token = Tok_Box then
Is_Constrained_Array_Def := False;
Def_Node :=
New_Node (N_Unconstrained_Array_Definition, Array_Loc);
Restore_Scan_State (Scan_State); -- to first subtype mark
-- Now parse a sequence of indexes where each is either of
-- form:
-- <subtype_mark> range <>
-- or
-- <subtype_mark> range <expr> .. <>
--
-- The latter indicates an index with a fixed lower bound,
-- and only applies when extensions are enabled (-gnatX).
loop
Subtype_Mark_Node := P_Subtype_Mark_Resync;
T_Range;
-- Normal "subtype_mark range <>" form, so simply append
-- the subtype reference.
if Token = Tok_Box then
Append (Subtype_Mark_Node, Subs_List);
Scan;
-- This must be an index of form:
-- <subtype_mark> range <expr> .. <>"
else
P_Index_Subtype_Def_With_Fixed_Lower_Bound
(Subtype_Mark_Node);
Error_Msg_GNAT_Extension ("fixed-lower-bound array");
end if;
exit when Token = Tok_Right_Paren or else Token = Tok_Of;
T_Comma;
end loop;
Set_Subtype_Marks (Def_Node, Subs_List);
end if;
end if;
end if;
if Is_Constrained_Array_Def then
Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
Restore_Scan_State (Scan_State); -- to first discrete range
loop
Append (P_Discrete_Subtype_Definition, Subs_List);
exit when not Comma_Present;
end loop;
Set_Discrete_Subtype_Definitions (Def_Node, Subs_List);
end if;
T_Right_Paren;
T_Of;
CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
if Token_Name = Name_Aliased then
Check_95_Keyword (Tok_Aliased, Tok_Identifier);
end if;
if Token = Tok_Aliased then
Aliased_Present := True;
Scan; -- past ALIASED
end if;
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
-- Ada 2005 (AI-230): Access Definition case
if Token = Tok_Access then
Error_Msg_Ada_2005_Extension
("generalized use of anonymous access types");
-- AI95-406 makes "aliased" legal (and useless) in this context so
-- followintg code which used to be needed is commented out.
-- if Aliased_Present then
-- Error_Msg_SP ("ALIASED not allowed here");
-- end if;
Set_Subtype_Indication (CompDef_Node, Empty);
Set_Aliased_Present (CompDef_Node, Aliased_Present);
Set_Access_Definition (CompDef_Node,
P_Access_Definition (Not_Null_Present));
else
Set_Access_Definition (CompDef_Node, Empty);
Set_Aliased_Present (CompDef_Node, Aliased_Present);
Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
Set_Subtype_Indication (CompDef_Node,
P_Subtype_Indication (Not_Null_Present));
end if;
Set_Component_Definition (Def_Node, CompDef_Node);
return Def_Node;
end P_Array_Type_Definition;
-----------------------------------------
-- 3.6 Unconstrained Array Definition --
-----------------------------------------
-- Parsed by P_Array_Type_Definition (3.6)
---------------------------------------
-- 3.6 Constrained Array Definition --
---------------------------------------
-- Parsed by P_Array_Type_Definition (3.6)
--------------------------------------
-- 3.6 Discrete Subtype Definition --
--------------------------------------
-- DISCRETE_SUBTYPE_DEFINITION ::=
-- discrete_SUBTYPE_INDICATION | RANGE
-- Note: the discrete subtype definition appearing in a constrained
-- array definition is parsed by P_Array_Type_Definition (3.6)
-- Error recovery: cannot raise Error_Resync
function P_Discrete_Subtype_Definition return Node_Id is
begin
-- The syntax of a discrete subtype definition is identical to that
-- of a discrete range, so we simply share the same parsing code.
return P_Discrete_Range;
end P_Discrete_Subtype_Definition;
-------------------------------
-- 3.6 Component Definition --
-------------------------------
-- For the array case, parsed by P_Array_Type_Definition (3.6)
-- For the record case, parsed by P_Component_Declaration (3.8)
-----------------------------
-- 3.6.1 Index Constraint --
-----------------------------
-- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
---------------------------
-- 3.6.1 Discrete Range --
---------------------------
-- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
-- The possible forms for a discrete range are:
-- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
-- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
-- Range_Attribute (RANGE, 3.5)
-- Simple_Expression .. Simple_Expression (RANGE, 3.5)
-- Error recovery: cannot raise Error_Resync
function P_Discrete_Range return Node_Id is
Expr_Node : Node_Id;
Range_Node : Node_Id;
begin
Expr_Node := P_Simple_Expression_Or_Range_Attribute;
if Expr_Form = EF_Range_Attr then
return Expr_Node;
elsif Token = Tok_Range then
if Expr_Form /= EF_Simple_Name then
Error_Msg_SC ("range must be preceded by subtype mark");
end if;
return P_Subtype_Indication (Expr_Node);
-- Check Expression .. Expression case
elsif Token = Tok_Dot_Dot then
Range_Node := New_Node (N_Range, Token_Ptr);
Set_Low_Bound (Range_Node, Expr_Node);
Scan; -- past ..
Expr_Node := P_Expression;
Check_Simple_Expression (Expr_Node);
Set_High_Bound (Range_Node, Expr_Node);
return Range_Node;
-- Otherwise we must have a subtype mark, or an Ada 2012 iterator
elsif Expr_Form = EF_Simple_Name then
return Expr_Node;
-- The domain of iteration must be a name. Semantics will determine that
-- the expression has the proper form.
elsif Ada_Version >= Ada_2012 then
return Expr_Node;
-- If incorrect, complain that we expect ..
else
T_Dot_Dot;
return Expr_Node;
end if;
end P_Discrete_Range;
----------------------------
-- 3.7 Discriminant Part --
----------------------------
-- DISCRIMINANT_PART ::=
-- UNKNOWN_DISCRIMINANT_PART
-- | KNOWN_DISCRIMINANT_PART
-- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
-- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
------------------------------------
-- 3.7 Unknown Discriminant Part --
------------------------------------
-- UNKNOWN_DISCRIMINANT_PART ::= (<>)
-- If no unknown discriminant part is present, then False is returned,
-- otherwise the unknown discriminant is scanned out and True is returned.
-- Error recovery: cannot raise Error_Resync
function P_Unknown_Discriminant_Part_Opt return Boolean is
Scan_State : Saved_Scan_State;
begin
-- If <> right now, then this is missing left paren
if Token = Tok_Box then
U_Left_Paren;
-- If not <> or left paren, then definitely no box
elsif Token /= Tok_Left_Paren then
return False;
-- Left paren, so might be a box after it
else
Save_Scan_State (Scan_State);
Scan; -- past the left paren
if Token /= Tok_Box then
Restore_Scan_State (Scan_State);
return False;
end if;
end if;
-- We are now pointing to the box
if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
end if;
Scan; -- past the box
U_Right_Paren; -- must be followed by right paren
return True;
end P_Unknown_Discriminant_Part_Opt;
----------------------------------
-- 3.7 Known Discriminant Part --
----------------------------------
-- KNOWN_DISCRIMINANT_PART ::=
-- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
-- DISCRIMINANT_SPECIFICATION ::=
-- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
-- [:= DEFAULT_EXPRESSION] [ASPECT_SPECIFICATION]
-- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
-- [:= DEFAULT_EXPRESSION] [ASPECT_SPECIFICATION]
-- If no known discriminant part is present, then No_List is returned
-- Error recovery: cannot raise Error_Resync
function P_Known_Discriminant_Part_Opt return List_Id is
Specification_Node : Node_Id;
Specification_List : List_Id;
Ident_Sloc : Source_Ptr;
Scan_State : Saved_Scan_State;
Num_Idents : Nat;
Not_Null_Present : Boolean;
Ident : Nat;
Idents : array (Int range 1 .. 4096) of Entity_Id;
-- This array holds the list of defining identifiers. The upper bound
-- of 4096 is intended to be essentially infinite, and we do not even
-- bother to check for it being exceeded.
begin
if Token = Tok_Left_Paren then
Specification_List := New_List;
Scan; -- past (
P_Pragmas_Misplaced;
Specification_Loop : loop
Ident_Sloc := Token_Ptr;
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);
end loop;
-- If there are multiple identifiers, we repeatedly scan the
-- type and initialization expression information by resetting
-- the scan pointer (so that we get completely separate trees
-- for each occurrence).
if Num_Idents > 1 then
Save_Scan_State (Scan_State);
end if;
T_Colon;
-- Loop through defining identifiers in list
Ident := 1;
Ident_Loop : loop
Specification_Node :=
New_Node (N_Discriminant_Specification, Ident_Sloc);
Set_Defining_Identifier (Specification_Node, Idents (Ident));
Not_Null_Present := -- Ada 2005 (AI-231, AI-447)
P_Null_Exclusion (Allow_Anonymous_In_95 => True);
if Token = Tok_Access then
if Ada_Version = Ada_83 then
Error_Msg_SC
("(Ada 83) access discriminant not allowed!");
end if;
Set_Discriminant_Type
(Specification_Node,
P_Access_Definition (Not_Null_Present));
-- Catch ouf-of-order keywords
elsif Token = Tok_Constant then
Scan;
if Token = Tok_Access then
Error_Msg_SC ("CONSTANT must appear after ACCESS");
Set_Discriminant_Type
(Specification_Node,
P_Access_Definition (Not_Null_Present));
else
Error_Msg_SC ("misplaced CONSTANT");
end if;
else
Set_Discriminant_Type
(Specification_Node, P_Subtype_Mark);
No_Constraint;
Set_Null_Exclusion_Present -- Ada 2005 (AI-231)
(Specification_Node, Not_Null_Present);
end if;
Set_Expression
(Specification_Node, Init_Expr_Opt (True));
if Token = Tok_With then
P_Aspect_Specifications (Specification_Node, False);
end if;
if Ident > 1 then
Set_Prev_Ids (Specification_Node, True);
end if;
if Ident < Num_Idents then
Set_More_Ids (Specification_Node, True);
end if;
Append (Specification_Node, Specification_List);
exit Ident_Loop when Ident = Num_Idents;
Ident := Ident + 1;
Restore_Scan_State (Scan_State);
T_Colon;
end loop Ident_Loop;
exit Specification_Loop when Token /= Tok_Semicolon;
Scan; -- past ;
P_Pragmas_Misplaced;
end loop Specification_Loop;
T_Right_Paren;
return Specification_List;
else
return No_List;
end if;
end P_Known_Discriminant_Part_Opt;
-------------------------------------
-- 3.7 Discriminant Specification --
-------------------------------------
-- Parsed by P_Known_Discriminant_Part_Opt (3.7)
-----------------------------
-- 3.7 Default Expression --
-----------------------------
-- Always parsed (simply as an Expression) by the parent construct
------------------------------------
-- 3.7.1 Discriminant Constraint --
------------------------------------
-- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
--------------------------------------------------------
-- 3.7.1 Index or Discriminant Constraint (also 3.6) --
--------------------------------------------------------
-- DISCRIMINANT_CONSTRAINT ::=
-- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
-- DISCRIMINANT_ASSOCIATION ::=
-- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
-- EXPRESSION
-- This routine parses either an index or a discriminant constraint. As
-- is clear from the above grammar, it is often possible to clearly
-- determine which of the two possibilities we have, but there are
-- cases (those in which we have a series of expressions of the same
-- syntactic form as subtype indications), where we cannot tell. Since
-- this means that in any case the semantic phase has to distinguish
-- between the two, there is not much point in the parser trying to
-- distinguish even those cases where the difference is clear. In any
-- case, if we have a situation like:
-- (A => 123, 235 .. 500)
-- it is not clear which of the two items is the wrong one, better to
-- let the semantic phase give a clear message. Consequently, this
-- routine in general returns a list of items which can be either
-- discrete ranges or discriminant associations.
-- The caller has checked that the initial token is a left paren
-- Error recovery: can raise Error_Resync
function P_Index_Or_Discriminant_Constraint return Node_Id is
Scan_State : Saved_Scan_State;
Constr_Node : Node_Id;
Constr_List : List_Id;
Expr_Node : Node_Id;
Result_Node : Node_Id;
begin
Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr);
Scan; -- past (
Constr_List := New_List;
Set_Constraints (Result_Node, Constr_List);
-- The two syntactic forms are a little mixed up, so what we are doing
-- here is looking at the first entry to determine which case we have
-- A discriminant constraint is a list of discriminant associations,
-- which have one of the following possible forms:
-- Expression
-- Id => Expression
-- Id | Id | .. | Id => Expression
-- An index constraint is a list of discrete ranges which have one
-- of the following possible forms:
-- Subtype_Mark
-- Subtype_Mark range Range
-- Range_Attribute
-- Simple_Expression .. Simple_Expression
-- Loop through discriminants in list
loop
-- Check cases of Id => Expression or Id | Id => Expression
if Token = Tok_Identifier then
Save_Scan_State (Scan_State); -- at Id
Scan; -- past Id
if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
Restore_Scan_State (Scan_State); -- to Id
Append (P_Discriminant_Association, Constr_List);
goto Loop_Continue;
else
Restore_Scan_State (Scan_State); -- to Id
end if;
end if;
-- Otherwise scan out an expression and see what we have got
Expr_Node := P_Expression_Or_Range_Attribute;
if Expr_Form = EF_Range_Attr then
Append (Expr_Node, Constr_List);
elsif Token = Tok_Range then
if Expr_Form /= EF_Simple_Name then
Error_Msg_SC ("subtype mark required before RANGE");
end if;
Append (P_Subtype_Indication (Expr_Node), Constr_List);
goto Loop_Continue;
-- Check Simple_Expression .. Simple_Expression case
elsif Token = Tok_Dot_Dot then
Check_Simple_Expression (Expr_Node);
Constr_Node := New_Node (N_Range, Token_Ptr);
Set_Low_Bound (Constr_Node, Expr_Node);
Scan; -- past ..
-- If the upper bound is given by "<>", this is an index for
-- a fixed-lower-bound subtype, so set the expression to Empty
-- for now (it will be set to the ranges maximum upper bound
-- later during analysis), and scan to the next token.
if Token = Tok_Box then
Error_Msg_GNAT_Extension ("fixed-lower-bound array");
Expr_Node := Empty;
Scan;
-- Otherwise parse the range's upper bound expression
else
Expr_Node := P_Expression;
Check_Simple_Expression (Expr_Node);
end if;
Set_High_Bound (Constr_Node, Expr_Node);
Append (Constr_Node, Constr_List);
goto Loop_Continue;
-- Case of an expression which could be either form
else
Append (Expr_Node, Constr_List);
goto Loop_Continue;
end if;
-- Here with a single entry scanned
<<Loop_Continue>>
exit when not Comma_Present;
end loop;
T_Right_Paren;
return Result_Node;
end P_Index_Or_Discriminant_Constraint;
-------------------------------------
-- 3.7.1 Discriminant Association --
-------------------------------------
-- DISCRIMINANT_ASSOCIATION ::=
-- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
-- EXPRESSION
-- This routine is used only when the name list is present and the caller
-- has already checked this (by scanning ahead and repositioning the
-- scan).
-- Error_Recovery: cannot raise Error_Resync;
function P_Discriminant_Association return Node_Id is
Discr_Node : Node_Id;
Names_List : List_Id;
Ident_Sloc : Source_Ptr;
begin
Ident_Sloc := Token_Ptr;
Names_List := New_List;
loop
Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List);
exit when Token /= Tok_Vertical_Bar;
Scan; -- past |
end loop;
Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc);
Set_Selector_Names (Discr_Node, Names_List);
TF_Arrow;
Set_Expression (Discr_Node, P_Expression);
return Discr_Node;
end P_Discriminant_Association;
---------------------------------
-- 3.8 Record Type Definition --
---------------------------------
-- RECORD_TYPE_DEFINITION ::=
-- [[abstract] tagged] [limited] RECORD_DEFINITION
-- There is no node in the tree for a record type definition. Instead
-- a record definition node appears, with possible Abstract_Present,
-- Tagged_Present, and Limited_Present flags set appropriately.
----------------------------
-- 3.8 Record Definition --
----------------------------
-- RECORD_DEFINITION ::=
-- record
-- COMPONENT_LIST
-- end record
-- | null record
-- Note: in the case where a record definition node is used to represent
-- a record type definition, the caller sets the Tagged_Present and
-- Limited_Present flags in the resulting N_Record_Definition node as
-- required.
-- Note that the RECORD token at the start may be missing in certain
-- error situations, so this function is expected to post the error
-- Error recovery: can raise Error_Resync
function P_Record_Definition return Node_Id is
Rec_Node : Node_Id;
begin
Inside_Record_Definition := True;
Rec_Node := New_Node (N_Record_Definition, Token_Ptr);
-- Null record case
if Token = Tok_Null then
Scan; -- past NULL
T_Record;
Set_Null_Present (Rec_Node, True);
-- Catch incomplete declaration to prevent cascaded errors, see
-- ACATS B393002 for an example.
elsif Token = Tok_Semicolon then
Error_Msg_AP ("missing record definition");
-- Case starting with RECORD keyword. Build scope stack entry. For the
-- column, we use the first non-blank character on the line, to deal
-- with situations such as:
-- type X is record
-- ...
-- end record;
-- which is not official RM indentation, but is not uncommon usage, and
-- in particular is standard GNAT coding style, so handle it nicely.
else
Push_Scope_Stack;
Scopes (Scope.Last).Etyp := E_Record;
Scopes (Scope.Last).Ecol := Start_Column;
Scopes (Scope.Last).Sloc := Token_Ptr;
Scopes (Scope.Last).Labl := Error;
Scopes (Scope.Last).Junk := (Token /= Tok_Record);
T_Record;
Set_Component_List (Rec_Node, P_Component_List);
loop
exit when Check_End;
Discard_Junk_Node (P_Component_List);
end loop;
end if;
Inside_Record_Definition := False;
return Rec_Node;
end P_Record_Definition;
-------------------------
-- 3.8 Component List --
-------------------------
-- COMPONENT_LIST ::=
-- COMPONENT_ITEM {COMPONENT_ITEM}
-- | {COMPONENT_ITEM} VARIANT_PART
-- | null;
-- Error recovery: cannot raise Error_Resync
function P_Component_List return Node_Id is
Component_List_Node : Node_Id;
Decls_List : List_Id;
Scan_State : Saved_Scan_State;
Null_Loc : Source_Ptr;
begin
Component_List_Node := New_Node (N_Component_List, Token_Ptr);
Decls_List := New_List;
-- Handle null
if Token = Tok_Null then
Null_Loc := Token_Ptr;
Scan; -- past NULL
TF_Semicolon;
P_Pragmas_Opt (Decls_List);
-- If we have an END or WHEN now, everything is fine, otherwise we
-- complain about the null, ignore it, and scan for more components.
if Token = Tok_End or else Token = Tok_When then
Set_Null_Present (Component_List_Node, True);
return Component_List_Node;
else
Error_Msg ("NULL component only allowed in null record", Null_Loc);
end if;
end if;
-- Scan components for non-null record
P_Pragmas_Opt (Decls_List);
if Token /= Tok_Case then
Component_Scan_Loop : loop
P_Component_Items (Decls_List);
P_Pragmas_Opt (Decls_List);
exit Component_Scan_Loop when Token = Tok_End
or else Token = Tok_Case
or else Token = Tok_When;
-- We are done if we do not have an identifier. However, if we
-- have a misspelled reserved identifier that is in a column to
-- the right of the record definition, we will treat it as an
-- identifier. It turns out to be too dangerous in practice to
-- accept such a mis-spelled identifier which does not have this
-- additional clue that confirms the incorrect spelling.
if Token /= Tok_Identifier then
if Start_Column > Scopes (Scope.Last).Ecol
and then Is_Reserved_Identifier
then
Save_Scan_State (Scan_State); -- at reserved id
Scan; -- possible reserved id
if Token = Tok_Comma or else Token = Tok_Colon then
Restore_Scan_State (Scan_State);
Scan_Reserved_Identifier (Force_Msg => True);
-- Note reserved identifier used as field name after all
-- because not followed by colon or comma.
else
Restore_Scan_State (Scan_State);
exit Component_Scan_Loop;
end if;
-- Non-identifier that definitely was not reserved id
else
exit Component_Scan_Loop;
end if;
end if;
end loop Component_Scan_Loop;
end if;
if Token = Tok_Case then
Set_Variant_Part (Component_List_Node, P_Variant_Part);
-- Check for junk after variant part
if Token = Tok_Identifier then
Save_Scan_State (Scan_State);
Scan; -- past identifier
if Token = Tok_Colon then
Restore_Scan_State (Scan_State);
Error_Msg_SC ("component may not follow variant part");
Discard_Junk_Node (P_Component_List);
elsif Token = Tok_Case then
Restore_Scan_State (Scan_State);
Error_Msg_SC ("only one variant part allowed in a record");
Discard_Junk_Node (P_Component_List);
else
Restore_Scan_State (Scan_State);
end if;
end if;
end if;
Set_Component_Items (Component_List_Node, Decls_List);
return Component_List_Node;
end P_Component_List;
-------------------------
-- 3.8 Component Item --
-------------------------
-- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
-- COMPONENT_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
-- [:= DEFAULT_EXPRESSION]
-- [ASPECT_SPECIFICATIONS];
-- COMPONENT_DEFINITION ::=
-- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- Error recovery: cannot raise Error_Resync, if an error occurs,
-- the scan is positioned past the following semicolon.
-- Note: we do not yet allow representation clauses to appear as component
-- items, do we need to add this capability sometime in the future ???
procedure P_Component_Items (Decls : List_Id) is
Aliased_Present : Boolean := False;
CompDef_Node : Node_Id;
Decl_Node : Node_Id := Empty; -- initialize to prevent warning
Scan_State : Saved_Scan_State;
Not_Null_Present : Boolean := False;
Num_Idents : Nat;
Ident : Nat;
Ident_Sloc : Source_Ptr;
Idents : array (Int range 1 .. 4096) of Entity_Id;
-- This array holds the list of defining identifiers. The upper bound
-- of 4096 is intended to be essentially infinite, and we do not even
-- bother to check for it being exceeded.
begin
if Token /= Tok_Identifier then
Error_Msg_SC ("component declaration expected");
Resync_Past_Semicolon;
return;
end if;
Ident_Sloc := Token_Ptr;
Check_Bad_Layout;
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);
end loop;
-- If there are multiple identifiers, we repeatedly scan the
-- type and initialization expression information by resetting
-- the scan pointer (so that we get completely separate trees
-- for each occurrence).
if Num_Idents > 1 then
Save_Scan_State (Scan_State);
end if;
T_Colon;
-- Loop through defining identifiers in list
Ident := 1;
Ident_Loop : loop
-- The following block is present to catch Error_Resync
-- which causes the parse to be reset past the semicolon
begin
Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc);
Set_Defining_Identifier (Decl_Node, Idents (Ident));
if Token = Tok_Constant then
Error_Msg_SC ("constant component not permitted");
Scan;
end if;
CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
if Token_Name = Name_Aliased then
Check_95_Keyword (Tok_Aliased, Tok_Identifier);
end if;
if Token = Tok_Aliased then
Aliased_Present := True;
Scan; -- past ALIASED
end if;
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
-- Ada 2005 (AI-230): Access Definition case
if Token = Tok_Access then
Error_Msg_Ada_2005_Extension
("generalized use of anonymous access types");
-- AI95-406 makes "aliased" legal (and useless) here, so the
-- following code which used to be required is commented out.
-- if Aliased_Present then
-- Error_Msg_SP ("ALIASED not allowed here");
-- end if;
Set_Subtype_Indication (CompDef_Node, Empty);
Set_Aliased_Present (CompDef_Node, False);
Set_Access_Definition (CompDef_Node,
P_Access_Definition (Not_Null_Present));
else
Set_Access_Definition (CompDef_Node, Empty);
Set_Aliased_Present (CompDef_Node, Aliased_Present);
Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
if Token = Tok_Array then
Error_Msg_SC ("anonymous array not allowed as component");
raise Error_Resync;
end if;
Set_Subtype_Indication (CompDef_Node,
P_Subtype_Indication (Not_Null_Present));
end if;
Set_Component_Definition (Decl_Node, CompDef_Node);
Set_Expression (Decl_Node, Init_Expr_Opt);
if Ident > 1 then
Set_Prev_Ids (Decl_Node, True);
end if;
if Ident < Num_Idents then
Set_More_Ids (Decl_Node, True);
end if;
Append (Decl_Node, Decls);
exception
when Error_Resync =>
if Token /= Tok_End then
Resync_Past_Semicolon;
end if;
end;
exit Ident_Loop when Ident = Num_Idents;
Ident := Ident + 1;
Restore_Scan_State (Scan_State);
T_Colon;
end loop Ident_Loop;
P_Aspect_Specifications (Decl_Node);
end P_Component_Items;
--------------------------------
-- 3.8 Component Declaration --
--------------------------------
-- Parsed by P_Component_Items (3.8)
-------------------------
-- 3.8.1 Variant Part --
-------------------------
-- VARIANT_PART ::=
-- case discriminant_DIRECT_NAME is
-- VARIANT
-- {VARIANT}
-- end case;
-- The caller has checked that the initial token is CASE
-- Error recovery: cannot raise Error_Resync
function P_Variant_Part return Node_Id is
Variant_Part_Node : Node_Id;
Variants_List : List_Id;
Case_Node : Node_Id;
begin
Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
Push_Scope_Stack;
Scopes (Scope.Last).Etyp := E_Case;
Scopes (Scope.Last).Sloc := Token_Ptr;
Scopes (Scope.Last).Ecol := Start_Column;
Scan; -- past CASE
Case_Node := P_Expression;
Set_Name (Variant_Part_Node, Case_Node);
if Nkind (Case_Node) /= N_Identifier then
Set_Name (Variant_Part_Node, Error);
Error_Msg ("discriminant name expected", Sloc (Case_Node));
elsif Paren_Count (Case_Node) /= 0 then
Error_Msg
("|discriminant name may not be parenthesized",
Sloc (Case_Node));
Set_Paren_Count (Case_Node, 0);
end if;
TF_Is;
Variants_List := New_List;
P_Pragmas_Opt (Variants_List);
-- Test missing variant
if Token = Tok_End then
Error_Msg_BC ("WHEN expected (must have at least one variant)");
else
Append (P_Variant, Variants_List);
end if;
-- Loop through variants, note that we allow if in place of when,
-- this error will be detected and handled in P_Variant.
loop
P_Pragmas_Opt (Variants_List);
if Token /= Tok_When
and then Token /= Tok_If
and then Token /= Tok_Others
then
exit when Check_End;
end if;
Append (P_Variant, Variants_List);
end loop;
Set_Variants (Variant_Part_Node, Variants_List);
return Variant_Part_Node;
end P_Variant_Part;
--------------------
-- 3.8.1 Variant --
--------------------
-- VARIANT ::=
-- when DISCRETE_CHOICE_LIST =>
-- COMPONENT_LIST
-- Error recovery: cannot raise Error_Resync
-- The initial token on entry is either WHEN, IF or OTHERS
function P_Variant return Node_Id is
Variant_Node : Node_Id;
begin
-- Special check to recover nicely from use of IF in place of WHEN
if Token = Tok_If then
T_When;
Scan; -- past IF
else
T_When;
end if;
Variant_Node := New_Node (N_Variant, Prev_Token_Ptr);
Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List);
TF_Arrow;
Set_Component_List (Variant_Node, P_Component_List);
return Variant_Node;
end P_Variant;
---------------------------------
-- 3.8.1 Discrete Choice List --
---------------------------------
-- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
-- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
-- Note: in Ada 83, the expression must be a simple expression
-- Error recovery: cannot raise Error_Resync
function P_Discrete_Choice_List return List_Id is
Choices : List_Id;
Expr_Node : Node_Id := Empty; -- initialize to prevent warning
Choice_Node : Node_Id;
begin
Choices := New_List;
loop
if Token = Tok_Others then
Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
Scan; -- past OTHERS
else
begin
-- Scan out expression or range attribute
Expr_Node := P_Expression_Or_Range_Attribute;
Ignore (Tok_Right_Paren);
if Token = Tok_Colon
and then Nkind (Expr_Node) = N_Identifier
then
Error_Msg_SP ("label not permitted in this context");
Scan; -- past colon
-- Range attribute
elsif Expr_Form = EF_Range_Attr then
Append (Expr_Node, Choices);
-- Explicit range
elsif Token = Tok_Dot_Dot then
Check_Simple_Expression (Expr_Node);
Choice_Node := New_Node (N_Range, Token_Ptr);
Set_Low_Bound (Choice_Node, Expr_Node);
Scan; -- past ..
Expr_Node := P_Expression_No_Right_Paren;
Check_Simple_Expression (Expr_Node);
Set_High_Bound (Choice_Node, Expr_Node);
Append (Choice_Node, Choices);
-- Simple name, must be subtype, so range allowed
elsif Expr_Form = EF_Simple_Name then
if Token = Tok_Range then
Append (P_Subtype_Indication (Expr_Node), Choices);
elsif Token in Token_Class_Consk then
Error_Msg_SC
("the only constraint allowed here " &
"is a range constraint");
Discard_Junk_Node (P_Constraint_Opt);
Append (Expr_Node, Choices);
else
Append (Expr_Node, Choices);
end if;
-- Expression
else
-- In Ada 2012 mode, the expression must be a simple
-- expression. The reason for this restriction (i.e. going
-- back to the Ada 83 rule) is to avoid ambiguities when set
-- membership operations are allowed, consider the
-- following:
-- when A in 1 .. 10 | 12 =>
-- This is ambiguous without parentheses, so we require one
-- of the following two parenthesized forms to disambiguate:
-- one of the following:
-- when (A in 1 .. 10 | 12) =>
-- when (A in 1 .. 10) | 12 =>
-- To solve this, in Ada 2012 mode, we disallow the use of
-- membership operations in expressions in choices.
-- Technically in the grammar, the expression must match the
-- grammar for restricted expression.
if Ada_Version >= Ada_2012 then
Check_Restricted_Expression (Expr_Node);
-- In Ada 83 mode, the syntax required a simple expression
else
Check_Simple_Expression_In_Ada_83 (Expr_Node);
end if;
Append (Expr_Node, Choices);
end if;
exception
when Error_Resync =>
Resync_Choice;
return Error_List;
end;
end if;
if Token = Tok_Comma then
if Nkind (Expr_Node) = N_Iterated_Component_Association then
return Choices;
end if;
Scan; -- past comma
if Token = Tok_Vertical_Bar then
Error_Msg_SP -- CODEFIX
("|extra "","" ignored");
Scan; -- past |
else
Error_Msg_SP -- CODEFIX
(""","" should be ""'|""");
end if;
else
exit when Token /= Tok_Vertical_Bar;
Scan; -- past |
end if;
end loop;
return Choices;
end P_Discrete_Choice_List;
----------------------------
-- 3.8.1 Discrete Choice --
----------------------------
-- Parsed by P_Discrete_Choice_List (3.8.1)
----------------------------------
-- 3.9.1 Record Extension Part --
----------------------------------
-- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
-- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
--------------------------------------
-- 3.9.4 Interface Type Definition --
--------------------------------------
-- INTERFACE_TYPE_DEFINITION ::=
-- [limited | task | protected | synchronized] interface
-- [and INTERFACE_LIST]
-- Error recovery: cannot raise Error_Resync
function P_Interface_Type_Definition
(Abstract_Present : Boolean) return Node_Id
is
Typedef_Node : Node_Id;
begin
Error_Msg_Ada_2005_Extension ("abstract interface");
if Abstract_Present then
Error_Msg_SP
("ABSTRACT not allowed in interface type definition " &
"(RM 3.9.4(2/2))");
end if;
Scan; -- past INTERFACE
-- Ada 2005 (AI-345): In case of interfaces with a null list of
-- interfaces we build a record_definition node.
if Token = Tok_Semicolon or else Aspect_Specifications_Present then
Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
Set_Abstract_Present (Typedef_Node);
Set_Tagged_Present (Typedef_Node);
Set_Null_Present (Typedef_Node);
Set_Interface_Present (Typedef_Node);
-- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
-- a list of interfaces we build a derived_type_definition node. This
-- simplifies the semantic analysis (and hence further maintenance)
else
if Token /= Tok_And then
Error_Msg_AP ("AND expected");
else
Scan; -- past AND
end if;
Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
Set_Abstract_Present (Typedef_Node);
Set_Interface_Present (Typedef_Node);
Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
Set_Record_Extension_Part (Typedef_Node,
New_Node (N_Record_Definition, Token_Ptr));
Set_Null_Present (Record_Extension_Part (Typedef_Node));
if Token = Tok_And then
Set_Interface_List (Typedef_Node, New_List);
Scan; -- past AND
loop
Append (P_Qualified_Simple_Name,
Interface_List (Typedef_Node));
exit when Token /= Tok_And;
Scan; -- past AND
end loop;
end if;
end if;
return Typedef_Node;
end P_Interface_Type_Definition;
----------------------------------
-- 3.10 Access Type Definition --
----------------------------------
-- ACCESS_TYPE_DEFINITION ::=
-- ACCESS_TO_OBJECT_DEFINITION
-- | ACCESS_TO_SUBPROGRAM_DEFINITION
-- ACCESS_TO_OBJECT_DEFINITION ::=
-- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
-- GENERAL_ACCESS_MODIFIER ::= all | constant
-- ACCESS_TO_SUBPROGRAM_DEFINITION
-- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
-- | [NULL_EXCLUSION] access [protected] function
-- PARAMETER_AND_RESULT_PROFILE
-- PARAMETER_PROFILE ::= [FORMAL_PART]
-- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
-- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
-- parsed the null_exclusion part and has also removed the ACCESS token;
-- otherwise the caller has just checked that the initial token is ACCESS
-- Error recovery: can raise Error_Resync
function P_Access_Type_Definition
(Header_Already_Parsed : Boolean := False) return Node_Id
is
procedure Check_Junk_Subprogram_Name;
-- Used in access to subprogram definition cases to check for an
-- identifier or operator symbol that does not belong.
--------------------------------
-- Check_Junk_Subprogram_Name --
--------------------------------
procedure Check_Junk_Subprogram_Name is
Saved_State : Saved_Scan_State;
begin
if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
Save_Scan_State (Saved_State);
Scan; -- past possible junk subprogram name
if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
Error_Msg_SP ("unexpected subprogram name ignored");
return;
else
Restore_Scan_State (Saved_State);
end if;
end if;
end Check_Junk_Subprogram_Name;
Access_Loc : constant Source_Ptr := Token_Ptr;
Prot_Flag : Boolean;
Not_Null_Present : Boolean := False;
Not_Null_Subtype : Boolean := False;
Not_Null_Subtype_Loc : Source_Ptr; -- loc of second "not null"
Type_Def_Node : Node_Id;
Result_Not_Null : Boolean;
Result_Node : Node_Id;
-- Start of processing for P_Access_Type_Definition
begin
if not Header_Already_Parsed then
-- NOT NULL ACCESS... is a common form of access definition. ACCESS
-- NOT NULL... is certainly rare, but syntactically legal. NOT NULL
-- ACCESS NOT NULL... is rarer yet, and also legal. The last two
-- cases are only meaningful if the following subtype indication
-- denotes an access type. We check below for "not null procedure"
-- and "not null function"; in the access-to-object case it is a
-- semantic check. The flag Not_Null_Subtype indicates that this
-- second null exclusion is present in the access type definition.
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
Scan; -- past ACCESS
Not_Null_Subtype_Loc := Token_Ptr;
Not_Null_Subtype := P_Null_Exclusion; -- Might also appear
end if;
if Token_Name = Name_Protected then
Check_95_Keyword (Tok_Protected, Tok_Procedure);
Check_95_Keyword (Tok_Protected, Tok_Function);
end if;
Prot_Flag := (Token = Tok_Protected);
if Prot_Flag then
Scan; -- past PROTECTED
if Token /= Tok_Procedure and then Token /= Tok_Function then
Error_Msg_SC -- CODEFIX
("FUNCTION or PROCEDURE expected");
end if;
end if;
-- Access-to-subprogram case
if Token in Tok_Procedure | Tok_Function then
-- Check for "not null [protected] procedure" and "not null
-- [protected] function".
if Not_Null_Subtype then
Error_Msg
("null exclusion must apply to access type",
Not_Null_Subtype_Loc);
end if;
end if;
if Token = Tok_Procedure then
if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
end if;
Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc);
Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
Scan; -- past PROCEDURE
Check_Junk_Subprogram_Name;
Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
Set_Protected_Present (Type_Def_Node, Prot_Flag);
elsif Token = Tok_Function then
if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) access to function not allowed!");
end if;
Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc);
Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
Scan; -- past FUNCTION
Check_Junk_Subprogram_Name;
Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
Set_Protected_Present (Type_Def_Node, Prot_Flag);
TF_Return;
Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231)
-- Ada 2005 (AI-318-02)
if Token = Tok_Access then
Error_Msg_Ada_2005_Extension ("anonymous access result type");
Result_Node := P_Access_Definition (Result_Not_Null);
else
Result_Node := P_Subtype_Mark;
No_Constraint;
-- A null exclusion on the result type must be recorded in a flag
-- distinct from the one used for the access-to-subprogram type's
-- null exclusion.
Set_Null_Exclusion_In_Return_Present
(Type_Def_Node, Result_Not_Null);
end if;
Set_Result_Definition (Type_Def_Node, Result_Node);
-- Access-to-object case
else
Type_Def_Node := New_Node (N_Access_To_Object_Definition, Access_Loc);
Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
Set_Null_Excluding_Subtype (Type_Def_Node, Not_Null_Subtype);
if Token = Tok_All or else Token = Tok_Constant then
if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) access modifier not allowed!");
end if;
if Token = Tok_All then
Set_All_Present (Type_Def_Node, True);
else
Set_Constant_Present (Type_Def_Node, True);
end if;
Scan; -- past ALL or CONSTANT
end if;
Set_Subtype_Indication (Type_Def_Node,
P_Subtype_Indication (Not_Null_Present));
end if;
return Type_Def_Node;
end P_Access_Type_Definition;
---------------------------------------
-- 3.10 Access To Object Definition --
---------------------------------------
-- Parsed by P_Access_Type_Definition (3.10)
-----------------------------------
-- 3.10 General Access Modifier --
-----------------------------------
-- Parsed by P_Access_Type_Definition (3.10)
-------------------------------------------
-- 3.10 Access To Subprogram Definition --
-------------------------------------------
-- Parsed by P_Access_Type_Definition (3.10)
-----------------------------
-- 3.10 Access Definition --
-----------------------------
-- ACCESS_DEFINITION ::=
-- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
-- | ACCESS_TO_SUBPROGRAM_DEFINITION
--
-- ACCESS_TO_SUBPROGRAM_DEFINITION
-- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
-- | [NULL_EXCLUSION] access [protected] function
-- PARAMETER_AND_RESULT_PROFILE