From: Arnaud Charlet Date: Mon, 20 Jan 2014 15:13:01 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=800da97743ec985d0de0215afcf6bb44b7cd23c8;p=gcc.git [multiple changes] 2014-01-20 Robert Dewar * gnat1drv.adb: Minor comment update. 2014-01-20 Tristan Gingold * 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 * 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 * sinput.adb, sinput.ads (Sloc_Range): Traverse the tree of original nodes to get the original sloc range. 2014-01-20 Hristian Kirtchev * sem_prag.adb (Analyze_Pragma): Use Defining_Entity to obtain the entity of a [library level] package. From-SVN: r206817 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c5c209b02b1..760a627e966 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +2014-01-20 Robert Dewar + + * gnat1drv.adb: Minor comment update. + +2014-01-20 Tristan Gingold + + * 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 + + * 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 + + * sinput.adb, sinput.ads (Sloc_Range): Traverse the tree of original + nodes to get the original sloc range. + +2014-01-20 Hristian Kirtchev + + * sem_prag.adb (Analyze_Pragma): Use Defining_Entity to obtain the + entity of a [library level] package. + 2014-01-20 Tristan Gingold * raise-gcc.c (exception_class_eq): New function. diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb index a9d9e4b7733..fa8e9db8784 100644 --- a/gcc/ada/a-exexpr-gcc.adb +++ b/gcc/ada/a-exexpr-gcc.adb @@ -35,107 +35,13 @@ 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; - ------------------------------------------------ - -- 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"); @@ -145,44 +51,6 @@ package body Exception_Propagation is -- 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); @@ -317,12 +185,8 @@ package body Exception_Propagation is 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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index c8cded16399..f47406054af 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -9411,11 +9411,8 @@ package body Exp_Ch4 is -- 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 @@ -9441,41 +9438,6 @@ package body Exp_Ch4 is 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: diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 02f6cb2832d..9e808b54a60 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -637,10 +637,15 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(target_cpu) $(target_vendor) s-vxwext.adbexceptionType; + ((_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 @@ -995,7 +998,6 @@ get_action_description_for (_Unwind_Ptr ip, else { const unsigned char * p = action->table_entry; - _sleb128_t ar_filter, ar_disp; action->kind = nothing; @@ -1028,7 +1030,8 @@ get_action_description_for (_Unwind_Ptr ip, /* 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) @@ -1105,7 +1108,7 @@ extern void __gnat_notify_unhandled_exception (struct Exception_Occurrence *); #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, @@ -1294,9 +1297,6 @@ PERSONALITY_FUNCTION (_Unwind_State state, struct _Unwind_Context* uw_context) { _Unwind_Action uw_phases; - region_descriptor region; - action_descriptor action; - _Unwind_Ptr ip; switch (state & _US_ACTION_MASK) { @@ -1306,14 +1306,21 @@ PERSONALITY_FUNCTION (_Unwind_State state, 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: diff --git a/gcc/ada/s-excmac-arm.ads b/gcc/ada/s-excmac-arm.ads new file mode 100644 index 00000000000..44997e4c342 --- /dev/null +++ b/gcc/ada/s-excmac-arm.ads @@ -0,0 +1,181 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-excmac-gcc.ads b/gcc/ada/s-excmac-gcc.ads new file mode 100644 index 00000000000..80e4cef3f91 --- /dev/null +++ b/gcc/ada/s-excmac-gcc.ads @@ -0,0 +1,186 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 38dad254903..c0211433326 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -18142,7 +18142,7 @@ package body Sem_Prag is Context := Specification (Context); end if; - Body_Id := Defining_Unit_Name (Context); + Body_Id := Defining_Entity (Context); Chain_Pragma (Body_Id, N); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 9ebb0bc20dd..d99d94f76af 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9155,6 +9155,7 @@ package body Sem_Res is 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 @@ -9267,47 +9268,64 @@ package body Sem_Res is 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 diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index 7bd0a693470..78920da804c 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -770,18 +770,20 @@ package body Sinput is ------------- 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 diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index b5b2d747cc1..899bead7339 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -693,8 +693,13 @@ package Sinput is -- 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