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.
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
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
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
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
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 =>
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
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 =>
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 =>
-- 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:
-- 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
-- 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!");
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
-- 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
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
- declare
- Scan_State : Saved_Scan_State;
- Tok : Token_Type;
- begin
- Save_Scan_State (Scan_State);
- Scan; -- past identifier
- Tok := Token;
- Restore_Scan_State (Scan_State);
- return Tok /= Tok_Colon and then Tok /= Tok_Comma;
- end;
+ -- 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
+ Scan_State : Saved_Scan_State;
+ Tok : Token_Type;
+ begin
+ Save_Scan_State (Scan_State);
+ Scan; -- past identifier
+ Tok := Token;
+ Restore_Scan_State (Scan_State);
+
+ if Tok = Tok_Colon or else Tok = Tok_Comma then
+ return False;
+ end if;
+ end;
+ end if;
end if;
- end Is_Parametrized_Expression;
- -- Start of processing for Parse_Body_Or_Parametrized_Expression
+ -- 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 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));
-- 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
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));
end if;
return Body_Node;
- end Parse_Body_Or_Parametrized_Expression;
+ end Scan_Body_Or_Parametrized_Expression;
end if;
-- Processing for subprogram declaration
-- 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;
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);
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;
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);
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);
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_Spcn : constant Pf_Rec :=
- Pf_Rec'(T, F, F, F, 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
type SS_Rec is record
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.
-- In case of primitives associated with abstract interface types
-- the check is applied later (see Analyze_Subprogram_Declaration).
- 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
+ if not Nkind_In (Parent (N),
+ N_Subprogram_Renaming_Declaration,
+ N_Abstract_Subprogram_Declaration,
+ N_Formal_Abstract_Subprogram_Declaration)
then
- Error_Msg_N
- ("function that returns abstract type must be abstract", N);
+ if Is_Abstract_Type (Etype (Designator))
+ and then not Is_Interface (Etype (Designator))
+ 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;
& "(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
- 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);
+ 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;
-- 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
projects / platform / upstream / linaro-gcc.git / commitdiff