From: Arnaud Charlet Date: Fri, 30 Jan 2015 09:00:10 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=445e588866137e1e26d9e69f5d657382f3d91006;p=gcc.git [multiple changes] 2015-01-30 Ed Schonberg * 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 * 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f5715461b7a..be0188ddad7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,15 @@ +2015-01-30 Ed Schonberg + + * 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 + + * 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 Fix build under cygwin/64. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 8ddced82947..1d33d1b2ce2 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 1335dcf5a86..17ad3c408e8 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 8f762d44b95..82890810a48 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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);