FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2013-07-05  Robert Dewar  <dewar@adacore.com>

	* a-cfhase.adb, sem_prag.adb, a-cfhama.adb: Minor reformatting.

2013-07-05  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Copy_Generic_Node): Check that name in function
	call is a valid entity name before preserving entity in generic
	copy.

2013-07-05  Thomas Quinot  <quinot@adacore.com>

	* par-ch5.adb: Minor reformatting.

2013-07-05  Thomas Quinot  <quinot@adacore.com>

	* sinfo.ads: Minor clarification to documentation for
	N_Implicit_Label_Declaration.

2013-07-05  Hristian Kirtchev  <kirtchev@adacore.com>

	* a-except-2005.adb, a-except.adb: Add constant Rmsg_17. Correct the
	values of all remaining constants.
	(Rcheck_35): New routine along with pragmas Export and No_Return.
	(Rcheck_PE_Aliased_Parameters): New routine along with pragmas
	Export and No_Return.
	(Rcheck_PE_All_Guards_Closed,
	Rcheck_PE_Bad_Predicated_Generic_Type,
	Rcheck_PE_Current_Task_In_Entry_Body,
	Rcheck_PE_Duplicated_Entry_Address, Rcheck_PE_Explicit_Raise,
	Rcheck_PE_Implicit_Return, Rcheck_PE_Misaligned_Address_Value,
	Rcheck_PE_Missing_Return, Rcheck_PE_Overlaid_Controlled_Object,
	Rcheck_PE_Potentially_Blocking_Operation
	Rcheck_PE_Stubbed_Subprogram_Called,
	Rcheck_PE_Unchecked_Union_Restriction,
	Rcheck_PE_Non_Transportable_Actual, Rcheck_SE_Empty_Storage_Pool,
	Rcheck_SE_Explicit_Raise, Rcheck_SE_Infinite_Recursion,
	Rcheck_SE_Object_Too_Large, Rcheck_PE_Finalize_Raised_Exception):
	Update the use of Rmsg_XX.
	(Rcheck_17, Rcheck_18, Rcheck_19,
	Rcheck_20, Rcheck_21, Rcheck_22, Rcheck_23, Rcheck_24, Rcheck_25,
	Rcheck_26, Rcheck_27, Rcheck_28, Rcheck_29, Rcheck_30, Rcheck_31,
	Rcheck_32, Rcheck_33, Rcheck_34, Rcheck_35): Update corresponding
	renamed subprograms.
	* checks.adb: Add with and use clause for Stringt.
	(Apply_Parameter_Aliasing_Checks): Make constant Loc visible in
	all subprograms of Apply_Parameter_Aliasing_Checks. Remove local
	variable Cond. Initialize Check at the start of the routine. Use
	routine Overlap_Check to construct a simple or a detailed run-time
	check. Update the creation of the simple check.
	(Overlap_Check): New routine.
	* exp_ch11.adb (Get_RT_Exception_Name): Add a value for
	PE_Aliased_Parameters.
	* types.ads: Add new enumeration literal
	PE_Aliased_Parameters. Update the corresponding integer values
	of all RT_Exception_Code literals.
	* types.h: Add new constant PE_Aliased_Parameters. Correct the
	values of all remaining constants.

2013-07-05  Yannick Moy  <moy@adacore.com>

	* gnat_rm.texi: Minor renaming of SPARK into SPARK 2005 in
	documentation.

From-SVN: r200690
This commit is contained in:
Arnaud Charlet 2013-07-05 11:04:59 +02:00
parent 45c9ce9868
commit baed70ac77
14 changed files with 354 additions and 177 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

64
gcc/ada/ChangeLog
View file

