diff mbox

[Ada] Detailed exception messages for aliased parameters

Message ID 20130705092320.GA21185@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet July 5, 2013, 9:23 a.m. UTC 
This patch adds code to generate two different runtime checks for aliased
parameters depending on whether switch -gnateE is in effect. The default check
raises a normal Program_Error. The detailed version points out the troublesome
formals involved.

------------
-- Source --
------------

--  parameter_aliasing.adb

with Ada.Text_IO; use Ada.Text_IO;

procedure Parameter_Aliasing is
   type Rec is record
      Data : Integer;
   end record;

   procedure Test (Formal_1 : Rec; Formal_2 : in out Rec) is
   begin
      Formal_2.Data := Formal_1.Data + 1;
   end Test;

   Actual : Rec := (Data => 1);

begin
   Test (Actual, Actual);
   Put_Line ("ERROR: aliasing not detected");

end Parameter_Aliasing;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -f -q -gnata -gnateA parameter_aliasing.adb
$ ./parameter_aliasing
$ gnatmake -f -q -gnata -gnateA -gnateE parameter_aliasing.adb
$ ./parameter_aliasing

raised PROGRAM_ERROR : parameter_aliasing.adb:16 aliased parameters

raised PROGRAM_ERROR : parameter_aliasing.adb:16 aliased parameters, actuals
  for "formal_1" and "formal_2" overlap

Tested on x86_64-pc-linux-gnu, committed on trunk

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.
diff mbox

Patch

Index: types.ads
===================================================================
--- types.ads	(revision 200688)
+++ types.ads	(working copy)
@@ -843,25 +843,26 @@ 
       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 ..
Index: checks.adb
===================================================================
--- checks.adb	(revision 200688)
+++ checks.adb	(working copy)
@@ -58,6 +58,7 @@ 
 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 @@ 
      (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 @@ 
       --  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 @@ 
          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 @@ 
                    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 @@ 
          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;
 
Index: types.h
===================================================================
--- types.h	(revision 200688)
+++ types.h	(working copy)
@@ -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 @@ 
 #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
Index: exp_ch11.adb
===================================================================
--- exp_ch11.adb	(revision 200688)
+++ exp_ch11.adb	(working copy)
@@ -2132,6 +2132,8 @@ 
             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 =>
Index: a-except.adb
===================================================================
--- a-except.adb	(revision 200688)
+++ a-except.adb	(working copy)
@@ -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 @@ 
      (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 @@ 
                   "__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 @@ 
    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 @@ 
    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 @@ 
    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 @@ 
    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 @@ 
    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 @@ 
       Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
    end Rcheck_PE_Address_Of_Intrinsic;
 
+   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_17'Address);
+      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 @@ 
       --  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 @@ 
    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_Aliased_Parameters;
+   procedure Rcheck_18 (File : System.Address; Line : Integer)
      renames Rcheck_PE_All_Guards_Closed;
-   procedure Rcheck_18 (File : System.Address; Line : Integer)
+   procedure Rcheck_19 (File : System.Address; Line : Integer)
      renames Rcheck_PE_Bad_Predicated_Generic_Type;
-   procedure Rcheck_19 (File : System.Address; Line : Integer)
+   procedure Rcheck_20 (File : System.Address; Line : Integer)
      renames Rcheck_PE_Current_Task_In_Entry_Body;
-   procedure Rcheck_20 (File : System.Address; Line : Integer)
+   procedure Rcheck_21 (File : System.Address; Line : Integer)
      renames Rcheck_PE_Duplicated_Entry_Address;
-   procedure Rcheck_21 (File : System.Address; Line : Integer)
+   procedure Rcheck_22 (File : System.Address; Line : Integer)
      renames Rcheck_PE_Explicit_Raise;
-   procedure Rcheck_23 (File : System.Address; Line : Integer)
+   procedure Rcheck_24 (File : System.Address; Line : Integer)
      renames Rcheck_PE_Implicit_Return;
-   procedure Rcheck_24 (File : System.Address; Line : Integer)
+   procedure Rcheck_25 (File : System.Address; Line : Integer)
      renames Rcheck_PE_Misaligned_Address_Value;
-   procedure Rcheck_25 (File : System.Address; Line : Integer)
+   procedure Rcheck_26 (File : System.Address; Line : Integer)
      renames Rcheck_PE_Missing_Return;
-   procedure Rcheck_26 (File : System.Address; Line : Integer)
+   procedure Rcheck_27 (File : System.Address; Line : Integer)
      renames Rcheck_PE_Overlaid_Controlled_Object;
-   procedure Rcheck_27 (File : System.Address; Line : Integer)
+   procedure Rcheck_28 (File : System.Address; Line : Integer)
      renames Rcheck_PE_Potentially_Blocking_Operation;
-   procedure Rcheck_28 (File : System.Address; Line : Integer)
+   procedure Rcheck_29 (File : System.Address; Line : Integer)
      renames Rcheck_PE_Stubbed_Subprogram_Called;
-   procedure Rcheck_29 (File : System.Address; Line : Integer)
+   procedure Rcheck_30 (File : System.Address; Line : Integer)
      renames Rcheck_PE_Unchecked_Union_Restriction;
-   procedure Rcheck_30 (File : System.Address; Line : Integer)
+   procedure Rcheck_31 (File : System.Address; Line : Integer)
      renames Rcheck_PE_Non_Transportable_Actual;
-   procedure Rcheck_31 (File : System.Address; Line : Integer)
+   procedure Rcheck_32 (File : System.Address; Line : Integer)
      renames Rcheck_SE_Empty_Storage_Pool;
-   procedure Rcheck_32 (File : System.Address; Line : Integer)
+   procedure Rcheck_33 (File : System.Address; Line : Integer)
      renames Rcheck_SE_Explicit_Raise;
-   procedure Rcheck_33 (File : System.Address; Line : Integer)
+   procedure Rcheck_34 (File : System.Address; Line : Integer)
      renames Rcheck_SE_Infinite_Recursion;
-   procedure Rcheck_34 (File : System.Address; Line : Integer)
+   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;
 
    -------------
Index: a-except-2005.adb
===================================================================
--- a-except-2005.adb	(revision 200688)
+++ a-except-2005.adb	(working copy)
@@ -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 @@ 
      (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 @@ 
                   "__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 @@ 
    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 @@ 
    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 @@ 
       Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
    end Rcheck_PE_Address_Of_Intrinsic;
 
+   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_17'Address);
+      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 @@ 
       --  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;