From a03805dafcfadf179be8c6e8c7174d0aad9b0c5a Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 5 Sep 2005 07:55:06 +0000 Subject: [PATCH] 2005-09-01 Gary Dismukes Robert Dewar Hristian Kirtchev * layout.adb (SO_Ref_From_Expr): Change Subtype_Mark to Result_Definition. * par-ch6.adb (P_Subprogram): Handle parsing of Access_Definitions in function specs. Call Set_Result_Definition instead of Set_Subtype_Mark. (P_Subprogram_Specification): Add parsing of anonymous access result plus null exclusions. Call Set_Result_Definition instead of Set_Subtype_Mark. * par-ch3.adb: Add support for LIMITED NEW for Ada 2005 AI-419 (P_Access_Type_Definition): Add parsing for an anonymous access result subtype, plus parsing for null exclusions. Call Set_Result_Definition instead of Set_Subtype_Mark. * sinfo.adb: Add support for LIMITED NEW for Ada 2005 AI-419 (Null_Exclusion_Present): Allow this flag for N_Function_Specification. (Result_Definition): New function for N_Function_Specifications. (Subtype_Mark): No longer allowed for N_Access_Function_Definition and N_Function_Specification. (Set_Null_Exclusion_Present): Allow this flag for N_Function_Specification. (Set_Result_Definition): New procedure for N_Function_Specifications. (Set_Subtype_Mark): No longer allowed for N_Access_Function_Definition and N_Function_Specification. * sinfo.ads: Update grammar rules for 9.7.2: Entry_Call_Alternative, Procedure_Or_Entry_Call; 9.7.4: Triggering_Statement. Add support for LIMITED NEW for Ada 2005 AI-419 Update the syntax of PARAMETER_AND_RESULT_PROFILE to reflect the new syntax for anonymous access results. Replace Subtype_Mark field by Result_Definition in N_Function_Specification and N_Access_Definition specs. Add Null_Exclusion_Present to spec of N_Function_Specification. (Result_Definition): New function for N_Function_Specification and N_Access_Function_Definition. (Set_Result_Definition): New procedure for N_Function_Specification and N_Access_Function_Definition. * sprint.adb (S_Print_Node_Actual): Change Subtype_Mark calls to Result_Definition for cases of N_Access_Function_Definition and N_Function_Specification. Print "not null" if Null_Exclusion_Present on N_Function_Specification. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@103869 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/layout.adb | 5 ++-- gcc/ada/par-ch3.adb | 60 ++++++++++++++++++++++++++++++++++++++--- gcc/ada/par-ch6.adb | 78 ++++++++++++++++++++++++++++++++++++++++------------- gcc/ada/sinfo.adb | 26 +++++++++++++++--- gcc/ada/sinfo.ads | 56 +++++++++++++++++++++++++------------- gcc/ada/sprint.adb | 13 +++++++-- 6 files changed, 189 insertions(+), 49 deletions(-) diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index d1568f9..6f702c0 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -3017,7 +3017,7 @@ package body Layout is Make_Defining_Identifier (Loc, Chars => Vname), Parameter_Type => New_Occurrence_Of (Vtype_Primary_View, Loc))), - Subtype_Mark => + Result_Definition => New_Occurrence_Of (Standard_Unsigned, Loc)), Declarations => Empty_List, @@ -3039,7 +3039,8 @@ package body Layout is Make_Function_Specification (Loc, Defining_Unit_Name => K, Parameter_Specifications => Empty_List, - Subtype_Mark => New_Occurrence_Of (Standard_Unsigned, Loc)), + Result_Definition => + New_Occurrence_Of (Standard_Unsigned, Loc)), Declarations => Empty_List, diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 695e89d..d4e84a5 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -644,6 +644,31 @@ package body Ch3 is Is_Derived_Iface := True; end if; + -- Ada 2005 (AI-419): LIMITED NEW + + elsif Token = Tok_New then + 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; + + Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; + Set_Limited_Present (Typedef_Node); + + if Nkind (Typedef_Node) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (Typedef_Node)) + then + End_Labl := + Make_Identifier (Token_Ptr, + Chars => Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label + (Record_Extension_Part (Typedef_Node), End_Labl); + end if; + -- LIMITED PRIVATE is the only remaining possibility here else @@ -853,6 +878,7 @@ package body Ch3 is function P_Subtype_Declaration return Node_Id is Decl_Node : Node_Id; Not_Null_Present : Boolean := False; + begin Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr); Scan; -- past SUBTYPE @@ -1732,12 +1758,12 @@ package body Ch3 is ------------------------------------------------------------------------- -- DERIVED_TYPE_DEFINITION ::= - -- [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION + -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION -- [[AND interface_list] RECORD_EXTENSION_PART] -- PRIVATE_EXTENSION_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is - -- [abstract] new ancestor_SUBTYPE_INDICATION + -- [abstract] [limited] new ancestor_SUBTYPE_INDICATION -- [AND interface_list] with PRIVATE; -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION @@ -3579,6 +3605,8 @@ package body Ch3 is Prot_Flag : Boolean; Not_Null_Present : Boolean := False; Type_Def_Node : Node_Id; + Result_Not_Null : Boolean; + Result_Node : Node_Id; procedure Check_Junk_Subprogram_Name; -- Used in access to subprogram definition cases to check for an @@ -3649,8 +3677,32 @@ package body Ch3 is 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; + + Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231) + + -- Ada 2005 (AI-318-02) + + if Token = Tok_Access then + if Ada_Version < Ada_05 then + Error_Msg_SC + ("anonymous access result type is an Ada 2005 extension"); + Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); + end if; + + Result_Node := P_Access_Definition (Result_Not_Null); + + 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); + + Set_Result_Definition (Type_Def_Node, Result_Node); else Type_Def_Node := diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index f6a5874..6996007 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -138,19 +138,20 @@ package body Ch6 is function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is Specification_Node : Node_Id; - Name_Node : Node_Id; - Fpart_List : List_Id; - Fpart_Sloc : Source_Ptr; - Return_Node : Node_Id; - Inst_Node : Node_Id; - Body_Node : Node_Id; - Decl_Node : Node_Id; - Rename_Node : Node_Id; - Absdec_Node : Node_Id; - Stub_Node : Node_Id; - Fproc_Sloc : Source_Ptr; - Func : Boolean; - Scan_State : Saved_Scan_State; + Name_Node : Node_Id; + Fpart_List : List_Id; + Fpart_Sloc : Source_Ptr; + Result_Not_Null : Boolean := False; + Result_Node : Node_Id; + Inst_Node : Node_Id; + Body_Node : Node_Id; + Decl_Node : Node_Id; + Rename_Node : Node_Id; + Absdec_Node : Node_Id; + Stub_Node : Node_Id; + Fproc_Sloc : Source_Ptr; + Func : Boolean; + Scan_State : Saved_Scan_State; -- Flags for optional overriding indication. Two flags are needed, -- to distinguish positive and negative overriding indicators from @@ -318,7 +319,7 @@ package body Ch6 is -- since later RETURN statements will be valid in either case. Check_Junk_Semicolon_Before_Return; - Return_Node := Error; + Result_Node := Error; if Token = Tok_Return then if not Func then @@ -327,8 +328,24 @@ package body Ch6 is end if; Scan; -- past RETURN - Return_Node := P_Subtype_Mark; - No_Constraint; + + Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231) + + -- Ada 2005 (AI-318-02) + + if Token = Tok_Access then + if Ada_Version < Ada_05 then + Error_Msg_SC + ("anonymous access result type is an Ada 2005 extension"); + Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); + end if; + + Result_Node := P_Access_Definition (Result_Not_Null); + + else + Result_Node := P_Subtype_Mark; + No_Constraint; + end if; else if Func then @@ -340,7 +357,9 @@ package body Ch6 is if Func then Specification_Node := New_Node (N_Function_Specification, Fproc_Sloc); - Set_Subtype_Mark (Specification_Node, Return_Node); + + Set_Null_Exclusion_Present (Specification_Node, Result_Not_Null); + Set_Result_Definition (Specification_Node, Result_Node); else Specification_Node := @@ -618,6 +637,8 @@ package body Ch6 is function P_Subprogram_Specification return Node_Id is Specification_Node : Node_Id; + Result_Not_Null : Boolean; + Result_Node : Node_Id; begin if Token = Tok_Function then @@ -629,8 +650,27 @@ package body Ch6 is (Specification_Node, P_Parameter_Profile); Check_Junk_Semicolon_Before_Return; TF_Return; - Set_Subtype_Mark (Specification_Node, P_Subtype_Mark); - No_Constraint; + + Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231) + + -- Ada 2005 (AI-318-02) + + if Token = Tok_Access then + if Ada_Version < Ada_05 then + Error_Msg_SC + ("anonymous access result type is an Ada 2005 extension"); + Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); + end if; + + Result_Node := P_Access_Definition (Result_Not_Null); + + else + Result_Node := P_Subtype_Mark; + No_Constraint; + end if; + + Set_Null_Exclusion_Present (Specification_Node, Result_Not_Null); + Set_Result_Definition (Specification_Node, Result_Node); return Specification_Node; elsif Token = Tok_Procedure then diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 553e789..83e094c 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1668,6 +1668,7 @@ package body Sinfo is pragma Assert (False or else NT (N).Nkind = N_Derived_Type_Definition or else NT (N).Nkind = N_Formal_Private_Type_Definition + or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Private_Type_Declaration or else NT (N).Nkind = N_Record_Definition or else NT (N).Nkind = N_With_Clause); @@ -1915,6 +1916,7 @@ package body Sinfo is or else NT (N).Nkind = N_Component_Definition or else NT (N).Nkind = N_Derived_Type_Definition or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Function_Specification or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification or else NT (N).Nkind = N_Subtype_Declaration); @@ -2243,6 +2245,15 @@ package body Sinfo is return Flag13 (N); end Redundant_Use; + function Result_Definition + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Function_Definition + or else NT (N).Nkind = N_Function_Specification); + return Node4 (N); + end Result_Definition; + function Return_Type (N : Node_Id) return Node_Id is begin @@ -2415,10 +2426,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Access_Definition - or else NT (N).Nkind = N_Access_Function_Definition or else NT (N).Nkind = N_Formal_Derived_Type_Definition or else NT (N).Nkind = N_Formal_Object_Declaration - or else NT (N).Nkind = N_Function_Specification or else NT (N).Nkind = N_Object_Renaming_Declaration or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Subtype_Indication @@ -4220,6 +4229,7 @@ package body Sinfo is pragma Assert (False or else NT (N).Nkind = N_Derived_Type_Definition or else NT (N).Nkind = N_Formal_Private_Type_Definition + or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Private_Type_Declaration or else NT (N).Nkind = N_Record_Definition or else NT (N).Nkind = N_With_Clause); @@ -4467,6 +4477,7 @@ package body Sinfo is or else NT (N).Nkind = N_Component_Definition or else NT (N).Nkind = N_Derived_Type_Definition or else NT (N).Nkind = N_Discriminant_Specification + or else NT (N).Nkind = N_Function_Specification or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification or else NT (N).Nkind = N_Subtype_Declaration); @@ -4795,6 +4806,15 @@ package body Sinfo is Set_Flag13 (N, Val); end Set_Redundant_Use; + procedure Set_Result_Definition + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_Function_Definition + or else NT (N).Nkind = N_Function_Specification); + Set_Node4_With_Parent (N, Val); + end Set_Result_Definition; + procedure Set_Return_Type (N : Node_Id; Val : Node_Id) is begin @@ -4967,10 +4987,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Access_Definition - or else NT (N).Nkind = N_Access_Function_Definition or else NT (N).Nkind = N_Formal_Derived_Type_Definition or else NT (N).Nkind = N_Formal_Object_Declaration - or else NT (N).Nkind = N_Function_Specification or else NT (N).Nkind = N_Object_Renaming_Declaration or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Subtype_Indication diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 5172e55..6bc6926 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1120,6 +1120,11 @@ package Sinfo is -- suppress any warnings that would otherwise be issued inside the -- loop since they are probably not useful. + -- Is_Overloaded (Flag5-Sem) + -- A flag present in all expression nodes. Used temporarily during + -- overloading determination. The setting of this flag is not + -- relevant once overloading analysis is complete. + -- Is_Power_Of_2_For_Shift (Flag13-Sem) -- A flag present only in N_Op_Expon nodes. It is set when the -- exponentiation is of the forma 2 ** N, where the type of N is @@ -2052,10 +2057,11 @@ package Sinfo is ---------------------------------- -- DERIVED_TYPE_DEFINITION ::= - -- [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION + -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART] - -- Note: ABSTRACT, record extension part not permitted in Ada 83 mode + -- Note: ABSTRACT, LIMITED and record extension part are not permitted + -- in Ada 83 mode -- Note: a record extension part is required if ABSTRACT is present @@ -2065,17 +2071,16 @@ package Sinfo is -- Null_Exclusion_Present (Flag11) (set to False if not present) -- Subtype_Indication (Node5) -- Record_Extension_Part (Node3) (set to Empty if not present) - -- Limited_Present (Flag17) set in interfaces + -- Limited_Present (Flag17) -- Task_Present (Flag5) set in task interfaces -- Protected_Present (Flag6) set in protected interfaces -- Synchronized_Present (Flag7) set in interfaces -- Interface_List (List2) (set to No_List if none) -- Interface_Present (Flag16) set in abstract interfaces - -- Note: The attributes Limited_Present, Task_Present, Protected_Present - -- Synchronized_Present, Interface_List and Interface_Present are - -- used for abstract interfaces (see comment in the definition - -- of INTERFACE_TYPE_DEFINITION) + -- Note: Task_Present, Protected_Present, Synchronized_Present, + -- Interface_List, and Interface_Present are used for abstract + -- interfaces (see comments for INTERFACE_TYPE_DEFINITION). --------------------------- -- 3.5 Range Constraint -- @@ -2531,10 +2536,9 @@ package Sinfo is -- Interface_Present (Flag16) set in abstract interfaces -- Interface_List (List2) (set to No_List if none) - -- Note: The attributes Task_Present, Protected_Present, Synchronized - -- _Present, Interface_List and Interface_Present are - -- used for abstract interfaces (see comment in the definition - -- of INTERFACE_TYPE_DEFINITION) + -- Note: Task_Present, Protected_Present, Synchronized _Present, + -- Interface_List and Interface_Present are used for abstract + -- interfaces (see comments for INTERFACE_TYPE_DEFINITION). ------------------------- -- 3.8 Component List -- @@ -2731,7 +2735,7 @@ package Sinfo is -- Null_Exclusion_Present (Flag11) -- Protected_Present (Flag6) -- Parameter_Specifications (List3) (set to No_List if no formal part) - -- Subtype_Mark (Node4) result subtype + -- Result_Definition (Node4) result subtype (subtype mark or access def) -- N_Access_Procedure_Definition -- Sloc points to ACCESS @@ -3913,7 +3917,8 @@ package Sinfo is -- Defining_Unit_Name (Node1) (the designator) -- Elaboration_Boolean (Node2-Sem) -- Parameter_Specifications (List3) (set to No_List if no formal part) - -- Subtype_Mark (Node4) for return type + -- Null_Exclusion_Present (Flag11) + -- Result_Definition (Node4) for result subtype -- Generic_Parent (Node5-Sem) -- Must_Override (Flag14) set if overriding indicator present -- Must_Not_Override (Flag15) set if not_overriding indicator present @@ -4041,7 +4046,9 @@ package Sinfo is -- 6.1 Parameter and Result Profile -- --------------------------------------- - -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK + -- PARAMETER_AND_RESULT_PROFILE ::= + -- [FORMAL_PART] return [NULL_EXCLUSION] SUBTYPE_MARK + -- | [FORMAL_PART] return ACCESS_DEFINITION -- There is no explicit node in the tree for a parameter and result -- profile. Instead the information appears directly in the parent. @@ -4315,10 +4322,11 @@ package Sinfo is -- PRIVATE_EXTENSION_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is - -- [abstract] new ancestor_SUBTYPE_INDICATION + -- [abstract] [limited] new ancestor_SUBTYPE_INDICATION -- [and INTERFACE_LIST] with private; - -- Note: private extension declarations are not allowed in Ada 83 mode + -- Note: LIMITED, and private extension declarations are not allowed + -- in Ada 83 mode. -- N_Private_Extension_Declaration -- Sloc points to TYPE @@ -4327,6 +4335,7 @@ package Sinfo is -- discriminant part) -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant -- Abstract_Present (Flag4) + -- Limited_Present (Flag17) -- Subtype_Indication (Node5) -- Interface_List (List2) (set to No_List if none) @@ -4956,7 +4965,10 @@ package Sinfo is ----------------------------------- -- ENTRY_CALL_ALTERNATIVE ::= - -- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS] + -- PROCEDURE_OR_ENTRY_CALL [SEQUENCE_OF_STATEMENTS] + + -- PROCEDURE_OR_ENTRY_CALL ::= + -- PROCEDURE_CALL_STATEMENT | ENTRY_CALL_STATEMENT -- Gigi restriction: This node never appears @@ -5023,7 +5035,7 @@ package Sinfo is -- 9.7.4 Triggering Statement -- --------------------------------- - -- TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT + -- TRIGGERING_STATEMENT ::= PROCEDURE_OR_ENTRY_CALL | DELAY_STATEMENT --------------------------- -- 9.7.4 Abortable Part -- @@ -7742,6 +7754,9 @@ package Sinfo is function Redundant_Use (N : Node_Id) return Boolean; -- Flag13 + function Result_Definition + (N : Node_Id) return Node_Id; -- Node4 + function Return_Type (N : Node_Id) return Node_Id; -- Node2 @@ -8549,6 +8564,9 @@ package Sinfo is procedure Set_Redundant_Use (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Result_Definition + (N : Node_Id; Val : Node_Id); -- Node4 + procedure Set_Return_Type (N : Node_Id; Val : Node_Id); -- Node2 @@ -8921,6 +8939,7 @@ package Sinfo is pragma Inline (Reason); pragma Inline (Record_Extension_Part); pragma Inline (Redundant_Use); + pragma Inline (Result_Definition); pragma Inline (Return_Type); pragma Inline (Reverse_Present); pragma Inline (Right_Opnd); @@ -9186,6 +9205,7 @@ package Sinfo is pragma Inline (Set_Reason); pragma Inline (Set_Record_Extension_Part); pragma Inline (Set_Redundant_Use); + pragma Inline (Set_Result_Definition); pragma Inline (Set_Return_Type); pragma Inline (Set_Reverse_Present); pragma Inline (Set_Right_Opnd); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 94347f4..58e61df 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -749,7 +749,7 @@ package body Sprint is Write_Str_With_Col_Check ("function"); Write_Param_Specs (Node); Write_Str_With_Col_Check (" return "); - Sprint_Node (Subtype_Mark (Node)); + Sprint_Node (Result_Definition (Node)); when N_Access_Procedure_Definition => @@ -1546,7 +1546,16 @@ package body Sprint is Sprint_Node (Defining_Unit_Name (Node)); Write_Param_Specs (Node); Write_Str_With_Col_Check (" return "); - Sprint_Node (Subtype_Mark (Node)); + + -- Ada 2005 (AI-231) + + if Nkind (Result_Definition (Node)) /= N_Access_Definition + and then Null_Exclusion_Present (Node) + then + Write_Str (" not null "); + end if; + + Sprint_Node (Result_Definition (Node)); when N_Generic_Association => Set_Debug_Sloc; -- 2.7.4