Robert Dewar <dewar@adacore.com>
Hristian Kirtchev <kirtchev@adacore.com>
* 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
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,
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,
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
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
-------------------------------------------------------------------------
-- 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
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
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 :=
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
-- 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
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
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 :=
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
(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
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);
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);
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
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
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);
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);
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
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
-- 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
----------------------------------
-- 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
-- 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 --
-- 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 --
-- 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
-- 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
-- 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.
-- 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
-- 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)
-----------------------------------
-- 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
-- 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 --
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
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
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);
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);
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 =>
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;
OSDN Git Service
