Commit 445e5888 by Arnaud Charlet

[multiple changes]

2015-01-30  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Analyze_Function_Return): In an extended return
	statement, apply accessibility check to result object when there
	is no initializing expression (Ada 2012 RM 6.5 (5.4/3))

2015-01-30  Robert Dewar  <dewar@adacore.com>

	* sem_ch4.adb (Analyze_If_Expression): Allow for non-standard
	Boolean for case where ELSE is omitted.
	* sem_res.adb: Minor reformatting.

From-SVN: r220274
parent 8ec350ed
2015-01-30 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Function_Return): In an extended return
statement, apply accessibility check to result object when there
is no initializing expression (Ada 2012 RM 6.5 (5.4/3))
2015-01-30 Robert Dewar <dewar@adacore.com>
* sem_ch4.adb (Analyze_If_Expression): Allow for non-standard
Boolean for case where ELSE is omitted.
* sem_res.adb: Minor reformatting.
2015-01-27 Bernd Edlinger <bernd.edlinger@hotmail.de>
Fix build under cygwin/64.
......
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -2035,29 +2035,22 @@ package body Sem_Ch4 is
begin
Set_Etype (N, Any_Type);
-- Shouldn't the following statement be down in the ELSE of the
-- following loop? ???
-- Loop through intepretations of Then_Expr
Get_First_Interp (Then_Expr, I, It);
while Present (It.Nam) loop
-- if no Else_Expression the conditional must be boolean
if No (Else_Expr) then
Set_Etype (N, Standard_Boolean);
-- Else_Expression Present. For each possible intepretation of
-- the Then_Expression, add it only if the Else_Expression has
-- a compatible type.
-- Add possible intepretation of Then_Expr if no Else_Expr,
-- or Else_Expr is present and has a compatible type.
else
while Present (It.Nam) loop
if Has_Compatible_Type (Else_Expr, It.Typ) then
Add_One_Interp (N, It.Typ, It.Typ);
end if;
if No (Else_Expr)
or else Has_Compatible_Type (Else_Expr, It.Typ)
then
Add_One_Interp (N, It.Typ, It.Typ);
end if;
Get_Next_Interp (I, It);
end loop;
end if;
Get_Next_Interp (I, It);
end loop;
end;
end if;
end Analyze_If_Expression;
......
......@@ -881,7 +881,8 @@ package body Sem_Ch6 is
-- Local Variables --
---------------------
Expr : Node_Id;
Expr : Node_Id;
Obj_Decl : Node_Id;
-- Start of processing for Analyze_Function_Return
......@@ -966,12 +967,11 @@ package body Sem_Ch6 is
else
Check_SPARK_05_Restriction ("extended RETURN is not allowed", N);
Obj_Decl := Last (Return_Object_Declarations (N));
-- Analyze parts specific to extended_return_statement:
declare
Obj_Decl : constant Node_Id :=
Last (Return_Object_Declarations (N));
Has_Aliased : constant Boolean := Aliased_Present (Obj_Decl);
HSS : constant Node_Id := Handled_Statement_Sequence (N);
......@@ -1142,6 +1142,18 @@ package body Sem_Ch6 is
& "null-excluding return??",
Reason => CE_Null_Not_Allowed);
end if;
-- RM 6.5 (5.4/3): accessibility checks also apply if the return object
-- has no initializing expression.
elsif Ada_Version > Ada_2005 and then Is_Class_Wide_Type (R_Type) then
if Type_Access_Level (Etype (Defining_Identifier (Obj_Decl))) >
Subprogram_Access_Level (Scope_Id)
then
Error_Msg_N
("level of return expression type is deeper than "
& "class-wide function!", Obj_Decl);
end if;
end if;
end Analyze_Function_Return;
......
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -722,9 +722,7 @@ package body Sem_Res is
F := First_Formal (Subp);
A := First_Actual (N);
while Present (F) and then Present (A) loop
if not Is_Entity_Name (A)
or else Entity (A) /= F
then
if not Is_Entity_Name (A) or else Entity (A) /= F then
return False;
end if;
......@@ -1310,9 +1308,7 @@ package body Sem_Res is
else
E := First_Entity (Pack);
while Present (E) loop
if Test (E)
and then not In_Decl
then
if Test (E) and then not In_Decl then
return E;
end if;
......@@ -2152,7 +2148,6 @@ package body Sem_Res is
Get_First_Interp (N, I, It);
Interp_Loop : while Present (It.Typ) loop
if Debug_Flag_V then
Write_Str ("Interp: ");
Write_Interp (It);
......
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