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> 2013-10-14 Robert Dewar <dewar@adacore.com>
* gnat_ugn.texi: Document -gnateu switch. * gnat_ugn.texi: Document -gnateu switch.

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

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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; function Language_For (E : Exception_Data_Ptr) return Character;
pragma Export (C, Language_For, "__gnat_language_for"); pragma Export (C, Language_For, "__gnat_language_for");
function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code; function Foreign_Data_For (E : Exception_Data_Ptr) return Address;
pragma Export (C, Import_Code_For, "__gnat_import_code_for"); pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for");
function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access) function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
return Exception_Id; return Exception_Id;
@ -489,16 +489,16 @@ package body Exception_Propagation is
return GNAT_Exception.Occurrence.Id; return GNAT_Exception.Occurrence.Id;
end EID_For; end EID_For;
--------------------- ----------------------
-- Import_Code_For -- -- Foreign_Data_For --
--------------------- ----------------------
function Import_Code_For function Foreign_Data_For
(E : SSL.Exception_Data_Ptr) return Exception_Code (E : SSL.Exception_Data_Ptr) return Address
is is
begin begin
return E.all.Import_Code; return E.Foreign_Data;
end Import_Code_For; end Foreign_Data_For;
-------------------------- --------------------------
-- Is_Handled_By_Others -- -- Is_Handled_By_Others --

11
gcc/ada/cstand.adb
View File

@ -1470,14 +1470,7 @@ package body CStand is
end Build_Duration; end Build_Duration;
-- Build standard exception type. Note that the type name here is -- 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; Standard_Exception_Type := New_Standard_Entity;
Set_Ekind (Standard_Exception_Type, E_Record_Type); Set_Ekind (Standard_Exception_Type, E_Record_Type);
@ -1501,7 +1494,7 @@ package body CStand is
Make_Component Make_Component
(Standard_Exception_Type, Standard_A_Char, "HTable_Ptr"); (Standard_Exception_Type, Standard_A_Char, "HTable_Ptr");
Make_Component Make_Component
(Standard_Exception_Type, Standard_Unsigned, "Import_Code"); (Standard_Exception_Type, Standard_A_Char, "Foreign_Data");
Make_Component Make_Component
(Standard_Exception_Type, Standard_A_Char, "Raise_Hook"); (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, -- Name_Length => exceptE'Length,
-- Full_Name => exceptE'Address, -- Full_Name => exceptE'Address,
-- HTable_Ptr => null, -- HTable_Ptr => null,
-- Import_Code => 0, -- Foreign_Data => null,
-- Raise_Hook => null, -- Raise_Hook => null,
-- ); -- );
@ -1319,9 +1319,9 @@ package body Exp_Ch11 is
Append_To (L, Make_Null (Loc)); 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 -- 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. -- alias to define the symbol.
Code := Code :=
Make_Integer_Literal (Loc, Unchecked_Convert_To (Standard_A_Char,
Intval => Exception_Code (Id)); Make_Integer_Literal (Loc,
Intval => Exception_Code (Id)));
-- Declare a dummy object -- Declare a dummy object
@ -655,7 +656,7 @@ package body Exp_Prag is
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Excep_Internal, Defining_Identifier => Excep_Internal,
Object_Definition => Object_Definition =>
New_Reference_To (RTE (RE_Exception_Code), Loc)); New_Reference_To (RTE (RE_Address), Loc));
Insert_Action (N, Excep_Object); Insert_Action (N, Excep_Object);
Analyze (Excep_Object); Analyze (Excep_Object);
@ -711,13 +712,12 @@ package body Exp_Prag is
else else
Code := Code :=
Unchecked_Convert_To (RTE (RE_Exception_Code), Make_Function_Call (Loc,
Make_Function_Call (Loc, Name =>
Name => New_Reference_To (RTE (RE_Import_Address), Loc),
New_Reference_To (RTE (RE_Import_Value), Loc), Parameter_Associations => New_List
Parameter_Associations => New_List (Make_String_Literal (Loc,
(Make_String_Literal (Loc, Strval => Excep_Image)));
Strval => Excep_Image))));
end if; end if;
-- Generate the call to Register_VMS_Exception -- Generate the call to Register_VMS_Exception
@ -733,7 +733,7 @@ package body Exp_Prag is
Prefix => New_Occurrence_Of (Id, Loc), Prefix => New_Occurrence_Of (Id, Loc),
Attribute_Name => Name_Unrestricted_Access))))); Attribute_Name => Name_Unrestricted_Access)))));
Analyze_And_Resolve (Code, RTE (RE_Exception_Code)); Analyze_And_Resolve (Code, RTE (RE_Address));
Analyze (Call); Analyze (Call);
end if; 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 Is_Handled_By_Others __gnat_is_handled_by_others
#define Language_For __gnat_language_for #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 #define EID_For __gnat_eid_for
extern bool Is_Handled_By_Others (_Unwind_Ptr eid); extern bool Is_Handled_By_Others (_Unwind_Ptr eid);
extern char Language_For (_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); 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 static enum action_kind
is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception) is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception)
{ {
/* All others choice match everything. */
if (choice == GNAT_ALL_OTHERS) if (choice == GNAT_ALL_OTHERS)
return handler; return handler;
/* GNAT exception occurrence. */
if (propagated_exception->common.exception_class == GNAT_EXCEPTION_CLASS) if (propagated_exception->common.exception_class == GNAT_EXCEPTION_CLASS)
{ {
/* Pointer to the GNAT exception data corresponding to the propagated /* 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))) if (choice == E || (choice == GNAT_OTHERS && Is_Handled_By_Others (E)))
return handler; return handler;
#ifdef VMS
/* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we
may have different exception data pointers that should match for the may have different exception data pointers that should match for the
same condition code, if both an export and an import have been 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 occurrence are expected to have been masked off regarding severity
bits already (at registration time for the former and from within the bits already (at registration time for the former and from within the
low level exception vector for the latter). */ 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' if ((Language_For (E) == 'V'
&& choice != GNAT_OTHERS && choice != GNAT_OTHERS
&& ((Language_For (choice) == 'V' && ((Language_For (choice) == 'V'
&& Import_Code_For (choice) != 0 && Foreign_Data_For (choice) != 0
&& Import_Code_For (choice) == Import_Code_For (E)) && Foreign_Data_For (choice) == Foreign_Data_For (E))
|| choice == (_Unwind_Ptr)&Non_Ada_Error))) || choice == (_Unwind_Ptr)&Non_Ada_Error)))
return handler; return handler;
#endif #endif
}
else
{
# define Foreign_Exception system__exceptions__foreign_exception
extern struct Exception_Data Foreign_Exception;
if (choice == GNAT_ALL_OTHERS /* Otherwise, it doesn't match an Ada choice. */
|| choice == GNAT_OTHERS return nothing;
|| 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; return nothing;
} }

