git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

cstand.adb (Create_Standard): Change Import_Code component of Standard_Exception_Type to Foreign_Data. 

2013-10-14  Tristan Gingold  <gingold@adacore.com>

	* cstand.adb (Create_Standard): Change Import_Code component
	of Standard_Exception_Type to Foreign_Data. Its type is now
	Standard_A_Char (access to character).
	* exp_prag.adb (Expand_Pragma_Import_Export_Exception): Adjust
	definition of Code to match the type of Foreign_Data.
	* s-stalib.ads (Exception_Data): Replace Import_Code by Foreign_Data
	Change the definition of standard predefined exceptions.
	(Exception_Code): Remove.
	* raise.h (Exception_Code): Remove (Exception_Data): Replace
	Import_Code field by Foreign_Data.
	* rtsfind.ads (RE_Exception_Code): Remove
	(RE_Import_Address): Add.
	* a-exexpr-gcc.adb (Import_Code_For): Replaced by Foreign_Data_For.
	* exp_ch11.adb (Expand_N_Exception_Declaration): Associate null
	to Foreign_Data component.
	* raise-gcc.c (Import_Code_For): Replaced by Foreign_Data_For.
	(is_handled_by): Add comments. Use replaced function. Change
	condition so that an Ada occurrence is never handled by
	Foreign_Exception.
	* s-exctab.adb (Internal_Exception): Associate Null_Address to
	Foreign_Data component.
	* s-vmexta.adb, s-vmexta.ads (Exception_Code): Declare Replace
	SSL.Exception_Code by Exception_Code.

From-SVN: r203538
This commit is contained in:
Tristan Gingold 2013-10-14 13:06:44 +00:00 committed by Arnaud Charlet
parent 5a015f2bbd
commit e443f14204
12 changed files with 114 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
gcc/ada/ChangeLog
View File

@ -1,3 +1,29 @@
2013-10-14 Tristan Gingold <gingold@adacore.com>
* cstand.adb (Create_Standard): Change Import_Code component
of Standard_Exception_Type to Foreign_Data. Its type is now
Standard_A_Char (access to character).
* exp_prag.adb (Expand_Pragma_Import_Export_Exception): Adjust
definition of Code to match the type of Foreign_Data.
* s-stalib.ads (Exception_Data): Replace Import_Code by Foreign_Data
Change the definition of standard predefined exceptions.
(Exception_Code): Remove.
* raise.h (Exception_Code): Remove (Exception_Data): Replace
Import_Code field by Foreign_Data.
* rtsfind.ads (RE_Exception_Code): Remove
(RE_Import_Address): Add.
* a-exexpr-gcc.adb (Import_Code_For): Replaced by Foreign_Data_For.
* exp_ch11.adb (Expand_N_Exception_Declaration): Associate null
to Foreign_Data component.
* raise-gcc.c (Import_Code_For): Replaced by Foreign_Data_For.
(is_handled_by): Add comments. Use replaced function. Change
condition so that an Ada occurrence is never handled by
Foreign_Exception.
* s-exctab.adb (Internal_Exception): Associate Null_Address to
Foreign_Data component.
* s-vmexta.adb, s-vmexta.ads (Exception_Code): Declare Replace
SSL.Exception_Code by Exception_Code.
2013-10-14 Robert Dewar <dewar@adacore.com>
* gnat_ugn.texi: Document -gnateu switch.

20
gcc/ada/a-exexpr-gcc.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -270,8 +270,8 @@ package body Exception_Propagation is
function Language_For (E : Exception_Data_Ptr) return Character;
pragma Export (C, Language_For, "__gnat_language_for");
function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;
pragma Export (C, Import_Code_For, "__gnat_import_code_for");
function Foreign_Data_For (E : Exception_Data_Ptr) return Address;
pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for");
function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
return Exception_Id;
@ -489,16 +489,16 @@ package body Exception_Propagation is
return GNAT_Exception.Occurrence.Id;
end EID_For;
---------------------
-- Import_Code_For --
---------------------
----------------------
-- Foreign_Data_For --
----------------------
function Import_Code_For
(E : SSL.Exception_Data_Ptr) return Exception_Code
function Foreign_Data_For
(E : SSL.Exception_Data_Ptr) return Address
is
begin
return E.all.Import_Code;
end Import_Code_For;
return E.Foreign_Data;
end Foreign_Data_For;
--------------------------
-- Is_Handled_By_Others --

