This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Reflect ACT changes of 2001-10-29
- From: Geert Bosch <bosch at darwin dot gnat dot com>
- To: gcc-patches at gcc dot gnu dot org
- Date: Tue, 11 Dec 2001 17:50:58 -0500 (EST)
- Subject: [Ada] Reflect ACT changes of 2001-10-29
2001-12-11 Robert Dewar <dewar@gnat.com>
* lib-xref.adb (Output_Refs): Don't output type references outside
the main unit if they are not otherwise referenced.
2001-12-11 Ed Schonberg <schonber@gnat.com>
* sem_attr.adb (Analyze_attribute, case Address and Size): Simplify
code and diagnose additional illegal uses
* sem_util.adb (Is_Object_Reference): An indexed component is an
object only if the prefix is.
2001-12-11 Vincent Celier <celier@gnat.com>
* g-diopit.adb: Initial version.
* g-diopit.ads: Initial version.
* g-dirope.adb:
(Expand_Path): Avoid use of Unbounded_String
(Find, Wildcard_Iterator): Moved to child package Iteration
* Makefile.in: Added g-diopit.o to GNATRTL_NONTASKING_OBJS
2001-12-11 Richard Kenner <dewar@gnat.com>
* sem_attr.adb: Minor reformatting
*** lib-xref.adb 2001/10/28 15:14:16 1.57
--- lib-xref.adb 2001/10/29 02:35:13 1.58
***************
*** 751,757 ****
if Sloc (Tref) = Standard_Location then
! -- For now, output only if speial -gnatdM flag set
exit when not Debug_Flag_MM;
--- 751,757 ----
if Sloc (Tref) = Standard_Location then
! -- For now, output only if special -gnatdM flag set
exit when not Debug_Flag_MM;
***************
*** 768,773 ****
--- 768,781 ----
-- unless we have special debug flag -gnatdM
exit when not (Debug_Flag_MM or else Left = '<');
+
+ -- Do not output type reference if referenced
+ -- entity is not in the main unit and is itself
+ -- not referenced, since otherwise the reference
+ -- will dangle.
+
+ exit when not Referenced (Tref)
+ and then not In_Extended_Main_Source_Unit (Tref);
-- Output the reference
*** sem_attr.adb 2001/10/29 01:53:32 1.556
--- sem_attr.adb 2001/10/29 12:24:35 1.557
***************
*** 1545,1577 ****
-- get the proper value, but if expansion is not active, then
-- the check here allows proper semantic analysis of the reference.
! if (Is_Entity_Name (P)
! and then
! (((Ekind (Entity (P)) = E_Task_Type
! or else Ekind (Entity (P)) = E_Protected_Type)
! and then Etype (Entity (P)) = Base_Type (Entity (P)))
! or else Ekind (Entity (P)) = E_Package
! or else Is_Generic_Unit (Entity (P))))
! or else
! (Nkind (P) = N_Attribute_Reference
! and then
! Attribute_Name (P) = Name_AST_Entry)
then
Rewrite (N,
New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
! -- The following logic is obscure, needs explanation ???
! elsif Nkind (P) = N_Attribute_Reference
! or else (Is_Entity_Name (P)
! and then not Is_Subprogram (Entity (P))
! and then not Is_Object (Entity (P))
! and then Ekind (Entity (P)) /= E_Label)
then
! Error_Attr ("invalid prefix for % attribute", P);
! elsif Is_Entity_Name (P) then
! Set_Address_Taken (Entity (P));
end if;
Set_Etype (N, RTE (RE_Address));
--- 1545,1592 ----
-- get the proper value, but if expansion is not active, then
-- the check here allows proper semantic analysis of the reference.
! -- An Address attribute created by expansion is legal even when it
! -- applies to other entity-denoting expressions.
!
! if (Is_Entity_Name (P)) then
! if Is_Subprogram (Entity (P))
! or else Is_Object (Entity (P))
! or else Ekind (Entity (P)) = E_Label
! then
! Set_Address_Taken (Entity (P));
!
! elsif ((Ekind (Entity (P)) = E_Task_Type
! or else Ekind (Entity (P)) = E_Protected_Type)
! and then Etype (Entity (P)) = Base_Type (Entity (P)))
! or else Ekind (Entity (P)) = E_Package
! or else Is_Generic_Unit (Entity (P))
! then
! Rewrite (N,
! New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
!
! else
! Error_Attr ("invalid prefix for % attribute", P);
! end if;
!
! elsif Nkind (P) = N_Attribute_Reference
! and then Attribute_Name (P) = Name_AST_Entry
then
Rewrite (N,
New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
! elsif Is_Object_Reference (P) then
! null;
! elsif Nkind (P) = N_Selected_Component
! and then Is_Subprogram (Entity (Selector_Name (P)))
then
! null;
! elsif not Comes_From_Source (N) then
! null;
!
! else
! Error_Attr ("invalid prefix for % attribute", P);
end if;
Set_Etype (N, RTE (RE_Address));
***************
*** 3138,3159 ****
if Is_Object_Reference (P)
or else (Is_Entity_Name (P)
! and then
! Ekind (Entity (P)) = E_Function)
then
Check_Object_Reference (P);
! elsif Nkind (P) = N_Attribute_Reference
! or else
! (Nkind (P) = N_Selected_Component
! and then (Is_Entry (Entity (Selector_Name (P)))
! or else
! Is_Subprogram (Entity (Selector_Name (P)))))
! or else
! (Is_Entity_Name (P)
! and then not Is_Type (Entity (P))
! and then not Is_Object (Entity (P)))
then
Error_Attr ("invalid prefix for % attribute", P);
end if;
--- 3153,3173 ----
if Is_Object_Reference (P)
or else (Is_Entity_Name (P)
! and then Ekind (Entity (P)) = E_Function)
then
Check_Object_Reference (P);
! elsif Is_Entity_Name (P)
! and then Is_Type (Entity (P))
then
+ null;
+
+ elsif Nkind (P) = N_Type_Conversion
+ and then not Comes_From_Source (P)
+ then
+ null;
+
+ else
Error_Attr ("invalid prefix for % attribute", P);
end if;
***************
*** 5490,5496 ****
when Attribute_Small =>
! -- The floating-point case is present only for Ada 83 compatibility.
-- Note that strictly this is an illegal addition, since we are
-- extending an Ada 95 defined attribute, but we anticipate an
-- ARG ruling that will permit this.
--- 5504,5510 ----
when Attribute_Small =>
! -- The floating-point case is present only for Ada 83 compatability.
-- Note that strictly this is an illegal addition, since we are
-- extending an Ada 95 defined attribute, but we anticipate an
-- ARG ruling that will permit this.
***************
*** 6509,6532 ****
("prefix of % attribute cannot be overloaded", N);
return;
end if;
- end if;
-
- -- Do not permit address to be applied to entry
-
- if (Is_Entity_Name (P) and then Is_Entry (Entity (P)))
- or else Nkind (P) = N_Entry_Call_Statement
-
- or else (Nkind (P) = N_Selected_Component
- and then Is_Entry (Entity (Selector_Name (P))))
-
- or else (Nkind (P) = N_Indexed_Component
- and then Nkind (Prefix (P)) = N_Selected_Component
- and then Is_Entry (Entity (Selector_Name (Prefix (P)))))
- then
- Error_Msg_Name_1 := Aname;
- Error_Msg_N
- ("prefix of % attribute cannot be entry", N);
- return;
end if;
if not Is_Entity_Name (P)
--- 6523,6528 ----
*** sem_util.adb 2001/10/28 15:14:54 1.546
--- sem_util.adb 2001/10/29 12:24:38 1.547
***************
*** 3053,3059 ****
else
case Nkind (N) is
when N_Indexed_Component | N_Slice =>
! return True;
-- In Ada95, a function call is a constant object.
--- 3053,3059 ----
else
case Nkind (N) is
when N_Indexed_Component | N_Slice =>
! return Is_Object_Reference (Prefix (N));
-- In Ada95, a function call is a constant object.
*** misc.c 2001/10/23 19:34:50 1.9
--- misc.c 2001/10/29 15:18:00 1.10
***************
*** 154,162 ****
/* For most front-ends, this is the parser for the language. For us, we
process the GNAT tree. */
- #define Set_Jmpbuf_Address system__soft_links__set_jmpbuf_address_soft
- extern void Set_Jmpbuf_Address (void *);
-
/* Declare functions we use as part of startup. */
extern void __gnat_initialize PARAMS((void));
extern void adainit PARAMS((void));
--- 154,159 ----
***************
*** 165,198 ****
int
yyparse ()
{
- /* Make up what Gigi uses as a jmpbuf. */
- size_t jmpbuf[10];
-
/* call the target specific initializations */
__gnat_initialize();
/* Call the front-end elaboration procedures */
adainit ();
- /* Set up to catch unhandled exceptions. */
- if (__builtin_setjmp (jmpbuf))
- {
- Set_Jmpbuf_Address (0);
- abort ();
- }
-
- /* This is only really needed in longjmp/setjmp mode exceptions
- but we don't know any easy way to tell what mode the host is
- compiled in, and it is harmless to do it unconditionally */
-
- Set_Jmpbuf_Address (jmpbuf);
-
immediate_size_expand = 1;
/* Call the front end */
_ada_gnat1drv ();
- Set_Jmpbuf_Address (0);
return 0;
}
--- 162,178 ----
*** /dev/null Tue Dec 11 17:36:01 2001
--- /tmp/cvsAAAOUaiQQ Tue Dec 11 17:39:50 2001
***************
*** 0 ****
--- 1,394 ----
+ ------------------------------------------------------------------------------
+ -- --
+ -- GNAT COMPILER COMPONENTS --
+ -- --
+ -- G N A T . D I R E C T O R Y _ O P E R A T I O N S . I T E R A T I O N --
+ -- --
+ -- B o d y --
+ -- --
+ -- $Revision$
+ -- --
+ -- Copyright (C) 2001 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- --
+ -- 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+ -- --
+ ------------------------------------------------------------------------------
+
+ with Ada.Characters.Handling;
+ with Ada.Strings.Fixed;
+ with Ada.Strings.Maps;
+ with GNAT.OS_Lib;
+ with GNAT.Regexp;
+
+ package body GNAT.Directory_Operations.Iteration is
+
+ use Ada;
+
+ ----------
+ -- Find --
+ ----------
+
+ procedure Find
+ (Root_Directory : Dir_Name_Str;
+ File_Pattern : String)
+ is
+ File_Regexp : constant Regexp.Regexp := Regexp.Compile (File_Pattern);
+ Index : Natural := 0;
+
+ procedure Read_Directory (Directory : Dir_Name_Str);
+ -- Open Directory and read all entries. This routine is called
+ -- recursively for each sub-directories.
+
+ function Make_Pathname (Dir, File : String) return String;
+ -- Returns the pathname for File by adding Dir as prefix.
+
+ -------------------
+ -- Make_Pathname --
+ -------------------
+
+ function Make_Pathname (Dir, File : String) return String is
+ begin
+ if Dir (Dir'Last) = '/' or else Dir (Dir'Last) = '\' then
+ return Dir & File;
+ else
+ return Dir & Dir_Separator & File;
+ end if;
+ end Make_Pathname;
+
+ --------------------
+ -- Read_Directory --
+ --------------------
+
+ procedure Read_Directory (Directory : Dir_Name_Str) is
+ Dir : Dir_Type;
+ Buffer : String (1 .. 2_048);
+ Last : Natural;
+ Quit : Boolean;
+
+ begin
+ Open (Dir, Directory);
+
+ loop
+ Read (Dir, Buffer, Last);
+ exit when Last = 0;
+
+ declare
+ Dir_Entry : constant String := Buffer (1 .. Last);
+ Pathname : constant String
+ := Make_Pathname (Directory, Dir_Entry);
+ begin
+ if Regexp.Match (Dir_Entry, File_Regexp) then
+ Quit := False;
+ Index := Index + 1;
+
+ begin
+ Action (Pathname, Index, Quit);
+ exception
+ when others =>
+ Close (Dir);
+ raise;
+ end;
+
+ exit when Quit;
+ end if;
+
+ -- Recursively call for sub-directories, except for . and ..
+
+ if not (Dir_Entry = "." or else Dir_Entry = "..")
+ and then OS_Lib.Is_Directory (Pathname)
+ then
+ Read_Directory (Pathname);
+ end if;
+ end;
+ end loop;
+
+ Close (Dir);
+ end Read_Directory;
+
+ begin
+ Read_Directory (Root_Directory);
+ end Find;
+
+ -----------------------
+ -- Wildcard_Iterator --
+ -----------------------
+
+ procedure Wildcard_Iterator (Path : Path_Name) is
+
+ Index : Natural := 0;
+
+ procedure Read
+ (Directory : String;
+ File_Pattern : String;
+ Suffix_Pattern : String);
+ -- Read entries in Directory and call user's callback if the entry
+ -- match File_Pattern and Suffix_Pattern is empty otherwise it will go
+ -- down one more directory level by calling Next_Level routine above.
+
+ procedure Next_Level
+ (Current_Path : String;
+ Suffix_Path : String);
+ -- Extract next File_Pattern from Suffix_Path and call Read routine
+ -- above.
+
+ ----------------
+ -- Next_Level --
+ ----------------
+
+ procedure Next_Level
+ (Current_Path : String;
+ Suffix_Path : String)
+ is
+ DS : Natural;
+ SP : String renames Suffix_Path;
+
+ begin
+ if SP'Length > 2
+ and then SP (SP'First) = '.'
+ and then Strings.Maps.Is_In (SP (SP'First + 1), Dir_Seps)
+ then
+ -- Starting with "./"
+
+ DS := Strings.Fixed.Index
+ (SP (SP'First + 2 .. SP'Last),
+ Dir_Seps);
+
+ if DS = 0 then
+
+ -- We have "./"
+
+ Read (Current_Path & ".", "*", "");
+
+ else
+ -- We have "./dir"
+
+ Read (Current_Path & ".",
+ SP (SP'First + 2 .. DS - 1),
+ SP (DS .. SP'Last));
+ end if;
+
+ elsif SP'Length > 3
+ and then SP (SP'First .. SP'First + 1) = ".."
+ and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps)
+ then
+ -- Starting with "../"
+
+ DS := Strings.Fixed.Index
+ (SP (SP'First + 3 .. SP'Last),
+ Dir_Seps);
+
+ if DS = 0 then
+
+ -- We have "../"
+
+ Read (Current_Path & "..", "*", "");
+
+ else
+ -- We have "../dir"
+
+ Read (Current_Path & "..",
+ SP (SP'First + 4 .. DS - 1),
+ SP (DS .. SP'Last));
+ end if;
+
+ elsif Current_Path = ""
+ and then SP'Length > 1
+ and then Characters.Handling.Is_Letter (SP (SP'First))
+ and then SP (SP'First + 1) = ':'
+ then
+ -- Starting with "<drive>:"
+
+ if SP'Length > 2
+ and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps)
+ then
+ -- Starting with "<drive>:\"
+
+ DS := Strings.Fixed.Index
+ (SP (SP'First + 3 .. SP'Last), Dir_Seps);
+
+ if DS = 0 then
+
+ -- Se have "<drive>:\dir"
+
+ Read (SP (SP'First .. SP'First + 1),
+ SP (SP'First + 3 .. SP'Last),
+ "");
+
+ else
+ -- We have "<drive>:\dir\kkk"
+
+ Read (SP (SP'First .. SP'First + 1),
+ SP (SP'First + 3 .. DS - 1),
+ SP (DS .. SP'Last));
+ end if;
+
+ else
+ -- Starting with "<drive>:"
+
+ DS := Strings.Fixed.Index
+ (SP (SP'First + 2 .. SP'Last), Dir_Seps);
+
+ if DS = 0 then
+
+ -- We have "<drive>:dir"
+
+ Read (SP (SP'First .. SP'First + 1),
+ SP (SP'First + 2 .. SP'Last),
+ "");
+
+ else
+ -- We have "<drive>:dir/kkk"
+
+ Read (SP (SP'First .. SP'First + 1),
+ SP (SP'First + 2 .. DS - 1),
+ SP (DS .. SP'Last));
+ end if;
+
+ end if;
+
+ elsif Strings.Maps.Is_In (SP (SP'First), Dir_Seps) then
+
+ -- Starting with a /
+
+ DS := Strings.Fixed.Index
+ (SP (SP'First + 1 .. SP'Last),
+ Dir_Seps);
+
+ if DS = 0 then
+
+ -- We have "/dir"
+
+ Read (Current_Path,
+ SP (SP'First + 1 .. SP'Last),
+ "");
+ else
+ -- We have "/dir/kkk"
+
+ Read (Current_Path,
+ SP (SP'First + 1 .. DS - 1),
+ SP (DS .. SP'Last));
+ end if;
+
+ else
+ -- Starting with a name
+
+ DS := Strings.Fixed.Index (SP, Dir_Seps);
+
+ if DS = 0 then
+
+ -- We have "dir"
+
+ Read (Current_Path & '.',
+ SP,
+ "");
+ else
+ -- We have "dir/kkk"
+
+ Read (Current_Path & '.',
+ SP (SP'First .. DS - 1),
+ SP (DS .. SP'Last));
+ end if;
+
+ end if;
+ end Next_Level;
+
+ ----------
+ -- Read --
+ ----------
+
+ Quit : Boolean := False;
+ -- Global state to be able to exit all recursive calls.
+
+ procedure Read
+ (Directory : String;
+ File_Pattern : String;
+ Suffix_Pattern : String)
+ is
+ File_Regexp : constant Regexp.Regexp :=
+ Regexp.Compile (File_Pattern, Glob => True);
+ Dir : Dir_Type;
+ Buffer : String (1 .. 2_048);
+ Last : Natural;
+
+ begin
+ if OS_Lib.Is_Directory (Directory) then
+ Open (Dir, Directory);
+
+ Dir_Iterator : loop
+ Read (Dir, Buffer, Last);
+ exit Dir_Iterator when Last = 0;
+
+ declare
+ Dir_Entry : constant String := Buffer (1 .. Last);
+ Pathname : constant String :=
+ Directory & Dir_Separator & Dir_Entry;
+ begin
+ -- Handle "." and ".." only if explicit use in the
+ -- File_Pattern.
+
+ if not
+ ((Dir_Entry = "." and then File_Pattern /= ".")
+ or else
+ (Dir_Entry = ".." and then File_Pattern /= ".."))
+ then
+ if Regexp.Match (Dir_Entry, File_Regexp) then
+
+ if Suffix_Pattern = "" then
+
+ -- No more matching needed, call user's callback
+
+ Index := Index + 1;
+
+ begin
+ Action (Pathname, Index, Quit);
+
+ exception
+ when others =>
+ Close (Dir);
+ raise;
+ end;
+
+ exit Dir_Iterator when Quit;
+
+ else
+ -- Down one level
+
+ Next_Level
+ (Directory & Dir_Separator & Dir_Entry,
+ Suffix_Pattern);
+ end if;
+ end if;
+ end if;
+ end;
+
+ exit Dir_Iterator when Quit;
+
+ end loop Dir_Iterator;
+
+ Close (Dir);
+ end if;
+ end Read;
+
+ begin
+ Next_Level ("", Path);
+ end Wildcard_Iterator;
+
+ end GNAT.Directory_Operations.Iteration;
*** /dev/null Tue Dec 11 17:36:01 2001
--- /tmp/cvsAAAGaaGQQ Tue Dec 11 17:39:51 2001
***************
*** 0 ****
--- 1,95 ----
+ ------------------------------------------------------------------------------
+ -- --
+ -- GNAT COMPILER COMPONENTS --
+ -- --
+ -- G N A T . D I R E C T O R Y _ O P E R A T I O N S . I T E R A T I O N --
+ -- --
+ -- S p e c --
+ -- --
+ -- $Revision$
+ -- --
+ -- Copyright (C) 2001 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- --
+ -- 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+ -- --
+ ------------------------------------------------------------------------------
+
+ -- Iterators among files
+
+ package GNAT.Directory_Operations.Iteration is
+
+ generic
+ with procedure Action
+ (Item : String;
+ Index : Positive;
+ Quit : in out Boolean);
+ procedure Find
+ (Root_Directory : Dir_Name_Str;
+ File_Pattern : String);
+ -- Recursively searches the directory structure rooted at Root_Directory.
+ -- This provides functionality similar to the UNIX 'find' command.
+ -- Action will be called for every item matching the regular expression
+ -- File_Pattern (see GNAT.Regexp). Item is the full pathname to the file
+ -- starting with Root_Directory that has been matched. Index is set to one
+ -- for the first call and is incremented by one at each call. The iterator
+ -- will pass in the value False on each call to Action. The iterator will
+ -- terminate after passing the last matched path to Action or after
+ -- returning from a call to Action which sets Quit to True.
+ -- Raises GNAT.Regexp.Error_In_Regexp if File_Pattern is ill formed.
+
+ generic
+ with procedure Action
+ (Item : String;
+ Index : Positive;
+ Quit : in out Boolean);
+ procedure Wildcard_Iterator (Path : Path_Name);
+ -- Calls Action for each path matching Path. Path can include wildcards '*'
+ -- and '?' and [...]. The rules are:
+ --
+ -- * can be replaced by any sequence of characters
+ -- ? can be replaced by a single character
+ -- [a-z] match one character in the range 'a' through 'z'
+ -- [abc] match either character 'a', 'b' or 'c'
+ --
+ -- Item is the filename that has been matched. Index is set to one for the
+ -- first call and is incremented by one at each call. The iterator's
+ -- termination can be controlled by setting Quit to True. It is by default
+ -- set to False.
+ --
+ -- For example, if we have the following directory structure:
+ -- /boo/
+ -- foo.ads
+ -- /sed/
+ -- foo.ads
+ -- file/
+ -- foo.ads
+ -- /sid/
+ -- foo.ads
+ -- file/
+ -- foo.ads
+ -- /life/
+ --
+ -- A call with expression "/s*/file/*" will call Action for the following
+ -- items:
+ -- /sed/file/foo.ads
+ -- /sid/file/foo.ads
+
+ end GNAT.Directory_Operations.Iteration;
*** g-dirope.adb 2001/10/29 02:06:10 1.18
--- g-dirope.adb 2001/10/29 19:20:03 1.19
***************
*** 34,46 ****
with Ada.Characters.Handling;
with Ada.Strings.Fixed;
- with Ada.Strings.Unbounded;
with Ada.Strings.Maps;
with Unchecked_Deallocation;
with Unchecked_Conversion;
with System; use System;
- with GNAT.Regexp;
with GNAT.OS_Lib;
package body GNAT.Directory_Operations is
--- 34,44 ----
***************
*** 51,60 ****
-- This is the low-level address directory structure as returned by the C
-- opendir routine.
- Dir_Seps : constant Strings.Maps.Character_Set :=
- Strings.Maps.To_Set ("/\");
- -- UNIX and DOS style directory separators.
-
procedure Free is new
Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
--- 49,54 ----
***************
*** 220,227 ****
-----------------
function Expand_Path (Path : Path_Name) return String is
- use Ada.Strings.Unbounded;
procedure Read (K : in out Positive);
-- Update Result while reading current Path starting at position K. If
-- a variable is found, call Var below.
--- 214,230 ----
-----------------
function Expand_Path (Path : Path_Name) return String is
+ Result : OS_Lib.String_Access := new String (1 .. 200);
+ Result_Last : Natural := 0;
+
+ procedure Append (C : Character);
+ procedure Append (S : String);
+ -- Append to Result
+
+ procedure Double_Result_Size;
+ -- Reallocate Result, doubling its size
+
procedure Read (K : in out Positive);
-- Update Result while reading current Path starting at position K. If
-- a variable is found, call Var below.
***************
*** 229,240 ****
procedure Var (K : in out Positive);
-- Translate variable name starting at position K with the associated
-- environment value.
! procedure Free is
! new Unchecked_Deallocation (String, OS_Lib.String_Access);
! Result : Unbounded_String;
----------
-- Read --
----------
--- 232,276 ----
procedure Var (K : in out Positive);
-- Translate variable name starting at position K with the associated
-- environment value.
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append (C : Character) is
+ begin
+ if Result_Last = Result'Last then
+ Double_Result_Size;
+ end if;
+
+ Result_Last := Result_Last + 1;
+ Result (Result_Last) := C;
+ end Append;
! procedure Append (S : String) is
! begin
! while Result_Last + S'Length - 1 > Result'Last loop
! Double_Result_Size;
! end loop;
! Result (Result_Last + 1 .. Result_Last + S'Length - 1) := S;
! Result_Last := Result_Last + S'Length - 1;
! end Append;
!
! ------------------------
! -- Double_Result_Size --
! ------------------------
!
! procedure Double_Result_Size is
! New_Result : constant OS_Lib.String_Access :=
! new String (1 .. 2 * Result'Last);
+ begin
+ New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
+ OS_Lib.Free (Result);
+ Result := New_Result;
+ end Double_Result_Size;
+
----------
-- Read --
----------
***************
*** 253,259 ****
-- Not a variable after all, this is a double $, just
-- insert one in the result string.
! Append (Result, '$');
K := K + 1;
else
--- 289,295 ----
-- Not a variable after all, this is a double $, just
-- insert one in the result string.
! Append ('$');
K := K + 1;
else
***************
*** 266,278 ****
else
-- We have an ending $ sign
! Append (Result, '$');
end if;
else
-- This is a standard character, just add it to the result
! Append (Result, Path (K));
end if;
-- Skip to next character
--- 302,314 ----
else
-- We have an ending $ sign
! Append ('$');
end if;
else
-- This is a standard character, just add it to the result
! Append (Path (K));
end if;
-- Skip to next character
***************
*** 311,325 ****
OS_Lib.Getenv (Path (K + 1 .. E - 1));
begin
! Append (Result, Env.all);
! Free (Env);
end;
else
-- No closing curly bracket, not a variable after all or a
-- syntax error, ignore it, insert string as-is.
! Append (Result, '$' & Path (K .. E));
end if;
else
--- 347,362 ----
OS_Lib.Getenv (Path (K + 1 .. E - 1));
begin
! Append (Env.all);
! OS_Lib.Free (Env);
end;
else
-- No closing curly bracket, not a variable after all or a
-- syntax error, ignore it, insert string as-is.
! Append ('$');
! Append (Path (K .. E));
end if;
else
***************
*** 350,363 ****
Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));
begin
! Append (Result, Env.all);
! Free (Env);
end;
else
-- This is not a variable after all
! Append (Result, '$' & Path (E));
end if;
end if;
--- 387,401 ----
Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));
begin
! Append (Env.all);
! OS_Lib.Free (Env);
end;
else
-- This is not a variable after all
! Append ('$');
! Append (Path (E));
end if;
end if;
***************
*** 373,379 ****
begin
Read (K);
! return To_String (Result);
end;
end Expand_Path;
--- 411,424 ----
begin
Read (K);
!
! declare
! Returned_Value : constant String := Result (1 .. Result_Last);
!
! begin
! OS_Lib.Free (Result);
! return Returned_Value;
! end;
end;
end Expand_Path;
***************
*** 413,503 ****
return Base_Name (Path);
end File_Name;
- ----------
- -- Find --
- ----------
-
- procedure Find
- (Root_Directory : Dir_Name_Str;
- File_Pattern : String)
- is
- File_Regexp : constant Regexp.Regexp := Regexp.Compile (File_Pattern);
- Index : Natural := 0;
-
- procedure Read_Directory (Directory : Dir_Name_Str);
- -- Open Directory and read all entries. This routine is called
- -- recursively for each sub-directories.
-
- function Make_Pathname (Dir, File : String) return String;
- -- Returns the pathname for File by adding Dir as prefix.
-
- -------------------
- -- Make_Pathname --
- -------------------
-
- function Make_Pathname (Dir, File : String) return String is
- begin
- if Dir (Dir'Last) = '/' or else Dir (Dir'Last) = '\' then
- return Dir & File;
- else
- return Dir & Dir_Separator & File;
- end if;
- end Make_Pathname;
-
- --------------------
- -- Read_Directory --
- --------------------
-
- procedure Read_Directory (Directory : Dir_Name_Str) is
- Dir : Dir_Type;
- Buffer : String (1 .. 2_048);
- Last : Natural;
- Quit : Boolean;
-
- begin
- Open (Dir, Directory);
-
- loop
- Read (Dir, Buffer, Last);
- exit when Last = 0;
-
- declare
- Dir_Entry : constant String := Buffer (1 .. Last);
- Pathname : constant String
- := Make_Pathname (Directory, Dir_Entry);
- begin
- if Regexp.Match (Dir_Entry, File_Regexp) then
- Quit := False;
- Index := Index + 1;
-
- begin
- Action (Pathname, Index, Quit);
- exception
- when others =>
- Close (Dir);
- raise;
- end;
-
- exit when Quit;
- end if;
-
- -- Recursively call for sub-directories, except for . and ..
-
- if not (Dir_Entry = "." or else Dir_Entry = "..")
- and then OS_Lib.Is_Directory (Pathname)
- then
- Read_Directory (Pathname);
- end if;
- end;
- end loop;
-
- Close (Dir);
- end Read_Directory;
-
- begin
- Read_Directory (Root_Directory);
- end Find;
-
---------------------
-- Get_Current_Dir --
---------------------
--- 458,463 ----
***************
*** 716,984 ****
begin
rmdir (C_Dir_Name);
end Remove_Dir;
-
- -----------------------
- -- Wildcard_Iterator --
- -----------------------
-
- procedure Wildcard_Iterator (Path : Path_Name) is
-
- Index : Natural := 0;
-
- procedure Read
- (Directory : String;
- File_Pattern : String;
- Suffix_Pattern : String);
- -- Read entries in Directory and call user's callback if the entry
- -- match File_Pattern and Suffix_Pattern is empty otherwise it will go
- -- down one more directory level by calling Next_Level routine above.
-
- procedure Next_Level
- (Current_Path : String;
- Suffix_Path : String);
- -- Extract next File_Pattern from Suffix_Path and call Read routine
- -- above.
-
- ----------------
- -- Next_Level --
- ----------------
-
- procedure Next_Level
- (Current_Path : String;
- Suffix_Path : String)
- is
- DS : Natural;
- SP : String renames Suffix_Path;
-
- begin
- if SP'Length > 2
- and then SP (SP'First) = '.'
- and then Strings.Maps.Is_In (SP (SP'First + 1), Dir_Seps)
- then
- -- Starting with "./"
-
- DS := Strings.Fixed.Index
- (SP (SP'First + 2 .. SP'Last),
- Dir_Seps);
-
- if DS = 0 then
-
- -- We have "./"
-
- Read (Current_Path & ".", "*", "");
-
- else
- -- We have "./dir"
-
- Read (Current_Path & ".",
- SP (SP'First + 2 .. DS - 1),
- SP (DS .. SP'Last));
- end if;
-
- elsif SP'Length > 3
- and then SP (SP'First .. SP'First + 1) = ".."
- and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps)
- then
- -- Starting with "../"
-
- DS := Strings.Fixed.Index
- (SP (SP'First + 3 .. SP'Last),
- Dir_Seps);
-
- if DS = 0 then
-
- -- We have "../"
-
- Read (Current_Path & "..", "*", "");
-
- else
- -- We have "../dir"
-
- Read (Current_Path & "..",
- SP (SP'First + 4 .. DS - 1),
- SP (DS .. SP'Last));
- end if;
-
- elsif Current_Path = ""
- and then SP'Length > 1
- and then Characters.Handling.Is_Letter (SP (SP'First))
- and then SP (SP'First + 1) = ':'
- then
- -- Starting with "<drive>:"
-
- if SP'Length > 2
- and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps)
- then
- -- Starting with "<drive>:\"
-
- DS := Strings.Fixed.Index
- (SP (SP'First + 3 .. SP'Last), Dir_Seps);
-
- if DS = 0 then
-
- -- Se have "<drive>:\dir"
-
- Read (SP (SP'First .. SP'First + 1),
- SP (SP'First + 3 .. SP'Last),
- "");
-
- else
- -- We have "<drive>:\dir\kkk"
-
- Read (SP (SP'First .. SP'First + 1),
- SP (SP'First + 3 .. DS - 1),
- SP (DS .. SP'Last));
- end if;
-
- else
- -- Starting with "<drive>:"
-
- DS := Strings.Fixed.Index
- (SP (SP'First + 2 .. SP'Last), Dir_Seps);
-
- if DS = 0 then
-
- -- We have "<drive>:dir"
-
- Read (SP (SP'First .. SP'First + 1),
- SP (SP'First + 2 .. SP'Last),
- "");
-
- else
- -- We have "<drive>:dir/kkk"
-
- Read (SP (SP'First .. SP'First + 1),
- SP (SP'First + 2 .. DS - 1),
- SP (DS .. SP'Last));
- end if;
-
- end if;
-
- elsif Strings.Maps.Is_In (SP (SP'First), Dir_Seps) then
-
- -- Starting with a /
-
- DS := Strings.Fixed.Index
- (SP (SP'First + 1 .. SP'Last),
- Dir_Seps);
-
- if DS = 0 then
-
- -- We have "/dir"
-
- Read (Current_Path,
- SP (SP'First + 1 .. SP'Last),
- "");
- else
- -- We have "/dir/kkk"
-
- Read (Current_Path,
- SP (SP'First + 1 .. DS - 1),
- SP (DS .. SP'Last));
- end if;
-
- else
- -- Starting with a name
-
- DS := Strings.Fixed.Index (SP, Dir_Seps);
-
- if DS = 0 then
-
- -- We have "dir"
-
- Read (Current_Path & '.',
- SP,
- "");
- else
- -- We have "dir/kkk"
-
- Read (Current_Path & '.',
- SP (SP'First .. DS - 1),
- SP (DS .. SP'Last));
- end if;
-
- end if;
- end Next_Level;
-
- ----------
- -- Read --
- ----------
-
- Quit : Boolean := False;
- -- Global state to be able to exit all recursive calls.
-
- procedure Read
- (Directory : String;
- File_Pattern : String;
- Suffix_Pattern : String)
- is
- File_Regexp : constant Regexp.Regexp :=
- Regexp.Compile (File_Pattern, Glob => True);
- Dir : Dir_Type;
- Buffer : String (1 .. 2_048);
- Last : Natural;
-
- begin
- if OS_Lib.Is_Directory (Directory) then
- Open (Dir, Directory);
-
- Dir_Iterator : loop
- Read (Dir, Buffer, Last);
- exit Dir_Iterator when Last = 0;
-
- declare
- Dir_Entry : constant String := Buffer (1 .. Last);
- Pathname : constant String :=
- Directory & Dir_Separator & Dir_Entry;
- begin
- -- Handle "." and ".." only if explicit use in the
- -- File_Pattern.
-
- if not
- ((Dir_Entry = "." and then File_Pattern /= ".")
- or else
- (Dir_Entry = ".." and then File_Pattern /= ".."))
- then
- if Regexp.Match (Dir_Entry, File_Regexp) then
-
- if Suffix_Pattern = "" then
-
- -- No more matching needed, call user's callback
-
- Index := Index + 1;
-
- begin
- Action (Pathname, Index, Quit);
-
- exception
- when others =>
- Close (Dir);
- raise;
- end;
-
- exit Dir_Iterator when Quit;
-
- else
- -- Down one level
-
- Next_Level
- (Directory & Dir_Separator & Dir_Entry,
- Suffix_Pattern);
- end if;
- end if;
- end if;
- end;
-
- exit Dir_Iterator when Quit;
-
- end loop Dir_Iterator;
-
- Close (Dir);
- end if;
- end Read;
-
- begin
- Next_Level ("", Path);
- end Wildcard_Iterator;
end GNAT.Directory_Operations;
--- 676,680 ----
*** Makefile.in 2001/10/29 15:39:15 1.1418
--- Makefile.in 2001/10/29 19:44:59 1.1419
***************
*** 1666,1671 ****
--- 1666,1672 ----
g-curexc.o \
g-debuti.o \
g-debpoo.o \
+ g-diopit.o \
g-dirope.o \
g-except.o \
g-exctra.o \
***************
*** 3412,3421 ****
s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
s-stoele.ads s-stratt.ads s-strops.ads s-unstyp.ads unchconv.ads
! g-dirope.o : ada.ads a-charac.ads a-chahan.ads a-chlat1.ads a-except.ads \
a-finali.ads a-filico.ads a-stream.ads a-string.ads a-strfix.ads \
! a-strmap.ads a-strunb.ads a-tags.ads gnat.ads g-dirope.ads g-dirope.adb \
g-os_lib.ads g-regexp.ads system.ads s-exctab.ads s-finimp.ads \
s-finroo.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \
s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-unstyp.ads \
unchconv.ads unchdeal.ads
--- 3413,3430 ----
s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
s-stoele.ads s-stratt.ads s-strops.ads s-unstyp.ads unchconv.ads
! g-diopit.o : ada.ads a-charac.ads a-chahan.ads a-chlat1.ads a-except.ads \
a-finali.ads a-filico.ads a-stream.ads a-string.ads a-strfix.ads \
! a-strmap.ads a-tags.ads gnat.ads g-dirope.ads g-dirope.adb \
g-os_lib.ads g-regexp.ads system.ads s-exctab.ads s-finimp.ads \
+ s-finroo.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \
+ s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-unstyp.ads \
+ unchconv.ads unchdeal.ads
+
+ g-dirope.o : ada.ads a-charac.ads a-chahan.ads a-chlat1.ads a-except.ads \
+ a-finali.ads a-filico.ads a-stream.ads a-string.ads a-strfix.ads \
+ a-strmap.ads a-tags.ads gnat.ads g-dirope.ads g-dirope.adb \
+ g-os_lib.ads system.ads s-exctab.ads s-finimp.ads \
s-finroo.ads s-parame.ads s-secsta.ads s-soflin.ads s-stache.ads \
s-stalib.ads s-stoele.ads s-stratt.ads s-strops.ads s-unstyp.ads \
unchconv.ads unchdeal.ads
*** misc.c 2001/10/29 15:18:00 1.10
--- misc.c 2001/10/29 20:07:20 1.11
***************
*** 634,640 ****
else
result = assign_temp (type, 0, TREE_ADDRESSABLE (exp), 1);
- set_mem_attributes (result, exp, 1);
return result;
case ALLOCATE_EXPR:
--- 634,639 ----
*** sem_attr.adb 2001/10/29 12:24:35 1.557
--- sem_attr.adb 2001/10/29 21:17:23 1.558
***************
*** 1556,1565 ****
Set_Address_Taken (Entity (P));
elsif ((Ekind (Entity (P)) = E_Task_Type
! or else Ekind (Entity (P)) = E_Protected_Type)
! and then Etype (Entity (P)) = Base_Type (Entity (P)))
! or else Ekind (Entity (P)) = E_Package
! or else Is_Generic_Unit (Entity (P))
then
Rewrite (N,
New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
--- 1556,1565 ----
Set_Address_Taken (Entity (P));
elsif ((Ekind (Entity (P)) = E_Task_Type
! or else Ekind (Entity (P)) = E_Protected_Type)
! and then Etype (Entity (P)) = Base_Type (Entity (P)))
! or else Ekind (Entity (P)) = E_Package
! or else Is_Generic_Unit (Entity (P))
then
Rewrite (N,
New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));