Skip to content

R
riscv-gcc-1
Commit 2e79de51 by Arnaud Charlet
Options

[multiple changes] 

2010-10-07  Robert Dewar  <dewar@adacore.com>

	* par-ch3.adb, par-ch6.adb, par-ch7.adb, par-ch9.adb, par-ch10.adb: Add
	Pexp to Pf_Rec constants
	(P_Subprogram): Expression is always enclosed in parentheses
	* par.adb (Pf_Rec): add Pexp flag for parametrized expression
	* sinfo.ads (N_Parametrized_Expression): Expression must be in parens

2010-10-07  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Analyze_Subprogram_Specification): Implement Ada2012
	checks on functions that return an abstract type or have a controlling
	result whose designated type is an abstract type.
	(Check_Private_Overriding): Implement Ada2012 checks on functions
	declared in the private part, if an abstract type is involved.
	* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): In Ada2012,
	reject a generic function that returns an abstract type.
	* exp_ch5.adb (Expand_Simple_Function_Return): in Ada2012, if a
	function has a controlling access result, check that the tag of the
	return value matches the designated type of the return expression.

From-SVN: r165100
parent da7d70aa
Showing with 212 additions and 85 deletions
gcc/ada/ChangeLog
2010-10-07 Robert Dewar <dewar@adacore.com>
* par-ch3.adb, par-ch6.adb, par-ch7.adb, par-ch9.adb, par-ch10.adb: Add
Pexp to Pf_Rec constants
(P_Subprogram): Expression is always enclosed in parentheses
* par.adb (Pf_Rec): add Pexp flag for parametrized expression
* sinfo.ads (N_Parametrized_Expression): Expression must be in parens
2010-10-07 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Subprogram_Specification): Implement Ada2012
checks on functions that return an abstract type or have a controlling
result whose designated type is an abstract type.
(Check_Private_Overriding): Implement Ada2012 checks on functions
declared in the private part, if an abstract type is involved.
* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): In Ada2012,
reject a generic function that returns an abstract type.
* exp_ch5.adb (Expand_Simple_Function_Return): in Ada2012, if a
function has a controlling access result, check that the tag of the
return value matches the designated type of the return expression.
2010-10-07 Robert Dewar <dewar@adacore.com>
* par-ch6.adb: Fix error in handling of parametrized expressions.
* par-ch4.adb (P_Name): Allow qualified expression as name in Ada 2012
mode.
......
gcc/ada/exp_ch5.adb
......@@ -4246,6 +4246,29 @@ package body Exp_Ch5 is
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
Reason => PE_Accessibility_Check_Failed));
end;
-- AI05-0073 : if function has a controlling access result, check that
-- the tag of the return value matches the designated type.
elsif Ekind (R_Type) = E_Anonymous_Access_Type
and then Has_Controlling_Result (Scope_Id)
and then Ada_Version >= Ada_12
then
Insert_Action (Exp,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Exp),
Selector_Name =>
Make_Identifier (Loc, Chars => Name_uTag)),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Designated_Type (R_Type), Loc),
Attribute_Name => Name_Tag)),
Reason => CE_Tag_Check_Failed));
end if;
-- If we are returning an object that may not be bit-aligned, then copy
......
gcc/ada/par-ch10.adb
......@@ -347,10 +347,10 @@ package body Ch10 is
Error_Msg_BC -- CODEFIX
("keyword BODY expected here [see file name]");
Restore_Scan_State (Scan_State);
Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod));
Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod_Pexp));
else
Restore_Scan_State (Scan_State);
Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam));
Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam_Pexp));
end if;
elsif Token = Tok_Generic then
......@@ -364,7 +364,7 @@ package body Ch10 is
or else Token = Tok_Overriding
or else Token = Tok_Procedure
then
Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam));
Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Pexp));
-- A little bit of an error recovery check here. If we just scanned
-- a subprogram declaration (as indicated by an SIS entry being
......@@ -1034,10 +1034,10 @@ package body Ch10 is
or else Token = Tok_Overriding
or else Token = Tok_Procedure
then
Body_Node := P_Subprogram (Pf_Pbod);
Body_Node := P_Subprogram (Pf_Pbod_Pexp);
elsif Token = Tok_Package then
Body_Node := P_Package (Pf_Pbod);
Body_Node := P_Package (Pf_Pbod_Pexp);
elsif Token = Tok_Protected then
Scan; -- past PROTECTED
......
gcc/ada/par-ch3.adb
......@@ -4142,7 +4142,7 @@ package body Ch3 is
when Tok_Function =>
Check_Bad_Layout;
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Done := False;
when Tok_For =>
......@@ -4186,7 +4186,7 @@ package body Ch3 is
Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
Token := Tok_Overriding;
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Done := False;
-- Normal case, no overriding, or overriding followed by colon
......@@ -4201,17 +4201,17 @@ package body Ch3 is
when Tok_Not =>
Check_Bad_Layout;
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Done := False;
when Tok_Overriding =>
Check_Bad_Layout;
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Done := False;
when Tok_Package =>
Check_Bad_Layout;
Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Done := False;
when Tok_Pragma =>
......@@ -4220,7 +4220,7 @@ package body Ch3 is
when Tok_Procedure =>
Check_Bad_Layout;
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Done := False;
when Tok_Protected =>
......
gcc/ada/par-ch6.adb
......@@ -124,7 +124,7 @@ package body Ch6 is
-- other subprogram constructs.
-- PARAMETRIZED_EXPRESSION ::=
-- FUNCTION SPECIFICATION IS EXPRESSION;
-- FUNCTION SPECIFICATION IS (EXPRESSION);
-- The value in Pf_Flags indicates which of these possible declarations
-- is acceptable to the caller:
......@@ -134,6 +134,7 @@ package body Ch6 is
-- Pf_Flags.Pbod Set if proper body OK
-- Pf_Flags.Rnam Set if renaming declaration OK
-- Pf_Flags.Stub Set if body stub OK
-- Pf_Flags.Pexp Set if parametrized expression OK
-- If an inappropriate form is encountered, it is scanned out but an
-- error message indicating that it is appearing in an inappropriate
......@@ -221,17 +222,17 @@ package body Ch6 is
-- already been given, so no need to give another message here.
-- An overriding indicator is allowed for subprogram declarations,
-- bodies (including subunits), renamings, stubs, and
-- instantiations. The test against Pf_Decl_Pbod is added to account
-- for the case of subprograms declared in a protected type, where
-- only subprogram declarations and bodies can occur. The Pf_Pbod
-- case is for subunits.
-- bodies (including subunits), renamings, stubs, and instantiations.
-- The test against Pf_Decl_Pbod is added to account for the case of
-- subprograms declared in a protected type, where only subprogram
-- declarations and bodies can occur. The Pf_Pbod case is for
-- subunits.
if Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub
if Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
and then
Pf_Flags /= Pf_Decl_Pbod
Pf_Flags /= Pf_Decl_Pbod_Pexp
and then
Pf_Flags /= Pf_Pbod
Pf_Flags /= Pf_Pbod_Pexp
then
Error_Msg_SC ("overriding indicator not allowed here!");
......@@ -583,12 +584,9 @@ package body Ch6 is
end if;
end if;
-- Processing for subprogram body or parametrized expression
-- Processing for stub or subprogram body or parametrized expression
<<Subprogram_Body>>
if not Pf_Flags.Pbod then
Error_Msg_SP ("subprogram body not allowed here!");
end if;
-- Subprogram body stub case
......@@ -614,28 +612,24 @@ package body Ch6 is
-- Subprogram body or parametrized expression case
else
-- Here we must distinguish a body and a parametrized expression
Scan_Body_Or_Parametrized_Expression : declare
Parse_Body_Or_Parametrized_Expression : declare
function Is_Parametrized_Expression return Boolean;
-- Returns True if we have case of parametrized epression
function Likely_Parametrized_Expression return Boolean;
-- Returns True if we have a probably case of a parametrized
-- expression omitting the parentheses, if so, returns True
-- and emits an appropriate error message, else returns False.
--------------------------------
-- Is_Parametrized_Expression --
--------------------------------
------------------------------------
-- Likely_Parametrized_Expression --
------------------------------------
function Is_Parametrized_Expression return Boolean is
function Likely_Parametrized_Expression return Boolean is
begin
-- Parametrized expression only allowed in Ada 2012
if Ada_Version < Ada_12 then
return False;
-- If currently pointing to BEGIN or a declaration keyword
-- or a pragma, then we definitely have a subprogram body.
-- This is a common case, so worth testing first.
elsif Token = Tok_Begin
if Token = Tok_Begin
or else Token in Token_Class_Declk
or else Token = Tok_Pragma
then
......@@ -652,21 +646,27 @@ package body Ch6 is
or else Token = Tok_New
or else Token = Tok_Not
then
return True;
null;
-- Anything other than an identifier must be a body at
-- this stage. Probably we could do a little better job of
-- distingushing some more error cases, but it seems right
-- to err on the side of favoring a body over the
-- new-fangled parametrized expression.
-- Anything other than an identifier must be a body
elsif Token /= Tok_Identifier then
return False;
-- For identifier we have to scan ahead if identifier is
-- followed by a colon or a comma, it is a declaration and
-- hence we have a subprogram body. Otherwise we have an
-- expression.
-- Here for an identifier
else
-- If the identifier is the first token on its line, then
-- let's assume that we have a missing begin and this is
-- intended as a subprogram body.
if Token_Is_At_Start_Of_Line then
return False;
-- Otherwise we have to scan ahead. If the identifier is
-- followed by a colon or a comma, it is a declaration
-- and hence we have a subprogram body. Otherwise assume
-- a parametrized expression.
else
declare
......@@ -677,17 +677,48 @@ package body Ch6 is
Scan; -- past identifier
Tok := Token;
Restore_Scan_State (Scan_State);
return Tok /= Tok_Colon and then Tok /= Tok_Comma;
if Tok = Tok_Colon or else Tok = Tok_Comma then
return False;
end if;
end;
end if;
end Is_Parametrized_Expression;
end if;
-- Fall through if we have a likely parametrized expression
Error_Msg_SC
("parametrized expression must be "
& "enclosed in parentheses");
return True;
end Likely_Parametrized_Expression;
-- Start of processing for Parse_Body_Or_Parametrized_Expression
-- Start of processing for Scan_Body_Or_Parametrized_Expression
begin
-- Parametrized_Expression case, parse expression
-- Parametrized_Expression case
if Token = Tok_Left_Paren
or else Likely_Parametrized_Expression
then
-- Check parametrized expression allowed here
if not Pf_Flags.Pexp then
Error_Msg_SC
("parametrized expression not allowed here!");
end if;
-- Check we are in Ada 2012 mode
if Ada_Version < Ada_12 then
Error_Msg_SC
("parametrized expression is an Ada 2012 feature!");
Error_Msg_SC
("\unit must be compiled with -gnat2012 switch!");
end if;
-- Parse out expression and build parametrized expression
if Is_Parametrized_Expression then
Body_Node :=
New_Node
(N_Parametrized_Expression, Sloc (Specification_Node));
......@@ -699,10 +730,16 @@ package body Ch6 is
-- Subprogram body case
else
-- Here is the test for a suspicious IS (i.e. one that looks
-- like it might more properly be a semicolon). See separate
-- section discussing use of IS instead of semicolon in
-- package Parse.
-- Check body allowed here
if not Pf_Flags.Pbod then
Error_Msg_SP ("subprogram body not allowed here!");
end if;
-- Here is the test for a suspicious IS (i.e. one that
-- looks like it might more properly be a semicolon).
-- See separate section describing use of IS instead
-- of semicolon in package Parse.
if (Token in Token_Class_Declk
or else
......@@ -715,7 +752,7 @@ package body Ch6 is
end if;
-- Build and return subprogram body, parsing declarations
-- an statement sequence that belong to the body.
-- and statement sequence that belong to the body.
Body_Node :=
New_Node (N_Subprogram_Body, Sloc (Specification_Node));
......@@ -724,7 +761,7 @@ package body Ch6 is
end if;
return Body_Node;
end Parse_Body_Or_Parametrized_Expression;
end Scan_Body_Or_Parametrized_Expression;
end if;
-- Processing for subprogram declaration
......
gcc/ada/par-ch7.adb
......@@ -109,7 +109,7 @@ package body Ch7 is
-- Case of package body. Note that we demand a package body if that
-- is the only possibility (even if the BODY keyword is not present)
if Token = Tok_Body or else Pf_Flags = Pf_Pbod then
if Token = Tok_Body or else Pf_Flags = Pf_Pbod_Pexp then
if not Pf_Flags.Pbod then
Error_Msg_SC ("package body cannot appear here!");
end if;
......
gcc/ada/par-ch9.adb
......@@ -651,7 +651,7 @@ package body Ch9 is
Set_Must_Not_Override (Decl, Not_Overriding);
elsif Token = Tok_Function or else Token = Tok_Procedure then
Decl := P_Subprogram (Pf_Decl);
Decl := P_Subprogram (Pf_Decl_Pexp);
Set_Must_Override (Specification (Decl), Is_Overriding);
Set_Must_Not_Override (Specification (Decl), Not_Overriding);
......@@ -682,7 +682,7 @@ package body Ch9 is
return P_Entry_Declaration;
elsif Token = Tok_Function or else Token = Tok_Procedure then
return P_Subprogram (Pf_Decl);
return P_Subprogram (Pf_Decl_Pexp);
elsif Token = Tok_Identifier then
L := New_List;
......@@ -754,7 +754,7 @@ package body Ch9 is
or else
Token = Tok_Not or else Bad_Spelling_Of (Tok_Not)
then
Append (P_Subprogram (Pf_Decl_Pbod), Item_List);
Append (P_Subprogram (Pf_Decl_Pbod_Pexp), Item_List);
elsif Token = Tok_Pragma or else Bad_Spelling_Of (Tok_Pragma) then
P_Pragmas_Opt (Item_List);
......
gcc/ada/par.adb
......@@ -352,7 +352,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
Pbod : Boolean; -- True if proper body OK
Rnam : Boolean; -- True if renaming declaration OK
Stub : Boolean; -- True if body stub OK
Fil1 : Boolean; -- Filler to fill to 8 bits
Pexp : Boolean; -- True if parametried expression OK
Fil2 : Boolean; -- Filler to fill to 8 bits
end record;
pragma Pack (Pf_Rec);
......@@ -360,16 +360,16 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
function T return Boolean renames True;
function F return Boolean renames False;
Pf_Decl_Gins_Pbod_Rnam_Stub : constant Pf_Rec :=
Pf_Rec'(F, T, T, T, T, T, F, F);
Pf_Decl : constant Pf_Rec :=
Pf_Rec'(F, T, F, F, F, F, F, F);
Pf_Decl_Gins_Pbod_Rnam : constant Pf_Rec :=
Pf_Rec'(F, T, T, T, T, F, F, F);
Pf_Decl_Pbod : constant Pf_Rec :=
Pf_Rec'(F, T, F, T, F, F, F, F);
Pf_Pbod : constant Pf_Rec :=
Pf_Rec'(F, F, F, T, F, F, F, F);
Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp : constant Pf_Rec :=
Pf_Rec'(F, T, T, T, T, T, T, F);
Pf_Decl_Pexp : constant Pf_Rec :=
Pf_Rec'(F, T, F, F, F, F, T, F);
Pf_Decl_Gins_Pbod_Rnam_Pexp : constant Pf_Rec :=
Pf_Rec'(F, T, T, T, T, F, T, F);
Pf_Decl_Pbod_Pexp : constant Pf_Rec :=
Pf_Rec'(F, T, F, T, F, F, T, F);
Pf_Pbod_Pexp : constant Pf_Rec :=
Pf_Rec'(F, F, F, T, F, F, T, F);
Pf_Spcn : constant Pf_Rec :=
Pf_Rec'(T, F, F, F, F, F, F, F);
-- The above are the only allowed values of Pf_Rec arguments
......
gcc/ada/sem_ch12.adb
......@@ -2800,10 +2800,28 @@ package body Sem_Ch12 is
if Nkind (Result_Definition (Spec)) = N_Access_Definition then
Result_Type := Access_Definition (Spec, Result_Definition (Spec));
Set_Etype (Id, Result_Type);
-- Check restriction imposed by AI05-073 : a generic function
-- cannot return an abstract type or an access to such.
if Is_Abstract_Type (Designated_Type (Result_Type))
and then Ada_Version >= Ada_12
then
Error_Msg_N ("generic function cannot have an access result"
& " that designates an abstract type", Spec);
end if;
else
Find_Type (Result_Definition (Spec));
Typ := Entity (Result_Definition (Spec));
if Is_Abstract_Type (Typ)
and then Ada_Version >= Ada_12
then
Error_Msg_N
("generic function cannot have abstract result type", Spec);
end if;
-- If a null exclusion is imposed on the result type, then create
-- a null-excluding itype (an access subtype) and use it as the
-- function's Etype.
......
gcc/ada/sem_ch6.adb
......@@ -2960,16 +2960,29 @@ package body Sem_Ch6 is
-- In case of primitives associated with abstract interface types
-- the check is applied later (see Analyze_Subprogram_Declaration).
if not Nkind_In (Parent (N),
N_Subprogram_Renaming_Declaration,
N_Abstract_Subprogram_Declaration,
N_Formal_Abstract_Subprogram_Declaration)
then
if Is_Abstract_Type (Etype (Designator))
and then not Is_Interface (Etype (Designator))
and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
and then Nkind (Parent (N)) /=
N_Abstract_Subprogram_Declaration
and then
(Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration
then
Error_Msg_N
("function that returns abstract type must be abstract", N);
-- Ada 2012 (AI-0073) : extend this test to subprograms with an
-- access result whose designated type is abstract.
elsif Nkind (Result_Definition (N)) = N_Access_Definition
and then
not Is_Class_Wide_Type (Designated_Type (Etype (Designator)))
and then Is_Abstract_Type (Designated_Type (Etype (Designator)))
and then Ada_Version >= Ada_12
then
Error_Msg_N ("function whose access result designates "
& "abstract type must be abstract", N);
end if;
end if;
end if;
......@@ -7029,16 +7042,34 @@ package body Sem_Ch6 is
& "(RM 3.9.3(10))!", S);
elsif Ekind (S) = E_Function
and then Is_Tagged_Type (T)
and then T = Base_Type (Etype (S))
and then not Is_Overriding
then
if Is_Tagged_Type (T)
and then T = Base_Type (Etype (S))
then
Error_Msg_N
("private function with tagged result must"
& " override visible-part function", S);
Error_Msg_N
("\move subprogram to the visible part"
& " (RM 3.9.3(10))", S);
-- AI05-0073: extend this test to the case of a function
-- with a controlling access result.
elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
and then Is_Tagged_Type (Designated_Type (Etype (S)))
and then
not Is_Class_Wide_Type (Designated_Type (Etype (S)))
and then Ada_Version >= Ada_12
then
Error_Msg_N
("private function with controlling access result "
& "must override visible-part function", S);
Error_Msg_N
("\move subprogram to the visible part"
& " (RM 3.9.3(10))", S);
end if;
end if;
end if;
end Check_Private_Overriding;
......
gcc/ada/sinfo.ads
......@@ -4435,10 +4435,7 @@ package Sinfo is
-- and put in its proper section when we know exactly where that is!
-- PARAMETRIZED_EXPRESSION ::=
-- FUNCTION SPECIFICATION IS EXPRESSION;
-- Note: there are no separate nodes for the profiles, instead the
-- information appears directly in the following nodes.
-- FUNCTION SPECIFICATION IS (EXPRESSION);
-- N_Parametrized_Expression
-- Sloc points to FUNCTION
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment