[multiple changes]

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

	* adaint.h, adaint.c: Add function __gnat_named_file_length

	* impunit.adb: Add Ada.Directories to the list

	* Makefile.in: Add VMS and Windows versions of
	Ada.Directories.Validity package body.

	* Makefile.rtl: Add a-direct and a-dirval

	* mlib-tgt.ads: Minor comment update.

	* a-dirval.ads, a-dirval.adb, 5vdirval.adb, 5wdirval.adb,
	a-direct.ads, a-direct.adb: New files.

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

	PR ada/13620
	* make.adb (Scan_Make_Arg): Pass any -fxxx switches to gnatlink, not
	just to the compiler.

2004-04-05  Robert Dewar  <dewar@gnat.com>

	* a-except.adb (Exception_Name_Simple): Make sure lower bound of
	returned string is 1.

	* ali-util.adb: Use proper specific form for Warnings (Off, entity)

	* eval_fat.ads: Minor reformatting

	* g-curexc.ads: Document that lower bound of returned string values
	is always one.

	* gnatlink.adb: Add ??? comment for previous change
	(need to document why this is VMS specific)

	* s-stoele.ads: Minor reformatting

	* tbuild.ads: Minor reformatting throughout (new function specs)

	* par-ch10.adb (P_Context_Clause): Handle comma instead of semicolon
	after WITH.

	* scng.adb: Minor reformatting

2004-04-05  Geert Bosch  <bosch@gnat.com>

	* eval_fat.adb (Machine): Remove unnecessary suppression of warning.
	(Leading_Part): Still perform truncation to machine number if the
	specified radix_digits is greater or equal to machine_mantissa.

2004-04-05  Javier Miranda  <miranda@gnat.com>

	* par-ch3.adb: Complete documentation of previous change
	Correct wrong syntax documentation of the OBJECT_DECLARATION rule
	(aliased must appear before constant).

	* par-ch4.adb: Complete documentation of previous change.

	* par-ch6.adb: Complete documentation of previous change.

	* sinfo.ads: Fix typo in commment.

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

	* sem_ch3.adb (Inherit_Components): If derived type is private and has
	stored discriminants, use its discriminants to constrain parent type,
	as is done for non-private derived record types.

	* sem_ch4.adb (Remove_Abstract_Operations): New subprogram to implement
	Ada 2005 AI-310: an abstract non-dispatching operation is not a
	candidate interpretation in an overloaded call.

	* tbuild.adb (Unchecked_Convert_To): Preserve conversion node if
	expression is Null and target type is not an access type (e.g. a
	non-private address type).

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

	* exp_ch6.adb (Rewrite_Function_Call): When rewriting an assignment
	statement whose right-hand side is an inlined call, save a copy of the
	original assignment subtree to preserve enough consistency for
	Analyze_Assignment to proceed.

	* sem_ch5.adb (Analyze_Assignment): Remove a costly copy of the
	complete assignment subtree which is now unnecessary, as the expansion
	of inlined call has been improved to preserve a consistent assignment
	tree.  Note_Possible_Modification must be called only
	after checks have been applied, or else unnecessary checks will
	be generated.

	* sem_util.adb (Note_Possible_Modification): Reorganise the handling
	of explicit dereferences that do not Come_From_Source:
	 - be selective on cases where we must go back to the dereferenced
	   pointer (an assignment to an implicit dereference must not be
	   recorded as modifying the pointer);
	 - do not rely on Original_Node being present (Analyze_Assignment
	   calls Note_Possible_Modification on a copied tree).

	* sem_warn.adb (Check_References): When an unset reference to a pointer
	that is never assigned is encountered, prefer '<pointer> may be null'
	warning over '<pointer> is never assigned a value'.

2004-04-05  Ramon Fernandez  <fernandez@gnat.com>

	* tracebak.c: Change STOP_FRAME in ppc vxworks to be compliant with
	the ABI.

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

	* 5gmastop.adb (Pop_Frame): Comment out the pragma Linker_Option for
	libexc. We currently don't reference anything in this library and
	linking it in triggers linker warnings we don't want to see.

	* init.c: Update comments.

From-SVN: r80431

gcc/ada/5gmastop.adb

@@ -292,15 +292,6 @@ package body System.Machine_State_Operations is
 
       procedure Exc_Unwind (Scp : Sigcontext_Ptr; Fde : Long_Integer := 0);
       pragma Import (C, Exc_Unwind, "exc_unwind");
-      pragma Linker_Options ("-lexc");
-
-   begin
-      --  exc_unwind is apparently not thread-safe under IRIX, so protect it
-      --  against race conditions within the GNAT run time.
-      --  ??? Note that we might want to use a fine grained lock here since
-      --  Lock_Task is used in many other places.
-
-      Lock_Task.all;
 
       --  ??? Calling exc_unwind in the current setup does not work and
       --  triggers the emission of system warning messages. Why it does
@@ -312,7 +303,19 @@ package body System.Machine_State_Operations is
       --  occurred and failed.
 
       --  ??? Until this is fixed, we shall document that the backtrace
-      --  computation facility does not work.
+      --  computation facility does not work, and we inhibit the pragma below
+      --  because we arrange for the call not to be emitted and the linker
+      --  complains when a library is linked in but resolves nothing.
+
+      --  pragma Linker_Options ("-lexc");
+
+   begin
+      --  exc_unwind is apparently not thread-safe under IRIX, so protect it
+      --  against race conditions within the GNAT run time.
+      --  ??? Note that we might want to use a fine grained lock here since
+      --  Lock_Task is used in many other places.
+
+      Lock_Task.all;
 
       if False then
          Exc_Unwind (Scp);

gcc/ada/5vdirval.adb

@@ -0,0 +1,175 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--             A D A . D I R E C T O R I E S . V A L I D I T Y              --
+--                                                                          --
+--                                 B o d y                                  --
+--                              (VMS Version)                               --
+--                                                                          --
+--          Copyright (C) 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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- As a special exception,  if other files  instantiate  generics from this --
+-- unit, or you link  this unit with other files  to produce an executable, --
+-- this  unit  does not  by itself cause  the resulting  executable  to  be --
+-- covered  by the  GNU  General  Public  License.  This exception does not --
+-- however invalidate  any other reasons why  the executable file  might be --
+-- covered by the  GNU Public License.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the OpenVMS version of this package
+
+package body Ada.Directories.Validity is
+
+   Max_Number_Of_Characters : constant := 39;
+   Max_Path_Length          : constant := 1_024;
+
+   Invalid_Character : constant array (Character) of Boolean :=
+                         ('a' .. 'z' => False,
+                          'A' .. 'Z' => False,
+                          '_' | '$' | '-' | '.' => False,
+                          others => True);
+
+   ------------------------
+   -- Is_Valid_Path_Name --
+   ------------------------
+
+   function Is_Valid_Path_Name (Name : String) return Boolean is
+      First     : Positive := Name'First;
+      Last      : Positive;
+      Dot_Found : Boolean := False;
+
+   begin
+      --  A valid path (directory) name cannot be empty, and cannot contain
+      --  more than 1024 characters. Directories can be ".", ".." or be simple
+      --  name without extensions.
+
+      if Name'Length = 0 or else Name'Length > Max_Path_Length then
+         return False;
+
+      else
+         loop
+            --  Look for the start of the next directory or file name
+
+            while First <= Name'Last and then Name (First) = '/' loop
+               First := First + 1;
+            end loop;
+
+            --  If all directories/file names are OK, return True
+
+            exit when First > Name'Last;
+
+            Last := First;
+            Dot_Found := False;
+
+            --  Look for the end of the directory/file name
+
+            while Last < Name'Last loop
+               exit when Name (Last + 1) = '/';
+               Last := Last + 1;
+
+               if Name (Last) = '.' then
+                  Dot_Found := True;
+               end if;
+            end loop;
+
+            --  If name include a dot, it can only be ".", ".." or a the last
+            --  file name.
+
+            if Dot_Found then
+               if Name (First .. Last) /= "." and then
+                  Name (First .. Last) /= ".."
+               then
+                  return Last = Name'Last
+                    and then Is_Valid_Simple_Name (Name (First .. Last));
+
+               end if;
+
+            --  Check if the directory/file name is valid
+
+            elsif not Is_Valid_Simple_Name (Name (First .. Last)) then
+                  return False;
+            end if;
+
+            --  Move to the next name
+
+            First := Last + 1;
+         end loop;
+      end if;
+
+      --  If Name follows the rules, then it is valid
+
+      return True;
+   end Is_Valid_Path_Name;
+
+   --------------------------
+   -- Is_Valid_Simple_Name --
+   --------------------------
+
+   function Is_Valid_Simple_Name (Name : String) return Boolean is
+      In_Extension         : Boolean := False;
+      Number_Of_Characters : Natural := 0;
+
+   begin
+      --  A file name cannot be empty, and cannot have more than 39 characters
+      --  before or after a single '.'.
+
+      if Name'Length = 0 then
+         return False;
+
+      else
+         --  Check each character for validity
+
+         for J in Name'Range loop
+            if Invalid_Character (Name (J)) then
+               return False;
+
+            elsif Name (J) = '.' then
+
+               --  Name cannot contain several dots
+
+               if In_Extension then
+                  return False;
+
+               else
+                  --  Reset the number of characters to count the characters
+                  --  of the extension.
+
+                  In_Extension := True;
+                  Number_Of_Characters := 0;
+               end if;
+
+            else
+               --  Check that the number of character is not too large
+
+               Number_Of_Characters := Number_Of_Characters + 1;
+
+               if Number_Of_Characters > Max_Number_Of_Characters then
+                  return False;
+               end if;
+            end if;
+         end loop;
+      end if;
+
+      --  If the rules are followed, then it is valid
+
+      return True;
+   end Is_Valid_Simple_Name;
+
+end Ada.Directories.Validity;
+

gcc/ada/5wdirval.adb

@@ -0,0 +1,142 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--             A D A . D I R E C T O R I E S . V A L I D I T Y              --
+--                                                                          --
+--                                 B o d y                                  --
+--                            (Windows Version)                             --
+--                                                                          --
+--          Copyright (C) 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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- As a special exception,  if other files  instantiate  generics from this --
+-- unit, or you link  this unit with other files  to produce an executable, --
+-- this  unit  does not  by itself cause  the resulting  executable  to  be --
+-- covered  by the  GNU  General  Public  License.  This exception does not --
+-- however invalidate  any other reasons why  the executable file  might be --
+-- covered by the  GNU Public License.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the Windows version of this package
+
+with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
+
+package body Ada.Directories.Validity is
+
+   Invalid_Character : constant array (Character) of Boolean :=
+                         (NUL .. US             => True,
+                          '/' | ':' | '*' | '?' => True,
+                          '"' | '<' | '>' | '|' => True,
+                          DEL .. NBSP           => True,
+                          others                => False);
+
+   ------------------------
+   -- Is_Valid_Path_Name --
+   ------------------------
+
+   function Is_Valid_Path_Name (Name : String) return Boolean is
+      Start : Positive := Name'First;
+      Last  : Natural;
+   begin
+      --  A path name cannot be empty, cannot contain more than 256 characters,
+      --  cannot contain invalid characters and each directory/file name need
+      --  to be valid.
+
+      if Name'Length = 0 or else Name'Length > 256 then
+         return False;
+
+      else
+         --  A drive letter may be specified at the beginning
+
+         if Name'Length >= 2
+           and then  Name (Start + 1) = ':'
+           and then
+            (Name (Start) in 'A' .. 'Z' or else
+             Name (Start) in 'a' .. 'z')
+         then
+            Start := Start + 2;
+         end if;
+
+         loop
+            --  Look for the start of the next directory or file name
+
+            while Start <= Name'Last and then Name (Start) = '\' loop
+               Start := Start + 1;
+            end loop;
+
+            --  If all directories/file names are OK, return True
+
+            exit when Start > Name'Last;
+
+            Last := Start;
+
+            --  Look for the end of the directory/file name
+
+            while Last < Name'Last loop
+               exit when Name (Last + 1) = '\';
+               Last := Last + 1;
+            end loop;
+
+            --  Check if the directory/file name is valid
+
+            if not Is_Valid_Simple_Name (Name (Start .. Last)) then
+                  return False;
+            end if;
+
+            --  Move to the next name
+
+            Start := Last + 1;
+         end loop;
+      end if;
+
+      --  If Name follows the rules, it is valid
+
+      return True;
+   end Is_Valid_Path_Name;
+
+   --------------------------
+   -- Is_Valid_Simple_Name --
+   --------------------------
+
+   function Is_Valid_Simple_Name (Name : String) return Boolean is
+      Only_Spaces : Boolean := True;
+   begin
+      --  A file name cannot be empty, cannot contain more than 256 characters,
+      --  and cannot contain invalid characters, including '\'
+
+      if Name'Length = 0 or else Name'Length > 256 then
+         return False;
+
+      else
+         for J in Name'Range loop
+            if Invalid_Character (Name (J)) or else Name (J) = '\' then
+               return False;
+
+            elsif Name (J) /= ' ' then
+               Only_Spaces := False;
+            end if;
+         end loop;
+      end if;
+
+      --  If Name follows the rules, it is valid
+
+      return not Only_Spaces;
+   end Is_Valid_Simple_Name;
+
+end Ada.Directories.Validity;
+

gcc/ada/ChangeLog

