-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
separate (Par)
+---------
+-- Ch3 --
+---------
+
package body Ch3 is
-----------------------
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;
-- 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_In (N, 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_In (N, 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 --
-------------------
-- we set Force_Msg to True, since we want at least one message for each
-- separate declaration (but not use) of a reserved identifier.
- if Token = Tok_Identifier then
-
- -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
- -- OVERRIDING, and SYNCHRONIZED are new reserved words.
+ -- Duplication should be removed, common code should be factored???
- if Ada_Version = Ada_95
- and then Warn_On_Ada_2005_Compatibility
- then
- if Token_Name = Name_Overriding
- or else Token_Name = Name_Synchronized
- or else (Token_Name = Name_Interface
- and then Prev_Token /= Tok_Pragma)
- then
- Error_Msg_N ("& is a reserved word in Ada 2005?", Token_Node);
- end if;
- end if;
+ if Token = Tok_Identifier then
+ Check_Future_Keyword;
-- If we have a reserved identifier, manufacture an identifier with
-- a corresponding name after posting an appropriate error message
Ident_Node := Token_Node;
Scan; -- past the reserved identifier
+ -- 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);
end if;
-- | PRIVATE_EXTENSION_DECLARATION
-- FULL_TYPE_DECLARATION ::=
- -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
+ -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION
+ -- [ASPECT_SPECIFICATIONS];
-- | CONCURRENT_TYPE_DECLARATION
-- INCOMPLETE_TYPE_DECLARATION ::=
-- Error recovery: can raise Error_Resync
- -- Note: The processing for full type declaration, incomplete type
- -- declaration, private type declaration and type definition is
- -- included in this function. The processing for concurrent type
- -- declarations is NOT here, but rather in chapter 9 (i.e. this
- -- function handles only declarations starting with TYPE).
+ -- 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;
Type_Start_Col : Column_Number;
Unknown_Dis : Boolean;
- Typedef_Node : Node_Id;
+ 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
Scan; -- past TYPE
Ident_Node := P_Defining_Identifier (C_Is);
- -- Otherwise this is an error case, and we may already have converted
- -- the current token to a defining identifier, so don't do it again!
+ -- Otherwise this is an error case
else
T_Type;
-
- if Token = Tok_Identifier
- and then Nkind (Token_Node) = N_Defining_Identifier
- then
- Ident_Node := Token_Node;
- Scan; -- past defining identifier
- else
- Ident_Node := P_Defining_Identifier (C_Is);
- end if;
+ Type_Token_Location := Type_Loc;
+ Ident_Node := P_Defining_Identifier (C_Is);
end if;
Discr_Sloc := Token_Ptr;
Scan; -- past = used in place of IS
elsif Token = Tok_Renames then
- Error_Msg_SC ("RENAMES should be IS");
+ Error_Msg_SC -- CODEFIX
+ ("RENAMES should be IS");
Scan; -- past RENAMES used in place of IS
else
-- Ada 2005 (AI-419): AARM 3.4 (2/2)
- if (Ada_Version < Ada_05 and then Token = Tok_Limited)
+ 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
Scan; -- past ALIASED
end if;
- -- The following procesing deals with either a private type declaration
+ -- 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
when Tok_Access |
Tok_Not => -- Ada 2005 (AI-231)
Typedef_Node := P_Access_Type_Definition;
- TF_Semicolon;
exit;
when Tok_Array =>
Typedef_Node := P_Array_Type_Definition;
- TF_Semicolon;
exit;
when Tok_Delta =>
Typedef_Node := P_Fixed_Point_Definition;
- TF_Semicolon;
exit;
when Tok_Digits =>
Typedef_Node := P_Floating_Point_Definition;
- TF_Semicolon;
exit;
when Tok_In =>
when Tok_Integer_Literal =>
T_Range;
Typedef_Node := P_Signed_Integer_Type_Definition;
- TF_Semicolon;
exit;
when Tok_Null =>
Typedef_Node := P_Record_Definition;
- TF_Semicolon;
exit;
when Tok_Left_Paren =>
Typedef_Node := P_Enumeration_Type_Definition;
- End_Labl :=
- Make_Identifier (Token_Ptr,
- Chars => Chars (Ident_Node));
+ End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label (Typedef_Node, End_Labl);
- TF_Semicolon;
exit;
when Tok_Mod =>
Typedef_Node := P_Modular_Type_Definition;
- TF_Semicolon;
exit;
when Tok_New =>
if Nkind (Typedef_Node) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Typedef_Node))
then
- End_Labl :=
- Make_Identifier (Token_Ptr,
- Chars => Chars (Ident_Node));
+ 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;
- TF_Semicolon;
exit;
when Tok_Range =>
Typedef_Node := P_Signed_Integer_Type_Definition;
- TF_Semicolon;
exit;
when Tok_Record =>
Typedef_Node := P_Record_Definition;
- End_Labl :=
- Make_Identifier (Token_Ptr,
- Chars => Chars (Ident_Node));
+ End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label (Typedef_Node, End_Labl);
- TF_Semicolon;
exit;
when Tok_Tagged =>
-- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
-- is a tagged incomplete type.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Token = Tok_Semicolon
then
Scan; -- past ;
end if;
if Token = Tok_Abstract then
- Error_Msg_SC ("ABSTRACT must come before TAGGED");
+ Error_Msg_SC -- CODEFIX
+ ("ABSTRACT must come before TAGGED");
Abstract_Present := True;
Abstract_Loc := Token_Ptr;
Scan; -- past ABSTRACT
Set_Limited_Present (Typedef_Node, True);
End_Labl :=
- Make_Identifier (Token_Ptr,
- Chars => Chars (Ident_Node));
+ Make_Identifier (Token_Ptr, Chars (Ident_Node));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label (Typedef_Node, End_Labl);
Set_Tagged_Present (Typedef_Node, True);
End_Labl :=
- Make_Identifier (Token_Ptr,
- Chars => Chars (Ident_Node));
+ 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;
- TF_Semicolon;
exit;
when Tok_Limited =>
loop
if Token = Tok_Tagged then
- Error_Msg_SC ("TAGGED must come before LIMITED");
+ Error_Msg_SC -- CODEFIX
+ ("TAGGED must come before LIMITED");
Scan; -- past TAGGED
elsif Token = Tok_Abstract then
- Error_Msg_SC ("ABSTRACT must come before LIMITED");
+ Error_Msg_SC -- CODEFIX
+ ("ABSTRACT must come before LIMITED");
Scan; -- past ABSTRACT
else
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;
-- Ada 2005 (AI-419): LIMITED NEW
elsif Token = Tok_New then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP
("LIMITED in derived type is an Ada 2005 extension");
Error_Msg_SP
and then Present (Record_Extension_Part (Typedef_Node))
then
End_Labl :=
- Make_Identifier (Token_Ptr,
- Chars => Chars (Ident_Node));
+ Make_Identifier (Token_Ptr, Chars (Ident_Node));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label
T_Private; -- past PRIVATE (or complain if not there!)
end if;
- TF_Semicolon;
exit;
-- Here we have an identifier after the IS, which is certainly
if not Token_Is_At_Start_Of_Line then
Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
- TF_Semicolon;
-- If the identifier is at the start of the line, and is in the
-- same column as the type declaration itself then we consider
else
Typedef_Node := P_Record_Definition;
- TF_Semicolon;
end if;
exit;
when Tok_Interface =>
Typedef_Node := P_Interface_Type_Definition (Abstract_Present);
Abstract_Present := True;
- TF_Semicolon;
exit;
when Tok_Private =>
Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
Scan; -- past PRIVATE
- TF_Semicolon;
+
+ -- 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
Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
if Saved_Token = Tok_Synchronized then
- Set_Synchronized_Present (Typedef_Node);
+ 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;
end if;
end;
- TF_Semicolon;
exit;
-- Anything else is an error
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;
--------------------------------
-- SUBTYPE_DECLARATION ::=
- -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
+ -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION
+ -- {ASPECT_SPECIFICATIONS];
-- The caller has checked that the initial token is SUBTYPE
TF_Is;
if Token = Tok_New then
- Error_Msg_SC ("NEW ignored (only allowed in type declaration)");
+ Error_Msg_SC -- CODEFIX
+ ("NEW ignored (only allowed in type declaration)");
Scan; -- past NEW
end if;
Set_Subtype_Indication
(Decl_Node, P_Subtype_Indication (Not_Null_Present));
- TF_Semicolon;
+ P_Aspect_Specifications (Decl_Node);
return Decl_Node;
end P_Subtype_Declaration;
-- access ..." is legal in Ada 95, whereas "Formal : not null
-- Named_Access_Type" is not.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
or else (Ada_Version >= Ada_95
and then Allow_Anonymous_In_95
and then Token = Tok_Access)
begin
Constr_Node := P_Constraint_Opt;
- if No (Constr_Node) then
+ 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
Make_Attribute_Reference (Prev_Token_Ptr,
Prefix => Prefix,
Attribute_Name => Token_Name);
- Delete_Node (Token_Node);
Scan; -- past type attribute identifier
end if;
-- OBJECT_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
- -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
+ -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]
+ -- [ASPECT_SPECIFICATIONS];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
- -- ACCESS_DEFINITION [:= EXPRESSION];
+ -- ACCESS_DEFINITION [:= EXPRESSION]
+ -- [ASPECT_SPECIFICATIONS];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
- -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
+ -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]
+ -- [ASPECT_SPECIFICATIONS];
-- NUMBER_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
-- DEFINING_IDENTIFIER : exception renames exception_NAME;
-- EXCEPTION_DECLARATION ::=
- -- DEFINING_IDENTIFIER_LIST : exception;
+ -- DEFINING_IDENTIFIER_LIST : exception
+ -- [ASPECT_SPECIFICATIONS];
-- Note that the ALIASED indication in an object declaration is
-- marked by a flag in the parent node.
-- 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 ("identifier list not allowed for RENAMES",
- Sloc (Idents (2)));
+ Error_Msg
+ ("identifier list not allowed for RENAMES",
+ Sloc (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;
Check_Misspelling_Of (Tok_Renames);
if Token = Tok_Renames then
- Error_Msg_SP ("extra "":"" ignored");
+ Error_Msg_SP -- CODEFIX
+ ("|extra "":"" ignored");
Scan; -- past RENAMES
return True;
else
-- 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 if;
if Token = Tok_Aliased then
- Error_Msg_SC ("ALIASED should be before CONSTANT");
+ Error_Msg_SC -- CODEFIX
+ ("ALIASED should be before CONSTANT");
Scan; -- past ALIASED
Set_Aliased_Present (Decl_Node, True);
end if;
Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
if Token = Tok_Access then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP
("generalized use of anonymous access types " &
"is an Ada 2005 extension");
-- Access definition (AI-406) or subtype indication
if Token = Tok_Access then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP
("generalized use of anonymous access types " &
"is an Ada 2005 extension");
Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423)
if Token = Tok_Access then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP
("generalized use of anonymous access types " &
"is an Ada 2005 extension");
-- Object renaming declaration
if Token_Is_Renames then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP
("`NOT NULL` not allowed in object renaming");
raise Error_Resync;
-- illegal
if Token_Is_Renames then
- Error_Msg_N ("constraint not allowed in object renaming "
- & "declaration",
- Constraint (Object_Definition (Decl_Node)));
+ Error_Msg_N
+ ("constraint not allowed in object renaming "
+ & "declaration",
+ Constraint (Object_Definition (Decl_Node)));
raise Error_Resync;
end if;
end if;
-- Ada 2005 (AI-230): Access Definition case
elsif Token = Tok_Access then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP
("generalized use of anonymous access types " &
"is an Ada 2005 extension");
end if;
end if;
- TF_Semicolon;
Set_Defining_Identifier (Decl_Node, Idents (Ident));
+ P_Aspect_Specifications (Decl_Node);
if List_OK then
if Ident < Num_Idents then
begin
Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
- if Ada_Version < Ada_05
+ if Ada_Version < Ada_2005
and then Token = Tok_Identifier
and then Token_Name = Name_Interface
then
end if;
if Token = Tok_Abstract then
- Error_Msg_SC ("ABSTRACT must come before NEW, not after");
+ Error_Msg_SC -- CODEFIX
+ ("ABSTRACT must come before NEW, not after");
Scan;
end if;
if Token = Tok_And then
Scan; -- past AND
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP
("abstract interface is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
-- missing in the case of "type X is new Y record ..." or in the
-- case of "type X is new Y null record".
- if Token = Tok_With
+ -- 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");
+ Error_Msg_SC ("LIMITED keyword not allowed in private extension");
Scan; -- ignore LIMITED
end if;
Abstract_Present => Abstract_Present (Typedef_Node),
Interface_List => Interface_List (Typedef_Node));
- Delete_Node (Typedef_Node);
return Typedecl_Node;
-- Derived type definition with record extension part
-- Error recovery: cannot raise Error_Resync
- function P_Range_Or_Subtype_Mark return Node_Id is
+ 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;
-- 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.
+ -- 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;
return Range_Node;
-- Case of subtype mark (optionally qualified simple name or an
- -- attribute whose prefix is an optionally qualifed simple name)
+ -- attribute whose prefix is an optionally qualified simple name)
elsif Expr_Form = EF_Simple_Name
or else Nkind (Expr_Node) = N_Attribute_Reference
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.
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 RANGE
end if;
- Expr_Node := P_Expression;
- 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);
+ 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;
-- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
if Token = Tok_Delta then
- Error_Msg_SC ("DELTA must come before DIGITS");
+ 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);
-- 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
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
-- Ada 2005 (AI-230): Access Definition case
if Token = Tok_Access then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP
("generalized use of anonymous access types " &
"is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
- if Aliased_Present then
- Error_Msg_SP ("ALIASED not allowed here");
- end if;
+ -- 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, False);
Set_High_Bound (Range_Node, Expr_Node);
return Range_Node;
- -- Otherwise we must have a subtype mark
+ -- 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
Scan_State : Saved_Scan_State;
begin
- if Token /= Tok_Left_Paren then
+ -- 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
- if Ada_Version = Ada_83 then
- Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
- end if;
-
- Scan; -- past the box
- T_Right_Paren; -- must be followed by right paren
- return True;
-
- else
+ 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;
----------------------------------
end P_Known_Discriminant_Part_Opt;
-------------------------------------
- -- 3.7 DIscriminant Specification --
+ -- 3.7 Discriminant Specification --
-------------------------------------
-- Parsed by P_Known_Discriminant_Part_Opt (3.7)
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:
-- ...
-- end record;
- -- which is not official RM indentation, but is not uncommon usage
+ -- 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;
-- COMPONENT_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
- -- [:= DEFAULT_EXPRESSION];
+ -- [:= DEFAULT_EXPRESSION]
+ -- [ASPECT_SPECIFICATIONS];
-- COMPONENT_DEFINITION ::=
-- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- Ada 2005 (AI-230): Access Definition case
if Token = Tok_Access then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP
("generalized use of anonymous access types " &
"is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
- if Aliased_Present then
- Error_Msg_SP ("ALIASED not allowed here");
- end if;
+ -- 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_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
if Token = Tok_Array then
- Error_Msg_SC
- ("anonymous arrays not allowed as components");
+ Error_Msg_SC ("anonymous arrays not allowed as components");
raise Error_Resync;
end if;
Ident := Ident + 1;
Restore_Scan_State (Scan_State);
T_Colon;
-
end loop Ident_Loop;
- TF_Semicolon;
+ P_Aspect_Specifications (Decl_Node);
end P_Component_Items;
--------------------------------
Variant_Part_Node : Node_Id;
Variants_List : List_Id;
Case_Node : Node_Id;
- Ident_Token : Token_Type;
begin
Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
Scope.Table (Scope.Last).Ecol := Start_Column;
Scan; -- past CASE
-
- -- A discriminant name between parentheses will be returned as
- -- a N_Identifier although it is not allowed by RM 3.8.1. We
- -- save the token type to check it later. However, in case of
- -- a discriminant name with parentheses, we can continue the
- -- analysis as if only the discriminant name had been given.
-
- Ident_Token := Token;
Case_Node := P_Expression;
+ Set_Name (Variant_Part_Node, Case_Node);
- if Nkind (Case_Node) = N_Identifier then
- Set_Name (Variant_Part_Node, Case_Node);
- else
+ if Nkind (Case_Node) /= N_Identifier then
Set_Name (Variant_Part_Node, Error);
- end if;
-
- if Nkind (Case_Node) /= N_Identifier
- or else Ident_Token /= Tok_Identifier
- then
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;
begin
Choices := New_List;
-
loop
if Token = Tok_Others then
Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
else
begin
+ -- Scan out expression or range attribute
+
Expr_Node := P_Expression_Or_Range_Attribute;
- Check_No_Right_Paren;
+ Ignore (Tok_Right_Paren);
if Token = Tok_Colon
and then Nkind (Expr_Node) = N_Identifier
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_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");
+ ("the only constraint allowed here " &
+ "is a range constraint");
Discard_Junk_Node (P_Constraint_Opt);
Append (Expr_Node, Choices);
Append (Expr_Node, Choices);
end if;
+ -- Expression
+
else
- Check_Simple_Expression_In_Ada_83 (Expr_Node);
+ -- 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;
end if;
if Token = Tok_Comma then
- Error_Msg_SC (""","" should be ""'|""");
+ 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;
- Scan; -- past | or comma
end loop;
return Choices;
Typedef_Node : Node_Id;
begin
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP ("abstract interface is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
if Abstract_Present then
- Error_Msg_SP ("ABSTRACT not allowed in interface type definition " &
- "(RM 3.9.4(2/2))");
+ 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 then
+ if Token = Tok_Semicolon or else Aspect_Specifications_Present then
Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
Set_Abstract_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 mainteinance)
+ -- simplifies the semantic analysis (and hence further maintenance)
else
if Token /= Tok_And then
Scan; -- past PROTECTED
if Token /= Tok_Procedure and then Token /= Tok_Function then
- Error_Msg_SC ("FUNCTION or PROCEDURE expected");
+ Error_Msg_SC -- CODEFIX
+ ("FUNCTION or PROCEDURE expected");
end if;
end if;
-- Ada 2005 (AI-318-02)
if Token = Tok_Access then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SC
("anonymous access result type is an Ada 2005 extension");
Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
else
Result_Node := P_Subtype_Mark;
No_Constraint;
- end if;
- -- Note: A null exclusion given on the result type needs to
- -- be coded by a distinct flag, since Null_Exclusion_Present
- -- on an access-to-function type pertains to a null exclusion
- -- on the access type itself (as set above). ???
- -- Set_Null_Exclusion_Present??? (Type_Def_Node, Result_Not_Null);
+ -- 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);
or else Token = Tok_Procedure
or else Token = Tok_Function
then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension");
Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
end if;
Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present);
if Token = Tok_All then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP
- ("access-all in this context is an Ada 2005 extension");
- Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
+ ("ALL is not permitted for anonymous access types");
end if;
Scan; -- past ALL
Set_All_Present (Def_Node);
elsif Token = Tok_Constant then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_SP ("access-to-constant is an Ada 2005 extension");
Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
end if;
when Tok_Function =>
Check_Bad_Layout;
- Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+ Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Done := False;
when Tok_For =>
when Tok_Identifier =>
Check_Bad_Layout;
- P_Identifier_Declarations (Decls, Done, In_Spec);
- -- Ada2005: A subprogram declaration can start with "not" or
+ -- Special check for misuse of overriding not in Ada 2005 mode
+
+ if Token_Name = Name_Overriding
+ and then not Next_Token_Is (Tok_Colon)
+ then
+ Error_Msg_SC ("overriding indicator is an Ada 2005 extension");
+ Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
+
+ Token := Tok_Overriding;
+ Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
+ Done := False;
+
+ -- Normal case, no overriding, or overriding followed by colon
+
+ else
+ P_Identifier_Declarations (Decls, Done, In_Spec);
+ end if;
+
+ -- Ada 2005: A subprogram declaration can start with "not" or
-- "overriding". In older versions, "overriding" is handled
- -- like an identifier, with the appropriate warning.
+ -- like an identifier, with the appropriate messages.
when Tok_Not =>
Check_Bad_Layout;
- Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+ Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Done := False;
when Tok_Overriding =>
Check_Bad_Layout;
- Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+ Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Done := False;
when Tok_Package =>
Check_Bad_Layout;
- Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+ Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Done := False;
when Tok_Pragma =>
when Tok_Procedure =>
Check_Bad_Layout;
- Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+ Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Done := False;
when Tok_Protected =>
when Tok_With =>
Check_Bad_Layout;
- Error_Msg_SC ("WITH can only appear in context clause");
- raise Error_Resync;
+
+ if Aspect_Specifications_Present then
+
+ -- If we are after a semicolon, complain that it was ignored.
+ -- But we don't really ignore it, since we dump the aspects,
+ -- so we make the error message a normal fatal message which
+ -- will inhibit semantic analysis anyway).
+
+ if Prev_Token = Tok_Semicolon then
+ Error_Msg_SP -- CODEFIX
+ ("extra "";"" ignored");
+
+ -- If not just past semicolon, just complain that aspects are
+ -- not allowed at this point.
+
+ else
+ Error_Msg_SC ("aspect specifications not allowed here");
+ end if;
+
+ declare
+ Dummy_Node : constant Node_Id :=
+ New_Node (N_Package_Specification, Token_Ptr);
+ pragma Warnings (Off, Dummy_Node);
+ -- Dummy node to attach aspect specifications to. We will
+ -- then throw them away.
+
+ begin
+ P_Aspect_Specifications (Dummy_Node, Semicolon => True);
+ end;
+
+ -- Here if not aspect specifications case
+
+ else
+ Error_Msg_SC ("WITH can only appear in context clause");
+ raise Error_Resync;
+ end if;
-- BEGIN terminates the scan of a sequence of declarations unless
-- there is a missing subprogram body, see section on handling
-- Otherwise we saved the semicolon position, so complain
else
- Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
+ Error_Msg -- CODEFIX
+ ("|"";"" should be IS", SIS_Semicolon_Sloc);
end if;
-- The next job is to fix up any declarations that occurred
Done := True;
end if;
- -- Normally an END terminates the scan for basic declarative
- -- items. The one exception is END RECORD, which is probably
- -- left over from some other junk.
+ -- Normally an END terminates the scan for basic declarative items.
+ -- The one exception is END RECORD, which is probably left over from
+ -- some other junk.
- when Tok_End =>
- Save_Scan_State (Scan_State); -- at END
- Scan; -- past END
+ when Tok_End =>
+ Save_Scan_State (Scan_State); -- at END
+ Scan; -- past END
- if Token = Tok_Record then
- Error_Msg_SP ("no RECORD for this `end record`!");
- Scan; -- past RECORD
- TF_Semicolon;
+ if Token = Tok_Record then
+ Error_Msg_SP ("no RECORD for this `end record`!");
+ Scan; -- past RECORD
+ TF_Semicolon;
- else
- Restore_Scan_State (Scan_State); -- to END
- Done := True;
- end if;
+ else
+ Restore_Scan_State (Scan_State); -- to END
+ Done := True;
+ end if;
-- The following tokens which can only be the start of a statement
-- are considered to end a declarative part (i.e. we have a missing
Kind = N_Task_Body or else
Kind = N_Protected_Body
then
- Error_Msg
- ("proper body not allowed in package spec", Sloc (Decl));
+ Error_Msg ("proper body not allowed in package spec", Sloc (Decl));
-- Test for body stub scanned, not acceptable as basic decl item
elsif Kind in N_Body_Stub then
- Error_Msg
- ("body stub not allowed in package spec", Sloc (Decl));
+ Error_Msg ("body stub not allowed in package spec", Sloc (Decl));
elsif Kind = N_Assignment_Statement then
Error_Msg
OSDN Git Service
