+2014-01-20 Robert Dewar <dewar@adacore.com>
+
+ * gnat1drv.adb: Minor comment update.
+
+2014-01-20 Tristan Gingold <gingold@adacore.com>
+
+ * raise-gcc.c (PERSONALITY_FUNCTION/arm): Remove unused
+ variables, comment out unused code.
+ * a-exexpr-gcc.adb: Move declarations to s-excmac-gcc.ads
+ * s-excmac-gcc.ads: New file, extracted from a-exexpr-gcc.adb
+ * s-excmac-arm.ads: New file.
+
+2014-01-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Slice): Remove constant D and variables
+ Drange and Index_Typ. Remove the circuitry which creates a
+ range check to compare the index type of the array against the
+ discrete_range.
+ * sem_res.adb (Resolve_Slice): Add local variable Dexpr. Update
+ the circuitry which creates a range check to handle a
+ discrete_range denoted by a subtype indication.
+
+2014-01-20 Pierre-Marie Derodat <derodat@adacore.com>
+
+ * sinput.adb, sinput.ads (Sloc_Range): Traverse the tree of original
+ nodes to get the original sloc range.
+
+2014-01-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Use Defining_Entity to obtain the
+ entity of a [library level] package.
+
2014-01-20 Tristan Gingold <gingold@adacore.com>
* raise-gcc.c (exception_class_eq): New function.
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;
- ------------------------------------------------
- -- Entities to interface with the GCC runtime --
- ------------------------------------------------
-
- -- These come from "C++ ABI for Itanium: Exception handling", which is the
- -- reference for GCC.
-
- -- Return codes from GCC runtime functions used to propagate an exception
-
- type Unwind_Reason_Code is
- (URC_NO_REASON,
- URC_FOREIGN_EXCEPTION_CAUGHT,
- URC_PHASE2_ERROR,
- URC_PHASE1_ERROR,
- URC_NORMAL_STOP,
- URC_END_OF_STACK,
- URC_HANDLER_FOUND,
- URC_INSTALL_CONTEXT,
- URC_CONTINUE_UNWIND);
-
- pragma Unreferenced
- (URC_NO_REASON,
- URC_FOREIGN_EXCEPTION_CAUGHT,
- URC_PHASE2_ERROR,
- URC_PHASE1_ERROR,
- URC_NORMAL_STOP,
- URC_END_OF_STACK,
- URC_HANDLER_FOUND,
- URC_INSTALL_CONTEXT,
- URC_CONTINUE_UNWIND);
-
- pragma Convention (C, Unwind_Reason_Code);
-
- -- Phase identifiers
-
- type Unwind_Action is new Integer;
- pragma Convention (C, Unwind_Action);
-
- UA_SEARCH_PHASE : constant Unwind_Action := 1;
- UA_CLEANUP_PHASE : constant Unwind_Action := 2;
- UA_HANDLER_FRAME : constant Unwind_Action := 4;
- UA_FORCE_UNWIND : constant Unwind_Action := 8;
- UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension
-
- pragma Unreferenced
- (UA_SEARCH_PHASE,
- UA_CLEANUP_PHASE,
- UA_HANDLER_FRAME,
- UA_FORCE_UNWIND,
- UA_END_OF_STACK);
-
- -- Mandatory common header for any exception object handled by the
- -- GCC unwinding runtime.
-
- type Exception_Class is mod 2 ** 64;
-
- GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
- -- "GNU-Ada\0"
-
- type Unwind_Word is mod 2 ** System.Word_Size;
- for Unwind_Word'Size use System.Word_Size;
- -- Map the corresponding C type used in Unwind_Exception below
-
- type Unwind_Exception is record
- Class : Exception_Class;
- Cleanup : System.Address;
- Private1 : Unwind_Word;
- Private2 : Unwind_Word;
-
- -- Usual exception structure has only two private fields, but the SEH
- -- one has six. To avoid making this file more complex, we use six
- -- fields on all platforms, wasting a few bytes on some.
-
- Private3 : Unwind_Word;
- Private4 : Unwind_Word;
- Private5 : Unwind_Word;
- Private6 : Unwind_Word;
- end record;
- pragma Convention (C, Unwind_Exception);
- -- Map the GCC struct used for exception handling
-
- for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
- -- The C++ ABI mandates the common exception header to be at least
- -- doubleword aligned, and the libGCC implementation actually makes it
- -- maximally aligned (see unwind.h). See additional comments on the
- -- alignment below.
-
- type GCC_Exception_Access is access all Unwind_Exception;
- -- Pointer to a GCC exception. Do not use convention C as on VMS this
- -- would imply the use of 32-bits pointers.
-
- procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access);
- pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
- -- Procedure to free any GCC exception
-
Foreign_Exception : aliased System.Standard_Library.Exception_Data;
pragma Import (Ada, Foreign_Exception,
"system__exceptions__foreign_exception");
-- GNAT Specific Entities To Deal With The GCC EH Circuitry --
--------------------------------------------------------------
- -- A GNAT exception object to be dealt with by the personality routine
- -- called by the GCC unwinding runtime.
-
- type GNAT_GCC_Exception is record
- Header : Unwind_Exception;
- -- ABI Exception header first
-
- Occurrence : aliased Exception_Occurrence;
- -- The Ada occurrence
- end record;
-
- pragma Convention (C, GNAT_GCC_Exception);
-
- -- There is a subtle issue with the common header alignment, since the C
- -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
- -- Standard'Maximum_Alignment, and those two values don't quite represent
- -- the same concepts and so may be decoupled someday. One typical reason
- -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system
- -- allocator guarantees, and there are extra costs involved in allocating
- -- objects aligned to such factors.
-
- -- To deal with the potential alignment differences between the C and Ada
- -- representations, the Ada part of the whole structure is only accessed
- -- by the personality routine through the accessors declared below. Ada
- -- specific fields are thus always accessed through consistent layout, and
- -- we expect the actual alignment to always be large enough to avoid traps
- -- from the C accesses to the common header. Besides, accessors alleviate
- -- the need for a C struct whole counterpart, both painful and error-prone
- -- to maintain anyway.
-
- type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
-
- function To_GCC_Exception is new
- Unchecked_Conversion (System.Address, GCC_Exception_Access);
-
- function To_GNAT_GCC_Exception is new
- Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access);
-
procedure GNAT_GCC_Exception_Cleanup
(Reason : Unwind_Reason_Code;
Excep : not null GNAT_GCC_Exception_Access);
Res : GNAT_GCC_Exception_Access;
begin
- Res :=
- new GNAT_GCC_Exception'
- (Header => (Class => GNAT_Exception_Class,
- Cleanup => GNAT_GCC_Exception_Cleanup'Address,
- others => 0),
- Occurrence => (others => <>));
+ Res := New_Occurrence;
+ Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address;
Res.Occurrence.Machine_Occurrence := Res.all'Address;
return Res.Occurrence'Access;
-- Local variables
- D : constant Node_Id := Discrete_Range (N);
- Pref : constant Node_Id := Prefix (N);
- Pref_Typ : Entity_Id := Etype (Pref);
- Drange : Node_Id;
- Index_Typ : Entity_Id;
+ Pref : constant Node_Id := Prefix (N);
+ Pref_Typ : Entity_Id := Etype (Pref);
-- Start of processing for Expand_N_Slice
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
end if;
- -- Find the range of the discrete_range. For ranges that do not appear
- -- in the slice itself, we make a shallow copy and inherit the source
- -- location and the parent field from the discrete_range. This ensures
- -- that the range check is inserted relative to the slice and that the
- -- runtime exception poins to the proper construct.
-
- if Nkind (D) = N_Range then
- Drange := D;
-
- elsif Nkind_In (D, N_Expanded_Name, N_Identifier) then
- Drange := New_Copy (Scalar_Range (Entity (D)));
- Set_Etype (Drange, Entity (D));
- Set_Parent (Drange, Parent (D));
- Set_Sloc (Drange, Sloc (D));
-
- else pragma Assert (Nkind (D) = N_Subtype_Indication);
- Drange := New_Copy (Range_Expression (Constraint (D)));
- Set_Etype (Drange, Etype (D));
- Set_Parent (Drange, Parent (D));
- Set_Sloc (Drange, Sloc (D));
- end if;
-
- -- Find the type of the array index
-
- if Ekind (Pref_Typ) = E_String_Literal_Subtype then
- Index_Typ := Etype (String_Literal_Low_Bound (Pref_Typ));
- else
- Index_Typ := Etype (First_Index (Pref_Typ));
- end if;
-
- -- Add a runtime check to test the compatibility between the array range
- -- and the discrete_range.
-
- Apply_Range_Check (Drange, Index_Typ);
-
-- The remaining case to be handled is packed slices. We can leave
-- packed slices as they are in the following situations:
s-vxwext.adb<s-vxwext-noints.adb \
s-vxwext.ads<s-vxwext-vthreads.ads \
s-vxwork.ads<s-vxwork-ppc.ads \
- system.ads<system-vxworks-ppc-vthread.ads \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
+ ifeq ($(strip $(filter-out e500%, $(arch))),)
+ LIBGNAT_TARGET_PAIRS += system.ads<system-vxworks-e500-vthread.ads
+ else
+ LIBGNAT_TARGET_PAIRS += system.ads<system-vxworks-ppc-vthread.ads
+ endif
+
TOOLS_TARGET_PAIRS=\
mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \
indepsw.adb<indepsw-gnu.adb
s-taprop.adb<s-taprop-vxworks.adb \
s-tasinf.ads<s-tasinf-vxworks.ads \
s-taspri.ads<s-taspri-vxworks.ads \
- s-tpopsp.adb<s-tpopsp-vxworks.adb \
s-vxwork.ads<s-vxwork-arm.ads \
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
- g-stsifd.adb<g-stsifd-sockets.adb \
- system.ads<system-vxworks-arm.ads
+ g-stsifd.adb<g-stsifd-sockets.adb
TOOLS_TARGET_PAIRS=\
mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \
indepsw.adb<indepsw-gnu.adb
+ ifeq ($(strip $(filter-out rtp-smp,$(THREAD_KIND))),)
+ LIBGNAT_TARGET_PAIRS += \
+ s-mudido.adb<s-mudido-affinity.adb \
+ s-vxwext.ads<s-vxwext-rtp.ads \
+ s-vxwext.adb<s-vxwext-rtp-smp.adb \
+ s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
+ system.ads<system-vxworks-arm-rtp.ads
+
+ EXTRA_LIBGNAT_OBJS+=affinity.o
+ else
+ ifeq ($(strip $(filter-out kernel-smp,$(THREAD_KIND))),)
+ LIBGNAT_TARGET_PAIRS += \
+ s-mudido.adb<s-mudido-affinity.adb \
+ s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
+ s-vxwext.ads<s-vxwext-kernel.ads \
+ s-vxwext.adb<s-vxwext-kernel-smp.adb \
+ system.ads<system-vxworks-arm.ads
+
+ EXTRA_LIBGNAT_OBJS+=affinity.o
+ else
+ LIBGNAT_TARGET_PAIRS += \
+ s-tpopsp.adb<s-tpopsp-vxworks.adb \
+ system.ads<system-vxworks-arm.ads
+
+ ifeq ($(strip $(filter-out kernel,$(THREAD_KIND))),)
+ LIBGNAT_TARGET_PAIRS += \
+ s-vxwext.ads<s-vxwext-kernel.ads \
+ s-vxwext.adb<s-vxwext-kernel.adb
+ endif
+ endif
+ endif
+
EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o
endif
ifeq ($(EH_MECHANISM),-gcc)
- LIBGNAT_TARGET_PAIRS += a-exexpr.adb<a-exexpr-gcc.adb
+ LIBGNAT_TARGET_PAIRS += \
+ a-exexpr.adb<a-exexpr-gcc.adb \
+ s-excmac.ads<s-excmac-gcc.ads
EXTRA_LIBGNAT_OBJS+=raise-gcc.o
- EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o
+ EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o
endif
# Use the Ada 2005 version of Ada.Exceptions by default, unless specified
Relaxed_RM_Semantics := True;
end if;
+ -- Enable some individual switches that are implied by relaxed RM
+ -- semantics mode.
+
if Relaxed_RM_Semantics then
Overriding_Renamings := True;
Treat_Categorization_Errors_As_Warnings := True;
#endif
}
+/* Return how CHOICE matches PROPAGATED_EXCEPTION. */
+
static enum action_kind
is_handled_by (_Unwind_Ptr choice, _GNAT_Exception *propagated_exception)
{
void *choice_typeinfo = Foreign_Data_For (choice);
void *except_typeinfo =
(((struct __cxa_exception *)
- ((_Unwind_Exception *)propagated_exception + 1)) - 1)->exceptionType;
+ ((_Unwind_Exception *)propagated_exception + 1)) - 1)
+ ->exceptionType;
/* Typeinfo are directly compared, which might not be correct if they
aren't merged. ??? We should call the == operator if this module is
else
{
const unsigned char * p = action->table_entry;
-
_sleb128_t ar_filter, ar_disp;
action->kind = nothing;
/* See if the filter we have is for an exception which
matches the one we are propagating. */
- _Unwind_Ptr choice = get_ttype_entry_for (region, ar_filter);
+ _Unwind_Ptr choice =
+ get_ttype_entry_for (region, ar_filter);
act = is_handled_by (choice, gnat_exception);
if (act != nothing)
#endif
/* Code executed to continue unwinding. With the ARM unwinder, the
- personality routine must unwind one frame. */
+ personality routine must unwind one frame (per EHABI 7.3 4.). */
static _Unwind_Reason_Code
continue_unwind (struct _Unwind_Exception* ue_header,
struct _Unwind_Context* uw_context)
{
_Unwind_Action uw_phases;
- region_descriptor region;
- action_descriptor action;
- _Unwind_Ptr ip;
switch (state & _US_ACTION_MASK)
{
break;
case _US_UNWIND_FRAME_STARTING:
+ /* Phase 2, to call a cleanup. */
uw_phases = _UA_CLEANUP_PHASE;
+#if 0
+ /* ??? We don't use UA_HANDLER_FRAME (except to debug). Futhermore,
+ barrier_cache.sp isn't yet set. */
if (!(state & _US_FORCE_UNWIND)
&& (uw_exception->barrier_cache.sp
== _Unwind_GetGR (uw_context, UNWIND_STACK_REG)))
uw_phases |= _UA_HANDLER_FRAME;
+#endif
break;
case _US_UNWIND_FRAME_RESUME:
+ /* Phase 2, called at the return of a cleanup. In the GNU
+ implementation, there is nothing left to do, so we simply go on. */
return continue_unwind (uw_exception, uw_context);
default:
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . E X C E P T I O N S . M A C H I N E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2013, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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 ARM EHABI mechanism
+
+with Ada.Unchecked_Conversion;
+with Ada.Exceptions;
+
+package System.Exceptions.Machine is
+ pragma Preelaborate;
+
+ ------------------------------------------------
+ -- Entities to interface with the GCC runtime --
+ ------------------------------------------------
+
+ -- Return codes from GCC runtime functions used to propagate an exception
+
+ type Unwind_Reason_Code is
+ (URC_OK,
+ URC_FOREIGN_EXCEPTION_CAUGHT,
+ URC_Unused2,
+ URC_Unused3,
+ URC_Unused4,
+ URC_Unused5,
+ URC_HANDLER_FOUND,
+ URC_INSTALL_CONTEXT,
+ URC_CONTINUE_UNWIND,
+ URC_FAILURE);
+
+ pragma Unreferenced
+ (URC_OK,
+ URC_FOREIGN_EXCEPTION_CAUGHT,
+ URC_Unused2,
+ URC_Unused3,
+ URC_Unused4,
+ URC_Unused5,
+ URC_HANDLER_FOUND,
+ URC_INSTALL_CONTEXT,
+ URC_CONTINUE_UNWIND,
+ URC_FAILURE);
+
+ pragma Convention (C, Unwind_Reason_Code);
+ subtype Unwind_Action is Unwind_Reason_Code;
+ -- Phase identifiers
+
+ type uint32_t is mod 2**32;
+ pragma Convention (C, uint32_t);
+
+ type uint32_t_array is array (Natural range <>) of uint32_t;
+ pragma Convention (C, uint32_t_array);
+
+ type Unwind_State is new uint32_t;
+ pragma Convention (C, Unwind_State);
+
+ US_VIRTUAL_UNWIND_FRAME : constant Unwind_State := 0;
+ US_UNWIND_FRAME_STARTING : constant Unwind_State := 1;
+ US_UNWIND_FRAME_RESUME : constant Unwind_State := 2;
+
+ pragma Unreferenced
+ (US_VIRTUAL_UNWIND_FRAME,
+ US_UNWIND_FRAME_STARTING,
+ US_UNWIND_FRAME_RESUME);
+
+ -- Mandatory common header for any exception object handled by the
+ -- GCC unwinding runtime.
+
+ type Exception_Class is array (0 .. 7) of Character;
+
+ GNAT_Exception_Class : constant Exception_Class := "GNU-Ada" & ASCII.NUL;
+ -- "GNU-Ada\0"
+
+ type Unwinder_Cache_Type is record
+ Reserved1 : uint32_t;
+ Reserved2 : uint32_t;
+ Reserved3 : uint32_t;
+ Reserved4 : uint32_t;
+ Reserved5 : uint32_t;
+ end record;
+
+ type Barrier_Cache_Type is record
+ Sp : uint32_t;
+ Bitpattern : uint32_t_array (0 .. 4);
+ end record;
+
+ type Cleanup_Cache_Type is record
+ Bitpattern : uint32_t_array (0 .. 3);
+ end record;
+
+ type Pr_Cache_Type is record
+ Fnstart : uint32_t;
+ Ehtp : System.Address;
+ Additional : uint32_t;
+ Reserved1 : uint32_t;
+ end record;
+
+ type Unwind_Control_Block is record
+ Class : Exception_Class;
+ Cleanup : System.Address;
+
+ -- Caches
+ Unwinder_Cache : Unwinder_Cache_Type;
+ Barrier_Cache : Barrier_Cache_Type;
+ Cleanup_Cache : Cleanup_Cache_Type;
+ Pr_Cache : Pr_Cache_Type;
+ end record;
+ pragma Convention (C, Unwind_Control_Block);
+ for Unwind_Control_Block'Alignment use 8;
+ -- Map the GCC struct used for exception handling
+
+ type Unwind_Control_Block_Access is access all Unwind_Control_Block;
+ subtype GCC_Exception_Access is Unwind_Control_Block_Access;
+ -- Pointer to a UCB
+
+ procedure Unwind_DeleteException
+ (Ucbp : not null Unwind_Control_Block_Access);
+ pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
+ -- Procedure to free any GCC exception
+
+ --------------------------------------------------------------
+ -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
+ --------------------------------------------------------------
+
+ -- A GNAT exception object to be dealt with by the personality routine
+ -- called by the GCC unwinding runtime.
+
+ type GNAT_GCC_Exception is record
+ Header : Unwind_Control_Block;
+ -- ABI Exception header first
+
+ Occurrence : aliased Ada.Exceptions.Exception_Occurrence;
+ -- The Ada occurrence
+ end record;
+
+ pragma Convention (C, GNAT_GCC_Exception);
+
+ type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
+
+ function To_GCC_Exception is new
+ Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access);
+
+ function To_GNAT_GCC_Exception is new
+ Ada.Unchecked_Conversion
+ (GCC_Exception_Access, GNAT_GCC_Exception_Access);
+
+ function New_Occurrence return GNAT_GCC_Exception_Access is
+ (new GNAT_GCC_Exception'
+ (Header => (Class => GNAT_Exception_Class,
+ Unwinder_Cache => (Reserved1 => 0,
+ others => <>),
+ others => <>),
+ Occurrence => <>));
+ -- Allocate and initialize a machine occurrence
+end System.Exceptions.Machine;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . E X C E P T I O N S . M A C H I N E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2013, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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.Exceptions;
+
+package System.Exceptions.Machine is
+ pragma Preelaborate;
+
+ ------------------------------------------------
+ -- Entities to interface with the GCC runtime --
+ ------------------------------------------------
+
+ -- These come from "C++ ABI for Itanium: Exception handling", which is
+ -- the reference for GCC.
+
+ -- Return codes from the GCC runtime functions used to propagate
+ -- an exception.
+
+ type Unwind_Reason_Code is
+ (URC_NO_REASON,
+ URC_FOREIGN_EXCEPTION_CAUGHT,
+ URC_PHASE2_ERROR,
+ URC_PHASE1_ERROR,
+ URC_NORMAL_STOP,
+ URC_END_OF_STACK,
+ URC_HANDLER_FOUND,
+ URC_INSTALL_CONTEXT,
+ URC_CONTINUE_UNWIND);
+
+ pragma Unreferenced
+ (URC_NO_REASON,
+ URC_FOREIGN_EXCEPTION_CAUGHT,
+ URC_PHASE2_ERROR,
+ URC_PHASE1_ERROR,
+ URC_NORMAL_STOP,
+ URC_END_OF_STACK,
+ URC_HANDLER_FOUND,
+ URC_INSTALL_CONTEXT,
+ URC_CONTINUE_UNWIND);
+
+ pragma Convention (C, Unwind_Reason_Code);
+
+ -- Phase identifiers
+
+ type Unwind_Action is new Integer;
+ pragma Convention (C, Unwind_Action);
+
+ UA_SEARCH_PHASE : constant Unwind_Action := 1;
+ UA_CLEANUP_PHASE : constant Unwind_Action := 2;
+ UA_HANDLER_FRAME : constant Unwind_Action := 4;
+ UA_FORCE_UNWIND : constant Unwind_Action := 8;
+ UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension
+
+ pragma Unreferenced
+ (UA_SEARCH_PHASE,
+ UA_CLEANUP_PHASE,
+ UA_HANDLER_FRAME,
+ UA_FORCE_UNWIND,
+ UA_END_OF_STACK);
+
+ -- Mandatory common header for any exception object handled by the
+ -- GCC unwinding runtime.
+
+ type Exception_Class is mod 2 ** 64;
+
+ GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
+ -- "GNU-Ada\0"
+
+ type Unwind_Word is mod 2 ** System.Word_Size;
+ for Unwind_Word'Size use System.Word_Size;
+ -- Map the corresponding C type used in Unwind_Exception below
+
+ type Unwind_Exception is record
+ Class : Exception_Class;
+ Cleanup : System.Address;
+ Private1 : Unwind_Word;
+ Private2 : Unwind_Word;
+
+ -- Usual exception structure has only two private fields, but the SEH
+ -- one has six. To avoid making this file more complex, we use six
+ -- fields on all platforms, wasting a few bytes on some.
+
+ Private3 : Unwind_Word;
+ Private4 : Unwind_Word;
+ Private5 : Unwind_Word;
+ Private6 : Unwind_Word;
+ end record;
+ pragma Convention (C, Unwind_Exception);
+ -- Map the GCC struct used for exception handling
+
+ for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
+ -- The C++ ABI mandates the common exception header to be at least
+ -- doubleword aligned, and the libGCC implementation actually makes it
+ -- maximally aligned (see unwind.h). See additional comments on the
+ -- alignment below.
+
+ -- There is a subtle issue with the common header alignment, since the C
+ -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
+ -- Standard'Maximum_Alignment, and those two values don't quite represent
+ -- the same concepts and so may be decoupled someday. One typical reason
+ -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system
+ -- allocator guarantees, and there are extra costs involved in allocating
+ -- objects aligned to such factors.
+
+ -- To deal with the potential alignment differences between the C and Ada
+ -- representations, the Ada part of the whole structure is only accessed
+ -- by the personality routine through accessors. Ada specific fields are
+ -- thus always accessed through consistent layout, and we expect the
+ -- actual alignment to always be large enough to avoid traps from the C
+ -- accesses to the common header. Besides, accessors alleviate the need
+ -- for a C struct whole counterpart, both painful and error-prone to
+ -- maintain anyway.
+
+ type GCC_Exception_Access is access all Unwind_Exception;
+ -- Pointer to a GCC exception. Do not use convention C as on VMS this
+ -- would imply the use of 32-bits pointers.
+
+ procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access);
+ pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
+ -- Procedure to free any GCC exception
+
+ --------------------------------------------------------------
+ -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
+ --------------------------------------------------------------
+
+ -- A GNAT exception object to be dealt with by the personality routine
+ -- called by the GCC unwinding runtime.
+
+ type GNAT_GCC_Exception is record
+ Header : Unwind_Exception;
+ -- ABI Exception header first
+
+ Occurrence : aliased Ada.Exceptions.Exception_Occurrence;
+ -- The Ada occurrence
+ end record;
+
+ pragma Convention (C, GNAT_GCC_Exception);
+
+ type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
+
+ function To_GCC_Exception is new
+ Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access);
+
+ function To_GNAT_GCC_Exception is new
+ Ada.Unchecked_Conversion
+ (GCC_Exception_Access, GNAT_GCC_Exception_Access);
+
+ function New_Occurrence return GNAT_GCC_Exception_Access is
+ (new GNAT_GCC_Exception'
+ (Header => (Class => GNAT_Exception_Class,
+ Cleanup => Null_Address,
+ others => 0),
+ Occurrence => <>));
+ -- Allocate and initialize a machine occurrence
+end System.Exceptions.Machine;
Context := Specification (Context);
end if;
- Body_Id := Defining_Unit_Name (Context);
+ Body_Id := Defining_Entity (Context);
Chain_Pragma (Body_Id, N);
Drange : constant Node_Id := Discrete_Range (N);
Name : constant Node_Id := Prefix (N);
Array_Type : Entity_Id := Empty;
+ Dexpr : Node_Id := Empty;
Index_Type : Entity_Id;
begin
Array_Type := Etype (Name);
end if;
+ -- Obtain the type of the array index
+
+ if Ekind (Array_Type) = E_String_Literal_Subtype then
+ Index_Type := Etype (String_Literal_Low_Bound (Array_Type));
+ else
+ Index_Type := Etype (First_Index (Array_Type));
+ end if;
+
-- If name was overloaded, set slice type correctly now
Set_Etype (N, Array_Type);
- -- If the range is specified by a subtype mark, no resolution is
- -- necessary. Else resolve the bounds, and apply needed checks.
+ -- Handle the generation of a range check that compares the array index
+ -- against the discrete_range. The check is not applied to internally
+ -- built nodes associated with the expansion of dispatch tables. Check
+ -- that Ada.Tags has already been loaded to avoid extra dependencies on
+ -- the unit.
+
+ if Tagged_Type_Expansion
+ and then RTU_Loaded (Ada_Tags)
+ and then Nkind (Prefix (N)) = N_Selected_Component
+ and then Present (Entity (Selector_Name (Prefix (N))))
+ and then Entity (Selector_Name (Prefix (N))) =
+ RTE_Record_Component (RE_Prims_Ptr)
+ then
+ null;
- if not Is_Entity_Name (Drange) then
- if Ekind (Array_Type) = E_String_Literal_Subtype then
- Index_Type := Etype (String_Literal_Low_Bound (Array_Type));
- else
- Index_Type := Etype (First_Index (Array_Type));
- end if;
+ -- The discrete_range is specified by a subtype indication. Create a
+ -- shallow copy and inherit the type, parent and source location from
+ -- the discrete_range. This ensures that the range check is inserted
+ -- relative to the slice and that the runtime exception points to the
+ -- proper construct.
- Resolve (Drange, Base_Type (Index_Type));
+ elsif Is_Entity_Name (Drange) then
+ Dexpr := New_Copy (Scalar_Range (Entity (Drange)));
- if Nkind (Drange) = N_Range then
+ Set_Etype (Dexpr, Etype (Drange));
+ Set_Parent (Dexpr, Parent (Drange));
+ Set_Sloc (Dexpr, Sloc (Drange));
- -- Ensure that side effects in the bounds are properly handled
+ -- The discrete_range is a regular range. Resolve the bounds and remove
+ -- their side effects.
- Force_Evaluation (Low_Bound (Drange));
+ else
+ Resolve (Drange, Base_Type (Index_Type));
+
+ if Nkind (Drange) = N_Range then
+ Force_Evaluation (Low_Bound (Drange));
Force_Evaluation (High_Bound (Drange));
- -- Do not apply the range check to nodes associated with the
- -- frontend expansion of the dispatch table. We first check
- -- if Ada.Tags is already loaded to avoid the addition of an
- -- undesired dependence on such run-time unit.
-
- if not Tagged_Type_Expansion
- or else not
- (RTU_Loaded (Ada_Tags)
- and then Nkind (Prefix (N)) = N_Selected_Component
- and then Present (Entity (Selector_Name (Prefix (N))))
- and then Entity (Selector_Name (Prefix (N))) =
- RTE_Record_Component (RE_Prims_Ptr))
- then
- Apply_Range_Check (Drange, Index_Type);
- end if;
+ Dexpr := Drange;
end if;
end if;
+ if Present (Dexpr) then
+ Apply_Range_Check (Dexpr, Index_Type);
+ end if;
+
Set_Slice_Subtype (N);
-- Check bad use of type with predicates
-------------
function Process (N : Node_Id) return Traverse_Result is
+ Orig : constant Node_Id := Original_Node (N);
begin
- if Sloc (N) < Min then
- if Sloc (N) > No_Location then
- Min := Sloc (N);
+ if Sloc (Orig) < Min then
+ if Sloc (Orig) > No_Location then
+ Min := Sloc (Orig);
end if;
- elsif Sloc (N) > Max then
- if Sloc (N) > No_Location then
- Max := Sloc (N);
+
+ elsif Sloc (Orig) > Max then
+ if Sloc (Orig) > No_Location then
+ Max := Sloc (Orig);
end if;
end if;
- return OK;
+ return OK_Orig;
end Process;
-- Start of processing for Sloc_Range
-- as the locations of the first and last token in the node construct
-- because parentheses at the outer level do not have a recorded Sloc.
--
+ -- Note: At each step of the tree traversal, we make sure to go back to
+ -- the Original_Node, since this function is concerned about original
+ -- (source) locations.
+ --
-- Note: if the tree for the expression contains no "real" Sloc values,
- -- i.e. values > No_Location, then both Min and Max are set to Sloc (Expr).
+ -- i.e. values > No_Location, then both Min and Max are set to
+ -- Sloc (Original_Node (N)).
function Source_Offset (S : Source_Ptr) return Nat;
-- Returns the zero-origin offset of the given source location from the
projects / gcc.git / commitdiff