OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2014-07-29  Robert Dewar  <dewar@adacore.com>

	* exp_attr.adb, types.ads, types.h, exp_ch11.adb, a-except.adb,
	a-except-2005.adb: Add new reason code PE_Stream_Operation_Not_Allowed,
	and then use it when a stream operation is used from a library generic
	when the restriction (No_Streams) is active.

2014-07-29  Thomas Quinot  <quinot@adacore.com>

	* projects.texi: Fix minor typo.

2014-07-29  Yannick Moy  <moy@adacore.com>

	* sem_attr.adb (Analyze_Attribute): Fix generation of warning.

2014-07-29  Arnaud Charlet  <charlet@adacore.com>

	* sem_ch5.adb (Check_Unreachable_Code): Do not remove code in
	CodePeer mode.

2014-07-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Find_Last_Init): Add local variable
	Deep_Init_Found. Check the statement immediately following the
	declaration if [Deep_]Initialization was not found.

2014-07-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_util.adb (Is_Aliased): It appears that
	'reference-d and renamed objects still play some role in Boolean
	expression with actions and cannot be finalized immediately.

2014-07-29  Ed Schonberg  <schonberg@adacore.com>

	* exp_dbug.adb (Qualify_Needed):  For debugging purposes,
	Loop names are not part of the full qualification of entity names.

From-SVN: r213164
This commit is contained in:
Arnaud Charlet 2014-07-29 15:10:48 +02:00
parent 02bb076558
commit b8b2d9829a
13 changed files with 148 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
gcc/ada/ChangeLog
View File

@ -1,3 +1,40 @@
2014-07-29 Robert Dewar <dewar@adacore.com>
* exp_attr.adb, types.ads, types.h, exp_ch11.adb, a-except.adb,
a-except-2005.adb: Add new reason code PE_Stream_Operation_Not_Allowed,
and then use it when a stream operation is used from a library generic
when the restriction (No_Streams) is active.
2014-07-29 Thomas Quinot <quinot@adacore.com>
* projects.texi: Fix minor typo.
2014-07-29 Yannick Moy <moy@adacore.com>
* sem_attr.adb (Analyze_Attribute): Fix generation of warning.
2014-07-29 Arnaud Charlet <charlet@adacore.com>
* sem_ch5.adb (Check_Unreachable_Code): Do not remove code in
CodePeer mode.
2014-07-29 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Find_Last_Init): Add local variable
Deep_Init_Found. Check the statement immediately following the
declaration if [Deep_]Initialization was not found.
2014-07-29 Hristian Kirtchev <kirtchev@adacore.com>
* exp_util.adb (Is_Aliased): It appears that
'reference-d and renamed objects still play some role in Boolean
expression with actions and cannot be finalized immediately.
2014-07-29 Ed Schonberg <schonberg@adacore.com>
* exp_dbug.adb (Qualify_Needed): For debugging purposes,
Loop names are not part of the full qualification of entity names.
2014-07-29 Robert Dewar <dewar@adacore.com>
* einfo.adb (Has_Protected): Test base type.

