OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

layout.adb (SO_Ref_From_Expr): Change Subtype_Mark to Result_Definition. 

2005-09-01  Gary Dismukes  <dismukes@adacore.com>
	    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.

From-SVN: r103869
This commit is contained in:
Gary Dismukes 2005-09-05 09:55:06 +02:00 committed by Arnaud Charlet
parent ec53a6da66
commit 244480db09
6 changed files with 189 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/ada/layout.adb
View File

@ -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,

60
gcc/ada/par-ch3.adb
View File

@ -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 :=

78
gcc/ada/par-ch6.adb
View File

@ -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

26
gcc/ada/sinfo.adb
View File

@ -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

56
gcc/ada/sinfo.ads
View File

@ -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);

13
gcc/ada/sprint.adb
View File

@ -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;