From 0873bafcaa07ec24cc51e2bced0458252b5d028e Mon Sep 17 00:00:00 2001 From: Geert Bosch Date: Tue, 11 Dec 2001 23:50:45 +0100 Subject: [PATCH] lib-xref.adb (Output_Refs): Don't output type references outside the main unit if... * lib-xref.adb (Output_Refs): Don't output type references outside the main unit if they are not otherwise referenced. * 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. * 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 * sem_attr.adb: Minor reformatting From-SVN: r47901 --- gcc/ada/ChangeLog | 29 +++ gcc/ada/Makefile.in | 13 +- gcc/ada/g-diopit.adb | 394 ++++++++++++++++++++++++++++++++++++++ gcc/ada/g-diopit.ads | 95 ++++++++++ gcc/ada/g-dirope.adb | 436 +++++++------------------------------------ gcc/ada/lib-xref.adb | 10 +- gcc/ada/sem_attr.adb | 98 +++++----- gcc/ada/sem_util.adb | 2 +- 8 files changed, 652 insertions(+), 425 deletions(-) create mode 100644 gcc/ada/g-diopit.adb create mode 100644 gcc/ada/g-diopit.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e82eb263a7a..4424fc425d6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +2001-12-11 Robert Dewar + + * 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 + + * 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 + + * 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 + + * sem_attr.adb: Minor reformatting + 2001-12-11 Ed Schonberg * sem_ch3.adb: Clarify some ???. diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 72f81d1811d..e2601a24542 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -1666,6 +1666,7 @@ GNATRTL_NONTASKING_OBJS= \ g-curexc.o \ g-debuti.o \ g-debpoo.o \ + g-diopit.o \ g-dirope.o \ g-except.o \ g-exctra.o \ @@ -3171,14 +3172,22 @@ g-comlin.o : ada.ads a-comlin.ads a-except.ads a-finali.ads a-filico.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 -g-dirope.o : ada.ads a-charac.ads a-chahan.ads a-chlat1.ads a-except.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-strunb.ads a-tags.ads gnat.ads g-dirope.ads g-dirope.adb \ + 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 + get_targ.o : get_targ.ads get_targ.adb system.ads s-exctab.ads \ s-stalib.ads types.ads unchconv.ads unchdeal.ads diff --git a/gcc/ada/g-diopit.adb b/gcc/ada/g-diopit.adb new file mode 100644 index 00000000000..69c7e4a41dc --- /dev/null +++ b/gcc/ada/g-diopit.adb @@ -0,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 ":" + + if SP'Length > 2 + 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 + + -- Se have ":\dir" + + Read (SP (SP'First .. SP'First + 1), + SP (SP'First + 3 .. SP'Last), + ""); + + else + -- We have ":\dir\kkk" + + Read (SP (SP'First .. SP'First + 1), + SP (SP'First + 3 .. DS - 1), + SP (DS .. SP'Last)); + end if; + + else + -- Starting with ":" + + DS := Strings.Fixed.Index + (SP (SP'First + 2 .. SP'Last), Dir_Seps); + + if DS = 0 then + + -- We have ":dir" + + Read (SP (SP'First .. SP'First + 1), + SP (SP'First + 2 .. SP'Last), + ""); + + else + -- We have ":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; diff --git a/gcc/ada/g-diopit.ads b/gcc/ada/g-diopit.ads new file mode 100644 index 00000000000..051c2814a54 --- /dev/null +++ b/gcc/ada/g-diopit.ads @@ -0,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; diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb index 677f5c4527a..7d212e8c71b 100644 --- a/gcc/ada/g-dirope.adb +++ b/gcc/ada/g-dirope.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- -- Copyright (C) 1998-2001 Ada Core Technologies, Inc. -- -- -- @@ -34,13 +34,11 @@ 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 @@ -51,10 +49,6 @@ package body GNAT.Directory_Operations is -- 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); @@ -220,7 +214,16 @@ package body GNAT.Directory_Operations is ----------------- function Expand_Path (Path : Path_Name) return String is - use Ada.Strings.Unbounded; + + 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 @@ -230,10 +233,43 @@ package body GNAT.Directory_Operations is -- Translate variable name starting at position K with the associated -- environment value. - procedure Free is - new Unchecked_Deallocation (String, OS_Lib.String_Access); + ------------ + -- 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; - Result : Unbounded_String; + 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,7 +289,7 @@ package body GNAT.Directory_Operations is -- Not a variable after all, this is a double $, just -- insert one in the result string. - Append (Result, '$'); + Append ('$'); K := K + 1; else @@ -266,13 +302,13 @@ package body GNAT.Directory_Operations is else -- We have an ending $ sign - Append (Result, '$'); + Append ('$'); end if; else -- This is a standard character, just add it to the result - Append (Result, Path (K)); + Append (Path (K)); end if; -- Skip to next character @@ -311,15 +347,16 @@ package body GNAT.Directory_Operations is OS_Lib.Getenv (Path (K + 1 .. E - 1)); begin - Append (Result, Env.all); - Free (Env); + 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 (Result, '$' & Path (K .. E)); + Append ('$'); + Append (Path (K .. E)); end if; else @@ -350,14 +387,15 @@ package body GNAT.Directory_Operations is Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E)); begin - Append (Result, Env.all); - Free (Env); + Append (Env.all); + OS_Lib.Free (Env); end; else -- This is not a variable after all - Append (Result, '$' & Path (E)); + Append ('$'); + Append (Path (E)); end if; end if; @@ -373,7 +411,14 @@ package body GNAT.Directory_Operations is begin Read (K); - return To_String (Result); + + declare + Returned_Value : constant String := Result (1 .. Result_Last); + + begin + OS_Lib.Free (Result); + return Returned_Value; + end; end; end Expand_Path; @@ -413,91 +458,6 @@ package body GNAT.Directory_Operations is 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 -- --------------------- @@ -717,268 +677,4 @@ package body GNAT.Directory_Operations is 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 ":" - - if SP'Length > 2 - 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 - - -- Se have ":\dir" - - Read (SP (SP'First .. SP'First + 1), - SP (SP'First + 3 .. SP'Last), - ""); - - else - -- We have ":\dir\kkk" - - Read (SP (SP'First .. SP'First + 1), - SP (SP'First + 3 .. DS - 1), - SP (DS .. SP'Last)); - end if; - - else - -- Starting with ":" - - DS := Strings.Fixed.Index - (SP (SP'First + 2 .. SP'Last), Dir_Seps); - - if DS = 0 then - - -- We have ":dir" - - Read (SP (SP'First .. SP'First + 1), - SP (SP'First + 2 .. SP'Last), - ""); - - else - -- We have ":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; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 4367eb1720b..c49866f4af2 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -751,7 +751,7 @@ package body Lib.Xref is if Sloc (Tref) = Standard_Location then - -- For now, output only if speial -gnatdM flag set + -- For now, output only if special -gnatdM flag set exit when not Debug_Flag_MM; @@ -769,6 +769,14 @@ package body Lib.Xref is 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 Write_Info_Char (Left); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 97002bb605d..c0bc236c822 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1545,33 +1545,48 @@ package body Sem_Attr is -- 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) + -- 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))); - -- The following logic is obscure, needs explanation ??? + elsif Is_Object_Reference (P) then + null; - 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) + elsif Nkind (P) = N_Selected_Component + and then Is_Subprogram (Entity (Selector_Name (P))) then - Error_Attr ("invalid prefix for % attribute", P); + null; - elsif Is_Entity_Name (P) then - Set_Address_Taken (Entity (P)); + 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,22 +3153,21 @@ package body Sem_Attr is if Is_Object_Reference (P) or else (Is_Entity_Name (P) - and then - Ekind (Entity (P)) = E_Function) + 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))) + 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,7 +5504,7 @@ package body Sem_Attr is when Attribute_Small => - -- The floating-point case is present only for Ada 83 compatibility. + -- 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. @@ -6511,24 +6525,6 @@ package body Sem_Attr is 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) or else not Is_Overloadable (Entity (P)) then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index df9ef755e89..53b9ce68d2a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3053,7 +3053,7 @@ package body Sem_Util is else case Nkind (N) is when N_Indexed_Component | N_Slice => - return True; + return Is_Object_Reference (Prefix (N)); -- In Ada95, a function call is a constant object. -- 2.30.2