39
gcc/ada/a-except-2005.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -456,16 +456,18 @@ package body Ada.Exceptions is
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Missing_Return
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Non_Transportable_Actual
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Overlaid_Controlled_Object
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Potentially_Blocking_Operation
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Stream_Operation_Not_Allowed
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Stubbed_Subprogram_Called
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Unchecked_Union_Restriction
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Non_Transportable_Actual
(File : System.Address; Line : Integer);
procedure Rcheck_SE_Empty_Storage_Pool
(File : System.Address; Line : Integer);
procedure Rcheck_SE_Explicit_Raise
@ -545,16 +547,18 @@ package body Ada.Exceptions is
"__gnat_rcheck_PE_Misaligned_Address_Value");
pragma Export (C, Rcheck_PE_Missing_Return,
"__gnat_rcheck_PE_Missing_Return");
pragma Export (C, Rcheck_PE_Non_Transportable_Actual,
"__gnat_rcheck_PE_Non_Transportable_Actual");
pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object,
"__gnat_rcheck_PE_Overlaid_Controlled_Object");
pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation,
"__gnat_rcheck_PE_Potentially_Blocking_Operation");
pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed,
"__gnat_rcheck_PE_Stream_Operation_Not_Allowed");
pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called,
"__gnat_rcheck_PE_Stubbed_Subprogram_Called");
pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction,
"__gnat_rcheck_PE_Unchecked_Union_Restriction");
pragma Export (C, Rcheck_PE_Non_Transportable_Actual,
"__gnat_rcheck_PE_Non_Transportable_Actual");
pragma Export (C, Rcheck_SE_Empty_Storage_Pool,
"__gnat_rcheck_SE_Empty_Storage_Pool");
pragma Export (C, Rcheck_SE_Explicit_Raise,
@ -603,11 +607,12 @@ package body Ada.Exceptions is
pragma No_Return (Rcheck_PE_Implicit_Return);
pragma No_Return (Rcheck_PE_Misaligned_Address_Value);
pragma No_Return (Rcheck_PE_Missing_Return);
pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object);
pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation);
pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed);
pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called);
pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction);
pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
pragma No_Return (Rcheck_PE_Finalize_Raised_Exception);
pragma No_Return (Rcheck_SE_Empty_Storage_Pool);
pragma No_Return (Rcheck_SE_Explicit_Raise);
@ -668,6 +673,7 @@ package body Ada.Exceptions is
Rmsg_33 : constant String := "explicit raise" & NUL;
Rmsg_34 : constant String := "infinite recursion" & NUL;
Rmsg_35 : constant String := "object too large" & NUL;
Rmsg_36 : constant String := "stream operation not allowed" & NUL;
-----------------------
-- Polling Interface --
@ -1392,6 +1398,13 @@ package body Ada.Exceptions is
Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
end Rcheck_PE_Missing_Return;
procedure Rcheck_PE_Non_Transportable_Actual
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
end Rcheck_PE_Non_Transportable_Actual;
procedure Rcheck_PE_Overlaid_Controlled_Object
(File : System.Address; Line : Integer)
is
@ -1406,6 +1419,13 @@ package body Ada.Exceptions is
Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
end Rcheck_PE_Potentially_Blocking_Operation;
procedure Rcheck_PE_Stream_Operation_Not_Allowed
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_36'Address);
end Rcheck_PE_Stream_Operation_Not_Allowed;
procedure Rcheck_PE_Stubbed_Subprogram_Called
(File : System.Address; Line : Integer)
is
@ -1420,13 +1440,6 @@ package body Ada.Exceptions is
Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
end Rcheck_PE_Unchecked_Union_Restriction;
procedure Rcheck_PE_Non_Transportable_Actual
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
end Rcheck_PE_Non_Transportable_Actual;
procedure Rcheck_SE_Empty_Storage_Pool
(File : System.Address; Line : Integer)
is

