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

[multiple changes] 

2004-04-08  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* trans.c (tree_transform): Shortcut returning error_mark_node for
	statements in annotate_only_mode.
	(tree_transform, case N_Label, case N_Return_Statement,
	N_Goto_Statement): Make statement tree instead of generating code.
	(tree_transform, case N_Assignment_Statement): No longer check
	type_annotate_only.
	(gnat_expand_stmt, case GOTO_STMT, case LABEL_STMT, case
	RETURN_STMT): New.
	(first_nondeleted_insn, build_block_stmt, make_expr_stmt_from_rtl):
	New fcns.
	(gnat_to_gnu): Collect any RTL generated and deal with it.
	(tree_transform, case N_And_Then): Refine when have non-null RTL_EXPR.
	(tree_transform case N_If_Statement): Rewrite to make IF_STMT.
	(gnat_expand_stmt, case BLOCK_STMT, IF_STMT): New cases.

	* ada-tree.def (GOTO_STMT, LABEL_STMT, RETURN_STMT): New tree nodes.

	* ada-tree.def (EXPR_STMT): Fix typo in name.
	(BLOCK_STMT, IF_STMT): New nodes.

	* ada-tree.h (GOTO_STMT_LABEL, LABEL_STMT_LABEL,
	LABEL_STMT_FIRST_IN_EH): New macros.
	(RETURN_STMT_EXPR): Likewise.

	* ada-tree.h: (BLOCK_STMT_LIST, IF_STMT_COND, IF_STMT_TRUE,
	IF_STMT_ELSEIF, IF_STMT_ELSE): New macros.

2004-04-08  Thomas Quinot  <quinot@act-europe.fr>

	* atree.ads: Correct documentation on extended nodes.

	* link.c: Set run_path_option for FreeBSD.

2004-04-08  Vincent Celier  <celier@gnat.com>

	* mlib-prj.adb (Build_Library.Check_Libs): On OpenVMS, if dec.ali is
	one of the ALI file, do not link with DEC lib.

	* par.adb Remove the last two characters ("%s" or "%b") when checking
	if a language defined unit may be recompiled.

2004-04-08  Ed Schonberg  <schonberg@gnat.com>

	* sem_ch4.adb (Remove_Abstract_Operations): Improve error message when
	removal of abstract operation leaves no possible interpretation for
	expression.

	* sem_eval.adb (Eval_Qualified_Expression): Use
	Set_Raises_Constraint_Error on node when needed, so that it does not
	get optimized away by subsequent optimizations.

	* sem_res.adb (Resolve_Intrinsic_Operator): Save interpretations of
	operands even when they are not wrapped in a type conversion.

2004-04-08  Olivier Hainque  <hainque@act-europe.fr>

	* sem_prag.adb (Set_Exported): Warn about making static as result of
	export only when the export is coming from source. This may be not
	be true e.g. on VMS where we expand export pragmas for exception codes
	together with imported or exported exceptions, and we don't want the
	user to be warned about something he didn't write.

2004-04-08  Thomas Quinot  <quinot@act-europe.fr>

	* sem_util.adb (Note_Possible_Modification): Reorganize to remove code
	duplication between normal entities and those declared as renamings.
	No functional change.

	* s-fileio.ads (Form): Remove pragma Inline, as we cannot currently
	inline functions returning an unconstrained result.

2004-04-08  Eric Botcazou  <ebotcazou@act-europe.fr>

	* utils.c (type_for_mode): Handle BLKmode and VOIDmode properly, to
	conform to what other front-ends do.

2004-04-08  Doug Rupp  <rupp@gnat.com>

	* 5vml-tgt.adb: Use Gas instead of VMS Macro to build auto init shared
	libraries.

From-SVN: r80504
This commit is contained in:
Arnaud Charlet 2004-04-08 15:23:50 +02:00
parent 2897f1d411
commit af15298919
16 changed files with 433 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
gcc/ada/5vml-tgt.adb
View File

