aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
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);
generated by cgit v1.1 at 2024-08-30 02:15:13 +0000