@ -1,3 +1,67 @@
2013-07-05 Robert Dewar <dewar@adacore.com>
* a-cfhase.adb, sem_prag.adb, a-cfhama.adb: Minor reformatting.
2013-07-05 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Copy_Generic_Node): Check that name in function
call is a valid entity name before preserving entity in generic
copy.
2013-07-05 Thomas Quinot <quinot@adacore.com>
* par-ch5.adb: Minor reformatting.
2013-07-05 Thomas Quinot <quinot@adacore.com>
* sinfo.ads: Minor clarification to documentation for
N_Implicit_Label_Declaration.
2013-07-05 Hristian Kirtchev <kirtchev@adacore.com>
* a-except-2005.adb, a-except.adb: Add constant Rmsg_17. Correct the
values of all remaining constants.
(Rcheck_35): New routine along with pragmas Export and No_Return.
(Rcheck_PE_Aliased_Parameters): New routine along with pragmas
Export and No_Return.
(Rcheck_PE_All_Guards_Closed,
Rcheck_PE_Bad_Predicated_Generic_Type,
Rcheck_PE_Current_Task_In_Entry_Body,
Rcheck_PE_Duplicated_Entry_Address, Rcheck_PE_Explicit_Raise,
Rcheck_PE_Implicit_Return, Rcheck_PE_Misaligned_Address_Value,
Rcheck_PE_Missing_Return, Rcheck_PE_Overlaid_Controlled_Object,
Rcheck_PE_Potentially_Blocking_Operation
Rcheck_PE_Stubbed_Subprogram_Called,
Rcheck_PE_Unchecked_Union_Restriction,
Rcheck_PE_Non_Transportable_Actual, Rcheck_SE_Empty_Storage_Pool,
Rcheck_SE_Explicit_Raise, Rcheck_SE_Infinite_Recursion,
Rcheck_SE_Object_Too_Large, Rcheck_PE_Finalize_Raised_Exception):
Update the use of Rmsg_XX.
(Rcheck_17, Rcheck_18, Rcheck_19,
Rcheck_20, Rcheck_21, Rcheck_22, Rcheck_23, Rcheck_24, Rcheck_25,
Rcheck_26, Rcheck_27, Rcheck_28, Rcheck_29, Rcheck_30, Rcheck_31,
Rcheck_32, Rcheck_33, Rcheck_34, Rcheck_35): Update corresponding
renamed subprograms.
* checks.adb: Add with and use clause for Stringt.
(Apply_Parameter_Aliasing_Checks): Make constant Loc visible in
all subprograms of Apply_Parameter_Aliasing_Checks. Remove local
variable Cond. Initialize Check at the start of the routine. Use
routine Overlap_Check to construct a simple or a detailed run-time
check. Update the creation of the simple check.
(Overlap_Check): New routine.
* exp_ch11.adb (Get_RT_Exception_Name): Add a value for
PE_Aliased_Parameters.
* types.ads: Add new enumeration literal
PE_Aliased_Parameters. Update the corresponding integer values
of all RT_Exception_Code literals.
* types.h: Add new constant PE_Aliased_Parameters. Correct the
values of all remaining constants.
2013-07-05 Yannick Moy <moy@adacore.com>
* gnat_rm.texi: Minor renaming of SPARK into SPARK 2005 in
documentation.
2013-07-05 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb (Analyze_PPC_In_Decl_Part): For a class-wide

1
gcc/ada/a-cfhama.adb
View file

@ -488,7 +488,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
declare
N : Node_Type renames Container.Nodes (Position.Node);
begin

1
gcc/ada/a-cfhase.adb
View file

@ -687,7 +687,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
Container.Nodes (Position.Node).Element := New_Item;
end if;
end Include;