11
gcc/ada/cstand.adb
View File

@ -1470,14 +1470,7 @@ package body CStand is
end Build_Duration;
-- Build standard exception type. Note that the type name here is
-- actually used in the generated code, so it must be set correctly
-- ??? Also note that the Import_Code component is now declared
-- as a System.Standard_Library.Exception_Code to enforce run-time
-- library implementation consistency. It's too early here to resort
-- to rtsfind to get the proper node for that type, so we use the
-- closest possible available type node at hand instead. We should
-- probably be fixing this up at some point.
-- actually used in the generated code, so it must be set correctly.
Standard_Exception_Type := New_Standard_Entity;
Set_Ekind (Standard_Exception_Type, E_Record_Type);
@ -1501,7 +1494,7 @@ package body CStand is
Make_Component
(Standard_Exception_Type, Standard_A_Char, "HTable_Ptr");
Make_Component
(Standard_Exception_Type, Standard_Unsigned, "Import_Code");
(Standard_Exception_Type, Standard_A_Char, "Foreign_Data");
Make_Component
(Standard_Exception_Type, Standard_A_Char, "Raise_Hook");

6
gcc/ada/exp_ch11.adb
View File

@ -1172,7 +1172,7 @@ package body Exp_Ch11 is
-- Name_Length => exceptE'Length,
-- Full_Name => exceptE'Address,
-- HTable_Ptr => null,
-- Import_Code => 0,
-- Foreign_Data => null,
-- Raise_Hook => null,
-- );
@ -1319,9 +1319,9 @@ package body Exp_Ch11 is
Append_To (L, Make_Null (Loc));
-- Import_Code component: 0
-- Foreign_Data component: null
Append_To (L, Make_Integer_Literal (Loc, 0));
Append_To (L, Make_Null (Loc));
-- Raise_Hook component: null

22
gcc/ada/exp_prag.adb
View File

@ -646,8 +646,9 @@ package body Exp_Prag is
-- alias to define the symbol.
Code :=
Make_Integer_Literal (Loc,
Intval => Exception_Code (Id));
Unchecked_Convert_To (Standard_A_Char,
Make_Integer_Literal (Loc,
Intval => Exception_Code (Id)));
-- Declare a dummy object
@ -655,7 +656,7 @@ package body Exp_Prag is
Make_Object_Declaration (Loc,
Defining_Identifier => Excep_Internal,
Object_Definition =>
New_Reference_To (RTE (RE_Exception_Code), Loc));
New_Reference_To (RTE (RE_Address), Loc));
Insert_Action (N, Excep_Object);
Analyze (Excep_Object);
@ -711,13 +712,12 @@ package body Exp_Prag is
else
Code :=
Unchecked_Convert_To (RTE (RE_Exception_Code),
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Import_Value), Loc),
Parameter_Associations => New_List
(Make_String_Literal (Loc,
Strval => Excep_Image))));
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Import_Address), Loc),
Parameter_Associations => New_List
(Make_String_Literal (Loc,
Strval => Excep_Image)));
end if;
-- Generate the call to Register_VMS_Exception
@ -733,7 +733,7 @@ package body Exp_Prag is
Prefix => New_Occurrence_Of (Id, Loc),
Attribute_Name => Name_Unrestricted_Access)))));
Analyze_And_Resolve (Code, RTE (RE_Exception_Code));
Analyze_And_Resolve (Code, RTE (RE_Address));
Analyze (Call);
end if;

41
gcc/ada/raise-gcc.c
View File