@@ -1,3 +1,120 @@
+2004-04-05  Vincent Celier  <celier@gnat.com>
+
+	* adaint.h, adaint.c: Add function __gnat_named_file_length
+
+	* impunit.adb: Add Ada.Directories to the list
+
+	* Makefile.in: Add VMS and Windows versions of
+	Ada.Directories.Validity package body.
+
+	* Makefile.rtl: Add a-direct and a-dirval
+
+	* mlib-tgt.ads: Minor comment update.
+
+	* a-dirval.ads, a-dirval.adb, 5vdirval.adb, 5wdirval.adb,
+	a-direct.ads, a-direct.adb: New files.
+
+2004-04-05  Vincent Celier  <celier@gnat.com>
+
+	PR ada/13620
+	* make.adb (Scan_Make_Arg): Pass any -fxxx switches to gnatlink, not
+	just to the compiler.
+
+2004-04-05  Robert Dewar  <dewar@gnat.com>
+
+	* a-except.adb (Exception_Name_Simple): Make sure lower bound of
+	returned string is 1.
+
+	* ali-util.adb: Use proper specific form for Warnings (Off, entity)
+
+	* eval_fat.ads: Minor reformatting
+
+	* g-curexc.ads: Document that lower bound of returned string values
+	is always one.
+
+	* gnatlink.adb: Add ??? comment for previous change
+	(need to document why this is VMS specific)
+
+	* s-stoele.ads: Minor reformatting
+
+	* tbuild.ads: Minor reformatting throughout (new function specs)
+
+	* par-ch10.adb (P_Context_Clause): Handle comma instead of semicolon
+	after WITH.
+
+	* scng.adb: Minor reformatting
+
+2004-04-05  Geert Bosch  <bosch@gnat.com>
+
+	* eval_fat.adb (Machine): Remove unnecessary suppression of warning.
+	(Leading_Part): Still perform truncation to machine number if the
+	specified radix_digits is greater or equal to machine_mantissa.
+
+2004-04-05  Javier Miranda  <miranda@gnat.com>
+
+	* par-ch3.adb: Complete documentation of previous change
+	Correct wrong syntax documentation of the OBJECT_DECLARATION rule
+	(aliased must appear before constant).
+
+	* par-ch4.adb: Complete documentation of previous change.
+
+	* par-ch6.adb: Complete documentation of previous change.
+
+	* sinfo.ads: Fix typo in commment.
+
+2004-04-05  Ed Schonberg  <schonberg@gnat.com>
+
+	* sem_ch3.adb (Inherit_Components): If derived type is private and has
+	stored discriminants, use its discriminants to constrain parent type,
+	as is done for non-private derived record types.
+
+	* sem_ch4.adb (Remove_Abstract_Operations): New subprogram to implement
+	Ada 2005 AI-310: an abstract non-dispatching operation is not a
+	candidate interpretation in an overloaded call.
+
+	* tbuild.adb (Unchecked_Convert_To): Preserve conversion node if
+	expression is Null and target type is not an access type (e.g. a
+	non-private address type).
+
+2004-04-05  Thomas Quinot  <quinot@act-europe.fr>
+
+	* exp_ch6.adb (Rewrite_Function_Call): When rewriting an assignment
+	statement whose right-hand side is an inlined call, save a copy of the
+	original assignment subtree to preserve enough consistency for
+	Analyze_Assignment to proceed.
+
+	* sem_ch5.adb (Analyze_Assignment): Remove a costly copy of the
+	complete assignment subtree which is now unnecessary, as the expansion
+	of inlined call has been improved to preserve a consistent assignment
+	tree.  Note_Possible_Modification must be called only
+	after checks have been applied, or else unnecessary checks will
+	be generated.
+
+	* sem_util.adb (Note_Possible_Modification): Reorganise the handling
+	of explicit dereferences that do not Come_From_Source:
+	 - be selective on cases where we must go back to the dereferenced
+	   pointer (an assignment to an implicit dereference must not be
+	   recorded as modifying the pointer);
+	 - do not rely on Original_Node being present (Analyze_Assignment
+	   calls Note_Possible_Modification on a copied tree).
+
+	* sem_warn.adb (Check_References): When an unset reference to a pointer
+	that is never assigned is encountered, prefer '<pointer> may be null'
+	warning over '<pointer> is never assigned a value'.
+
+2004-04-05  Ramon Fernandez  <fernandez@gnat.com>
+
+	* tracebak.c: Change STOP_FRAME in ppc vxworks to be compliant with
+	the ABI.
+
+2004-04-05  Olivier Hainque  <hainque@act-europe.fr>
+
+	* 5gmastop.adb (Pop_Frame): Comment out the pragma Linker_Option for
+	libexc. We currently don't reference anything in this library and
+	linking it in triggers linker warnings we don't want to see.
+
+	* init.c: Update comments.
+
 2004-04-05  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>
 
 	* decl.c (gnat_to_gnu_entity): Use TYPE_READONLY.

gcc/ada/Makefile.in

@@ -1178,6 +1178,7 @@ endif
   a-caldel.adb<4vcaldel.adb \
   a-calend.adb<4vcalend.adb \
   a-calend.ads<4vcalend.ads \
+  a-dirval.adb<5vdirval.adb \
   a-excpol.adb<4wexcpol.adb \
   a-intnam.ads<4vintnam.ads \
   a-numaux.ads<4vnumaux.ads \
@@ -1227,6 +1228,7 @@ endif
 ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
   LIBGNAT_TARGET_PAIRS = \
   a-calend.adb<4wcalend.adb \
+  a-dirval.adb<5wdirval.adb \
   a-excpol.adb<4wexcpol.adb \
   a-intnam.ads<4wintnam.ads \
   a-numaux.adb<86numaux.adb \

gcc/ada/Makefile.rtl

@@ -85,7 +85,9 @@ GNATRTL_NONTASKING_OBJS= \
   a-cwila9$(objext) \
   a-decima$(objext) \
   a-diocst$(objext) \
+  a-direct$(objext) \
   a-direio$(objext) \
+  a-dirval$(objext) \
   a-einuoc$(objext) \
   a-elchha$(objext) \
   a-except$(objext) \

gcc/ada/a-direct.adb

