Skip to content

R
riscv-gcc-1
Commit e443f142 by Tristan Gingold Committed by Arnaud Charlet
Options

cstand.adb (Create_Standard): Change Import_Code component of… 

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
parent 5a015f2b
Showing with 114 additions and 103 deletions
gcc/ada/ChangeLog
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.
......
gcc/ada/a-exexpr-gcc.adb
......@@ -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 --
......
gcc/ada/cstand.adb
......@@ -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");
......
gcc/ada/exp_ch11.adb
......@@ -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
......
gcc/ada/exp_prag.adb
......@@ -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;
......
gcc/ada/raise-gcc.c
......@@ -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;
}
......
gcc/ada/raise.h
......@@ -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);
};
......
gcc/ada/rtsfind.ads
......@@ -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,
......
gcc/ada/s-exctab.adb
......@@ -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);
......
gcc/ada/s-stalib.ads
......@@ -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");
......
gcc/ada/s-vmexta.adb
......@@ -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));
......
gcc/ada/s-vmexta.ads
......@@ -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
......
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