Skip to content

R
riscv-gcc-1
Commit 800da977 by Arnaud Charlet
Options

[multiple changes] 

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.

From-SVN: r206817
parent 51b0e05a
Showing with 525 additions and 228 deletions
gcc/ada/ChangeLog
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.
......
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;
......
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:
......
gcc/ada/gcc-interface/Makefile.in
......@@ -637,10 +637,15 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(target_cpu) $(target_vendor)
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
......@@ -947,17 +952,47 @@ ifeq ($(strip $(filter-out arm% coff wrs vx%,$(target_cpu) $(target_vendor) $(ta
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
......@@ -2317,9 +2352,11 @@ ifeq ($(strip $(filter-out arm nucleus%,$(target_cpu) $(target_os))),)
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
......
gcc/ada/gnat1drv.adb
......@@ -289,6 +289,9 @@ procedure Gnat1drv is
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;
......
gcc/ada/raise-gcc.c
......@@ -878,6 +878,8 @@ exception_class_eq (const _GNAT_Exception *except, unsigned long long ec)
#endif
}
/* Return how CHOICE matches PROPAGATED_EXCEPTION. */
static enum action_kind
is_handled_by (_Unwind_Ptr choice, _GNAT_Exception *propagated_exception)
{
......@@ -937,7 +939,8 @@ 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
......@@ -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:
......
gcc/ada/s-excmac-arm.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-excmac-gcc.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
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);
......
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
......
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
......
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment