diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-04-05 14:57:42 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-04-05 14:57:42 +0000 |
| commit | d24d7e81b6a309d113bc69412592c363733bc095 (patch) | |
| tree | 2d91f19f11f8b38d7d3f5b5cf90649006ce6ddb8 /gcc/ada | |
| parent | 66d12a6c0042f50195e3775da6684f7455019f15 (diff) | |
| download | gcc-d24d7e81b6a309d113bc69412592c363733bc095.tar.gz | |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@80431 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
38 files changed, 2369 insertions, 281 deletions
diff --git a/gcc/ada/5gmastop.adb b/gcc/ada/5gmastop.adb index d75bf326b7a..74b1818f752 100644 --- a/gcc/ada/5gmastop.adb +++ b/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); diff --git a/gcc/ada/5vdirval.adb b/gcc/ada/5vdirval.adb new file mode 100644 index 00000000000..76cae74aa34 --- /dev/null +++ b/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; + diff --git a/gcc/ada/5wdirval.adb b/gcc/ada/5wdirval.adb new file mode 100644 index 00000000000..4607fb17791 --- /dev/null +++ b/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; + diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1ff5439c701..2cd3dd6126f 100644 --- a/gcc/ada/ChangeLog +++ b/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. diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 3fd157b4e59..072c9e8f7d6 100644 --- a/gcc/ada/Makefile.in +++ b/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 \ diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index f2499814421..3fe48f3016c 100644 --- a/gcc/ada/Makefile.rtl +++ b/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) \ diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb new file mode 100644 index 00000000000..74757fe8077 --- /dev/null +++ b/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; + diff --git a/gcc/ada/a-direct.ads b/gcc/ada/a-direct.ads new file mode 100644 index 00000000000..b5ed79b3bee --- /dev/null +++ b/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; + + diff --git a/gcc/ada/a-dirval.adb b/gcc/ada/a-dirval.adb new file mode 100644 index 00000000000..f0740d2c0e0 --- /dev/null +++ b/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; + + diff --git a/gcc/ada/a-dirval.ads b/gcc/ada/a-dirval.ads new file mode 100644 index 00000000000..23d681cdbfd --- /dev/null +++ b/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; + + diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index cf12af818c7..8e9e98c342d 100644 --- a/gcc/ada/a-except.adb +++ b/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; -------------------- diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 0b27ada7ef4..4c1430dd235 100644 --- a/gcc/ada/adaint.c +++ b/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. */ diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index bcfb453e221..def011c678b 100644 --- a/gcc/ada/adaint.h +++ b/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); diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index 07ed8f14c44..1358ed07c11 100644 --- a/gcc/ada/ali-util.adb +++ b/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 -- ----------------------- diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb index f8d14bfe2fa..2a5357cb311 100644 --- a/gcc/ada/eval_fat.adb +++ b/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); diff --git a/gcc/ada/eval_fat.ads b/gcc/ada/eval_fat.ads index 45dfc69c537..451326dd523 100644 --- a/gcc/ada/eval_fat.ads +++ b/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; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 469bae6caa4..a405d6bece5 100644 --- a/gcc/ada/exp_ch6.adb +++ b/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)); diff --git a/gcc/ada/g-curexc.ads b/gcc/ada/g-curexc.ads index 9b552b1ab48..87017c71df2 100644 --- a/gcc/ada/g-curexc.ads +++ b/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 diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 83313755ba7..52920794600 100644 --- a/gcc/ada/gnatlink.adb +++ b/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))) diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 1f6b5b6658e..b69886cca90 100644 --- a/gcc/ada/impunit.adb +++ b/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 diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 61981725eaa..50e0feb085a 100644 --- a/gcc/ada/init.c +++ b/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 } /********************************/ diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 89b0d69a739..35875997962 100644 --- a/gcc/ada/make.adb +++ b/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); diff --git a/gcc/ada/mlib-tgt.ads b/gcc/ada/mlib-tgt.ads index 1fac4efe3fc..a6458956cdc 100644 --- a/gcc/ada/mlib-tgt.ads +++ b/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. diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index 97d4c362daa..d45e727e97c 100644 --- a/gcc/ada/par-ch10.adb +++ b/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); diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 7940fe4c505..c109d3f2387 100644 --- a/gcc/ada/par-ch3.adb +++ b/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 diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 791a866c95f..1e8e23f1e10 100644 --- a/gcc/ada/par-ch4.adb +++ b/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 diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 964a9a60aa7..3d7e2708c84 100644 --- a/gcc/ada/par-ch6.adb +++ b/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] diff --git a/gcc/ada/s-stoele.ads b/gcc/ada/s-stoele.ads index 30eff082bf7..535813852b0 100644 --- a/gcc/ada/s-stoele.ads +++ b/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"); diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 690656c76fb..93e340f54ac 100644 --- a/gcc/ada/scng.adb +++ b/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; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1c33c4ab582..cf0ba5e6678 100644 --- a/gcc/ada/sem_ch3.adb +++ b/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 - - -- Field Corresponding_Discriminant (abbreviated CD below) allows to find - -- the corresponding discriminant in the parent type, while + -- 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 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 diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 06e296a0aa4..1ac9b4491fd 100644 --- a/gcc/ada/sem_ch4.adb +++ b/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 -- ----------------------- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 42db6899373..c43aee8cf0a 100644 --- a/gcc/ada/sem_ch5.adb +++ b/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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 36f165f1e32..578c9340f94 100644 --- a/gcc/ada/sem_util.adb +++ b/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) + 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); - if Nkind (Exp) = N_Explicit_Dereference - and then not Comes_From_Source (Exp) + elsif Nkind (Exp) = N_Slice + or else Nkind (Exp) = N_Indexed_Component + or else Nkind (Exp) = N_Selected_Component then - Exp := Original_Node (Exp); + Exp := Prefix (Exp); + + else + return; + end if; -- Now look for entity being referenced - if Is_Entity_Name (Exp) then - Ent := Entity (Exp); - + 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; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index c6aa3599d5d..187fc9bf389 100644 --- a/gcc/ada/sem_warn.adb +++ b/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; - - Next_Entity (Comp); - end loop; - end; - 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; - 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; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 7f35f5c384a..5ee8fb38827 100644 --- a/gcc/ada/sinfo.ads +++ b/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 diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 00131e7c06b..60242a5e8c2 100644 --- a/gcc/ada/tbuild.adb +++ b/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); diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index cca92773c43..7aac7295600 100644 --- a/gcc/ada/tbuild.ads +++ b/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. diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index 59ed396d266..991550ad540 100644 --- a/gcc/ada/tracebak.c +++ b/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 |