aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@gcc.gnu.org>2004-04-08 15:23:50 +0200
committerArnaud Charlet <charlet@gcc.gnu.org>2004-04-08 15:23:50 +0200
commitaf15298919fc249fc35fc33144271c560c74939c (patch)
tree98ecce319b28000f5041a6bf64ba3936cb69b73c /gcc/ada
parent2897f1d41141d67398e0647d9713d690c4368959 (diff)
downloadgcc-af15298919fc249fc35fc33144271c560c74939c.zip
gcc-af15298919fc249fc35fc33144271c560c74939c.tar.gz
gcc-af15298919fc249fc35fc33144271c560c74939c.tar.bz2
[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
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/5vml-tgt.adb22
-rw-r--r--gcc/ada/ChangeLog83
-rw-r--r--gcc/ada/ada-tree.def24
-rw-r--r--gcc/ada/ada-tree.h12
-rw-r--r--gcc/ada/atree.ads2
-rw-r--r--gcc/ada/link.c2
-rw-r--r--gcc/ada/mlib-prj.adb28
-rw-r--r--gcc/ada/par.adb26
-rw-r--r--gcc/ada/s-fileio.ads3
-rw-r--r--gcc/ada/sem_ch4.adb30
-rw-r--r--gcc/ada/sem_eval.adb7
-rw-r--r--gcc/ada/sem_prag.adb10
-rw-r--r--gcc/ada/sem_res.adb9
-rw-r--r--gcc/ada/sem_util.adb58
-rw-r--r--gcc/ada/trans.c286
-rw-r--r--gcc/ada/utils.c6
16 files changed, 434 insertions, 174 deletions
diff --git a/gcc/ada/5vml-tgt.adb b/gcc/ada/5vml-tgt.adb
index f747922..851ccf7 100644
--- a/gcc/ada/5vml-tgt.adb
+++ b/gcc/ada/5vml-tgt.adb
@@ -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);
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5ca1aeb..0a24bc0 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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.
diff --git a/gcc/ada/ada-tree.def b/gcc/ada/ada-tree.def
index 08a69ac..e58963e 100644
--- a/gcc/ada/ada-tree.def
+++ b/gcc/ada/ada-tree.def
@@ -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)
diff --git a/gcc/ada/ada-tree.h b/gcc/ada/ada-tree.h
index aa256dc..572a5b7 100644
--- a/gcc/ada/ada-tree.h
+++ b/gcc/ada/ada-tree.h
@@ -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)
+
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index 501c183..0f38e3e 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -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
diff --git a/gcc/ada/link.c b/gcc/ada/link.c
index dd20d03..e16978e 100644
--- a/gcc/ada/link.c
+++ b/gcc/ada/link.c
@@ -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;
diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb
index 4b82ffa..612845c 100644
--- a/gcc/ada/mlib-prj.adb
+++ b/gcc/ada/mlib-prj.adb
@@ -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;
------------------
diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb
index dbec0b8..2d86577 100644
--- a/gcc/ada/par.adb
+++ b/gcc/ada/par.adb
@@ -1310,16 +1310,24 @@ begin
and then not GNAT_Mode
then
declare
- Name : constant String :=
- Get_Name_String
- (Unit_Name (Current_Source_Unit));
+ Uname : constant String :=
+ Get_Name_String
+ (Unit_Name (Current_Source_Unit));
+ Name : String (1 .. Uname'Length - 2);
+
begin
- if (Name = "ada" or else
- Name = "calendar" or else
- Name = "interfaces" or else
- Name = "system" or else
- Name = "machine_code" or else
- Name = "unchecked_conversion" or else
+ -- 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
+ Name = "system" or else
+ Name = "machine_code" or else
+ Name = "unchecked_conversion" or else
Name = "unchecked_deallocation"
or else (Name'Length > 4
and then
diff --git a/gcc/ada/s-fileio.ads b/gcc/ada/s-fileio.ads
index fe06807..dbbc8bf 100644
--- a/gcc/ada/s-fileio.ads
+++ b/gcc/ada/s-fileio.ads
@@ -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;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 9388125..2b958a8 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -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))))
+ and then
+ (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;
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index f884854..9c20310 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -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;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 3c8ca3d..ea1eab3 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -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
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index c05b81b..103ebfd 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -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));
+ 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);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 578c934..a3adc6e 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -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))
- then
- Set_Never_Set_In_Source (Ent, False);
+
+ 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,13 +5060,18 @@ package body Sem_Util is
Set_Is_Known_Non_Null (Ent, False);
end if;
- Exp := Renamed_Object (Ent);
+ 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;
- else
- Set_Ref (Ent, Exp);
- Kill_Checks (Ent);
- return;
+ Generate_Reference (Ent, Exp, 'm');
end if;
+
+ Kill_Checks (Ent);
+ return;
end if;
end loop;
end Note_Possible_Modification;
diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c
index efa99fe..8b24761 100644
--- a/gcc/ada/trans.c
+++ b/gcc/ada/trans.c
@@ -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)
- gigi_abort (303);
+ 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);
-
- /* Generate code for the statements to be executed if the condition
- is true. */
+ gnu_result = NULL_TREE;
- 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))
- {
- Node_Id gnat_statement;
-
- 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);
- }
- }
-
- /* 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);
- }
+ for (gnat_temp = First (Elsif_Parts (gnat_node));
+ Present (gnat_temp); gnat_temp = Next (gnat_temp))
+ {
+ tree gnu_elseif
+ = build_nt (IF_STMT, gnat_to_gnu (Condition (gnat_temp)),
+ build_block_stmt (Then_Statements (gnat_temp)),
+ NULL_TREE, NULL_TREE);
+
+ 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;
+ }
- 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,12 +4175,70 @@ 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)
{
- set_lineno_from_sloc (TREE_SLOC (gnu_stmt), 1);
+ 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 ();
}
diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c
index 1cefff8..8b0bf81 100644
--- a/gcc/ada/utils.c
+++ b/gcc/ada/utils.c
@@ -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);