Skip to content

R
riscv-gcc-1
Commit b0186f71 by Arnaud Charlet
Options

[multiple changes] 

2011-08-02  Robert Dewar  <dewar@adacore.com>

	* exp_util.adb, par-ch10.adb, par-ch6.adb, sem.adb, sem_ch6.adb,
	sem_ch6.ads, sinfo.adb, sinfo.ads, sprint.adb: Change parameterized
	expression to expression function.

2011-08-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb: transform simple Ada2012 membership into equality only
	if types are compatible.

2011-08-02  Yannick Moy  <moy@adacore.com>

	* sem_res.adb (Matching_Static_Array_Bounds): new function which
	returns True if its argument array types have same dimension and same
	static bounds at each index.
	(Resolve_Actuals): issue an error in formal mode on actuals passed as
	OUT or IN OUT paramaters which are not view conversions in SPARK.
	(Resolve_Arithmetic_Op): issue an error in formal mode on
	multiplication or division with operands of fixed point types which are
	not qualified or explicitly converted.
	(Resolve_Comparison_Op): issue an error in formal mode on comparisons of
	Boolean or array type (except String) operands.
	(Resolve_Equality_Op): issue an error in formal mode on equality
	operators for array types other than String with non-matching static
	bounds.
	(Resolve_Logical_Op): issue an error in formal mode on logical operators
	for array types with non-matching static bounds. Factorize the code in
	Matching_Static_Array_Bounds.
	(Resolve_Qualified_Expression): issue an error in formal mode on
	qualified expressions for array types with non-matching static bounds.
	(Resolve_Type_Conversion): issue an error in formal mode on type
	conversion for array types with non-matching static bounds