@ -812,22 +812,32 @@ get_call_site_action_for (_Unwind_Ptr ip,
#define Is_Handled_By_Others __gnat_is_handled_by_others
#define Language_For __gnat_language_for
#define Import_Code_For __gnat_import_code_for
#define Foreign_Data_For __gnat_foreign_data_for
#define EID_For __gnat_eid_for
extern bool Is_Handled_By_Others (_Unwind_Ptr eid);
extern char Language_For (_Unwind_Ptr eid);
extern Exception_Code Import_Code_For (_Unwind_Ptr eid);
extern void *Foreign_Data_For (_Unwind_Ptr eid);
extern Exception_Id EID_For (_GNAT_Exception * e);
#define Foreign_Exception system__exceptions__foreign_exception
extern struct Exception_Data Foreign_Exception;
#ifdef VMS
#define Non_Ada_Error system__aux_dec__non_ada_error
extern struct Exception_Data Non_Ada_Error;
#endif
static enum action_kind
is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception)
{
/* All others choice match everything. */
if (choice == GNAT_ALL_OTHERS)
return handler;
/* GNAT exception occurrence. */
if (propagated_exception->common.exception_class == GNAT_EXCEPTION_CLASS)
{
/* Pointer to the GNAT exception data corresponding to the propagated
@ -845,6 +855,7 @@ is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception)
if (choice == E || (choice == GNAT_OTHERS && Is_Handled_By_Others (E)))
return handler;
#ifdef VMS
/* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we
may have different exception data pointers that should match for the
same condition code, if both an export and an import have been
@ -852,29 +863,25 @@ is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception)
occurrence are expected to have been masked off regarding severity
bits already (at registration time for the former and from within the
low level exception vector for the latter). */
#ifdef VMS
# define Non_Ada_Error system__aux_dec__non_ada_error
extern struct Exception_Data Non_Ada_Error;
if ((Language_For (E) == 'V'
&& choice != GNAT_OTHERS
&& ((Language_For (choice) == 'V'
&& Import_Code_For (choice) != 0
&& Import_Code_For (choice) == Import_Code_For (E))
&& Foreign_Data_For (choice) != 0
&& Foreign_Data_For (choice) == Foreign_Data_For (E))
|| choice == (_Unwind_Ptr)&Non_Ada_Error)))
return handler;
#endif
}
else
{
# define Foreign_Exception system__exceptions__foreign_exception
extern struct Exception_Data Foreign_Exception;
if (choice == GNAT_ALL_OTHERS
|| choice == GNAT_OTHERS
|| choice == (_Unwind_Ptr) &Foreign_Exception)
return handler;
/* Otherwise, it doesn't match an Ada choice. */
return nothing;
}
/* All others and others choice match any foreign exception. */
if (choice == GNAT_ALL_OTHERS
|| choice == GNAT_OTHERS
|| choice == (_Unwind_Ptr) &Foreign_Exception)
return handler;
return nothing;
}

9
gcc/ada/raise.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1992-2012, Free Software Foundation, Inc. *
* Copyright (C) 1992-2013, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@ -35,15 +35,14 @@ extern "C" {
/* C counterparts of what System.Standard_Library defines. */
typedef unsigned Exception_Code;
struct Exception_Data
{
char Not_Handled_By_Others;
char Lang;
int Name_Length;
char *Full_Name, *Htable_Ptr;
Exception_Code Import_Code;
char *Full_Name;
char *Htable_Ptr;
void *Foreign_Data;
void (*Raise_Hook)(void);
};

4
gcc/ada/rtsfind.ads
View File

@ -748,6 +748,7 @@ package Rtsfind is
RE_Uint64, -- System.Atomic_Primitives
RE_AST_Handler, -- System.Aux_DEC
RE_Import_Address, -- System.Aux_DEC
RE_Import_Value, -- System.Aux_DEC
RE_No_AST_Handler, -- System.Aux_DEC
RE_Type_Class, -- System.Aux_DEC
@ -1413,7 +1414,6 @@ package Rtsfind is
RE_Shared_Var_Procs, -- System.Shared_Storage
RE_Abort_Undefer_Direct, -- System.Standard_Library
RE_Exception_Code, -- System.Standard_Library
RE_Exception_Data_Ptr, -- System.Standard_Library
RE_Integer_Address, -- System.Storage_Elements
@ -2001,6 +2001,7 @@ package Rtsfind is
RE_Uint64 => System_Atomic_Primitives,
RE_AST_Handler => System_Aux_DEC,
RE_Import_Address => System_Aux_DEC,
RE_Import_Value => System_Aux_DEC,
RE_No_AST_Handler => System_Aux_DEC,
RE_Type_Class => System_Aux_DEC,
@ -2670,7 +2671,6 @@ package Rtsfind is
RE_Shared_Var_Procs => System_Shared_Storage,
RE_Abort_Undefer_Direct => System_Standard_Library,
RE_Exception_Code => System_Standard_Library,
RE_Exception_Data_Ptr => System_Standard_Library,
RE_Integer_Address => System_Storage_Elements,

4
gcc/ada/s-exctab.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1996-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- --
@ -180,7 +180,7 @@ package body System.Exception_Table is
Name_Length => Copy'Length,
Full_Name => Dyn_Copy.all'Address,
HTable_Ptr => null,
Import_Code => 0,
Foreign_Data => Null_Address,
Raise_Hook => null);
Register_Exception (Res);

