OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_dbug.ads (Get_External_Name): Add 'False' default to Has_Suffix, add 'Suffix' parameter and adjust comment. 

* exp_dbug.ads (Get_External_Name): Add 'False' default to Has_Suffix,
	add 'Suffix' parameter and adjust comment.
	(Get_External_Name_With_Suffix): Delete.
	* exp_dbug.adb (Get_External_Name_With_Suffix): Merge into...
	(Get_External_Name): ...here.  Add 'False' default to Has_Suffix, add
	'Suffix' parameter.
	(Get_Encoded_Name): Remove 2nd argument in call to Get_External_Name.
	Call Get_External_Name instead of Get_External_Name_With_Suffix.
	(Get_Secondary_DT_External_Name): Likewise.
	* exp_cg.adb (Write_Call_Info): Likewise.
	* exp_disp.adb (Export_DT): Likewise.
	(Import_DT): Likewise.
	* comperr.ads (Compiler_Abort): Remove Code parameter and add From_GCC
	parameter with False default.
	* comperr.adb (Compiler_Abort): Likewise.  Adjust accordingly.
	* types.h (Fat_Pointer): Rename into...
	(String_Pointer): ...this.  Add comment on interfacing rules.
	* fe.h (Compiler_Abort): Adjust for above renaming.
	(Error_Msg_N): Likewise.
	(Error_Msg_NE): Likewise.
	(Get_External_Name): Likewise.  Add third parameter.
	(Get_External_Name_With_Suffix): Delete.
	* gcc-interface/decl.c (STDCALL_PREFIX): Define.
	(create_concat_name): Adjust call to Get_External_Name, remove call to
	Get_External_Name_With_Suffix, use STDCALL_PREFIX, adjust for renaming.
	* gcc-interface/trans.c (post_error): Likewise.
	(post_error_ne): Likewise.
	* gcc-interface/misc.c (internal_error_function): Likewise.

From-SVN: r209866
This commit is contained in:
Eric Botcazou 2014-04-28 14:58:28 +00:00 committed by Eric Botcazou
parent 9ba5fb4309
commit 9358288555
12 changed files with 138 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/ada/ChangeLog
View File

@ -1,3 +1,34 @@
2014-04-28 Eric Botcazou <ebotcazou@adacore.com>
* exp_dbug.ads (Get_External_Name): Add 'False' default to Has_Suffix,
add 'Suffix' parameter and adjust comment.
(Get_External_Name_With_Suffix): Delete.
* exp_dbug.adb (Get_External_Name_With_Suffix): Merge into...
(Get_External_Name): ...here. Add 'False' default to Has_Suffix, add
'Suffix' parameter.
(Get_Encoded_Name): Remove 2nd argument in call to Get_External_Name.
Call Get_External_Name instead of Get_External_Name_With_Suffix.
(Get_Secondary_DT_External_Name): Likewise.
* exp_cg.adb (Write_Call_Info): Likewise.
* exp_disp.adb (Export_DT): Likewise.
(Import_DT): Likewise.
* comperr.ads (Compiler_Abort): Remove Code parameter and add From_GCC
parameter with False default.
* comperr.adb (Compiler_Abort): Likewise. Adjust accordingly.
* types.h (Fat_Pointer): Rename into...
(String_Pointer): ...this. Add comment on interfacing rules.
* fe.h (Compiler_Abort): Adjust for above renaming.
(Error_Msg_N): Likewise.
(Error_Msg_NE): Likewise.
(Get_External_Name): Likewise. Add third parameter.
(Get_External_Name_With_Suffix): Delete.
* gcc-interface/decl.c (STDCALL_PREFIX): Define.
(create_concat_name): Adjust call to Get_External_Name, remove call to
Get_External_Name_With_Suffix, use STDCALL_PREFIX, adjust for renaming.
* gcc-interface/trans.c (post_error): Likewise.
(post_error_ne): Likewise.
* gcc-interface/misc.c (internal_error_function): Likewise.
2014-04-28 Richard Biener <rguenther@suse.de>
PR middle-end/60092

14
gcc/ada/comperr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -74,8 +74,8 @@ package body Comperr is
procedure Compiler_Abort
(X : String;
Code : Integer := 0;
Fallback_Loc : String := "")
Fallback_Loc : String := "";
From_GCC : Boolean := False)
is
-- The procedures below output a "bug box" with information about
-- the cause of the compiler abort and about the preferred method
@ -206,7 +206,7 @@ package body Comperr is
Write_Str (") ");
if X'Length + Column > 76 then
if Code < 0 then
if From_GCC then
Write_Str ("GCC error:");
end if;
@ -235,11 +235,7 @@ package body Comperr is
Write_Str (X);
end if;
if Code > 0 then
Write_Str (", Code=");
Write_Int (Int (Code));
elsif Code = 0 then
if not From_GCC then
-- For exception case, get exception message from the TSD. Note
-- that it would be neater and cleaner to pass the exception

