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
-- 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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
+
+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.
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 \
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 \
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) \
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
+
+
-- --
-- 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- --
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;
--------------------
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. */
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);
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;
------------------
procedure Error_Msg_SC (Msg : String) is
+ pragma Warnings (Off, Msg);
begin
null;
end Error_Msg_SC;
------------------
procedure Error_Msg_SP (Msg : String) is
+ pragma Warnings (Off, Msg);
begin
null;
end Error_Msg_SP;
- pragma Warnings (On);
-
-----------------------
-- Get_File_Checksum --
-----------------------
-- --
-- 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- --
-- 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
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;
-- 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);
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;
function Fraction (RT : R; X : T) return T is
X_Frac : T;
X_Exp : UI;
-
begin
if UR_Is_Zero (X) then
return X;
------------------
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;
-------------
(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));
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);
-- --
-- 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- --
(RT : R;
X : T;
Mode : Rounding_Mode;
- Enode : Node_Id)
- return T;
+ Enode : Node_Id) return T;
end Eval_Fat;
-- 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);
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));
-- --
-- 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- --
-- 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
-- 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)))
"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
{
__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
}
/********************************/
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);
-- --
-- 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- --
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
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.
--
-- 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.
declare
Save_Style_Check : constant Boolean := Style_Check;
+
begin
Style_Check := False;
Error_Msg_SC
("end of file expected, " &
"file can have only one compilation unit");
-
else
Error_Msg_SC ("end of file expected");
end if;
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;
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);
--------------------------------
-- 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
-- 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 ::=
-------------------------------------------------------------------------
-- 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
-- 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
-- (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]
-- [:= 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.
-- | 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]
-- 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
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
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));
--------------------
-- 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
-- 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]
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");
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;
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
-- 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
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;
-- 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
-- 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;
Generate_Reference (Entity (Nam), Nam);
Set_Etype (Nam, Etype (Entity (Nam)));
+ else
+ Remove_Abstract_Operations (N);
end if;
End_Interp_List;
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
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 --
-----------------------
Set_Assignment_Type (Lhs, T1);
Resolve (Rhs, T1);
+ Check_Unset_Reference (Rhs);
-- Remaining steps are skipped if Rhs was syntactically in error
end if;
T2 := Etype (Rhs);
- Check_Unset_Reference (Rhs);
if Covers (T1, T2) then
null;
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
("?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
--------------------------------
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;
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;
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
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;
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
-- 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.
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
-- 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;
-- 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
procedure Discard_List (L : List_Id) is
pragma Warnings (Off, L);
-
begin
null;
end Discard_List;
procedure Discard_Node (N : Node_Or_Entity_Id) is
pragma Warnings (Off, N);
-
begin
null;
end Discard_Node;
--------------------
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;
-----------------------
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;
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);
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);
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);
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));
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);
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);
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);
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
(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);
(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);
function New_External_Name
(Suffix : Character;
- Suffix_Index : Nat)
- return Name_Id
+ Suffix_Index : Nat) return Name_Id
is
begin
Name_Buffer (1) := Suffix;
function New_Occurrence_Of
(Def_Id : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr) return Node_Id
is
Occurrence : Node_Id;
function New_Reference_To
(Def_Id : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr) return Node_Id
is
Occurrence : Node_Id;
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);
function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id is
Result : Node_Id;
-
begin
Result :=
Make_Type_Conversion (Sloc (Expr),
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;
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);
-- --
-- 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- --
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
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.
--
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
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
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
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.
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.
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.
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
(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]
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
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
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
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.
* *
* 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- *
#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
# define CURRENT_STACK_FRAME ({ char __csf; &__csf; })
#endif
-
#ifndef VALID_STACK_FRAME
#define VALID_STACK_FRAME(ptr) 1
#endif
OSDN Git Service
