[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

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);
 

gcc/ada/ChangeLog

+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.

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)

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)
+

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

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;

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;
 
    ------------------

gcc/ada/par.adb

@@ -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

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;

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))))
+                   (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;
 

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;
 

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

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));
          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);

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))
+
+            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;
 

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)
+  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))
-	    {
-	      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)))
+	     Present (gnat_temp); gnat_temp = Next (gnat_temp))
 	  {
-	  expand_start_else ();
+	    tree gnu_elseif
+	      = build_nt (IF_STMT, gnat_to_gnu (Condition (gnat_temp)),
+			  build_block_stmt (Then_Statements (gnat_temp)),
+			  NULL_TREE, NULL_TREE);
 
-	  for (gnat_temp = First (Else_Statements (gnat_node));
-	       Present (gnat_temp);
-	       gnat_temp = Next (gnat_temp))
-	    gnat_to_code (gnat_temp);
+	    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,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 ();
     }

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);