36
gcc/ada/s-stalib.ads
View File

@ -85,20 +85,6 @@ package System.Standard_Library is
type Exception_Data_Ptr is access all Exception_Data;
-- An equivalent of Exception_Id that is public
type Exception_Code is mod 2 ** Integer'Size;
-- A scalar value bound to some exception data. Typically used for
-- imported or exported exceptions on VMS. Having a separate type for this
-- is useful to enforce consistency throughout the various run-time units
-- handling such codes, and having it unsigned is the most appropriate
-- choice for it's currently single use on VMS.
-- ??? The construction in Cstand has no way to access the proper type
-- node for Exception_Code, and currently uses Standard_Unsigned as a
-- fallback. The representations shall match, and the size clause below
-- is aimed at ensuring that.
for Exception_Code'Size use Integer'Size;
-- The following record defines the underlying representation of exceptions
-- WARNING! Any changes to this may need to be reflected in the following
@ -121,6 +107,7 @@ package System.Standard_Library is
-- A character indicating the language raising the exception.
-- Set to "A" for exceptions defined by an Ada program.
-- Set to "V" for imported VMS exceptions.
-- Set to "C" for imported C++ exceptions.
Name_Length : Natural;
-- Length of fully expanded name of exception
@ -134,11 +121,10 @@ package System.Standard_Library is
-- built (by Register_Exception in s-exctab.adb) for converting between
-- identities and names.
Import_Code : Exception_Code;
-- Value for imported exceptions. Needed only for the handling of
-- Import/Export_Exception for the VMS case, but present in all
-- implementations (we might well extend this mechanism for other
-- systems in the future).
Foreign_Data : Address;
-- Data for imported exceptions. This represents the exception code
-- for the handling of Import/Export_Exception for the VMS case.
-- This represents the address of the RTTI for the C++ case.
Raise_Hook : Raise_Action;
-- This field can be used to place a "hook" on an exception. If the
@ -169,7 +155,7 @@ package System.Standard_Library is
Name_Length => Constraint_Error_Name'Length,
Full_Name => Constraint_Error_Name'Address,
HTable_Ptr => null,
Import_Code => 0,
Foreign_Data => Null_Address,
Raise_Hook => null);
Numeric_Error_Def : aliased Exception_Data :=
@ -178,7 +164,7 @@ package System.Standard_Library is
Name_Length => Numeric_Error_Name'Length,
Full_Name => Numeric_Error_Name'Address,
HTable_Ptr => null,
Import_Code => 0,
Foreign_Data => Null_Address,
Raise_Hook => null);
Program_Error_Def : aliased Exception_Data :=
@ -187,7 +173,7 @@ package System.Standard_Library is
Name_Length => Program_Error_Name'Length,
Full_Name => Program_Error_Name'Address,
HTable_Ptr => null,
Import_Code => 0,
Foreign_Data => Null_Address,
Raise_Hook => null);
Storage_Error_Def : aliased Exception_Data :=
@ -196,7 +182,7 @@ package System.Standard_Library is
Name_Length => Storage_Error_Name'Length,
Full_Name => Storage_Error_Name'Address,
HTable_Ptr => null,
Import_Code => 0,
Foreign_Data => Null_Address,
Raise_Hook => null);
Tasking_Error_Def : aliased Exception_Data :=
@ -205,7 +191,7 @@ package System.Standard_Library is
Name_Length => Tasking_Error_Name'Length,
Full_Name => Tasking_Error_Name'Address,
HTable_Ptr => null,
Import_Code => 0,
Foreign_Data => Null_Address,
Raise_Hook => null);
Abort_Signal_Def : aliased Exception_Data :=
@ -214,7 +200,7 @@ package System.Standard_Library is
Name_Length => Abort_Signal_Name'Length,
Full_Name => Abort_Signal_Name'Address,
HTable_Ptr => null,
Import_Code => 0,
Foreign_Data => Null_Address,
Raise_Hook => null);
pragma Export (C, Constraint_Error_Def, "constraint_error");

