The OpenVMS specific component Import_Code is replaced by Foreign_Data.
Although the size of the component is not the same, due to alignment constraint
of the component before and after, the size of the record doesn't change.
Furthermore, this component is never used by the code generated for gnat1 or
gnatbind, so there is no bootstrap issue.
No functional change, so no new testcase.
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-10-14 Tristan Gingold <ging...@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.
Index: exp_prag.adb
===================================================================
--- exp_prag.adb (revision 203534)
+++ exp_prag.adb (working copy)
@@ -646,8 +646,9 @@
-- 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 @@
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 @@
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 @@
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;
Index: raise.h
===================================================================
--- raise.h (revision 203521)
+++ raise.h (working copy)
@@ -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 @@
/* 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);
};
Index: rtsfind.ads
===================================================================
--- rtsfind.ads (revision 203521)
+++ rtsfind.ads (working copy)
@@ -748,6 +748,7 @@
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 @@
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 @@
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 @@
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,
Index: a-exexpr-gcc.adb
===================================================================
--- a-exexpr-gcc.adb (revision 203521)
+++ a-exexpr-gcc.adb (working copy)
@@ -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 @@
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 @@
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 --
Index: exp_ch11.adb
===================================================================
--- exp_ch11.adb (revision 203521)
+++ exp_ch11.adb (working copy)
@@ -1172,7 +1172,7 @@
-- Name_Length => exceptE'Length,
-- Full_Name => exceptE'Address,
-- HTable_Ptr => null,
- -- Import_Code => 0,
+ -- Foreign_Data => null,
-- Raise_Hook => null,
-- );
@@ -1319,9 +1319,9 @@
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
Index: cstand.adb
===================================================================
--- cstand.adb (revision 203521)
+++ cstand.adb (working copy)
@@ -1470,15 +1470,8 @@
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
+ -- 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.
-
Standard_Exception_Type := New_Standard_Entity;
Set_Ekind (Standard_Exception_Type, E_Record_Type);
Set_Etype (Standard_Exception_Type, Standard_Exception_Type);
@@ -1501,7 +1494,7 @@
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");
Index: raise-gcc.c
===================================================================
--- raise-gcc.c (revision 203521)
+++ raise-gcc.c (working copy)
@@ -812,22 +812,32 @@
#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 @@
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 @@
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
+
+ /* Otherwise, it doesn't match an Ada choice. */
+ return nothing;
}
- 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;
- }
+ /* 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;
}
Index: s-exctab.adb
===================================================================
--- s-exctab.adb (revision 203521)
+++ s-exctab.adb (working copy)
@@ -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 @@
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);
Index: s-vmexta.adb
===================================================================
--- s-vmexta.adb (revision 203521)
+++ s-vmexta.adb (working copy)
@@ -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 @@
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 @@
-- 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 @@
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 @@
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 @@
------------------
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 @@
---------------------
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 @@
-------------
function Get_Key (T : Exception_Code_Data_Ptr)
- return SSL.Exception_Code
+ return Exception_Code
is
begin
return T.Code;
@@ -132,10 +130,10 @@
----------
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 @@
----------------------------
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 @@
-- 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));
Index: s-vmexta.ads
===================================================================
--- s-vmexta.ads (revision 203534)
+++ s-vmexta.ads (working copy)
@@ -38,8 +38,10 @@
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 @@
-- 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
Index: s-stalib.ads
===================================================================
--- s-stalib.ads (revision 203521)
+++ s-stalib.ads (working copy)
@@ -85,20 +85,6 @@
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 @@
-- 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 @@
-- 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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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");