@ -50,15 +50,10 @@ package body MLib.Tgt is
-- Used to add the generated auto-init object files for auto-initializing
-- stand-alone libraries.
Macro_Name : constant String := "macro";
Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler";
-- The name of the command to invoke the macro-assembler
-- Options to use when invoking gcc to build the dynamic library
No_Start_Files : aliased String := "-nostartfiles";
VMS_Options : Argument_List :=
(No_Start_Files'Access, null);
VMS_Options : Argument_List := (1 .. 1 => null);
Gnatsym_Name : constant String := "gnatsym";
@ -272,7 +267,7 @@ package body MLib.Tgt is
new String'("--for-linker=" & Opt_File_Name & "/OPTIONS");
end if;
VMS_Options (VMS_Options'First + 1) := For_Linker_Opt;
VMS_Options (VMS_Options'First) := For_Linker_Opt;
for J in Inter'Range loop
To_Lower (Inter (J).all);
@ -293,7 +288,7 @@ package body MLib.Tgt is
if Auto_Init then
declare
Macro_File_Name : constant String := Lib_Filename & "$init.mar";
Macro_File_Name : constant String := Lib_Filename & "$init.asm";
Macro_File : Ada.Text_IO.File_Type;
Init_Proc : String := Lib_Filename & "INIT";
Popen_Result : System.Address;
@ -319,13 +314,12 @@ package body MLib.Tgt is
begin
Create (Macro_File, Out_File, Macro_File_Name);
Put_Line (Macro_File, ASCII.HT & ".EXTRN LIB$INITIALIZE");
Put_Line (Macro_File, ASCII.HT & ".EXTRN " & Init_Proc);
Put_Line
(Macro_File,
ASCII.HT & ".PSECT LIB$INITIALIZE USR,GBL,NOEXE,NOWRT,LONG");
Put_Line (Macro_File, ASCII.HT & ".ADDRESS " & Init_Proc);
Put_Line (Macro_File, ASCII.HT & ".END");
ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT");
Put_Line
(Macro_File,
ASCII.HT & ".long " & Init_Proc);
Close (Macro_File);

83
gcc/ada/ChangeLog
View File

@ -1,3 +1,86 @@
2004-04-08 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c (tree_transform): Shortcut returning error_mark_node for
statements in annotate_only_mode.
(tree_transform, case N_Label, case N_Return_Statement,
N_Goto_Statement): Make statement tree instead of generating code.
(tree_transform, case N_Assignment_Statement): No longer check
type_annotate_only.
(gnat_expand_stmt, case GOTO_STMT, case LABEL_STMT, case
RETURN_STMT): New.
(first_nondeleted_insn, build_block_stmt, make_expr_stmt_from_rtl):
New fcns.
(gnat_to_gnu): Collect any RTL generated and deal with it.
(tree_transform, case N_And_Then): Refine when have non-null RTL_EXPR.
(tree_transform case N_If_Statement): Rewrite to make IF_STMT.
(gnat_expand_stmt, case BLOCK_STMT, IF_STMT): New cases.
* ada-tree.def (GOTO_STMT, LABEL_STMT, RETURN_STMT): New tree nodes.
* ada-tree.def (EXPR_STMT): Fix typo in name.
(BLOCK_STMT, IF_STMT): New nodes.
* ada-tree.h (GOTO_STMT_LABEL, LABEL_STMT_LABEL,
LABEL_STMT_FIRST_IN_EH): New macros.
(RETURN_STMT_EXPR): Likewise.
* ada-tree.h: (BLOCK_STMT_LIST, IF_STMT_COND, IF_STMT_TRUE,
IF_STMT_ELSEIF, IF_STMT_ELSE): New macros.
2004-04-08 Thomas Quinot <quinot@act-europe.fr>
* atree.ads: Correct documentation on extended nodes.
* link.c: Set run_path_option for FreeBSD.
2004-04-08 Vincent Celier <celier@gnat.com>
* mlib-prj.adb (Build_Library.Check_Libs): On OpenVMS, if dec.ali is
one of the ALI file, do not link with DEC lib.
* par.adb Remove the last two characters ("%s" or "%b") when checking
if a language defined unit may be recompiled.
2004-04-08 Ed Schonberg <schonberg@gnat.com>
* sem_ch4.adb (Remove_Abstract_Operations): Improve error message when
removal of abstract operation leaves no possible interpretation for
expression.
* sem_eval.adb (Eval_Qualified_Expression): Use
Set_Raises_Constraint_Error on node when needed, so that it does not
get optimized away by subsequent optimizations.
* sem_res.adb (Resolve_Intrinsic_Operator): Save interpretations of
operands even when they are not wrapped in a type conversion.
2004-04-08 Olivier Hainque <hainque@act-europe.fr>
* sem_prag.adb (Set_Exported): Warn about making static as result of
export only when the export is coming from source. This may be not
be true e.g. on VMS where we expand export pragmas for exception codes
together with imported or exported exceptions, and we don't want the
user to be warned about something he didn't write.
2004-04-08 Thomas Quinot <quinot@act-europe.fr>
* sem_util.adb (Note_Possible_Modification): Reorganize to remove code
duplication between normal entities and those declared as renamings.
No functional change.
* s-fileio.ads (Form): Remove pragma Inline, as we cannot currently
inline functions returning an unconstrained result.
2004-04-08 Eric Botcazou <ebotcazou@act-europe.fr>
* utils.c (type_for_mode): Handle BLKmode and VOIDmode properly, to
conform to what other front-ends do.
2004-04-08 Doug Rupp <rupp@gnat.com>
* 5vml-tgt.adb: Use Gas instead of VMS Macro to build auto init shared
libraries.
2004-04-06 Pascal Obry <obry@gnat.com>
* adaint.c (DIR_SEPARATOR): Properly set DIR_SEPARATOR on Win32.

24
gcc/ada/ada-tree.def
View File

@ -84,4 +84,26 @@ DEFTREECODE (GNAT_LOOP_ID, "gnat_loop_id", 'x', 0)
We start with an expression statement, whose only operand is an
expression, EXPR_STMT_EXPR, Execution of the statement means evaluation of
the expression (such as a MODIFY_EXPR) and discarding its result. */
DEFTREECODE (EXPR_STMT, "expr_stmt_expr", 's', 1)
DEFTREECODE (EXPR_STMT, "expr_stmt", 's', 1)
/* This represents a list of statements. BLOCK_STMT_LIST is a list
statement tree, chained via TREE_CHAIN. */
DEFTREECODE (BLOCK_STMT, "block_stmt", 's', 1)
/* This is an IF statement. IF_STMT_COND is the condition being tested,
IF_STMT_TRUE is the statement to be executed if the condition is
true; IF_STMT_ELSEIF, if non-null, is a list of more IF_STMT nodes (where
we only look at IF_STMT_COND and IF_STMT_TRUE) that correspond to
any "else if" parts; and IF_STMT_ELSE is the statement to be executed if
all conditions are. */
DEFTREECODE (IF_STMT, "if_stmt", 's', 4)
/* A goto just points to the label: GOTO_STMT_LABEL. */
DEFTREECODE (GOTO_STMT, "goto_stmt", 's', 1)
/* A label: LABEL_STMT_LABEL is the label and LABEL_STMT_FIRST_IN_EH is set
if this is the first label of an exception handler. */
DEFTREECODE (LABEL_STMT, "label_stmt", 's', 1)
/* A "return". RETURN_STMT_EXPR is the value to return if non-null. */
DEFTREECODE (RETURN_STMT, "return_stmt", 's', 1)

12
gcc/ada/ada-tree.h
View File

@ -294,5 +294,15 @@ struct lang_type GTY(())
/* We store the Sloc in statement nodes. */
#define TREE_SLOC(NODE) TREE_COMPLEXITY (STMT_CHECK (NODE))
/* There is just one field in an EXPR_STMT: the expression. */
#define EXPR_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXPR_STMT, 0)
#define BLOCK_STMT_LIST(NODE) TREE_OPERAND_CHECK_CODE (NODE, BLOCK_STMT, 0)
#define IF_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 0)
#define IF_STMT_TRUE(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 1)
#define IF_STMT_ELSEIF(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 2)
#define IF_STMT_ELSE(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 3)
#define GOTO_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, GOTO_STMT, 0)
#define LABEL_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, LABEL_STMT, 0)
#define LABEL_STMT_FIRST_IN_EH(NODE) \
(LABEL_STMT_CHECK (NODE)->common.unsigned_flag)
#define RETURN_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, RETURN_STMT, 0)

2
gcc/ada/atree.ads
View File

@ -495,7 +495,7 @@ package Atree is
function Extend_Node (Node : Node_Id) return Entity_Id;
-- This function returns a copy of its input node with an extension
-- added. The fields of the extension are set to Empty. Due to the way
-- extensions are handled (as two consecutive array elements), it may
-- extensions are handled (as four consecutive array elements), it may
-- be necessary to reallocate the node, so that the returned value is
-- not the same as the input value, but where possible the returned
-- value will be the same as the input value (i.e. the extension will

2
gcc/ada/link.c
View File

@ -156,7 +156,7 @@ const char *object_library_extension = ".a";
#elif defined (__FreeBSD__)
char *object_file_option = "";
char *run_path_option = "";
char *run_path_option = "-Wl,-rpath,";
char shared_libgnat_default = STATIC;
int link_max = 2147483647;
unsigned char objlist_file_supported = 0;

28
gcc/ada/mlib-prj.adb
View File

@ -308,6 +308,9 @@ package body MLib.Prj is
Libdecgnat_Needed : Boolean := False;
-- On OpenVMS, set to True if library needs to be linked with libdecgnat
Check_Libdecgnat : Boolean := Hostparm.OpenVMS;
-- Set to False if package Dec is part of the library sources.
Data : Project_Data := Projects.Table (For_Project);
Object_Directory_Path : constant String :=
@ -372,7 +375,8 @@ package body MLib.Prj is
-- to link with -lgnarl (this is the case when there is a dependency
-- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file
-- indicates that there is a need to link with -ldecgnat (this is the
-- case when there is a dependency on dec.ads).
-- case when there is a dependency on dec.ads, except when it is the
-- DEC library, the one that contains package DEC).
procedure Process (The_ALI : File_Name_Type);
-- Check if the closure of a library unit which is or should be in the
@ -504,12 +508,17 @@ package body MLib.Prj is
Text : Text_Buffer_Ptr;
Id : ALI.ALI_Id;
pragma Warnings (Off, Id);
-- Comment needed ???
begin
-- On OpenVMS, if we have package DEC, it means this is the DEC lib:
-- no need to link with itself.
if Check_Libdecgnat and then ALI_File = "dec.ali" then
Check_Libdecgnat := False;
Libdecgnat_Needed := False;
end if;
if not Libgnarl_Needed or
(Hostparm.OpenVMS and then (not Libdecgnat_Needed))
(Check_Libdecgnat and then (not Libdecgnat_Needed))
then
-- Scan the ALI file
@ -526,7 +535,7 @@ package body MLib.Prj is
Read_Lines => "D");
Free (Text);
-- Look for s-osinte.ads in the dependencies
-- Look for s-osinte.ads and dec.ads in the dependencies
for Index in ALI.ALIs.Table (Id).First_Sdep ..
ALI.ALIs.Table (Id).Last_Sdep
@ -534,7 +543,7 @@ package body MLib.Prj is
if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then
Libgnarl_Needed := True;
elsif Hostparm.OpenVMS and then
elsif Check_Libdecgnat and then
ALI.Sdep.Table (Index).Sfile = S_Dec_Ads
then
Libdecgnat_Needed := True;
@ -1941,7 +1950,10 @@ package body MLib.Prj is
end if;
Status := fclose (Fd);
-- Is it really right to ignore any close error ???
-- It is safe to ignore any error when closing, because the file was
-- only opened for reading.
end Process_Binder_File;
------------------

10
gcc/ada/par.adb
View File

@ -1310,10 +1310,18 @@ begin
and then not GNAT_Mode
then
declare
Name : constant String :=
Uname : constant String :=
Get_Name_String
(Unit_Name (Current_Source_Unit));
Name : String (1 .. Uname'Length - 2);
begin
-- Because Unit_Name includes "%s" or "%b", we need to
-- strip the last two characters to get the real unit
-- name.
Name := Uname (Uname'First .. Uname'Last - 2);
if (Name = "ada" or else
Name = "calendar" or else
Name = "interfaces" or else

3
gcc/ada/s-fileio.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, 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- --
@ -250,7 +250,6 @@ package System.File_IO is
private
pragma Inline (Check_Read_Status);
pragma Inline (Check_Write_Status);
pragma Inline (Form);
pragma Inline (Mode);
end System.File_IO;

28
gcc/ada/sem_ch4.adb
View File

@ -4332,7 +4332,7 @@ package body Sem_Ch4 is
procedure Remove_Abstract_Operations (N : Node_Id) is
I : Interp_Index;
It : Interp;
Has_Abstract_Op : Boolean := False;
Abstract_Op : Entity_Id := Empty;
-- AI-310: If overloaded, remove abstract non-dispatching
-- operations.
@ -4347,7 +4347,7 @@ package body Sem_Ch4 is
and then Is_Abstract (It.Nam)
and then not Is_Dispatching_Operation (It.Nam)
then
Has_Abstract_Op := True;
Abstract_Op := It.Nam;
Remove_Interp (I);
exit;
end if;
@ -4359,7 +4359,7 @@ package body Sem_Ch4 is
-- always added to the overload set, unless it is a universal
-- operation.
if not Has_Abstract_Op then
if No (Abstract_Op) then
return;
elsif Nkind (N) in N_Op then
@ -4398,10 +4398,9 @@ package body Sem_Ch4 is
begin
if Present (Universal_Interpretation (Arg1))
or else
(Present (Next (Arg1))
and then
Present (Universal_Interpretation (Next (Arg1))))
(No (Next (Arg1))
or else Present (Universal_Interpretation (Next (Arg1))))
then
return;
@ -4417,6 +4416,23 @@ package body Sem_Ch4 is
end if;
end;
end if;
-- If the removal has left no valid interpretations, emit
-- error message now an label node as illegal.
if Present (Abstract_Op) then
Get_First_Interp (N, I, It);
if No (It.Nam) then
-- Removal of abstract operation left no viable candidate.
Set_Etype (N, Any_Type);
Error_Msg_Sloc := Sloc (Abstract_Op);
Error_Msg_NE
("cannot call abstract operation& declared#", N, Abstract_Op);
end if;
end if;
end if;
end Remove_Abstract_Operations;

7
gcc/ada/sem_eval.adb
View File

@ -1947,6 +1947,13 @@ package body Sem_Eval is
or else Nkind (Parent (N)) = N_Allocator
then
Check_Non_Static_Context (Operand);
-- If operand is known to raise constraint_error, set the
-- flag on the expression so it does not get optimized away.
if Nkind (Operand) = N_Raise_Constraint_Error then
Set_Raises_Constraint_Error (N);
end if;
return;
end if;

10
gcc/ada/sem_prag.adb
View File

@ -3555,7 +3555,15 @@ package body Sem_Prag is
Set_Is_Public (E);
Set_Is_Statically_Allocated (E);
if Warn_On_Export_Import then
-- Warn if the corresponding W flag is set and the pragma
-- comes from source. The latter may be not be true e.g. on
-- VMS where we expand export pragmas for exception codes
-- associated with imported or exported exceptions. We don't
-- want the user to be warned about something he didn't write.
if Warn_On_Export_Import
and then Comes_From_Source (Arg)
then
Error_Msg_NE
("?& has been made static as a result of Export", Arg, E);
Error_Msg_N

7
gcc/ada/sem_res.adb
View File

@ -4965,6 +4965,7 @@ package body Sem_Res is
end loop;
Set_Entity (N, Op);
Set_Is_Overloaded (N, False);
-- If the operand type is private, rewrite with suitable
-- conversions on the operands and the result, to expose
@ -4993,17 +4994,21 @@ package body Sem_Res is
or else Typ /= Etype (Right_Opnd (N))
then
-- Add explicit conversion where needed, and save interpretations
-- if operands are overloaded.
-- in case operands are overloaded.
Arg1 := Convert_To (Typ, Left_Opnd (N));
Arg2 := Convert_To (Typ, Right_Opnd (N));
if Nkind (Arg1) = N_Type_Conversion then
Save_Interps (Left_Opnd (N), Expression (Arg1));
else
Save_Interps (Left_Opnd (N), Arg1);
end if;
if Nkind (Arg2) = N_Type_Conversion then
Save_Interps (Right_Opnd (N), Expression (Arg2));
else
Save_Interps (Right_Opnd (N), Arg1);
end if;
Rewrite (Left_Opnd (N), Arg1);

50
gcc/ada/sem_util.adb
View File

@ -4985,41 +4985,12 @@ package body Sem_Util is
Ent : Entity_Id;
Exp : Node_Id;
procedure Set_Ref (E : Entity_Id; N : Node_Id);
-- Internal routine to note modification on entity E by node N
-- Has no effect if entity E does not represent an object.
-------------
-- Set_Ref --
-------------
procedure Set_Ref (E : Entity_Id; N : Node_Id) is
begin
if Is_Object (E) then
if Comes_From_Source (N)
or else Modification_Comes_From_Source
then
Set_Never_Set_In_Source (E, False);
end if;
Set_Is_True_Constant (E, False);
Set_Current_Value (E, Empty);
Generate_Reference (E, N, 'm');
Kill_Checks (E);
if not Can_Never_Be_Null (E) then
Set_Is_Known_Non_Null (E, False);
end if;
end if;
end Set_Ref;
-- Start of processing for Note_Possible_Modification
begin
-- Loop to find referenced entity, if there is one
Exp := N;
loop
<<Continue>>
Ent := Empty;
if Is_Entity_Name (Exp) then
@ -5074,10 +5045,14 @@ package body Sem_Util is
-- Now look for entity being referenced
if Present (Ent) then
if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
and then Present (Renamed_Object (Ent))
if Is_Object (Ent) then
if Comes_From_Source (Exp)
or else Modification_Comes_From_Source
then
Set_Never_Set_In_Source (Ent, False);
end if;
Set_Is_True_Constant (Ent, False);
Set_Current_Value (Ent, Empty);
@ -5085,14 +5060,19 @@ package body Sem_Util is
Set_Is_Known_Non_Null (Ent, False);
end if;
if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
and then Present (Renamed_Object (Ent))
then
Exp := Renamed_Object (Ent);
goto Continue;
end if;
Generate_Reference (Ent, Exp, 'm');
end if;
else
Set_Ref (Ent, Exp);
Kill_Checks (Ent);
return;
end if;
end if;
end loop;
end Note_Possible_Modification;

274
gcc/ada/trans.c
View File

@ -104,6 +104,9 @@ Node_Id error_gnat_node;
static GTY(()) tree gnu_return_label_stack;
static tree tree_transform (Node_Id);
static rtx first_nondeleted_insn (rtx);
static tree build_block_stmt (List_Id);
static tree make_expr_stmt_from_rtl (rtx, Node_Id);
static void elaborate_all_entities (Node_Id);
static void process_freeze_entity (Node_Id);
static void process_inlined_subprograms (Node_Id);
@ -255,15 +258,60 @@ tree
gnat_to_gnu (Node_Id gnat_node)
{
tree gnu_root;
bool made_sequence = false;
/* We support the use of this on statements now as a transition
to full function-at-a-time processing. So we need to see if anything
we do generates RTL and returns error_mark_node. */
if (!global_bindings_p ())
{
start_sequence ();
emit_note (NOTE_INSN_DELETED);
made_sequence = true;
}
/* Save node number in case error */
error_gnat_node = gnat_node;
gnu_root = tree_transform (gnat_node);
/* If we got no code as a result, something is wrong. */
if (gnu_root == error_mark_node && ! type_annotate_only)
if (gnu_root == error_mark_node)
{
if (!made_sequence)
{
if (type_annotate_only)
return gnu_root;
else
gigi_abort (303);
}
gnu_root = make_expr_stmt_from_rtl (first_nondeleted_insn (get_insns ()),
gnat_node);
end_sequence ();
}
else if (made_sequence)
{
rtx insns = first_nondeleted_insn (get_insns ());
end_sequence ();
if (insns)
{
/* If we have a statement, we need to first evaluate any RTL we
made in the process of building it and then the statement. */
if (IS_STMT (gnu_root))
{
tree gnu_expr_stmt = make_expr_stmt_from_rtl (insns, gnat_node);
TREE_CHAIN (gnu_expr_stmt) = gnu_root;
gnu_root = build_nt (BLOCK_STMT, gnu_expr_stmt);
TREE_TYPE (gnu_root) = void_type_node;
TREE_SLOC (gnu_root) = Sloc (gnat_node);
}
else
emit_insn (insns);
}
}
return gnu_root;
}
@ -290,6 +338,10 @@ tree_transform (Node_Id gnat_node)
/* Set input_file_name and lineno from the Sloc in the GNAT tree. */
set_lineno (gnat_node, 0);
if (IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
&& type_annotate_only)
return error_mark_node;
/* If this is a Statement and we are at top level, we add the statement
as an elaboration for a null tree. That will cause it to be placed
in the elaboration procedure. */
@ -1795,7 +1847,7 @@ tree_transform (Node_Id gnat_node)
gnu_result_type = get_unpadded_type (Etype (gnat_node));
if (RTL_EXPR_SEQUENCE (gnu_rhs_side) != 0)
if (first_nondeleted_insn (RTL_EXPR_SEQUENCE (gnu_rhs_side)))
gnu_rhs = build (COMPOUND_EXPR, gnu_result_type, gnu_rhs_side,
gnu_rhs);
@ -2020,31 +2072,17 @@ tree_transform (Node_Id gnat_node)
/***************************/
case N_Label:
if (! type_annotate_only)
{
tree gnu_label = gnat_to_gnu (Identifier (gnat_node));
Node_Id gnat_parent = Parent (gnat_node);
expand_label (gnu_label);
/* If this is the first label of an exception handler, we must
mark that any CALL_INSN can jump to it. */
if (Present (gnat_parent)
&& Nkind (gnat_parent) == N_Exception_Handler
&& First (Statements (gnat_parent)) == gnat_node)
nonlocal_goto_handler_labels
= gen_rtx_EXPR_LIST (VOIDmode, label_rtx (gnu_label),
nonlocal_goto_handler_labels);
}
gnu_result = build_nt (LABEL_STMT, gnat_to_gnu (Identifier (gnat_node)));
LABEL_STMT_FIRST_IN_EH (gnu_result)
= (Present (Parent (gnat_node))
&& Nkind (Parent (gnat_node)) == N_Exception_Handler
&& First (Statements (Parent (gnat_node))) == gnat_node);
break;
case N_Null_Statement:
break;
case N_Assignment_Statement:
if (type_annotate_only)
break;
/* Get the LHS and RHS of the statement and convert any reference to an
unconstrained array into a reference to the underlying array. */
gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
@ -2071,53 +2109,28 @@ tree_transform (Node_Id gnat_node)
break;
case N_If_Statement:
/* Start an IF statement giving the condition. */
gnu_expr = gnat_to_gnu (Condition (gnat_node));
set_lineno (gnat_node, 1);
expand_start_cond (gnu_expr, 0);
gnu_result = NULL_TREE;
/* Generate code for the statements to be executed if the condition
is true. */
for (gnat_temp = First (Then_Statements (gnat_node));
Present (gnat_temp);
gnat_temp = Next (gnat_temp))
gnat_to_code (gnat_temp);
/* Generate each of the "else if" parts. */
/* Make an IF_STMT for each of the "else if" parts. */
if (Present (Elsif_Parts (gnat_node)))
{
for (gnat_temp = First (Elsif_Parts (gnat_node));
Present (gnat_temp);
gnat_temp = Next (gnat_temp))
Present (gnat_temp); gnat_temp = Next (gnat_temp))
{
Node_Id gnat_statement;
tree gnu_elseif
= build_nt (IF_STMT, gnat_to_gnu (Condition (gnat_temp)),
build_block_stmt (Then_Statements (gnat_temp)),
NULL_TREE, NULL_TREE);
expand_start_else ();
/* Set up the line numbers for each condition we test. */
set_lineno (Condition (gnat_temp), 1);
expand_elseif (gnat_to_gnu (Condition (gnat_temp)));
for (gnat_statement = First (Then_Statements (gnat_temp));
Present (gnat_statement);
gnat_statement = Next (gnat_statement))
gnat_to_code (gnat_statement);
}
TREE_SLOC (gnu_elseif) = Sloc (Condition (gnat_temp));
TREE_CHAIN (gnu_elseif) = gnu_result;
TREE_TYPE (gnu_elseif) = void_type_node;
gnu_result = gnu_elseif;
}
/* Finally, handle any statements in the "else" part. */
if (Present (Else_Statements (gnat_node)))
{
expand_start_else ();
for (gnat_temp = First (Else_Statements (gnat_node));
Present (gnat_temp);
gnat_temp = Next (gnat_temp))
gnat_to_code (gnat_temp);
}
expand_end_cond ();
gnu_result = build_nt (IF_STMT, gnat_to_gnu (Condition (gnat_node)),
build_block_stmt (Then_Statements (gnat_node)),
nreverse (gnu_result),
build_block_stmt (Else_Statements (gnat_node)));
break;
case N_Case_Statement:
@ -2456,9 +2469,6 @@ tree_transform (Node_Id gnat_node)
break;
case N_Return_Statement:
if (type_annotate_only)
break;
{
/* The gnu function type of the subprogram currently processed. */
tree gnu_subprog_type = TREE_TYPE (current_function_decl);
@ -2478,7 +2488,11 @@ tree_transform (Node_Id gnat_node)
a branch to that label. */
if (TREE_VALUE (gnu_return_label_stack) != 0)
expand_goto (TREE_VALUE (gnu_return_label_stack));
{
gnu_result = build_nt (GOTO_STMT,
TREE_VALUE (gnu_return_label_stack));
break;
}
else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
{
@ -2538,25 +2552,12 @@ tree_transform (Node_Id gnat_node)
}
}
set_lineno (gnat_node, 1);
if (gnu_ret_val)
expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE,
DECL_RESULT (current_function_decl),
gnu_ret_val));
else
expand_null_return ();
gnu_result = build_nt (RETURN_STMT, gnu_ret_val);
}
break;
case N_Goto_Statement:
if (type_annotate_only)
break;
gnu_expr = gnat_to_gnu (Name (gnat_node));
TREE_USED (gnu_expr) = 1;
set_lineno (gnat_node, 1);
expand_goto (gnu_expr);
gnu_result = build_nt (GOTO_STMT, gnat_to_gnu (Name (gnat_node)));
break;
/****************************/
@ -4174,11 +4175,69 @@ tree_transform (Node_Id gnat_node)
return gnu_result;
}
/* INSN is a list of insns. Return the first rtl in the list that isn't
an INSN_NOTE_DELETED. */
static rtx
first_nondeleted_insn (rtx insns)
{
for (; insns && GET_CODE (insns) == NOTE
&& NOTE_LINE_NUMBER (insns) == NOTE_INSN_DELETED;
insns = NEXT_INSN (insns))
;
return insns;
}
/* Build a BLOCK_STMT from GNAT_LIST, a possibly-empty list of statements. */
static tree
build_block_stmt (List_Id gnat_list)
{
tree gnu_result = NULL_TREE;
Node_Id gnat_node;
if (No (gnat_list) || Is_Empty_List (gnat_list))
return NULL_TREE;
for (gnat_node = First (gnat_list);
Present (gnat_node);
gnat_node = Next (gnat_node))
gnu_result = chainon (gnat_to_gnu (gnat_node), gnu_result);
gnu_result = build_nt (BLOCK_STMT, nreverse (gnu_result));
TREE_SLOC (gnu_result) = TREE_SLOC (BLOCK_STMT_LIST (gnu_result));
TREE_TYPE (gnu_result) = void_type_node;
return gnu_result;
}
/* Build an EXPR_STMT to evaluate INSNS. Use Sloc from GNAT_NODE. */
static tree
make_expr_stmt_from_rtl (rtx insns, Node_Id gnat_node)
{
tree gnu_result = make_node (RTL_EXPR);
TREE_TYPE (gnu_result) = void_type_node;
RTL_EXPR_RTL (gnu_result) = RTL_EXPR_ALT_RTL (gnu_result) = const0_rtx;
RTL_EXPR_SEQUENCE (gnu_result) = insns;
rtl_expr_chain = tree_cons (NULL_TREE, gnu_result, rtl_expr_chain);
gnu_result = build_nt (EXPR_STMT, gnu_result);
TREE_SLOC (gnu_result) = Sloc (gnat_node);
TREE_TYPE (gnu_result) = void_type_node;
return gnu_result;
}
/* GNU_STMT is a statement. We generate code for that statement. */
void
gnat_expand_stmt (tree gnu_stmt)
{
tree gnu_elmt;
if (TREE_SLOC (gnu_stmt))
set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1);
switch (TREE_CODE (gnu_stmt))
@ -4187,6 +4246,59 @@ gnat_expand_stmt (tree gnu_stmt)
expand_expr_stmt (EXPR_STMT_EXPR (gnu_stmt));
break;
case BLOCK_STMT:
for (gnu_elmt = BLOCK_STMT_LIST (gnu_stmt); gnu_elmt;
gnu_elmt = TREE_CHAIN (gnu_elmt))
expand_expr_stmt (gnu_elmt);
break;
case IF_STMT:
expand_start_cond (IF_STMT_COND (gnu_stmt), 0);
if (IF_STMT_TRUE (gnu_stmt))
expand_expr_stmt (IF_STMT_TRUE (gnu_stmt));
for (gnu_elmt = IF_STMT_ELSEIF (gnu_stmt); gnu_elmt;
gnu_elmt = TREE_CHAIN (gnu_elmt))
{
expand_start_else ();
set_lineno_from_sloc (TREE_SLOC (gnu_elmt), 1);
expand_elseif (IF_STMT_COND (gnu_elmt));
expand_expr_stmt (IF_STMT_TRUE (gnu_elmt));
}
if (IF_STMT_ELSE (gnu_stmt))
{
expand_start_else ();
expand_expr_stmt (IF_STMT_ELSE (gnu_stmt));
}
expand_end_cond ();
break;
case GOTO_STMT:
TREE_USED (GOTO_STMT_LABEL (gnu_stmt)) = 1;
expand_goto (GOTO_STMT_LABEL (gnu_stmt));
break;
case LABEL_STMT:
expand_label (LABEL_STMT_LABEL (gnu_stmt));
if (LABEL_STMT_FIRST_IN_EH (gnu_stmt))
nonlocal_goto_handler_labels
= gen_rtx_EXPR_LIST (VOIDmode,
label_rtx (LABEL_STMT_LABEL (gnu_stmt)),
nonlocal_goto_handler_labels);
break;
case RETURN_STMT:
if (RETURN_STMT_EXPR (gnu_stmt))
expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE,
DECL_RESULT (current_function_decl),
RETURN_STMT_EXPR (gnu_stmt)));
else
expand_null_return ();
break;
default:
abort ();
}

6
gcc/ada/utils.c
View File

@ -2069,7 +2069,11 @@ float_type_for_precision (int precision, enum machine_mode mode)
tree
gnat_type_for_mode (enum machine_mode mode, int unsignedp)
{
if (GET_MODE_CLASS (mode) == MODE_FLOAT)
if (mode == BLKmode)
return NULL_TREE;
else if (mode == VOIDmode)
return void_type_node;
else if (GET_MODE_CLASS (mode) == MODE_FLOAT)
return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
else
return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);