52
gcc/ada/a-except.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -412,16 +412,18 @@ package body Ada.Exceptions is
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Missing_Return
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Non_Transportable_Actual
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Overlaid_Controlled_Object
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Potentially_Blocking_Operation
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Stream_Operation_Not_Allowed
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Stubbed_Subprogram_Called
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Unchecked_Union_Restriction
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Non_Transportable_Actual
(File : System.Address; Line : Integer);
procedure Rcheck_SE_Empty_Storage_Pool
(File : System.Address; Line : Integer);
procedure Rcheck_SE_Explicit_Raise
@ -492,16 +494,18 @@ package body Ada.Exceptions is
"__gnat_rcheck_PE_Misaligned_Address_Value");
pragma Export (C, Rcheck_PE_Missing_Return,
"__gnat_rcheck_PE_Missing_Return");
pragma Export (C, Rcheck_PE_Non_Transportable_Actual,
"__gnat_rcheck_PE_Non_Transportable_Actual");
pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object,
"__gnat_rcheck_PE_Overlaid_Controlled_Object");
pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation,
"__gnat_rcheck_PE_Potentially_Blocking_Operation");
pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed,
"__gnat_rcheck_PE_Stream_Operation_Not_Allowed");
pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called,
"__gnat_rcheck_PE_Stubbed_Subprogram_Called");
pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction,
"__gnat_rcheck_PE_Unchecked_Union_Restriction");
pragma Export (C, Rcheck_PE_Non_Transportable_Actual,
"__gnat_rcheck_PE_Non_Transportable_Actual");
pragma Export (C, Rcheck_SE_Empty_Storage_Pool,
"__gnat_rcheck_SE_Empty_Storage_Pool");
pragma Export (C, Rcheck_SE_Explicit_Raise,
@ -542,10 +546,11 @@ package body Ada.Exceptions is
pragma No_Return (Rcheck_PE_Misaligned_Address_Value);
pragma No_Return (Rcheck_PE_Missing_Return);
pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object);
pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation);
pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed);
pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called);
pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction);
pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
pragma No_Return (Rcheck_PE_Finalize_Raised_Exception);
pragma No_Return (Rcheck_SE_Empty_Storage_Pool);
pragma No_Return (Rcheck_SE_Explicit_Raise);
@ -576,6 +581,7 @@ package body Ada.Exceptions is
procedure Rcheck_19 (File : System.Address; Line : Integer);
procedure Rcheck_20 (File : System.Address; Line : Integer);
procedure Rcheck_21 (File : System.Address; Line : Integer);
procedure Rcheck_22 (File : System.Address; Line : Integer);
procedure Rcheck_23 (File : System.Address; Line : Integer);
procedure Rcheck_24 (File : System.Address; Line : Integer);
procedure Rcheck_25 (File : System.Address; Line : Integer);
@ -589,8 +595,7 @@ package body Ada.Exceptions is
procedure Rcheck_33 (File : System.Address; Line : Integer);
procedure Rcheck_34 (File : System.Address; Line : Integer);
procedure Rcheck_35 (File : System.Address; Line : Integer);
procedure Rcheck_22 (File : System.Address; Line : Integer);
procedure Rcheck_36 (File : System.Address; Line : Integer);
pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
@ -628,6 +633,7 @@ package body Ada.Exceptions is
pragma Export (C, Rcheck_33, "__gnat_rcheck_33");
pragma Export (C, Rcheck_34, "__gnat_rcheck_34");
pragma Export (C, Rcheck_35, "__gnat_rcheck_35");
pragma Export (C, Rcheck_36, "__gnat_rcheck_36");
-- None of these procedures ever returns (they raise an exception). By
-- using pragma No_Return, we ensure that any junk code after the call,
@ -668,6 +674,7 @@ package body Ada.Exceptions is
pragma No_Return (Rcheck_33);
pragma No_Return (Rcheck_34);
pragma No_Return (Rcheck_35);
pragma No_Return (Rcheck_36);
---------------------------------------------
-- Reason Strings for Run-Time Check Calls --
@ -718,6 +725,7 @@ package body Ada.Exceptions is
Rmsg_33 : constant String := "explicit raise" & NUL;
Rmsg_34 : constant String := "infinite recursion" & NUL;
Rmsg_35 : constant String := "object too large" & NUL;
Rmsg_36 : constant String := "stream operation not allowed" & NUL;
-----------------------
-- Polling Interface --
@ -1357,6 +1365,13 @@ package body Ada.Exceptions is
Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
end Rcheck_PE_Missing_Return;
procedure Rcheck_PE_Non_Transportable_Actual
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
end Rcheck_PE_Non_Transportable_Actual;
procedure Rcheck_PE_Overlaid_Controlled_Object
(File : System.Address; Line : Integer)
is
@ -1371,6 +1386,13 @@ package body Ada.Exceptions is
Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
end Rcheck_PE_Potentially_Blocking_Operation;
procedure Rcheck_PE_Stream_Operation_Not_Allowed
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_36'Address);
end Rcheck_PE_Stream_Operation_Not_Allowed;
procedure Rcheck_PE_Stubbed_Subprogram_Called
(File : System.Address; Line : Integer)
is
@ -1385,13 +1407,6 @@ package body Ada.Exceptions is
Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
end Rcheck_PE_Unchecked_Union_Restriction;
procedure Rcheck_PE_Non_Transportable_Actual
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
end Rcheck_PE_Non_Transportable_Actual;
procedure Rcheck_SE_Empty_Storage_Pool
(File : System.Address; Line : Integer)
is
@ -1483,6 +1498,8 @@ package body Ada.Exceptions is
renames Rcheck_PE_Duplicated_Entry_Address;
procedure Rcheck_22 (File : System.Address; Line : Integer)
renames Rcheck_PE_Explicit_Raise;
procedure Rcheck_23 (File : System.Address; Line : Integer)
renames Rcheck_PE_Finalize_Raised_Exception;
procedure Rcheck_24 (File : System.Address; Line : Integer)
renames Rcheck_PE_Implicit_Return;
procedure Rcheck_25 (File : System.Address; Line : Integer)
@ -1507,9 +1524,8 @@ package body Ada.Exceptions is
renames Rcheck_SE_Infinite_Recursion;
procedure Rcheck_35 (File : System.Address; Line : Integer)
renames Rcheck_SE_Object_Too_Large;
procedure Rcheck_23 (File : System.Address; Line : Integer)
renames Rcheck_PE_Finalize_Raised_Exception;
procedure Rcheck_36 (File : System.Address; Line : Integer)
renames Rcheck_PE_Stream_Operation_Not_Allowed;
-------------
-- Reraise --