13
gcc/ada/comperr.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -31,8 +31,8 @@ package Comperr is
procedure Compiler_Abort
(X : String;
Code : Integer := 0;
Fallback_Loc : String := "");
Fallback_Loc : String := "";
From_GCC : Boolean := False);
pragma No_Return (Compiler_Abort);
-- Signals an internal compiler error. Never returns control. Depending on
-- processing may end up raising Unrecoverable_Error, or exiting directly.
@ -46,10 +46,9 @@ package Comperr is
-- Note that this is only used at the outer level (to handle constraint
-- errors or assert errors etc.) In the normal logic of the compiler we
-- always use pragma Assert to check for errors, and if necessary an
-- explicit abort is achieved by pragma Assert (False). Code is positive
-- for a gigi abort (giving the gigi abort code), zero for a front
-- end exception (with possible message stored in TSD.Current_Excep,
-- and negative (an unused value) for a GCC abort.
-- explicit abort is achieved by pragma Assert (False). From_GCC is true
-- for a GCC abort and false for a front end exception (with a possible
-- message stored in TSD.Current_Excep).
procedure Delete_SCIL_Files;
-- Delete SCIL files associated with the main unit

6
gcc/ada/exp_cg.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2010-2014, 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- --
@ -437,10 +437,10 @@ package body Exp_CG is
if Nkind (P) = N_Subprogram_Body
and then not Acts_As_Spec (P)
then
Get_External_Name (Corresponding_Spec (P), Has_Suffix => False);
Get_External_Name (Corresponding_Spec (P));
else
Get_External_Name (Defining_Entity (P), Has_Suffix => False);
Get_External_Name (Defining_Entity (P));
end if;
Write_Str (Name_Buffer (1 .. Name_Len));

77
gcc/ada/exp_dbug.adb
View File

@ -507,8 +507,8 @@ package body Exp_Dbug is
begin
-- If not generating code, there is no need to create encoded names, and
-- problems when the back-end is called to annotate types without full
-- code generation. See comments in Get_External_Name_With_Suffix for
-- additional details.
-- code generation. See comments in Get_External_Name for additional
-- details.
-- However we do create encoded names if the back end is active, even
-- if Operating_Mode got reset. Otherwise any serious error reported
@ -556,7 +556,7 @@ package body Exp_Dbug is
-- Fixed-point case
if Is_Fixed_Point_Type (E) then
Get_External_Name_With_Suffix (E, "XF_");
Get_External_Name (E, True, "XF_");
Add_Real_To_Buffer (Delta_Value (E));
if Small_Value (E) /= Delta_Value (E) then
@ -568,14 +568,14 @@ package body Exp_Dbug is
elsif Vax_Float (E) then
if Digits_Value (Base_Type (E)) = 6 then
Get_External_Name_With_Suffix (E, "XFF");
Get_External_Name (E, True, "XFF");
elsif Digits_Value (Base_Type (E)) = 9 then
Get_External_Name_With_Suffix (E, "XFF");
Get_External_Name (E, True, "XFF");
else
pragma Assert (Digits_Value (Base_Type (E)) = 15);
Get_External_Name_With_Suffix (E, "XFG");
Get_External_Name (E, True, "XFG");
end if;
-- Discrete case where bounds do not match size
@ -607,9 +607,9 @@ package body Exp_Dbug is
begin
if Biased then
Get_External_Name_With_Suffix (E, "XB");
Get_External_Name (E, True, "XB");
else
Get_External_Name_With_Suffix (E, "XD");
Get_External_Name (E, True, "XD");
end if;
if Lo_Encode or Hi_Encode then
@ -649,7 +649,7 @@ package body Exp_Dbug is
else
Has_Suffix := False;
Get_External_Name (E, Has_Suffix);
Get_External_Name (E);
end if;
if Debug_Flag_B and then Has_Suffix then
@ -667,7 +667,11 @@ package body Exp_Dbug is
-- Get_External_Name --
-----------------------
procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean) is
procedure Get_External_Name
(Entity : Entity_Id;
Has_Suffix : Boolean := False;
Suffix : String := "")
is
E : Entity_Id := Entity;
Kind : Entity_Kind;
@ -704,6 +708,20 @@ package body Exp_Dbug is
-- Start of processing for Get_External_Name
begin
-- If we are not in code generation mode, this procedure may still be
-- called from Back_End (more specifically - from gigi for doing type
-- representation annotation or some representation-specific checks).
-- But in this mode there is no need to mess with external names.
-- Furthermore, the call causes difficulties in this case because the
-- string representing the homonym number is not correctly reset as a
-- part of the call to Output_Homonym_Numbers_Suffix (which is not
-- called in gigi).
if Operating_Mode /= Generate_Code then
return;
end if;
Reset_Buffers;
-- If this is a child unit, we want the child
@ -762,42 +780,13 @@ package body Exp_Dbug is
Get_Qualified_Name_And_Append (E);
end if;
Name_Buffer (Name_Len + 1) := ASCII.NUL;
end Get_External_Name;
-----------------------------------
-- Get_External_Name_With_Suffix --
-----------------------------------
procedure Get_External_Name_With_Suffix
(Entity : Entity_Id;
Suffix : String)
is
Has_Suffix : constant Boolean := (Suffix /= "");
begin
-- If we are not in code generation mode, this procedure may still be
-- called from Back_End (more specifically - from gigi for doing type
-- representation annotation or some representation-specific checks).
-- But in this mode there is no need to mess with external names.
-- Furthermore, the call causes difficulties in this case because the
-- string representing the homonym number is not correctly reset as a
-- part of the call to Output_Homonym_Numbers_Suffix (which is not
-- called in gigi).
if Operating_Mode /= Generate_Code then
return;
end if;
Get_External_Name (Entity, Has_Suffix);
if Has_Suffix then
Add_Str_To_Name_Buffer ("___");
Add_Str_To_Name_Buffer (Suffix);
Name_Buffer (Name_Len + 1) := ASCII.NUL;
end if;
end Get_External_Name_With_Suffix;
Name_Buffer (Name_Len + 1) := ASCII.NUL;
end Get_External_Name;
--------------------------
-- Get_Variant_Encoding --
@ -944,7 +933,7 @@ package body Exp_Dbug is
Suffix_Index : Int)
is
begin
Get_External_Name (Typ, Has_Suffix => False);
Get_External_Name (Typ);
if Ancestor_Typ /= Typ then
declare
@ -952,7 +941,7 @@ package body Exp_Dbug is
Save_Str : constant String (1 .. Name_Len)
:= Name_Buffer (1 .. Name_Len);
begin
Get_External_Name (Ancestor_Typ, Has_Suffix => False);
Get_External_Name (Ancestor_Typ);
-- Append the extended name of the ancestor to the
-- extended name of Typ