@@ -0,0 +1,926 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--                      A D A . D I R E C T O R I E S                       --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- As a special exception,  if other files  instantiate  generics from this --
+-- unit, or you link  this unit with other files  to produce an executable, --
+-- this  unit  does not  by itself cause  the resulting  executable  to  be --
+-- covered  by the  GNU  General  Public  License.  This exception does not --
+-- however invalidate  any other reasons why  the executable file  might be --
+-- covered by the  GNU Public License.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Directories.Validity; use Ada.Directories.Validity;
+with Ada.Strings.Unbounded;    use Ada.Strings.Unbounded;
+with Ada.Unchecked_Deallocation;
+
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.OS_Lib;               use GNAT.OS_Lib;
+with GNAT.Regexp;               use GNAT.Regexp;
+
+with System;
+
+package body Ada.Directories is
+
+   type Search_Data is record
+      Is_Valid : Boolean := False;
+      Name     : Ada.Strings.Unbounded.Unbounded_String;
+      Pattern  : Regexp;
+      Filter   : Filter_Type;
+      Dir      : Dir_Type;
+      Entry_Fetched : Boolean := False;
+      Dir_Entry     : Directory_Entry_Type;
+   end record;
+
+   Empty_String : constant String := (1 .. 0 => ASCII.NUL);
+
+   procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
+
+   function File_Exists (Name : String) return Boolean;
+   --  Returns True if the named file exists.
+
+   procedure Fetch_Next_Entry (Search : Search_Type);
+   --  Get the next entry in a directory, setting Entry_Fetched if successful
+   --  or resetting Is_Valid if not.
+
+   ---------------
+   -- Base_Name --
+   ---------------
+
+   function Base_Name (Name : String) return String is
+      Simple : constant String := Simple_Name (Name);
+      --  Simple'First is guaranteed to be 1
+
+   begin
+      --  Look for the last dot in the file name and return the part of the
+      --  file name preceding this last dot. If the first dot is the first
+      --  character of the file name, the base name is the empty string.
+
+      for Pos in reverse Simple'Range loop
+         if Simple (Pos) = '.' then
+            return Simple (1 .. Pos - 1);
+         end if;
+      end loop;
+
+      --  If there is no dot, return the complete file name
+
+      return Simple;
+   end Base_Name;
+
+   -------------
+   -- Compose --
+   -------------
+
+   function Compose
+     (Containing_Directory : String := "";
+      Name                 : String;
+      Extension            : String := "") return String
+   is
+      Result : String (1 ..
+                         Containing_Directory'Length +
+                         Name'Length + Extension'Length + 2);
+      Last   : Natural;
+
+   begin
+      --  First, deal with the invalid cases
+
+      if not Is_Valid_Path_Name (Containing_Directory) then
+         raise Name_Error;
+
+      elsif
+        Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
+      then
+         raise Name_Error;
+
+      elsif Extension'Length /= 0 and then
+        (not Is_Valid_Simple_Name (Name & '.' & Extension))
+      then
+         raise Name_Error;
+
+         --  This is not an invalid case. Build the path name.
+
+      else
+         Last := Containing_Directory'Length;
+         Result (1 .. Last) := Containing_Directory;
+
+         --  Add a directory separator if needed
+
+         if Result (Last) /= Dir_Separator then
+            Last := Last + 1;
+            Result (Last) := Dir_Separator;
+         end if;
+
+         --  Add the file name
+
+         Result (Last + 1 .. Last + Name'Length) := Name;
+         Last := Last + Name'Length;
+
+         --  If extension was specified, add dot followed by this extension
+
+         if Extension'Length /= 0 then
+            Last := Last + 1;
+            Result (Last) := '.';
+            Result (Last + 1 .. Last + Extension'Length) := Extension;
+            Last := Last + Extension'Length;
+         end if;
+
+         return Result (1 .. Last);
+      end if;
+   end Compose;
+
+   --------------------------
+   -- Containing_Directory --
+   --------------------------
+
+   function Containing_Directory (Name : String) return String is
+   begin
+      --  First, the invalid case
+
+      if not Is_Valid_Path_Name (Name) then
+         raise Name_Error;
+
+      else
+         --  Get the directory name using GNAT.Directory_Operations.Dir_Name
+
+         declare
+            Value : constant String := Dir_Name (Path => Name);
+            Result : String (1 .. Value'Length);
+            Last : Natural := Result'Last;
+
+         begin
+            Result := Value;
+
+            --  Remove any trailing directory separator, except as the first
+            --  character.
+
+            while Last > 1 and then Result (Last) = Dir_Separator loop
+               Last := Last - 1;
+            end loop;
+
+            --  Special case of current directory, identified by "."
+
+            if Last = 1 and then Result (1) = '.' then
+               return Get_Current_Dir;
+
+            else
+               return Result (1 .. Last);
+            end if;
+         end;
+      end if;
+   end Containing_Directory;
+
+   ---------------
+   -- Copy_File --
+   ---------------
+
+   procedure Copy_File
+     (Source_Name   : String;
+      Target_Name   : String;
+      Form          : String := "")
+   is
+      pragma Unreferenced (Form);
+      Success : Boolean;
+
+   begin
+      --  First, the invalid cases
+
+      if (not Is_Valid_Path_Name (Source_Name)) or else
+        (not Is_Valid_Path_Name (Target_Name)) or else
+        (not Is_Regular_File (Source_Name))
+      then
+         raise Name_Error;
+
+      elsif Is_Directory (Target_Name) then
+         raise Use_Error;
+
+      else
+         --  The implementation uses GNAT.OS_Lib.Copy_File, with parameters
+         --  suitable for all platforms.
+
+         Copy_File
+           (Source_Name, Target_Name, Success, Overwrite, None);
+
+         if not Success then
+            raise Use_Error;
+         end if;
+      end if;
+   end Copy_File;
+
+   ----------------------
+   -- Create_Directory --
+   ----------------------
+
+   procedure Create_Directory
+     (New_Directory : String;
+      Form          : String := "")
+   is
+      pragma Unreferenced (Form);
+
+   begin
+      --  First, the invalid case
+
+      if not Is_Valid_Path_Name (New_Directory) then
+         raise Name_Error;
+
+      else
+         --  The implementation uses GNAT.Directory_Operations.Make_Dir
+
+         begin
+            Make_Dir (Dir_Name => New_Directory);
+
+         exception
+            when Directory_Error =>
+               raise Use_Error;
+         end;
+      end if;
+   end Create_Directory;
+
+   -----------------
+   -- Create_Path --
+   -----------------
+
+   procedure Create_Path
+     (New_Directory : String;
+      Form          : String := "")
+   is
+      pragma Unreferenced (Form);
+
+      New_Dir : String (1 .. New_Directory'Length + 1);
+      Last    : Positive := 1;
+
+   begin
+      --  First, the invalid case
+
+      if not Is_Valid_Path_Name (New_Directory) then
+         raise Name_Error;
+
+      else
+         --  Build New_Dir with a directory separator at the end, so that the
+         --  complete path will be found in the loop below.
+
+         New_Dir (1 .. New_Directory'Length) := New_Directory;
+         New_Dir (New_Dir'Last) := Directory_Separator;
+
+         --  Create, if necessary, each directory in the path
+
+         for J in 2 .. New_Dir'Last loop
+
+            --  Look for the end of an intermediate directory
+
+            if New_Dir (J) /= Dir_Separator then
+               Last := J;
+
+            --  We have found a new intermediate directory each time we find
+            --  a first directory separator.
+
+            elsif New_Dir (J - 1) /= Dir_Separator then
+
+               --  No need to create the directory if it already exists
+
+               if Is_Directory (New_Dir (1 .. Last)) then
+                  null;
+
+               --  It is an error if a file with such a name already exists
+
+               elsif Is_Regular_File (New_Dir (1 .. Last)) then
+                  raise Use_Error;
+
+               else
+                  --  The implementation uses
+                  --  GNAT.Directory_Operations.Make_Dir.
+
+                  begin
+                     Make_Dir (Dir_Name => New_Dir (1 .. Last));
+
+                  exception
+                     when Directory_Error =>
+                        raise Use_Error;
+                  end;
+               end if;
+            end if;
+         end loop;
+      end if;
+   end Create_Path;
+
+   -----------------------
+   -- Current_Directory --
+   -----------------------
+
+   function Current_Directory return String is
+   begin
+      --  The implementation uses GNAT.Directory_Operations.Get_Current_Dir
+
+      return Get_Current_Dir;
+   end Current_Directory;
+
+   ----------------------
+   -- Delete_Directory --
+   ----------------------
+
+   procedure Delete_Directory (Directory : String) is
+   begin
+      --  First, the invalid case
+
+      if not Is_Valid_Path_Name (Directory) then
+         raise Name_Error;
+
+      else
+         --  The implementation uses GNAT.Directory_Operations.Remove_Dir
+
+         begin
+            Remove_Dir (Dir_Name => Directory, Recursive => False);
+
+         exception
+            when Directory_Error =>
+               raise Use_Error;
+         end;
+      end if;
+   end Delete_Directory;
+
+   -----------------
+   -- Delete_File --
+   -----------------
+
+   procedure Delete_File (Name : String) is
+      Success : Boolean;
+
+   begin
+      --  First, the invalid cases
+
+      if not Is_Valid_Path_Name (Name) then
+         raise Name_Error;
+
+      elsif not Is_Regular_File (Name) then
+         raise Name_Error;
+
+      else
+         --  The implementation uses GNAT.OS_Lib.Delete_File
+
+         Delete_File (Name, Success);
+
+         if not Success then
+            raise Use_Error;
+         end if;
+      end if;
+   end Delete_File;
+
+   -----------------
+   -- Delete_Tree --
+   -----------------
+
+   procedure Delete_Tree (Directory : String) is
+   begin
+      --  First, the invalid case
+
+      if not Is_Valid_Path_Name (Directory) then
+         raise Name_Error;
+
+      else
+         --  The implementation uses GNAT.Directory_Operations.Remove_Dir
+
+         begin
+            Remove_Dir (Directory, Recursive => True);
+
+         exception
+            when Directory_Error =>
+               raise Use_Error;
+         end;
+      end if;
+   end Delete_Tree;
+
+   ------------
+   -- Exists --
+   ------------
+
+   function Exists (Name : String) return Boolean is
+   begin
+      --  First, the invalid case
+
+      if not Is_Valid_Path_Name (Name) then
+         raise Name_Error;
+
+      else
+         --  The implementation is in File_Exists
+
+         return File_Exists (Name);
+      end if;
+   end Exists;
+
+   ---------------
+   -- Extension --
+   ---------------
+
+   function Extension (Name : String) return String is
+   begin
+      --  First, the invalid case
+
+      if not Is_Valid_Path_Name (Name) then
+         raise Name_Error;
+
+      else
+         --  Look fir the first dot that is not followed by a directory
+         --  separator.
+
+         for Pos in reverse Name'Range loop
+
+            --  If a directory separator is found before a dot, there is no
+            --  extension.
+
+            if Name (Pos) = Dir_Separator then
+               return Empty_String;
+
+            elsif Name (Pos) = '.' then
+
+               --  We found a dot, build the return value with lower bound 1
+
+               declare
+                  Result : String (1 .. Name'Last - Pos);
+               begin
+                  Result := Name (Pos + 1 .. Name'Last);
+                  return Result;
+               end;
+            end if;
+         end loop;
+
+         --  No dot were found, there is no extension
+
+         return Empty_String;
+      end if;
+   end Extension;
+
+   ----------------------
+   -- Fetch_Next_Entry --
+   ----------------------
+
+   procedure Fetch_Next_Entry (Search : Search_Type) is
+      Name : String (1 .. 255);
+      Last : Natural;
+      Kind : File_Kind;
+
+   begin
+      --  Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
+
+      loop
+         Read (Search.Value.Dir, Name, Last);
+
+         --  If no matching entry is found, set Is_Valid to False
+
+         if Last = 0 then
+            Search.Value.Is_Valid := False;
+            exit;
+         end if;
+
+         --  Check if the entry matches the pattern
+
+         if Match (Name (1 .. Last), Search.Value.Pattern) then
+            declare
+               Full_Name : constant String :=
+                             Compose
+                               (To_String
+                                  (Search.Value.Name), Name (1 .. Last));
+               Found : Boolean := False;
+
+            begin
+               if File_Exists (Full_Name) then
+
+                  --  Now check if the file kind matches the filter
+
+                  if Is_Regular_File (Full_Name) then
+                     if Search.Value.Filter (Ordinary_File) then
+                        Kind := Ordinary_File;
+                        Found := True;
+                     end if;
+
+                  elsif Is_Directory (Full_Name) then
+                     if Search.Value.Filter (Directory) then
+                        Kind := Directory;
+                        Found := True;
+                     end if;
+
+                  elsif Search.Value.Filter (Special_File) then
+                     Kind := Special_File;
+                     Found := True;
+                  end if;
+
+                  --  If it does, update Search and return
+
+                  if Found then
+                     Search.Value.Entry_Fetched := True;
+                     Search.Value.Dir_Entry :=
+                       (Is_Valid => True,
+                        Simple   => To_Unbounded_String (Name (1 .. Last)),
+                        Full     => To_Unbounded_String (Full_Name),
+                        Kind     => Kind);
+                     exit;
+                  end if;
+               end if;
+            end;
+         end if;
+      end loop;
+   end Fetch_Next_Entry;
+
+   -----------------
+   -- File_Exists --
+   -----------------
+
+   function File_Exists (Name : String) return Boolean is
+      function C_File_Exists (A : System.Address) return Integer;
+      pragma Import (C, C_File_Exists, "__gnat_file_exists");
+
+      C_Name : String (1 .. Name'Length + 1);
+
+   begin
+      C_Name (1 .. Name'Length) := Name;
+      C_Name (C_Name'Last) := ASCII.NUL;
+
+      return C_File_Exists (C_Name (1)'Address) = 1;
+   end File_Exists;
+
+   --------------
+   -- Finalize --
+   --------------
+
+   procedure Finalize (Search : in out Search_Type) is
+   begin
+      if Search.Value /= null then
+
+         --  Close the directory, if one is open
+
+         if Is_Open (Search.Value.Dir) then
+            Close (Search.Value.Dir);
+         end if;
+
+         Free (Search.Value);
+      end if;
+   end Finalize;
+
+   ---------------
+   -- Full_Name --
+   ---------------
+
+   function Full_Name (Name : String) return String is
+   begin
+      --  First, the invalid case
+
+      if not Is_Valid_Path_Name (Name) then
+         raise Name_Error;
+
+      else
+         --  Build the return value with lower bound 1.
+         --  Use GNAT.OS_Lib.Normalize_Pathname.
+
+         declare
+            Value : constant String := Normalize_Pathname (Name);
+            Result : String (1 .. Value'Length);
+         begin
+            Result := Value;
+            return Result;
+         end;
+      end if;
+   end Full_Name;
+
+   function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
+   begin
+      --  First, the invalid case
+
+      if not Directory_Entry.Is_Valid then
+         raise Status_Error;
+
+      else
+         --  The value to return has already been computed
+
+         return To_String (Directory_Entry.Full);
+      end if;
+   end Full_Name;
+
+   --------------------
+   -- Get_Next_Entry --
+   --------------------
+
+   procedure Get_Next_Entry
+     (Search          : in out Search_Type;
+      Directory_Entry : out Directory_Entry_Type)
+   is
+   begin
+      --  First, the invalid case
+
+      if Search.Value = null or else not Search.Value.Is_Valid then
+         raise Status_Error;
+      end if;
+
+      --  Fetch the next entry, if needed
+
+      if not Search.Value.Entry_Fetched then
+         Fetch_Next_Entry (Search);
+      end if;
+
+      --  It is an error if no valid entry is found
+
+      if not Search.Value.Is_Valid then
+         raise Status_Error;
+
+      else
+         --  Reset Entry_Fatched and return the entry
+
+         Search.Value.Entry_Fetched := False;
+         Directory_Entry := Search.Value.Dir_Entry;
+      end if;
+   end Get_Next_Entry;
+
+   ----------
+   -- Kind --
+   ----------
+
+   function Kind (Name : String) return File_Kind is
+   begin
+      --  First, the invalid case
+
+      if not File_Exists (Name) then
+         raise Name_Error;
+
+      elsif Is_Regular_File (Name) then
+         return Ordinary_File;
+
+      elsif Is_Directory (Name) then
+         return Directory;
+
+      else
+         return Special_File;
+      end if;
+   end Kind;
+
+   function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
+   begin
+      --  First, the invalid case
+
+      if not Directory_Entry.Is_Valid then
+         raise Status_Error;
+
+      else
+         --  The value to return has already be computed
+
+         return Directory_Entry.Kind;
+      end if;
+   end Kind;
+
+   -----------------------
+   -- Modification_Time --
+   -----------------------
+
+   function Modification_Time (Name : String) return Ada.Calendar.Time is
+      Date   : OS_Time;
+      Year   : Year_Type;
+      Month  : Month_Type;
+      Day    : Day_Type;
+      Hour   : Hour_Type;
+      Minute : Minute_Type;
+      Second : Second_Type;
+
+   begin
+      --  First, the invalid cases
+
+
+      if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
+         raise Name_Error;
+
+      else
+         Date := File_Time_Stamp (Name);
+         --  ???? We need to be able to convert OS_Time to Ada.Calendar.Time
+         --  For now, use the component of the OS_Time to create the
+         --  Calendar.Time value.
+
+         GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
+
+         return Ada.Calendar.Time_Of
+           (Year, Month, Day, Duration (Second + 60 * (Minute + 60 * Hour)));
+      end if;
+   end Modification_Time;
+
+   function Modification_Time
+     (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
+   is
+   begin
+      --  First, the invalid case
+
+      if not Directory_Entry.Is_Valid then
+         raise Status_Error;
+
+      else
+         --  The value to return has already be computed
+
+         return Modification_Time (To_String (Directory_Entry.Full));
+      end if;
+   end Modification_Time;
+
+   ------------------
+   -- More_Entries --
+   ------------------
+
+   function More_Entries (Search : Search_Type) return Boolean is
+   begin
+      if Search.Value = null then
+         return False;
+
+      elsif Search.Value.Is_Valid then
+
+         --  Fetch the next entry, if needed
+
+         if not Search.Value.Entry_Fetched then
+            Fetch_Next_Entry (Search);
+         end if;
+      end if;
+
+      return Search.Value.Is_Valid;
+   end More_Entries;
+
+   ------------
+   -- Rename --
+   ------------
+
+   procedure Rename (Old_Name, New_Name : String) is
+      Success : Boolean;
+
+   begin
+      --  First, the invalid cases
+
+      if not Is_Valid_Path_Name (Old_Name)
+        or else not Is_Valid_Path_Name (New_Name)
+        or else (not Is_Regular_File (Old_Name)
+                   and then not Is_Directory (Old_Name))
+      then
+         raise Name_Error;
+
+      elsif Is_Regular_File (New_Name) or Is_Directory (New_Name) then
+         raise Use_Error;
+
+      else
+         --  The implemewntation uses GNAT.OS_Lib.Rename_File
+
+         Rename_File (Old_Name, New_Name, Success);
+
+         if not Success then
+            raise Use_Error;
+         end if;
+      end if;
+   end Rename;
+
+   -------------------
+   -- Set_Directory --
+   -------------------
+
+   procedure Set_Directory (Directory : String) is
+   begin
+      --  The implementation uses GNAT.Directory_Operations.Change_Dir
+
+      Change_Dir (Dir_Name => Directory);
+
+   exception
+      when Directory_Error =>
+         raise Name_Error;
+   end Set_Directory;
+
+   -----------------
+   -- Simple_Name --
+   -----------------
+
+   function Simple_Name (Name : String) return String is
+   begin
+      --  First, the invalid case
+
+      if not Is_Valid_Path_Name (Name) then
+         raise Name_Error;
+
+      else
+         --  Build the value to return with lower bound 1.
+         --  The implementation uses GNAT.Directory_Operations.Base_Name.
+
+         declare
+            Value : constant String :=
+                       GNAT.Directory_Operations.Base_Name (Name);
+            Result : String (1 .. Value'Length);
+         begin
+            Result := Value;
+            return Result;
+         end;
+      end if;
+   end Simple_Name;
+
+   function Simple_Name
+     (Directory_Entry : Directory_Entry_Type) return String
+   is
+   begin
+      --  First, the invalid case
+
+      if not Directory_Entry.Is_Valid then
+         raise Status_Error;
+
+      else
+         --  The value to return has already be computed
+
+         return To_String (Directory_Entry.Simple);
+      end if;
+   end Simple_Name;
+
+   ----------
+   -- Size --
+   ----------
+
+   function Size (Name : String) return File_Size is
+      C_Name : String (1 .. Name'Length + 1);
+
+      function C_Size (Name : System.Address) return File_Size;
+      pragma Import (C, C_Size, "__gnat_named_file_length");
+
+   begin
+      --  First, the invalid case
+
+      if not Is_Regular_File (Name) then
+         raise Name_Error;
+
+      else
+         C_Name (1 .. Name'Length) := Name;
+         C_Name (C_Name'Last) := ASCII.NUL;
+         return C_Size (C_Name'Address);
+      end if;
+   end Size;
+
+   function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
+   begin
+      --  First, the invalid case
+
+      if not Directory_Entry.Is_Valid then
+         raise Status_Error;
+
+      else
+         --  The value to return has already be computed
+
+         return Size (To_String (Directory_Entry.Full));
+      end if;
+   end Size;
+
+   ------------------
+   -- Start_Search --
+   ------------------
+
+   procedure Start_Search
+     (Search    : in out Search_Type;
+      Directory : String;
+      Pattern   : String;
+      Filter    : Filter_Type := (others => True))
+   is
+   begin
+      --  First, the invalid case
+
+      if not Is_Directory (Directory) then
+         raise Name_Error;
+      end if;
+
+      --  If needed, finalize Search
+
+      Finalize (Search);
+
+      --  Allocate the default data
+
+      Search.Value := new Search_Data;
+
+      begin
+         --  Check the pattern
+
+         Search.Value.Pattern := Compile (Pattern, Glob => True);
+
+      exception
+         when Error_In_Regexp =>
+            raise Name_Error;
+      end;
+
+      --  Initialize some Search components
+
+      Search.Value.Filter := Filter;
+      Search.Value.Name := To_Unbounded_String (Full_Name (Directory));
+      Open (Search.Value.Dir, Directory);
+      Search.Value.Is_Valid := True;
+   end Start_Search;
+
+end Ada.Directories;
+

gcc/ada/a-direct.ads

@@ -0,0 +1,415 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--                      A D A . D I R E C T O R I E S                       --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--          Copyright (C) 2004 Free Software Foundation, Inc.               --
+--                                                                          --
+-- This specification is derived for use with GNAT from AI-00248,  which is --
+-- expected to be a part of a future expected revised Ada Reference Manual. --
+-- The copyright notice above, and the license provisions that follow apply --
+-- solely to the  contents of the part following the private keyword.       --
+--                                                                          --
+-- 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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- As a special exception,  if other files  instantiate  generics from this --
+-- unit, or you link  this unit with other files  to produce an executable, --
+-- this  unit  does not  by itself cause  the resulting  executable  to  be --
+-- covered  by the  GNU  General  Public  License.  This exception does not --
+-- however invalidate  any other reasons why  the executable file  might be --
+-- covered by the  GNU Public License.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Ada0Y: Implementation of Ada.Directories (AI95-00248). Note that this
+--  unit is available without -gnatX. That seems reasonable, since you only
+--  get it if you explicitly ask for it.
+
+--  External files may be classified as directories, special files, or ordinary
+--  files. A directory is an external file that is a container for files on
+--  the target system. A special file is an external file that cannot be
+--  created or read by a predefined Ada Input-Output package. External files
+--  that are not special files or directories are called ordinary files.
+
+--  A file name is a string identifying an external file. Similarly, a
+--  directory name is a string identifying a directory. The interpretation of
+--  file names and directory names is implementation-defined.
+
+--  The full name of an external file is a full specification of the name of
+--  the file. If the external environment allows alternative specifications of
+--  the name (for example, abbreviations), the full name should not use such
+--  alternatives. A full name typically will include the names of all of
+--  directories that contain the item. The simple name of an external file is
+--  the name of the item, not including any containing directory names. Unless
+--  otherwise specified, a file name or directory name parameter to a
+--  predefined Ada input-output subprogram can be a full name, a simple name,
+--  or any other form of name supported by the implementation.
+
+--  The default directory is the directory that is used if a directory or
+--  file name is not a full name (that is, when the name does not fully
+--  identify all of the containing directories).
+
+--  A directory entry is a single item in a directory, identifying a single
+--  external file (including directories and special files).
+
+--  For each function that returns a string, the lower bound of the returned
+--  value is 1.
+
+with Ada.Calendar;
+with Ada.Finalization;
+with Ada.IO_Exceptions;
+with Ada.Strings.Unbounded;
+
+package Ada.Directories is
+
+   -----------------------------------
+   -- Directory and File Operations --
+   -----------------------------------
+
+   function Current_Directory return String;
+   --  Returns the full directory name for the current default directory. The
+   --  name returned shall be suitable for a future call to Set_Directory.
+   --  The exception Use_Error is propagated if a default directory is not
+   --  supported by the external environment.
+
+   procedure Set_Directory (Directory : String);
+   --  Sets the current default directory. The exception Name_Error is
+   --  propagated if the string given as Directory does not identify an
+   --  existing directory. The exception Use_Error is propagated if the
+   --  external environment does not support making Directory (in the absence
+   --  of Name_Error) a default directory.
+
+   procedure Create_Directory
+     (New_Directory : String;
+      Form          : String := "");
+   --  Creates a directory with name New_Directory. The Form parameter can be
+   --  used to give system-dependent characteristics of the directory; the
+   --  interpretation of the Form parameter is implementation-defined. A null
+   --  string for Form specifies the use of the default options of the
+   --  implementation of the new directory. The exception Name_Error is
+   --  propagated if the string given as New_Directory does not allow the
+   --  identification of a directory. The exception Use_Error is propagated if
+   --  the external environment does not support the creation of a directory
+   --  with the given name (in the absence of Name_Error) and form.
+
+   procedure Delete_Directory (Directory : String);
+   --  Deletes an existing empty directory with name Directory. The exception
+   --  Name_Error is propagated if the string given as Directory does not
+   --  identify an existing directory. The exception Use_Error is propagated
+   --  if the external environment does not support the deletion of the
+   --  directory (or some portion of its contents) with the given name (in the
+   --  absence of Name_Error).
+
+   procedure Create_Path
+     (New_Directory : String;
+      Form          : String := "");
+   --  Creates zero or more directories with name New_Directory. Each
+   --  non-existent directory named by New_Directory is created. For example,
+   --  on a typical Unix system, Create_Path ("/usr/me/my"); would create
+   --  directory "me" in directory "usr", then create directory "my" in
+   --  directory "me". The Form can be used to give system-dependent
+   --  characteristics of the directory; the interpretation of the Form
+   --  parameter is implementation-defined. A null string for Form specifies
+   --  the use of the default options of the implementation of the new
+   --  directory. The exception Name_Error is propagated if the string given
+   --  as New_Directory does not allow the identification of any directory.
+   --  The exception Use_Error is propagated if the external environment does
+   --  not support the creation of any directories with the given name (in the
+   --  absence of Name_Error) and form.
+
+   procedure Delete_Tree (Directory : String);
+   --  Deletes an existing directory with name Directory. The directory and
+   --  all of its contents (possibly including other directories) are deleted.
+   --  The exception Name_Error is propagated if the string given as Directory
+   --  does not identify an existing directory. The exception Use_Error is
+   --  propagatedi f the external environment does not support the deletion of
+   --  the directory or some portion of its contents with the given name (in
+   --  the absence of Name_Error). If Use_Error is propagated, it is
+   --  unspecified if a portion of the contents of the directory are deleted.
+
+   procedure Delete_File (Name : String);
+   --  Deletes an existing ordinary or special file with Name. The exception
+   --  Name_Error is propagated if the string given as Name does not identify
+   --  an existing ordinary or special external file. The exception Use_Error
+   --  is propagated if the external environment does not support the deletion
+   --  of the file with the given name (in the absence of Name_Error).
+
+   procedure Rename (Old_Name, New_Name : String);
+   --  Renames an existing external file (including directories) with Old_Name
+   --  to New_Name. The exception Name_Error is propagated if the string given
+   --  as Old_Name does not identify an existing external file. The exception
+   --  Use_Error is propagated if the external environment does not support the
+   --  renaming of the file with the given name (in the absence of Name_Error).
+   --  In particular, Use_Error is propagated if a file or directory already
+   --  exists with New_Name.
+
+   procedure Copy_File
+     (Source_Name   : String;
+      Target_Name   : String;
+      Form          : String := "");
+   --  Copies the contents of the existing external file with Source_Name
+   --  to Target_Name. The resulting external file is a duplicate of the source
+   --  external file. The Form can be used to give system-dependent
+   --  characteristics of the resulting external file; the interpretation of
+   --  the Form parameter is implementation-defined. Exception Name_Error is
+   --  propagated if the string given as Source_Name does not identify an
+   --  existing external ordinary or special file or if the string given as
+   --  Target_Name does not allow the identification of an external file.
+   --  The exception Use_Error is propagated if the external environment does
+   --  not support the creating of the file with the name given by Target_Name
+   --  and form given by Form, or copying of the file with the name given by
+   --  Source_Name (in the absence of Name_Error).
+
+
+   --  File and directory name operations:
+
+   function Full_Name (Name : String) return String;
+   --  Returns the full name corresponding to the file name specified by Name.
+   --  The exception Name_Error is propagated if the string given as Name does
+   --  not allow the identification of an external file (including directories
+   --  and special files).
+
+   function Simple_Name (Name : String) return String;
+   --  Returns the simple name portion of the file name specified by Name. The
+   --  exception Name_Error is propagated if the string given as Name does not
+   --  allow the identification of an external file (including directories and
+   --  special files).
+
+   function Containing_Directory (Name : String) return String;
+   --  Returns the name of the containing directory of the external file
+   --  (including directories) identified by Name. If more than one directory
+   --  can contain Name, the directory name returned is implementation-defined.
+   --  The exception Name_Error is propagated if the string given as Name does
+   --  not allow the identification of an external file. The exception
+   --  Use_Error is propagated if the external file does not have a containing
+   --  directory.
+
+   function Extension (Name : String) return String;
+   --  Returns the extension name corresponding to Name. The extension name is
+   --  a portion of a simple name (not including any separator characters),
+   --  typically used to identify the file class. If the external environment
+   --  does not have extension names, then the null string is returned.
+   --  The exception Name_Error is propagated if the string given as Name does
+   --  not allow the identification of an external file.
+
+   function Base_Name (Name : String) return String;
+   --  Returns the base name corresponding to Name. The base name is the
+   --  remainder of a simple name after removing any extension and extension
+   --  separators. The exception Name_Error is propagated if the string given
+   --  as Name does not allow the identification of an external file
+   --  (including directories and special files).
+
+   function Compose
+     (Containing_Directory : String := "";
+      Name                 : String;
+      Extension            : String := "") return String;
+   --  Returns the name of the external file with the specified
+   --  Containing_Directory, Name, and Extension. If Extension is the null
+   --  string, then Name is interpreted as a simple name; otherwise Name is
+   --  interpreted as a base name. The exception Name_Error is propagated if
+   --  the string given as Containing_Directory is not null and does not allow
+   --  the identification of a directory, or if the string given as Extension
+   --  is not null and is not a possible extension, or if the string given as
+   --  Name is not a possible simple name (if Extension is null) or base name
+   --  (if Extension is non-null).
+
+
+   --  File and directory queries:
+
+   type File_Kind is (Directory, Ordinary_File, Special_File);
+   --  The type File_Kind represents the kind of file represented by an
+   --  external file or directory.
+
+   type File_Size is range 0 .. Long_Long_Integer'Last;
+   --  The type File_Size represents the size of an external file.
+
+   function Exists (Name : String) return Boolean;
+   --  Returns True if external file represented by Name exists, and False
+   --  otherwise. The exception Name_Error is propagated if the string given as
+   --  Name does not allow the identification of an external file (including
+   --  directories and special files).
+
+   function Kind (Name : String) return File_Kind;
+   --  Returns the kind of external file represented by Name. The exception
+   --  Name_Error is propagated if the string given as Name does not allow the
+   --  identification of an existing external file.
+
+   function Size (Name : String) return File_Size;
+   --  Returns the size of the external file represented by Name. The size of
+   --  an external file is the number of stream elements contained in the file.
+   --  If the external file is discontiguous (not all elements exist), the
+   --  result is implementation-defined. If the external file is not an
+   --  ordinary file, the result is implementation-defined. The exception
+   --  Name_Error is propagated if the string given as Name does not allow the
+   --  identification of an existing external file. The exception
+   --  Constraint_Error is propagated if the file size is not a value of type
+   --  File_Size.
+
+   function Modification_Time (Name : String) return Ada.Calendar.Time;
+   --  Returns the time that the external file represented by Name was most
+   --  recently modified. If the external file is not an ordinary file, the
+   --  result is implementation-defined. The exception Name_Error is propagated
+   --  if the string given as Name does not allow the identification of an
+   --  existing external file. The exception Use_Error is propagated if the
+   --  external environment does not support the reading the modification time
+   --  of the file with the name given by Name (in the absence of Name_Error).
+
+   -------------------------
+   -- Directory Searching --
+   -------------------------
+
+   type Directory_Entry_Type is limited private;
+   --  The type Directory_Entry_Type represents a single item in a directory.
+   --  These items can only be created by the Get_Next_Entry procedure in this
+   --  package. Information about the item can be obtained from the functions
+   --  declared in this package. A default initialized object of this type is
+   --  invalid; objects returned from Get_Next_Entry are valid.
+
+   type Filter_Type is array (File_Kind) of Boolean;
+   --  The type Filter_Type specifies which directory entries are provided from
+   --  a search operation. If the Directory component is True, directory
+   --  entries representing directories are provided. If the Ordinary_File
+   --  component is True, directory entries representing ordinary files are
+   --  provided. If the Special_File component is True, directory entries
+   --  representing special files are provided.
+
+   type Search_Type is limited private;
+   --  The type Search_Type contains the state of a directory search. A
+   --  default-initialized Search_Type object has no entries available
+   --  (More_Entries returns False).
+
+   procedure Start_Search
+     (Search    : in out Search_Type;
+      Directory : String;
+      Pattern   : String;
+      Filter    : Filter_Type := (others => True));
+   --  Starts a search in the directory entry in the directory named by
+   --  Directory for entries matching Pattern. Pattern represents a file name
+   --  matching pattern. If Pattern is null, all items in the directory are
+   --  matched; otherwise, the interpretation of Pattern is
+   --  implementation-defined. Only items which match Filter will be returned.
+   --  After a successful call on Start_Search, the object Search may have
+   --  entries available, but it may have no entries available if no files or
+   --  directories match Pattern and Filter. The exception Name_Error is
+   --  propagated if the string given by Directory does not identify an
+   --  existing directory, or if Pattern does not allow the identification of
+   --  any possible external file or directory. The exception Use_Error is
+   --  propagated if the external environment does not support the searching
+   --  of the directory with the given name (in the absence of Name_Error).
+
+   procedure End_Search (Search : in out Search_Type);
+   --  Ends the search represented by Search. After a successful call on
+   --  End_Search, the object Search will have no entries available.
+
+   function More_Entries (Search : Search_Type) return Boolean;
+   --  Returns True if more entries are available to be returned by a call
+   --  to Get_Next_Entry for the specified search object, and False otherwise.
+
+   procedure Get_Next_Entry
+     (Search          : in out Search_Type;
+      Directory_Entry : out Directory_Entry_Type);
+   --  Returns the next Directory_Entry for the search described by Search that
+   --  matches the pattern and filter. If no further matches are available,
+   --  Status_Error is raised. It is implementation-defined as to whether the
+   --  results returned by this routine are altered if the contents of the
+   --  directory are altered while the Search object is valid (for example, by
+   --  another program). The exception Use_Error is propagated if the external
+   --  environment does not support continued searching of the directory
+   --  represented by Search.
+
+   -------------------------------------
+   -- Operations on Directory Entries --
+   -------------------------------------
+
+   function Simple_Name (Directory_Entry : Directory_Entry_Type) return String;
+   --  Returns the simple external name of the external file (including
+   --  directories) represented by Directory_Entry. The format of the name
+   --  returned is implementation-defined. The exception Status_Error is
+   --  propagated if Directory_Entry is invalid.
+
+   function Full_Name (Directory_Entry : Directory_Entry_Type) return String;
+   --  Returns the full external name of the external file (including
+   --  directories) represented by Directory_Entry. The format of the name
+   --  returned is implementation-defined. The exception Status_Error is
+   --  propagated if Directory_Entry is invalid.
+
+   function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind;
+   --  Returns the kind of external file represented by Directory_Entry. The
+   --  exception Status_Error is propagated if Directory_Entry is invalid.
+
+   function Size (Directory_Entry : Directory_Entry_Type) return File_Size;
+   --  Returns the size of the external file represented by Directory_Entry.
+   --  The size of an external file is the number of stream elements contained
+   --  in the file. If the external file is discontiguous (not all elements
+   --  exist), the result is implementation-defined. If the external file
+   --  represented by Directory_Entry is not an ordinary file, the result is
+   --  implementation-defined. The exception Status_Error is propagated if
+   --  Directory_Entry is invalid. The exception Constraint_Error is propagated
+   --  if the file size is not a value of type File_Size.
+
+   function Modification_Time
+     (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time;
+   --  Returns the time that the external file represented by Directory_Entry
+   --  was most recently modified. If the external file represented by
+   --  Directory_Entry is not an ordinary file, the result is
+   --  implementation-defined. The exception Status_Error is propagated if
+   --  Directory_Entry is invalid. The exception Use_Error is propagated if
+   --  the external environment does not support the reading the modification
+   --  time of the file represented by Directory_Entry.
+
+   ----------------
+   -- Exceptions --
+   ----------------
+
+   Status_Error : exception renames Ada.IO_Exceptions.Status_Error;
+   Name_Error   : exception renames Ada.IO_Exceptions.Name_Error;
+   Use_Error    : exception renames Ada.IO_Exceptions.Use_Error;
+   Device_Error : exception renames Ada.IO_Exceptions.Device_Error;
+
+private
+   type Directory_Entry_Type is record
+      Is_Valid : Boolean := False;
+      Simple   : Ada.Strings.Unbounded.Unbounded_String;
+      Full     : Ada.Strings.Unbounded.Unbounded_String;
+      Kind     : File_Kind;
+   end record;
+
+   --  The type Search_Data is defined in the body, so that the spec does not
+   --  depend on packages of the GNAT hierarchy.
+
+   type Search_Data;
+   type Search_Ptr is access Search_Data;
+
+   --  Search_Type need to be a controlled type, because it includes component
+   --  of type Dir_Type (in GNAT.Directory_Operations) that need to be closed
+   --  (if opened) during finalization.
+   --  The component need to be an access value, because Search_Data is not
+   --  fully defined in the spec.
+
+   type Search_Type is new Ada.Finalization.Controlled with record
+      Value : Search_Ptr;
+   end record;
+
+   procedure Finalize (Search : in out Search_Type);
+   --  Close the directory, if opened, and deallocate Value.
+
+   procedure End_Search (Search : in out Search_Type) renames Finalize;
+
+end Ada.Directories;
+
+

gcc/ada/a-dirval.adb

@@ -0,0 +1,90 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--             A D A . D I R E C T O R I E S . V A L I D I T Y              --
+--                                                                          --
+--                                 B o d y                                  --
+--                             (POSIX Version)                              --
+--                                                                          --
+--          Copyright (C) 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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- As a special exception,  if other files  instantiate  generics from this --
+-- unit, or you link  this unit with other files  to produce an executable, --
+-- this  unit  does not  by itself cause  the resulting  executable  to  be --
+-- covered  by the  GNU  General  Public  License.  This exception does not --
+-- however invalidate  any other reasons why  the executable file  might be --
+-- covered by the  GNU Public License.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the POSIX version of this package
+
+package body Ada.Directories.Validity is
+
+   ------------------------
+   -- Is_Valid_Path_Name --
+   ------------------------
+
+   function Is_Valid_Path_Name   (Name : String) return Boolean is
+   begin
+      --  A path name cannot be empty and cannot contain any NUL character
+
+      if Name'Length = 0 then
+         return False;
+
+      else
+         for J in Name'Range loop
+            if Name (J) = ASCII.NUL then
+               return False;
+            end if;
+         end loop;
+      end if;
+
+      --  If Name does not contain any NUL character, it is valid
+
+      return True;
+   end Is_Valid_Path_Name;
+
+   --------------------------
+   -- Is_Valid_Simple_Name --
+   --------------------------
+
+   function Is_Valid_Simple_Name (Name : String) return Boolean is
+   begin
+      --  A file name cannot be empty and cannot contain a slash ('/') or
+      --  the NUL character.
+
+      if Name'Length = 0 then
+         return False;
+
+      else
+         for J in Name'Range loop
+            if Name (J) = '/' or else Name (J) = ASCII.NUL then
+               return False;
+            end if;
+         end loop;
+      end if;
+
+      --  If Name does not contain any slash or NUL, it is valid
+
+      return True;
+   end Is_Valid_Simple_Name;
+
+end Ada.Directories.Validity;
+
+

gcc/ada/a-dirval.ads

@@ -0,0 +1,47 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT RUN-TIME COMPONENTS                         --
+--                                                                          --
+--             A D A . D I R E C T O R I E S . V A L I D I T Y              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--          Copyright (C) 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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- As a special exception,  if other files  instantiate  generics from this --
+-- unit, or you link  this unit with other files  to produce an executable, --
+-- this  unit  does not  by itself cause  the resulting  executable  to  be --
+-- covered  by the  GNU  General  Public  License.  This exception does not --
+-- however invalidate  any other reasons why  the executable file  might be --
+-- covered by the  GNU Public License.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This private child package is used in the body of Ada.Directories.
+--  It has several bodies, for different platforms.
+
+private package Ada.Directories.Validity is
+
+   function Is_Valid_Simple_Name (Name : String) return Boolean;
+   --  Returns True if Name is a valid file name
+
+   function Is_Valid_Path_Name (Name : String) return Boolean;
+   --  Returns True if Name is a valid path name
+
+end Ada.Directories.Validity;
+
+

gcc/ada/a-except.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2003 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- --
@@ -703,7 +703,13 @@ package body Ada.Exceptions is
          P := P - 1;
       end loop;
 
-      return Name (P .. Name'Length);
+      --  Return result making sure lower bound is 1
+
+      declare
+         subtype Rname is String (1 .. Name'Length - P + 1);
+      begin
+         return Rname (Name (P .. Name'Length));
+      end;
    end Exception_Name_Simple;
 
    --------------------

gcc/ada/adaint.c

@@ -720,6 +720,21 @@ __gnat_file_length (int fd)
   return (statbuf.st_size);
 }
 
+/* Return the number of bytes in the specified named file.  */
+
+long
+__gnat_named_file_length (char *name)
+{
+  int ret;
+  struct stat statbuf;
+
+  ret = __gnat_stat (name, &statbuf);
+  if (ret || !S_ISREG (statbuf.st_mode))
+    return 0;
+
+  return (statbuf.st_size);
+}
+
 /* Create a temporary filename and put it in string pointed to by
    TMP_FILENAME.  */
 

gcc/ada/adaint.h

@@ -66,6 +66,7 @@ extern int    __gnat_open_create                   (char *, int);
 extern int    __gnat_create_output_file            (char *);
 extern int    __gnat_open_append                   (char *, int);
 extern long   __gnat_file_length                   (int);
+extern long   __gnat_named_file_length             (char *);
 extern void   __gnat_tmp_name			   (char *);
 extern char  *__gnat_readdir                       (DIR *, char *);
 extern int    __gnat_readdir_is_thread_safe        (void);

gcc/ada/ali-util.adb

@@ -86,26 +86,23 @@ package body ALI.Util is
       return Checksum1 = Checksum2 and then Checksum1 /= Checksum_Error;
    end Checksums_Match;
 
-   pragma Warnings (Off);
-   --  To avoid warnings on non referenced parameters of the error procedures
-
    ---------------
    -- Error_Msg --
    ---------------
 
    procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
+      pragma Warnings (Off, Msg);
+      pragma Warnings (Off, Flag_Location);
    begin
       null;
    end Error_Msg;
 
-   pragma Warnings (Off);
-   --  To avoid warnings on non referenced parameters of the error procedures
-
    -----------------
    -- Error_Msg_S --
    -----------------
 
    procedure Error_Msg_S (Msg : String) is
+      pragma Warnings (Off, Msg);
    begin
       null;
    end Error_Msg_S;
@@ -115,6 +112,7 @@ package body ALI.Util is
    ------------------
 
    procedure Error_Msg_SC (Msg : String) is
+      pragma Warnings (Off, Msg);
    begin
       null;
    end Error_Msg_SC;
@@ -124,12 +122,11 @@ package body ALI.Util is
    ------------------
 
    procedure Error_Msg_SP (Msg : String) is
+      pragma Warnings (Off, Msg);
    begin
       null;
    end Error_Msg_SP;
 
-   pragma Warnings (On);
-
    -----------------------
    -- Get_File_Checksum --
    -----------------------

gcc/ada/eval_fat.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2003 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- --
@@ -62,11 +62,11 @@ package body Eval_Fat is
    --  The result is rounded to a nearest machine number.
 
    procedure Decompose_Int
-     (RT               : R;
-      X                : in T;
-      Fraction         : out UI;
-      Exponent         : out UI;
-      Mode             : Rounding_Mode);
+     (RT       : R;
+      X        : in T;
+      Fraction : out UI;
+      Exponent : out UI;
+      Mode     : Rounding_Mode);
    --  This is similar to Decompose, except that the Fraction value returned
    --  is an integer representing the value Fraction * Scale, where Scale is
    --  the value (Radix ** Machine_Mantissa (RT)). The value is obtained by
@@ -129,7 +129,6 @@ package body Eval_Fat is
    function Compose (RT : R; Fraction : T; Exponent : UI) return T is
       Arg_Frac : T;
       Arg_Exp  : UI;
-
    begin
       if UR_Is_Zero (Fraction) then
          return Fraction;
@@ -190,18 +189,17 @@ package body Eval_Fat is
    -- Decompose_Int --
    -------------------
 
-   --  This procedure should be modified with care, as there
-   --  are many non-obvious details that may cause problems
-   --  that are hard to detect. The cases of positive and
-   --  negative zeroes are also special and should be
-   --  verified separately.
+   --  This procedure should be modified with care, as there are many
+   --  non-obvious details that may cause problems that are hard to
+   --  detect. The cases of positive and negative zeroes are also
+   --  special and should be verified separately.
 
    procedure Decompose_Int
-     (RT               : R;
-      X                : in T;
-      Fraction         : out UI;
-      Exponent         : out UI;
-      Mode             : Rounding_Mode)
+     (RT       : R;
+      X        : in T;
+      Fraction : out UI;
+      Exponent : out UI;
+      Mode     : Rounding_Mode)
    is
       Base : Int := Rbase (X);
       N    : UI  := abs Numerator (X);
@@ -466,7 +464,6 @@ package body Eval_Fat is
    function Exponent (RT : R; X : T) return UI is
       X_Frac : UI;
       X_Exp  : UI;
-
    begin
       if UR_Is_Zero (X) then
          return Uint_0;
@@ -502,7 +499,6 @@ package body Eval_Fat is
    function Fraction (RT : R; X : T) return T is
       X_Frac : T;
       X_Exp  : UI;
-
    begin
       if UR_Is_Zero (X) then
          return X;
@@ -517,19 +513,13 @@ package body Eval_Fat is
    ------------------
 
    function Leading_Part (RT : R; X : T; Radix_Digits : UI) return T is
-      L    : UI;
-      Y, Z : T;
-
+      RD : constant UI := UI_Min (Radix_Digits, Machine_Mantissa (RT));
+      L  : UI;
+      Y  : T;
    begin
-      if Radix_Digits >= Machine_Mantissa (RT) then
-         return X;
-
-      else
-         L := Exponent (RT, X) - Radix_Digits;
-         Y := Truncation (RT, Scaling (RT, X, -L));
-         Z := Scaling (RT, Y, L);
-         return Z;
-      end if;
+      L := Exponent (RT, X) - RD;
+      Y := UR_From_Uint (UR_Trunc (Scaling (RT, X, -L)));
+      return Scaling (RT, Y, L);
    end Leading_Part;
 
    -------------
@@ -540,11 +530,8 @@ package body Eval_Fat is
      (RT    : R;
       X     : T;
       Mode  : Rounding_Mode;
-      Enode : Node_Id)
-      return  T
+      Enode : Node_Id) return T
    is
-      pragma Warnings (Off, Enode); -- not yet referenced
-
       X_Frac : T;
       X_Exp  : UI;
       Emin   : constant UI := UI_From_Int (Machine_Emin (RT));
@@ -726,7 +713,6 @@ package body Eval_Fat is
    function Model (RT : R; X : T) return T is
       X_Frac : T;
       X_Exp  : UI;
-
    begin
       Decompose (RT, X, X_Frac, X_Exp);
       return Compose (RT, X_Frac, X_Exp);

gcc/ada/eval_fat.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2003 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- --
@@ -98,7 +98,6 @@ package Eval_Fat is
      (RT    : R;
       X     : T;
       Mode  : Rounding_Mode;
-      Enode : Node_Id)
-      return  T;
+      Enode : Node_Id) return T;
 
 end Eval_Fat;

gcc/ada/exp_ch6.adb

@@ -2457,7 +2457,19 @@ package body Exp_Ch6 is
 
             --  Replace assignment with the block
 
-            Rewrite (Parent (N), Blk);
+            declare
+               Original_Assignment : constant Node_Id := Parent (N);
+               Saved_Assignment    : constant Node_Id :=
+                                       Relocate_Node (Original_Assignment);
+               pragma Warnings (Off, Saved_Assignment);
+               --  Preserve the original assignment node to keep the
+               --  complete assignment subtree consistent enough for
+               --  Analyze_Assignment to proceed. We do not use the
+               --  saved value, the point was just to do the relocation.
+
+            begin
+               Rewrite (Original_Assignment, Blk);
+            end;
 
          elsif Nkind (Parent (N)) = N_Object_Declaration then
             Set_Expression (Parent (N), Empty);
@@ -2471,7 +2483,6 @@ package body Exp_Ch6 is
 
       procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
          HSS  : constant Node_Id := Handled_Statement_Sequence (Blk);
-
       begin
          if Is_Empty_List (Declarations (Blk)) then
             Insert_List_After (N, Statements (HSS));

gcc/ada/g-curexc.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---         Copyright (C) 1996-2000 Ada Core Technologies, Inc.              --
+--         Copyright (C) 1996-2004 Ada Core Technologies, 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- --
@@ -50,6 +50,8 @@ pragma Pure (Current_Exception);
    -- Subprograms --
    -----------------
 
+   --  Note: the lower bound of returnd String values is always one.
+
    function Exception_Information return String;
    --  Returns the result of calling Ada.Exceptions.Exception_Information
    --  with an argument that is the Exception_Occurrence corresponding to

gcc/ada/gnatlink.adb

@@ -988,6 +988,9 @@ procedure Gnatlink is
             --  Add binder options only if not already set on the command
             --  line. This rule is a way to control the linker options order.
 
+            --  The following test needs comments, why is it VMS specific.
+            --  The above comment looks out of date ???
+
             elsif not (Hostparm.OpenVMS
                          and then
                        Is_Option_Present (Next_Line (Nfirst .. Nlast)))

gcc/ada/impunit.adb

@@ -53,6 +53,7 @@ package body Impunit is
      "a-chlat1",    -- Ada.Characters.Latin_1
      "a-comlin",    -- Ada.Command_Line
      "a-decima",    -- Ada.Decimal
+     "a-direct",    -- Ada.Directories
      "a-direio",    -- Ada.Direct_IO
      "a-dynpri",    -- Ada.Dynamic_Priorities
      "a-except",    -- Ada.Exceptions

gcc/ada/init.c

@@ -1777,6 +1777,41 @@ __gnat_initialize (void)
 {
   __gnat_init_float ();
 
+  /* On targets where we might be using the ZCX scheme, we need to register
+     the frame tables.
+
+     For application "modules", the crtstuff objects linked in (crtbegin/endS)
+     are tailored to provide this service a-la C++ constructor fashion,
+     typically triggered by the dynamic loader. This is achieved by way of a
+     special variable declaration in the crt object, the name of which has
+     been deduced by analyzing the output of the "munching" step documented
+     for C++.  The de-registration call is handled symetrically, a-la C++
+     destructor fashion and typically triggered by the dynamic unloader. With
+     this scheme, a mixed Ada/C++ application has to be linked and loaded as
+     separate modules for each language, which is not unreasonable anyway.
+
+     For applications statically linked with the kernel, the module scheme
+     above would lead to duplicated symbols because the VxWorks kernel build
+     "munches" by default. To prevent those conflicts, we link against
+     crtbegin/end objects that don't include the special variable and directly
+     call the appropriate function here. We'll never unload that, so there is
+     no de-registration to worry about.
+
+     We can differentiate between the two cases by looking at the
+     __module_has_ctors value provided by each class of crt objects. As of
+     today, selecting the crt set intended for applications to be statically
+     linked with the kernel is triggered by adding "-static" to the gcc *link*
+     command line options.  */
+
+#if 0
+ {
+   extern const int __module_has_ctors;
+   extern void __do_global_ctors ();
+
+   if (! __module_has_ctors)
+     __do_global_ctors ();
+ }
+#endif
 }
 
 /********************************/

gcc/ada/make.adb

@@ -6778,14 +6778,19 @@ package body Make is
          elsif Argv (2) = 'L' then
             Add_Switch (Argv, Linker, And_Save => And_Save);
 
-         --  For -gxxxxx,-pg,-mxxx: give the switch to both the compiler and
-         --  the linker (except for -gnatxxx which is only for the compiler)
+         --  For -gxxxxx, -pg, -mxxx, -fxxx: give the switch to both the
+         --  compiler and the linker (except for -gnatxxx which is only for
+         --  the compiler). Some of the -mxxx (for example -m64) and -fxxx
+         --  (for example -ftest-coverage for gcov) need to be used when
+         --  compiling the binder generated files, and using all these gcc
+         --  switches for the binder generated files should not be a problem.
 
          elsif
            (Argv (2) = 'g' and then (Argv'Last < 5
                                        or else Argv (2 .. 5) /= "gnat"))
              or else Argv (2 .. Argv'Last) = "pg"
              or else (Argv (2) = 'm' and then Argv'Last > 2)
+             or else (Argv (2) = 'f' and then Argv'Last > 2)
          then
             Add_Switch (Argv, Compiler, And_Save => And_Save);
             Add_Switch (Argv, Linker, And_Save => And_Save);

gcc/ada/mlib-tgt.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---              Copyright (C) 2001-2003, Ada Core Technologies, Inc.        --
+--              Copyright (C) 2001-2004, Ada Core Technologies, 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- --
@@ -86,7 +86,8 @@ package MLib.Tgt is
 
    function DLL_Ext return String;
    --  System dependent dynamic library extension, without leading dot.
-   --  On Unix, returns "so", on Windows, returns "dll".
+   --  On Windows, returns "dll". On Unix, usually returns "so", but not
+   --  always, e.g. on HP-UX the extension for shared libraries is "sl".
 
    function PIC_Option return String;
    --  Position independent code option
@@ -119,11 +120,14 @@ package MLib.Tgt is
       Lib_Version  : String  := "";
       Relocatable  : Boolean := False;
       Auto_Init    : Boolean := False);
-   --  Build a dynamic/relocatable library.
+   --  Build a dynamic/relocatable library
+   --
+   --  Ofiles is the list of all object files in the library
+   --
+   --  Foreign is the list of non Ada object files (also included in Ofiles)
+   --
+   --  Afiles is the list of ALI files for the Ada object files
    --
-   --  Ofiles is the list of all object files in the library.
-   --  Foreign is the list of non Ada object files (also included in Ofiles).
-   --  Afiles is the list of ALI files for the Ada object files.
    --  Options is a list of options to be passed to the tool (gcc or other)
    --  that effectively builds the dynamic library.
    --
@@ -131,10 +135,10 @@ package MLib.Tgt is
    --  It is empty if the library is not a SAL.
    --
    --  Lib_Filename is the name of the library, without any prefix or
-   --  extension. For example, on Unix, if Lib_Filename is "toto", the name of
-   --  the library file will be "libtoto.so".
+   --  extension. For example, on Unix, if Lib_Filename is "toto", the
+   --  name of the library file will be "libtoto.so".
    --
-   --  Lib_Dir is the directory path where the library will be located.
+   --  Lib_Dir is the directory path where the library will be located
    --
    --  Lib_Address is the base address of the library for a non relocatable
    --  library, given as an hexadecimal string.

gcc/ada/par-ch10.adb

@@ -669,6 +669,7 @@ package body Ch10 is
 
             declare
                Save_Style_Check : constant Boolean := Style_Check;
+
             begin
                Style_Check := False;
 
@@ -691,7 +692,6 @@ package body Ch10 is
                   Error_Msg_SC
                     ("end of file expected, " &
                      "file can have only one compilation unit");
-
                else
                   Error_Msg_SC ("end of file expected");
                end if;
@@ -833,7 +833,7 @@ package body Ch10 is
 
             if Token /= Tok_With then
 
-               --  Keyword is beginning of private child unit.
+               --  Keyword is beginning of private child unit
 
                Restore_Scan_State (Scan_State); -- to PRIVATE
                return Item_List;
@@ -901,8 +901,25 @@ package body Ch10 is
                   Set_Limited_Present (With_Node, Has_Limited);
                   Set_Private_Present (With_Node, Has_Private);
                   First_Flag := False;
+
+                  --  All done if no comma
+
                   exit when Token /= Tok_Comma;
+
+                  --  If comma is followed by compilation unit token
+                  --  or by USE, or PRAGMA, then it should have been a
+                  --  semicolon after all
+
+                  Save_Scan_State (Scan_State);
                   Scan; -- past comma
+
+                  if Token in Token_Class_Cunit
+                    or else Token = Tok_Use
+                    or else Token = Tok_Pragma
+                  then
+                     Restore_Scan_State (Scan_State);
+                     exit;
+                  end if;
                end loop;
 
                Set_Last_Name (With_Node, True);

gcc/ada/par-ch3.adb

@@ -721,7 +721,7 @@ package body Ch3 is
    --------------------------------
 
    --  SUBTYPE_DECLARATION ::=
-   --    subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION;
+   --    subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
 
    --  The caller has checked that the initial token is SUBTYPE
 
@@ -1017,9 +1017,9 @@ package body Ch3 is
    --  This routine scans out a declaration starting with an identifier:
 
    --  OBJECT_DECLARATION ::=
-   --    DEFINING_IDENTIFIER_LIST : [constant] [aliased]
-   --      SUBTYPE_INDICATION [:= EXPRESSION];
-   --  | DEFINING_IDENTIFIER_LIST : [constant] [aliased]
+   --    DEFINING_IDENTIFIER_LIST : [aliased] [constant]
+   --      [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
+   --  | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
    --      ARRAY_TYPE_DEFINITION [:= EXPRESSION];
 
    --  NUMBER_DECLARATION ::=
@@ -1519,7 +1519,8 @@ package body Ch3 is
    -------------------------------------------------------------------------
 
    --  DERIVED_TYPE_DEFINITION ::=
-   --    [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART]
+   --    [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
+   --    [RECORD_EXTENSION_PART]
 
    --  PRIVATE_EXTENSION_DECLARATION ::=
    --     type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
@@ -2116,7 +2117,7 @@ package body Ch3 is
    --    DISCRETE_SUBTYPE_INDICATION | RANGE
 
    --  COMPONENT_DEFINITION ::=
-   --    [aliased] SUBTYPE_INDICATION | ACCESS_DEFINITION
+   --    [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
 
    --  The caller has checked that the initial token is ARRAY
 
@@ -2385,7 +2386,7 @@ package body Ch3 is
    --    (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
 
    --  DISCRIMINANT_SPECIFICATION ::=
-   --    DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK
+   --    DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
    --      [:= DEFAULT_EXPRESSION]
    --  | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
    --      [:= DEFAULT_EXPRESSION]
@@ -2866,7 +2867,7 @@ package body Ch3 is
    --      [:= DEFAULT_EXPRESSION];
 
    --  COMPONENT_DEFINITION ::=
-   --    [aliased] SUBTYPE_INDICATION | ACCESS_DEFINITION
+   --    [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
 
    --  Error recovery: cannot raise Error_Resync, if an error occurs,
    --  the scan is positioned past the following semicolon.
@@ -3217,13 +3218,14 @@ package body Ch3 is
    --  | ACCESS_TO_SUBPROGRAM_DEFINITION
 
    --  ACCESS_TO_OBJECT_DEFINITION ::=
-   --    access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
+   --    [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
 
    --  GENERAL_ACCESS_MODIFIER ::= all | constant
 
    --  ACCESS_TO_SUBPROGRAM_DEFINITION
-   --    access [protected] procedure PARAMETER_PROFILE
-   --  | access [protected] function PARAMETER_AND_RESULT_PROFILE
+   --    [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
+   --  | [NULL_EXCLUSION] access [protected] function
+   --    PARAMETER_AND_RESULT_PROFILE
 
    --  PARAMETER_PROFILE ::= [FORMAL_PART]
 
@@ -3362,7 +3364,8 @@ package body Ch3 is
    -- 3.10  Access Definition --
    -----------------------------
 
-   --  ACCESS_DEFINITION ::= access SUBTYPE_MARK
+   --  ACCESS_DEFINITION ::=
+   --    [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
 
    --  The caller has checked that the initial token is ACCESS
 
@@ -3375,7 +3378,7 @@ package body Ch3 is
       Def_Node := New_Node (N_Access_Definition, Token_Ptr);
       Scan; -- past ACCESS
 
-      --  Ada 0Y (AI-231): ACCESS [general_access_modifier] subtype_mark
+      --  Ada 0Y (AI-231)
 
       if Extensions_Allowed then
          if Token = Tok_All then

gcc/ada/par-ch4.adb

@@ -2308,7 +2308,6 @@ package body Ch4 is
 
    function  P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id is
       Qual_Node : Node_Id;
-
    begin
       Qual_Node := New_Node (N_Qualified_Expression, Prev_Token_Ptr);
       Set_Subtype_Mark (Qual_Node, Check_Subtype_Mark (Subtype_Mark));
@@ -2321,7 +2320,7 @@ package body Ch4 is
    --------------------
 
    --  ALLOCATOR ::=
-   --   new SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
+   --    new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
 
    --  The caller has checked that the initial token is NEW
 

gcc/ada/par-ch6.adb

@@ -839,7 +839,7 @@ package body Ch6 is
    --  FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION})
 
    --  PARAMETER_SPECIFICATION ::=
-   --    DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK
+   --    DEFINING_IDENTIFIER_LIST : MODE [NULL_EXCLUSION] SUBTYPE_MARK
    --      [:= DEFAULT_EXPRESSION]
    --  | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
    --      [:= DEFAULT_EXPRESSION]

gcc/ada/s-stoele.ads

@@ -91,8 +91,7 @@ pragma Pure (Storage_Elements);
 
    function "mod"
      (Left  : Address;
-      Right : Storage_Offset)
-      return  Storage_Offset;
+      Right : Storage_Offset) return  Storage_Offset;
    pragma Convention (Intrinsic, "mod");
    pragma Inline_Always ("mod");
    pragma Pure_Function ("mod");

gcc/ada/scng.adb

@@ -459,10 +459,10 @@ package body Scng is
                C := Source (Scan_Ptr);
 
                if C = '_' then
-                  --  We do not want to accumulate the '_' in the checksum,
-                  --  so that 1_234 is equivalent to 1234, and does not
-                  --  trigger compilation in "minimal recompilation"
-                  --  (gnatmake -m).
+
+                  --  We do not accumulate the '_' in the checksum, so that
+                  --  1_234 is equivalent to 1234, and does not trigger
+                  --  compilation for "minimal recompilation" (gnatmake -m).
 
                   loop
                      Scan_Ptr := Scan_Ptr + 1;

gcc/ada/sem_ch3.adb

@@ -4026,6 +4026,7 @@ package body Sem_Ch3 is
 
             Set_First_Entity (Derived_Type, First_Entity (Der_Base));
             Set_Last_Entity  (Derived_Type, Last_Entity  (Der_Base));
+            Set_Stored_Constraint (Full_Der, Stored_Constraint (Derived_Type));
 
          else
             --  If this is a completion, the derived type stays private
@@ -4343,14 +4344,14 @@ package body Sem_Ch3 is
    --  discriminants in R and T1 through T4.
 
    --   Type      Discrim     Stored Discrim  Comment
-   --    R      (D1, D2, D3)   (D1, D2, D3)   Gider discrims are implicit in R
-   --    T1     (D1, D2, D3)   (D1, D2, D3)   Gider discrims are implicit in T1
-   --    T2     (X1, X2)       (D1, D2, D3)   Gider discrims are EXPLICIT in T2
-   --    T3     (X1, X2)       (D1, D2, D3)   Gider discrims are EXPLICIT in T3
-   --    T4     (Y)            (D1, D2, D3)   Gider discrims are EXPLICIT in T4
+   --    R      (D1, D2, D3)   (D1, D2, D3)   Girder discrims implicit in R
+   --    T1     (D1, D2, D3)   (D1, D2, D3)   Girder discrims implicit in T1
+   --    T2     (X1, X2)       (D1, D2, D3)   Girder discrims EXPLICIT in T2
+   --    T3     (X1, X2)       (D1, D2, D3)   Girder discrims EXPLICIT in T3
+   --    T4     (Y)            (D1, D2, D3)   Girder discrims EXPLICIT in T4
 
-   --  Field Corresponding_Discriminant (abbreviated CD below) allows to find
-   --  the corresponding discriminant in the parent type, while
+   --  Field Corresponding_Discriminant (abbreviated CD below) allows us to
+   --  find the corresponding discriminant in the parent type, while
    --  Original_Record_Component (abbreviated ORC below), the actual physical
    --  component that is renamed. Finally the field Is_Completely_Hidden
    --  (abbreviated ICH below) is set for all explicit stored discriminants
@@ -5309,7 +5310,7 @@ package body Sem_Ch3 is
             Set_Discriminant_Constraint
               (Derived_Type, Save_Discr_Constr);
             Set_Stored_Constraint
-              (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs));
+              (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
             Replace_Components (Derived_Type, New_Decl);
          end if;
 
@@ -10472,11 +10473,18 @@ package body Sem_Ch3 is
       --  This is achieved by appending Derived_Base discriminants into
       --  Discs, which has the side effect of returning a non empty Discs
       --  list to the caller of Inherit_Components, which is what we want.
+      --  This must be done for private derived types if there are explicit
+      --  stored discriminants, to ensure that we can retrieve the values of
+      --  the constraints provided in the ancestors.
 
       if Inherit_Discr
         and then Is_Empty_Elmt_List (Discs)
-        and then (not Is_Private_Type (Derived_Base)
-                   or Is_Generic_Type (Derived_Base))
+        and then Present (First_Discriminant (Derived_Base))
+        and then
+          (not Is_Private_Type (Derived_Base)
+           or else Is_Completely_Hidden
+             (First_Stored_Discriminant (Derived_Base))
+           or else Is_Generic_Type (Derived_Base))
       then
          D := First_Discriminant (Derived_Base);
          while Present (D) loop

gcc/ada/sem_ch4.adb

@@ -209,6 +209,10 @@ package body Sem_Ch4 is
    --  for the type is not directly visible. The routine uses this type to emit
    --  a more informative message.
 
+   procedure Remove_Abstract_Operations (N : Node_Id);
+   --  Ada 2005: implementation of AI-310. An abstract non-dispatching
+   --  operation is not a candidate interpretation.
+
    function Try_Indexed_Call
      (N   : Node_Id;
       Nam : Entity_Id;
@@ -852,6 +856,8 @@ package body Sem_Ch4 is
             Generate_Reference (Entity (Nam), Nam);
 
             Set_Etype (Nam, Etype (Entity (Nam)));
+         else
+            Remove_Abstract_Operations (N);
          end if;
 
          End_Interp_List;
@@ -4125,6 +4131,8 @@ package body Sem_Ch4 is
 
    procedure Operator_Check (N : Node_Id) is
    begin
+      Remove_Abstract_Operations (N);
+
       --  Test for case of no interpretation found for operator
 
       if Etype (N) = Any_Type then
@@ -4317,6 +4325,71 @@ package body Sem_Ch4 is
       end if;
    end Operator_Check;
 
+   --------------------------------
+   -- Remove_Abstract_Operations --
+   --------------------------------
+
+   procedure Remove_Abstract_Operations (N : Node_Id) is
+      I               : Interp_Index;
+      It              : Interp;
+      Has_Abstract_Op : Boolean := False;
+
+      --  AI-310: If overloaded, remove abstract non-dispatching
+      --  operations.
+
+   begin
+      if Extensions_Allowed
+        and then Is_Overloaded (N)
+      then
+         Get_First_Interp (N, I, It);
+         while Present (It.Nam) loop
+            if not Is_Type (It.Nam)
+              and then Is_Abstract (It.Nam)
+              and then not Is_Dispatching_Operation (It.Nam)
+            then
+               Has_Abstract_Op := True;
+               Remove_Interp (I);
+               exit;
+            end if;
+
+            Get_Next_Interp (I, It);
+         end loop;
+
+         --  Remove corresponding predefined operator, which is
+         --  always added to the overload set, unless it is a universal
+         --  operation.
+
+         if Nkind (N) in N_Op
+           and then Has_Abstract_Op
+         then
+            if Nkind (N) in N_Unary_Op
+              and then
+                Present (Universal_Interpretation (Etype (Right_Opnd (N))))
+            then
+               return;
+
+            elsif Nkind (N) in N_Binary_Op
+              and then
+                Present (Universal_Interpretation (Etype (Right_Opnd (N))))
+              and then
+                Present (Universal_Interpretation (Etype (Left_Opnd (N))))
+            then
+               return;
+
+            else
+               Get_First_Interp (N, I, It);
+               while Present (It.Nam) loop
+                  if Scope (It.Nam) = Standard_Standard then
+                     Remove_Interp (I);
+                  end if;
+
+                  Get_Next_Interp (I, It);
+               end loop;
+            end if;
+         end if;
+      end if;
+   end Remove_Abstract_Operations;
+
    -----------------------
    -- Try_Indirect_Call --
    -----------------------

gcc/ada/sem_ch5.adb

@@ -339,6 +339,7 @@ package body Sem_Ch5 is
       Set_Assignment_Type (Lhs, T1);
 
       Resolve (Rhs, T1);
+      Check_Unset_Reference (Rhs);
 
       --  Remaining steps are skipped if Rhs was syntactically in error
 
@@ -347,7 +348,6 @@ package body Sem_Ch5 is
       end if;
 
       T2 := Etype (Rhs);
-      Check_Unset_Reference (Rhs);
 
       if Covers (T1, T2) then
          null;
@@ -430,10 +430,16 @@ package body Sem_Ch5 is
          Apply_Length_Check (Rhs, Etype (Lhs));
 
       else
-         --  Discriminant checks are applied in the course of expansion.
+         --  Discriminant checks are applied in the course of expansion
+
          null;
       end if;
 
+      --  Note: modifications of the Lhs may only be recorded after
+      --  checks have been applied.
+
+      Note_Possible_Modification (Lhs);
+
       --  ??? a real accessibility check is needed when ???
 
       --  Post warning for useless assignment
@@ -462,8 +468,6 @@ package body Sem_Ch5 is
            ("?useless assignment of & to itself", N, Entity (Lhs));
       end if;
 
-      Note_Possible_Modification (Lhs);
-
       --  Check for non-allowed composite assignment
 
       if not Support_Composite_Assign_On_Target

gcc/ada/sem_util.adb

@@ -4979,6 +4979,9 @@ package body Sem_Util is
    --------------------------------
 
    procedure Note_Possible_Modification (N : Node_Id) is
+      Modification_Comes_From_Source : constant Boolean :=
+                                         Comes_From_Source (Parent (N));
+
       Ent : Entity_Id;
       Exp : Node_Id;
 
@@ -4993,7 +4996,9 @@ package body Sem_Util is
       procedure Set_Ref (E : Entity_Id; N : Node_Id) is
       begin
          if Is_Object (E) then
-            if Comes_From_Source (N) then
+            if Comes_From_Source (N)
+              or else Modification_Comes_From_Source
+            then
                Set_Never_Set_In_Source (E, False);
             end if;
 
@@ -5015,19 +5020,60 @@ package body Sem_Util is
 
       Exp := N;
       loop
-         --  Test for node rewritten as dereference (e.g. accept parameter)
-
-         if Nkind (Exp) = N_Explicit_Dereference
-           and then not Comes_From_Source (Exp)
-         then
-            Exp := Original_Node (Exp);
-         end if;
-
-         --  Now look for entity being referenced
+         Ent := Empty;
 
          if Is_Entity_Name (Exp) then
             Ent := Entity (Exp);
 
+         elsif Nkind (Exp) = N_Explicit_Dereference then
+            declare
+               P : constant Node_Id := Prefix (Exp);
+
+            begin
+               if Nkind (P) = N_Selected_Component
+                 and then Present (
+                   Entry_Formal (Entity (Selector_Name (P))))
+               then
+                  --  Case of a reference to an entry formal
+
+                  Ent := Entry_Formal (Entity (Selector_Name (P)));
+
+               elsif Nkind (P) = N_Identifier
+                 and then Nkind (Parent (Entity (P))) = N_Object_Declaration
+                 and then Present (Expression (Parent (Entity (P))))
+                 and then Nkind (Expression (Parent (Entity (P))))
+                   = N_Reference
+               then
+                  --  Case of a reference to a value on which
+                  --  side effects have been removed.
+
+                  Exp := Prefix (Expression (Parent (Entity (P))));
+
+               else
+                  return;
+
+               end if;
+            end;
+
+         elsif     Nkind (Exp) = N_Type_Conversion
+           or else Nkind (Exp) = N_Unchecked_Type_Conversion
+         then
+            Exp := Expression (Exp);
+
+         elsif     Nkind (Exp) = N_Slice
+           or else Nkind (Exp) = N_Indexed_Component
+           or else Nkind (Exp) = N_Selected_Component
+         then
+            Exp := Prefix (Exp);
+
+         else
+            return;
+
+         end if;
+
+         --  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
@@ -5046,20 +5092,6 @@ package body Sem_Util is
                Kill_Checks (Ent);
                return;
             end if;
-
-         elsif     Nkind (Exp) = N_Type_Conversion
-           or else Nkind (Exp) = N_Unchecked_Type_Conversion
-         then
-            Exp := Expression (Exp);
-
-         elsif     Nkind (Exp) = N_Slice
-           or else Nkind (Exp) = N_Indexed_Component
-           or else Nkind (Exp) = N_Selected_Component
-         then
-            Exp := Prefix (Exp);
-
-         else
-            return;
          end if;
       end loop;
    end Note_Possible_Modification;

gcc/ada/sem_warn.adb

@@ -351,7 +351,7 @@ package body Sem_Warn is
       E1 := First_Entity (E);
       while Present (E1) loop
 
-         --  We only look at source entities with warning flag off
+         --  We only look at source entities with warning flag on
 
          if Comes_From_Source (E1) and then not Warnings_Off (E1) then
 
@@ -367,6 +367,14 @@ package body Sem_Warn is
                --  do not consider the implicit initialization of an access
                --  type to be the assignment of a value for this purpose.
 
+               if Ekind (E1) = E_Out_Parameter
+                 and then Present (Spec_Entity (E1))
+               then
+                  UR := Unset_Reference (Spec_Entity (E1));
+               else
+                  UR := Unset_Reference (E1);
+               end if;
+
                --  If the entity is an out parameter of the current subprogram
                --  body, check the warning status of the parameter in the spec.
 
@@ -376,6 +384,23 @@ package body Sem_Warn is
                then
                   null;
 
+               elsif Warn_On_No_Value_Assigned
+                 and then Present (UR)
+                 and then Is_Access_Type (Etype (E1))
+               then
+
+                  --  For access types, the only time we made a UR
+                  --  entry was for a dereference, and so we post
+                  --  the appropriate warning here (note that the
+                  --  dereference may not be explicit in the source,
+                  --  for example in the case of a dispatching call
+                  --  with an anonymous access controlling formal, or
+                  --  of an assignment of a pointer involving a
+                  --  discriminant check on the designated object).
+
+                  Error_Msg_NE ("& may be null?", UR, E1);
+                  goto Continue;
+
                elsif Never_Set_In_Source (E1)
                  and then not Generic_Package_Spec_Entity (E1)
                then
@@ -435,86 +460,67 @@ package body Sem_Warn is
                --  types from this check, since access types do always have
                --  a null value, and that seems legitimate in this case.
 
-               if Ekind (E1) = E_Out_Parameter
-                 and then Present (Spec_Entity (E1))
-               then
-                  UR := Unset_Reference (Spec_Entity (E1));
-               else
-                  UR := Unset_Reference (E1);
-               end if;
-
                if Warn_On_No_Value_Assigned and then Present (UR) then
 
-                  --  For access types, the only time we made a UR entry
-                  --  was for a dereference, and so we post the appropriate
-                  --  warning here. The issue is not that the value is not
-                  --  initialized here, but that it is null.
-
-                  if Is_Access_Type (Etype (E1)) then
-                     Error_Msg_NE ("& may be null?", UR, E1);
-                     goto Continue;
-
                   --  For other than access type, go back to original node
                   --  to deal with case where original unset reference
                   --  has been rewritten during expansion.
 
-                  else
-                     UR := Original_Node (UR);
+                  UR := Original_Node (UR);
 
-                     --  In some cases, the original node may be a type
-                     --  conversion or qualification, and in this case
-                     --  we want the object entity inside.
+                  --  In some cases, the original node may be a type
+                  --  conversion or qualification, and in this case
+                  --  we want the object entity inside.
 
-                     while Nkind (UR) = N_Type_Conversion
-                       or else Nkind (UR) = N_Qualified_Expression
-                     loop
-                        UR := Expression (UR);
-                     end loop;
+                  while Nkind (UR) = N_Type_Conversion
+                    or else Nkind (UR) = N_Qualified_Expression
+                  loop
+                     UR := Expression (UR);
+                  end loop;
 
-                     --  Here we issue the warning, all checks completed
-                     --  If the unset reference is prefix of a selected
-                     --  component that comes from source, mention the
-                     --  component as well. If the selected component comes
-                     --  from expansion, all we know is that the entity is
-                     --  not fully initialized at the point of the reference.
-                     --  Locate an unintialized component to get a better
-                     --  error message.
+                  --  Here we issue the warning, all checks completed
+                  --  If the unset reference is prefix of a selected
+                  --  component that comes from source, mention the
+                  --  component as well. If the selected component comes
+                  --  from expansion, all we know is that the entity is
+                  --  not fully initialized at the point of the reference.
+                  --  Locate an unintialized component to get a better
+                  --  error message.
 
-                     if Nkind (Parent (UR)) = N_Selected_Component then
-                        Error_Msg_Node_2 := Selector_Name (Parent (UR));
+                  if Nkind (Parent (UR)) = N_Selected_Component then
+                     Error_Msg_Node_2 := Selector_Name (Parent (UR));
 
-                        if not Comes_From_Source (Parent (UR)) then
-                           declare
-                              Comp : Entity_Id;
+                     if not Comes_From_Source (Parent (UR)) then
+                        declare
+                           Comp : Entity_Id;
 
-                           begin
-                              Comp := First_Entity (Etype (E1));
-                              while Present (Comp) loop
-                                 if Ekind (Comp) = E_Component
-                                   and then Nkind (Parent (Comp)) =
-                                     N_Component_Declaration
-                                   and then No (Expression (Parent (Comp)))
-                                 then
-                                    Error_Msg_Node_2 := Comp;
-                                    exit;
-                                 end if;
+                        begin
+                           Comp := First_Entity (Etype (E1));
+                           while Present (Comp) loop
+                              if Ekind (Comp) = E_Component
+                                and then Nkind (Parent (Comp)) =
+                                  N_Component_Declaration
+                                and then No (Expression (Parent (Comp)))
+                              then
+                                 Error_Msg_Node_2 := Comp;
+                                 exit;
+                              end if;
 
-                                 Next_Entity (Comp);
-                              end loop;
-                           end;
-                        end if;
-
-                        Error_Msg_N
-                          ("`&.&` may be referenced before it has a value?",
-                           UR);
-                     else
-                        Error_Msg_N
-                          ("& may be referenced before it has a value?",
-                           UR);
+                              Next_Entity (Comp);
+                           end loop;
+                        end;
                      end if;
 
-                     goto Continue;
+                     Error_Msg_N
+                       ("`&.&` may be referenced before it has a value?",
+                        UR);
+                  else
+                     Error_Msg_N
+                       ("& may be referenced before it has a value?",
+                        UR);
                   end if;
+
+                  goto Continue;
                end if;
             end if;
 

gcc/ada/sinfo.ads

@@ -4242,7 +4242,7 @@ package Sinfo is
 
       --  PRIVATE_TYPE_DECLARATION ::=
       --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
-      --      is [[abstract] tagged] [limited] private;
+      --      is [abstract] tagged] [limited] private;
 
       --  Note: TAGGED is not permitted in Ada 83 mode
 

gcc/ada/tbuild.adb

@@ -113,7 +113,6 @@ package body Tbuild is
 
    procedure Discard_List (L : List_Id) is
       pragma Warnings (Off, L);
-
    begin
       null;
    end Discard_List;
@@ -124,7 +123,6 @@ package body Tbuild is
 
    procedure Discard_Node (N : Node_Or_Entity_Id) is
       pragma Warnings (Off, N);
-
    begin
       null;
    end Discard_Node;
@@ -157,10 +155,9 @@ package body Tbuild is
    --------------------
 
    function Make_DT_Access
-     (Loc  : Source_Ptr;
-      Rec  : Node_Id;
-      Typ  : Entity_Id)
-      return Node_Id
+     (Loc : Source_Ptr;
+      Rec : Node_Id;
+      Typ : Entity_Id) return Node_Id
    is
       Full_Type : Entity_Id := Typ;
 
@@ -183,10 +180,9 @@ package body Tbuild is
    -----------------------
 
    function Make_DT_Component
-     (Loc  : Source_Ptr;
-      Typ  : Entity_Id;
-      I    : Positive)
-      return Node_Id
+     (Loc : Source_Ptr;
+      Typ : Entity_Id;
+      I   : Positive) return Node_Id
    is
       X : Node_Id;
       Full_Type : Entity_Id := Typ;
@@ -215,8 +211,7 @@ package body Tbuild is
       Condition       : Node_Id;
       Then_Statements : List_Id;
       Elsif_Parts     : List_Id := No_List;
-      Else_Statements : List_Id := No_List)
-      return            Node_Id
+      Else_Statements : List_Id := No_List) return Node_Id
    is
    begin
       Check_Restriction (No_Implicit_Conditionals, Node);
@@ -234,8 +229,7 @@ package body Tbuild is
    function Make_Implicit_Label_Declaration
      (Loc                 : Source_Ptr;
       Defining_Identifier : Node_Id;
-      Label_Construct     : Node_Id)
-      return                Node_Id
+      Label_Construct     : Node_Id) return Node_Id
    is
       N : constant Node_Id :=
             Make_Implicit_Label_Declaration (Loc, Defining_Identifier);
@@ -255,8 +249,7 @@ package body Tbuild is
       Identifier             : Node_Id := Empty;
       Iteration_Scheme       : Node_Id := Empty;
       Has_Created_Identifier : Boolean := False;
-      End_Label              : Node_Id := Empty)
-      return                   Node_Id
+      End_Label              : Node_Id := Empty) return Node_Id
    is
    begin
       Check_Restriction (No_Implicit_Loops, Node);
@@ -281,8 +274,7 @@ package body Tbuild is
 
    function Make_Integer_Literal
      (Loc    : Source_Ptr;
-      Intval : Int)
-      return   Node_Id
+      Intval : Int) return Node_Id
    is
    begin
       return Make_Integer_Literal (Loc, UI_From_Int (Intval));
@@ -295,8 +287,7 @@ package body Tbuild is
    function Make_Raise_Constraint_Error
      (Sloc      : Source_Ptr;
       Condition : Node_Id := Empty;
-      Reason    : RT_Exception_Code)
-      return      Node_Id
+      Reason    : RT_Exception_Code) return Node_Id
    is
    begin
       pragma Assert (Reason in RT_CE_Exceptions);
@@ -314,8 +305,7 @@ package body Tbuild is
    function Make_Raise_Program_Error
      (Sloc      : Source_Ptr;
       Condition : Node_Id := Empty;
-      Reason    : RT_Exception_Code)
-      return      Node_Id
+      Reason    : RT_Exception_Code) return Node_Id
    is
    begin
       pragma Assert (Reason in RT_PE_Exceptions);
@@ -333,8 +323,7 @@ package body Tbuild is
    function Make_Raise_Storage_Error
      (Sloc      : Source_Ptr;
       Condition : Node_Id := Empty;
-      Reason    : RT_Exception_Code)
-      return      Node_Id
+      Reason    : RT_Exception_Code) return Node_Id
    is
    begin
       pragma Assert (Reason in RT_SE_Exceptions);
@@ -360,8 +349,7 @@ package body Tbuild is
    function Make_Unsuppress_Block
      (Loc   : Source_Ptr;
       Check : Name_Id;
-      Stmts : List_Id)
-      return  Node_Id
+      Stmts : List_Id) return Node_Id
    is
    begin
       return
@@ -403,8 +391,7 @@ package body Tbuild is
      (Related_Id   : Name_Id;
       Suffix       : Character := ' ';
       Suffix_Index : Int       := 0;
-      Prefix       : Character := ' ')
-      return         Name_Id
+      Prefix       : Character := ' ') return Name_Id
    is
    begin
       Get_Name_String (Related_Id);
@@ -441,8 +428,7 @@ package body Tbuild is
      (Related_Id   : Name_Id;
       Suffix       : String;
       Suffix_Index : Int       := 0;
-      Prefix       : Character := ' ')
-      return         Name_Id
+      Prefix       : Character := ' ') return Name_Id
    is
    begin
       Get_Name_String (Related_Id);
@@ -476,8 +462,7 @@ package body Tbuild is
 
    function New_External_Name
      (Suffix       : Character;
-      Suffix_Index : Nat)
-      return         Name_Id
+      Suffix_Index : Nat) return Name_Id
    is
    begin
       Name_Buffer (1) := Suffix;
@@ -505,8 +490,7 @@ package body Tbuild is
 
    function New_Occurrence_Of
      (Def_Id : Entity_Id;
-      Loc    : Source_Ptr)
-      return   Node_Id
+      Loc    : Source_Ptr) return Node_Id
    is
       Occurrence : Node_Id;
 
@@ -530,8 +514,7 @@ package body Tbuild is
 
    function New_Reference_To
      (Def_Id : Entity_Id;
-      Loc    : Source_Ptr)
-      return   Node_Id
+      Loc    : Source_Ptr) return Node_Id
    is
       Occurrence : Node_Id;
 
@@ -548,8 +531,7 @@ package body Tbuild is
 
    function New_Suffixed_Name
      (Related_Id : Name_Id;
-      Suffix     : String)
-      return       Name_Id
+      Suffix     : String) return Name_Id
    is
    begin
       Get_Name_String (Related_Id);
@@ -566,7 +548,6 @@ package body Tbuild is
 
    function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
       Result : Node_Id;
-
    begin
       Result :=
         Make_Type_Conversion (Sloc (Expr),
@@ -583,8 +564,7 @@ package body Tbuild is
 
    function Unchecked_Convert_To
      (Typ  : Entity_Id;
-      Expr : Node_Id)
-      return Node_Id
+      Expr : Node_Id) return Node_Id
    is
       Loc    : constant Source_Ptr := Sloc (Expr);
       Result : Node_Id;
@@ -607,8 +587,9 @@ package body Tbuild is
       then
          Result := Relocate_Node (Expr);
 
-      elsif Nkind (Expr) = N_Null then
-
+      elsif Nkind (Expr) = N_Null
+        and then Is_Access_Type (Typ)
+      then
          --  No need for a conversion
 
          Result := Relocate_Node (Expr);

gcc/ada/tbuild.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2003, 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- --
@@ -63,8 +63,7 @@ package Tbuild is
    function Make_Byte_Aligned_Attribute_Reference
      (Sloc           : Source_Ptr;
       Prefix         : Node_Id;
-      Attribute_Name : Name_Id)
-      return           Node_Id;
+      Attribute_Name : Name_Id) return Node_Id;
    pragma Inline (Make_Byte_Aligned_Attribute_Reference);
    --  Like the standard Make_Attribute_Reference but the special flag
    --  Must_Be_Byte_Aligned is set in the attribute reference node. The
@@ -73,8 +72,7 @@ package Tbuild is
    function Make_DT_Component
      (Loc  : Source_Ptr;
       Typ  : Entity_Id;
-      I    : Positive)
-      return Node_Id;
+      I    : Positive) return Node_Id;
    --  Gives a reference to the Ith component of the Dispatch Table of
    --  a given Tagged Type.
    --
@@ -95,8 +93,7 @@ package Tbuild is
       Condition       : Node_Id;
       Then_Statements : List_Id;
       Elsif_Parts     : List_Id := No_List;
-      Else_Statements : List_Id := No_List)
-      return            Node_Id;
+      Else_Statements : List_Id := No_List) return Node_Id;
    pragma Inline (Make_Implicit_If_Statement);
    --  This function makes an N_If_Statement node whose fields are filled
    --  in with the indicated values (see Sinfo), and whose Sloc field is
@@ -108,8 +105,7 @@ package Tbuild is
    function Make_Implicit_Label_Declaration
      (Loc                 : Source_Ptr;
       Defining_Identifier : Node_Id;
-      Label_Construct     : Node_Id)
-      return                Node_Id;
+      Label_Construct     : Node_Id) return Node_Id;
    --  Used to contruct an implicit label declaration node, including setting
    --  the proper Label_Construct field (since Label_Construct is a semantic
    --  field, the normal call to Make_Implicit_Label_Declaration does not
@@ -121,8 +117,7 @@ package Tbuild is
       Identifier             : Node_Id := Empty;
       Iteration_Scheme       : Node_Id := Empty;
       Has_Created_Identifier : Boolean := False;
-      End_Label              : Node_Id := Empty)
-      return                   Node_Id;
+      End_Label              : Node_Id := Empty) return Node_Id;
    --  This function makes an N_Loop_Statement node whose fields are filled
    --  in with the indicated values (see Sinfo), and whose Sloc field is
    --  is set to Sloc (Node). The effect is identical to calling function
@@ -133,16 +128,14 @@ package Tbuild is
 
    function Make_Integer_Literal
      (Loc    : Source_Ptr;
-      Intval : Int)
-      return   Node_Id;
+      Intval : Int) return Node_Id;
    pragma Inline (Make_Integer_Literal);
    --  A convenient form of Make_Integer_Literal taking Int instead of Uint
 
    function Make_Raise_Constraint_Error
      (Sloc      : Source_Ptr;
       Condition : Node_Id := Empty;
-      Reason    : RT_Exception_Code)
-      return      Node_Id;
+      Reason    : RT_Exception_Code) return Node_Id;
    pragma Inline (Make_Raise_Constraint_Error);
    --  A convenient form of Make_Raise_Constraint_Error where the Reason
    --  is given simply as an enumeration value, rather than a Uint code.
@@ -150,8 +143,7 @@ package Tbuild is
    function Make_Raise_Program_Error
      (Sloc      : Source_Ptr;
       Condition : Node_Id := Empty;
-      Reason    : RT_Exception_Code)
-      return      Node_Id;
+      Reason    : RT_Exception_Code) return Node_Id;
    pragma Inline (Make_Raise_Program_Error);
    --  A convenient form of Make_Raise_Program_Error where the Reason
    --  is given simply as an enumeration value, rather than a Uint code.
@@ -159,8 +151,7 @@ package Tbuild is
    function Make_Raise_Storage_Error
      (Sloc      : Source_Ptr;
       Condition : Node_Id := Empty;
-      Reason    : RT_Exception_Code)
-      return      Node_Id;
+      Reason    : RT_Exception_Code) return Node_Id;
    pragma Inline (Make_Raise_Storage_Error);
    --  A convenient form of Make_Raise_Storage_Error where the Reason
    --  is given simply as an enumeration value, rather than a Uint code.
@@ -168,8 +159,7 @@ package Tbuild is
    function Make_Unsuppress_Block
      (Loc   : Source_Ptr;
       Check : Name_Id;
-      Stmts : List_Id)
-      return  Node_Id;
+      Stmts : List_Id) return Node_Id;
    --  Build a block with a pragma Suppress on 'Check'. Stmts is the
    --  statements list that needs protection against the check
 
@@ -182,14 +172,12 @@ package Tbuild is
      (Related_Id   : Name_Id;
       Suffix       : Character := ' ';
       Suffix_Index : Int       := 0;
-      Prefix       : Character := ' ')
-      return         Name_Id;
+      Prefix       : Character := ' ') return Name_Id;
    function New_External_Name
      (Related_Id   : Name_Id;
       Suffix       : String;
       Suffix_Index : Int       := 0;
-      Prefix       : Character := ' ')
-      return         Name_Id;
+      Prefix       : Character := ' ') return Name_Id;
    --  Builds a new entry in the names table of the form:
    --
    --    [Prefix  &] Related_Id [& Suffix] [& Suffix_Index]
