-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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 2, or (at your option) any later ver- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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. --
Scan; -- past GENERIC
if Token = Tok_Private then
- Error_Msg_SC ("PRIVATE goes before GENERIC, not after");
+ Error_Msg_SC -- CODEFIX
+ ("PRIVATE goes before GENERIC, not after");
Scan; -- past junk PRIVATE token
end if;
Decl_Loop : loop
P_Pragmas_Opt (Decls);
- Ignore (Tok_Private);
+
+ if Token = Tok_Private then
+ Error_Msg_S ("generic private child packages not permitted");
+ Scan; -- past PRIVATE
+ end if;
if Token = Tok_Use then
Append (P_Use_Clause, Decls);
Append (P_Formal_Subprogram_Declaration, Decls);
else
- Error_Msg_BC
+ Error_Msg_BC -- CODEFIX
("FUNCTION, PROCEDURE or PACKAGE expected here");
Resync_Past_Semicolon;
end if;
begin
Generic_Assoc_Node := New_Node (N_Generic_Association, Token_Ptr);
+ -- Ada2005: an association can be given by: others => <>
+
+ if Token = Tok_Others then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("partial parametrization of formal packages" &
+ " is an Ada 2005 extension");
+ Error_Msg_SP
+ ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Scan; -- past OTHERS
+
+ if Token /= Tok_Arrow then
+ Error_Msg_BC ("expect arrow after others");
+ else
+ Scan; -- past arrow
+ end if;
+
+ if Token /= Tok_Box then
+ Error_Msg_BC ("expect Box after arrow");
+ else
+ Scan; -- past box
+ end if;
+
+ -- Source position of the others choice is beginning of construct
+
+ return New_Node (N_Others_Choice, Sloc (Generic_Assoc_Node));
+ end if;
+
if Token in Token_Class_Desig then
Param_Name_Node := Token_Node;
Save_Scan_State (Scan_State); -- at designator
end if;
end if;
- Set_Explicit_Generic_Actual_Parameter (Generic_Assoc_Node, P_Expression);
+ -- In Ada 2005 the actual can be a box
+
+ if Token = Tok_Box then
+ Scan;
+ Set_Box_Present (Generic_Assoc_Node);
+ Set_Explicit_Generic_Actual_Parameter (Generic_Assoc_Node, Empty);
+
+ else
+ Set_Explicit_Generic_Actual_Parameter
+ (Generic_Assoc_Node, P_Expression);
+ end if;
+
return Generic_Assoc_Node;
end P_Generic_Association;
-- FORMAL_OBJECT_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST :
- -- MODE SUBTYPE_MARK [:= DEFAULT_EXPRESSION];
+ -- MODE [NULL_EXCLUSION] SUBTYPE_MARK [:= DEFAULT_EXPRESSION];
+ -- | DEFINING_IDENTIFIER_LIST :
+ -- MODE ACCESS_DEFINITION [:= DEFAULT_EXPRESSION];
-- The caller has checked that the initial token is an identifier
-- Error recovery: cannot raise Error_Resync
procedure P_Formal_Object_Declarations (Decls : List_Id) is
- Decl_Node : Node_Id;
- Scan_State : Saved_Scan_State;
- Num_Idents : Nat;
- Ident : Nat;
+ Decl_Node : Node_Id;
+ Ident : Nat;
+ Not_Null_Present : Boolean := False;
+ Num_Idents : Nat;
+ Scan_State : Saved_Scan_State;
Idents : array (Int range 1 .. 4096) of Entity_Id;
-- This array holds the list of defining identifiers. The upper bound
Decl_Node := New_Node (N_Formal_Object_Declaration, Token_Ptr);
Set_Defining_Identifier (Decl_Node, Idents (Ident));
P_Mode (Decl_Node);
- Set_Subtype_Mark (Decl_Node, P_Subtype_Mark_Resync);
+
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-423)
+
+ -- Ada 2005 (AI-423): Formal object with an access definition
+
+ if Token = Tok_Access then
+
+ -- The access definition is still parsed and set even though
+ -- the compilation may not use the proper switch. This action
+ -- ensures the required local error recovery.
+
+ Set_Access_Definition (Decl_Node,
+ P_Access_Definition (Not_Null_Present));
+
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("access definition not allowed in formal object " &
+ "declaration");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ -- Formal object with a subtype mark
+
+ else
+ Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
+ Set_Subtype_Mark (Decl_Node, P_Subtype_Mark_Resync);
+ end if;
+
No_Constraint;
- Set_Expression (Decl_Node, Init_Expr_Opt);
+ Set_Default_Expression (Decl_Node, Init_Expr_Opt);
if Ident > 1 then
Set_Prev_Ids (Decl_Node, True);
-- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION
-- | FORMAL_ARRAY_TYPE_DEFINITION
-- | FORMAL_ACCESS_TYPE_DEFINITION
+ -- | FORMAL_INTERFACE_TYPE_DEFINITION
-- FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION
-- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION
+ -- FORMAL_INTERFACE_TYPE_DEFINITION ::= INTERFACE_TYPE_DEFINITION
+
function P_Formal_Type_Definition return Node_Id is
- Scan_State : Saved_Scan_State;
+ Scan_State : Saved_Scan_State;
+ Typedef_Node : Node_Id;
begin
if Token_Name = Name_Abstract then
-- exception is ABSTRACT, where we have to scan ahead to see if we
-- have a formal derived type or a formal private type definition.
+ -- In addition, in Ada 2005 LIMITED may appear after abstract, so
+ -- that the lookahead must be extended by one more token.
+
when Tok_Abstract =>
Save_Scan_State (Scan_State);
Scan; -- past ABSTRACT
Restore_Scan_State (Scan_State); -- to ABSTRACT
return P_Formal_Derived_Type_Definition;
+ elsif Token = Tok_Limited then
+ Scan; -- past LIMITED
+
+ if Token = Tok_New then
+ Restore_Scan_State (Scan_State); -- to ABSTRACT
+ return P_Formal_Derived_Type_Definition;
+
+ else
+ Restore_Scan_State (Scan_State); -- to ABSTRACT
+ return P_Formal_Private_Type_Definition;
+ end if;
+
+ -- Ada 2005 (AI-443): Abstract synchronized formal derived type
+
+ elsif Token = Tok_Synchronized then
+ Restore_Scan_State (Scan_State); -- to ABSTRACT
+ return P_Formal_Derived_Type_Definition;
+
else
Restore_Scan_State (Scan_State); -- to ABSTRACT
return P_Formal_Private_Type_Definition;
end if;
- when Tok_Private | Tok_Limited | Tok_Tagged =>
- return P_Formal_Private_Type_Definition;
+ when Tok_Access =>
+ return P_Access_Type_Definition;
- when Tok_New =>
- return P_Formal_Derived_Type_Definition;
+ when Tok_Array =>
+ return P_Array_Type_Definition;
+
+ when Tok_Delta =>
+ return P_Formal_Fixed_Point_Definition;
+
+ when Tok_Digits =>
+ return P_Formal_Floating_Point_Definition;
+
+ when Tok_Interface => -- Ada 2005 (AI-251)
+ return P_Interface_Type_Definition (Abstract_Present => False);
when Tok_Left_Paren =>
return P_Formal_Discrete_Type_Definition;
- when Tok_Range =>
- return P_Formal_Signed_Integer_Type_Definition;
+ when Tok_Limited =>
+ Save_Scan_State (Scan_State);
+ Scan; -- past LIMITED
+
+ if Token = Tok_Interface then
+ Typedef_Node :=
+ P_Interface_Type_Definition (Abstract_Present => False);
+ Set_Limited_Present (Typedef_Node);
+ return Typedef_Node;
+
+ elsif Token = Tok_New then
+ Restore_Scan_State (Scan_State); -- to LIMITED
+ return P_Formal_Derived_Type_Definition;
+
+ else
+ if Token = Tok_Abstract then
+ Error_Msg_SC -- CODEFIX
+ ("ABSTRACT must come before LIMITED");
+ Scan; -- past improper ABSTRACT
+
+ if Token = Tok_New then
+ Restore_Scan_State (Scan_State); -- to LIMITED
+ return P_Formal_Derived_Type_Definition;
+
+ else
+ Restore_Scan_State (Scan_State);
+ return P_Formal_Private_Type_Definition;
+ end if;
+ end if;
+
+ Restore_Scan_State (Scan_State);
+ return P_Formal_Private_Type_Definition;
+ end if;
when Tok_Mod =>
return P_Formal_Modular_Type_Definition;
- when Tok_Digits =>
- return P_Formal_Floating_Point_Definition;
+ when Tok_New =>
+ return P_Formal_Derived_Type_Definition;
- when Tok_Delta =>
- return P_Formal_Fixed_Point_Definition;
+ when Tok_Not =>
+ if P_Null_Exclusion then
+ Typedef_Node := P_Access_Type_Definition;
+ Set_Null_Exclusion_Present (Typedef_Node);
+ return Typedef_Node;
- when Tok_Array =>
- return P_Array_Type_Definition;
+ else
+ Error_Msg_SC ("expect valid formal access definition!");
+ Resync_Past_Semicolon;
+ return Error;
+ end if;
- when Tok_Access =>
- return P_Access_Type_Definition;
+ when Tok_Private |
+ Tok_Tagged =>
+ return P_Formal_Private_Type_Definition;
+
+ when Tok_Range =>
+ return P_Formal_Signed_Integer_Type_Definition;
when Tok_Record =>
Error_Msg_SC ("record not allowed in generic type definition!");
Discard_Junk_Node (P_Record_Definition);
return Error;
+ -- Ada 2005 (AI-345): Task, Protected or Synchronized interface or
+ -- (AI-443): Synchronized formal derived type declaration.
+
+ when Tok_Protected |
+ Tok_Synchronized |
+ Tok_Task =>
+
+ declare
+ Saved_Token : constant Token_Type := Token;
+
+ begin
+ Scan; -- past TASK, PROTECTED or SYNCHRONIZED
+
+ -- Synchronized derived type
+
+ if Token = Tok_New then
+ Typedef_Node := P_Formal_Derived_Type_Definition;
+
+ if Saved_Token = Tok_Synchronized then
+ Set_Synchronized_Present (Typedef_Node);
+ else
+ Error_Msg_SC ("invalid kind of formal derived type");
+ end if;
+
+ -- Interface
+
+ else
+ Typedef_Node :=
+ P_Interface_Type_Definition (Abstract_Present => False);
+
+ 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 =>
+ null;
+ end case;
+ end if;
+
+ return Typedef_Node;
+ end;
+
when others =>
Error_Msg_BC ("expecting generic type definition here");
Resync_Past_Semicolon;
Scan; -- past LIMITED
end if;
+ if Token = Tok_Abstract then
+ if Prev_Token = Tok_Tagged then
+ Error_Msg_SC -- CODEFIX
+ ("ABSTRACT must come before TAGGED");
+ elsif Prev_Token = Tok_Limited then
+ Error_Msg_SC -- CODEFIX
+ ("ABSTRACT must come before LIMITED");
+ end if;
+
+ Resync_Past_Semicolon;
+
+ elsif Token = Tok_Tagged then
+ Error_Msg_SC -- CODEFIX
+ ("TAGGED must come before LIMITED");
+ Resync_Past_Semicolon;
+ end if;
+
Set_Sloc (Def_Node, Token_Ptr);
T_Private;
return Def_Node;
--------------------------------------------
-- FORMAL_DERIVED_TYPE_DEFINITION ::=
- -- [abstract] new SUBTYPE_MARK [with private]
+ -- [abstract] [limited | synchronized]
+ -- new SUBTYPE_MARK [[and INTERFACE_LIST] with private]
- -- The caller has checked the initial token(s) is/are NEW or ASTRACT NEW
+ -- The caller has checked the initial token(s) is/are NEW, ABSTRACT NEW,
+ -- or LIMITED NEW, ABSTRACT LIMITED NEW, SYNCHRONIZED NEW or ABSTRACT
+ -- SYNCHRONIZED NEW.
-- Error recovery: cannot raise Error_Resync
Scan; -- past ABSTRACT
end if;
+ if Token = Tok_Limited then
+ Set_Limited_Present (Def_Node);
+ Scan; -- past LIMITED
+
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("LIMITED in derived type is an Ada 2005 extension");
+ Error_Msg_SP
+ ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ elsif Token = Tok_Synchronized then
+ Set_Synchronized_Present (Def_Node);
+ Scan; -- past SYNCHRONIZED
+
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("SYNCHRONIZED in derived type is an Ada 2005 extension");
+ Error_Msg_SP
+ ("\unit must be compiled with -gnat05 switch");
+ end if;
+ end if;
+
+ if Token = Tok_Abstract then
+ Scan; -- past ABSTRACT, diagnosed already in caller.
+ end if;
+
Scan; -- past NEW;
Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
No_Constraint;
+ -- Ada 2005 (AI-251): Deal with interfaces
+
+ if Token = Tok_And then
+ Scan; -- past AND
+
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("abstract interface is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Set_Interface_List (Def_Node, New_List);
+
+ loop
+ Append (P_Qualified_Simple_Name, Interface_List (Def_Node));
+ exit when Token /= Tok_And;
+ Scan; -- past AND
+ end loop;
+ end if;
+
if Token = Tok_With then
Scan; -- past WITH
Set_Private_Present (Def_Node, True);
-- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <>
- -- DEFAULT_NAME ::= NAME
+ -- DEFAULT_NAME ::= NAME | null
-- The caller has checked that the initial tokens are WITH FUNCTION or
-- WITH PROCEDURE, and the initial WITH has been scanned out.
+ -- A null default is an Ada 2005 feature
+
-- Error recovery: cannot raise Error_Resync
function P_Formal_Subprogram_Declaration return Node_Id is
Scan; -- past <>
T_Semicolon;
+ elsif Token = Tok_Null then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("null default subprograms are an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ if Nkind (Spec_Node) = N_Procedure_Specification then
+ Set_Null_Present (Spec_Node);
+ else
+ Error_Msg_SP ("only procedures can be null");
+ end if;
+
+ Scan; -- past NULL
+ T_Semicolon;
+
else
Set_Default_Name (Def_Node, P_Name);
T_Semicolon;
-- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART;
-- FORMAL_PACKAGE_ACTUAL_PART ::=
- -- (<>) | [GENERIC_ACTUAL_PART]
+ -- ([OTHERS =>] <>) |
+ -- [GENERIC_ACTUAL_PART]
+ -- (FORMAL_PACKAGE_ASSOCIATION {, FORMAL_PACKAGE_ASSOCIATION}
+ -- [, OTHERS => <>)
+
+ -- FORMAL_PACKAGE_ASSOCIATION ::=
+ -- GENERIC_ASSOCIATION
+ -- | GENERIC_FORMAL_PARAMETER_SELECTOR_NAME => <>
-- The caller has checked that the initial tokens are WITH PACKAGE,
-- and the initial WITH has been scanned out (so Token = Tok_Package).
OSDN Git Service