9
gcc/ada/raise.h
View File

@ -6,7 +6,7 @@
* * * *
* C Header File * * 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 * * 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- * * 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. */ /* C counterparts of what System.Standard_Library defines. */
typedef unsigned Exception_Code;
struct Exception_Data struct Exception_Data
{ {
char Not_Handled_By_Others; char Not_Handled_By_Others;
char Lang; char Lang;
int Name_Length; int Name_Length;
char *Full_Name, *Htable_Ptr; char *Full_Name;
Exception_Code Import_Code; char *Htable_Ptr;
void *Foreign_Data;
void (*Raise_Hook)(void); void (*Raise_Hook)(void);
}; };

4
gcc/ada/rtsfind.ads
View File

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

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

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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, Name_Length => Copy'Length,
Full_Name => Dyn_Copy.all'Address, Full_Name => Dyn_Copy.all'Address,
HTable_Ptr => null, HTable_Ptr => null,
Import_Code => 0, Foreign_Data => Null_Address,
Raise_Hook => null); Raise_Hook => null);
Register_Exception (Res); 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; type Exception_Data_Ptr is access all Exception_Data;
-- An equivalent of Exception_Id that is public -- 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 -- The following record defines the underlying representation of exceptions
-- WARNING! Any changes to this may need to be reflected in the following -- 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. -- A character indicating the language raising the exception.
-- Set to "A" for exceptions defined by an Ada program. -- Set to "A" for exceptions defined by an Ada program.
-- Set to "V" for imported VMS exceptions. -- Set to "V" for imported VMS exceptions.
-- Set to "C" for imported C++ exceptions.
Name_Length : Natural; Name_Length : Natural;
-- Length of fully expanded name of exception -- 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 -- built (by Register_Exception in s-exctab.adb) for converting between
-- identities and names. -- identities and names.
Import_Code : Exception_Code; Foreign_Data : Address;
-- Value for imported exceptions. Needed only for the handling of -- Data for imported exceptions. This represents the exception code
-- Import/Export_Exception for the VMS case, but present in all -- for the handling of Import/Export_Exception for the VMS case.
-- implementations (we might well extend this mechanism for other -- This represents the address of the RTTI for the C++ case.
-- systems in the future).
Raise_Hook : Raise_Action; Raise_Hook : Raise_Action;
-- This field can be used to place a "hook" on an exception. If the -- 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, Name_Length => Constraint_Error_Name'Length,
Full_Name => Constraint_Error_Name'Address, Full_Name => Constraint_Error_Name'Address,
HTable_Ptr => null, HTable_Ptr => null,
Import_Code => 0, Foreign_Data => Null_Address,
Raise_Hook => null); Raise_Hook => null);
Numeric_Error_Def : aliased Exception_Data := Numeric_Error_Def : aliased Exception_Data :=
@ -178,7 +164,7 @@ package System.Standard_Library is
Name_Length => Numeric_Error_Name'Length, Name_Length => Numeric_Error_Name'Length,
Full_Name => Numeric_Error_Name'Address, Full_Name => Numeric_Error_Name'Address,
HTable_Ptr => null, HTable_Ptr => null,
Import_Code => 0, Foreign_Data => Null_Address,
Raise_Hook => null); Raise_Hook => null);
Program_Error_Def : aliased Exception_Data := Program_Error_Def : aliased Exception_Data :=
@ -187,7 +173,7 @@ package System.Standard_Library is
Name_Length => Program_Error_Name'Length, Name_Length => Program_Error_Name'Length,
Full_Name => Program_Error_Name'Address, Full_Name => Program_Error_Name'Address,
HTable_Ptr => null, HTable_Ptr => null,
Import_Code => 0, Foreign_Data => Null_Address,
Raise_Hook => null); Raise_Hook => null);
Storage_Error_Def : aliased Exception_Data := Storage_Error_Def : aliased Exception_Data :=
@ -196,7 +182,7 @@ package System.Standard_Library is
Name_Length => Storage_Error_Name'Length, Name_Length => Storage_Error_Name'Length,
Full_Name => Storage_Error_Name'Address, Full_Name => Storage_Error_Name'Address,
HTable_Ptr => null, HTable_Ptr => null,
Import_Code => 0, Foreign_Data => Null_Address,
Raise_Hook => null); Raise_Hook => null);
Tasking_Error_Def : aliased Exception_Data := Tasking_Error_Def : aliased Exception_Data :=
@ -205,7 +191,7 @@ package System.Standard_Library is
Name_Length => Tasking_Error_Name'Length, Name_Length => Tasking_Error_Name'Length,
Full_Name => Tasking_Error_Name'Address, Full_Name => Tasking_Error_Name'Address,
HTable_Ptr => null, HTable_Ptr => null,
Import_Code => 0, Foreign_Data => Null_Address,
Raise_Hook => null); Raise_Hook => null);
Abort_Signal_Def : aliased Exception_Data := Abort_Signal_Def : aliased Exception_Data :=
@ -214,7 +200,7 @@ package System.Standard_Library is
Name_Length => Abort_Signal_Name'Length, Name_Length => Abort_Signal_Name'Length,
Full_Name => Abort_Signal_Name'Address, Full_Name => Abort_Signal_Name'Address,
HTable_Ptr => null, HTable_Ptr => null,
Import_Code => 0, Foreign_Data => Null_Address,
Raise_Hook => null); Raise_Hook => null);
pragma Export (C, Constraint_Error_Def, "constraint_error"); pragma Export (C, Constraint_Error_Def, "constraint_error");

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

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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 package body System.VMS_Exception_Table is
use type SSL.Exception_Code;
type HTable_Headers is range 1 .. 37; type HTable_Headers is range 1 .. 37;
type Exception_Code_Data; type Exception_Code_Data;
@ -47,7 +45,7 @@ package body System.VMS_Exception_Table is
-- Ada exception. -- Ada exception.
type Exception_Code_Data is record type Exception_Code_Data is record
Code : SSL.Exception_Code; Code : Exception_Code;
Except : SSL.Exception_Data_Ptr; Except : SSL.Exception_Data_Ptr;
HTable_Ptr : Exception_Code_Data_Ptr; HTable_Ptr : Exception_Code_Data_Ptr;
end record; end record;
@ -59,8 +57,8 @@ package body System.VMS_Exception_Table is
function Get_HT_Link (T : Exception_Code_Data_Ptr) function Get_HT_Link (T : Exception_Code_Data_Ptr)
return Exception_Code_Data_Ptr; return Exception_Code_Data_Ptr;
function Hash (F : SSL.Exception_Code) return HTable_Headers; function Hash (F : Exception_Code) return HTable_Headers;
function Get_Key (T : Exception_Code_Data_Ptr) return SSL.Exception_Code; function Get_Key (T : Exception_Code_Data_Ptr) return Exception_Code;
package Exception_Code_HTable is new System.HTable.Static_HTable ( package Exception_Code_HTable is new System.HTable.Static_HTable (
Header_Num => HTable_Headers, Header_Num => HTable_Headers,
@ -69,7 +67,7 @@ package body System.VMS_Exception_Table is
Null_Ptr => null, Null_Ptr => null,
Set_Next => Set_HT_Link, Set_Next => Set_HT_Link,
Next => Get_HT_Link, Next => Get_HT_Link,
Key => SSL.Exception_Code, Key => Exception_Code,
Get_Key => Get_Key, Get_Key => Get_Key,
Hash => Hash, Hash => Hash,
Equal => "="); Equal => "=");
@ -79,7 +77,7 @@ package body System.VMS_Exception_Table is
------------------ ------------------
function Base_Code_In function Base_Code_In
(Code : SSL.Exception_Code) return SSL.Exception_Code (Code : Exception_Code) return Exception_Code
is is
begin begin
return Code and not 2#0111#; return Code and not 2#0111#;
@ -90,7 +88,7 @@ package body System.VMS_Exception_Table is
--------------------- ---------------------
function Coded_Exception function Coded_Exception
(X : SSL.Exception_Code) return SSL.Exception_Data_Ptr (X : Exception_Code) return SSL.Exception_Data_Ptr
is is
Res : Exception_Code_Data_Ptr; Res : Exception_Code_Data_Ptr;
@ -121,7 +119,7 @@ package body System.VMS_Exception_Table is
------------- -------------
function Get_Key (T : Exception_Code_Data_Ptr) function Get_Key (T : Exception_Code_Data_Ptr)
return SSL.Exception_Code return Exception_Code
is is
begin begin
return T.Code; return T.Code;
@ -132,10 +130,10 @@ package body System.VMS_Exception_Table is
---------- ----------
function Hash function Hash
(F : SSL.Exception_Code) return HTable_Headers (F : Exception_Code) return HTable_Headers
is is
Headers_Magnitude : constant SSL.Exception_Code := Headers_Magnitude : constant Exception_Code :=
SSL.Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1); Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1);
begin begin
return HTable_Headers (F mod Headers_Magnitude + 1); return HTable_Headers (F mod Headers_Magnitude + 1);
@ -146,13 +144,13 @@ package body System.VMS_Exception_Table is
---------------------------- ----------------------------
procedure Register_VMS_Exception procedure Register_VMS_Exception
(Code : SSL.Exception_Code; (Code : Exception_Code;
E : SSL.Exception_Data_Ptr) E : SSL.Exception_Data_Ptr)
is is
-- We bind the exception data with the base code found in the -- We bind the exception data with the base code found in the
-- input value, that is with the severity bits masked off. -- 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 begin
-- The exception data registered here is mostly filled prior to this -- 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. -- routine attempts to match the import codes in this case.
E.Lang := 'V'; E.Lang := 'V';
E.Import_Code := Excode; E.Foreign_Data := Excode;
if Exception_Code_HTable.Get (Excode) = null then if Exception_Code_HTable.Get (Excode) = null then
Exception_Code_HTable.Set (new Exception_Code_Data'(Excode, E, null)); 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; package SSL renames System.Standard_Library;
subtype Exception_Code is System.Address;
procedure Register_VMS_Exception procedure Register_VMS_Exception
(Code : SSL.Exception_Code; (Code : Exception_Code;
E : SSL.Exception_Data_Ptr); E : SSL.Exception_Data_Ptr);
-- Register an exception in hash table mapping with a VMS condition code. -- 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 -- The following functions are directly called (without import/export) in
-- init.c by __gnat_handle_vms_condition. -- 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 -- 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; return SSL.Exception_Data_Ptr;
-- Given a VMS condition, find and return its allocated Ada exception -- Given a VMS condition, find and return its allocated Ada exception