26
gcc/ada/exp_dbug.ads
View File

@ -413,10 +413,11 @@ package Exp_Dbug is
procedure Get_External_Name
(Entity : Entity_Id;
Has_Suffix : Boolean);
-- Set Name_Buffer and Name_Len to the external name of entity E. The
Has_Suffix : Boolean := False;
Suffix : String := "");
-- Set Name_Buffer and Name_Len to the external name of the entity. The
-- external name is the Interface_Name, if specified, unless the entity
-- has an address clause or a suffix.
-- has an address clause or Has_Suffix is true.
--
-- If the Interface is not present, or not used, the external name is the
-- concatenation of:
@ -428,26 +429,11 @@ package Exp_Dbug is
-- - the string "$" (or "__" if target does not allow "$"), followed
-- by homonym suffix, if the entity is an overloaded subprogram
-- or is defined within an overloaded subprogram.
procedure Get_External_Name_With_Suffix
(Entity : Entity_Id;
Suffix : String);
-- Set Name_Buffer and Name_Len to the external name of entity E. If
-- Suffix is the empty string the external name is as above, otherwise
-- the external name is the concatenation of:
--
-- - the string "_ada_", if the entity is a library subprogram,
-- - the names of any enclosing scopes, each followed by "__",
-- or "X_" if the next entity is a subunit)
-- - the name of the entity
-- - the string "$" (or "__" if target does not allow "$"), followed
-- by homonym suffix, if the entity is an overloaded subprogram
-- or is defined within an overloaded subprogram.
-- - the string "___" followed by Suffix
-- - the string "___" followed by Suffix if Has_Suffix is true.
--
-- Note that a call to this procedure has no effect if we are not
-- generating code, since the necessary information for computing the
-- proper encoded name is not available in this case.
-- proper external name is not available in this case.
--------------------------------------------
-- Subprograms for Handling Qualification --

