From patchwork Thu Apr 27 09:50:09 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 755931 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.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3wDBzK0Z2yz9sN8 for ; Thu, 27 Apr 2017 19:51:08 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="w9NSzd1o"; dkim-atps=neutral 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=maFrD06ff1jpE/iHACUG9knMzXbSephiZJBYe6q11FIXt61fYf MA7PT56O5n4CUGzvLyXFZ3p0f3bGIphyc3xN7q0FmCqSFQ1aNNtpt/FvbFYRhJUy D3TDs44sxX7H7YCp4iYZKfI8kSr/uqnV5ez8wRFaynJMQyXWPpsd2bScY= 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=nUEhpw9ucYMNppB1IOiks6cNZtk=; b=w9NSzd1oJv81YXqbLtU4 nr/3eAUKtx3B0Ueg+6I5Wc1sh1HUMazZQE+v85sqmdtMln1hockv86MJbSw9Tcp8 0ZLzqi1SdoPR5ALBzYC1uY4RzS0+tPy29dxb1xMirM6/+U7qVEgE+CKzqr5wZnWi 8LwRJvlVhKQD0UiBHiw1+Po= Received: (qmail 67087 invoked by alias); 27 Apr 2017 09:50:33 -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 67027 invoked by uid 89); 27 Apr 2017 09:50:29 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-14.8 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=Little, accordance, throwing, exclusion X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 27 Apr 2017 09:50:09 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id D13855A5AD; Thu, 27 Apr 2017 05:50:09 -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 5RWN1jq4xFVa; Thu, 27 Apr 2017 05:50:09 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id ABF1B5A59F; Thu, 27 Apr 2017 05:50:09 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id AA0894F9; Thu, 27 Apr 2017 05:50:09 -0400 (EDT) Date: Thu, 27 Apr 2017 05:50:09 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Tristan Gingold Subject: [Ada] Use backend (ie gcc) exception mechanism for gnat1 Message-ID: <20170427095009.GA13507@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) Before this patch, gnat1 was using frontend exception mechanism. This is a mechanism based on setjmp/longjmp (the builtin variant), so it is not known by the backend. This mechanism is known to be fragile and can create huge BB graph (as the backend doesn't know the target of a longjmp). No functional change. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-04-27 Tristan Gingold * raise.c (__gnat_builtin_longjmp): Remove. (__gnat_bracktrace): Add a dummy definition for the compiler (__gnat_eh_personality, __gnat_rcheck_04, __gnat_rcheck_10) (__gnat_rcheck_19, __gnat_rcheck_20, __gnat_rcheck_21) (__gnat_rcheck_30, __gnat_rcheck_31, __gnat_rcheck_32): Likewise. * a-exexpr.adb: Renamed from a-exexpr-gcc.adb * a-except.ads, a-except.adb: Renamed from a-except-2005.ads and a-except-2005.adb. * raise-gcc.c: Allow build in compiler, compiled as a C++ file. (__gnat_Unwind_ForcedUnwind): Adjust prototype. (db): Constify msg_format. (get_call_site_action_for): Don't use void arithmetic. * system.ads (Frontend_Exceptions): Set to False. (ZCX_By_Default): Set to True. (GCC_ZC_Support): Set to True. * gcc-interface/Makefile.in: No more variants for a-exexpr.adb and a-except.ad[sb]. * gcc-interface/Make-lang.in: Add support for backend zcx exceptions in gnat1 and gnatbind. * gnat1, gnatbind: link with raise-gcc.o, a-exctra.o, s-addima.o, s-excmac.o, s-imgint.o, s-traceb.o, s-trasym.o, s-wchstw.o * s-excmac.ads, s-excmac.adb: Copy of variants. * a-except.o: Adjust preequisites. Add handling of s-excmac-arm.adb and s-excmac-gcc.adb. Index: a-exexpr.adb =================================================================== --- a-exexpr.adb (revision 247293) +++ a-exexpr.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -29,71 +29,411 @@ -- -- ------------------------------------------------------------------------------ --- This is the default version, using the __builtin_setjmp/longjmp EH --- mechanism. +-- This is the version using the GCC EH mechanism with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with System.Storage_Elements; use System.Storage_Elements; +with System.Exceptions.Machine; use System.Exceptions.Machine; + separate (Ada.Exceptions) package body Exception_Propagation is - -- Common binding to __builtin_longjmp for sjlj variants. + use Exception_Traces; - procedure builtin_longjmp (buffer : System.Address; Flag : Integer); - pragma No_Return (builtin_longjmp); - pragma Import (Intrinsic, builtin_longjmp, "__builtin_longjmp"); + Foreign_Exception : aliased System.Standard_Library.Exception_Data; + pragma Import (Ada, Foreign_Exception, + "system__exceptions__foreign_exception"); + -- Id for foreign exceptions - procedure Propagate_Continue (E : Exception_Id); - pragma No_Return (Propagate_Continue); - pragma Export (C, Propagate_Continue, "__gnat_raise_nodefer_with_msg"); - -- A call to this procedure is inserted automatically by GIGI, in order - -- to continue the propagation when the exception was not handled. - -- The linkage name is historical. + -------------------------------------------------------------- + -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- + -------------------------------------------------------------- + procedure GNAT_GCC_Exception_Cleanup + (Reason : Unwind_Reason_Code; + Excep : not null GNAT_GCC_Exception_Access); + pragma Convention (C, GNAT_GCC_Exception_Cleanup); + -- Procedure called when a GNAT GCC exception is free. + + procedure Propagate_GCC_Exception + (GCC_Exception : not null GCC_Exception_Access); + pragma No_Return (Propagate_GCC_Exception); + -- Propagate a GCC exception + + procedure Reraise_GCC_Exception + (GCC_Exception : not null GCC_Exception_Access); + pragma No_Return (Reraise_GCC_Exception); + pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx"); + -- Called to implement raise without exception, ie reraise. Called + -- directly from gigi. + + function Setup_Current_Excep + (GCC_Exception : not null GCC_Exception_Access) return EOA; + pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); + -- Write Get_Current_Excep.all from GCC_Exception. Called by the + -- personality routine. + + procedure Unhandled_Except_Handler + (GCC_Exception : not null GCC_Exception_Access); + pragma No_Return (Unhandled_Except_Handler); + pragma Export (C, Unhandled_Except_Handler, + "__gnat_unhandled_except_handler"); + -- Called for handle unhandled exceptions, ie the last chance handler + -- on platforms (such as SEH) that never returns after throwing an + -- exception. Called directly by gigi. + + function CleanupUnwind_Handler + (UW_Version : Integer; + UW_Phases : Unwind_Action; + UW_Eclass : Exception_Class; + UW_Exception : not null GCC_Exception_Access; + UW_Context : System.Address; + UW_Argument : System.Address) return Unwind_Reason_Code; + pragma Import (C, CleanupUnwind_Handler, + "__gnat_cleanupunwind_handler"); + -- Hook called at each step of the forced unwinding we perform to trigger + -- cleanups found during the propagation of an unhandled exception. + + -- GCC runtime functions used. These are C non-void functions, actually, + -- but we ignore the return values. See raise.c as to why we are using + -- __gnat stubs for these. + + procedure Unwind_RaiseException + (UW_Exception : not null GCC_Exception_Access); + pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException"); + + procedure Unwind_ForcedUnwind + (UW_Exception : not null GCC_Exception_Access; + UW_Handler : System.Address; + UW_Argument : System.Address); + pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind"); + + procedure Set_Exception_Parameter + (Excep : EOA; + GCC_Exception : not null GCC_Exception_Access); + pragma Export + (C, Set_Exception_Parameter, "__gnat_set_exception_parameter"); + -- Called inserted by gigi to set the exception choice parameter from the + -- gcc occurrence. + + procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address); + -- Utility routine to initialize occurrence Excep from a foreign exception + -- whose machine occurrence is Mo. The message is empty, the backtrace + -- is empty too and the exception identity is Foreign_Exception. + + -- Hooks called when entering/leaving an exception handler for a given + -- occurrence, aimed at handling the stack of active occurrences. The + -- calls are generated by gigi in tree_transform/N_Exception_Handler. + + procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access); + pragma Export (C, Begin_Handler, "__gnat_begin_handler"); + + procedure End_Handler (GCC_Exception : GCC_Exception_Access); + pragma Export (C, End_Handler, "__gnat_end_handler"); + + -------------------------------------------------------------------- + -- Accessors to Basic Components of a GNAT Exception Data Pointer -- + -------------------------------------------------------------------- + + -- As of today, these are only used by the C implementation of the GCC + -- propagation personality routine to avoid having to rely on a C + -- counterpart of the whole exception_data structure, which is both + -- painful and error prone. These subprograms could be moved to a more + -- widely visible location if need be. + + function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean; + pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others"); + pragma Warnings (Off, Is_Handled_By_Others); + + function Language_For (E : Exception_Data_Ptr) return Character; + pragma Export (C, Language_For, "__gnat_language_for"); + + function Foreign_Data_For (E : Exception_Data_Ptr) return Address; + pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for"); + + function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access) + return Exception_Id; + pragma Export (C, EID_For, "__gnat_eid_for"); + + --------------------------------------------------------------------------- + -- Objects to materialize "others" and "all others" in the GCC EH tables -- + --------------------------------------------------------------------------- + + -- Currently, these only have their address taken and compared so there is + -- no real point having whole exception data blocks allocated. Note that + -- there are corresponding declarations in gigi (trans.c) which must be + -- kept properly synchronized. + + Others_Value : constant Character := 'O'; + pragma Export (C, Others_Value, "__gnat_others_value"); + + All_Others_Value : constant Character := 'A'; + pragma Export (C, All_Others_Value, "__gnat_all_others_value"); + + Unhandled_Others_Value : constant Character := 'U'; + pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value"); + -- Special choice (emitted by gigi) to catch and notify unhandled + -- exceptions on targets which always handle exceptions (such as SEH). + -- The handler will simply call Unhandled_Except_Handler. + ------------------------- -- Allocate_Occurrence -- ------------------------- function Allocate_Occurrence return EOA is + Res : GNAT_GCC_Exception_Access; + begin - return Get_Current_Excep.all; + Res := New_Occurrence; + Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address; + Res.Occurrence.Machine_Occurrence := Res.all'Address; + + return Res.Occurrence'Access; end Allocate_Occurrence; + -------------------------------- + -- GNAT_GCC_Exception_Cleanup -- + -------------------------------- + + procedure GNAT_GCC_Exception_Cleanup + (Reason : Unwind_Reason_Code; + Excep : not null GNAT_GCC_Exception_Access) + is + pragma Unreferenced (Reason); + + procedure Free is new Unchecked_Deallocation + (GNAT_GCC_Exception, GNAT_GCC_Exception_Access); + + Copy : GNAT_GCC_Exception_Access := Excep; + + begin + -- Simply free the memory + + Free (Copy); + end GNAT_GCC_Exception_Cleanup; + + ---------------------------- + -- Set_Foreign_Occurrence -- + ---------------------------- + + procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is + begin + Excep.all := ( + Id => Foreign_Exception'Access, + Machine_Occurrence => Mo, + Msg => <>, + Msg_Length => 0, + Exception_Raised => True, + Pid => Local_Partition_ID, + Num_Tracebacks => 0, + Tracebacks => <>); + end Set_Foreign_Occurrence; + ------------------------- + -- Setup_Current_Excep -- + ------------------------- + + function Setup_Current_Excep + (GCC_Exception : not null GCC_Exception_Access) return EOA + is + Excep : constant EOA := Get_Current_Excep.all; + + begin + -- Setup the exception occurrence + + if GCC_Exception.Class = GNAT_Exception_Class then + + -- From the GCC exception + + declare + GNAT_Occurrence : constant GNAT_GCC_Exception_Access := + To_GNAT_GCC_Exception (GCC_Exception); + begin + Excep.all := GNAT_Occurrence.Occurrence; + return GNAT_Occurrence.Occurrence'Access; + end; + + else + -- A default one + + Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); + + return Excep; + end if; + end Setup_Current_Excep; + + ------------------- + -- Begin_Handler -- + ------------------- + + procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is + pragma Unreferenced (GCC_Exception); + begin + null; + end Begin_Handler; + + ----------------- + -- End_Handler -- + ----------------- + + procedure End_Handler (GCC_Exception : GCC_Exception_Access) is + begin + if GCC_Exception /= null then + + -- The exception might have been reraised, in this case the cleanup + -- mustn't be called. + + Unwind_DeleteException (GCC_Exception); + end if; + end End_Handler; + + ----------------------------- + -- Reraise_GCC_Exception -- + ----------------------------- + + procedure Reraise_GCC_Exception + (GCC_Exception : not null GCC_Exception_Access) + is + begin + -- Simply propagate it + + Propagate_GCC_Exception (GCC_Exception); + end Reraise_GCC_Exception; + + ----------------------------- + -- Propagate_GCC_Exception -- + ----------------------------- + + -- Call Unwind_RaiseException to actually throw, taking care of handling + -- the two phase scheme it implements. + + procedure Propagate_GCC_Exception + (GCC_Exception : not null GCC_Exception_Access) + is + Excep : EOA; + + begin + -- Perform a standard raise first. If a regular handler is found, it + -- will be entered after all the intermediate cleanups have run. If + -- there is no regular handler, it will return. + + Unwind_RaiseException (GCC_Exception); + + -- If we get here we know the exception is not handled, as otherwise + -- Unwind_RaiseException arranges for the handler to be entered. Take + -- the necessary steps to enable the debugger to gain control while the + -- stack is still intact. + + Excep := Setup_Current_Excep (GCC_Exception); + Notify_Unhandled_Exception (Excep); + + -- Now, un a forced unwind to trigger cleanups. Control should not + -- resume there, if there are cleanups and in any cases as the + -- unwinding hook calls Unhandled_Exception_Terminate when end of + -- stack is reached. + + Unwind_ForcedUnwind + (GCC_Exception, + CleanupUnwind_Handler'Address, + System.Null_Address); + + -- We get here in case of error. The debugger has been notified before + -- the second step above. + + Unhandled_Except_Handler (GCC_Exception); + end Propagate_GCC_Exception; + + ------------------------- -- Propagate_Exception -- ------------------------- procedure Propagate_Exception (Excep : EOA) is - Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; + begin + Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence)); + end Propagate_Exception; + ----------------------------- + -- Set_Exception_Parameter -- + ----------------------------- + + procedure Set_Exception_Parameter + (Excep : EOA; + GCC_Exception : not null GCC_Exception_Access) + is begin - -- If the jump buffer pointer is non-null, transfer control using - -- it. Otherwise announce an unhandled exception (note that this - -- means that we have no finalizations to do other than at the outer - -- level). Perform the necessary notification tasks in both cases. + -- Setup the exception occurrence - if Jumpbuf_Ptr /= Null_Address then - if not Excep.Exception_Raised then - Excep.Exception_Raised := True; - Exception_Traces.Notify_Handled_Exception (Excep); - end if; + if GCC_Exception.Class = GNAT_Exception_Class then - builtin_longjmp (Jumpbuf_Ptr, 1); + -- From the GCC exception + declare + GNAT_Occurrence : constant GNAT_GCC_Exception_Access := + To_GNAT_GCC_Exception (GCC_Exception); + begin + Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence); + end; + else - Exception_Traces.Notify_Unhandled_Exception (Excep); - Exception_Traces.Unhandled_Exception_Terminate (Excep); + -- A default one + + Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); end if; - end Propagate_Exception; + end Set_Exception_Parameter; - ------------------------ - -- Propagate_Continue -- - ------------------------ + ------------------------------ + -- Unhandled_Except_Handler -- + ------------------------------ - procedure Propagate_Continue (E : Exception_Id) is - pragma Unreferenced (E); + procedure Unhandled_Except_Handler + (GCC_Exception : not null GCC_Exception_Access) + is + Excep : EOA; begin - Propagate_Exception (Get_Current_Excep.all); - end Propagate_Continue; + Excep := Setup_Current_Excep (GCC_Exception); + Unhandled_Exception_Terminate (Excep); + end Unhandled_Except_Handler; + ------------- + -- EID_For -- + ------------- + + function EID_For + (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id + is + begin + return GNAT_Exception.Occurrence.Id; + end EID_For; + + ---------------------- + -- Foreign_Data_For -- + ---------------------- + + function Foreign_Data_For + (E : SSL.Exception_Data_Ptr) return Address + is + begin + return E.Foreign_Data; + end Foreign_Data_For; + + -------------------------- + -- Is_Handled_By_Others -- + -------------------------- + + function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is + begin + return not E.all.Not_Handled_By_Others; + end Is_Handled_By_Others; + + ------------------ + -- Language_For -- + ------------------ + + function Language_For (E : SSL.Exception_Data_Ptr) return Character is + begin + return E.all.Lang; + end Language_For; + end Exception_Propagation; Index: a-exexpr-gcc.adb =================================================================== --- a-exexpr-gcc.adb (revision 247293) +++ a-exexpr-gcc.adb (working copy) @@ -1,439 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . E X C E P T I O N _ P R O P A G A T I O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the version using the GCC EH mechanism - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -with System.Storage_Elements; use System.Storage_Elements; -with System.Exceptions.Machine; use System.Exceptions.Machine; - -separate (Ada.Exceptions) -package body Exception_Propagation is - - use Exception_Traces; - - Foreign_Exception : aliased System.Standard_Library.Exception_Data; - pragma Import (Ada, Foreign_Exception, - "system__exceptions__foreign_exception"); - -- Id for foreign exceptions - - -------------------------------------------------------------- - -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- - -------------------------------------------------------------- - - procedure GNAT_GCC_Exception_Cleanup - (Reason : Unwind_Reason_Code; - Excep : not null GNAT_GCC_Exception_Access); - pragma Convention (C, GNAT_GCC_Exception_Cleanup); - -- Procedure called when a GNAT GCC exception is free. - - procedure Propagate_GCC_Exception - (GCC_Exception : not null GCC_Exception_Access); - pragma No_Return (Propagate_GCC_Exception); - -- Propagate a GCC exception - - procedure Reraise_GCC_Exception - (GCC_Exception : not null GCC_Exception_Access); - pragma No_Return (Reraise_GCC_Exception); - pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx"); - -- Called to implement raise without exception, ie reraise. Called - -- directly from gigi. - - function Setup_Current_Excep - (GCC_Exception : not null GCC_Exception_Access) return EOA; - pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); - -- Write Get_Current_Excep.all from GCC_Exception. Called by the - -- personality routine. - - procedure Unhandled_Except_Handler - (GCC_Exception : not null GCC_Exception_Access); - pragma No_Return (Unhandled_Except_Handler); - pragma Export (C, Unhandled_Except_Handler, - "__gnat_unhandled_except_handler"); - -- Called for handle unhandled exceptions, ie the last chance handler - -- on platforms (such as SEH) that never returns after throwing an - -- exception. Called directly by gigi. - - function CleanupUnwind_Handler - (UW_Version : Integer; - UW_Phases : Unwind_Action; - UW_Eclass : Exception_Class; - UW_Exception : not null GCC_Exception_Access; - UW_Context : System.Address; - UW_Argument : System.Address) return Unwind_Reason_Code; - pragma Import (C, CleanupUnwind_Handler, - "__gnat_cleanupunwind_handler"); - -- Hook called at each step of the forced unwinding we perform to trigger - -- cleanups found during the propagation of an unhandled exception. - - -- GCC runtime functions used. These are C non-void functions, actually, - -- but we ignore the return values. See raise.c as to why we are using - -- __gnat stubs for these. - - procedure Unwind_RaiseException - (UW_Exception : not null GCC_Exception_Access); - pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException"); - - procedure Unwind_ForcedUnwind - (UW_Exception : not null GCC_Exception_Access; - UW_Handler : System.Address; - UW_Argument : System.Address); - pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind"); - - procedure Set_Exception_Parameter - (Excep : EOA; - GCC_Exception : not null GCC_Exception_Access); - pragma Export - (C, Set_Exception_Parameter, "__gnat_set_exception_parameter"); - -- Called inserted by gigi to set the exception choice parameter from the - -- gcc occurrence. - - procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address); - -- Utility routine to initialize occurrence Excep from a foreign exception - -- whose machine occurrence is Mo. The message is empty, the backtrace - -- is empty too and the exception identity is Foreign_Exception. - - -- Hooks called when entering/leaving an exception handler for a given - -- occurrence, aimed at handling the stack of active occurrences. The - -- calls are generated by gigi in tree_transform/N_Exception_Handler. - - procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access); - pragma Export (C, Begin_Handler, "__gnat_begin_handler"); - - procedure End_Handler (GCC_Exception : GCC_Exception_Access); - pragma Export (C, End_Handler, "__gnat_end_handler"); - - -------------------------------------------------------------------- - -- Accessors to Basic Components of a GNAT Exception Data Pointer -- - -------------------------------------------------------------------- - - -- As of today, these are only used by the C implementation of the GCC - -- propagation personality routine to avoid having to rely on a C - -- counterpart of the whole exception_data structure, which is both - -- painful and error prone. These subprograms could be moved to a more - -- widely visible location if need be. - - function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean; - pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others"); - pragma Warnings (Off, Is_Handled_By_Others); - - function Language_For (E : Exception_Data_Ptr) return Character; - pragma Export (C, Language_For, "__gnat_language_for"); - - function Foreign_Data_For (E : Exception_Data_Ptr) return Address; - pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for"); - - function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access) - return Exception_Id; - pragma Export (C, EID_For, "__gnat_eid_for"); - - --------------------------------------------------------------------------- - -- Objects to materialize "others" and "all others" in the GCC EH tables -- - --------------------------------------------------------------------------- - - -- Currently, these only have their address taken and compared so there is - -- no real point having whole exception data blocks allocated. Note that - -- there are corresponding declarations in gigi (trans.c) which must be - -- kept properly synchronized. - - Others_Value : constant Character := 'O'; - pragma Export (C, Others_Value, "__gnat_others_value"); - - All_Others_Value : constant Character := 'A'; - pragma Export (C, All_Others_Value, "__gnat_all_others_value"); - - Unhandled_Others_Value : constant Character := 'U'; - pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value"); - -- Special choice (emitted by gigi) to catch and notify unhandled - -- exceptions on targets which always handle exceptions (such as SEH). - -- The handler will simply call Unhandled_Except_Handler. - - ------------------------- - -- Allocate_Occurrence -- - ------------------------- - - function Allocate_Occurrence return EOA is - Res : GNAT_GCC_Exception_Access; - - begin - Res := New_Occurrence; - Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address; - Res.Occurrence.Machine_Occurrence := Res.all'Address; - - return Res.Occurrence'Access; - end Allocate_Occurrence; - - -------------------------------- - -- GNAT_GCC_Exception_Cleanup -- - -------------------------------- - - procedure GNAT_GCC_Exception_Cleanup - (Reason : Unwind_Reason_Code; - Excep : not null GNAT_GCC_Exception_Access) - is - pragma Unreferenced (Reason); - - procedure Free is new Unchecked_Deallocation - (GNAT_GCC_Exception, GNAT_GCC_Exception_Access); - - Copy : GNAT_GCC_Exception_Access := Excep; - - begin - -- Simply free the memory - - Free (Copy); - end GNAT_GCC_Exception_Cleanup; - - ---------------------------- - -- Set_Foreign_Occurrence -- - ---------------------------- - - procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is - begin - Excep.all := ( - Id => Foreign_Exception'Access, - Machine_Occurrence => Mo, - Msg => <>, - Msg_Length => 0, - Exception_Raised => True, - Pid => Local_Partition_ID, - Num_Tracebacks => 0, - Tracebacks => <>); - end Set_Foreign_Occurrence; - - ------------------------- - -- Setup_Current_Excep -- - ------------------------- - - function Setup_Current_Excep - (GCC_Exception : not null GCC_Exception_Access) return EOA - is - Excep : constant EOA := Get_Current_Excep.all; - - begin - -- Setup the exception occurrence - - if GCC_Exception.Class = GNAT_Exception_Class then - - -- From the GCC exception - - declare - GNAT_Occurrence : constant GNAT_GCC_Exception_Access := - To_GNAT_GCC_Exception (GCC_Exception); - begin - Excep.all := GNAT_Occurrence.Occurrence; - return GNAT_Occurrence.Occurrence'Access; - end; - - else - -- A default one - - Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); - - return Excep; - end if; - end Setup_Current_Excep; - - ------------------- - -- Begin_Handler -- - ------------------- - - procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is - pragma Unreferenced (GCC_Exception); - begin - null; - end Begin_Handler; - - ----------------- - -- End_Handler -- - ----------------- - - procedure End_Handler (GCC_Exception : GCC_Exception_Access) is - begin - if GCC_Exception /= null then - - -- The exception might have been reraised, in this case the cleanup - -- mustn't be called. - - Unwind_DeleteException (GCC_Exception); - end if; - end End_Handler; - - ----------------------------- - -- Reraise_GCC_Exception -- - ----------------------------- - - procedure Reraise_GCC_Exception - (GCC_Exception : not null GCC_Exception_Access) - is - begin - -- Simply propagate it - - Propagate_GCC_Exception (GCC_Exception); - end Reraise_GCC_Exception; - - ----------------------------- - -- Propagate_GCC_Exception -- - ----------------------------- - - -- Call Unwind_RaiseException to actually throw, taking care of handling - -- the two phase scheme it implements. - - procedure Propagate_GCC_Exception - (GCC_Exception : not null GCC_Exception_Access) - is - Excep : EOA; - - begin - -- Perform a standard raise first. If a regular handler is found, it - -- will be entered after all the intermediate cleanups have run. If - -- there is no regular handler, it will return. - - Unwind_RaiseException (GCC_Exception); - - -- If we get here we know the exception is not handled, as otherwise - -- Unwind_RaiseException arranges for the handler to be entered. Take - -- the necessary steps to enable the debugger to gain control while the - -- stack is still intact. - - Excep := Setup_Current_Excep (GCC_Exception); - Notify_Unhandled_Exception (Excep); - - -- Now, un a forced unwind to trigger cleanups. Control should not - -- resume there, if there are cleanups and in any cases as the - -- unwinding hook calls Unhandled_Exception_Terminate when end of - -- stack is reached. - - Unwind_ForcedUnwind - (GCC_Exception, - CleanupUnwind_Handler'Address, - System.Null_Address); - - -- We get here in case of error. The debugger has been notified before - -- the second step above. - - Unhandled_Except_Handler (GCC_Exception); - end Propagate_GCC_Exception; - - ------------------------- - -- Propagate_Exception -- - ------------------------- - - procedure Propagate_Exception (Excep : EOA) is - begin - Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence)); - end Propagate_Exception; - - ----------------------------- - -- Set_Exception_Parameter -- - ----------------------------- - - procedure Set_Exception_Parameter - (Excep : EOA; - GCC_Exception : not null GCC_Exception_Access) - is - begin - -- Setup the exception occurrence - - if GCC_Exception.Class = GNAT_Exception_Class then - - -- From the GCC exception - - declare - GNAT_Occurrence : constant GNAT_GCC_Exception_Access := - To_GNAT_GCC_Exception (GCC_Exception); - begin - Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence); - end; - - else - -- A default one - - Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); - end if; - end Set_Exception_Parameter; - - ------------------------------ - -- Unhandled_Except_Handler -- - ------------------------------ - - procedure Unhandled_Except_Handler - (GCC_Exception : not null GCC_Exception_Access) - is - Excep : EOA; - begin - Excep := Setup_Current_Excep (GCC_Exception); - Unhandled_Exception_Terminate (Excep); - end Unhandled_Except_Handler; - - ------------- - -- EID_For -- - ------------- - - function EID_For - (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id - is - begin - return GNAT_Exception.Occurrence.Id; - end EID_For; - - ---------------------- - -- Foreign_Data_For -- - ---------------------- - - function Foreign_Data_For - (E : SSL.Exception_Data_Ptr) return Address - is - begin - return E.Foreign_Data; - end Foreign_Data_For; - - -------------------------- - -- Is_Handled_By_Others -- - -------------------------- - - function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is - begin - return not E.all.Not_Handled_By_Others; - end Is_Handled_By_Others; - - ------------------ - -- Language_For -- - ------------------ - - function Language_For (E : SSL.Exception_Data_Ptr) return Character is - begin - return E.all.Lang; - end Language_For; - -end Exception_Propagation; Index: a-except.adb =================================================================== --- a-except.adb (revision 247293) +++ a-except.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Compiler_Unit_Warning; - pragma Style_Checks (All_Checks); -- No subprogram ordering check, due to logical grouping @@ -39,16 +37,29 @@ -- elaboration circularities with System.Exception_Tables. with System; use System; +with System.Exceptions; use System.Exceptions; with System.Exceptions_Debug; use System.Exceptions_Debug; with System.Standard_Library; use System.Standard_Library; with System.Soft_Links; use System.Soft_Links; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_StW; use System.WCh_StW; +pragma Warnings (Off); +-- Suppress complaints about Symbolic not being referenced, and about it not +-- having pragma Preelaborate. +with System.Traceback.Symbolic; +-- Bring Symbolic into the closure. If it is the s-trasym-dwarf.adb version, +-- it will install symbolic tracebacks as the default decorator. Otherwise, +-- symbolic tracebacks are not supported, and we fall back to hexadecimal +-- addresses. +pragma Warnings (On); + package body Ada.Exceptions is pragma Suppress (All_Checks); - -- We definitely do not want exceptions occurring within this unit, or we - -- are in big trouble. If an exceptional situation does occur, better that - -- it not be raised, since raising it can cause confusing chaos. + -- We definitely do not want exceptions occurring within this unit, or + -- we are in big trouble. If an exceptional situation does occur, better + -- that it not be raised, since raising it can cause confusing chaos. ----------------------- -- Local Subprograms -- @@ -58,22 +69,47 @@ -- from C clients using the given external name, even though they are not -- technically visible in the Ada sense. - procedure Process_Raise_Exception (E : Exception_Id); - pragma No_Return (Process_Raise_Exception); - -- This is the lowest level raise routine. It raises the exception - -- referenced by Current_Excep.all in the TSD, without deferring abort - -- (the caller must ensure that abort is deferred on entry). + function Code_Address_For_AAA return System.Address; + function Code_Address_For_ZZZ return System.Address; + -- Return start and end of procedures in this package + -- + -- These procedures are used to provide exclusion bounds in + -- calls to Call_Chain at exception raise points from this unit. The + -- purpose is to arrange for the exception tracebacks not to include + -- frames from subprograms involved in the raise process, as these are + -- meaningless from the user's standpoint. + -- + -- For these bounds to be meaningful, we need to ensure that the object + -- code for the subprograms involved in processing a raise is located + -- after the object code Code_Address_For_AAA and before the object + -- code Code_Address_For_ZZZ. This will indeed be the case as long as + -- the following rules are respected: + -- + -- 1) The bodies of the subprograms involved in processing a raise + -- are located after the body of Code_Address_For_AAA and before the + -- body of Code_Address_For_ZZZ. + -- + -- 2) No pragma Inline applies to any of these subprograms, as this + -- could delay the corresponding assembly output until the end of + -- the unit. + procedure Call_Chain (Excep : EOA); + -- Store up to Max_Tracebacks in Excep, corresponding to the current + -- call chain. + + function Image (Index : Integer) return String; + -- Return string image corresponding to Index + procedure To_Stderr (S : String); pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); - -- Little routine to output string to stderr that is also used in the - -- tasking run time. + -- Little routine to output string to stderr that is also used + -- in the tasking run time. procedure To_Stderr (C : Character); pragma Inline (To_Stderr); pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char"); - -- Little routine to output a character to stderr, used by some of the - -- separate units below. + -- Little routine to output a character to stderr, used by some of + -- the separate units below. package Exception_Data is @@ -88,22 +124,21 @@ Line : Integer := 0; Column : Integer := 0; Msg2 : System.Address := System.Null_Address); - -- This routine is called to setup the exception referenced by the - -- Current_Excep field in the TSD to contain the indicated Id value - -- and message. Msg1 is a null terminated string which is generated - -- as the exception message. If line is non-zero, then a colon and - -- the decimal representation of this integer is appended to the - -- message. Ditto for Column. When Msg2 is non-null, a space and this - -- additional null terminated string is added to the message. + -- This routine is called to setup the exception referenced by X + -- to contain the indicated Id value and message. Msg1 is a null + -- terminated string which is generated as the exception message. If + -- line is non-zero, then a colon and the decimal representation of + -- this integer is appended to the message. Ditto for Column. When Msg2 + -- is non-null, a space and this additional null terminated string is + -- added to the message. procedure Set_Exception_Msg (Excep : EOA; Id : Exception_Id; Message : String); - -- This routine is called to setup the exception referenced by the - -- Current_Excep field in the TSD to contain the indicated Id value and - -- message. Message is a string which is generated as the exception - -- message. + -- This routine is called to setup the exception referenced by X + -- to contain the indicated Id value and message. Message is a string + -- which is generated as the exception message. --------------------------------------- -- Exception Information Subprograms -- @@ -176,14 +211,29 @@ procedure Unhandled_Exception_Terminate (Excep : EOA); pragma No_Return (Unhandled_Exception_Terminate); - -- This procedure is called to terminate program execution following an - -- unhandled exception. The exception information, including traceback - -- if available is output, and execution is then terminated. Note that - -- at the point where this routine is called, the stack has typically - -- been destroyed. + -- This procedure is called to terminate execution following an + -- unhandled exception. The exception information, including + -- traceback if available is output, and execution is then + -- terminated. Note that at the point where this routine is + -- called, the stack has typically been destroyed. end Exception_Traces; + package Exception_Propagation is + + --------------------------------------- + -- Exception Propagation Subprograms -- + --------------------------------------- + + function Allocate_Occurrence return EOA; + -- Allocate an exception occurrence (as well as the machine occurrence) + + procedure Propagate_Exception (Excep : EOA); + pragma No_Return (Propagate_Exception); + -- This procedure propagates the exception represented by Excep + + end Exception_Propagation; + package Stream_Attributes is ---------------------------------- @@ -201,18 +251,32 @@ end Stream_Attributes; - procedure Raise_Current_Excep (E : Exception_Id); - pragma No_Return (Raise_Current_Excep); - pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg"); - -- This is a simple wrapper to Process_Raise_Exception. - -- - -- This external name for Raise_Current_Excep is historical, and probably - -- should be changed but for now we keep it, because gdb and gigi know - -- about it. + procedure Complete_Occurrence (X : EOA); + -- Finish building the occurrence: save the call chain and notify the + -- debugger. + procedure Complete_And_Propagate_Occurrence (X : EOA); + pragma No_Return (Complete_And_Propagate_Occurrence); + -- This is a simple wrapper to Complete_Occurrence and + -- Exception_Propagation.Propagate_Exception. + + function Create_Occurrence_From_Signal_Handler + (E : Exception_Id; + M : System.Address) return EOA; + -- Create and build an exception occurrence using exception id E and + -- nul-terminated message M. + + function Create_Machine_Occurrence_From_Signal_Handler + (E : Exception_Id; + M : System.Address) return System.Address; + pragma Export (C, Create_Machine_Occurrence_From_Signal_Handler, + "__gnat_create_machine_occurrence_from_signal_handler"); + -- Create and build an exception occurrence using exception id E and + -- nul-terminated message M. Return the machine occurrence. + procedure Raise_Exception_No_Defer - (E : Exception_Id; - Message : String := ""); + (E : Exception_Id; + Message : String := ""); pragma Export (Ada, Raise_Exception_No_Defer, "ada__exceptions__raise_exception_no_defer"); @@ -222,45 +286,41 @@ procedure Raise_With_Msg (E : Exception_Id); pragma No_Return (Raise_With_Msg); pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg"); - -- Raises an exception with given exception id value. A message is - -- associated with the raise, and has already been stored in the exception - -- occurrence referenced by the Current_Excep in the TSD. Abort is deferred - -- before the raise call. + -- Raises an exception with given exception id value. A message + -- is associated with the raise, and has already been stored in the + -- exception occurrence referenced by the Current_Excep in the TSD. + -- Abort is deferred before the raise call. procedure Raise_With_Location_And_Msg (E : Exception_Id; F : System.Address; L : Integer; + C : Integer := 0; M : System.Address := System.Null_Address); pragma No_Return (Raise_With_Location_And_Msg); -- Raise an exception with given exception id value. A filename and line -- number is associated with the raise and is stored in the exception - -- occurrence and in addition a string message M is appended to this - -- if M is not null. + -- occurrence and in addition a column and a string message M may be + -- appended to this (if not null/0). - procedure Raise_Constraint_Error - (File : System.Address; - Line : Integer); + procedure Raise_Constraint_Error (File : System.Address; Line : Integer); pragma No_Return (Raise_Constraint_Error); - pragma Export - (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); + pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); -- Raise constraint error with file:line information procedure Raise_Constraint_Error_Msg - (File : System.Address; - Line : Integer; - Msg : System.Address); + (File : System.Address; + Line : Integer; + Column : Integer; + Msg : System.Address); pragma No_Return (Raise_Constraint_Error_Msg); pragma Export (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg"); - -- Raise constraint error with file:line + msg information + -- Raise constraint error with file:line:col + msg information - procedure Raise_Program_Error - (File : System.Address; - Line : Integer); + procedure Raise_Program_Error (File : System.Address; Line : Integer); pragma No_Return (Raise_Program_Error); - pragma Export - (C, Raise_Program_Error, "__gnat_raise_program_error"); + pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error"); -- Raise program error with file:line information procedure Raise_Program_Error_Msg @@ -272,12 +332,9 @@ (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg"); -- Raise program error with file:line + msg information - procedure Raise_Storage_Error - (File : System.Address; - Line : Integer); + procedure Raise_Storage_Error (File : System.Address; Line : Integer); pragma No_Return (Raise_Storage_Error); - pragma Export - (C, Raise_Storage_Error, "__gnat_raise_storage_error"); + pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error"); -- Raise storage error with file:line information procedure Raise_Storage_Error_Msg @@ -294,10 +351,10 @@ -- graph below illustrates the relations between the Raise_ subprograms -- and identifies the points where basic flags such as Exception_Raised -- are initialized. - -- + -- (i) signs indicate the flags initialization points. R stands for Raise, -- W for With, and E for Exception. - -- + -- R_No_Msg R_E R_Pe R_Ce R_Se -- | | | | | -- +--+ +--+ +---+ | +---+ @@ -308,23 +365,24 @@ -- | | | | -- | | | Set_E_C_Msg(i) -- | | | - -- Raise_Current_Excep + -- Complete_And_Propagate_Occurrence procedure Reraise; pragma No_Return (Reraise); pragma Export (C, Reraise, "__gnat_reraise"); - -- Reraises the exception referenced by the Current_Excep field of the TSD - -- (all fields of this exception occurrence are set). Abort is deferred - -- before the reraise operation. + -- Reraises the exception referenced by the Current_Excep field + -- of the TSD (all fields of this exception occurrence are set). + -- Abort is deferred before the reraise operation. Called from + -- System.Tasking.RendezVous.Exceptional_Complete_RendezVous procedure Transfer_Occurrence (Target : Exception_Occurrence_Access; Source : Exception_Occurrence); pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); - -- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous - -- to setup Target from Source as an exception to be propagated in the - -- caller task. Target is expected to be a pointer to the fixed TSD - -- occurrence for this task. + -- Called from s-tasren.adb:Local_Complete_RendezVous and + -- s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from + -- Source as an exception to be propagated in the caller task. Target is + -- expected to be a pointer to the fixed TSD occurrence for this task. -------------------------------- -- Run-Time Check Subprograms -- @@ -334,91 +392,88 @@ -- attached. The parameters are the file name and line number in each -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name. - -- Note on ordering of these subprograms. Normally in the Ada.Exceptions - -- units we do not care about the ordering of entries for Rcheck - -- subprograms, and the normal approach is to keep them in the same - -- order as declarations in Types. - - -- This section is an IMPORTANT EXCEPTION. It is required by the .Net - -- runtime that the routine Rcheck_PE_Finalize_Raise_Exception is at the - -- end of the list (for reasons that are documented in the exceptmsg.awk - -- script which takes care of generating the required exception data). - - procedure Rcheck_CE_Access_Check -- 00 + procedure Rcheck_CE_Access_Check (File : System.Address; Line : Integer); - procedure Rcheck_CE_Null_Access_Parameter -- 01 + procedure Rcheck_CE_Null_Access_Parameter (File : System.Address; Line : Integer); - procedure Rcheck_CE_Discriminant_Check -- 02 + procedure Rcheck_CE_Discriminant_Check (File : System.Address; Line : Integer); - procedure Rcheck_CE_Divide_By_Zero -- 03 + procedure Rcheck_CE_Divide_By_Zero (File : System.Address; Line : Integer); - procedure Rcheck_CE_Explicit_Raise -- 04 + procedure Rcheck_CE_Explicit_Raise (File : System.Address; Line : Integer); - procedure Rcheck_CE_Index_Check -- 05 + procedure Rcheck_CE_Index_Check (File : System.Address; Line : Integer); - procedure Rcheck_CE_Invalid_Data -- 06 + procedure Rcheck_CE_Invalid_Data (File : System.Address; Line : Integer); - procedure Rcheck_CE_Length_Check -- 07 + procedure Rcheck_CE_Length_Check (File : System.Address; Line : Integer); - procedure Rcheck_CE_Null_Exception_Id -- 08 + procedure Rcheck_CE_Null_Exception_Id (File : System.Address; Line : Integer); - procedure Rcheck_CE_Null_Not_Allowed -- 09 + procedure Rcheck_CE_Null_Not_Allowed (File : System.Address; Line : Integer); - procedure Rcheck_CE_Overflow_Check -- 10 + procedure Rcheck_CE_Overflow_Check (File : System.Address; Line : Integer); - procedure Rcheck_CE_Partition_Check -- 11 + procedure Rcheck_CE_Partition_Check (File : System.Address; Line : Integer); - procedure Rcheck_CE_Range_Check -- 12 + procedure Rcheck_CE_Range_Check (File : System.Address; Line : Integer); - procedure Rcheck_CE_Tag_Check -- 13 + procedure Rcheck_CE_Tag_Check (File : System.Address; Line : Integer); - procedure Rcheck_PE_Access_Before_Elaboration -- 14 + procedure Rcheck_PE_Access_Before_Elaboration (File : System.Address; Line : Integer); - procedure Rcheck_PE_Accessibility_Check -- 15 + procedure Rcheck_PE_Accessibility_Check (File : System.Address; Line : Integer); - procedure Rcheck_PE_Address_Of_Intrinsic -- 16 + procedure Rcheck_PE_Address_Of_Intrinsic (File : System.Address; Line : Integer); - procedure Rcheck_PE_Aliased_Parameters -- 17 + procedure Rcheck_PE_Aliased_Parameters (File : System.Address; Line : Integer); - procedure Rcheck_PE_All_Guards_Closed -- 18 + procedure Rcheck_PE_All_Guards_Closed (File : System.Address; Line : Integer); - procedure Rcheck_PE_Bad_Predicated_Generic_Type -- 19 + procedure Rcheck_PE_Bad_Predicated_Generic_Type (File : System.Address; Line : Integer); - procedure Rcheck_PE_Current_Task_In_Entry_Body -- 20 + procedure Rcheck_PE_Current_Task_In_Entry_Body (File : System.Address; Line : Integer); - procedure Rcheck_PE_Duplicated_Entry_Address -- 21 + procedure Rcheck_PE_Duplicated_Entry_Address (File : System.Address; Line : Integer); - procedure Rcheck_PE_Explicit_Raise -- 22 + procedure Rcheck_PE_Explicit_Raise (File : System.Address; Line : Integer); - - procedure Rcheck_PE_Implicit_Return -- 24 + procedure Rcheck_PE_Implicit_Return (File : System.Address; Line : Integer); - procedure Rcheck_PE_Misaligned_Address_Value -- 25 + procedure Rcheck_PE_Misaligned_Address_Value (File : System.Address; Line : Integer); - procedure Rcheck_PE_Missing_Return -- 26 + procedure Rcheck_PE_Missing_Return (File : System.Address; Line : Integer); - procedure Rcheck_PE_Overlaid_Controlled_Object -- 27 + procedure Rcheck_PE_Non_Transportable_Actual (File : System.Address; Line : Integer); - procedure Rcheck_PE_Potentially_Blocking_Operation -- 28 + procedure Rcheck_PE_Overlaid_Controlled_Object (File : System.Address; Line : Integer); - procedure Rcheck_PE_Stubbed_Subprogram_Called -- 29 + procedure Rcheck_PE_Potentially_Blocking_Operation (File : System.Address; Line : Integer); - procedure Rcheck_PE_Unchecked_Union_Restriction -- 30 + procedure Rcheck_PE_Stubbed_Subprogram_Called (File : System.Address; Line : Integer); - procedure Rcheck_PE_Non_Transportable_Actual -- 31 + procedure Rcheck_PE_Unchecked_Union_Restriction (File : System.Address; Line : Integer); - procedure Rcheck_SE_Empty_Storage_Pool -- 32 + procedure Rcheck_SE_Empty_Storage_Pool (File : System.Address; Line : Integer); - procedure Rcheck_SE_Explicit_Raise -- 33 + procedure Rcheck_SE_Explicit_Raise (File : System.Address; Line : Integer); - procedure Rcheck_SE_Infinite_Recursion -- 34 + procedure Rcheck_SE_Infinite_Recursion (File : System.Address; Line : Integer); - procedure Rcheck_SE_Object_Too_Large -- 35 + procedure Rcheck_SE_Object_Too_Large (File : System.Address; Line : Integer); - procedure Rcheck_PE_Stream_Operation_Not_Allowed -- 36 + procedure Rcheck_PE_Stream_Operation_Not_Allowed (File : System.Address; Line : Integer); + procedure Rcheck_CE_Access_Check_Ext + (File : System.Address; Line, Column : Integer); + procedure Rcheck_CE_Index_Check_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer); + procedure Rcheck_CE_Invalid_Data_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer); + procedure Rcheck_CE_Range_Check_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer); - procedure Rcheck_PE_Finalize_Raised_Exception -- 23 + procedure Rcheck_PE_Finalize_Raised_Exception (File : System.Address; Line : Integer); -- This routine is separated out because it has quite different behavior -- from the others. This is the "finalize/adjust raised exception". This @@ -500,6 +555,15 @@ pragma Export (C, Rcheck_SE_Object_Too_Large, "__gnat_rcheck_SE_Object_Too_Large"); + pragma Export (C, Rcheck_CE_Access_Check_Ext, + "__gnat_rcheck_CE_Access_Check_ext"); + pragma Export (C, Rcheck_CE_Index_Check_Ext, + "__gnat_rcheck_CE_Index_Check_ext"); + pragma Export (C, Rcheck_CE_Invalid_Data_Ext, + "__gnat_rcheck_CE_Invalid_Data_ext"); + pragma Export (C, Rcheck_CE_Range_Check_Ext, + "__gnat_rcheck_CE_Range_Check_ext"); + -- None of these procedures ever returns (they raise an exception). By -- using pragma No_Return, we ensure that any junk code after the call, -- such as normal return epilogue stuff, can be eliminated). @@ -530,8 +594,8 @@ pragma No_Return (Rcheck_PE_Implicit_Return); pragma No_Return (Rcheck_PE_Misaligned_Address_Value); pragma No_Return (Rcheck_PE_Missing_Return); + pragma No_Return (Rcheck_PE_Non_Transportable_Actual); pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object); - pragma No_Return (Rcheck_PE_Non_Transportable_Actual); pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation); pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed); pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called); @@ -542,125 +606,11 @@ pragma No_Return (Rcheck_SE_Infinite_Recursion); pragma No_Return (Rcheck_SE_Object_Too_Large); - -- For compatibility with previous version of GNAT, to preserve bootstrap + pragma No_Return (Rcheck_CE_Access_Check_Ext); + pragma No_Return (Rcheck_CE_Index_Check_Ext); + pragma No_Return (Rcheck_CE_Invalid_Data_Ext); + pragma No_Return (Rcheck_CE_Range_Check_Ext); - procedure Rcheck_00 (File : System.Address; Line : Integer); - procedure Rcheck_01 (File : System.Address; Line : Integer); - procedure Rcheck_02 (File : System.Address; Line : Integer); - procedure Rcheck_03 (File : System.Address; Line : Integer); - procedure Rcheck_04 (File : System.Address; Line : Integer); - procedure Rcheck_05 (File : System.Address; Line : Integer); - procedure Rcheck_06 (File : System.Address; Line : Integer); - procedure Rcheck_07 (File : System.Address; Line : Integer); - procedure Rcheck_08 (File : System.Address; Line : Integer); - procedure Rcheck_09 (File : System.Address; Line : Integer); - procedure Rcheck_10 (File : System.Address; Line : Integer); - procedure Rcheck_11 (File : System.Address; Line : Integer); - procedure Rcheck_12 (File : System.Address; Line : Integer); - procedure Rcheck_13 (File : System.Address; Line : Integer); - procedure Rcheck_14 (File : System.Address; Line : Integer); - procedure Rcheck_15 (File : System.Address; Line : Integer); - procedure Rcheck_16 (File : System.Address; Line : Integer); - procedure Rcheck_17 (File : System.Address; Line : Integer); - procedure Rcheck_18 (File : System.Address; Line : Integer); - procedure Rcheck_19 (File : System.Address; Line : Integer); - procedure Rcheck_20 (File : System.Address; Line : Integer); - procedure Rcheck_21 (File : System.Address; Line : Integer); - procedure Rcheck_22 (File : System.Address; Line : Integer); - procedure Rcheck_23 (File : System.Address; Line : Integer); - procedure Rcheck_24 (File : System.Address; Line : Integer); - procedure Rcheck_25 (File : System.Address; Line : Integer); - procedure Rcheck_26 (File : System.Address; Line : Integer); - procedure Rcheck_27 (File : System.Address; Line : Integer); - procedure Rcheck_28 (File : System.Address; Line : Integer); - procedure Rcheck_29 (File : System.Address; Line : Integer); - procedure Rcheck_30 (File : System.Address; Line : Integer); - procedure Rcheck_31 (File : System.Address; Line : Integer); - 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_36 (File : System.Address; Line : Integer); - - pragma Export (C, Rcheck_00, "__gnat_rcheck_00"); - pragma Export (C, Rcheck_01, "__gnat_rcheck_01"); - pragma Export (C, Rcheck_02, "__gnat_rcheck_02"); - pragma Export (C, Rcheck_03, "__gnat_rcheck_03"); - pragma Export (C, Rcheck_04, "__gnat_rcheck_04"); - pragma Export (C, Rcheck_05, "__gnat_rcheck_05"); - pragma Export (C, Rcheck_06, "__gnat_rcheck_06"); - pragma Export (C, Rcheck_07, "__gnat_rcheck_07"); - pragma Export (C, Rcheck_08, "__gnat_rcheck_08"); - pragma Export (C, Rcheck_09, "__gnat_rcheck_09"); - pragma Export (C, Rcheck_10, "__gnat_rcheck_10"); - pragma Export (C, Rcheck_11, "__gnat_rcheck_11"); - pragma Export (C, Rcheck_12, "__gnat_rcheck_12"); - pragma Export (C, Rcheck_13, "__gnat_rcheck_13"); - pragma Export (C, Rcheck_14, "__gnat_rcheck_14"); - pragma Export (C, Rcheck_15, "__gnat_rcheck_15"); - pragma Export (C, Rcheck_16, "__gnat_rcheck_16"); - pragma Export (C, Rcheck_17, "__gnat_rcheck_17"); - pragma Export (C, Rcheck_18, "__gnat_rcheck_18"); - pragma Export (C, Rcheck_19, "__gnat_rcheck_19"); - pragma Export (C, Rcheck_20, "__gnat_rcheck_20"); - pragma Export (C, Rcheck_21, "__gnat_rcheck_21"); - pragma Export (C, Rcheck_22, "__gnat_rcheck_22"); - pragma Export (C, Rcheck_23, "__gnat_rcheck_23"); - pragma Export (C, Rcheck_24, "__gnat_rcheck_24"); - pragma Export (C, Rcheck_25, "__gnat_rcheck_25"); - pragma Export (C, Rcheck_26, "__gnat_rcheck_26"); - pragma Export (C, Rcheck_27, "__gnat_rcheck_27"); - pragma Export (C, Rcheck_28, "__gnat_rcheck_28"); - pragma Export (C, Rcheck_29, "__gnat_rcheck_29"); - pragma Export (C, Rcheck_30, "__gnat_rcheck_30"); - pragma Export (C, Rcheck_31, "__gnat_rcheck_31"); - 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"); - pragma Export (C, Rcheck_36, "__gnat_rcheck_36"); - - -- None of these procedures ever returns (they raise an exception). By - -- using pragma No_Return, we ensure that any junk code after the call, - -- such as normal return epilogue stuff, can be eliminated). - - pragma No_Return (Rcheck_00); - pragma No_Return (Rcheck_01); - pragma No_Return (Rcheck_02); - pragma No_Return (Rcheck_03); - pragma No_Return (Rcheck_04); - pragma No_Return (Rcheck_05); - pragma No_Return (Rcheck_06); - pragma No_Return (Rcheck_07); - pragma No_Return (Rcheck_08); - pragma No_Return (Rcheck_09); - pragma No_Return (Rcheck_10); - pragma No_Return (Rcheck_11); - pragma No_Return (Rcheck_12); - pragma No_Return (Rcheck_13); - pragma No_Return (Rcheck_14); - pragma No_Return (Rcheck_15); - pragma No_Return (Rcheck_16); - pragma No_Return (Rcheck_17); - pragma No_Return (Rcheck_18); - pragma No_Return (Rcheck_19); - pragma No_Return (Rcheck_20); - pragma No_Return (Rcheck_21); - pragma No_Return (Rcheck_22); - pragma No_Return (Rcheck_23); - pragma No_Return (Rcheck_24); - pragma No_Return (Rcheck_25); - pragma No_Return (Rcheck_26); - pragma No_Return (Rcheck_27); - pragma No_Return (Rcheck_28); - pragma No_Return (Rcheck_29); - pragma No_Return (Rcheck_30); - pragma No_Return (Rcheck_32); - pragma No_Return (Rcheck_33); - pragma No_Return (Rcheck_34); - pragma No_Return (Rcheck_35); - pragma No_Return (Rcheck_36); - --------------------------------------------- -- Reason Strings for Run-Time Check Calls -- --------------------------------------------- @@ -727,6 +677,33 @@ -- The actual polling routine is separate, so that it can easily be -- replaced with a target dependent version. + -------------------------- + -- Code_Address_For_AAA -- + -------------------------- + + -- This function gives us the start of the PC range for addresses within + -- the exception unit itself. We hope that gigi/gcc keep all the procedures + -- in their original order. + + function Code_Address_For_AAA return System.Address is + begin + -- We are using a label instead of Code_Address_For_AAA'Address because + -- on some platforms the latter does not yield the address we want, but + -- the address of a stub or of a descriptor instead. This is the case at + -- least on PA-HPUX. + + <> + return Start_Of_AAA'Address; + end Code_Address_For_AAA; + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain (Excep : EOA) is separate; + -- The actual Call_Chain routine is separate, so that it can easily + -- be dummied out when no exception traceback information is needed. + ------------------- -- EId_To_String -- ------------------- @@ -752,9 +729,9 @@ (X : Exception_Occurrence) return Exception_Id is begin - -- Note that the following test used to be here for the original Ada 95 - -- semantics, but these were modified by AI-241 to require returning - -- Null_Id instead of raising Constraint_Error. + -- Note that the following test used to be here for the original + -- Ada 95 semantics, but these were modified by AI-241 to require + -- returning Null_Id instead of raising Constraint_Error. -- if X.Id = Null_Id then -- raise Constraint_Error; @@ -784,9 +761,9 @@ begin if X.Id = Null_Id then raise Constraint_Error; + else + return X.Msg (1 .. X.Msg_Length); end if; - - return X.Msg (1 .. X.Msg_Length); end Exception_Message; -------------------- @@ -797,9 +774,9 @@ begin if Id = null then raise Constraint_Error; + else + return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1); end if; - - return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1); end Exception_Name; function Exception_Name (X : Exception_Occurrence) return String is @@ -839,16 +816,50 @@ -- This package can be easily dummied out if we do not want the basic -- support for exception messages (such as in Ada 83). + --------------------------- + -- Exception_Propagation -- + --------------------------- + + package body Exception_Propagation is separate; + -- Depending on the actual exception mechanism used (front-end or + -- back-end based), the implementation will differ, which is why this + -- package is separated. + ---------------------- -- Exception_Traces -- ---------------------- package body Exception_Traces is separate; -- Depending on the underlying support for IO the implementation will - -- differ. Moreover we would like to dummy out this package in case we do - -- not want any exception tracing support. This is why this package is - -- separated. + -- differ. Moreover we would like to dummy out this package in case we + -- do not want any exception tracing support. This is why this package + -- is separated. + -------------------------------------- + -- Get_Exception_Machine_Occurrence -- + -------------------------------------- + + function Get_Exception_Machine_Occurrence + (X : Exception_Occurrence) return System.Address + is + begin + return X.Machine_Occurrence; + end Get_Exception_Machine_Occurrence; + + ----------- + -- Image -- + ----------- + + function Image (Index : Integer) return String is + Result : constant String := Integer'Image (Index); + begin + if Result (1) = ' ' then + return Result (2 .. Result'Last); + else + return Result; + end if; + end Image; + ----------------------- -- Stream Attributes -- ----------------------- @@ -857,59 +868,13 @@ -- This package can be easily dummied out if we do not want the -- support for streaming Exception_Ids and Exception_Occurrences. - ----------------------------- - -- Process_Raise_Exception -- - ----------------------------- - - procedure Process_Raise_Exception (E : Exception_Id) is - pragma Inspection_Point (E); - -- This is so the debugger can reliably inspect the parameter - - Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; - Excep : constant EOA := Get_Current_Excep.all; - - procedure builtin_longjmp (buffer : Address; Flag : Integer); - pragma No_Return (builtin_longjmp); - pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp"); - - begin - -- WARNING: There should be no exception handler for this body because - -- this would cause gigi to prepend a setup for a new jmpbuf to the - -- sequence of statements in case of built-in sjljl. We would then - -- always get this new buf in Jumpbuf_Ptr instead of the one for the - -- exception we are handling, which would completely break the whole - -- design of this procedure. - - -- If the jump buffer pointer is non-null, transfer control using it. - -- Otherwise announce an unhandled exception (note that this means that - -- we have no finalizations to do other than at the outer level). - -- Perform the necessary notification tasks in both cases. - - if Jumpbuf_Ptr /= Null_Address then - if not Excep.Exception_Raised then - Excep.Exception_Raised := True; - Exception_Traces.Notify_Handled_Exception (Excep); - end if; - - builtin_longjmp (Jumpbuf_Ptr, 1); - - else - Exception_Traces.Notify_Unhandled_Exception (Excep); - Exception_Traces.Unhandled_Exception_Terminate (Excep); - end if; - end Process_Raise_Exception; - ---------------------------- -- Raise_Constraint_Error -- ---------------------------- - procedure Raise_Constraint_Error - (File : System.Address; - Line : Integer) - is + procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is begin - Raise_With_Location_And_Msg - (Constraint_Error_Def'Access, File, Line); + Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line); end Raise_Constraint_Error; -------------------------------- @@ -917,41 +882,60 @@ -------------------------------- procedure Raise_Constraint_Error_Msg - (File : System.Address; - Line : Integer; - Msg : System.Address) + (File : System.Address; + Line : Integer; + Column : Integer; + Msg : System.Address) is begin Raise_With_Location_And_Msg - (Constraint_Error_Def'Access, File, Line, Msg); + (Constraint_Error_Def'Access, File, Line, Column, Msg); end Raise_Constraint_Error_Msg; ------------------------- - -- Raise_Current_Excep -- + -- Complete_Occurrence -- ------------------------- - procedure Raise_Current_Excep (E : Exception_Id) is + procedure Complete_Occurrence (X : EOA) is + begin + -- Compute the backtrace for this occurrence if the corresponding + -- binder option has been set. Call_Chain takes care of the reraise + -- case. - pragma Inspection_Point (E); - -- This is so the debugger can reliably inspect the parameter when - -- inserting a breakpoint at the start of this procedure. + -- ??? Using Call_Chain here means we are going to walk up the stack + -- once only for backtracing purposes before doing it again for the + -- propagation per se. - Id : Exception_Id := E; - pragma Volatile (Id); - pragma Warnings (Off, Id); - -- In order to provide support for breakpoints on unhandled exceptions, - -- the debugger will also need to be able to inspect the value of E from - -- another (inner) frame. So we need to make sure that if E is passed in - -- a register, its value is also spilled on stack. For this, we store - -- the parameter value in a local variable, and add a pragma Volatile to - -- make sure it is spilled. The pragma Warnings (Off) is needed because - -- the compiler knows that Id is not referenced and that this use of - -- pragma Volatile is peculiar. + -- The first inspection is much lighter, though, as it only requires + -- partial unwinding of each frame. Additionally, although we could use + -- the personality routine to record the addresses while propagating, + -- this method has two drawbacks: + -- 1) the trace is incomplete if the exception is handled since we + -- don't walk past the frame with the handler, + + -- and + + -- 2) we would miss the frames for which our personality routine is not + -- called, e.g. if C or C++ calls are on the way. + + Call_Chain (X); + + -- Notify the debugger + Debug_Raise_Exception + (E => SSL.Exception_Data_Ptr (X.Id), + Message => X.Msg (1 .. X.Msg_Length)); + end Complete_Occurrence; + + --------------------------------------- + -- Complete_And_Propagate_Occurrence -- + --------------------------------------- + + procedure Complete_And_Propagate_Occurrence (X : EOA) is begin - Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E), Message => ""); - Process_Raise_Exception (E); - end Raise_Current_Excep; + Complete_Occurrence (X); + Exception_Propagation.Propagate_Exception (X); + end Complete_And_Propagate_Occurrence; --------------------- -- Raise_Exception -- @@ -961,8 +945,7 @@ (E : Exception_Id; Message : String := "") is - EF : Exception_Id := E; - Excep : constant EOA := Get_Current_Excep.all; + EF : Exception_Id := E; begin -- Raise CE if E = Null_ID (AI-446) @@ -972,9 +955,7 @@ -- Go ahead and raise appropriate exception - Exception_Data.Set_Exception_Msg (Excep, EF, Message); - Abort_Defer.all; - Raise_Current_Excep (EF); + Raise_Exception_Always (EF, Message); end Raise_Exception; ---------------------------- @@ -985,11 +966,16 @@ (E : Exception_Id; Message : String := "") is - Excep : constant EOA := Get_Current_Excep.all; + X : constant EOA := Exception_Propagation.Allocate_Occurrence; + begin - Exception_Data.Set_Exception_Msg (Excep, E, Message); - Abort_Defer.all; - Raise_Current_Excep (E); + Exception_Data.Set_Exception_Msg (X, E, Message); + + if not ZCX_By_Default then + Abort_Defer.all; + end if; + + Complete_And_Propagate_Occurrence (X); end Raise_Exception_Always; ------------------------------ @@ -1000,13 +986,14 @@ (E : Exception_Id; Message : String := "") is - Excep : constant EOA := Get_Current_Excep.all; + X : constant EOA := Exception_Propagation.Allocate_Occurrence; + begin - Exception_Data.Set_Exception_Msg (Excep, E, Message); + Exception_Data.Set_Exception_Msg (X, E, Message); -- Do not call Abort_Defer.all, as specified by the spec - Raise_Current_Excep (E); + Complete_And_Propagate_Occurrence (X); end Raise_Exception_No_Defer; ------------------------------------- @@ -1019,11 +1006,13 @@ Prefix : constant String := "adjust/finalize raised "; Orig_Msg : constant String := Exception_Message (X); Orig_Prefix_Length : constant Natural := - Integer'Min (Prefix'Length, Orig_Msg'Length); - Orig_Prefix : String renames Orig_Msg - (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1); + Integer'Min (Prefix'Length, Orig_Msg'Length); + + Orig_Prefix : String renames + Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1); + begin - -- Message already has proper prefix, just re-reraise + -- Message already has the proper prefix, just re-raise if Orig_Prefix = Prefix then Raise_Exception_No_Defer @@ -1053,6 +1042,39 @@ end if; end Raise_From_Controlled_Operation; + ------------------------------------------- + -- Create_Occurrence_From_Signal_Handler -- + ------------------------------------------- + + function Create_Occurrence_From_Signal_Handler + (E : Exception_Id; + M : System.Address) return EOA + is + X : constant EOA := Exception_Propagation.Allocate_Occurrence; + + begin + Exception_Data.Set_Exception_C_Msg (X, E, M); + + if not ZCX_By_Default then + Abort_Defer.all; + end if; + + Complete_Occurrence (X); + return X; + end Create_Occurrence_From_Signal_Handler; + + --------------------------------------------------- + -- Create_Machine_Occurrence_From_Signal_Handler -- + --------------------------------------------------- + + function Create_Machine_Occurrence_From_Signal_Handler + (E : Exception_Id; + M : System.Address) return System.Address + is + begin + return Create_Occurrence_From_Signal_Handler (E, M).Machine_Occurrence; + end Create_Machine_Occurrence_From_Signal_Handler; + ------------------------------- -- Raise_From_Signal_Handler -- ------------------------------- @@ -1061,11 +1083,9 @@ (E : Exception_Id; M : System.Address) is - Excep : constant EOA := Get_Current_Excep.all; begin - Exception_Data.Set_Exception_C_Msg (Excep, E, M); - Abort_Defer.all; - Process_Raise_Exception (E); + Exception_Propagation.Propagate_Exception + (Create_Occurrence_From_Signal_Handler (E, M)); end Raise_From_Signal_Handler; ------------------------- @@ -1077,8 +1097,7 @@ Line : Integer) is begin - Raise_With_Location_And_Msg - (Program_Error_Def'Access, File, Line); + Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line); end Raise_Program_Error; ----------------------------- @@ -1092,7 +1111,7 @@ is begin Raise_With_Location_And_Msg - (Program_Error_Def'Access, File, Line, Msg); + (Program_Error_Def'Access, File, Line, M => Msg); end Raise_Program_Error_Msg; ------------------------- @@ -1104,8 +1123,7 @@ Line : Integer) is begin - Raise_With_Location_And_Msg - (Storage_Error_Def'Access, File, Line); + Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line); end Raise_Storage_Error; ----------------------------- @@ -1119,7 +1137,7 @@ is begin Raise_With_Location_And_Msg - (Storage_Error_Def'Access, File, Line, Msg); + (Storage_Error_Def'Access, File, Line, M => Msg); end Raise_Storage_Error_Msg; --------------------------------- @@ -1130,13 +1148,18 @@ (E : Exception_Id; F : System.Address; L : Integer; + C : Integer := 0; M : System.Address := System.Null_Address) is - Excep : constant EOA := Get_Current_Excep.all; + X : constant EOA := Exception_Propagation.Allocate_Occurrence; begin - Exception_Data.Set_Exception_C_Msg (Excep, E, F, L, Msg2 => M); - Abort_Defer.all; - Raise_Current_Excep (E); + Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M); + + if not ZCX_By_Default then + Abort_Defer.all; + end if; + + Complete_And_Propagate_Occurrence (X); end Raise_With_Location_And_Msg; -------------------- @@ -1144,15 +1167,28 @@ -------------------- procedure Raise_With_Msg (E : Exception_Id) is - Excep : constant EOA := Get_Current_Excep.all; - + Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; + Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; begin Excep.Exception_Raised := False; Excep.Id := E; Excep.Num_Tracebacks := 0; Excep.Pid := Local_Partition_ID; - Abort_Defer.all; - Raise_Current_Excep (E); + + -- Copy the message from the current exception + -- Change the interface to be called with an occurrence ??? + + Excep.Msg_Length := Ex.Msg_Length; + Excep.Msg (1 .. Excep.Msg_Length) := Ex.Msg (1 .. Ex.Msg_Length); + + -- The following is a common pattern, should be abstracted + -- into a procedure call ??? + + if not ZCX_By_Default then + Abort_Defer.all; + end if; + + Complete_And_Propagate_Occurrence (Excep); end Raise_With_Msg; ----------------------------------------- @@ -1163,98 +1199,98 @@ (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_00'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_00'Address); end Rcheck_CE_Access_Check; procedure Rcheck_CE_Null_Access_Parameter (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_01'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_01'Address); end Rcheck_CE_Null_Access_Parameter; procedure Rcheck_CE_Discriminant_Check (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_02'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_02'Address); end Rcheck_CE_Discriminant_Check; procedure Rcheck_CE_Divide_By_Zero (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_03'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_03'Address); end Rcheck_CE_Divide_By_Zero; procedure Rcheck_CE_Explicit_Raise (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_04'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_04'Address); end Rcheck_CE_Explicit_Raise; procedure Rcheck_CE_Index_Check (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_05'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_05'Address); end Rcheck_CE_Index_Check; procedure Rcheck_CE_Invalid_Data (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_06'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_06'Address); end Rcheck_CE_Invalid_Data; procedure Rcheck_CE_Length_Check (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_07'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_07'Address); end Rcheck_CE_Length_Check; procedure Rcheck_CE_Null_Exception_Id (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_08'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_08'Address); end Rcheck_CE_Null_Exception_Id; procedure Rcheck_CE_Null_Not_Allowed (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_09'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_09'Address); end Rcheck_CE_Null_Not_Allowed; procedure Rcheck_CE_Overflow_Check (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_10'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_10'Address); end Rcheck_CE_Overflow_Check; procedure Rcheck_CE_Partition_Check (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_11'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_11'Address); end Rcheck_CE_Partition_Check; procedure Rcheck_CE_Range_Check (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_12'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_12'Address); end Rcheck_CE_Range_Check; procedure Rcheck_CE_Tag_Check (File : System.Address; Line : Integer) is begin - Raise_Constraint_Error_Msg (File, Line, Rmsg_13'Address); + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address); end Rcheck_CE_Tag_Check; procedure Rcheck_PE_Access_Before_Elaboration @@ -1341,6 +1377,13 @@ Raise_Program_Error_Msg (File, Line, Rmsg_26'Address); end Rcheck_PE_Missing_Return; + procedure Rcheck_PE_Non_Transportable_Actual + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_31'Address); + end Rcheck_PE_Non_Transportable_Actual; + procedure Rcheck_PE_Overlaid_Controlled_Object (File : System.Address; Line : Integer) is @@ -1355,6 +1398,13 @@ Raise_Program_Error_Msg (File, Line, Rmsg_28'Address); end Rcheck_PE_Potentially_Blocking_Operation; + procedure Rcheck_PE_Stream_Operation_Not_Allowed + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_36'Address); + end Rcheck_PE_Stream_Operation_Not_Allowed; + procedure Rcheck_PE_Stubbed_Subprogram_Called (File : System.Address; Line : Integer) is @@ -1369,13 +1419,6 @@ Raise_Program_Error_Msg (File, Line, Rmsg_30'Address); end Rcheck_PE_Unchecked_Union_Restriction; - procedure Rcheck_PE_Non_Transportable_Actual - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_31'Address); - end Rcheck_PE_Non_Transportable_Actual; - procedure Rcheck_SE_Empty_Storage_Pool (File : System.Address; Line : Integer) is @@ -1404,116 +1447,79 @@ Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address); end Rcheck_SE_Object_Too_Large; - procedure Rcheck_PE_Stream_Operation_Not_Allowed - (File : System.Address; Line : Integer) + procedure Rcheck_CE_Access_Check_Ext + (File : System.Address; Line, Column : Integer) is begin - Raise_Program_Error_Msg (File, Line, Rmsg_36'Address); - end Rcheck_PE_Stream_Operation_Not_Allowed; + Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address); + end Rcheck_CE_Access_Check_Ext; + procedure Rcheck_CE_Index_Check_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer) + is + Msg : constant String := + Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF + & "index " & Image (Index) & " not in " & Image (First) + & ".." & Image (Last) & ASCII.NUL; + begin + Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); + end Rcheck_CE_Index_Check_Ext; + + procedure Rcheck_CE_Invalid_Data_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer) + is + Msg : constant String := + Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF + & "value " & Image (Index) & " not in " & Image (First) + & ".." & Image (Last) & ASCII.NUL; + begin + Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); + end Rcheck_CE_Invalid_Data_Ext; + + procedure Rcheck_CE_Range_Check_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer) + is + Msg : constant String := + Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF + & "value " & Image (Index) & " not in " & Image (First) + & ".." & Image (Last) & ASCII.NUL; + begin + Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); + end Rcheck_CE_Range_Check_Ext; + procedure Rcheck_PE_Finalize_Raised_Exception (File : System.Address; Line : Integer) is - E : constant Exception_Id := Program_Error_Def'Access; - Excep : constant EOA := Get_Current_Excep.all; + X : constant EOA := Exception_Propagation.Allocate_Occurrence; begin -- This is "finalize/adjust raised exception". This subprogram is always - -- called with abort deferred, unlike all other Rcheck_* subprograms, - -- itneeds to call Raise_Exception_No_Defer. + -- called with abort deferred, unlike all other Rcheck_* subprograms, it + -- needs to call Raise_Exception_No_Defer. -- This is consistent with Raise_From_Controlled_Operation - Exception_Data.Set_Exception_C_Msg (Excep, E, File, Line, 0, - Rmsg_23'Address); - Raise_Current_Excep (E); + Exception_Data.Set_Exception_C_Msg + (X, Program_Error_Def'Access, File, Line, 0, Rmsg_23'Address); + Complete_And_Propagate_Occurrence (X); end Rcheck_PE_Finalize_Raised_Exception; - procedure Rcheck_00 (File : System.Address; Line : Integer) - renames Rcheck_CE_Access_Check; - procedure Rcheck_01 (File : System.Address; Line : Integer) - renames Rcheck_CE_Null_Access_Parameter; - procedure Rcheck_02 (File : System.Address; Line : Integer) - renames Rcheck_CE_Discriminant_Check; - procedure Rcheck_03 (File : System.Address; Line : Integer) - renames Rcheck_CE_Divide_By_Zero; - procedure Rcheck_04 (File : System.Address; Line : Integer) - renames Rcheck_CE_Explicit_Raise; - procedure Rcheck_05 (File : System.Address; Line : Integer) - renames Rcheck_CE_Index_Check; - procedure Rcheck_06 (File : System.Address; Line : Integer) - renames Rcheck_CE_Invalid_Data; - procedure Rcheck_07 (File : System.Address; Line : Integer) - renames Rcheck_CE_Length_Check; - procedure Rcheck_08 (File : System.Address; Line : Integer) - renames Rcheck_CE_Null_Exception_Id; - procedure Rcheck_09 (File : System.Address; Line : Integer) - renames Rcheck_CE_Null_Not_Allowed; - procedure Rcheck_10 (File : System.Address; Line : Integer) - renames Rcheck_CE_Overflow_Check; - procedure Rcheck_11 (File : System.Address; Line : Integer) - renames Rcheck_CE_Partition_Check; - procedure Rcheck_12 (File : System.Address; Line : Integer) - renames Rcheck_CE_Range_Check; - procedure Rcheck_13 (File : System.Address; Line : Integer) - renames Rcheck_CE_Tag_Check; - procedure Rcheck_14 (File : System.Address; Line : Integer) - renames Rcheck_PE_Access_Before_Elaboration; - procedure Rcheck_15 (File : System.Address; Line : Integer) - renames Rcheck_PE_Accessibility_Check; - 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_19 (File : System.Address; Line : Integer) - renames Rcheck_PE_Bad_Predicated_Generic_Type; - procedure Rcheck_20 (File : System.Address; Line : Integer) - 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_Finalize_Raised_Exception; - procedure Rcheck_24 (File : System.Address; Line : Integer) - renames Rcheck_PE_Implicit_Return; - procedure Rcheck_25 (File : System.Address; Line : Integer) - renames Rcheck_PE_Misaligned_Address_Value; - procedure Rcheck_26 (File : System.Address; Line : Integer) - renames Rcheck_PE_Missing_Return; - procedure Rcheck_27 (File : System.Address; Line : Integer) - renames Rcheck_PE_Overlaid_Controlled_Object; - procedure Rcheck_28 (File : System.Address; Line : Integer) - renames Rcheck_PE_Potentially_Blocking_Operation; - procedure Rcheck_29 (File : System.Address; Line : Integer) - renames Rcheck_PE_Stubbed_Subprogram_Called; - procedure Rcheck_30 (File : System.Address; Line : Integer) - renames Rcheck_PE_Unchecked_Union_Restriction; - procedure Rcheck_31 (File : System.Address; Line : Integer) - renames Rcheck_PE_Non_Transportable_Actual; - procedure Rcheck_32 (File : System.Address; Line : Integer) - renames Rcheck_SE_Empty_Storage_Pool; - procedure Rcheck_33 (File : System.Address; Line : Integer) - 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_36 (File : System.Address; Line : Integer) - renames Rcheck_PE_Stream_Operation_Not_Allowed; - ------------- -- Reraise -- ------------- procedure Reraise is - Excep : constant EOA := Get_Current_Excep.all; + Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; + Saved_MO : constant System.Address := Excep.Machine_Occurrence; begin - Abort_Defer.all; - Raise_Current_Excep (Excep.Id); + if not ZCX_By_Default then + Abort_Defer.all; + end if; + + Save_Occurrence (Excep.all, Get_Current_Excep.all.all); + Excep.Machine_Occurrence := Saved_MO; + Complete_And_Propagate_Occurrence (Excep); end Reraise; -------------------------------------- @@ -1522,10 +1528,18 @@ procedure Reraise_Library_Exception_If_Any is LE : Exception_Occurrence; + begin if Library_Exception_Set then LE := Library_Exception; - Raise_From_Controlled_Operation (LE); + + if LE.Id = Null_Id then + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => "finalize/adjust raised exception"); + else + Raise_From_Controlled_Operation (LE); + end if; end if; end Reraise_Library_Exception_If_Any; @@ -1535,10 +1549,10 @@ procedure Reraise_Occurrence (X : Exception_Occurrence) is begin - if X.Id /= null then - Abort_Defer.all; - Save_Occurrence (Get_Current_Excep.all.all, X); - Raise_Current_Excep (X.Id); + if X.Id = null then + return; + else + Reraise_Occurrence_Always (X); end if; end Reraise_Occurrence; @@ -1548,9 +1562,11 @@ procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is begin - Abort_Defer.all; - Save_Occurrence (Get_Current_Excep.all.all, X); - Raise_Current_Excep (X.Id); + if not ZCX_By_Default then + Abort_Defer.all; + end if; + + Reraise_Occurrence_No_Defer (X); end Reraise_Occurrence_Always; --------------------------------- @@ -1558,9 +1574,12 @@ --------------------------------- procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is + Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; + Saved_MO : constant System.Address := Excep.Machine_Occurrence; begin - Save_Occurrence (Get_Current_Excep.all.all, X); - Raise_Current_Excep (X.Id); + Save_Occurrence (Excep.all, X); + Excep.Machine_Occurrence := Saved_MO; + Complete_And_Propagate_Occurrence (Excep); end Reraise_Occurrence_No_Defer; --------------------- @@ -1572,11 +1591,15 @@ Source : Exception_Occurrence) is begin - Target.Id := Source.Id; - Target.Msg_Length := Source.Msg_Length; - Target.Num_Tracebacks := Source.Num_Tracebacks; - Target.Pid := Source.Pid; + -- As the machine occurrence might be a data that must be finalized + -- (outside any Ada mechanism), do not copy it + Target.Id := Source.Id; + Target.Machine_Occurrence := System.Null_Address; + Target.Msg_Length := Source.Msg_Length; + Target.Num_Tracebacks := Source.Num_Tracebacks; + Target.Pid := Source.Pid; + Target.Msg (1 .. Target.Msg_Length) := Source.Msg (1 .. Target.Msg_Length); @@ -1610,13 +1633,10 @@ --------------- procedure To_Stderr (C : Character) is - type int is new Integer; - - procedure put_char_stderr (C : int); - pragma Import (C, put_char_stderr, "put_char_stderr"); - + procedure Put_Char_Stderr (C : Character); + pragma Import (C, Put_Char_Stderr, "put_char_stderr"); begin - put_char_stderr (Character'Pos (C)); + Put_Char_Stderr (C); end To_Stderr; procedure To_Stderr (S : String) is @@ -1651,4 +1671,78 @@ and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity; end Triggered_By_Abort; + ------------------------- + -- Wide_Exception_Name -- + ------------------------- + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Encoding method for source, as exported by binder + + function Wide_Exception_Name + (Id : Exception_Id) return Wide_String + is + S : constant String := Exception_Name (Id); + W : Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Exception_Name; + + function Wide_Exception_Name + (X : Exception_Occurrence) return Wide_String + is + S : constant String := Exception_Name (X); + W : Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Exception_Name; + + ---------------------------- + -- Wide_Wide_Exception_Name -- + ----------------------------- + + function Wide_Wide_Exception_Name + (Id : Exception_Id) return Wide_Wide_String + is + S : constant String := Exception_Name (Id); + W : Wide_Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Wide_Exception_Name; + + function Wide_Wide_Exception_Name + (X : Exception_Occurrence) return Wide_Wide_String + is + S : constant String := Exception_Name (X); + W : Wide_Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Wide_Exception_Name; + + -------------------------- + -- Code_Address_For_ZZZ -- + -------------------------- + + -- This function gives us the end of the PC range for addresses + -- within the exception unit itself. We hope that gigi/gcc keeps all the + -- procedures in their original order. + + function Code_Address_For_ZZZ return System.Address is + begin + <> + return Start_Of_ZZZ'Address; + end Code_Address_For_ZZZ; + end Ada.Exceptions; Index: a-except.ads =================================================================== --- a-except.ads (revision 247293) +++ a-except.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -33,24 +33,15 @@ -- -- ------------------------------------------------------------------------------ --- This version of Ada.Exceptions is used only for building the compiler --- and certain basic tools. The "real" version of Ada.Exceptions is in --- a-except-2005.ads/adb, and is used for all other builds where full Ada --- functionality is required. In particular, it is used for building run --- times on all targets. +-- This version of Ada.Exceptions fully supports Ada 95 and later language +-- versions. It is used in all situations except for the build of the +-- compiler and other basic tools. For these latter builds, we use an +-- Ada 95-only version. --- This version is limited to Ada 95 features. It omits Ada 2005 features --- such as the additional definitions of Exception_Name returning --- Wide_[Wide_]String. It differs from the version specified in the Ada 95 RM --- only in that it is declared Preelaborate (see declaration below for why --- this is done). - -- The reason for this splitting off of a separate version is to support -- older bootstrap compilers that do not support Ada 2005 features, and -- Ada.Exceptions is part of the compiler sources. -pragma Compiler_Unit_Warning; - pragma Polling (Off); -- We must turn polling off for this unit, because otherwise we get -- elaboration circularities with ourself. @@ -62,26 +53,40 @@ package Ada.Exceptions is pragma Preelaborate; - -- We make this preelaborable. If we did not do this, then run time units - -- used by the compiler (e.g. s-soflin.ads) would run into trouble. - -- Conformance with Ada 95 is not an issue, since this version is used - -- only by the compiler. + -- In accordance with Ada 2005 AI-362. type Exception_Id is private; + pragma Preelaborable_Initialization (Exception_Id); Null_Id : constant Exception_Id; type Exception_Occurrence is limited private; + pragma Preelaborable_Initialization (Exception_Occurrence); type Exception_Occurrence_Access is access all Exception_Occurrence; Null_Occurrence : constant Exception_Occurrence; + function Exception_Name (Id : Exception_Id) return String; + function Exception_Name (X : Exception_Occurrence) return String; - -- Same as Exception_Name (Exception_Identity (X)) - function Exception_Name (Id : Exception_Id) return String; + function Wide_Exception_Name + (Id : Exception_Id) return Wide_String; + pragma Ada_05 (Wide_Exception_Name); + function Wide_Exception_Name + (X : Exception_Occurrence) return Wide_String; + pragma Ada_05 (Wide_Exception_Name); + + function Wide_Wide_Exception_Name + (Id : Exception_Id) return Wide_Wide_String; + pragma Ada_05 (Wide_Wide_Exception_Name); + + function Wide_Wide_Exception_Name + (X : Exception_Occurrence) return Wide_Wide_String; + pragma Ada_05 (Wide_Wide_Exception_Name); + procedure Raise_Exception (E : Exception_Id; Message : String := ""); pragma No_Return (Raise_Exception); -- Note: In accordance with AI-466, CE is raised if E = Null_Id @@ -105,7 +110,9 @@ -- 0xyyyyyyyy 0xyyyyyyyy ... -- -- The lines are separated by a ASCII.LF character - -- The nnnn is the partition Id given as decimal digits. + -- + -- The nnnn is the partition Id given as decimal digits + -- -- The 0x... line represents traceback program counter locations, -- in order with the first one being the exception location. @@ -121,6 +128,22 @@ (Source : Exception_Occurrence) return Exception_Occurrence_Access; + -- Ada 2005 (AI-438): The language revision introduces the following + -- subprograms and attribute definitions. We do not provide them + -- explicitly. instead, the corresponding stream attributes are made + -- available through a pragma Stream_Convert in the private part. + + -- procedure Read_Exception_Occurrence + -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + -- Item : out Exception_Occurrence); + + -- procedure Write_Exception_Occurrence + -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + -- Item : Exception_Occurrence); + + -- for Exception_Occurrence'Read use Read_Exception_Occurrence; + -- for Exception_Occurrence'Write use Write_Exception_Occurrence; + private package SSL renames System.Standard_Library; package SP renames System.Parameters; @@ -216,8 +239,8 @@ pragma No_Return (Reraise_Occurrence_No_Defer); -- Exactly like Reraise_Occurrence, except that abort is not deferred -- before the call and the parameter X is known not to be the null - -- occurrence. This is used in generated code when it is known that - -- abort is already deferred. + -- occurrence. This is used in generated code when it is known that abort + -- is already deferred. function Triggered_By_Abort return Boolean; -- Determine whether the current exception (if it exists) is an instance of @@ -264,6 +287,10 @@ Id : Exception_Id; -- Exception_Identity for this exception occurrence + Machine_Occurrence : System.Address; + -- The underlying machine occurrence. For GCC, this corresponds to the + -- _Unwind_Exception structure address. + Msg_Length : Natural := 0; -- Length of message (zero = no message) @@ -295,18 +322,28 @@ -- this, and it would not work right, because of the Msg and Tracebacks -- fields which have unused entries not copied by Save_Occurrence. + function Get_Exception_Machine_Occurrence + (X : Exception_Occurrence) return System.Address; + pragma Export (Ada, Get_Exception_Machine_Occurrence, + "__gnat_get_exception_machine_occurrence"); + -- Get the machine occurrence corresponding to an exception occurrence. + -- It is Null_Address if there is no machine occurrence (in runtimes that + -- doesn't use GCC mechanism) or if it has been lost (Save_Occurrence + -- doesn't save the machine occurrence). + function EO_To_String (X : Exception_Occurrence) return String; function String_To_EO (S : String) return Exception_Occurrence; pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String); -- Functions for implementing Exception_Occurrence stream attributes Null_Occurrence : constant Exception_Occurrence := ( - Id => null, - Msg_Length => 0, - Msg => (others => ' '), - Exception_Raised => False, - Pid => 0, - Num_Tracebacks => 0, - Tracebacks => (others => TBE.Null_TB_Entry)); + Id => null, + Machine_Occurrence => System.Null_Address, + Msg_Length => 0, + Msg => (others => ' '), + Exception_Raised => False, + Pid => 0, + Num_Tracebacks => 0, + Tracebacks => (others => TBE.Null_TB_Entry)); end Ada.Exceptions; Index: a-except-2005.ads =================================================================== --- a-except-2005.ads (revision 247293) +++ a-except-2005.ads (working copy) @@ -1,349 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X C E P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version of Ada.Exceptions fully supports Ada 95 and later language --- versions. It is used in all situations except for the build of the --- compiler and other basic tools. For these latter builds, we use an --- Ada 95-only version. - --- The reason for this splitting off of a separate version is to support --- older bootstrap compilers that do not support Ada 2005 features, and --- Ada.Exceptions is part of the compiler sources. - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with ourself. - -with System; -with System.Parameters; -with System.Standard_Library; -with System.Traceback_Entries; - -package Ada.Exceptions is - pragma Preelaborate; - -- In accordance with Ada 2005 AI-362. - - type Exception_Id is private; - pragma Preelaborable_Initialization (Exception_Id); - - Null_Id : constant Exception_Id; - - type Exception_Occurrence is limited private; - pragma Preelaborable_Initialization (Exception_Occurrence); - - type Exception_Occurrence_Access is access all Exception_Occurrence; - - Null_Occurrence : constant Exception_Occurrence; - - function Exception_Name (Id : Exception_Id) return String; - - function Exception_Name (X : Exception_Occurrence) return String; - - function Wide_Exception_Name - (Id : Exception_Id) return Wide_String; - pragma Ada_05 (Wide_Exception_Name); - - function Wide_Exception_Name - (X : Exception_Occurrence) return Wide_String; - pragma Ada_05 (Wide_Exception_Name); - - function Wide_Wide_Exception_Name - (Id : Exception_Id) return Wide_Wide_String; - pragma Ada_05 (Wide_Wide_Exception_Name); - - function Wide_Wide_Exception_Name - (X : Exception_Occurrence) return Wide_Wide_String; - pragma Ada_05 (Wide_Wide_Exception_Name); - - procedure Raise_Exception (E : Exception_Id; Message : String := ""); - pragma No_Return (Raise_Exception); - -- Note: In accordance with AI-466, CE is raised if E = Null_Id - - function Exception_Message (X : Exception_Occurrence) return String; - - procedure Reraise_Occurrence (X : Exception_Occurrence); - -- Note: it would be really nice to give a pragma No_Return for this - -- procedure, but it would be wrong, since Reraise_Occurrence does return - -- if the argument is the null exception occurrence. See also procedure - -- Reraise_Occurrence_Always in the private part of this package. - - function Exception_Identity (X : Exception_Occurrence) return Exception_Id; - - function Exception_Information (X : Exception_Occurrence) return String; - -- The format of the exception information is as follows: - -- - -- exception name (as in Exception_Name) - -- message (or a null line if no message) - -- PID=nnnn - -- 0xyyyyyyyy 0xyyyyyyyy ... - -- - -- The lines are separated by a ASCII.LF character - -- - -- The nnnn is the partition Id given as decimal digits - -- - -- The 0x... line represents traceback program counter locations, - -- in order with the first one being the exception location. - - -- Note on ordering: the compiler uses the Save_Occurrence procedure, but - -- not the function from Rtsfind, so it is important that the procedure - -- come first, since Rtsfind finds the first matching entity. - - procedure Save_Occurrence - (Target : out Exception_Occurrence; - Source : Exception_Occurrence); - - function Save_Occurrence - (Source : Exception_Occurrence) - return Exception_Occurrence_Access; - - -- Ada 2005 (AI-438): The language revision introduces the following - -- subprograms and attribute definitions. We do not provide them - -- explicitly. instead, the corresponding stream attributes are made - -- available through a pragma Stream_Convert in the private part. - - -- procedure Read_Exception_Occurrence - -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - -- Item : out Exception_Occurrence); - - -- procedure Write_Exception_Occurrence - -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - -- Item : Exception_Occurrence); - - -- for Exception_Occurrence'Read use Read_Exception_Occurrence; - -- for Exception_Occurrence'Write use Write_Exception_Occurrence; - -private - package SSL renames System.Standard_Library; - package SP renames System.Parameters; - - subtype EOA is Exception_Occurrence_Access; - - Exception_Msg_Max_Length : constant := SP.Default_Exception_Msg_Max_Length; - - ------------------ - -- Exception_Id -- - ------------------ - - subtype Code_Loc is System.Address; - -- Code location used in building exception tables and for call addresses - -- when propagating an exception. Values of this type are created by using - -- Label'Address or extracted from machine states using Get_Code_Loc. - - Null_Loc : constant Code_Loc := System.Null_Address; - -- Null code location, used to flag outer level frame - - type Exception_Id is new SSL.Exception_Data_Ptr; - - function EId_To_String (X : Exception_Id) return String; - function String_To_EId (S : String) return Exception_Id; - pragma Stream_Convert (Exception_Id, String_To_EId, EId_To_String); - -- Functions for implementing Exception_Id stream attributes - - Null_Id : constant Exception_Id := null; - - ------------------------- - -- Private Subprograms -- - ------------------------- - - function Exception_Name_Simple (X : Exception_Occurrence) return String; - -- Like Exception_Name, but returns the simple non-qualified name of the - -- exception. This is used to implement the Exception_Name function in - -- Current_Exceptions (the DEC compatible unit). It is called from the - -- compiler generated code (using Rtsfind, which does not respect the - -- private barrier, so we can place this function in the private part - -- where the compiler can find it, but the spec is unchanged.) - - procedure Raise_Exception_Always (E : Exception_Id; Message : String := ""); - pragma No_Return (Raise_Exception_Always); - pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); - -- This differs from Raise_Exception only in that the caller has determined - -- that for sure the parameter E is not null, and that therefore no check - -- for Null_Id is required. The expander converts Raise_Exception calls to - -- Raise_Exception_Always if it can determine this is the case. The Export - -- allows this routine to be accessed from Pure units. - - procedure Raise_From_Signal_Handler - (E : Exception_Id; - M : System.Address); - pragma Export - (Ada, Raise_From_Signal_Handler, - "ada__exceptions__raise_from_signal_handler"); - pragma No_Return (Raise_From_Signal_Handler); - -- This routine is used to raise an exception from a signal handler. The - -- signal handler has already stored the machine state (i.e. the state that - -- corresponds to the location at which the signal was raised). E is the - -- Exception_Id specifying what exception is being raised, and M is a - -- pointer to a null-terminated string which is the message to be raised. - -- Note that this routine never returns, so it is permissible to simply - -- jump to this routine, rather than call it. This may be appropriate for - -- systems where the right way to get out of signal handler is to alter the - -- PC value in the machine state or in some other way ask the operating - -- system to return here rather than to the original location. - - procedure Raise_From_Controlled_Operation - (X : Ada.Exceptions.Exception_Occurrence); - pragma No_Return (Raise_From_Controlled_Operation); - pragma Export - (Ada, Raise_From_Controlled_Operation, - "__gnat_raise_from_controlled_operation"); - -- Raise Program_Error, providing information about X (an exception raised - -- during a controlled operation) in the exception message. - - procedure Reraise_Library_Exception_If_Any; - pragma Export - (Ada, Reraise_Library_Exception_If_Any, - "__gnat_reraise_library_exception_if_any"); - -- If there was an exception raised during library-level finalization, - -- reraise the exception. - - procedure Reraise_Occurrence_Always (X : Exception_Occurrence); - pragma No_Return (Reraise_Occurrence_Always); - -- This differs from Raise_Occurrence only in that the caller guarantees - -- that for sure the parameter X is not the null occurrence, and that - -- therefore this procedure cannot return. The expander uses this routine - -- in the translation of a raise statement with no parameter (reraise). - - procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence); - pragma No_Return (Reraise_Occurrence_No_Defer); - -- Exactly like Reraise_Occurrence, except that abort is not deferred - -- before the call and the parameter X is known not to be the null - -- occurrence. This is used in generated code when it is known that abort - -- is already deferred. - - function Triggered_By_Abort return Boolean; - -- Determine whether the current exception (if it exists) is an instance of - -- Standard'Abort_Signal. - - ----------------------- - -- Polling Interface -- - ----------------------- - - -- The GNAT compiler has an option to generate polling calls to the Poll - -- routine in this package. Specifying the -gnatP option for a compilation - -- causes a call to Ada.Exceptions.Poll to be generated on every subprogram - -- entry and on every iteration of a loop, thus avoiding the possibility of - -- a case of unbounded time between calls. - - -- This polling interface may be used for instrumentation or debugging - -- purposes (e.g. implementing watchpoints in software or in the debugger). - - -- In the GNAT technology itself, this interface is used to implement - -- immediate asynchronous transfer of control and immediate abort on - -- targets which do not provide for one thread interrupting another. - - -- Note: this used to be in a separate unit called System.Poll, but that - -- caused horrible circular elaboration problems between System.Poll and - -- Ada.Exceptions. - - procedure Poll; - -- Check for asynchronous abort. Note that we do not inline the body. - -- This makes the interface more useful for debugging purposes. - - -------------------------- - -- Exception_Occurrence -- - -------------------------- - - package TBE renames System.Traceback_Entries; - - Max_Tracebacks : constant := 50; - -- Maximum number of trace backs stored in exception occurrence - - subtype Tracebacks_Array is TBE.Tracebacks_Array (1 .. Max_Tracebacks); - -- Traceback array stored in exception occurrence - - type Exception_Occurrence is record - Id : Exception_Id; - -- Exception_Identity for this exception occurrence - - Machine_Occurrence : System.Address; - -- The underlying machine occurrence. For GCC, this corresponds to the - -- _Unwind_Exception structure address. - - Msg_Length : Natural := 0; - -- Length of message (zero = no message) - - Msg : String (1 .. Exception_Msg_Max_Length); - -- Characters of message - - Exception_Raised : Boolean := False; - -- Set to true to indicate that this exception occurrence has actually - -- been raised. When an exception occurrence is first created, this is - -- set to False, then when it is processed by Raise_Current_Exception, - -- it is set to True. If Raise_Current_Exception is used to raise an - -- exception for which this flag is already True, then it knows that - -- it is dealing with the reraise case (which is useful to distinguish - -- for exception tracing purposes). - - Pid : Natural := 0; - -- Partition_Id for partition raising exception - - Num_Tracebacks : Natural range 0 .. Max_Tracebacks := 0; - -- Number of traceback entries stored - - Tracebacks : Tracebacks_Array; - -- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks)) - end record; - - function "=" (Left, Right : Exception_Occurrence) return Boolean - is abstract; - -- Don't allow comparison on exception occurrences, we should not need - -- this, and it would not work right, because of the Msg and Tracebacks - -- fields which have unused entries not copied by Save_Occurrence. - - function Get_Exception_Machine_Occurrence - (X : Exception_Occurrence) return System.Address; - pragma Export (Ada, Get_Exception_Machine_Occurrence, - "__gnat_get_exception_machine_occurrence"); - -- Get the machine occurrence corresponding to an exception occurrence. - -- It is Null_Address if there is no machine occurrence (in runtimes that - -- doesn't use GCC mechanism) or if it has been lost (Save_Occurrence - -- doesn't save the machine occurrence). - - function EO_To_String (X : Exception_Occurrence) return String; - function String_To_EO (S : String) return Exception_Occurrence; - pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String); - -- Functions for implementing Exception_Occurrence stream attributes - - Null_Occurrence : constant Exception_Occurrence := ( - Id => null, - Machine_Occurrence => System.Null_Address, - Msg_Length => 0, - Msg => (others => ' '), - Exception_Raised => False, - Pid => 0, - Num_Tracebacks => 0, - Tracebacks => (others => TBE.Null_TB_Entry)); - -end Ada.Exceptions; Index: a-except-2005.adb =================================================================== --- a-except-2005.adb (revision 247293) +++ a-except-2005.adb (working copy) @@ -1,1748 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- A D A . E X C E P T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Style_Checks (All_Checks); --- No subprogram ordering check, due to logical grouping - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with System.Exception_Tables. - -with System; use System; -with System.Exceptions; use System.Exceptions; -with System.Exceptions_Debug; use System.Exceptions_Debug; -with System.Standard_Library; use System.Standard_Library; -with System.Soft_Links; use System.Soft_Links; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_StW; use System.WCh_StW; - -pragma Warnings (Off); --- Suppress complaints about Symbolic not being referenced, and about it not --- having pragma Preelaborate. -with System.Traceback.Symbolic; --- Bring Symbolic into the closure. If it is the s-trasym-dwarf.adb version, --- it will install symbolic tracebacks as the default decorator. Otherwise, --- symbolic tracebacks are not supported, and we fall back to hexadecimal --- addresses. -pragma Warnings (On); - -package body Ada.Exceptions is - - pragma Suppress (All_Checks); - -- We definitely do not want exceptions occurring within this unit, or - -- we are in big trouble. If an exceptional situation does occur, better - -- that it not be raised, since raising it can cause confusing chaos. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- Note: the exported subprograms in this package body are called directly - -- from C clients using the given external name, even though they are not - -- technically visible in the Ada sense. - - function Code_Address_For_AAA return System.Address; - function Code_Address_For_ZZZ return System.Address; - -- Return start and end of procedures in this package - -- - -- These procedures are used to provide exclusion bounds in - -- calls to Call_Chain at exception raise points from this unit. The - -- purpose is to arrange for the exception tracebacks not to include - -- frames from subprograms involved in the raise process, as these are - -- meaningless from the user's standpoint. - -- - -- For these bounds to be meaningful, we need to ensure that the object - -- code for the subprograms involved in processing a raise is located - -- after the object code Code_Address_For_AAA and before the object - -- code Code_Address_For_ZZZ. This will indeed be the case as long as - -- the following rules are respected: - -- - -- 1) The bodies of the subprograms involved in processing a raise - -- are located after the body of Code_Address_For_AAA and before the - -- body of Code_Address_For_ZZZ. - -- - -- 2) No pragma Inline applies to any of these subprograms, as this - -- could delay the corresponding assembly output until the end of - -- the unit. - - procedure Call_Chain (Excep : EOA); - -- Store up to Max_Tracebacks in Excep, corresponding to the current - -- call chain. - - function Image (Index : Integer) return String; - -- Return string image corresponding to Index - - procedure To_Stderr (S : String); - pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); - -- Little routine to output string to stderr that is also used - -- in the tasking run time. - - procedure To_Stderr (C : Character); - pragma Inline (To_Stderr); - pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char"); - -- Little routine to output a character to stderr, used by some of - -- the separate units below. - - package Exception_Data is - - ----------------------------------- - -- Exception Message Subprograms -- - ----------------------------------- - - procedure Set_Exception_C_Msg - (Excep : EOA; - Id : Exception_Id; - Msg1 : System.Address; - Line : Integer := 0; - Column : Integer := 0; - Msg2 : System.Address := System.Null_Address); - -- This routine is called to setup the exception referenced by X - -- to contain the indicated Id value and message. Msg1 is a null - -- terminated string which is generated as the exception message. If - -- line is non-zero, then a colon and the decimal representation of - -- this integer is appended to the message. Ditto for Column. When Msg2 - -- is non-null, a space and this additional null terminated string is - -- added to the message. - - procedure Set_Exception_Msg - (Excep : EOA; - Id : Exception_Id; - Message : String); - -- This routine is called to setup the exception referenced by X - -- to contain the indicated Id value and message. Message is a string - -- which is generated as the exception message. - - --------------------------------------- - -- Exception Information Subprograms -- - --------------------------------------- - - function Untailored_Exception_Information - (X : Exception_Occurrence) return String; - -- This is used by Stream_Attributes.EO_To_String to convert an - -- Exception_Occurrence to a String for the stream attributes. - -- String_To_EO understands the format, as documented here. - -- - -- The format of the string is as follows: - -- - -- raised : - -- (" : " is present only if Exception_Message is not empty) - -- PID=nnnn (only if nonzero) - -- Call stack traceback locations: (only if at least one location) - -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded) - -- - -- The lines are separated by a ASCII.LF character. - -- The nnnn is the partition Id given as decimal digits. - -- The 0x... line represents traceback program counter locations, in - -- execution order with the first one being the exception location. - -- - -- The Exception_Name and Message lines are omitted in the abort - -- signal case, since this is not really an exception. - -- - -- Note: If the format of the generated string is changed, please note - -- that an equivalent modification to the routine String_To_EO must be - -- made to preserve proper functioning of the stream attributes. - - function Exception_Information (X : Exception_Occurrence) return String; - -- This is the implementation of Ada.Exceptions.Exception_Information, - -- as defined in the Ada RM. - -- - -- If no traceback decorator (see GNAT.Exception_Traces) is currently - -- in place, this is the same as Untailored_Exception_Information. - -- Otherwise, the decorator is used to produce a symbolic traceback - -- instead of hexadecimal addresses. - -- - -- Note that unlike Untailored_Exception_Information, there is no need - -- to keep the output of Exception_Information stable for streaming - -- purposes, and in fact the output differs across platforms. - - end Exception_Data; - - package Exception_Traces is - - ------------------------------------------------- - -- Run-Time Exception Notification Subprograms -- - ------------------------------------------------- - - -- These subprograms provide a common run-time interface to trigger the - -- actions required when an exception is about to be propagated (e.g. - -- user specified actions or output of exception information). They are - -- exported to be usable by the Ada exception handling personality - -- routine when the GCC 3 mechanism is used. - - procedure Notify_Handled_Exception (Excep : EOA); - pragma Export - (C, Notify_Handled_Exception, "__gnat_notify_handled_exception"); - -- This routine is called for a handled occurrence is about to be - -- propagated. - - procedure Notify_Unhandled_Exception (Excep : EOA); - pragma Export - (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception"); - -- This routine is called when an unhandled occurrence is about to be - -- propagated. - - procedure Unhandled_Exception_Terminate (Excep : EOA); - pragma No_Return (Unhandled_Exception_Terminate); - -- This procedure is called to terminate execution following an - -- unhandled exception. The exception information, including - -- traceback if available is output, and execution is then - -- terminated. Note that at the point where this routine is - -- called, the stack has typically been destroyed. - - end Exception_Traces; - - package Exception_Propagation is - - --------------------------------------- - -- Exception Propagation Subprograms -- - --------------------------------------- - - function Allocate_Occurrence return EOA; - -- Allocate an exception occurrence (as well as the machine occurrence) - - procedure Propagate_Exception (Excep : EOA); - pragma No_Return (Propagate_Exception); - -- This procedure propagates the exception represented by Excep - - end Exception_Propagation; - - package Stream_Attributes is - - ---------------------------------- - -- Stream Attribute Subprograms -- - ---------------------------------- - - function EId_To_String (X : Exception_Id) return String; - function String_To_EId (S : String) return Exception_Id; - -- Functions for implementing Exception_Id stream attributes - - function EO_To_String (X : Exception_Occurrence) return String; - function String_To_EO (S : String) return Exception_Occurrence; - -- Functions for implementing Exception_Occurrence stream - -- attributes - - end Stream_Attributes; - - procedure Complete_Occurrence (X : EOA); - -- Finish building the occurrence: save the call chain and notify the - -- debugger. - - procedure Complete_And_Propagate_Occurrence (X : EOA); - pragma No_Return (Complete_And_Propagate_Occurrence); - -- This is a simple wrapper to Complete_Occurrence and - -- Exception_Propagation.Propagate_Exception. - - function Create_Occurrence_From_Signal_Handler - (E : Exception_Id; - M : System.Address) return EOA; - -- Create and build an exception occurrence using exception id E and - -- nul-terminated message M. - - function Create_Machine_Occurrence_From_Signal_Handler - (E : Exception_Id; - M : System.Address) return System.Address; - pragma Export (C, Create_Machine_Occurrence_From_Signal_Handler, - "__gnat_create_machine_occurrence_from_signal_handler"); - -- Create and build an exception occurrence using exception id E and - -- nul-terminated message M. Return the machine occurrence. - - procedure Raise_Exception_No_Defer - (E : Exception_Id; - Message : String := ""); - pragma Export - (Ada, Raise_Exception_No_Defer, - "ada__exceptions__raise_exception_no_defer"); - pragma No_Return (Raise_Exception_No_Defer); - -- Similar to Raise_Exception, but with no abort deferral - - procedure Raise_With_Msg (E : Exception_Id); - pragma No_Return (Raise_With_Msg); - pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg"); - -- Raises an exception with given exception id value. A message - -- is associated with the raise, and has already been stored in the - -- exception occurrence referenced by the Current_Excep in the TSD. - -- Abort is deferred before the raise call. - - procedure Raise_With_Location_And_Msg - (E : Exception_Id; - F : System.Address; - L : Integer; - C : Integer := 0; - M : System.Address := System.Null_Address); - pragma No_Return (Raise_With_Location_And_Msg); - -- Raise an exception with given exception id value. A filename and line - -- number is associated with the raise and is stored in the exception - -- occurrence and in addition a column and a string message M may be - -- appended to this (if not null/0). - - procedure Raise_Constraint_Error (File : System.Address; Line : Integer); - pragma No_Return (Raise_Constraint_Error); - pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); - -- Raise constraint error with file:line information - - procedure Raise_Constraint_Error_Msg - (File : System.Address; - Line : Integer; - Column : Integer; - Msg : System.Address); - pragma No_Return (Raise_Constraint_Error_Msg); - pragma Export - (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg"); - -- Raise constraint error with file:line:col + msg information - - procedure Raise_Program_Error (File : System.Address; Line : Integer); - pragma No_Return (Raise_Program_Error); - pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error"); - -- Raise program error with file:line information - - procedure Raise_Program_Error_Msg - (File : System.Address; - Line : Integer; - Msg : System.Address); - pragma No_Return (Raise_Program_Error_Msg); - pragma Export - (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg"); - -- Raise program error with file:line + msg information - - procedure Raise_Storage_Error (File : System.Address; Line : Integer); - pragma No_Return (Raise_Storage_Error); - pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error"); - -- Raise storage error with file:line information - - procedure Raise_Storage_Error_Msg - (File : System.Address; - Line : Integer; - Msg : System.Address); - pragma No_Return (Raise_Storage_Error_Msg); - pragma Export - (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg"); - -- Raise storage error with file:line + reason msg information - - -- The exception raising process and the automatic tracing mechanism rely - -- on some careful use of flags attached to the exception occurrence. The - -- graph below illustrates the relations between the Raise_ subprograms - -- and identifies the points where basic flags such as Exception_Raised - -- are initialized. - - -- (i) signs indicate the flags initialization points. R stands for Raise, - -- W for With, and E for Exception. - - -- R_No_Msg R_E R_Pe R_Ce R_Se - -- | | | | | - -- +--+ +--+ +---+ | +---+ - -- | | | | | - -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc - -- | | | | - -- +------------+ | +-----------+ +--+ - -- | | | | - -- | | | Set_E_C_Msg(i) - -- | | | - -- Complete_And_Propagate_Occurrence - - procedure Reraise; - pragma No_Return (Reraise); - pragma Export (C, Reraise, "__gnat_reraise"); - -- Reraises the exception referenced by the Current_Excep field - -- of the TSD (all fields of this exception occurrence are set). - -- Abort is deferred before the reraise operation. Called from - -- System.Tasking.RendezVous.Exceptional_Complete_RendezVous - - procedure Transfer_Occurrence - (Target : Exception_Occurrence_Access; - Source : Exception_Occurrence); - pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); - -- Called from s-tasren.adb:Local_Complete_RendezVous and - -- s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from - -- Source as an exception to be propagated in the caller task. Target is - -- expected to be a pointer to the fixed TSD occurrence for this task. - - -------------------------------- - -- Run-Time Check Subprograms -- - -------------------------------- - - -- These subprograms raise a specific exception with a reason message - -- attached. The parameters are the file name and line number in each - -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name. - - procedure Rcheck_CE_Access_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Null_Access_Parameter - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Discriminant_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Divide_By_Zero - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Explicit_Raise - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Index_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Invalid_Data - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Length_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Null_Exception_Id - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Null_Not_Allowed - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Overflow_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Partition_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Range_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Tag_Check - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Access_Before_Elaboration - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Accessibility_Check - (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 - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Current_Task_In_Entry_Body - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Duplicated_Entry_Address - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Explicit_Raise - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Implicit_Return - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Misaligned_Address_Value - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Missing_Return - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Non_Transportable_Actual - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Overlaid_Controlled_Object - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Potentially_Blocking_Operation - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Stubbed_Subprogram_Called - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Unchecked_Union_Restriction - (File : System.Address; Line : Integer); - procedure Rcheck_SE_Empty_Storage_Pool - (File : System.Address; Line : Integer); - procedure Rcheck_SE_Explicit_Raise - (File : System.Address; Line : Integer); - procedure Rcheck_SE_Infinite_Recursion - (File : System.Address; Line : Integer); - procedure Rcheck_SE_Object_Too_Large - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Stream_Operation_Not_Allowed - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Access_Check_Ext - (File : System.Address; Line, Column : Integer); - procedure Rcheck_CE_Index_Check_Ext - (File : System.Address; Line, Column, Index, First, Last : Integer); - procedure Rcheck_CE_Invalid_Data_Ext - (File : System.Address; Line, Column, Index, First, Last : Integer); - procedure Rcheck_CE_Range_Check_Ext - (File : System.Address; Line, Column, Index, First, Last : Integer); - - procedure Rcheck_PE_Finalize_Raised_Exception - (File : System.Address; Line : Integer); - -- This routine is separated out because it has quite different behavior - -- from the others. This is the "finalize/adjust raised exception". This - -- subprogram is always called with abort deferred, unlike all other - -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer. - - pragma Export (C, Rcheck_CE_Access_Check, - "__gnat_rcheck_CE_Access_Check"); - pragma Export (C, Rcheck_CE_Null_Access_Parameter, - "__gnat_rcheck_CE_Null_Access_Parameter"); - pragma Export (C, Rcheck_CE_Discriminant_Check, - "__gnat_rcheck_CE_Discriminant_Check"); - pragma Export (C, Rcheck_CE_Divide_By_Zero, - "__gnat_rcheck_CE_Divide_By_Zero"); - pragma Export (C, Rcheck_CE_Explicit_Raise, - "__gnat_rcheck_CE_Explicit_Raise"); - pragma Export (C, Rcheck_CE_Index_Check, - "__gnat_rcheck_CE_Index_Check"); - pragma Export (C, Rcheck_CE_Invalid_Data, - "__gnat_rcheck_CE_Invalid_Data"); - pragma Export (C, Rcheck_CE_Length_Check, - "__gnat_rcheck_CE_Length_Check"); - pragma Export (C, Rcheck_CE_Null_Exception_Id, - "__gnat_rcheck_CE_Null_Exception_Id"); - pragma Export (C, Rcheck_CE_Null_Not_Allowed, - "__gnat_rcheck_CE_Null_Not_Allowed"); - pragma Export (C, Rcheck_CE_Overflow_Check, - "__gnat_rcheck_CE_Overflow_Check"); - pragma Export (C, Rcheck_CE_Partition_Check, - "__gnat_rcheck_CE_Partition_Check"); - pragma Export (C, Rcheck_CE_Range_Check, - "__gnat_rcheck_CE_Range_Check"); - pragma Export (C, Rcheck_CE_Tag_Check, - "__gnat_rcheck_CE_Tag_Check"); - pragma Export (C, Rcheck_PE_Access_Before_Elaboration, - "__gnat_rcheck_PE_Access_Before_Elaboration"); - pragma Export (C, Rcheck_PE_Accessibility_Check, - "__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, - "__gnat_rcheck_PE_Bad_Predicated_Generic_Type"); - pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body, - "__gnat_rcheck_PE_Current_Task_In_Entry_Body"); - pragma Export (C, Rcheck_PE_Duplicated_Entry_Address, - "__gnat_rcheck_PE_Duplicated_Entry_Address"); - pragma Export (C, Rcheck_PE_Explicit_Raise, - "__gnat_rcheck_PE_Explicit_Raise"); - pragma Export (C, Rcheck_PE_Finalize_Raised_Exception, - "__gnat_rcheck_PE_Finalize_Raised_Exception"); - pragma Export (C, Rcheck_PE_Implicit_Return, - "__gnat_rcheck_PE_Implicit_Return"); - pragma Export (C, Rcheck_PE_Misaligned_Address_Value, - "__gnat_rcheck_PE_Misaligned_Address_Value"); - pragma Export (C, Rcheck_PE_Missing_Return, - "__gnat_rcheck_PE_Missing_Return"); - pragma Export (C, Rcheck_PE_Non_Transportable_Actual, - "__gnat_rcheck_PE_Non_Transportable_Actual"); - pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object, - "__gnat_rcheck_PE_Overlaid_Controlled_Object"); - pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation, - "__gnat_rcheck_PE_Potentially_Blocking_Operation"); - pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed, - "__gnat_rcheck_PE_Stream_Operation_Not_Allowed"); - pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called, - "__gnat_rcheck_PE_Stubbed_Subprogram_Called"); - pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction, - "__gnat_rcheck_PE_Unchecked_Union_Restriction"); - pragma Export (C, Rcheck_SE_Empty_Storage_Pool, - "__gnat_rcheck_SE_Empty_Storage_Pool"); - pragma Export (C, Rcheck_SE_Explicit_Raise, - "__gnat_rcheck_SE_Explicit_Raise"); - pragma Export (C, Rcheck_SE_Infinite_Recursion, - "__gnat_rcheck_SE_Infinite_Recursion"); - pragma Export (C, Rcheck_SE_Object_Too_Large, - "__gnat_rcheck_SE_Object_Too_Large"); - - pragma Export (C, Rcheck_CE_Access_Check_Ext, - "__gnat_rcheck_CE_Access_Check_ext"); - pragma Export (C, Rcheck_CE_Index_Check_Ext, - "__gnat_rcheck_CE_Index_Check_ext"); - pragma Export (C, Rcheck_CE_Invalid_Data_Ext, - "__gnat_rcheck_CE_Invalid_Data_ext"); - pragma Export (C, Rcheck_CE_Range_Check_Ext, - "__gnat_rcheck_CE_Range_Check_ext"); - - -- None of these procedures ever returns (they raise an exception). By - -- using pragma No_Return, we ensure that any junk code after the call, - -- such as normal return epilogue stuff, can be eliminated). - - pragma No_Return (Rcheck_CE_Access_Check); - pragma No_Return (Rcheck_CE_Null_Access_Parameter); - pragma No_Return (Rcheck_CE_Discriminant_Check); - pragma No_Return (Rcheck_CE_Divide_By_Zero); - pragma No_Return (Rcheck_CE_Explicit_Raise); - pragma No_Return (Rcheck_CE_Index_Check); - pragma No_Return (Rcheck_CE_Invalid_Data); - pragma No_Return (Rcheck_CE_Length_Check); - pragma No_Return (Rcheck_CE_Null_Exception_Id); - pragma No_Return (Rcheck_CE_Null_Not_Allowed); - pragma No_Return (Rcheck_CE_Overflow_Check); - pragma No_Return (Rcheck_CE_Partition_Check); - pragma No_Return (Rcheck_CE_Range_Check); - pragma No_Return (Rcheck_CE_Tag_Check); - 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); - pragma No_Return (Rcheck_PE_Duplicated_Entry_Address); - pragma No_Return (Rcheck_PE_Explicit_Raise); - pragma No_Return (Rcheck_PE_Implicit_Return); - pragma No_Return (Rcheck_PE_Misaligned_Address_Value); - pragma No_Return (Rcheck_PE_Missing_Return); - pragma No_Return (Rcheck_PE_Non_Transportable_Actual); - pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object); - pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation); - pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed); - pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called); - pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction); - pragma No_Return (Rcheck_PE_Finalize_Raised_Exception); - pragma No_Return (Rcheck_SE_Empty_Storage_Pool); - pragma No_Return (Rcheck_SE_Explicit_Raise); - pragma No_Return (Rcheck_SE_Infinite_Recursion); - pragma No_Return (Rcheck_SE_Object_Too_Large); - - pragma No_Return (Rcheck_CE_Access_Check_Ext); - pragma No_Return (Rcheck_CE_Index_Check_Ext); - pragma No_Return (Rcheck_CE_Invalid_Data_Ext); - pragma No_Return (Rcheck_CE_Range_Check_Ext); - - --------------------------------------------- - -- Reason Strings for Run-Time Check Calls -- - --------------------------------------------- - - -- These strings are null-terminated and are used by Rcheck_nn. The - -- strings correspond to the definitions for Types.RT_Exception_Code. - - use ASCII; - - Rmsg_00 : constant String := "access check failed" & NUL; - Rmsg_01 : constant String := "access parameter is null" & NUL; - Rmsg_02 : constant String := "discriminant check failed" & NUL; - Rmsg_03 : constant String := "divide by zero" & NUL; - Rmsg_04 : constant String := "explicit raise" & NUL; - Rmsg_05 : constant String := "index check failed" & NUL; - Rmsg_06 : constant String := "invalid data" & NUL; - Rmsg_07 : constant String := "length check failed" & NUL; - Rmsg_08 : constant String := "null Exception_Id" & NUL; - Rmsg_09 : constant String := "null-exclusion check failed" & NUL; - Rmsg_10 : constant String := "overflow check failed" & NUL; - Rmsg_11 : constant String := "partition check failed" & NUL; - Rmsg_12 : constant String := "range check failed" & NUL; - Rmsg_13 : constant String := "tag check failed" & NUL; - Rmsg_14 : constant String := "access before elaboration" & NUL; - Rmsg_15 : constant String := "accessibility check failed" & NUL; - Rmsg_16 : constant String := "attempt to take address of" & - " intrinsic subprogram" & NUL; - 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_20 : constant String := "Current_Task referenced in entry" & - " body" & NUL; - 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_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; - Rmsg_36 : constant String := "stream operation not allowed" & NUL; - - ----------------------- - -- Polling Interface -- - ----------------------- - - type Unsigned is mod 2 ** 32; - - Counter : Unsigned := 0; - pragma Warnings (Off, Counter); - -- This counter is provided for convenience. It can be used in Poll to - -- perform periodic but not systematic operations. - - procedure Poll is separate; - -- The actual polling routine is separate, so that it can easily be - -- replaced with a target dependent version. - - -------------------------- - -- Code_Address_For_AAA -- - -------------------------- - - -- This function gives us the start of the PC range for addresses within - -- the exception unit itself. We hope that gigi/gcc keep all the procedures - -- in their original order. - - function Code_Address_For_AAA return System.Address is - begin - -- We are using a label instead of Code_Address_For_AAA'Address because - -- on some platforms the latter does not yield the address we want, but - -- the address of a stub or of a descriptor instead. This is the case at - -- least on PA-HPUX. - - <> - return Start_Of_AAA'Address; - end Code_Address_For_AAA; - - ---------------- - -- Call_Chain -- - ---------------- - - procedure Call_Chain (Excep : EOA) is separate; - -- The actual Call_Chain routine is separate, so that it can easily - -- be dummied out when no exception traceback information is needed. - - ------------------- - -- EId_To_String -- - ------------------- - - function EId_To_String (X : Exception_Id) return String - renames Stream_Attributes.EId_To_String; - - ------------------ - -- EO_To_String -- - ------------------ - - -- We use the null string to represent the null occurrence, otherwise we - -- output the Untailored_Exception_Information string for the occurrence. - - function EO_To_String (X : Exception_Occurrence) return String - renames Stream_Attributes.EO_To_String; - - ------------------------ - -- Exception_Identity -- - ------------------------ - - function Exception_Identity - (X : Exception_Occurrence) return Exception_Id - is - begin - -- Note that the following test used to be here for the original - -- Ada 95 semantics, but these were modified by AI-241 to require - -- returning Null_Id instead of raising Constraint_Error. - - -- if X.Id = Null_Id then - -- raise Constraint_Error; - -- end if; - - return X.Id; - end Exception_Identity; - - --------------------------- - -- Exception_Information -- - --------------------------- - - function Exception_Information (X : Exception_Occurrence) return String is - begin - if X.Id = Null_Id then - raise Constraint_Error; - else - return Exception_Data.Exception_Information (X); - end if; - end Exception_Information; - - ----------------------- - -- Exception_Message -- - ----------------------- - - function Exception_Message (X : Exception_Occurrence) return String is - begin - if X.Id = Null_Id then - raise Constraint_Error; - else - return X.Msg (1 .. X.Msg_Length); - end if; - end Exception_Message; - - -------------------- - -- Exception_Name -- - -------------------- - - function Exception_Name (Id : Exception_Id) return String is - begin - if Id = null then - raise Constraint_Error; - else - return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1); - end if; - end Exception_Name; - - function Exception_Name (X : Exception_Occurrence) return String is - begin - return Exception_Name (X.Id); - end Exception_Name; - - --------------------------- - -- Exception_Name_Simple -- - --------------------------- - - function Exception_Name_Simple (X : Exception_Occurrence) return String is - Name : constant String := Exception_Name (X); - P : Natural; - - begin - P := Name'Length; - while P > 1 loop - exit when Name (P - 1) = '.'; - P := P - 1; - end loop; - - -- Return result making sure lower bound is 1 - - declare - subtype Rname is String (1 .. Name'Length - P + 1); - begin - return Rname (Name (P .. Name'Length)); - end; - end Exception_Name_Simple; - - -------------------- - -- Exception_Data -- - -------------------- - - package body Exception_Data is separate; - -- This package can be easily dummied out if we do not want the basic - -- support for exception messages (such as in Ada 83). - - --------------------------- - -- Exception_Propagation -- - --------------------------- - - package body Exception_Propagation is separate; - -- Depending on the actual exception mechanism used (front-end or - -- back-end based), the implementation will differ, which is why this - -- package is separated. - - ---------------------- - -- Exception_Traces -- - ---------------------- - - package body Exception_Traces is separate; - -- Depending on the underlying support for IO the implementation will - -- differ. Moreover we would like to dummy out this package in case we - -- do not want any exception tracing support. This is why this package - -- is separated. - - -------------------------------------- - -- Get_Exception_Machine_Occurrence -- - -------------------------------------- - - function Get_Exception_Machine_Occurrence - (X : Exception_Occurrence) return System.Address - is - begin - return X.Machine_Occurrence; - end Get_Exception_Machine_Occurrence; - - ----------- - -- Image -- - ----------- - - function Image (Index : Integer) return String is - Result : constant String := Integer'Image (Index); - begin - if Result (1) = ' ' then - return Result (2 .. Result'Last); - else - return Result; - end if; - end Image; - - ----------------------- - -- Stream Attributes -- - ----------------------- - - package body Stream_Attributes is separate; - -- This package can be easily dummied out if we do not want the - -- support for streaming Exception_Ids and Exception_Occurrences. - - ---------------------------- - -- Raise_Constraint_Error -- - ---------------------------- - - procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is - begin - Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line); - end Raise_Constraint_Error; - - -------------------------------- - -- Raise_Constraint_Error_Msg -- - -------------------------------- - - procedure Raise_Constraint_Error_Msg - (File : System.Address; - Line : Integer; - Column : Integer; - Msg : System.Address) - is - begin - Raise_With_Location_And_Msg - (Constraint_Error_Def'Access, File, Line, Column, Msg); - end Raise_Constraint_Error_Msg; - - ------------------------- - -- Complete_Occurrence -- - ------------------------- - - procedure Complete_Occurrence (X : EOA) is - begin - -- Compute the backtrace for this occurrence if the corresponding - -- binder option has been set. Call_Chain takes care of the reraise - -- case. - - -- ??? Using Call_Chain here means we are going to walk up the stack - -- once only for backtracing purposes before doing it again for the - -- propagation per se. - - -- The first inspection is much lighter, though, as it only requires - -- partial unwinding of each frame. Additionally, although we could use - -- the personality routine to record the addresses while propagating, - -- this method has two drawbacks: - - -- 1) the trace is incomplete if the exception is handled since we - -- don't walk past the frame with the handler, - - -- and - - -- 2) we would miss the frames for which our personality routine is not - -- called, e.g. if C or C++ calls are on the way. - - Call_Chain (X); - - -- Notify the debugger - Debug_Raise_Exception - (E => SSL.Exception_Data_Ptr (X.Id), - Message => X.Msg (1 .. X.Msg_Length)); - end Complete_Occurrence; - - --------------------------------------- - -- Complete_And_Propagate_Occurrence -- - --------------------------------------- - - procedure Complete_And_Propagate_Occurrence (X : EOA) is - begin - Complete_Occurrence (X); - Exception_Propagation.Propagate_Exception (X); - end Complete_And_Propagate_Occurrence; - - --------------------- - -- Raise_Exception -- - --------------------- - - procedure Raise_Exception - (E : Exception_Id; - Message : String := "") - is - EF : Exception_Id := E; - begin - -- Raise CE if E = Null_ID (AI-446) - - if E = null then - EF := Constraint_Error'Identity; - end if; - - -- Go ahead and raise appropriate exception - - Raise_Exception_Always (EF, Message); - end Raise_Exception; - - ---------------------------- - -- Raise_Exception_Always -- - ---------------------------- - - procedure Raise_Exception_Always - (E : Exception_Id; - Message : String := "") - is - X : constant EOA := Exception_Propagation.Allocate_Occurrence; - - begin - Exception_Data.Set_Exception_Msg (X, E, Message); - - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Complete_And_Propagate_Occurrence (X); - end Raise_Exception_Always; - - ------------------------------ - -- Raise_Exception_No_Defer -- - ------------------------------ - - procedure Raise_Exception_No_Defer - (E : Exception_Id; - Message : String := "") - is - X : constant EOA := Exception_Propagation.Allocate_Occurrence; - - begin - Exception_Data.Set_Exception_Msg (X, E, Message); - - -- Do not call Abort_Defer.all, as specified by the spec - - Complete_And_Propagate_Occurrence (X); - end Raise_Exception_No_Defer; - - ------------------------------------- - -- Raise_From_Controlled_Operation -- - ------------------------------------- - - procedure Raise_From_Controlled_Operation - (X : Ada.Exceptions.Exception_Occurrence) - is - Prefix : constant String := "adjust/finalize raised "; - Orig_Msg : constant String := Exception_Message (X); - Orig_Prefix_Length : constant Natural := - Integer'Min (Prefix'Length, Orig_Msg'Length); - - Orig_Prefix : String renames - Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1); - - begin - -- Message already has the proper prefix, just re-raise - - if Orig_Prefix = Prefix then - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => Orig_Msg); - - else - declare - New_Msg : constant String := Prefix & Exception_Name (X); - - begin - -- No message present, just provide our own - - if Orig_Msg = "" then - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => New_Msg); - - -- Message present, add informational prefix - - else - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => New_Msg & ": " & Orig_Msg); - end if; - end; - end if; - end Raise_From_Controlled_Operation; - - ------------------------------------------- - -- Create_Occurrence_From_Signal_Handler -- - ------------------------------------------- - - function Create_Occurrence_From_Signal_Handler - (E : Exception_Id; - M : System.Address) return EOA - is - X : constant EOA := Exception_Propagation.Allocate_Occurrence; - - begin - Exception_Data.Set_Exception_C_Msg (X, E, M); - - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Complete_Occurrence (X); - return X; - end Create_Occurrence_From_Signal_Handler; - - --------------------------------------------------- - -- Create_Machine_Occurrence_From_Signal_Handler -- - --------------------------------------------------- - - function Create_Machine_Occurrence_From_Signal_Handler - (E : Exception_Id; - M : System.Address) return System.Address - is - begin - return Create_Occurrence_From_Signal_Handler (E, M).Machine_Occurrence; - end Create_Machine_Occurrence_From_Signal_Handler; - - ------------------------------- - -- Raise_From_Signal_Handler -- - ------------------------------- - - procedure Raise_From_Signal_Handler - (E : Exception_Id; - M : System.Address) - is - begin - Exception_Propagation.Propagate_Exception - (Create_Occurrence_From_Signal_Handler (E, M)); - end Raise_From_Signal_Handler; - - ------------------------- - -- Raise_Program_Error -- - ------------------------- - - procedure Raise_Program_Error - (File : System.Address; - Line : Integer) - is - begin - Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line); - end Raise_Program_Error; - - ----------------------------- - -- Raise_Program_Error_Msg -- - ----------------------------- - - procedure Raise_Program_Error_Msg - (File : System.Address; - Line : Integer; - Msg : System.Address) - is - begin - Raise_With_Location_And_Msg - (Program_Error_Def'Access, File, Line, M => Msg); - end Raise_Program_Error_Msg; - - ------------------------- - -- Raise_Storage_Error -- - ------------------------- - - procedure Raise_Storage_Error - (File : System.Address; - Line : Integer) - is - begin - Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line); - end Raise_Storage_Error; - - ----------------------------- - -- Raise_Storage_Error_Msg -- - ----------------------------- - - procedure Raise_Storage_Error_Msg - (File : System.Address; - Line : Integer; - Msg : System.Address) - is - begin - Raise_With_Location_And_Msg - (Storage_Error_Def'Access, File, Line, M => Msg); - end Raise_Storage_Error_Msg; - - --------------------------------- - -- Raise_With_Location_And_Msg -- - --------------------------------- - - procedure Raise_With_Location_And_Msg - (E : Exception_Id; - F : System.Address; - L : Integer; - C : Integer := 0; - M : System.Address := System.Null_Address) - is - X : constant EOA := Exception_Propagation.Allocate_Occurrence; - begin - Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M); - - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Complete_And_Propagate_Occurrence (X); - end Raise_With_Location_And_Msg; - - -------------------- - -- Raise_With_Msg -- - -------------------- - - procedure Raise_With_Msg (E : Exception_Id) is - Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; - Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; - begin - Excep.Exception_Raised := False; - Excep.Id := E; - Excep.Num_Tracebacks := 0; - Excep.Pid := Local_Partition_ID; - - -- Copy the message from the current exception - -- Change the interface to be called with an occurrence ??? - - Excep.Msg_Length := Ex.Msg_Length; - Excep.Msg (1 .. Excep.Msg_Length) := Ex.Msg (1 .. Ex.Msg_Length); - - -- The following is a common pattern, should be abstracted - -- into a procedure call ??? - - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Complete_And_Propagate_Occurrence (Excep); - end Raise_With_Msg; - - ----------------------------------------- - -- Calls to Run-Time Check Subprograms -- - ----------------------------------------- - - procedure Rcheck_CE_Access_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_00'Address); - end Rcheck_CE_Access_Check; - - procedure Rcheck_CE_Null_Access_Parameter - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_01'Address); - end Rcheck_CE_Null_Access_Parameter; - - procedure Rcheck_CE_Discriminant_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_02'Address); - end Rcheck_CE_Discriminant_Check; - - procedure Rcheck_CE_Divide_By_Zero - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_03'Address); - end Rcheck_CE_Divide_By_Zero; - - procedure Rcheck_CE_Explicit_Raise - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_04'Address); - end Rcheck_CE_Explicit_Raise; - - procedure Rcheck_CE_Index_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_05'Address); - end Rcheck_CE_Index_Check; - - procedure Rcheck_CE_Invalid_Data - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_06'Address); - end Rcheck_CE_Invalid_Data; - - procedure Rcheck_CE_Length_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_07'Address); - end Rcheck_CE_Length_Check; - - procedure Rcheck_CE_Null_Exception_Id - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_08'Address); - end Rcheck_CE_Null_Exception_Id; - - procedure Rcheck_CE_Null_Not_Allowed - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_09'Address); - end Rcheck_CE_Null_Not_Allowed; - - procedure Rcheck_CE_Overflow_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_10'Address); - end Rcheck_CE_Overflow_Check; - - procedure Rcheck_CE_Partition_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_11'Address); - end Rcheck_CE_Partition_Check; - - procedure Rcheck_CE_Range_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_12'Address); - end Rcheck_CE_Range_Check; - - procedure Rcheck_CE_Tag_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address); - end Rcheck_CE_Tag_Check; - - procedure Rcheck_PE_Access_Before_Elaboration - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_14'Address); - end Rcheck_PE_Access_Before_Elaboration; - - procedure Rcheck_PE_Accessibility_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_15'Address); - end Rcheck_PE_Accessibility_Check; - - procedure Rcheck_PE_Address_Of_Intrinsic - (File : System.Address; Line : Integer) - is - begin - 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_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_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_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_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_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_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_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_26'Address); - end Rcheck_PE_Missing_Return; - - procedure Rcheck_PE_Non_Transportable_Actual - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_31'Address); - end Rcheck_PE_Non_Transportable_Actual; - - procedure Rcheck_PE_Overlaid_Controlled_Object - (File : System.Address; Line : Integer) - is - begin - 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_28'Address); - end Rcheck_PE_Potentially_Blocking_Operation; - - procedure Rcheck_PE_Stream_Operation_Not_Allowed - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_36'Address); - end Rcheck_PE_Stream_Operation_Not_Allowed; - - procedure Rcheck_PE_Stubbed_Subprogram_Called - (File : System.Address; Line : Integer) - is - begin - 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_30'Address); - end Rcheck_PE_Unchecked_Union_Restriction; - - procedure Rcheck_SE_Empty_Storage_Pool - (File : System.Address; Line : Integer) - is - begin - 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_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_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_35'Address); - end Rcheck_SE_Object_Too_Large; - - procedure Rcheck_CE_Access_Check_Ext - (File : System.Address; Line, Column : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address); - end Rcheck_CE_Access_Check_Ext; - - procedure Rcheck_CE_Index_Check_Ext - (File : System.Address; Line, Column, Index, First, Last : Integer) - is - Msg : constant String := - Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF - & "index " & Image (Index) & " not in " & Image (First) - & ".." & Image (Last) & ASCII.NUL; - begin - Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); - end Rcheck_CE_Index_Check_Ext; - - procedure Rcheck_CE_Invalid_Data_Ext - (File : System.Address; Line, Column, Index, First, Last : Integer) - is - Msg : constant String := - Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF - & "value " & Image (Index) & " not in " & Image (First) - & ".." & Image (Last) & ASCII.NUL; - begin - Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); - end Rcheck_CE_Invalid_Data_Ext; - - procedure Rcheck_CE_Range_Check_Ext - (File : System.Address; Line, Column, Index, First, Last : Integer) - is - Msg : constant String := - Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF - & "value " & Image (Index) & " not in " & Image (First) - & ".." & Image (Last) & ASCII.NUL; - begin - Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); - end Rcheck_CE_Range_Check_Ext; - - procedure Rcheck_PE_Finalize_Raised_Exception - (File : System.Address; Line : Integer) - is - X : constant EOA := Exception_Propagation.Allocate_Occurrence; - - begin - -- This is "finalize/adjust raised exception". This subprogram is always - -- called with abort deferred, unlike all other Rcheck_* subprograms, it - -- needs to call Raise_Exception_No_Defer. - - -- This is consistent with Raise_From_Controlled_Operation - - Exception_Data.Set_Exception_C_Msg - (X, Program_Error_Def'Access, File, Line, 0, Rmsg_23'Address); - Complete_And_Propagate_Occurrence (X); - end Rcheck_PE_Finalize_Raised_Exception; - - ------------- - -- Reraise -- - ------------- - - procedure Reraise is - Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; - Saved_MO : constant System.Address := Excep.Machine_Occurrence; - - begin - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Save_Occurrence (Excep.all, Get_Current_Excep.all.all); - Excep.Machine_Occurrence := Saved_MO; - Complete_And_Propagate_Occurrence (Excep); - end Reraise; - - -------------------------------------- - -- Reraise_Library_Exception_If_Any -- - -------------------------------------- - - procedure Reraise_Library_Exception_If_Any is - LE : Exception_Occurrence; - - begin - if Library_Exception_Set then - LE := Library_Exception; - - if LE.Id = Null_Id then - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => "finalize/adjust raised exception"); - else - Raise_From_Controlled_Operation (LE); - end if; - end if; - end Reraise_Library_Exception_If_Any; - - ------------------------ - -- Reraise_Occurrence -- - ------------------------ - - procedure Reraise_Occurrence (X : Exception_Occurrence) is - begin - if X.Id = null then - return; - else - Reraise_Occurrence_Always (X); - end if; - end Reraise_Occurrence; - - ------------------------------- - -- Reraise_Occurrence_Always -- - ------------------------------- - - procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is - begin - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Reraise_Occurrence_No_Defer (X); - end Reraise_Occurrence_Always; - - --------------------------------- - -- Reraise_Occurrence_No_Defer -- - --------------------------------- - - procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is - Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; - Saved_MO : constant System.Address := Excep.Machine_Occurrence; - begin - Save_Occurrence (Excep.all, X); - Excep.Machine_Occurrence := Saved_MO; - Complete_And_Propagate_Occurrence (Excep); - end Reraise_Occurrence_No_Defer; - - --------------------- - -- Save_Occurrence -- - --------------------- - - procedure Save_Occurrence - (Target : out Exception_Occurrence; - Source : Exception_Occurrence) - is - begin - -- As the machine occurrence might be a data that must be finalized - -- (outside any Ada mechanism), do not copy it - - Target.Id := Source.Id; - Target.Machine_Occurrence := System.Null_Address; - Target.Msg_Length := Source.Msg_Length; - Target.Num_Tracebacks := Source.Num_Tracebacks; - Target.Pid := Source.Pid; - - Target.Msg (1 .. Target.Msg_Length) := - Source.Msg (1 .. Target.Msg_Length); - - Target.Tracebacks (1 .. Target.Num_Tracebacks) := - Source.Tracebacks (1 .. Target.Num_Tracebacks); - end Save_Occurrence; - - function Save_Occurrence (Source : Exception_Occurrence) return EOA is - Target : constant EOA := new Exception_Occurrence; - begin - Save_Occurrence (Target.all, Source); - return Target; - end Save_Occurrence; - - ------------------- - -- String_To_EId -- - ------------------- - - function String_To_EId (S : String) return Exception_Id - renames Stream_Attributes.String_To_EId; - - ------------------ - -- String_To_EO -- - ------------------ - - function String_To_EO (S : String) return Exception_Occurrence - renames Stream_Attributes.String_To_EO; - - --------------- - -- To_Stderr -- - --------------- - - procedure To_Stderr (C : Character) is - procedure Put_Char_Stderr (C : Character); - pragma Import (C, Put_Char_Stderr, "put_char_stderr"); - begin - Put_Char_Stderr (C); - end To_Stderr; - - procedure To_Stderr (S : String) is - begin - for J in S'Range loop - if S (J) /= ASCII.CR then - To_Stderr (S (J)); - end if; - end loop; - end To_Stderr; - - ------------------------- - -- Transfer_Occurrence -- - ------------------------- - - procedure Transfer_Occurrence - (Target : Exception_Occurrence_Access; - Source : Exception_Occurrence) - is - begin - Save_Occurrence (Target.all, Source); - end Transfer_Occurrence; - - ------------------------ - -- Triggered_By_Abort -- - ------------------------ - - function Triggered_By_Abort return Boolean is - Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; - begin - return Ex /= null - and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity; - end Triggered_By_Abort; - - ------------------------- - -- Wide_Exception_Name -- - ------------------------- - - WC_Encoding : Character; - pragma Import (C, WC_Encoding, "__gl_wc_encoding"); - -- Encoding method for source, as exported by binder - - function Wide_Exception_Name - (Id : Exception_Id) return Wide_String - is - S : constant String := Exception_Name (Id); - W : Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_String - (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); - return W (1 .. L); - end Wide_Exception_Name; - - function Wide_Exception_Name - (X : Exception_Occurrence) return Wide_String - is - S : constant String := Exception_Name (X); - W : Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_String - (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); - return W (1 .. L); - end Wide_Exception_Name; - - ---------------------------- - -- Wide_Wide_Exception_Name -- - ----------------------------- - - function Wide_Wide_Exception_Name - (Id : Exception_Id) return Wide_Wide_String - is - S : constant String := Exception_Name (Id); - W : Wide_Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_Wide_String - (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); - return W (1 .. L); - end Wide_Wide_Exception_Name; - - function Wide_Wide_Exception_Name - (X : Exception_Occurrence) return Wide_Wide_String - is - S : constant String := Exception_Name (X); - W : Wide_Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_Wide_String - (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); - return W (1 .. L); - end Wide_Wide_Exception_Name; - - -------------------------- - -- Code_Address_For_ZZZ -- - -------------------------- - - -- This function gives us the end of the PC range for addresses - -- within the exception unit itself. We hope that gigi/gcc keeps all the - -- procedures in their original order. - - function Code_Address_For_ZZZ return System.Address is - begin - <> - return Start_Of_ZZZ'Address; - end Code_Address_For_ZZZ; - -end Ada.Exceptions; Index: raise.c =================================================================== --- raise.c (revision 247293) +++ raise.c (working copy) @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2012, Free Software Foundation, Inc. * + * Copyright (C) 1992-2017, 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- * @@ -47,20 +47,6 @@ extern "C" { #endif -/* Wrapper to builtin_longjmp. This is for the compiler eh only, as the sjlj - runtime library interfaces directly to the intrinsic. We can't yet do - this for the compiler itself, because this capability relies on changes - made in April 2008 and we need to preserve the possibility to bootstrap - with an older base version. */ - -#if defined (IN_GCC) && !defined (IN_RTS) -void -_gnat_builtin_longjmp (void *ptr, int flag ATTRIBUTE_UNUSED) -{ - __builtin_longjmp (ptr, 1); -} -#endif - /* When an exception is raised for which no handler exists, the procedure Ada.Exceptions.Unhandled_Exception is called, which performs the call to adafinal to complete finalization, and then prints out the error messages @@ -84,6 +70,71 @@ __gnat_os_exit (1); } +#ifndef IN_RTS +int +__gnat_backtrace (void **array ATTRIBUTE_UNUSED, + int size ATTRIBUTE_UNUSED, + void *exclude_min ATTRIBUTE_UNUSED, + void *exclude_max ATTRIBUTE_UNUSED, + int skip_frames ATTRIBUTE_UNUSED) +{ + return 0; +} + +void +__gnat_eh_personality (void) +{ + abort (); +} + +void +__gnat_rcheck_04 (void) +{ + abort (); +} + +void +__gnat_rcheck_10 (void) +{ + abort (); +} + +void +__gnat_rcheck_19 (void) +{ + abort (); +} + +void +__gnat_rcheck_20 (void) +{ + abort (); +} + +void +__gnat_rcheck_21 (void) +{ + abort (); +} + +void +__gnat_rcheck_30 (void) +{ + abort (); +} + +void +__gnat_rcheck_31 (void) +{ + abort (); +} + +void +__gnat_rcheck_32 (void) +{ + abort (); +} +#endif #ifdef __cplusplus } #endif Index: raise-gcc.c =================================================================== --- raise-gcc.c (revision 247293) +++ raise-gcc.c (working copy) @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2016, Free Software Foundation, Inc. * + * Copyright (C) 1992-2017, 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- * @@ -32,10 +32,6 @@ /* Code related to the integration of the GCC mechanism for exception handling. */ -#ifndef IN_RTS -#error "RTS unit only" -#endif - #ifndef CERT #include "tconfig.h" #include "tsystem.h" @@ -45,9 +41,14 @@ #endif #include + +#ifdef __cplusplus +# include +#else typedef char bool; # define true 1 # define false 0 +#endif #include "raise.h" @@ -72,6 +73,10 @@ #include "unwind.h" +#ifdef __cplusplus +extern "C" { +#endif + typedef struct _Unwind_Context _Unwind_Context; typedef struct _Unwind_Exception _Unwind_Exception; @@ -79,7 +84,7 @@ __gnat_Unwind_RaiseException (_Unwind_Exception *); _Unwind_Reason_Code -__gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *); +__gnat_Unwind_ForcedUnwind (_Unwind_Exception *, _Unwind_Stop_Fn, void *); extern struct Exception_Occurrence *__gnat_setup_current_excep (_Unwind_Exception *); @@ -209,7 +214,7 @@ } static void ATTRIBUTE_PRINTF_2 -db (int db_code, char * msg_format, ...) +db (int db_code, const char * msg_format, ...) { if (db_accepted_codes () & db_code) { @@ -816,8 +821,8 @@ db (DB_CSITE, "c_site @ %p (+%p), len = %p, lpad @ %p (+%p)\n", - (void *)region->base + cs_start, (void *)cs_start, (void *)cs_len, - (void *)region->lp_base + cs_lp, (void *)cs_lp); + (char *)region->base + cs_start, (void *)cs_start, (void *)cs_len, + (char *)region->lp_base + cs_lp, (void *)cs_lp); /* The table is sorted, so if we've passed the IP, stop. */ if (ip < region->base + cs_start) @@ -1399,7 +1404,7 @@ _Unwind_Reason_Code __gnat_Unwind_ForcedUnwind (_Unwind_Exception *e ATTRIBUTE_UNUSED, - void *handler ATTRIBUTE_UNUSED, + _Unwind_Stop_Fn handler ATTRIBUTE_UNUSED, void *argument ATTRIBUTE_UNUSED) { #ifdef __USING_SJLJ_EXCEPTIONS__ @@ -1609,3 +1614,7 @@ const int __gnat_unwind_exception_size = sizeof (_Unwind_Exception); #endif + +#ifdef __cplusplus +} +#endif Index: system.ads =================================================================== --- system.ads (revision 247293) +++ system.ads (working copy) @@ -7,7 +7,7 @@ -- S p e c -- -- (Compiler Version) -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -163,8 +163,8 @@ Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := True; - ZCX_By_Default : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; -- Obsolete entries, to be removed eventually (bootstrap issues) @@ -173,6 +173,6 @@ Long_Shifts_Inlined : constant Boolean := True; Functions_Return_By_DSP : constant Boolean := False; Support_64_Bit_Divides : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := True; end System; Index: gcc-interface/Makefile.in =================================================================== --- gcc-interface/Makefile.in (revision 247293) +++ gcc-interface/Makefile.in (working copy) @@ -2427,32 +2427,20 @@ ifeq ($(EH_MECHANISM),-gcc) LIBGNAT_TARGET_PAIRS += \ - a-exexpr.adb