@@ -217,8 +205,7 @@ package Tbuild is
 
    function New_External_Name
      (Suffix       : Character;
-      Suffix_Index : Nat)
-      return         Name_Id;
+      Suffix_Index : Nat) return Name_Id;
    --  Builds a new entry in the names table of the form
    --    Suffix & Suffix_Index'Image
    --  where Suffix is a single upper case letter other than O,Q,U,W,X and is
@@ -249,8 +236,7 @@ package Tbuild is
 
    function New_Occurrence_Of
      (Def_Id : Entity_Id;
-      Loc    : Source_Ptr)
-      return   Node_Id;
+      Loc    : Source_Ptr) return Node_Id;
    --  New_Occurrence_Of creates an N_Identifier node which is an
    --  occurrence of the defining identifier which is passed as its
    --  argument. The Entity and Etype of the result are set from
@@ -260,16 +246,14 @@ package Tbuild is
 
    function New_Reference_To
      (Def_Id : Entity_Id;
-      Loc    : Source_Ptr)
-      return   Node_Id;
+      Loc    : Source_Ptr) return Node_Id;
    --  This is like New_Occurrence_Of, but it does not set the Etype field.
    --  It is used from the expander, where Etype fields are generally not set,
    --  since they are set when the expanded tree is reanalyzed.
 
    function New_Suffixed_Name
      (Related_Id : Name_Id;
-      Suffix     : String)
-      return       Name_Id;
+      Suffix     : String) return Name_Id;
    --  This function is used to create special suffixed names used by the
    --  debugger. Suffix is a string of upper case letters, used to construct
    --  the required name. For instance, the special type used to record the