87
gcc/ada/a-except-2005.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2013, 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- --
@ -447,6 +447,8 @@ package body Ada.Exceptions is
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Address_Of_Intrinsic
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Aliased_Parameters
(File : System.Address; Line : Integer);
procedure Rcheck_PE_All_Guards_Closed
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Bad_Predicated_Generic_Type
@ -532,6 +534,8 @@ package body Ada.Exceptions is
"__gnat_rcheck_PE_Accessibility_Check");
pragma Export (C, Rcheck_PE_Address_Of_Intrinsic,
"__gnat_rcheck_PE_Address_Of_Intrinsic");
pragma Export (C, Rcheck_PE_Aliased_Parameters,
"__gnat_rcheck_PE_Aliased_Parameters");
pragma Export (C, Rcheck_PE_All_Guards_Closed,
"__gnat_rcheck_PE_All_Guards_Closed");
pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type,
@ -599,6 +603,7 @@ package body Ada.Exceptions is
pragma No_Return (Rcheck_PE_Access_Before_Elaboration);
pragma No_Return (Rcheck_PE_Accessibility_Check);
pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
pragma No_Return (Rcheck_PE_Aliased_Parameters);
pragma No_Return (Rcheck_PE_All_Guards_Closed);
pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type);
pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body);
@ -650,27 +655,28 @@ package body Ada.Exceptions is
Rmsg_15 : constant String := "accessibility check failed" & NUL;
Rmsg_16 : constant String := "attempt to take address of" &
" intrinsic subprogram" & NUL;
Rmsg_17 : constant String := "all guards closed" & NUL;
Rmsg_18 : constant String := "improper use of generic subtype" &
Rmsg_17 : constant String := "aliased parameters" & NUL;
Rmsg_18 : constant String := "all guards closed" & NUL;
Rmsg_19 : constant String := "improper use of generic subtype" &
" with predicate" & NUL;
Rmsg_19 : constant String := "Current_Task referenced in entry" &
Rmsg_20 : constant String := "Current_Task referenced in entry" &
" body" & NUL;
Rmsg_20 : constant String := "duplicated entry address" & NUL;
Rmsg_21 : constant String := "explicit raise" & NUL;
Rmsg_22 : constant String := "finalize/adjust raised exception" & NUL;
Rmsg_23 : constant String := "implicit return with No_Return" & NUL;
Rmsg_24 : constant String := "misaligned address value" & NUL;
Rmsg_25 : constant String := "missing return" & NUL;
Rmsg_26 : constant String := "overlaid controlled object" & NUL;
Rmsg_27 : constant String := "potentially blocking operation" & NUL;
Rmsg_28 : constant String := "stubbed subprogram called" & NUL;
Rmsg_29 : constant String := "unchecked union restriction" & NUL;
Rmsg_30 : constant String := "actual/returned class-wide" &
Rmsg_21 : constant String := "duplicated entry address" & NUL;
Rmsg_22 : constant String := "explicit raise" & NUL;
Rmsg_23 : constant String := "finalize/adjust raised exception" & NUL;
Rmsg_24 : constant String := "implicit return with No_Return" & NUL;
Rmsg_25 : constant String := "misaligned address value" & NUL;
Rmsg_26 : constant String := "missing return" & NUL;
Rmsg_27 : constant String := "overlaid controlled object" & NUL;
Rmsg_28 : constant String := "potentially blocking operation" & NUL;
Rmsg_29 : constant String := "stubbed subprogram called" & NUL;
Rmsg_30 : constant String := "unchecked union restriction" & NUL;
Rmsg_31 : constant String := "actual/returned class-wide" &
" value not transportable" & NUL;
Rmsg_31 : constant String := "empty storage pool" & NUL;
Rmsg_32 : constant String := "explicit raise" & NUL;
Rmsg_33 : constant String := "infinite recursion" & NUL;
Rmsg_34 : constant String := "object too large" & NUL;
Rmsg_32 : constant String := "empty storage pool" & NUL;
Rmsg_33 : constant String := "explicit raise" & NUL;
Rmsg_34 : constant String := "infinite recursion" & NUL;
Rmsg_35 : constant String := "object too large" & NUL;
-----------------------
-- Polling Interface --
@ -1316,123 +1322,130 @@ package body Ada.Exceptions is
Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
end Rcheck_PE_Address_Of_Intrinsic;
procedure Rcheck_PE_All_Guards_Closed
procedure Rcheck_PE_Aliased_Parameters
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_17'Address);
end Rcheck_PE_Aliased_Parameters;
procedure Rcheck_PE_All_Guards_Closed
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
end Rcheck_PE_All_Guards_Closed;
procedure Rcheck_PE_Bad_Predicated_Generic_Type
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
end Rcheck_PE_Bad_Predicated_Generic_Type;
procedure Rcheck_PE_Current_Task_In_Entry_Body
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
end Rcheck_PE_Current_Task_In_Entry_Body;
procedure Rcheck_PE_Duplicated_Entry_Address
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
end Rcheck_PE_Duplicated_Entry_Address;
procedure Rcheck_PE_Explicit_Raise
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
end Rcheck_PE_Explicit_Raise;
procedure Rcheck_PE_Implicit_Return
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_23'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
end Rcheck_PE_Implicit_Return;
procedure Rcheck_PE_Misaligned_Address_Value
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
end Rcheck_PE_Misaligned_Address_Value;
procedure Rcheck_PE_Missing_Return
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
end Rcheck_PE_Missing_Return;
procedure Rcheck_PE_Overlaid_Controlled_Object
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_27'Address);
end Rcheck_PE_Overlaid_Controlled_Object;
procedure Rcheck_PE_Potentially_Blocking_Operation
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_27'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
end Rcheck_PE_Potentially_Blocking_Operation;
procedure Rcheck_PE_Stubbed_Subprogram_Called
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
end Rcheck_PE_Stubbed_Subprogram_Called;
procedure Rcheck_PE_Unchecked_Union_Restriction
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
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_30'Address);
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
begin
Raise_Storage_Error_Msg (File, Line, Rmsg_31'Address);
Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
end Rcheck_SE_Empty_Storage_Pool;
procedure Rcheck_SE_Explicit_Raise
(File : System.Address; Line : Integer)
is
begin
Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
end Rcheck_SE_Explicit_Raise;
procedure Rcheck_SE_Infinite_Recursion
(File : System.Address; Line : Integer)
is
begin
Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
end Rcheck_SE_Infinite_Recursion;
procedure Rcheck_SE_Object_Too_Large
(File : System.Address; Line : Integer)
is
begin
Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address);
end Rcheck_SE_Object_Too_Large;
procedure Rcheck_CE_Access_Check_Ext
@ -1488,7 +1501,7 @@ package body Ada.Exceptions is
-- This is consistent with Raise_From_Controlled_Operation
Exception_Data.Set_Exception_C_Msg
(X, Program_Error_Def'Access, File, Line, 0, Rmsg_22'Address);
(X, Program_Error_Def'Access, File, Line, 0, Rmsg_23'Address);
Complete_And_Propagate_Occurrence (X);
end Rcheck_PE_Finalize_Raised_Exception;