30
gcc/ada/s-vmexta.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1997-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- --
@ -36,8 +36,6 @@ pragma Elaborate_All (System.HTable);
package body System.VMS_Exception_Table is
use type SSL.Exception_Code;
type HTable_Headers is range 1 .. 37;
type Exception_Code_Data;
@ -47,7 +45,7 @@ package body System.VMS_Exception_Table is
-- Ada exception.
type Exception_Code_Data is record
Code : SSL.Exception_Code;
Code : Exception_Code;
Except : SSL.Exception_Data_Ptr;
HTable_Ptr : Exception_Code_Data_Ptr;
end record;
@ -59,8 +57,8 @@ package body System.VMS_Exception_Table is
function Get_HT_Link (T : Exception_Code_Data_Ptr)
return Exception_Code_Data_Ptr;
function Hash (F : SSL.Exception_Code) return HTable_Headers;
function Get_Key (T : Exception_Code_Data_Ptr) return SSL.Exception_Code;
function Hash (F : Exception_Code) return HTable_Headers;
function Get_Key (T : Exception_Code_Data_Ptr) return Exception_Code;
package Exception_Code_HTable is new System.HTable.Static_HTable (
Header_Num => HTable_Headers,
@ -69,7 +67,7 @@ package body System.VMS_Exception_Table is
Null_Ptr => null,
Set_Next => Set_HT_Link,
Next => Get_HT_Link,
Key => SSL.Exception_Code,
Key => Exception_Code,
Get_Key => Get_Key,
Hash => Hash,
Equal => "=");
@ -79,7 +77,7 @@ package body System.VMS_Exception_Table is
------------------
function Base_Code_In
(Code : SSL.Exception_Code) return SSL.Exception_Code
(Code : Exception_Code) return Exception_Code
is
begin
return Code and not 2#0111#;
@ -90,7 +88,7 @@ package body System.VMS_Exception_Table is
---------------------
function Coded_Exception
(X : SSL.Exception_Code) return SSL.Exception_Data_Ptr
(X : Exception_Code) return SSL.Exception_Data_Ptr
is
Res : Exception_Code_Data_Ptr;
@ -121,7 +119,7 @@ package body System.VMS_Exception_Table is
-------------
function Get_Key (T : Exception_Code_Data_Ptr)
return SSL.Exception_Code
return Exception_Code
is
begin
return T.Code;
@ -132,10 +130,10 @@ package body System.VMS_Exception_Table is
----------
function Hash
(F : SSL.Exception_Code) return HTable_Headers
(F : Exception_Code) return HTable_Headers
is
Headers_Magnitude : constant SSL.Exception_Code :=
SSL.Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1);
Headers_Magnitude : constant Exception_Code :=
Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1);
begin
return HTable_Headers (F mod Headers_Magnitude + 1);
@ -146,13 +144,13 @@ package body System.VMS_Exception_Table is
----------------------------
procedure Register_VMS_Exception
(Code : SSL.Exception_Code;
(Code : Exception_Code;
E : SSL.Exception_Data_Ptr)
is
-- We bind the exception data with the base code found in the
-- input value, that is with the severity bits masked off.
Excode : constant SSL.Exception_Code := Base_Code_In (Code);
Excode : constant Exception_Code := Base_Code_In (Code);
begin
-- The exception data registered here is mostly filled prior to this
@ -165,7 +163,7 @@ package body System.VMS_Exception_Table is
-- routine attempts to match the import codes in this case.
E.Lang := 'V';
E.Import_Code := Excode;
E.Foreign_Data := Excode;
if Exception_Code_HTable.Get (Excode) = null then
Exception_Code_HTable.Set (new Exception_Code_Data'(Excode, E, null));

8
gcc/ada/s-vmexta.ads
View File

@ -38,8 +38,10 @@ package System.VMS_Exception_Table is
package SSL renames System.Standard_Library;
subtype Exception_Code is System.Address;
procedure Register_VMS_Exception
(Code : SSL.Exception_Code;
(Code : Exception_Code;
E : SSL.Exception_Data_Ptr);
-- Register an exception in hash table mapping with a VMS condition code.
--
@ -55,10 +57,10 @@ private
-- The following functions are directly called (without import/export) in
-- init.c by __gnat_handle_vms_condition.
function Base_Code_In (Code : SSL.Exception_Code) return SSL.Exception_Code;
function Base_Code_In (Code : Exception_Code) return Exception_Code;
-- Value of Code with the severity bits masked off
function Coded_Exception (X : SSL.Exception_Code)
function Coded_Exception (X : Exception_Code)
return SSL.Exception_Data_Ptr;
-- Given a VMS condition, find and return its allocated Ada exception