From patchwork Fri Jul 5 09:23:20 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 257062 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client CN "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id 6C5022C0091 for ; Fri, 5 Jul 2013 19:23:34 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=KRpuIsGEMQKp4d7mBEOe80WAQBWVDqJ3lj9a95ABpQsNxfZNiq GaPzu3ag4dP7e6bbtMNkwNYKmirGWWtxAum3I+i9HOw8WaulEEUs4tQQIWNMOn4K iKM6VgH+5iKZK2YHTtsX0DIgfe1CYR7WRKFmDaVkvjzwUhB2FyyTgz3Cc= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=+I3aoQNctsAGPE58HAlp3Q6N8SY=; b=m8iL93/Aow8DGWYlmssv bsVj3andKj0h+O9uTQPTMBq0tgVWfYVi3PcuV/Y5Di49Sl/+McioAy8St5Hlu/fZ 3mPmgqk9QpxfvchRGbWS5EZU8jwvsKLKka++I1F293XE4eNuLgn7+q9F26fhRYKQ PE58eI6c7UL/QQhGm7trqL4= Received: (qmail 23370 invoked by alias); 5 Jul 2013 09:23:26 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 23315 invoked by uid 89); 5 Jul 2013 09:23:26 -0000 X-Spam-SWARE-Status: No, score=-0.5 required=5.0 tests=AWL, BAYES_50, RCVD_IN_HOSTKARMA_NO autolearn=ham version=3.3.1 Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Fri, 05 Jul 2013 09:23:22 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 3074D1C65A1; Fri, 5 Jul 2013 05:23:20 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id DRBdzbv3klaA; Fri, 5 Jul 2013 05:23:20 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 13BA01C6591; Fri, 5 Jul 2013 05:23:20 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 1291C3FB31; Fri, 5 Jul 2013 05:23:20 -0400 (EDT) Date: Fri, 5 Jul 2013 05:23:20 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Detailed exception messages for aliased parameters Message-ID: <20130705092320.GA21185@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) X-Virus-Found: No 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 * 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. 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 ; + -- 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;