From-SVN: r177089
parent 767bb4e8
Showing with 461 additions and 295 deletions
gcc/ada/ChangeLog
2011-08-02 Robert Dewar <dewar@adacore.com> 2011-08-02 Robert Dewar <dewar@adacore.com>
* exp_util.adb, par-ch10.adb, par-ch6.adb, sem.adb, sem_ch6.adb,
sem_ch6.ads, sinfo.adb, sinfo.ads, sprint.adb: Change parameterized
expression to expression function.
2011-08-02 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb: transform simple Ada2012 membership into equality only
if types are compatible.
2011-08-02 Yannick Moy <moy@adacore.com>
* sem_res.adb (Matching_Static_Array_Bounds): new function which
returns True if its argument array types have same dimension and same
static bounds at each index.
(Resolve_Actuals): issue an error in formal mode on actuals passed as
OUT or IN OUT paramaters which are not view conversions in SPARK.
(Resolve_Arithmetic_Op): issue an error in formal mode on
multiplication or division with operands of fixed point types which are
not qualified or explicitly converted.
(Resolve_Comparison_Op): issue an error in formal mode on comparisons of
Boolean or array type (except String) operands.
(Resolve_Equality_Op): issue an error in formal mode on equality
operators for array types other than String with non-matching static
bounds.
(Resolve_Logical_Op): issue an error in formal mode on logical operators
for array types with non-matching static bounds. Factorize the code in
Matching_Static_Array_Bounds.
(Resolve_Qualified_Expression): issue an error in formal mode on
qualified expressions for array types with non-matching static bounds.
(Resolve_Type_Conversion): issue an error in formal mode on type
conversion for array types with non-matching static bounds
2011-08-02 Robert Dewar <dewar@adacore.com>
* par-ch10.adb: Minor code reorganization (use Nkind_In). * par-ch10.adb: Minor code reorganization (use Nkind_In).
2011-08-02 Ed Schonberg <schonberg@adacore.com> 2011-08-02 Ed Schonberg <schonberg@adacore.com>
......
gcc/ada/exp_util.adb
...@@ -2592,6 +2592,7 @@ package body Exp_Util is ...@@ -2592,6 +2592,7 @@ package body Exp_Util is
N_Entry_Body | N_Entry_Body |
N_Exception_Declaration | N_Exception_Declaration |
N_Exception_Renaming_Declaration | N_Exception_Renaming_Declaration |
N_Expression_Function |
N_Formal_Abstract_Subprogram_Declaration | N_Formal_Abstract_Subprogram_Declaration |
N_Formal_Concrete_Subprogram_Declaration | N_Formal_Concrete_Subprogram_Declaration |
N_Formal_Object_Declaration | N_Formal_Object_Declaration |
...@@ -2613,7 +2614,6 @@ package body Exp_Util is ...@@ -2613,7 +2614,6 @@ package body Exp_Util is
N_Package_Declaration | N_Package_Declaration |
N_Package_Instantiation | N_Package_Instantiation |
N_Package_Renaming_Declaration | N_Package_Renaming_Declaration |
N_Parameterized_Expression |
N_Private_Extension_Declaration | N_Private_Extension_Declaration |
N_Private_Type_Declaration | N_Private_Type_Declaration |
N_Procedure_Instantiation | N_Procedure_Instantiation |
......
gcc/ada/par-ch10.adb
...@@ -562,9 +562,9 @@ package body Ch10 is ...@@ -562,9 +562,9 @@ package body Ch10 is
then then
Name_Node := Defining_Unit_Name (Unit_Node); Name_Node := Defining_Unit_Name (Unit_Node);
elsif Nkind (Unit_Node) = N_Parameterized_Expression then elsif Nkind (Unit_Node) = N_Expression_Function then
Error_Msg_SP Error_Msg_SP
("parameterized expression cannot be used as compilation unit"); ("expression function cannot be used as compilation unit");
return Comp_Unit_Node; return Comp_Unit_Node;
-- Anything else is a serious error, abandon scan -- Anything else is a serious error, abandon scan
......
gcc/ada/par-ch6.adb
...@@ -82,7 +82,7 @@ package body Ch6 is ...@@ -82,7 +82,7 @@ package body Ch6 is
-- This routine scans out a subprogram declaration, subprogram body, -- This routine scans out a subprogram declaration, subprogram body,
-- subprogram renaming declaration or subprogram generic instantiation. -- subprogram renaming declaration or subprogram generic instantiation.
-- It also handles the new Ada 2012 parameterized expression form -- It also handles the new Ada 2012 expression function form
-- SUBPROGRAM_DECLARATION ::= -- SUBPROGRAM_DECLARATION ::=
-- SUBPROGRAM_SPECIFICATION -- SUBPROGRAM_SPECIFICATION
...@@ -126,7 +126,7 @@ package body Ch6 is ...@@ -126,7 +126,7 @@ package body Ch6 is
-- is classified as a basic declarative item, but it is parsed here, with -- is classified as a basic declarative item, but it is parsed here, with
-- other subprogram constructs. -- other subprogram constructs.
-- PARAMETERIZED_EXPRESSION ::= -- EXPRESSION_FUNCTION ::=
-- FUNCTION SPECIFICATION IS (EXPRESSION); -- FUNCTION SPECIFICATION IS (EXPRESSION);
-- The value in Pf_Flags indicates which of these possible declarations -- The value in Pf_Flags indicates which of these possible declarations
...@@ -137,7 +137,7 @@ package body Ch6 is ...@@ -137,7 +137,7 @@ package body Ch6 is
-- Pf_Flags.Pbod Set if proper body OK -- Pf_Flags.Pbod Set if proper body OK
-- Pf_Flags.Rnam Set if renaming declaration OK -- Pf_Flags.Rnam Set if renaming declaration OK
-- Pf_Flags.Stub Set if body stub OK -- Pf_Flags.Stub Set if body stub OK
-- Pf_Flags.Pexp Set if parameterized expression OK -- Pf_Flags.Pexp Set if expression function OK
-- If an inappropriate form is encountered, it is scanned out but an -- If an inappropriate form is encountered, it is scanned out but an
-- error message indicating that it is appearing in an inappropriate -- error message indicating that it is appearing in an inappropriate
...@@ -598,7 +598,7 @@ package body Ch6 is ...@@ -598,7 +598,7 @@ package body Ch6 is
end if; end if;
end if; end if;
-- Processing for stub or subprogram body or parameterized expression -- Processing for stub or subprogram body or expression function
<<Subprogram_Body>> <<Subprogram_Body>>
...@@ -623,21 +623,21 @@ package body Ch6 is ...@@ -623,21 +623,21 @@ package body Ch6 is
TF_Semicolon; TF_Semicolon;
return Stub_Node; return Stub_Node;
-- Subprogram body or parameterized expression case -- Subprogram body or expression function case
else else
Scan_Body_Or_Parameterized_Expression : declare Scan_Body_Or_Expression_Function : declare
function Likely_Parameterized_Expression return Boolean; function Likely_Expression_Function return Boolean;
-- Returns True if we have a probably case of a parameterized -- Returns True if we have a probable case of an expression
-- expression omitting the parentheses, if so, returns True -- function omitting the parentheses, if so, returns True
-- and emits an appropriate error message, else returns False. -- and emits an appropriate error message, else returns False.
------------------------------------- --------------------------------
-- Likely_Parameterized_Expression -- -- Likely_Expression_Function --
------------------------------------- --------------------------------
function Likely_Parameterized_Expression return Boolean is function Likely_Expression_Function return Boolean is
begin begin
-- If currently pointing to BEGIN or a declaration keyword -- If currently pointing to BEGIN or a declaration keyword
-- or a pragma, then we definitely have a subprogram body. -- or a pragma, then we definitely have a subprogram body.
...@@ -650,15 +650,15 @@ package body Ch6 is ...@@ -650,15 +650,15 @@ package body Ch6 is
return False; return False;
-- Test for tokens which could only start an expression and -- Test for tokens which could only start an expression and
-- thus signal the case of a parameterized expression. -- thus signal the case of a expression function.
elsif Token in Token_Class_Literal elsif Token in Token_Class_Literal
or else Token in Token_Class_Unary_Addop or else Token in Token_Class_Unary_Addop
or else Token = Tok_Left_Paren or else Token = Tok_Left_Paren
or else Token = Tok_Abs or else Token = Tok_Abs
or else Token = Tok_Null or else Token = Tok_Null
or else Token = Tok_New or else Token = Tok_New
or else Token = Tok_Not or else Token = Tok_Not
then then
null; null;
...@@ -680,12 +680,13 @@ package body Ch6 is ...@@ -680,12 +680,13 @@ package body Ch6 is
-- Otherwise we have to scan ahead. If the identifier is -- Otherwise we have to scan ahead. If the identifier is
-- followed by a colon or a comma, it is a declaration -- followed by a colon or a comma, it is a declaration
-- and hence we have a subprogram body. Otherwise assume -- and hence we have a subprogram body. Otherwise assume
-- a parameterized expression. -- a expression function.
else else
declare declare
Scan_State : Saved_Scan_State; Scan_State : Saved_Scan_State;
Tok : Token_Type; Tok : Token_Type;
begin begin
Save_Scan_State (Scan_State); Save_Scan_State (Scan_State);
Scan; -- past identifier Scan; -- past identifier
...@@ -699,43 +700,41 @@ package body Ch6 is ...@@ -699,43 +700,41 @@ package body Ch6 is
end if; end if;
end if; end if;
-- Fall through if we have a likely parameterized expression -- Fall through if we have a likely expression function
Error_Msg_SC Error_Msg_SC
("parameterized expression must be " ("expression function must be enclosed in parentheses");
& "enclosed in parentheses");
return True; return True;
end Likely_Parameterized_Expression; end Likely_Expression_Function;
-- Start of processing for Scan_Body_Or_Parameterized_Expression -- Start of processing for Scan_Body_Or_Expression_Function
begin begin
-- Parameterized_Expression case -- Expression_Function case
if Token = Tok_Left_Paren if Token = Tok_Left_Paren
or else Likely_Parameterized_Expression or else Likely_Expression_Function
then then
-- Check parameterized expression allowed here -- Check expression function allowed here
if not Pf_Flags.Pexp then if not Pf_Flags.Pexp then
Error_Msg_SC Error_Msg_SC ("expression function not allowed here!");
("parameterized expression not allowed here!");
end if; end if;
-- Check we are in Ada 2012 mode -- Check we are in Ada 2012 mode
if Ada_Version < Ada_2012 then if Ada_Version < Ada_2012 then
Error_Msg_SC Error_Msg_SC
("parameterized expression is an Ada 2012 feature!"); ("expression function is an Ada 2012 feature!");
Error_Msg_SC Error_Msg_SC
("\unit must be compiled with -gnat2012 switch!"); ("\unit must be compiled with -gnat2012 switch!");
end if; end if;
-- Parse out expression and build parameterized expression -- Parse out expression and build expression function
Body_Node := Body_Node :=
New_Node New_Node
(N_Parameterized_Expression, Sloc (Specification_Node)); (N_Expression_Function, Sloc (Specification_Node));
Set_Specification (Body_Node, Specification_Node); Set_Specification (Body_Node, Specification_Node);
Set_Expression (Body_Node, P_Expression); Set_Expression (Body_Node, P_Expression);
T_Semicolon; T_Semicolon;
...@@ -775,7 +774,7 @@ package body Ch6 is ...@@ -775,7 +774,7 @@ package body Ch6 is
end if; end if;
return Body_Node; return Body_Node;
end Scan_Body_Or_Parameterized_Expression; end Scan_Body_Or_Expression_Function;
end if; end if;
-- Processing for subprogram declaration -- Processing for subprogram declaration
......
gcc/ada/sem.adb
...@@ -223,6 +223,9 @@ package body Sem is ...@@ -223,6 +223,9 @@ package body Sem is
when N_Explicit_Dereference => when N_Explicit_Dereference =>
Analyze_Explicit_Dereference (N); Analyze_Explicit_Dereference (N);
when N_Expression_Function =>
Analyze_Expression_Function (N);
when N_Expression_With_Actions => when N_Expression_With_Actions =>
Analyze_Expression_With_Actions (N); Analyze_Expression_With_Actions (N);
...@@ -439,9 +442,6 @@ package body Sem is ...@@ -439,9 +442,6 @@ package body Sem is
when N_Parameter_Association => when N_Parameter_Association =>
Analyze_Parameter_Association (N); Analyze_Parameter_Association (N);
when N_Parameterized_Expression =>
Analyze_Parameterized_Expression (N);
when N_Pragma => when N_Pragma =>
Analyze_Pragma (N); Analyze_Pragma (N);
......
gcc/ada/sem_ch4.adb
...@@ -2475,7 +2475,8 @@ package body Sem_Ch4 is ...@@ -2475,7 +2475,8 @@ package body Sem_Ch4 is
end if; end if;
-- If not a range, it can be a subtype mark, or else it is a degenerate -- If not a range, it can be a subtype mark, or else it is a degenerate
-- membership test with a singleton value, i.e. a test for equality. -- membership test with a singleton value, i.e. a test for equality,
-- if the types are compatible.
else else
Analyze (R); Analyze (R);
...@@ -2485,7 +2486,9 @@ package body Sem_Ch4 is ...@@ -2485,7 +2486,9 @@ package body Sem_Ch4 is
Find_Type (R); Find_Type (R);
Check_Fully_Declared (Entity (R), R); Check_Fully_Declared (Entity (R), R);
elsif Ada_Version >= Ada_2012 then elsif Ada_Version >= Ada_2012
and then Has_Compatible_Type (R, Etype (L))
then
if Nkind (N) = N_In then if Nkind (N) = N_In then
Rewrite (N, Rewrite (N,
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
...@@ -2502,8 +2505,8 @@ package body Sem_Ch4 is ...@@ -2502,8 +2505,8 @@ package body Sem_Ch4 is
return; return;
else else
-- In previous version of the language this is an error that will -- In all versions of the language, if we reach this point there
-- be diagnosed below. -- is a previous error that will be diagnosed below.
Find_Type (R); Find_Type (R);
end if; end if;
......
gcc/ada/sem_ch6.adb
...@@ -215,141 +215,6 @@ package body Sem_Ch6 is ...@@ -215,141 +215,6 @@ package body Sem_Ch6 is
-- setting the proper validity status for this entity, which depends on -- setting the proper validity status for this entity, which depends on
-- the kind of parameter and the validity checking mode. -- the kind of parameter and the validity checking mode.
------------------------------
-- Analyze_Return_Statement --
------------------------------
procedure Analyze_Return_Statement (N : Node_Id) is
pragma Assert (Nkind_In (N, N_Simple_Return_Statement,
N_Extended_Return_Statement));
Returns_Object : constant Boolean :=
Nkind (N) = N_Extended_Return_Statement
or else
(Nkind (N) = N_Simple_Return_Statement
and then Present (Expression (N)));
-- True if we're returning something; that is, "return <expression>;"
-- or "return Result : T [:= ...]". False for "return;". Used for error
-- checking: If Returns_Object is True, N should apply to a function
-- body; otherwise N should apply to a procedure body, entry body,
-- accept statement, or extended return statement.
function Find_What_It_Applies_To return Entity_Id;
-- Find the entity representing the innermost enclosing body, accept
-- statement, or extended return statement. If the result is a callable
-- construct or extended return statement, then this will be the value
-- of the Return_Applies_To attribute. Otherwise, the program is
-- illegal. See RM-6.5(4/2).
-----------------------------
-- Find_What_It_Applies_To --
-----------------------------
function Find_What_It_Applies_To return Entity_Id is
Result : Entity_Id := Empty;
begin
-- Loop outward through the Scope_Stack, skipping blocks and loops
for J in reverse 0 .. Scope_Stack.Last loop
Result := Scope_Stack.Table (J).Entity;
exit when Ekind (Result) /= E_Block and then
Ekind (Result) /= E_Loop;
end loop;
pragma Assert (Present (Result));
return Result;
end Find_What_It_Applies_To;
-- Local declarations
Scope_Id : constant Entity_Id := Find_What_It_Applies_To;
Kind : constant Entity_Kind := Ekind (Scope_Id);
Loc : constant Source_Ptr := Sloc (N);
Stm_Entity : constant Entity_Id :=
New_Internal_Entity
(E_Return_Statement, Current_Scope, Loc, 'R');
-- Start of processing for Analyze_Return_Statement
begin
Set_Return_Statement_Entity (N, Stm_Entity);
Set_Etype (Stm_Entity, Standard_Void_Type);
Set_Return_Applies_To (Stm_Entity, Scope_Id);
-- Place Return entity on scope stack, to simplify enforcement of 6.5
-- (4/2): an inner return statement will apply to this extended return.
if Nkind (N) = N_Extended_Return_Statement then
Push_Scope (Stm_Entity);
end if;
-- Check that pragma No_Return is obeyed. Don't complain about the
-- implicitly-generated return that is placed at the end.
if No_Return (Scope_Id) and then Comes_From_Source (N) then
Error_Msg_N ("RETURN statement not allowed (No_Return)", N);
end if;
-- Warn on any unassigned OUT parameters if in procedure
if Ekind (Scope_Id) = E_Procedure then
Warn_On_Unassigned_Out_Parameter (N, Scope_Id);
end if;
-- Check that functions return objects, and other things do not
if Kind = E_Function or else Kind = E_Generic_Function then
if not Returns_Object then
Error_Msg_N ("missing expression in return from function", N);
end if;
elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
if Returns_Object then
Error_Msg_N ("procedure cannot return value (use function)", N);
end if;
elsif Kind = E_Entry or else Kind = E_Entry_Family then
if Returns_Object then
if Is_Protected_Type (Scope (Scope_Id)) then
Error_Msg_N ("entry body cannot return value", N);
else
Error_Msg_N ("accept statement cannot return value", N);
end if;
end if;
elsif Kind = E_Return_Statement then
-- We are nested within another return statement, which must be an
-- extended_return_statement.
if Returns_Object then
Error_Msg_N
("extended_return_statement cannot return value; " &
"use `""RETURN;""`", N);
end if;
else
Error_Msg_N ("illegal context for return statement", N);
end if;
if Ekind_In (Kind, E_Function, E_Generic_Function) then
Analyze_Function_Return (N);
elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then
Set_Return_Present (Scope_Id);
end if;
if Nkind (N) = N_Extended_Return_Statement then
End_Scope;
end if;
Kill_Current_Values (Last_Assignment_Only => True);
Check_Unreachable_Code (N);
end Analyze_Return_Statement;
--------------------------------------------- ---------------------------------------------
-- Analyze_Abstract_Subprogram_Declaration -- -- Analyze_Abstract_Subprogram_Declaration --
--------------------------------------------- ---------------------------------------------
...@@ -398,6 +263,55 @@ package body Sem_Ch6 is ...@@ -398,6 +263,55 @@ package body Sem_Ch6 is
Analyze_Aspect_Specifications (N, Designator, Aspect_Specifications (N)); Analyze_Aspect_Specifications (N, Designator, Aspect_Specifications (N));
end Analyze_Abstract_Subprogram_Declaration; end Analyze_Abstract_Subprogram_Declaration;
---------------------------------
-- Analyze_Expression_Function --
---------------------------------
procedure Analyze_Expression_Function (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
LocX : constant Source_Ptr := Sloc (Expression (N));
Def_Id : constant Entity_Id := Defining_Entity (Specification (N));
New_Body : Node_Id;
Prev : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
-- If the expression is a completion, Prev is the entity whose
-- declaration is completed.
begin
-- This is one of the occasions on which we transform the tree during
-- semantic analysis. Transform the expression function into an
-- equivalent subprogram body, and then analyze that.
New_Body :=
Make_Subprogram_Body (Loc,
Specification => Specification (N),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (LocX,
Statements => New_List (
Make_Simple_Return_Statement (LocX,
Expression => Expression (N)))));
if Present (Prev)
and then Ekind (Prev) = E_Generic_Function
then
-- If the expression completes a generic subprogram, we must create a
-- separate node for the body, because at instantiation the original
-- node of the generic copy must be a generic subprogram body, and
-- cannot be a expression function. Otherwise we just rewrite the
-- expression with the non-generic body.
Insert_After (N, New_Body);
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
Analyze (New_Body);
else
Rewrite (N, New_Body);
Analyze (N);
end if;
end Analyze_Expression_Function;
---------------------------------------- ----------------------------------------
-- Analyze_Extended_Return_Statement -- -- Analyze_Extended_Return_Statement --
---------------------------------------- ----------------------------------------
...@@ -1095,55 +1009,6 @@ package body Sem_Ch6 is ...@@ -1095,55 +1009,6 @@ package body Sem_Ch6 is
Analyze (Explicit_Actual_Parameter (N)); Analyze (Explicit_Actual_Parameter (N));
end Analyze_Parameter_Association; end Analyze_Parameter_Association;
--------------------------------------
-- Analyze_Parameterized_Expression --
--------------------------------------
procedure Analyze_Parameterized_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
LocX : constant Source_Ptr := Sloc (Expression (N));
Def_Id : constant Entity_Id := Defining_Entity (Specification (N));
New_Body : Node_Id;
Prev : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
-- If the expression is a completion, Prev is the entity whose
-- declaration is completed.
begin
-- This is one of the occasions on which we transform the tree during
-- semantic analysis. Transform the parameterized expression into an
-- equivalent subprogram body, and then analyze that.
New_Body :=
Make_Subprogram_Body (Loc,
Specification => Specification (N),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (LocX,
Statements => New_List (
Make_Simple_Return_Statement (LocX,
Expression => Expression (N)))));
if Present (Prev)
and then Ekind (Prev) = E_Generic_Function
then
-- If the expression completes a generic subprogram, we must create
-- a separate node for the body, because at instantiation the
-- original node of the generic copy must be a generic subprogram
-- body, and cannot be a parameterized expression. Otherwise we
-- just rewrite the expression with the non-generic body.
Insert_After (N, New_Body);
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
Analyze (New_Body);
else
Rewrite (N, New_Body);
Analyze (N);
end if;
end Analyze_Parameterized_Expression;
---------------------------- ----------------------------
-- Analyze_Procedure_Call -- -- Analyze_Procedure_Call --
---------------------------- ----------------------------
...@@ -1372,6 +1237,141 @@ package body Sem_Ch6 is ...@@ -1372,6 +1237,141 @@ package body Sem_Ch6 is
end if; end if;
end Analyze_Procedure_Call; end Analyze_Procedure_Call;
------------------------------
-- Analyze_Return_Statement --
------------------------------
procedure Analyze_Return_Statement (N : Node_Id) is
pragma Assert (Nkind_In (N, N_Simple_Return_Statement,
N_Extended_Return_Statement));
Returns_Object : constant Boolean :=
Nkind (N) = N_Extended_Return_Statement
or else
(Nkind (N) = N_Simple_Return_Statement
and then Present (Expression (N)));
-- True if we're returning something; that is, "return <expression>;"
-- or "return Result : T [:= ...]". False for "return;". Used for error
-- checking: If Returns_Object is True, N should apply to a function
-- body; otherwise N should apply to a procedure body, entry body,
-- accept statement, or extended return statement.
function Find_What_It_Applies_To return Entity_Id;
-- Find the entity representing the innermost enclosing body, accept
-- statement, or extended return statement. If the result is a callable
-- construct or extended return statement, then this will be the value
-- of the Return_Applies_To attribute. Otherwise, the program is
-- illegal. See RM-6.5(4/2).
-----------------------------
-- Find_What_It_Applies_To --
-----------------------------
function Find_What_It_Applies_To return Entity_Id is
Result : Entity_Id := Empty;
begin
-- Loop outward through the Scope_Stack, skipping blocks and loops
for J in reverse 0 .. Scope_Stack.Last loop
Result := Scope_Stack.Table (J).Entity;
exit when Ekind (Result) /= E_Block and then
Ekind (Result) /= E_Loop;
end loop;
pragma Assert (Present (Result));
return Result;
end Find_What_It_Applies_To;
-- Local declarations
Scope_Id : constant Entity_Id := Find_What_It_Applies_To;
Kind : constant Entity_Kind := Ekind (Scope_Id);
Loc : constant Source_Ptr := Sloc (N);
Stm_Entity : constant Entity_Id :=
New_Internal_Entity
(E_Return_Statement, Current_Scope, Loc, 'R');
-- Start of processing for Analyze_Return_Statement
begin
Set_Return_Statement_Entity (N, Stm_Entity);
Set_Etype (Stm_Entity, Standard_Void_Type);
Set_Return_Applies_To (Stm_Entity, Scope_Id);
-- Place Return entity on scope stack, to simplify enforcement of 6.5
-- (4/2): an inner return statement will apply to this extended return.
if Nkind (N) = N_Extended_Return_Statement then
Push_Scope (Stm_Entity);
end if;
-- Check that pragma No_Return is obeyed. Don't complain about the
-- implicitly-generated return that is placed at the end.
if No_Return (Scope_Id) and then Comes_From_Source (N) then
Error_Msg_N ("RETURN statement not allowed (No_Return)", N);
end if;
-- Warn on any unassigned OUT parameters if in procedure
if Ekind (Scope_Id) = E_Procedure then
Warn_On_Unassigned_Out_Parameter (N, Scope_Id);
end if;
-- Check that functions return objects, and other things do not
if Kind = E_Function or else Kind = E_Generic_Function then
if not Returns_Object then
Error_Msg_N ("missing expression in return from function", N);
end if;
elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
if Returns_Object then
Error_Msg_N ("procedure cannot return value (use function)", N);
end if;
elsif Kind = E_Entry or else Kind = E_Entry_Family then
if Returns_Object then
if Is_Protected_Type (Scope (Scope_Id)) then
Error_Msg_N ("entry body cannot return value", N);
else
Error_Msg_N ("accept statement cannot return value", N);
end if;
end if;
elsif Kind = E_Return_Statement then
-- We are nested within another return statement, which must be an
-- extended_return_statement.
if Returns_Object then
Error_Msg_N
("extended_return_statement cannot return value; " &
"use `""RETURN;""`", N);
end if;
else
Error_Msg_N ("illegal context for return statement", N);
end if;
if Ekind_In (Kind, E_Function, E_Generic_Function) then
Analyze_Function_Return (N);
elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then
Set_Return_Present (Scope_Id);
end if;
if Nkind (N) = N_Extended_Return_Statement then
End_Scope;
end if;
Kill_Current_Values (Last_Assignment_Only => True);
Check_Unreachable_Code (N);
end Analyze_Return_Statement;
------------------------------------- -------------------------------------
-- Analyze_Simple_Return_Statement -- -- Analyze_Simple_Return_Statement --
------------------------------------- -------------------------------------
...@@ -2449,9 +2449,9 @@ package body Sem_Ch6 is ...@@ -2449,9 +2449,9 @@ package body Sem_Ch6 is
and then not In_Instance and then not In_Instance
-- No warnings for parameterized expressions -- No warnings for expression functions
and then Nkind (Original_Node (N)) /= N_Parameterized_Expression and then Nkind (Original_Node (N)) /= N_Expression_Function
then then
Style.Body_With_No_Spec (N); Style.Body_With_No_Spec (N);
end if; end if;
......
gcc/ada/sem_ch6.ads
...@@ -35,11 +35,11 @@ package Sem_Ch6 is ...@@ -35,11 +35,11 @@ package Sem_Ch6 is
-- type is stronger than the ones preceding it. -- type is stronger than the ones preceding it.
procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id); procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id);
procedure Analyze_Expression_Function (N : Node_Id);
procedure Analyze_Extended_Return_Statement (N : Node_Id); procedure Analyze_Extended_Return_Statement (N : Node_Id);
procedure Analyze_Function_Call (N : Node_Id); procedure Analyze_Function_Call (N : Node_Id);
procedure Analyze_Operator_Symbol (N : Node_Id); procedure Analyze_Operator_Symbol (N : Node_Id);
procedure Analyze_Parameter_Association (N : Node_Id); procedure Analyze_Parameter_Association (N : Node_Id);
procedure Analyze_Parameterized_Expression (N : Node_Id);
procedure Analyze_Procedure_Call (N : Node_Id); procedure Analyze_Procedure_Call (N : Node_Id);
procedure Analyze_Simple_Return_Statement (N : Node_Id); procedure Analyze_Simple_Return_Statement (N : Node_Id);
procedure Analyze_Subprogram_Declaration (N : Node_Id); procedure Analyze_Subprogram_Declaration (N : Node_Id);
......
gcc/ada/sem_res.adb
...@@ -92,6 +92,12 @@ package body Sem_Res is ...@@ -92,6 +92,12 @@ package body Sem_Res is
-- Note that Resolve_Attribute is separated off in Sem_Attr -- Note that Resolve_Attribute is separated off in Sem_Attr
function Matching_Static_Array_Bounds
(L_Typ : Node_Id;
R_Typ : Node_Id) return Boolean;
-- L_Typ and R_Typ are two array types. Returns True when they have the
-- same dimension, and, for each index position, the same static bounds.
function Bad_Unordered_Enumeration_Reference function Bad_Unordered_Enumeration_Reference
(N : Node_Id; (N : Node_Id;
T : Entity_Id) return Boolean; T : Entity_Id) return Boolean;
...@@ -1571,6 +1577,65 @@ package body Sem_Res is ...@@ -1571,6 +1577,65 @@ package body Sem_Res is
end if; end if;
end Make_Call_Into_Operator; end Make_Call_Into_Operator;
----------------------------------
-- Matching_Static_Array_Bounds --
----------------------------------
function Matching_Static_Array_Bounds
(L_Typ : Node_Id;
R_Typ : Node_Id) return Boolean
is
L_Ndims : constant Nat := Number_Dimensions (L_Typ);
R_Ndims : constant Nat := Number_Dimensions (R_Typ);
L_Index : Node_Id;
R_Index : Node_Id;
L_Low : Node_Id;
L_High : Node_Id;
R_Low : Node_Id;
R_High : Node_Id;
begin
if L_Ndims /= R_Ndims then
return False;
end if;
-- Unconstrained types do not have static bounds
if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
return False;
end if;
L_Index := First_Index (L_Typ);
R_Index := First_Index (R_Typ);
for Indx in 1 .. L_Ndims loop
Get_Index_Bounds (L_Index, L_Low, L_High);
Get_Index_Bounds (R_Index, R_Low, R_High);
if True
and then Is_Static_Expression (L_Low)
and then Is_Static_Expression (L_High)
and then Is_Static_Expression (R_Low)
and then Is_Static_Expression (R_High)
and then Expr_Value (L_Low) = Expr_Value (R_Low)
and then Expr_Value (L_High) = Expr_Value (R_High)
then
-- Matching so far, continue with next index
null;
else
return False;
end if;
Next (L_Index);
Next (R_Index);
end loop;
return True;
end Matching_Static_Array_Bounds;
------------------- -------------------
-- Operator_Kind -- -- Operator_Kind --
------------------- -------------------
...@@ -1582,6 +1647,8 @@ package body Sem_Res is ...@@ -1582,6 +1647,8 @@ package body Sem_Res is
Kind : Node_Kind; Kind : Node_Kind;
begin begin
-- Use CASE statement or array???
if Is_Binary then if Is_Binary then
if Op_Name = Name_Op_And then if Op_Name = Name_Op_And then
Kind := N_Op_And; Kind := N_Op_And;
...@@ -3555,6 +3622,31 @@ package body Sem_Res is ...@@ -3555,6 +3622,31 @@ package body Sem_Res is
A_Typ := Etype (A); A_Typ := Etype (A);
F_Typ := Etype (F); F_Typ := Etype (F);
-- In SPARK or ALFA, the only view conversions are those involving
-- ancestor conversion of an extended type.
if Formal_Verification_Mode
and then Comes_From_Source (Original_Node (A))
and then Nkind (A) = N_Type_Conversion
and then Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter)
then
declare
Operand : constant Node_Id := Expression (A);
Operand_Typ : constant Entity_Id := Etype (Operand);
Target_Typ : constant Entity_Id := A_Typ;
begin
if not (Is_Tagged_Type (Target_Typ)
and then not Is_Class_Wide_Type (Target_Typ)
and then Is_Tagged_Type (Operand_Typ)
and then not Is_Class_Wide_Type (Operand_Typ)
and then Is_Ancestor (Target_Typ, Operand_Typ))
then
Error_Msg_F ("|~~ancestor conversion is the only "
& "view conversion", A);
end if;
end;
end if;
-- Save actual for subsequent check on order dependence, and -- Save actual for subsequent check on order dependence, and
-- indicate whether actual is modifiable. For AI05-0144-2. -- indicate whether actual is modifiable. For AI05-0144-2.
...@@ -4795,6 +4887,21 @@ package body Sem_Res is ...@@ -4795,6 +4887,21 @@ package body Sem_Res is
Generate_Operator_Reference (N, Typ); Generate_Operator_Reference (N, Typ);
Eval_Arithmetic_Op (N); Eval_Arithmetic_Op (N);
-- In SPARK and ALFA, a multiplication or division with operands of
-- fixed point types shall be qualified or explicitly converted to
-- identify the result type.
if Formal_Verification_Mode
and then (Is_Fixed_Point_Type (Etype (L))
or else Is_Fixed_Point_Type (Etype (R)))
and then Nkind_In (N, N_Op_Multiply, N_Op_Divide)
and then
not Nkind_In (Parent (N), N_Qualified_Expression, N_Type_Conversion)
then
Error_Msg_F
("|~~operation should be qualified or explicitly converted", N);
end if;
-- Set overflow and division checking bit. Much cleverer code needed -- Set overflow and division checking bit. Much cleverer code needed
-- here eventually and perhaps the Resolve routines should be separated -- here eventually and perhaps the Resolve routines should be separated
-- for the various arithmetic operations, since they will need -- for the various arithmetic operations, since they will need
...@@ -5792,6 +5899,22 @@ package body Sem_Res is ...@@ -5792,6 +5899,22 @@ package body Sem_Res is
Generate_Operator_Reference (N, T); Generate_Operator_Reference (N, T);
Check_Low_Bound_Tested (N); Check_Low_Bound_Tested (N);
-- In SPARK or ALFA, ordering operators <, <=, >, >= are not defined
-- for Boolean types or array types except String.
if Formal_Verification_Mode
and then Comes_From_Source (Original_Node (N))
then
if Is_Boolean_Type (T) then
Error_Msg_F ("|~~comparison is not defined on Boolean type", N);
elsif Is_Array_Type (T)
and then Base_Type (T) /= Standard_String
then
Error_Msg_F
("|~~comparison is not defined on array type except String", N);
end if;
end if;
-- Check comparison on unordered enumeration -- Check comparison on unordered enumeration
if Comes_From_Source (N) if Comes_From_Source (N)
...@@ -6635,6 +6758,20 @@ package body Sem_Res is ...@@ -6635,6 +6758,20 @@ package body Sem_Res is
Resolve (L, T); Resolve (L, T);
Resolve (R, T); Resolve (R, T);
-- In SPARK or ALFA, equality operators = and /= for array types
-- other than String are only defined when, for each index position,
-- the operands have equal static bounds.
if Formal_Verification_Mode
and then Comes_From_Source (Original_Node (N))
and then Is_Array_Type (T)
and then Base_Type (T) /= Standard_String
and then not Matching_Static_Array_Bounds (Etype (L), Etype (R))
then
Error_Msg_F
("|~~array types should have matching static bounds", N);
end if;
-- If the unique type is a class-wide type then it will be expanded -- If the unique type is a class-wide type then it will be expanded
-- into a dispatching call to the predefined primitive. Therefore we -- into a dispatching call to the predefined primitive. Therefore we
-- check here for potential violation of such restriction. -- check here for potential violation of such restriction.
...@@ -7163,48 +7300,11 @@ package body Sem_Res is ...@@ -7163,48 +7300,11 @@ package body Sem_Res is
if Formal_Verification_Mode if Formal_Verification_Mode
and then Comes_From_Source (Original_Node (N)) and then Comes_From_Source (Original_Node (N))
and then Is_Array_Type (Etype (N)) and then Is_Array_Type (B_Typ)
and then not Matching_Static_Array_Bounds (Etype (Left_Opnd (N)),
Etype (Right_Opnd (N)))
then then
declare Error_Msg_F ("|~~array types should have matching static bounds", N);
L_Index : Node_Id;
R_Index : Node_Id;
L_Low : Node_Id;
L_High : Node_Id;
R_Low : Node_Id;
R_High : Node_Id;
L_Typ : constant Node_Id := Etype (Left_Opnd (N));
R_Typ : constant Node_Id := Etype (Right_Opnd (N));
begin
L_Index := First_Index (L_Typ);
R_Index := First_Index (R_Typ);
Get_Index_Bounds (L_Index, L_Low, L_High);
Get_Index_Bounds (R_Index, R_Low, R_High);
-- Another error is issued for constrained array types with
-- non-static bounds elsewhere, so only deal with different
-- constrained types, or unconstrained types.
if L_Typ /= R_Typ or else not Is_Constrained (L_Typ) then
if not Is_Static_Expression (L_Low)
or else not Is_Static_Expression (R_Low)
or else Expr_Value (L_Low) /= Expr_Value (R_Low)
then
Error_Msg_F ("|~~operation defined only when both operands "
& "have the same static lower bound", N);
end if;
if not Is_Static_Expression (L_High)
or else not Is_Static_Expression (R_High)
or else Expr_Value (L_High) /= Expr_Value (R_High)
then
Error_Msg_F ("|~~operation defined only when both operands "
& "have the same static higher bound", N);
end if;
end if;
end;
end if; end if;
end Resolve_Logical_Op; end Resolve_Logical_Op;
...@@ -7857,6 +7957,15 @@ package body Sem_Res is ...@@ -7857,6 +7957,15 @@ package body Sem_Res is
begin begin
Resolve (Expr, Target_Typ); Resolve (Expr, Target_Typ);
if Formal_Verification_Mode
and then Comes_From_Source (Original_Node (N))
and then Is_Array_Type (Target_Typ)
and then Is_Array_Type (Etype (Expr))
and then not Matching_Static_Array_Bounds (Target_Typ, Etype (Expr))
then
Error_Msg_F ("|~~array types should have matching static bounds", N);
end if;
-- A qualified expression requires an exact match of the type, -- A qualified expression requires an exact match of the type,
-- class-wide matching is not allowed. However, if the qualifying -- class-wide matching is not allowed. However, if the qualifying
-- type is specific and the expression has a class-wide type, it -- type is specific and the expression has a class-wide type, it
...@@ -8971,6 +9080,18 @@ package body Sem_Res is ...@@ -8971,6 +9080,18 @@ package body Sem_Res is
Resolve (Operand); Resolve (Operand);
-- In SPARK or ALFA, a type conversion between array types should be
-- restricted to types which have matching static bounds.
if Formal_Verification_Mode
and then Comes_From_Source (Original_Node (N))
and then Is_Array_Type (Target_Typ)
and then Is_Array_Type (Operand_Typ)
and then not Matching_Static_Array_Bounds (Target_Typ, Operand_Typ)
then
Error_Msg_F ("|~~array types should have matching static bounds", N);
end if;
-- Note: we do the Eval_Type_Conversion call before applying the -- Note: we do the Eval_Type_Conversion call before applying the
-- required checks for a subtype conversion. This is important, since -- required checks for a subtype conversion. This is important, since
-- both are prepared under certain circumstances to change the type -- both are prepared under certain circumstances to change the type
......
gcc/ada/sinfo.adb
...@@ -1223,6 +1223,7 @@ package body Sinfo is ...@@ -1223,6 +1223,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Discriminant_Association or else NT (N).Nkind = N_Discriminant_Association
or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Discriminant_Specification
or else NT (N).Nkind = N_Exception_Declaration or else NT (N).Nkind = N_Exception_Declaration
or else NT (N).Nkind = N_Expression_Function
or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Expression_With_Actions
or else NT (N).Nkind = N_Free_Statement or else NT (N).Nkind = N_Free_Statement
or else NT (N).Nkind = N_Mod_Clause or else NT (N).Nkind = N_Mod_Clause
...@@ -1230,7 +1231,6 @@ package body Sinfo is ...@@ -1230,7 +1231,6 @@ package body Sinfo is
or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Number_Declaration
or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Object_Declaration
or else NT (N).Nkind = N_Parameter_Specification or else NT (N).Nkind = N_Parameter_Specification
or else NT (N).Nkind = N_Parameterized_Expression
or else NT (N).Nkind = N_Pragma_Argument_Association or else NT (N).Nkind = N_Pragma_Argument_Association
or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Qualified_Expression
or else NT (N).Nkind = N_Raise_Statement or else NT (N).Nkind = N_Raise_Statement
...@@ -2797,12 +2797,12 @@ package body Sinfo is ...@@ -2797,12 +2797,12 @@ package body Sinfo is
begin begin
pragma Assert (False pragma Assert (False
or else NT (N).Nkind = N_Abstract_Subprogram_Declaration or else NT (N).Nkind = N_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Expression_Function
or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Generic_Package_Declaration
or else NT (N).Nkind = N_Generic_Subprogram_Declaration or else NT (N).Nkind = N_Generic_Subprogram_Declaration
or else NT (N).Nkind = N_Package_Declaration or else NT (N).Nkind = N_Package_Declaration
or else NT (N).Nkind = N_Parameterized_Expression
or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Subprogram_Body
or else NT (N).Nkind = N_Subprogram_Body_Stub or else NT (N).Nkind = N_Subprogram_Body_Stub
or else NT (N).Nkind = N_Subprogram_Declaration or else NT (N).Nkind = N_Subprogram_Declaration
...@@ -4267,6 +4267,7 @@ package body Sinfo is ...@@ -4267,6 +4267,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Discriminant_Association or else NT (N).Nkind = N_Discriminant_Association
or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Discriminant_Specification
or else NT (N).Nkind = N_Exception_Declaration or else NT (N).Nkind = N_Exception_Declaration
or else NT (N).Nkind = N_Expression_Function
or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Expression_With_Actions
or else NT (N).Nkind = N_Free_Statement or else NT (N).Nkind = N_Free_Statement
or else NT (N).Nkind = N_Mod_Clause or else NT (N).Nkind = N_Mod_Clause
...@@ -4274,7 +4275,6 @@ package body Sinfo is ...@@ -4274,7 +4275,6 @@ package body Sinfo is
or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Number_Declaration
or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Object_Declaration
or else NT (N).Nkind = N_Parameter_Specification or else NT (N).Nkind = N_Parameter_Specification
or else NT (N).Nkind = N_Parameterized_Expression
or else NT (N).Nkind = N_Pragma_Argument_Association or else NT (N).Nkind = N_Pragma_Argument_Association
or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Qualified_Expression
or else NT (N).Nkind = N_Raise_Statement or else NT (N).Nkind = N_Raise_Statement
...@@ -5842,12 +5842,12 @@ package body Sinfo is ...@@ -5842,12 +5842,12 @@ package body Sinfo is
begin begin
pragma Assert (False pragma Assert (False
or else NT (N).Nkind = N_Abstract_Subprogram_Declaration or else NT (N).Nkind = N_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Expression_Function
or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Generic_Package_Declaration
or else NT (N).Nkind = N_Generic_Subprogram_Declaration or else NT (N).Nkind = N_Generic_Subprogram_Declaration
or else NT (N).Nkind = N_Package_Declaration or else NT (N).Nkind = N_Package_Declaration
or else NT (N).Nkind = N_Parameterized_Expression
or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Subprogram_Body
or else NT (N).Nkind = N_Subprogram_Body_Stub or else NT (N).Nkind = N_Subprogram_Body_Stub
or else NT (N).Nkind = N_Subprogram_Declaration or else NT (N).Nkind = N_Subprogram_Declaration
......
gcc/ada/sinfo.ads
...@@ -4591,17 +4591,17 @@ package Sinfo is ...@@ -4591,17 +4591,17 @@ package Sinfo is
-- Has_Relative_Deadline_Pragma (Flag9-Sem) -- Has_Relative_Deadline_Pragma (Flag9-Sem)
-- Has_Pragma_CPU (Flag14-Sem) -- Has_Pragma_CPU (Flag14-Sem)
------------------------------ -------------------------
-- Parameterized Expression -- -- Expression Function --
------------------------------ -------------------------
-- This is an Ada 2012 extension, we put it here for now, to be labeled -- This is an Ada 2012 extension, we put it here for now, to be labeled
-- and put in its proper section when we know exactly where that is! -- and put in its proper section when we know exactly where that is!
-- PARAMETERIZED_EXPRESSION ::= -- EXPRESSION_FUNCTION ::=
-- FUNCTION SPECIFICATION IS (EXPRESSION); -- FUNCTION SPECIFICATION IS (EXPRESSION);
-- N_Parameterized_Expression -- N_Expression_Function
-- Sloc points to FUNCTION -- Sloc points to FUNCTION
-- Specification (Node1) -- Specification (Node1)
-- Expression (Node3) -- Expression (Node3)
...@@ -7591,6 +7591,7 @@ package Sinfo is ...@@ -7591,6 +7591,7 @@ package Sinfo is
N_Component_Declaration, N_Component_Declaration,
N_Entry_Declaration, N_Entry_Declaration,
N_Expression_Function,
N_Formal_Object_Declaration, N_Formal_Object_Declaration,
N_Formal_Type_Declaration, N_Formal_Type_Declaration,
N_Full_Type_Declaration, N_Full_Type_Declaration,
...@@ -7598,7 +7599,6 @@ package Sinfo is ...@@ -7598,7 +7599,6 @@ package Sinfo is
N_Iterator_Specification, N_Iterator_Specification,
N_Loop_Parameter_Specification, N_Loop_Parameter_Specification,
N_Object_Declaration, N_Object_Declaration,
N_Parameterized_Expression,
N_Protected_Type_Declaration, N_Protected_Type_Declaration,
N_Private_Extension_Declaration, N_Private_Extension_Declaration,
N_Private_Type_Declaration, N_Private_Type_Declaration,
...@@ -10818,7 +10818,7 @@ package Sinfo is ...@@ -10818,7 +10818,7 @@ package Sinfo is
4 => True, -- Handled_Statement_Sequence (Node4) 4 => True, -- Handled_Statement_Sequence (Node4)
5 => False), -- Corresponding_Spec (Node5-Sem) 5 => False), -- Corresponding_Spec (Node5-Sem)
N_Parameterized_Expression => N_Expression_Function =>
(1 => True, -- Specification (Node1) (1 => True, -- Specification (Node1)
2 => False, -- unused 2 => False, -- unused
3 => True, -- Expression (Node3) 3 => True, -- Expression (Node3)
...@@ -12317,8 +12317,18 @@ package Sinfo is ...@@ -12317,8 +12317,18 @@ package Sinfo is
pragma Inline (Set_Withed_Body); pragma Inline (Set_Withed_Body);
pragma Inline (Set_Zero_Cost_Handling); pragma Inline (Set_Zero_Cost_Handling);
--------------
-- Synonyms --
--------------
-- These synonyms are to aid in transition, they should eventually be
-- removed when all remaining references to the obsolete name are gone.
N_Simple_Return_Statement : constant Node_Kind := N_Return_Statement; N_Simple_Return_Statement : constant Node_Kind := N_Return_Statement;
-- Rename N_Return_Statement to be N_Simple_Return_Statement. Clients -- Rename N_Return_Statement to be N_Simple_Return_Statement. Clients
-- should refer to N_Simple_Return_Statement. -- should refer to N_Simple_Return_Statement.
N_Parameterized_Expression : constant Node_Kind := N_Expression_Function;
-- Old name for expression functions (used during Ada 2012 transition)
end Sinfo; end Sinfo;
gcc/ada/sprint.adb
...@@ -1620,6 +1620,16 @@ package body Sprint is ...@@ -1620,6 +1620,16 @@ package body Sprint is
Indent_End; Indent_End;
Write_Indent; Write_Indent;
when N_Expression_Function =>
Write_Indent;
Sprint_Node_Sloc (Specification (Node));
Write_Str (" is");
Indent_Begin;
Write_Indent;
Sprint_Node (Expression (Node));
Write_Char (';');
Indent_End;
when N_Extended_Return_Statement => when N_Extended_Return_Statement =>
Write_Indent_Str_Sloc ("return "); Write_Indent_Str_Sloc ("return ");
Sprint_Node_List (Return_Object_Declarations (Node)); Sprint_Node_List (Return_Object_Declarations (Node));
...@@ -2488,17 +2498,6 @@ package body Sprint is ...@@ -2488,17 +2498,6 @@ package body Sprint is
Write_Str (", "); Write_Str (", ");
end if; end if;
when N_Parameterized_Expression =>
Write_Indent;
Sprint_Node_Sloc (Specification (Node));
Write_Str (" is");
Indent_Begin;
Write_Indent;
Sprint_Node (Expression (Node));
Write_Char (';');
Indent_End;
when N_Pop_Constraint_Error_Label => when N_Pop_Constraint_Error_Label =>
Write_Indent_Str ("%pop_constraint_error_label"); Write_Indent_Str ("%pop_constraint_error_label");
......
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