126
gcc/ada/a-except.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2013, 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- --
@ -394,6 +394,8 @@ package body Ada.Exceptions is
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Address_Of_Intrinsic
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Aliased_Parameters
(File : System.Address; Line : Integer);
procedure Rcheck_PE_All_Guards_Closed
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Bad_Predicated_Generic_Type
@ -470,6 +472,8 @@ package body Ada.Exceptions is
"__gnat_rcheck_PE_Accessibility_Check");
pragma Export (C, Rcheck_PE_Address_Of_Intrinsic,
"__gnat_rcheck_PE_Address_Of_Intrinsic");
pragma Export (C, Rcheck_PE_Aliased_Parameters,
"__gnat_rcheck_PE_Aliased_Parameters");
pragma Export (C, Rcheck_PE_All_Guards_Closed,
"__gnat_rcheck_PE_All_Guards_Closed");
pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type,
@ -528,6 +532,7 @@ package body Ada.Exceptions is
pragma No_Return (Rcheck_PE_Access_Before_Elaboration);
pragma No_Return (Rcheck_PE_Accessibility_Check);
pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
pragma No_Return (Rcheck_PE_Aliased_Parameters);
pragma No_Return (Rcheck_PE_All_Guards_Closed);
pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type);
pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body);
@ -583,6 +588,7 @@ package body Ada.Exceptions is
procedure Rcheck_32 (File : System.Address; Line : Integer);
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);
@ -621,6 +627,7 @@ package body Ada.Exceptions is
pragma Export (C, Rcheck_32, "__gnat_rcheck_32");
pragma Export (C, Rcheck_33, "__gnat_rcheck_33");
pragma Export (C, Rcheck_34, "__gnat_rcheck_34");
pragma Export (C, Rcheck_35, "__gnat_rcheck_35");
-- None of these procedures ever returns (they raise an exception!). By
-- using pragma No_Return, we ensure that any junk code after the call,
@ -660,6 +667,7 @@ package body Ada.Exceptions is
pragma No_Return (Rcheck_32);
pragma No_Return (Rcheck_33);
pragma No_Return (Rcheck_34);
pragma No_Return (Rcheck_35);
---------------------------------------------
-- Reason Strings for Run-Time Check Calls --
@ -688,27 +696,28 @@ package body Ada.Exceptions is
Rmsg_15 : constant String := "accessibility check failed" & NUL;
Rmsg_16 : constant String := "attempt to take address of" &
" intrinsic subprogram" & NUL;
Rmsg_17 : constant String := "all guards closed" & NUL;
Rmsg_18 : constant String := "improper use of generic subtype" &
Rmsg_17 : constant String := "aliased parameters" & NUL;
Rmsg_18 : constant String := "all guards closed" & NUL;
Rmsg_19 : constant String := "improper use of generic subtype" &
" with predicate" & NUL;
Rmsg_19 : constant String := "Current_Task referenced in entry" &
Rmsg_20 : constant String := "Current_Task referenced in entry" &
" body" & NUL;
Rmsg_20 : constant String := "duplicated entry address" & NUL;
Rmsg_21 : constant String := "explicit raise" & NUL;
Rmsg_22 : constant String := "finalize/adjust raised exception" & NUL;
Rmsg_23 : constant String := "implicit return with No_Return" & NUL;
Rmsg_24 : constant String := "misaligned address value" & NUL;
Rmsg_25 : constant String := "missing return" & NUL;
Rmsg_26 : constant String := "overlaid controlled object" & NUL;
Rmsg_27 : constant String := "potentially blocking operation" & NUL;
Rmsg_28 : constant String := "stubbed subprogram called" & NUL;
Rmsg_29 : constant String := "unchecked union restriction" & NUL;
Rmsg_30 : constant String := "actual/returned class-wide" &
Rmsg_21 : constant String := "duplicated entry address" & NUL;
Rmsg_22 : constant String := "explicit raise" & NUL;
Rmsg_23 : constant String := "finalize/adjust raised exception" & NUL;
Rmsg_24 : constant String := "implicit return with No_Return" & NUL;
Rmsg_25 : constant String := "misaligned address value" & NUL;
Rmsg_26 : constant String := "missing return" & NUL;
Rmsg_27 : constant String := "overlaid controlled object" & NUL;
Rmsg_28 : constant String := "potentially blocking operation" & NUL;
Rmsg_29 : constant String := "stubbed subprogram called" & NUL;
Rmsg_30 : constant String := "unchecked union restriction" & NUL;
Rmsg_31 : constant String := "actual/returned class-wide" &
" value not transportable" & NUL;
Rmsg_31 : constant String := "empty storage pool" & NUL;
Rmsg_32 : constant String := "explicit raise" & NUL;
Rmsg_33 : constant String := "infinite recursion" & NUL;
Rmsg_34 : constant String := "object too large" & NUL;
Rmsg_32 : constant String := "empty storage pool" & NUL;
Rmsg_33 : constant String := "explicit raise" & NUL;
Rmsg_34 : constant String := "infinite recursion" & NUL;
Rmsg_35 : constant String := "object too large" & NUL;
-----------------------
-- Polling Interface --
@ -1285,123 +1294,130 @@ package body Ada.Exceptions is
Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
end Rcheck_PE_Address_Of_Intrinsic;
procedure Rcheck_PE_All_Guards_Closed
procedure Rcheck_PE_Aliased_Parameters
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_17'Address);
end Rcheck_PE_Aliased_Parameters;
procedure Rcheck_PE_All_Guards_Closed
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
end Rcheck_PE_All_Guards_Closed;
procedure Rcheck_PE_Bad_Predicated_Generic_Type
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
end Rcheck_PE_Bad_Predicated_Generic_Type;
procedure Rcheck_PE_Current_Task_In_Entry_Body
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
end Rcheck_PE_Current_Task_In_Entry_Body;
procedure Rcheck_PE_Duplicated_Entry_Address
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
end Rcheck_PE_Duplicated_Entry_Address;
procedure Rcheck_PE_Explicit_Raise
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
end Rcheck_PE_Explicit_Raise;
procedure Rcheck_PE_Implicit_Return
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_23'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
end Rcheck_PE_Implicit_Return;
procedure Rcheck_PE_Misaligned_Address_Value
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
end Rcheck_PE_Misaligned_Address_Value;
procedure Rcheck_PE_Missing_Return
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
end Rcheck_PE_Missing_Return;
procedure Rcheck_PE_Overlaid_Controlled_Object
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_27'Address);
end Rcheck_PE_Overlaid_Controlled_Object;
procedure Rcheck_PE_Potentially_Blocking_Operation
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_27'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
end Rcheck_PE_Potentially_Blocking_Operation;
procedure Rcheck_PE_Stubbed_Subprogram_Called
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
end Rcheck_PE_Stubbed_Subprogram_Called;
procedure Rcheck_PE_Unchecked_Union_Restriction
(File : System.Address; Line : Integer)
is
begin
Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
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_30'Address);
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
begin
Raise_Storage_Error_Msg (File, Line, Rmsg_31'Address);
Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
end Rcheck_SE_Empty_Storage_Pool;
procedure Rcheck_SE_Explicit_Raise
(File : System.Address; Line : Integer)
is
begin
Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
end Rcheck_SE_Explicit_Raise;
procedure Rcheck_SE_Infinite_Recursion
(File : System.Address; Line : Integer)
is
begin
Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
end Rcheck_SE_Infinite_Recursion;
procedure Rcheck_SE_Object_Too_Large
(File : System.Address; Line : Integer)
is
begin
Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address);
end Rcheck_SE_Object_Too_Large;
procedure Rcheck_PE_Finalize_Raised_Exception
@ -1417,7 +1433,7 @@ package body Ada.Exceptions is
-- This is consistent with Raise_From_Controlled_Operation
Exception_Data.Set_Exception_C_Msg (Excep, E, File, Line, 0,
Rmsg_22'Address);
Rmsg_23'Address);
Raise_Current_Excep (E);
end Rcheck_PE_Finalize_Raised_Exception;
@ -1456,41 +1472,43 @@ package body Ada.Exceptions is
procedure Rcheck_16 (File : System.Address; Line : Integer)
renames Rcheck_PE_Address_Of_Intrinsic;
procedure Rcheck_17 (File : System.Address; Line : Integer)
renames Rcheck_PE_All_Guards_Closed;
renames Rcheck_PE_Aliased_Parameters;
procedure Rcheck_18 (File : System.Address; Line : Integer)
renames Rcheck_PE_Bad_Predicated_Generic_Type;
renames Rcheck_PE_All_Guards_Closed;
procedure Rcheck_19 (File : System.Address; Line : Integer)
renames Rcheck_PE_Current_Task_In_Entry_Body;
renames Rcheck_PE_Bad_Predicated_Generic_Type;
procedure Rcheck_20 (File : System.Address; Line : Integer)
renames Rcheck_PE_Duplicated_Entry_Address;
renames Rcheck_PE_Current_Task_In_Entry_Body;
procedure Rcheck_21 (File : System.Address; Line : Integer)
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_Implicit_Return;
procedure Rcheck_24 (File : System.Address; Line : Integer)
renames Rcheck_PE_Misaligned_Address_Value;
renames Rcheck_PE_Implicit_Return;
procedure Rcheck_25 (File : System.Address; Line : Integer)
renames Rcheck_PE_Missing_Return;
renames Rcheck_PE_Misaligned_Address_Value;
procedure Rcheck_26 (File : System.Address; Line : Integer)
renames Rcheck_PE_Overlaid_Controlled_Object;
renames Rcheck_PE_Missing_Return;
procedure Rcheck_27 (File : System.Address; Line : Integer)
renames Rcheck_PE_Potentially_Blocking_Operation;
renames Rcheck_PE_Overlaid_Controlled_Object;
procedure Rcheck_28 (File : System.Address; Line : Integer)
renames Rcheck_PE_Stubbed_Subprogram_Called;
renames Rcheck_PE_Potentially_Blocking_Operation;
procedure Rcheck_29 (File : System.Address; Line : Integer)
renames Rcheck_PE_Unchecked_Union_Restriction;
renames Rcheck_PE_Stubbed_Subprogram_Called;
procedure Rcheck_30 (File : System.Address; Line : Integer)
renames Rcheck_PE_Non_Transportable_Actual;
renames Rcheck_PE_Unchecked_Union_Restriction;
procedure Rcheck_31 (File : System.Address; Line : Integer)
renames Rcheck_SE_Empty_Storage_Pool;
renames Rcheck_PE_Non_Transportable_Actual;
procedure Rcheck_32 (File : System.Address; Line : Integer)
renames Rcheck_SE_Explicit_Raise;
renames Rcheck_SE_Empty_Storage_Pool;
procedure Rcheck_33 (File : System.Address; Line : Integer)
renames Rcheck_SE_Infinite_Recursion;
renames Rcheck_SE_Explicit_Raise;
procedure Rcheck_34 (File : System.Address; Line : Integer)
renames Rcheck_SE_Infinite_Recursion;
procedure Rcheck_35 (File : System.Address; Line : Integer)
renames Rcheck_SE_Object_Too_Large;
procedure Rcheck_22 (File : System.Address; Line : Integer)
procedure Rcheck_23 (File : System.Address; Line : Integer)
renames Rcheck_PE_Finalize_Raised_Exception;
-------------

125
gcc/ada/checks.adb
View file

@ -58,6 +58,7 @@ with Sinput; use Sinput;
with Snames; use Snames;
with Sprint; use Sprint;
with Stand; use Stand;
with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
@ -2093,6 +2094,8 @@ package body Checks is
(Call : Node_Id;
Subp : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Call);
function May_Cause_Aliasing
(Formal_1 : Entity_Id;
Formal_2 : Entity_Id) return Boolean;
@ -2105,6 +2108,20 @@ package body Checks is
-- it does not share the address of the actual. This routine attempts
-- to retrieve the original actual.
procedure Overlap_Check
(Actual_1 : Node_Id;
Actual_2 : Node_Id;
Formal_1 : Entity_Id;
Formal_2 : Entity_Id;
Check : in out Node_Id);
-- Create a check to determine whether Actual_1 overlaps with Actual_2.
-- If detailed exception messages are enabled, the check is augmented to
-- provide information about the names of the corresponding formals. See
-- the body for details. Actual_1 and Actual_2 denote the two actuals to
-- be tested. Formal_1 and Formal_2 denote the corresponding formals.
-- Check contains all and-ed simple tests generated so far or remains
-- unchanged in the case of detailed exception messaged.
------------------------
-- May_Cause_Aliasing --
------------------------
@ -2161,20 +2178,89 @@ package body Checks is
return N;
end Original_Actual;
-------------------
-- Overlap_Check --
-------------------
procedure Overlap_Check
(Actual_1 : Node_Id;
Actual_2 : Node_Id;
Formal_1 : Entity_Id;
Formal_2 : Entity_Id;
Check : in out Node_Id)
is
Cond : Node_Id;
begin
-- Generate:
-- Actual_1'Overlaps_Storage (Actual_2)
Cond :=
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Original_Actual (Actual_1)),
Attribute_Name => Name_Overlaps_Storage,
Expressions =>
New_List (New_Copy_Tree (Original_Actual (Actual_2))));
-- Generate the following check when detailed exception messages are
-- enabled:
-- if Actual_1'Overlaps_Storage (Actual_2) then
-- raise Program_Error with <detailed message>;
-- end if;
if Exception_Extra_Info then
Start_String;
-- Do not generate location information for internal calls
if Comes_From_Source (Call) then
Store_String_Chars (Build_Location_String (Loc));
Store_String_Char (' ');
end if;
Store_String_Chars ("aliased parameters, actuals for """);
Store_String_Chars (Get_Name_String (Chars (Formal_1)));
Store_String_Chars (""" and """);
Store_String_Chars (Get_Name_String (Chars (Formal_2)));
Store_String_Chars (""" overlap");
Insert_Action (Call,
Make_If_Statement (Loc,
Condition => Cond,
Then_Statements => New_List (
Make_Raise_Statement (Loc,
Name =>
New_Reference_To (Standard_Program_Error, Loc),
Expression => Make_String_Literal (Loc, End_String)))));
-- Create a sequence of overlapping checks by and-ing them all
-- together.
else
if No (Check) then
Check := Cond;
else
Check :=
Make_And_Then (Loc,
Left_Opnd => Check,
Right_Opnd => Cond);
end if;
end if;
end Overlap_Check;
-- Local variables
Loc : constant Source_Ptr := Sloc (Call);
Actual_1 : Node_Id;
Actual_2 : Node_Id;
Check : Node_Id;
Cond : Node_Id;
Formal_1 : Entity_Id;
Formal_2 : Entity_Id;
-- Start of processing for Apply_Parameter_Aliasing_Checks
begin
Cond := Empty;
Check := Empty;
Actual_1 := First_Actual (Call);
Formal_1 := First_Formal (Subp);
@ -2200,25 +2286,12 @@ package body Checks is
Is_Elementary_Type (Etype (Original_Actual (Actual_2)))
and then May_Cause_Aliasing (Formal_1, Formal_2)
then
-- Generate:
-- Actual_1'Overlaps_Storage (Actual_2)
Check :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Copy_Tree (Original_Actual (Actual_1)),
Attribute_Name => Name_Overlaps_Storage,
Expressions =>
New_List (New_Copy_Tree (Original_Actual (Actual_2))));
if No (Cond) then
Cond := Check;
else
Cond :=
Make_And_Then (Loc,
Left_Opnd => Cond,
Right_Opnd => Check);
end if;
Overlap_Check
(Actual_1 => Actual_1,
Actual_2 => Actual_2,
Formal_1 => Formal_1,
Formal_2 => Formal_2,
Check => Check);
end if;
Next_Actual (Actual_2);
@ -2230,13 +2303,13 @@ package body Checks is
Next_Formal (Formal_1);
end loop;
-- Place the check right before the call
-- Place a simple check right before the call
if Present (Cond) then
if Present (Check) and then not Exception_Extra_Info then
Insert_Action (Call,
Make_Raise_Program_Error (Loc,
Condition => Cond,
Reason => PE_Explicit_Raise));
Condition => Check,
Reason => PE_Aliased_Parameters));
end if;
end Apply_Parameter_Aliasing_Checks;

2
gcc/ada/exp_ch11.adb
View file

@ -2132,6 +2132,8 @@ package body Exp_Ch11 is
Add_Str_To_Name_Buffer ("PE_Accessibility_Check");
when PE_Address_Of_Intrinsic =>
Add_Str_To_Name_Buffer ("PE_Address_Of_Intrinsic");
when PE_Aliased_Parameters =>
Add_Str_To_Name_Buffer ("PE_Aliased_Parameters");
when PE_All_Guards_Closed =>
Add_Str_To_Name_Buffer ("PE_All_Guards_Closed");
when PE_Bad_Predicated_Generic_Type =>

27
gcc/ada/gnat_rm.texi
View file

@ -9185,11 +9185,8 @@ type @code{Character}).
@unnumberedsubsec SPARK
@findex SPARK
[GNAT] This restriction checks at compile time that some constructs
forbidden in SPARK are not present. The SPARK version used as a
reference is the same as the Ada mode for the unit, so a unit compiled
in Ada 95 mode with SPARK restrictions will be checked for constructs
forbidden in SPARK 95. Error messages related to SPARK restriction have
the form:
forbidden in SPARK 2005 are not present. Error messages related to
SPARK restriction have the form:
@smallexample
violation of restriction "SPARK" at <file>
@ -9198,18 +9195,22 @@ violation of restriction "SPARK" at <file>
This is not a replacement for the semantic checks performed by the
SPARK Examiner tool, as the compiler only deals currently with code,
not at all with SPARK annotations and does not guarantee catching all
cases of constructs forbidden by SPARK.
not at all with SPARK 2005 annotations and does not guarantee catching all
cases of constructs forbidden by SPARK 2005.
Thus it may well be the case that code which
passes the compiler in SPARK mode is rejected by the SPARK Examiner,
e.g. due to the different visibility rules of the Examiner based on
SPARK @code{inherit} annotations.
Thus it may well be the case that code which passes the compiler with
the SPARK restriction is rejected by the SPARK Examiner, e.g. due to
the different visibility rules of the Examiner based on SPARK 2005
@code{inherit} annotations.
This restriction can be useful in providing an initial filter for
code developed using SPARK, or in examining legacy code to see how far
This restriction can be useful in providing an initial filter for code
developed using SPARK 2005, or in examining legacy code to see how far
it is from meeting SPARK restrictions.
Note that if a unit is compiled in Ada 95 mode with SPARK restriction,
violations will be reported for constructs forbidden in SPARK 95,
instead of SPARK 2005.
@c ------------------------
@node Implementation Advice
@chapter Implementation Advice

5
gcc/ada/par-ch5.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2013, 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- --
@ -595,8 +595,7 @@ package body Ch5 is
-- For statement (labeled loop statement with FOR)
elsif Token = Tok_For then
Append_To (Statement_List,
P_For_Statement (Id_Node));
Append_To (Statement_List, P_For_Statement (Id_Node));
-- Improper statement follows label. If we have an
-- expression token, then assume the colon was part

8
gcc/ada/sem_ch12.adb
View file

@ -6577,7 +6577,13 @@ package body Sem_Ch12 is
Set_Entity (New_N, Entity (Assoc));
Check_Private_View (N);
elsif Nkind (Assoc) = N_Function_Call then
-- The name in the call may be a selected component if the
-- call has not been analyzed yet, as may be the case for
-- pre/post conditions in a generic unit.
elsif Nkind (Assoc) = N_Function_Call
and then Is_Entity_Name (Name (Assoc))
then
Set_Entity (New_N, Entity (Name (Assoc)));
elsif Nkind_In (Assoc, N_Defining_Identifier,

4
gcc/ada/sem_prag.adb
View file

@ -1751,7 +1751,7 @@ package body Sem_Prag is
-- defined for a primitive subprogram of a type descended from T.
-- Note that this replacement is not done for selector names in
-- parameter associations. These carry an entity for reference
-- purposes, but they semantically they are just identifiers.
-- purposes, but semantically they are just identifiers.
-------------
-- Get_ACW --
@ -1795,7 +1795,7 @@ package body Sem_Prag is
and then Nkind (Parent (N)) /= N_Type_Conversion
and then
(Nkind (Parent (N)) /= N_Parameter_Association
or else N /= Selector_Name (Parent (N)))
or else N /= Selector_Name (Parent (N)))
then
if Etype (Entity (N)) = T then
Typ := Class_Wide_Type (T);

3
gcc/ada/sinfo.ads
View file

@ -7225,7 +7225,8 @@ package Sinfo is
-- Sprint syntax: labelname : label;
-- N_Implicit_Label_Declaration
-- Sloc points to the << of the label
-- Sloc points to the << token for a statement identifier, or to the
-- LOOP, DECLARE, or BEGIN token for a loop or block identifier
-- Defining_Identifier (Node1)
-- Label_Construct (Node2-Sem)

37
gcc/ada/types.ads
View file

@ -843,25 +843,26 @@ package Types is
PE_Access_Before_Elaboration, -- 14
PE_Accessibility_Check_Failed, -- 15
PE_Address_Of_Intrinsic, -- 16
PE_All_Guards_Closed, -- 17
PE_Bad_Predicated_Generic_Type, -- 18
PE_Current_Task_In_Entry_Body, -- 19
PE_Duplicated_Entry_Address, -- 20
PE_Explicit_Raise, -- 21
PE_Finalize_Raised_Exception, -- 22
PE_Implicit_Return, -- 23
PE_Misaligned_Address_Value, -- 24
PE_Missing_Return, -- 25
PE_Overlaid_Controlled_Object, -- 26
PE_Potentially_Blocking_Operation, -- 27
PE_Stubbed_Subprogram_Called, -- 28
PE_Unchecked_Union_Restriction, -- 29
PE_Non_Transportable_Actual, -- 30
PE_Aliased_Parameters, -- 17
PE_All_Guards_Closed, -- 18
PE_Bad_Predicated_Generic_Type, -- 19
PE_Current_Task_In_Entry_Body, -- 20
PE_Duplicated_Entry_Address, -- 21
PE_Explicit_Raise, -- 22
PE_Finalize_Raised_Exception, -- 23
PE_Implicit_Return, -- 24
PE_Misaligned_Address_Value, -- 25
PE_Missing_Return, -- 26
PE_Overlaid_Controlled_Object, -- 27
PE_Potentially_Blocking_Operation, -- 28
PE_Stubbed_Subprogram_Called, -- 29
PE_Unchecked_Union_Restriction, -- 30
PE_Non_Transportable_Actual, -- 31
SE_Empty_Storage_Pool, -- 31
SE_Explicit_Raise, -- 32
SE_Infinite_Recursion, -- 33
SE_Object_Too_Large); -- 34
SE_Empty_Storage_Pool, -- 32
SE_Explicit_Raise, -- 33
SE_Infinite_Recursion, -- 34
SE_Object_Too_Large); -- 35
subtype RT_CE_Exceptions is RT_Exception_Code range
CE_Access_Check_Failed ..

41
gcc/ada/types.h
View file

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1992-2012, Free Software Foundation, Inc. *
* Copyright (C) 1992-2013, 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- *
@ -363,24 +363,25 @@ typedef Int Mechanism_Type;
#define PE_Access_Before_Elaboration 14
#define PE_Accessibility_Check_Failed 15
#define PE_Address_Of_Intrinsic 16
#define PE_All_Guards_Closed 17
#define PE_Bad_Attribute_For_Predicate 18
#define PE_Current_Task_In_Entry_Body 19
#define PE_Duplicated_Entry_Address 20
#define PE_Explicit_Raise 21
#define PE_Finalize_Raised_Exception 22
#define PE_Implicit_Return 23
#define PE_Misaligned_Address_Value 24
#define PE_Missing_Return 25
#define PE_Overlaid_Controlled_Object 26
#define PE_Potentially_Blocking_Operation 27
#define PE_Stubbed_Subprogram_Called 28
#define PE_Unchecked_Union_Restriction 29
#define PE_Non_Transportable_Actual 30
#define PE_Aliased_Parameters 17
#define PE_All_Guards_Closed 18
#define PE_Bad_Attribute_For_Predicate 19
#define PE_Current_Task_In_Entry_Body 20
#define PE_Duplicated_Entry_Address 21
#define PE_Explicit_Raise 22
#define PE_Finalize_Raised_Exception 23
#define PE_Implicit_Return 24
#define PE_Misaligned_Address_Value 25
#define PE_Missing_Return 26
#define PE_Overlaid_Controlled_Object 27
#define PE_Potentially_Blocking_Operation 28
#define PE_Stubbed_Subprogram_Called 29
#define PE_Unchecked_Union_Restriction 30
#define PE_Non_Transportable_Actual 31
#define SE_Empty_Storage_Pool 31
#define SE_Explicit_Raise 32
#define SE_Infinite_Recursion 33
#define SE_Object_Too_Large 34
#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 34
#define LAST_REASON_CODE 35