7
gcc/ada/exp_disp.adb
View File

@ -3913,10 +3913,7 @@ package body Exp_Disp is
pragma Assert (Related_Type (Node (Elmt)) = Typ);
Get_External_Name
(Entity => Node (Elmt),
Has_Suffix => True);
Get_External_Name (Node (Elmt));
Set_Interface_Name (DT,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
@ -7088,7 +7085,7 @@ package body Exp_Disp is
Set_Scope (DT, Current_Scope);
Get_External_Name (DT, True);
Get_External_Name (DT);
Set_Interface_Name (DT,
Make_String_Literal (Loc, Strval => String_From_Name_Buffer));

23
gcc/ada/fe.h
View File

@ -29,17 +29,20 @@
* *
****************************************************************************/
/* This file contains definitions to access front-end functions and
variables used by gigi. */
/* This file contains declarations to access front-end functions and variables
used by gigi.
WARNING: functions taking String_Pointer parameters must abide by the rule
documented alongside the definition of String_Pointer in types.h. */
#ifdef __cplusplus
extern "C" {
#endif
/* comperr: */
/* comperr: */
#define Compiler_Abort comperr__compiler_abort
extern int Compiler_Abort (Fat_Pointer, int, Fat_Pointer) ATTRIBUTE_NORETURN;
extern int Compiler_Abort (String_Pointer, String_Pointer, Boolean) ATTRIBUTE_NORETURN;
/* csets: */
@ -72,8 +75,6 @@ extern void Set_Mechanism (Entity_Id, Mechanism_Type);
extern void Set_RM_Size (Entity_Id, Uint);
extern void Set_Present_Expr (Node_Id, Uint);
/* Test if the node N is the name of an entity (i.e. is an identifier,
expanded name, or an attribute reference that returns an entity). */
#define Is_Entity_Name einfo__is_entity_name
extern Boolean Is_Entity_Name (Node_Id);
@ -90,8 +91,8 @@ extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, char);
#define Error_Msg_NE errout__error_msg_ne
#define Set_Identifier_Casing errout__set_identifier_casing
extern void Error_Msg_N (Fat_Pointer, Node_Id);
extern void Error_Msg_NE (Fat_Pointer, Node_Id, Entity_Id);
extern void Error_Msg_N (String_Pointer, Node_Id);
extern void Error_Msg_NE (String_Pointer, Node_Id, Entity_Id);
extern void Set_Identifier_Casing (Char *, const Char *);
/* err_vars: */
@ -147,11 +148,9 @@ extern void Setup_Asm_Outputs (Node_Id);
#define Get_Encoded_Name exp_dbug__get_encoded_name
#define Get_External_Name exp_dbug__get_external_name
#define Get_External_Name_With_Suffix exp_dbug__get_external_name_with_suffix
extern void Get_Encoded_Name (Entity_Id);
extern void Get_External_Name (Entity_Id, Boolean);
extern void Get_External_Name_With_Suffix (Entity_Id, Fat_Pointer);
extern void Get_Encoded_Name (Entity_Id);
extern void Get_External_Name (Entity_Id, Boolean, String_Pointer);
/* exp_util: */

20
gcc/ada/gcc-interface/decl.c
View File

@ -72,6 +72,8 @@
#define Has_Thiscall_Convention(E) 0
#endif
#define STDCALL_PREFIX "_imp__"
/* Stack realignment is necessary for functions with foreign conventions when
the ABI doesn't mandate as much as what the compiler assumes - that is, up
to PREFERRED_STACK_BOUNDARY.
@ -8856,16 +8858,12 @@ get_entity_name (Entity_Id gnat_entity)
tree
create_concat_name (Entity_Id gnat_entity, const char *suffix)
{
Entity_Kind kind = Ekind (gnat_entity);
const Entity_Kind kind = Ekind (gnat_entity);
const bool has_suffix = (suffix != NULL);
String_Template temp = {1, has_suffix ? strlen (suffix) : 0};
String_Pointer sp = {suffix, &temp};
if (suffix)
{
String_Template temp = {1, (int) strlen (suffix)};
Fat_Pointer fp = {suffix, &temp};
Get_External_Name_With_Suffix (gnat_entity, fp);
}
else
Get_External_Name (gnat_entity, 0);
Get_External_Name (gnat_entity, has_suffix, sp);
/* A variable using the Stdcall convention lives in a DLL. We adjust
its name to use the jump table, the _imp__NAME contains the address
@ -8873,9 +8871,9 @@ create_concat_name (Entity_Id gnat_entity, const char *suffix)
if ((kind == E_Variable || kind == E_Constant)
&& Has_Stdcall_Convention (gnat_entity))
{
const int len = 6 + Name_Len;
const int len = strlen (STDCALL_PREFIX) + Name_Len;
char *new_name = (char *) alloca (len + 1);
strcpy (new_name, "_imp__");
strcpy (new_name, STDCALL_PREFIX);
strcat (new_name, Name_Buffer);
return get_identifier_with_length (new_name, len);
}

22
gcc/ada/gcc-interface/misc.c
View File

@ -283,8 +283,8 @@ internal_error_function (diagnostic_context *context,
text_info tinfo;
char *buffer, *p, *loc;
String_Template temp, temp_loc;
Fat_Pointer fp, fp_loc;
expanded_location s;
String_Pointer sp, sp_loc;
expanded_location xloc;
/* Warn if plugins present. */
warn_if_plugins ();
@ -311,21 +311,21 @@ internal_error_function (diagnostic_context *context,
temp.Low_Bound = 1;
temp.High_Bound = p - buffer;
fp.Bounds = &temp;
fp.Array = buffer;
sp.Bounds = &temp;
sp.Array = buffer;
s = expand_location (input_location);
if (context->show_column && s.column != 0)
asprintf (&loc, "%s:%d:%d", s.file, s.line, s.column);
xloc = expand_location (input_location);
if (context->show_column && xloc.column != 0)
asprintf (&loc, "%s:%d:%d", xloc.file, xloc.line, xloc.column);
else
asprintf (&loc, "%s:%d", s.file, s.line);
asprintf (&loc, "%s:%d", xloc.file, xloc.line);
temp_loc.Low_Bound = 1;
temp_loc.High_Bound = strlen (loc);
fp_loc.Bounds = &temp_loc;
fp_loc.Array = loc;
sp_loc.Bounds = &temp_loc;
sp_loc.Array = loc;
Current_Error_Node = error_gnat_node;
Compiler_Abort (fp, -1, fp_loc);
Compiler_Abort (sp, sp_loc, true);
}
/* Perform all the initialization steps that are language-specific. */

16
gcc/ada/gcc-interface/trans.c
View File

@ -9356,16 +9356,16 @@ void
post_error (const char *msg, Node_Id node)
{
String_Template temp;
Fat_Pointer fp;
String_Pointer sp;
if (No (node))
return;
temp.Low_Bound = 1;
temp.High_Bound = strlen (msg);
fp.Bounds = &temp;
fp.Array = msg;
Error_Msg_N (fp, node);
sp.Bounds = &temp;
sp.Array = msg;
Error_Msg_N (sp, node);
}
/* Similar to post_error, but NODE is the node at which to post the error and
@ -9375,16 +9375,16 @@ void
post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
{
String_Template temp;
Fat_Pointer fp;
String_Pointer sp;
if (No (node))
return;
temp.Low_Bound = 1;
temp.High_Bound = strlen (msg);
fp.Bounds = &temp;
fp.Array = msg;
Error_Msg_NE (fp, node, ent);
sp.Bounds = &temp;
sp.Array = msg;
Error_Msg_NE (sp, node, ent);
}
/* Similar to post_error_ne, but NUM is the number to use for the '^'. */

18
gcc/ada/types.h
View File

@ -76,11 +76,19 @@ typedef Char *Str;
/* Pointer to string of Chars */
typedef Char *Str_Ptr;
/* Types for the fat pointer used for strings and the template it
points to. */
typedef struct {int Low_Bound, High_Bound; } String_Template;
typedef struct {const char *Array; String_Template *Bounds; }
__attribute ((aligned (sizeof (char *) * 2))) Fat_Pointer;
/* Types for the fat pointer used for strings and the template it points to.
The fat pointer is conceptually a couple of pointers, but it is wrapped
up in a special record type. On the Ada side, the record is naturally
aligned (i.e. given pointer alignment) on regular platforms, but it is
given twice this alignment on strict-alignment platforms for performance
reasons. On the C side, for the sake of portability and simplicity, we
overalign it on all platforms (so the machine mode is always the same as
on the Ada side) but arrange to pass it in an even scalar position as a
parameter to functions (so the scalar parameter alignment is always the
same as on the Ada side). */
typedef struct { int Low_Bound, High_Bound; } String_Template;
typedef struct { const char *Array; String_Template *Bounds; }
__attribute ((aligned (sizeof (char *) * 2))) String_Pointer;
/* Types for Node/Entity Kinds: */