11
gcc/ada/exp_attr.adb
View File

@ -3246,13 +3246,10 @@ package body Exp_Attr is
-- container). In that case rewrite the attribute as a Raise to
-- prevent any run-time use.
-- This is not an explicit raise, the Reason code is wrong, we most
-- likely need a new Reason code ???
if Restriction_Active (No_Streams) then
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Explicit_Raise));
Reason => PE_Stream_Operation_Not_Allowed));
Set_Etype (N, B_Type);
return;
end if;
@ -4248,7 +4245,7 @@ package body Exp_Attr is
if Restriction_Active (No_Streams) then
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Explicit_Raise));
Reason => PE_Stream_Operation_Not_Allowed));
Set_Etype (N, Standard_Void_Type);
return;
end if;
@ -4888,7 +4885,7 @@ package body Exp_Attr is
if Restriction_Active (No_Streams) then
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Explicit_Raise));
Reason => PE_Stream_Operation_Not_Allowed));
Set_Etype (N, B_Type);
return;
end if;
@ -6600,7 +6597,7 @@ package body Exp_Attr is
if Restriction_Active (No_Streams) then
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Explicit_Raise));
Reason => PE_Stream_Operation_Not_Allowed));
Set_Etype (N, U_Type);
return;
end if;

6
gcc/ada/exp_ch11.adb
View File

@ -2137,16 +2137,18 @@ package body Exp_Ch11 is
Add_Str_To_Name_Buffer ("PE_Misaligned_Address_Value");
when PE_Missing_Return =>
Add_Str_To_Name_Buffer ("PE_Missing_Return");
when PE_Non_Transportable_Actual =>
Add_Str_To_Name_Buffer ("PE_Non_Transportable_Actual");
when PE_Overlaid_Controlled_Object =>
Add_Str_To_Name_Buffer ("PE_Overlaid_Controlled_Object");
when PE_Potentially_Blocking_Operation =>
Add_Str_To_Name_Buffer ("PE_Potentially_Blocking_Operation");
when PE_Stream_Operation_Not_Allowed =>
Add_Str_To_Name_Buffer ("PE_Stream_Operation_Not_Allowed");
when PE_Stubbed_Subprogram_Called =>
Add_Str_To_Name_Buffer ("PE_Stubbed_Subprogram_Called");
when PE_Unchecked_Union_Restriction =>
Add_Str_To_Name_Buffer ("PE_Unchecked_Union_Restriction");
when PE_Non_Transportable_Actual =>
Add_Str_To_Name_Buffer ("PE_Non_Transportable_Actual");
when SE_Empty_Storage_Pool =>
Add_Str_To_Name_Buffer ("SE_Empty_Storage_Pool");

16
gcc/ada/exp_ch7.adb
View File