@@ -282,8 +266,7 @@ package Tbuild is
 
    function Unchecked_Convert_To
      (Typ  : Entity_Id;
-      Expr : Node_Id)
-      return Node_Id;
+      Expr : Node_Id) return Node_Id;
    --  Like Convert_To, but if a conversion is actually needed, constructs
    --  an N_Unchecked_Type_Conversion node to do the required conversion.
 

gcc/ada/tracebak.c

@@ -6,7 +6,7 @@
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *           Copyright (C) 2000-2003 Ada Core Technologies, Inc.            *
+ *           Copyright (C) 2000-2004 Ada Core Technologies, 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- *
@@ -230,7 +230,7 @@ struct layout
 
 #define FRAME_OFFSET 0
 #define PC_ADJUST -4
-#define STOP_FRAME(CURRENT, TOP_STACK) ((CURRENT)->return_address == 0)
+#define STOP_FRAME(CURRENT, TOP_STACK) ((CURRENT)->next == 0)
 
 #define BASE_SKIP 1
 
@@ -322,7 +322,6 @@ extern unsigned int _image_base__;
 # define CURRENT_STACK_FRAME  ({ char __csf; &__csf; })
 #endif
 
-
 #ifndef VALID_STACK_FRAME
 #define VALID_STACK_FRAME(ptr) 1
 #endif