pragma Style_Checks (All_Checks);
with Sinfo.CN; use Sinfo.CN;
separate (Par)
package body Ch3 is
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 P_Declarative_Items
(Decls : List_Id;
Done : out Boolean;
In_Spec : Boolean);
procedure P_Identifier_Declarations
(Decls : List_Id;
Done : out Boolean;
In_Spec : Boolean);
procedure Statement_When_Declaration_Expected
(Decls : List_Id;
Done : out Boolean;
In_Spec : Boolean);
procedure Set_Declaration_Expected;
function Init_Expr_Opt (P : Boolean := False) return Node_Id is
begin
if Token = Tok_Colon then
if Token_Is_At_End_Of_Line then
T_Semicolon;
return Empty;
end if;
elsif Token = Tok_Colon_Equal
or else Token = Tok_Equal
or else Token = Tok_Is
then
null;
elsif Token in Token_Class_Literal then
declare
Scan_State : Saved_Scan_State;
begin
Save_Scan_State (Scan_State);
Scan;
if Token = Tok_Semicolon then
Restore_Scan_State (Scan_State);
else
Restore_Scan_State (Scan_State);
return Empty;
end if;
end;
else
return Empty;
end if;
T_Colon_Equal;
if P then
return P_Expression;
else
return P_Expression_No_Right_Paren;
end if;
end Init_Expr_Opt;
function P_Defining_Identifier (C : Id_Check := None) return Node_Id is
Ident_Node : Node_Id;
begin
if Token = Tok_Identifier then
if Ada_Version = Ada_95 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;
elsif Is_Reserved_Identifier (C) then
Scan_Reserved_Identifier (Force_Msg => True);
else
T_Identifier; raise Error_Resync;
end if;
Ident_Node := Token_Node;
Scan;
if Ident_Node /= Error then
Change_Identifier_To_Defining_Identifier (Ident_Node);
end if;
return Ident_Node;
end P_Defining_Identifier;
function P_Type_Declaration return Node_Id is
Type_Loc : Source_Ptr;
Type_Start_Col : Column_Number;
Ident_Node : Node_Id;
Decl_Node : Node_Id;
Discr_List : List_Id;
Unknown_Dis : Boolean;
Discr_Sloc : Source_Ptr;
Abstract_Present : Boolean;
Abstract_Loc : Source_Ptr;
End_Labl : Node_Id;
Typedef_Node : Node_Id;
begin
Type_Loc := Token_Ptr;
Type_Start_Col := Start_Column;
T_Type;
Ident_Node := P_Defining_Identifier (C_Is);
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;
if Token = Tok_Semicolon then
Scan; 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;
if Token = Tok_Equal then
TF_Is;
Scan;
elsif Token = Tok_Renames then
Error_Msg_SC ("RENAMES should be IS");
Scan;
else
TF_Is;
end if;
if Token = Tok_Identifier then
declare
SS : Saved_Scan_State;
I2 : Boolean;
begin
Save_Scan_State (SS);
Scan; 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;
if Token_Name = Name_Abstract then
Check_95_Keyword (Tok_Abstract, Tok_Tagged);
Check_95_Keyword (Tok_Abstract, Tok_New);
end if;
if Token = Tok_Abstract then
Abstract_Present := True;
Abstract_Loc := Token_Ptr;
Scan;
if 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;
else
Abstract_Present := False;
Abstract_Loc := No_Location;
end if;
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;
if Token = Tok_Aliased or else Token_Name = Name_Aliased then
Error_Msg_SC ("ALIASED not allowed in type definition");
Scan; end if;
Typedef_Node := Empty;
loop
case Token is
when Tok_Access |
Tok_Not => 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 =>
Ignore (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));
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 =>
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 => 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));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label (Typedef_Node, End_Labl);
TF_Semicolon;
exit;
when Tok_Tagged =>
Scan;
if Token = Tok_Abstract then
Error_Msg_SC ("ABSTRACT must come before TAGGED");
Abstract_Present := True;
Abstract_Loc := Token_Ptr;
Scan; end if;
if Token = Tok_Limited then
Scan;
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;
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 => Chars (Ident_Node));
Set_Comes_From_Source (End_Labl, False);
Set_End_Label (Typedef_Node, End_Labl);
end if;
else
if Token = Tok_Private then
Decl_Node :=
New_Node (N_Private_Type_Declaration, Type_Loc);
Set_Tagged_Present (Decl_Node, True);
Scan;
else
Typedef_Node := P_Record_Definition;
Set_Tagged_Present (Typedef_Node, True);
End_Labl :=
Make_Identifier (Token_Ptr,
Chars => 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_Private =>
Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
Scan; TF_Semicolon;
exit;
when Tok_Limited =>
Scan;
loop
if Token = Tok_Tagged then
Error_Msg_SC ("TAGGED must come before LIMITED");
Scan;
elsif Token = Tok_Abstract then
Error_Msg_SC ("ABSTRACT must come before LIMITED");
Scan;
else
exit;
end if;
end loop;
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!");
end if;
Typedef_Node := P_Record_Definition;
Set_Limited_Present (Typedef_Node, True);
else
Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
Set_Limited_Present (Decl_Node, True);
T_Private; end if;
TF_Semicolon;
exit;
when Tok_Identifier =>
if not Token_Is_At_Start_Of_Line then
Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
TF_Semicolon;
elsif Start_Column <= Type_Start_Col then
Error_Msg_AP ("type definition expected");
Typedef_Node := Error;
else
Typedef_Node := P_Record_Definition;
TF_Semicolon;
end if;
exit;
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;
if No (Typedef_Node) then
Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
Set_Abstract_Present (Decl_Node, Abstract_Present);
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);
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)))
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;
Set_Defining_Identifier (Decl_Node, Ident_Node);
Set_Discriminant_Specifications (Decl_Node, Discr_List);
return Decl_Node;
end P_Type_Declaration;
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; Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is));
TF_Is;
if Token = Tok_New then
Error_Msg_SC ("NEW ignored (only allowed in type declaration)");
Scan; end if;
Not_Null_Present := P_Null_Exclusion; Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Subtype_Indication
(Decl_Node, P_Subtype_Indication (Not_Null_Present));
TF_Semicolon;
return Decl_Node;
end P_Subtype_Declaration;
function P_Null_Exclusion return Boolean is
begin
if Token /= Tok_Not then
return False;
else
if Ada_Version < Ada_05 then
Error_Msg_SP
("null-excluding access is an Ada 2005 extension");
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
Scan;
if Token = Tok_Null then
Scan; else
Error_Msg_SP ("NULL expected");
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
if Token = Tok_Record then
Error_Msg_SC ("anonymous record definitions are 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;
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) then
return Subtype_Mark;
else
if Not_Null_Present then
Error_Msg_SP ("constrained null-exclusion not allowed");
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;
function P_Subtype_Mark return Node_Id is
begin
return P_Subtype_Mark_Resync;
exception
when Error_Resync =>
return Error;
end P_Subtype_Mark;
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; 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;
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;
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
Save_Scan_State (Scan_State); Scan;
if Token /= Tok_Identifier then
Restore_Scan_State (Scan_State); return Prefix;
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);
Delete_Node (Token_Node);
Scan; end if;
exit when Token /= Tok_Apostrophe;
Prefix := Attr_Node;
end loop;
return Attr_Node;
end P_Subtype_Mark_Attribute;
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;
else
return Empty;
end if;
end P_Constraint_Opt;
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;
Num_Idents : Nat := 1;
procedure No_List;
function Token_Is_Renames return Boolean;
procedure No_List is
begin
if Num_Idents > 1 then
Error_Msg ("identifier list not allowed for RENAMES",
Sloc (Idents (2)));
end if;
List_OK := False;
end No_List;
function Token_Is_Renames return Boolean is
At_Colon : Saved_Scan_State;
begin
if Token = Tok_Colon then
Save_Scan_State (At_Colon);
Scan; Check_Misspelling_Of (Tok_Renames);
if Token = Tok_Renames then
Error_Msg_SP ("extra "":"" ignored");
Scan; return True;
else
Restore_Scan_State (At_Colon);
return False;
end if;
else
Check_Misspelling_Of (Tok_Renames);
if Token = Tok_Renames then
Scan; return True;
else
return False;
end if;
end if;
end Token_Is_Renames;
begin
Ident_Sloc := Token_Ptr;
Save_Scan_State (Scan_State); Idents (1) := P_Defining_Identifier (C_Comma_Colon);
if Token = Tok_Colon then
Scan;
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); T_Colon;
elsif Token = Tok_Colon_Equal then
Scan;
if Token = Tok_Constant then
Error_Msg_SP ("colon expected");
else
Restore_Scan_State (Scan_State);
Statement_When_Declaration_Expected (Decls, Done, In_Spec);
return;
end if;
elsif Token = Tok_Is then
Restore_Scan_State (Scan_State);
Append_To (Decls, P_Type_Declaration);
Done := False;
return;
else
Restore_Scan_State (Scan_State);
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;
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;
else
Set_Declaration_Expected;
Resync_Past_Semicolon;
Done := False;
return;
end if;
end if;
if Token = Tok_Identifier then
declare
SS : Saved_Scan_State;
I2 : Boolean;
begin
Save_Scan_State (SS);
Scan; 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;
Ident := 1;
Ident_Loop : loop
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;
if Token = Tok_Constant then
Con_Loc := Token_Ptr;
Scan;
Init_Expr := Init_Expr_Opt;
if Present (Init_Expr) then
if Not_Null_Present then
Error_Msg_SP ("null-exclusion not allowed in "
& "numeric expression");
end if;
Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
Set_Expression (Decl_Node, Init_Expr);
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 ("ALIASED should be before CONSTANT");
Scan; 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; Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Object_Definition (Decl_Node,
P_Subtype_Indication (Not_Null_Present));
end if;
if Token = Tok_Renames then
Error_Msg
("CONSTANT not permitted in renaming declaration",
Con_Loc);
Scan; Discard_Junk_Node (P_Name);
end if;
end if;
elsif Token = Tok_Exception then
Scan;
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;
elsif Token = Tok_Aliased then
Scan; Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Aliased_Present (Decl_Node, True);
if Token = Tok_Constant then
Scan; 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; Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Object_Definition (Decl_Node,
P_Subtype_Indication (Not_Null_Present));
end if;
elsif Token = Tok_Array then
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
elsif Token = Tok_Not then
Not_Null_Present := P_Null_Exclusion;
if Token = Tok_Access then
if Ada_Version < Ada_05 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;
Acc_Node := P_Access_Definition (Not_Null_Present);
if Token /= Tok_Renames then
Error_Msg_SC ("'RENAMES' expected");
raise Error_Resync;
end if;
Scan; 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);
else
Type_Node := P_Subtype_Mark;
if Token_Is_Renames then
Error_Msg_SP
("null-exclusion not allowed in object renamings");
raise Error_Resync;
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));
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;
elsif Token = Tok_Access then
if Ada_Version < Ada_05 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;
Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
if Token /= Tok_Renames then
Error_Msg_SC ("'RENAMES' expected");
raise Error_Resync;
end if;
Scan; 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);
else
Type_Node := P_Subtype_Mark;
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);
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));
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;
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);
else
Error_Msg ("initialization not allowed here", Init_Loc);
end if;
end if;
TF_Semicolon;
Set_Defining_Identifier (Decl_Node, Idents (Ident));
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;
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);
T_New;
if Token = Tok_Abstract then
Error_Msg_SC ("ABSTRACT must come before NEW, not after");
Scan;
end if;
Not_Null_Present := P_Null_Exclusion; Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
Set_Subtype_Indication (Typedef_Node,
P_Subtype_Indication (Not_Null_Present));
if Token = Tok_With
or else Token = Tok_Record
or else Token = Tok_Null
then
T_With;
if Token = Tok_Limited then
Error_Msg_SC
("LIMITED keyword not allowed in private extension");
Scan; end if;
if Token = Tok_Private then
Scan;
Typedecl_Node :=
Make_Private_Extension_Declaration (No_Location,
Defining_Identifier => Empty,
Subtype_Indication => Subtype_Indication (Typedef_Node),
Abstract_Present => Abstract_Present (Typedef_Node));
Delete_Node (Typedef_Node);
return Typedecl_Node;
else
Set_Record_Extension_Part (Typedef_Node, P_Record_Definition);
return Typedef_Node;
end if;
else
return Typedef_Node;
end if;
end P_Derived_Type_Def_Or_Private_Ext_Decl;
function P_Range_Constraint return Node_Id is
Range_Node : Node_Id;
begin
Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
Scan; Set_Range_Expression (Range_Node, P_Range);
return Range_Node;
end P_Range_Constraint;
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; Expr_Node := P_Expression;
Check_Simple_Expression (Expr_Node);
Set_High_Bound (Range_Node, Expr_Node);
return Range_Node;
else
T_Dot_Dot; return Error;
end if;
end P_Range;
function P_Range_Or_Subtype_Mark 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
Check_Simple_Expression (Expr_Node);
Range_Node := New_Node (N_Range, Token_Ptr);
Set_Low_Bound (Range_Node, Expr_Node);
Scan; Set_High_Bound (Range_Node, P_Simple_Expression);
return Range_Node;
elsif Expr_Form = EF_Simple_Name
or else Nkind (Expr_Node) = N_Attribute_Reference
then
if Token = Tok_Range then
Error_Msg_SC
("range constraint not allowed in membership test");
Scan; raise Error_Resync;
elsif Token = Tok_Digits or else Token = Tok_Delta then
Error_Msg_SC
("accuracy definition not allowed in membership test");
Scan; raise Error_Resync;
elsif Token = Tok_Apostrophe then
return P_Subtype_Mark_Attribute (Expr_Node);
else
return Expr_Node;
end if;
else
return Expr_Node;
end if;
end P_Range_Or_Subtype_Mark;
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;
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;
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; return Literal_Node;
end P_Defining_Character_Literal;
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; 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);
return Typedef_Node;
end P_Signed_Integer_Type_Definition;
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; Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
if Token = Tok_Dot_Dot then
Error_Msg_SC ("range not allowed for modular type");
Scan; Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
end if;
return Typedef_Node;
end P_Modular_Type_Definition;
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; Expr_Node := P_Expression_No_Right_Paren;
Check_Simple_Expression_In_Ada_83 (Expr_Node);
if Token = Tok_Delta then
Error_Msg_SC ("DELTA must come before DIGITS");
Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
Scan; Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);
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;
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; 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;
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; 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; 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);
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;
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; Expr_Node := P_Expression_No_Right_Paren;
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;
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; Expr_Node := P_Expression_No_Right_Paren;
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;
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;
begin
Array_Loc := Token_Ptr;
Scan; Subs_List := New_List;
T_Left_Paren;
Save_Scan_State (Scan_State);
while Token in Token_Class_Desig or else
Token = Tok_Dot or else
Token = Tok_Apostrophe loop
Scan;
end loop;
Scan;
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);
loop
Append (P_Subtype_Mark_Resync, Subs_List);
T_Range;
T_Box;
exit when Token = Tok_Right_Paren or else Token = Tok_Of;
T_Comma;
end loop;
Set_Subtype_Marks (Def_Node, Subs_List);
else
Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
Restore_Scan_State (Scan_State);
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; end if;
Not_Null_Present := P_Null_Exclusion;
if Token = Tok_Access then
if Ada_Version < Ada_05 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;
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);
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;
function P_Discrete_Subtype_Definition return Node_Id is
begin
return P_Discrete_Range;
end P_Discrete_Subtype_Definition;
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);
elsif Token = Tok_Dot_Dot then
Range_Node := New_Node (N_Range, Token_Ptr);
Set_Low_Bound (Range_Node, Expr_Node);
Scan; Expr_Node := P_Expression;
Check_Simple_Expression (Expr_Node);
Set_High_Bound (Range_Node, Expr_Node);
return Range_Node;
elsif Expr_Form = EF_Simple_Name then
return Expr_Node;
else
T_Dot_Dot;
return Expr_Node;
end if;
end P_Discrete_Range;
function P_Unknown_Discriminant_Part_Opt return Boolean is
Scan_State : Saved_Scan_State;
begin
if Token /= Tok_Left_Paren then
return False;
else
Save_Scan_State (Scan_State);
Scan;
if Token = Tok_Box then
if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
end if;
Scan; T_Right_Paren; return True;
else
Restore_Scan_State (Scan_State);
return False;
end if;
end if;
end P_Unknown_Discriminant_Part_Opt;
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;
begin
if Token = Tok_Left_Paren then
Specification_List := New_List;
Scan; 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;
T_Colon;
if Num_Idents > 1 then
Save_Scan_State (Scan_State);
end if;
Ident := 1;
Ident_Loop : loop
Specification_Node :=
New_Node (N_Discriminant_Specification, Ident_Sloc);
Set_Defining_Identifier (Specification_Node, Idents (Ident));
Not_Null_Present := P_Null_Exclusion;
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));
else
Set_Discriminant_Type
(Specification_Node, P_Subtype_Mark);
No_Constraint;
Set_Null_Exclusion_Present (Specification_Node, Not_Null_Present);
end if;
Set_Expression
(Specification_Node, Init_Expr_Opt (True));
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);
end loop Ident_Loop;
exit Specification_Loop when Token /= Tok_Semicolon;
Scan; 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;
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; Constr_List := New_List;
Set_Constraints (Result_Node, Constr_List);
loop
if Token = Tok_Identifier then
Save_Scan_State (Scan_State); Scan;
if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
Restore_Scan_State (Scan_State); Append (P_Discriminant_Association, Constr_List);
goto Loop_Continue;
else
Restore_Scan_State (Scan_State); end if;
end if;
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;
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; Expr_Node := P_Expression;
Check_Simple_Expression (Expr_Node);
Set_High_Bound (Constr_Node, Expr_Node);
Append (Constr_Node, Constr_List);
goto Loop_Continue;
else
Append (Expr_Node, Constr_List);
goto Loop_Continue;
end if;
<<Loop_Continue>>
exit when not Comma_Present;
end loop;
T_Right_Paren;
return Result_Node;
end P_Index_Or_Discriminant_Constraint;
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; 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;
function P_Record_Definition return Node_Id is
Rec_Node : Node_Id;
begin
Rec_Node := New_Node (N_Record_Definition, Token_Ptr);
if Token = Tok_Null then
Scan; T_Record;
Set_Null_Present (Rec_Node, True);
else
Push_Scope_Stack;
Scope.Table (Scope.Last).Etyp := E_Record;
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Sloc := Token_Ptr;
Scope.Table (Scope.Last).Labl := Error;
Scope.Table (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;
return Rec_Node;
end P_Record_Definition;
function P_Component_List return Node_Id is
Component_List_Node : Node_Id;
Decls_List : List_Id;
Scan_State : Saved_Scan_State;
begin
Component_List_Node := New_Node (N_Component_List, Token_Ptr);
Decls_List := New_List;
if Token = Tok_Null then
Scan; TF_Semicolon;
P_Pragmas_Opt (Decls_List);
Set_Null_Present (Component_List_Node, True);
return Component_List_Node;
else
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;
if Token /= Tok_Identifier then
if Start_Column > Scope.Table (Scope.Last).Ecol
and then Is_Reserved_Identifier
then
Save_Scan_State (Scan_State); Scan;
if Token = Tok_Comma or else Token = Tok_Colon then
Restore_Scan_State (Scan_State);
Scan_Reserved_Identifier (Force_Msg => True);
else
Restore_Scan_State (Scan_State);
exit Component_Scan_Loop;
end if;
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);
if Token = Tok_Identifier then
Save_Scan_State (Scan_State);
Scan;
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;
end if;
Set_Component_Items (Component_List_Node, Decls_List);
return Component_List_Node;
end P_Component_List;
procedure P_Component_Items (Decls : List_Id) is
Aliased_Present : Boolean := False;
CompDef_Node : Node_Id;
Decl_Node : Node_Id;
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;
begin
if Token /= Tok_Identifier then
Error_Msg_SC ("component declaration expected");
Resync_Past_Semicolon;
return;
end if;
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;
T_Colon;
if Num_Idents > 1 then
Save_Scan_State (Scan_State);
end if;
Ident := 1;
Ident_Loop : loop
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 components are 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; end if;
Not_Null_Present := P_Null_Exclusion;
if Token = Tok_Access then
if Ada_Version < Ada_05 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;
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 arrays not allowed as components");
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);
end loop Ident_Loop;
TF_Semicolon;
end P_Component_Items;
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;
Scope.Table (Scope.Last).Etyp := E_Case;
Scope.Table (Scope.Last).Sloc := Token_Ptr;
Scope.Table (Scope.Last).Ecol := Start_Column;
Scan; 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));
end if;
TF_Is;
Variants_List := New_List;
P_Pragmas_Opt (Variants_List);
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
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;
function P_Variant return Node_Id is
Variant_Node : Node_Id;
begin
if Token = Tok_If then
T_When;
Scan; 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;
function P_Discrete_Choice_List return List_Id is
Choices : List_Id;
Expr_Node : Node_Id;
Choice_Node : Node_Id;
begin
Choices := New_List;
loop
if Token = Tok_Others then
Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
Scan;
else
begin
Expr_Node := No_Right_Paren (P_Expression_Or_Range_Attribute);
if Token = Tok_Colon
and then Nkind (Expr_Node) = N_Identifier
then
Error_Msg_SP ("label not permitted in this context");
Scan;
elsif Expr_Form = EF_Range_Attr then
Append (Expr_Node, Choices);
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; Expr_Node := P_Expression_No_Right_Paren;
Check_Simple_Expression (Expr_Node);
Set_High_Bound (Choice_Node, Expr_Node);
Append (Choice_Node, Choices);
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;
else
Check_Simple_Expression_In_Ada_83 (Expr_Node);
Append (Expr_Node, Choices);
end if;
exception
when Error_Resync =>
Resync_Choice;
return Error_List;
end;
end if;
if Token = Tok_Comma then
Error_Msg_SC (""","" should be ""'|""");
else
exit when Token /= Tok_Vertical_Bar;
end if;
Scan; end loop;
return Choices;
end P_Discrete_Choice_List;
function P_Access_Type_Definition
(Header_Already_Parsed : Boolean := False) return Node_Id is
Access_Loc : constant Source_Ptr := Token_Ptr;
Prot_Flag : Boolean;
Not_Null_Present : Boolean := False;
Type_Def_Node : Node_Id;
procedure 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;
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;
begin
if not Header_Already_Parsed then
Not_Null_Present := P_Null_Exclusion; Scan; 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;
if Token /= Tok_Procedure and then Token /= Tok_Function then
Error_Msg_SC ("FUNCTION or PROCEDURE expected");
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; 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; Check_Junk_Subprogram_Name;
Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
Set_Protected_Present (Type_Def_Node, Prot_Flag);
TF_Return;
Set_Subtype_Mark (Type_Def_Node, P_Subtype_Mark);
No_Constraint;
else
Type_Def_Node :=
New_Node (N_Access_To_Object_Definition, Access_Loc);
Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
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; 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;
function P_Access_Definition
(Null_Exclusion_Present : Boolean) return Node_Id is
Def_Node : Node_Id;
Subp_Node : Node_Id;
begin
Def_Node := New_Node (N_Access_Definition, Token_Ptr);
Scan;
if Ada_Version >= Ada_05 then
if Token = Tok_Protected
or else Token = Tok_Procedure
or else Token = Tok_Function
then
Subp_Node :=
P_Access_Type_Definition (Header_Already_Parsed => True);
Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node);
else
Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present);
if Token = Tok_All then
Scan; Set_All_Present (Def_Node);
elsif Token = Tok_Constant then
Scan; Set_Constant_Present (Def_Node);
end if;
Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
No_Constraint;
end if;
else
pragma Assert (Null_Exclusion_Present = False);
Set_Null_Exclusion_Present (Def_Node, False);
Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
No_Constraint;
end if;
return Def_Node;
end P_Access_Definition;
function P_Declarative_Part return List_Id is
Decls : List_Id;
Done : Boolean;
begin
Missing_Begin_Msg := No_Error_Msg;
SIS_Entry_Active := False;
Decls := New_List;
loop
P_Declarative_Items (Decls, Done, In_Spec => False);
exit when Done;
end loop;
SIS_Entry_Active := False;
return Decls;
end P_Declarative_Part;
procedure P_Declarative_Items
(Decls : List_Id;
Done : out Boolean;
In_Spec : Boolean)
is
Scan_State : Saved_Scan_State;
begin
if Style_Check then Style.Check_Indentation; end if;
case Token is
when Tok_Function =>
Check_Bad_Layout;
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
Done := False;
when Tok_For =>
Check_Bad_Layout;
Save_Scan_State (Scan_State);
Scan;
if Token = Tok_Identifier then
Scan;
if Token = Tok_In then
Restore_Scan_State (Scan_State);
Statement_When_Declaration_Expected (Decls, Done, In_Spec);
return;
end if;
end if;
Restore_Scan_State (Scan_State);
Append (P_Representation_Clause, Decls);
Done := False;
when Tok_Generic =>
Check_Bad_Layout;
Append (P_Generic, Decls);
Done := False;
when Tok_Identifier =>
Check_Bad_Layout;
P_Identifier_Declarations (Decls, Done, In_Spec);
when Tok_Package =>
Check_Bad_Layout;
Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
Done := False;
when Tok_Pragma =>
Append (P_Pragma, Decls);
Done := False;
when Tok_Procedure =>
Check_Bad_Layout;
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
Done := False;
when Tok_Protected =>
Check_Bad_Layout;
Scan; Append (P_Protected, Decls);
Done := False;
when Tok_Subtype =>
Check_Bad_Layout;
Append (P_Subtype_Declaration, Decls);
Done := False;
when Tok_Task =>
Check_Bad_Layout;
Scan; Append (P_Task, Decls);
Done := False;
when Tok_Type =>
Check_Bad_Layout;
Append (P_Type_Declaration, Decls);
Done := False;
when Tok_Use =>
Check_Bad_Layout;
Append (P_Use_Clause, Decls);
Done := False;
when Tok_With =>
Check_Bad_Layout;
Error_Msg_SC ("WITH can only appear in context clause");
raise Error_Resync;
when Tok_Begin =>
if SIS_Entry_Active and then Start_Column >= SIS_Ecol then
declare
Specification_Node : Node_Id;
Decl_Node : Node_Id;
Body_Node : Node_Id;
begin
if SIS_Missing_Semicolon_Message /= No_Error_Msg then
Change_Error_Text (SIS_Missing_Semicolon_Message, "missing ""is""");
else
Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
end if;
Specification_Node := Specification (SIS_Declaration_Node);
Change_Node (SIS_Declaration_Node, N_Subprogram_Body);
Body_Node := SIS_Declaration_Node;
Set_Specification (Body_Node, Specification_Node);
Set_Declarations (Body_Node, New_List);
loop
Decl_Node := Remove_Next (Body_Node);
exit when Decl_Node = Empty;
Append (Decl_Node, Declarations (Body_Node));
end loop;
Push_Scope_Stack;
Scope.Table (Scope.Last).Sloc := SIS_Sloc;
Scope.Table (Scope.Last).Etyp := E_Name;
Scope.Table (Scope.Last).Ecol := SIS_Ecol;
Scope.Table (Scope.Last).Labl := SIS_Labl;
Scope.Table (Scope.Last).Lreq := False;
SIS_Entry_Active := False;
Scan; Set_Handled_Statement_Sequence (Body_Node,
P_Handled_Sequence_Of_Statements);
End_Statements (Handled_Statement_Sequence (Body_Node));
end;
Done := False;
else
Done := True;
end if;
when Tok_End =>
Save_Scan_State (Scan_State); Scan;
if Token = Tok_Record then
Error_Msg_SP ("no RECORD for this `end record`!");
Scan; TF_Semicolon;
else
Restore_Scan_State (Scan_State); Done := True;
end if;
when Tok_Abort |
Tok_Accept |
Tok_Declare |
Tok_Delay |
Tok_Exit |
Tok_Goto |
Tok_If |
Tok_Loop |
Tok_Null |
Tok_Requeue |
Tok_Select |
Tok_While =>
if Is_Reserved_Identifier then
Save_Scan_State (Scan_State);
Scan;
if Token /= Tok_Colon and then Token /= Tok_Comma then
Restore_Scan_State (Scan_State);
Statement_When_Declaration_Expected (Decls, Done, In_Spec);
return;
else
Restore_Scan_State (Scan_State);
Scan_Reserved_Identifier (Force_Msg => True);
P_Identifier_Declarations (Decls, Done, In_Spec);
end if;
else
Statement_When_Declaration_Expected (Decls, Done, In_Spec);
return;
end if;
when Tok_Return =>
Error_Msg_SC ("misplaced RETURN statement");
raise Error_Resync;
when Tok_Private =>
if In_Spec then
Done := True;
else
Error_Msg_SC ("PRIVATE not allowed in body");
Scan; end if;
when Tok_EOF =>
Done := True;
when others =>
if Is_Reserved_Identifier then
Save_Scan_State (Scan_State);
Scan;
if Token /= Tok_Colon and then Token /= Tok_Comma then
Restore_Scan_State (Scan_State);
Set_Declaration_Expected;
raise Error_Resync;
else
Restore_Scan_State (Scan_State);
Scan_Reserved_Identifier (Force_Msg => True);
Check_Bad_Layout;
P_Identifier_Declarations (Decls, Done, In_Spec);
end if;
else
Set_Declaration_Expected;
raise Error_Resync;
end if;
end case;
exception
when Error_Resync =>
Resync_Past_Semicolon;
Done := False;
end P_Declarative_Items;
function P_Basic_Declarative_Items return List_Id is
Decl : Node_Id;
Decls : List_Id;
Kind : Node_Kind;
Done : Boolean;
begin
Missing_Begin_Msg := No_Error_Msg;
SIS_Entry_Active := False;
Decls := New_List;
loop
P_Declarative_Items (Decls, Done, In_Spec => True);
exit when Done;
end loop;
SIS_Entry_Active := False;
Decl := First (Decls);
while Present (Decl) loop
Kind := Nkind (Decl);
if Kind = N_Subprogram_Body or else
Kind = N_Package_Body or else
Kind = N_Task_Body or else
Kind = N_Protected_Body
then
Error_Msg
("proper body not allowed in package spec", Sloc (Decl));
elsif Kind in N_Body_Stub then
Error_Msg
("body stub not allowed in package spec", Sloc (Decl));
elsif Kind = N_Assignment_Statement then
Error_Msg
("assignment statement not allowed in package spec",
Sloc (Decl));
end if;
Next (Decl);
end loop;
return Decls;
end P_Basic_Declarative_Items;
procedure Set_Declaration_Expected is
begin
Error_Msg_SC ("declaration expected");
if Missing_Begin_Msg = No_Error_Msg then
Missing_Begin_Msg := Get_Msg_Id;
end if;
end Set_Declaration_Expected;
procedure Skip_Declaration (S : List_Id) is
Dummy_Done : Boolean;
begin
P_Declarative_Items (S, Dummy_Done, False);
end Skip_Declaration;
procedure Statement_When_Declaration_Expected
(Decls : List_Id;
Done : out Boolean;
In_Spec : Boolean)
is
begin
if Missing_Begin_Msg /= No_Error_Msg then
if In_Spec then
null;
else
Done := True;
return;
end if;
else
if In_Spec then
Error_Msg_SC ("statement not allowed in package spec");
else
Error_Msg_SC ("statement not allowed in declarative part");
end if;
Missing_Begin_Msg := Get_Msg_Id;
end if;
Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco));
Done := False;
end Statement_When_Declaration_Expected;
end Ch3;