@ -2399,6 +2399,9 @@ package body Exp_Ch7 is
Stmt : Node_Id;
Stmt_2 : Node_Id;
Deep_Init_Found : Boolean := False;
-- A flag set when a call to [Deep_]Initialize has been found
-- Start of processing for Find_Last_Init
begin
@ -2488,19 +2491,22 @@ package body Exp_Ch7 is
Call := Find_Last_Init_In_Block (Stmt_2);
if Present (Call) then
Last_Init := Call;
Body_Insert := Stmt_2;
Deep_Init_Found := True;
Last_Init := Call;
Body_Insert := Stmt_2;
end if;
elsif Is_Init_Call (Stmt_2) then
Last_Init := Stmt_2;
Body_Insert := Last_Init;
Deep_Init_Found := True;
Last_Init := Stmt_2;
Body_Insert := Last_Init;
end if;
end if;
-- If the object lacks a call to Deep_Initialize, then it must
-- have a call to its related type init proc.
elsif Is_Init_Call (Stmt) then
if not Deep_Init_Found and then Is_Init_Call (Stmt) then
Last_Init := Stmt;
Body_Insert := Last_Init;
end if;

4
gcc/ada/exp_dbug.adb
View File

@ -1103,7 +1103,8 @@ package body Exp_Dbug is
function Qualify_Needed (S : Entity_Id) return Boolean;
-- Given a scope, determines if the scope is to be included in the
-- fully qualified name, True if so, False if not.
-- fully qualified name, True if so, False if not. Blocks and loops
-- are excluded from a qualified name.
procedure Set_BNPE_Suffix (E : Entity_Id);
-- Recursive routine to append the BNPE qualification suffix. Works
@ -1218,6 +1219,7 @@ package body Exp_Dbug is
return Is_Subprogram (Ent)
or else Ekind (Ent) = E_Subprogram_Body
or else (Ekind (S) /= E_Block
and then Ekind (S) /= E_Loop
and then not Is_Dynamic_Scope (S));
end if;
end Qualify_Needed;

11
gcc/ada/exp_util.adb
View File

@ -4556,17 +4556,6 @@ package body Exp_Util is
-- Start of processing for Is_Aliased
begin
-- 'Reference-d or renamed transient objects are not consider aliased
-- when the related context is a Boolean expression_with_actions. The
-- Boolean result is always known after the action list is evaluated,
-- therefore the transient objects must be finalized at that point.
if Nkind (Rel_Node) = N_Expression_With_Actions
and then Is_Boolean_Type (Etype (Rel_Node))
then
return False;
end if;
Stmt := First_Stmt;
while Present (Stmt) loop
if Nkind (Stmt) = N_Object_Declaration then

4
gcc/ada/projects.texi
View File

@ -1,7 +1,7 @@
@set gprconfig GPRconfig
@c ------ projects.texi
@c Copyright (C) 2002-2013, Free Software Foundation, Inc.
@c Copyright (C) 2002-2014, Free Software Foundation, Inc.
@c This file is shared between the GNAT user's guide and gprbuild. It is not
@c compilable on its own, you should instead compile the other two manuals.
@c For that reason, there is no toplevel @menu
@ -2465,7 +2465,7 @@ use a project file like:
@smallexample @c projectfile
aggregate project Agg is
for Project_Path use (external("SETUP") % "path");
for Project_Path use (external("SETUP") & "path");
for Project_Files use ("myproject.gpr");
end Agg;

8
gcc/ada/sem_attr.adb
View File

@ -412,8 +412,7 @@ package body Sem_Attr is
procedure Uneval_Old_Msg;
-- Called when Loop_Entry or Old is used in a potentially unevaluated
-- expression. Generates appropriate message or warning depending on
-- the setting of Opt.Uneval_Old. The caller has put the Name_Id of
-- the attribute in Error_Msg_Name_1 prior to the call.
-- the setting of Opt.Uneval_Old.
procedure Unexpected_Argument (En : Node_Id);
-- Signal unexpected attribute argument (En is the argument)
@ -2284,9 +2283,10 @@ package body Sem_Attr is
& "unevaluated must denote an entity");
when 'W' =>
Error_Attr_P
Error_Msg_Name_1 := Aname;
Error_Msg_F
("??prefix of attribute % appears in potentially "
& "unevaluated context, exception may be raised");
& "unevaluated context, exception may be raised", P);
when 'A' =>
null;

10
gcc/ada/sem_ch5.adb
View File

@ -3182,16 +3182,20 @@ package body Sem_Ch5 is
-- unreachable code, since it is useless and we don't
-- want to generate junk warnings.
-- We skip this step if we are not in code generation mode.
-- We skip this step if we are not in code generation mode
-- or CodePeer mode.
-- This is the one case where we remove dead code in the
-- semantics as opposed to the expander, and we do not want
-- to remove code if we are not in code generation mode,
-- since this messes up the ASIS trees.
-- since this messes up the ASIS trees or loses useful
-- information in the CodePeer tree.
-- Note that one might react by moving the whole circuit to
-- exp_ch5, but then we lose the warning in -gnatc mode.
if Operating_Mode = Generate_Code then
if Operating_Mode = Generate_Code
and then not CodePeer_Mode
then
loop
Nxt := Next (N);

18
gcc/ada/types.ads
View File

@ -823,12 +823,16 @@ package Types is
-- 1. Modify the type and subtype declarations below appropriately,
-- keeping things in alphabetical order.
-- 2. Modify the corresponding definitions in types.h, including the
-- 2. Assign a new number to the reason. Do not renumber existing codes,
-- this causes compatibility/bootstrap issues. So always add the new
-- code at the end of the existing range.
-- 3. Modify the corresponding definitions in types.h, including the
-- definition of last_reason_code.
-- 3. Add the name of the routines in exp_ch11.Get_RT_Exception_Name
-- 4. Add the name of the routines in exp_ch11.Get_RT_Exception_Name
-- 4. Add a new routine in Ada.Exceptions with the appropriate call and
-- 5. Add a new routine in Ada.Exceptions with the appropriate call and
-- static string constant. Note that there is more than one version
-- of a-except.adb which must be modified.
@ -861,24 +865,28 @@ package Types is
PE_Implicit_Return, -- 24
PE_Misaligned_Address_Value, -- 25
PE_Missing_Return, -- 26
PE_Non_Transportable_Actual, -- 31
PE_Overlaid_Controlled_Object, -- 27
PE_Potentially_Blocking_Operation, -- 28
PE_Stream_Operation_Not_Allowed, -- 36
PE_Stubbed_Subprogram_Called, -- 29
PE_Unchecked_Union_Restriction, -- 30
PE_Non_Transportable_Actual, -- 31
SE_Empty_Storage_Pool, -- 32
SE_Explicit_Raise, -- 33
SE_Infinite_Recursion, -- 34
SE_Object_Too_Large); -- 35
Last_Reason_Code : constant := 36;
-- Last reason code
subtype RT_CE_Exceptions is RT_Exception_Code range
CE_Access_Check_Failed ..
CE_Tag_Check_Failed;
subtype RT_PE_Exceptions is RT_Exception_Code range
PE_Access_Before_Elaboration ..
PE_Non_Transportable_Actual;
PE_Unchecked_Union_Restriction;
subtype RT_SE_Exceptions is RT_Exception_Code range
SE_Empty_Storage_Pool ..

5
gcc/ada/types.h
View File

@ -383,15 +383,16 @@ typedef Int Mechanism_Type;
#define PE_Implicit_Return 24
#define PE_Misaligned_Address_Value 25
#define PE_Missing_Return 26
#define PE_Non_Transportable_Actual 31
#define PE_Overlaid_Controlled_Object 27
#define PE_Potentially_Blocking_Operation 28
#define PE_Stream_Operation_Not_Allowed 36
#define PE_Stubbed_Subprogram_Called 29
#define PE_Unchecked_Union_Restriction 30
#define PE_Non_Transportable_Actual 31
#define SE_Empty_Storage_Pool 32
#define SE_Explicit_Raise 33
#define SE_Infinite_Recursion 34
#define SE_Object_Too_Large 35
#define LAST_REASON_CODE 35
#define LAST_REASON_CODE 36