RISC-V: Move mode assertion out of conditional branch in emit_insn
[official-gcc.git] / gcc / ada / gnatname.adb
blobb39a38c3c718c7808fad09ae24accc0e3ef95765
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T N A M E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2024, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Ada.Characters.Handling; use Ada.Characters.Handling;
27 with Ada.Command_Line; use Ada.Command_Line;
28 with Ada.Text_IO; use Ada.Text_IO;
30 with GNAT.Command_Line; use GNAT.Command_Line;
31 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
32 with GNAT.Dynamic_Tables;
33 with GNAT.OS_Lib; use GNAT.OS_Lib;
35 with Make_Util; use Make_Util;
36 with Namet; use Namet;
37 with Opt;
38 with Osint; use Osint;
39 with Output;
40 with Switch; use Switch;
41 with Table;
42 with Tempdir;
43 with Types; use Types;
45 with System.CRTL;
46 with System.Regexp; use System.Regexp;
48 procedure Gnatname is
50 pragma Warnings (Off);
51 type Matched_Type is (True, False, Excluded);
52 pragma Warnings (On);
54 Create_Project : Boolean := False;
56 Subdirs_Switch : constant String := "--subdirs=";
58 Usage_Output : Boolean := False;
59 -- Set to True when usage is output, to avoid multiple output
61 Usage_Needed : Boolean := False;
62 -- Set to True by -h switch
64 Version_Output : Boolean := False;
65 -- Set to True when version is output, to avoid multiple output
67 Very_Verbose : Boolean := False;
68 -- Set to True with -v -v
70 File_Path : String_Access := new String'("gnat.adc");
71 -- Path name of the file specified by -c or -P switch
73 File_Set : Boolean := False;
74 -- Set to True by -c or -P switch.
75 -- Used to detect multiple -c/-P switches.
77 Args : Argument_List_Access;
78 -- The list of arguments for calls to the compiler to get the unit names
79 -- and kinds (spec or body) in the Ada sources.
81 Path_Name : String_Access;
83 Path_Last : Natural;
85 Directory_Last : Natural := 0;
87 function Dup (Fd : File_Descriptor) return File_Descriptor;
89 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
91 Gcc : constant String := "gcc";
92 Gcc_Path : String_Access := null;
94 package Patterns is new GNAT.Dynamic_Tables
95 (Table_Component_Type => String_Access,
96 Table_Index_Type => Natural,
97 Table_Low_Bound => 0,
98 Table_Initial => 10,
99 Table_Increment => 100);
100 -- Table to accumulate the patterns
102 type Argument_Data is record
103 Directories : Patterns.Instance;
104 Name_Patterns : Patterns.Instance;
105 Excluded_Patterns : Patterns.Instance;
106 Foreign_Patterns : Patterns.Instance;
107 end record;
109 package Arguments is new Table.Table
110 (Table_Component_Type => Argument_Data,
111 Table_Index_Type => Natural,
112 Table_Low_Bound => 0,
113 Table_Initial => 10,
114 Table_Increment => 100,
115 Table_Name => "Gnatname.Arguments");
116 -- Table to accumulate directories and patterns
118 package Preprocessor_Switches is new Table.Table
119 (Table_Component_Type => String_Access,
120 Table_Index_Type => Natural,
121 Table_Low_Bound => 0,
122 Table_Initial => 10,
123 Table_Increment => 100,
124 Table_Name => "Gnatname.Preprocessor_Switches");
125 -- Table to store the preprocessor switches to be used in the call
126 -- to the compiler.
128 type Source is record
129 File_Name : Name_Id;
130 Unit_Name : Name_Id;
131 Index : Int := 0;
132 Spec : Boolean;
133 end record;
135 package Processed_Directories is new Table.Table
136 (Table_Component_Type => String_Access,
137 Table_Index_Type => Natural,
138 Table_Low_Bound => 0,
139 Table_Initial => 10,
140 Table_Increment => 100,
141 Table_Name => "Prj.Makr.Processed_Directories");
142 -- The list of already processed directories for each section, to avoid
143 -- processing several times the same directory in the same section.
145 package Sources is new Table.Table
146 (Table_Component_Type => Source,
147 Table_Index_Type => Natural,
148 Table_Low_Bound => 0,
149 Table_Initial => 10,
150 Table_Increment => 100,
151 Table_Name => "Gnatname.Sources");
152 -- The list of Ada sources found, with their unit name and kind, to be put
153 -- in the pragmas Source_File_Name in the configuration pragmas file.
155 procedure Output_Version;
156 -- Print name and version
158 procedure Usage;
159 -- Print usage
161 procedure Scan_Args;
162 -- Scan the command line arguments
164 procedure Add_Source_Directory (S : String);
165 -- Add S in the Source_Directories table
167 procedure Get_Directories (From_File : String);
168 -- Read a source directory text file
170 procedure Write_Eol;
171 -- Output an empty line
173 procedure Write_A_String (S : String);
174 -- Write a String to Output_FD
176 procedure Initialize
177 (File_Path : String;
178 Preproc_Switches : Argument_List);
179 -- Start the creation of a configuration pragmas file
181 -- File_Path is the name of the configuration pragmas file to create
183 -- Preproc_Switches is a list of switches to be used when invoking the
184 -- compiler to get the name and kind of unit of a source file.
186 type Regexp_List is array (Positive range <>) of Regexp;
188 procedure Process
189 (Directories : Argument_List;
190 Name_Patterns : Regexp_List;
191 Excluded_Patterns : Regexp_List;
192 Foreign_Patterns : Regexp_List);
193 -- Look for source files in the specified directories, with the specified
194 -- patterns.
196 -- Directories is the list of source directories where to look for sources.
198 -- Name_Patterns is a potentially empty list of file name patterns to check
199 -- for Ada Sources.
201 -- Excluded_Patterns is a potentially empty list of file name patterns that
202 -- should not be checked for Ada or non Ada sources.
204 -- Foreign_Patterns is a potentially empty list of file name patterns to
205 -- check for non Ada sources.
207 -- At least one of Name_Patterns and Foreign_Patterns is not empty
209 procedure Finalize;
210 -- Write the configuration pragmas file indicated in a call to procedure
211 -- Initialize, after one or several calls to procedure Process.
213 --------------------------
214 -- Add_Source_Directory --
215 --------------------------
217 procedure Add_Source_Directory (S : String) is
218 begin
219 Patterns.Append
220 (Arguments.Table (Arguments.Last).Directories, new String'(S));
221 end Add_Source_Directory;
223 ---------
224 -- Dup --
225 ---------
227 function Dup (Fd : File_Descriptor) return File_Descriptor is
228 begin
229 return File_Descriptor (System.CRTL.dup (Integer (Fd)));
230 end Dup;
232 ----------
233 -- Dup2 --
234 ----------
236 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is
237 Fd : Integer;
238 pragma Warnings (Off, Fd);
239 begin
240 Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd));
241 end Dup2;
243 ---------------------
244 -- Get_Directories --
245 ---------------------
247 procedure Get_Directories (From_File : String) is
248 File : Ada.Text_IO.File_Type;
249 Line : String (1 .. 2_000);
250 Last : Natural;
252 begin
253 Open (File, In_File, From_File);
255 while not End_Of_File (File) loop
256 Get_Line (File, Line, Last);
258 if Last /= 0 then
259 Add_Source_Directory (Line (1 .. Last));
260 end if;
261 end loop;
263 Close (File);
265 exception
266 when Name_Error =>
267 Fail ("cannot open source directory file """ & From_File & '"');
268 end Get_Directories;
270 --------------
271 -- Finalize --
272 --------------
274 procedure Finalize is
275 Discard : Boolean;
276 pragma Warnings (Off, Discard);
278 begin
279 -- Delete the file if it already exists
281 Delete_File
282 (Path_Name (Directory_Last + 1 .. Path_Last),
283 Success => Discard);
285 -- Create a new one
287 if Opt.Verbose_Mode then
288 Output.Write_Str ("Creating new file """);
289 Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
290 Output.Write_Line ("""");
291 end if;
293 Output_FD := Create_New_File
294 (Path_Name (Directory_Last + 1 .. Path_Last),
295 Fmode => Text);
297 -- Fails if file cannot be created
299 if Output_FD = Invalid_FD then
300 Fail_Program
301 ("cannot create new """ & Path_Name (1 .. Path_Last) & """");
302 end if;
304 -- For each Ada source, write a pragma Source_File_Name to the
305 -- configuration pragmas file.
307 for Index in 1 .. Sources.Last loop
308 if Sources.Table (Index).Unit_Name /= No_Name then
309 Write_A_String ("pragma Source_File_Name");
310 Write_Eol;
311 Write_A_String (" (");
312 Write_A_String
313 (Get_Name_String (Sources.Table (Index).Unit_Name));
314 Write_A_String (",");
315 Write_Eol;
317 if Sources.Table (Index).Spec then
318 Write_A_String (" Spec_File_Name => """);
320 else
321 Write_A_String (" Body_File_Name => """);
322 end if;
324 Write_A_String
325 (Get_Name_String (Sources.Table (Index).File_Name));
327 Write_A_String ("""");
329 if Sources.Table (Index).Index /= 0 then
330 Write_A_String (", Index =>");
331 Write_A_String (Sources.Table (Index).Index'Img);
332 end if;
334 Write_A_String (");");
335 Write_Eol;
336 end if;
337 end loop;
339 Close (Output_FD);
340 end Finalize;
342 ----------------
343 -- Initialize --
344 ----------------
346 procedure Initialize
347 (File_Path : String;
348 Preproc_Switches : Argument_List)
350 begin
351 Sources.Set_Last (0);
353 -- Initialize the compiler switches
355 Args := new Argument_List (1 .. Preproc_Switches'Length + 6);
356 Args (1) := new String'("-c");
357 Args (2) := new String'("-gnats");
358 Args (3) := new String'("-gnatu");
359 Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
360 Args (4 + Preproc_Switches'Length) := new String'("-x");
361 Args (5 + Preproc_Switches'Length) := new String'("ada");
363 -- Get the path and file names
365 Path_Name := new
366 String (1 .. File_Path'Length);
367 Path_Last := File_Path'Length;
369 if File_Names_Case_Sensitive then
370 Path_Name (1 .. Path_Last) := File_Path;
371 else
372 Path_Name (1 .. Path_Last) := To_Lower (File_Path);
373 end if;
375 -- Get the end of directory information, if any
377 for Index in reverse 1 .. Path_Last loop
378 if Path_Name (Index) = Directory_Separator then
379 Directory_Last := Index;
380 exit;
381 end if;
382 end loop;
384 -- Change the current directory to the directory of the project file,
385 -- if any directory information is specified.
387 if Directory_Last /= 0 then
388 begin
389 Change_Dir (Path_Name (1 .. Directory_Last));
390 exception
391 when Directory_Error =>
392 Fail_Program
393 ("unknown directory """
394 & Path_Name (1 .. Directory_Last)
395 & """");
396 end;
397 end if;
398 end Initialize;
400 -------------
401 -- Process --
402 -------------
404 procedure Process
405 (Directories : Argument_List;
406 Name_Patterns : Regexp_List;
407 Excluded_Patterns : Regexp_List;
408 Foreign_Patterns : Regexp_List)
410 procedure Process_Directory (Dir_Name : String);
411 -- Look for Ada and foreign sources in a directory, according to the
412 -- patterns.
414 -----------------------
415 -- Process_Directory --
416 -----------------------
418 procedure Process_Directory (Dir_Name : String) is
419 Matched : Matched_Type := False;
420 Str : String (1 .. 2_000);
421 Canon : String (1 .. 2_000);
422 Last : Natural;
423 Dir : Dir_Type;
424 Do_Process : Boolean := True;
426 Temp_File_Name : String_Access := null;
427 Save_Last_Source_Index : Natural := 0;
428 File_Name_Id : Name_Id := No_Name;
430 Current_Source : Source;
432 begin
433 -- Avoid processing the same directory more than once
435 for Index in 1 .. Processed_Directories.Last loop
436 if Processed_Directories.Table (Index).all = Dir_Name then
437 Do_Process := False;
438 exit;
439 end if;
440 end loop;
442 if Do_Process then
443 if Opt.Verbose_Mode then
444 Output.Write_Str ("Processing directory """);
445 Output.Write_Str (Dir_Name);
446 Output.Write_Line ("""");
447 end if;
449 Processed_Directories. Increment_Last;
450 Processed_Directories.Table (Processed_Directories.Last) :=
451 new String'(Dir_Name);
453 -- Get the source file names from the directory. Fails if the
454 -- directory does not exist.
456 begin
457 Open (Dir, Dir_Name);
458 exception
459 when Directory_Error =>
460 Fail_Program ("cannot open directory """ & Dir_Name & """");
461 end;
463 -- Process each regular file in the directory
465 File_Loop : loop
466 Read (Dir, Str, Last);
467 exit File_Loop when Last = 0;
469 -- Copy the file name and put it in canonical case to match
470 -- against the patterns that have themselves already been put
471 -- in canonical case.
473 Canon (1 .. Last) := Str (1 .. Last);
474 Canonical_Case_File_Name (Canon (1 .. Last));
476 if Is_Regular_File
477 (Dir_Name & Directory_Separator & Str (1 .. Last))
478 then
479 Matched := True;
481 Name_Len := Last;
482 Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
483 File_Name_Id := Name_Find;
485 -- First, check if the file name matches at least one of
486 -- the excluded expressions;
488 for Index in Excluded_Patterns'Range loop
490 Match (Canon (1 .. Last), Excluded_Patterns (Index))
491 then
492 Matched := Excluded;
493 exit;
494 end if;
495 end loop;
497 -- If it does not match any of the excluded expressions,
498 -- check if the file name matches at least one of the
499 -- regular expressions.
501 if Matched = True then
502 Matched := False;
504 for Index in Name_Patterns'Range loop
506 Match
507 (Canon (1 .. Last), Name_Patterns (Index))
508 then
509 Matched := True;
510 exit;
511 end if;
512 end loop;
513 end if;
515 if Very_Verbose
516 or else (Matched = True and then Opt.Verbose_Mode)
517 then
518 Output.Write_Str (" Checking """);
519 Output.Write_Str (Str (1 .. Last));
520 Output.Write_Line (""": ");
521 end if;
523 -- If the file name matches one of the regular expressions,
524 -- parse it to get its unit name.
526 if Matched = True then
527 declare
528 FD : File_Descriptor;
529 Success : Boolean;
530 Saved_Output : File_Descriptor;
531 Saved_Error : File_Descriptor;
532 Tmp_File : Path_Name_Type;
534 begin
535 -- If we don't have the path of the compiler yet,
536 -- get it now. The compiler name may have a prefix,
537 -- so we get the potentially prefixed name.
539 if Gcc_Path = null then
540 declare
541 Prefix_Gcc : String_Access :=
542 Program_Name (Gcc, "gnatname");
543 begin
544 Gcc_Path :=
545 Locate_Exec_On_Path (Prefix_Gcc.all);
546 Free (Prefix_Gcc);
547 end;
549 if Gcc_Path = null then
550 Fail_Program ("could not locate " & Gcc);
551 end if;
552 end if;
554 -- Create the temporary file
556 Tempdir.Create_Temp_File (FD, Tmp_File);
558 if FD = Invalid_FD then
559 Fail_Program
560 ("could not create temporary file");
562 else
563 Temp_File_Name :=
564 new String'(Get_Name_String (Tmp_File));
565 end if;
567 Args (Args'Last) :=
568 new String'
569 (Dir_Name & Directory_Separator & Str (1 .. Last));
571 -- Save the standard output and error
573 Saved_Output := Dup (Standout);
574 Saved_Error := Dup (Standerr);
576 -- Set standard output and error to the temporary file
578 Dup2 (FD, Standout);
579 Dup2 (FD, Standerr);
581 -- And spawn the compiler
583 Spawn (Gcc_Path.all, Args.all, Success);
585 -- Restore the standard output and error
587 Dup2 (Saved_Output, Standout);
588 Dup2 (Saved_Error, Standerr);
590 -- Close the temporary file
592 Close (FD);
594 -- And close the saved standard output and error to
595 -- avoid too many file descriptors.
597 Close (Saved_Output);
598 Close (Saved_Error);
600 -- Now that standard output is restored, check if
601 -- the compiler ran correctly.
603 -- Read the lines of the temporary file:
604 -- they should contain the kind and name of the unit.
606 declare
607 File : Ada.Text_IO.File_Type;
608 Text_Line : String (1 .. 1_000);
609 Text_Last : Natural;
611 begin
612 begin
613 Open (File, In_File, Temp_File_Name.all);
615 exception
616 when others =>
617 Fail_Program
618 ("could not read temporary file " &
619 Temp_File_Name.all);
620 end;
622 Save_Last_Source_Index := Sources.Last;
624 if End_Of_File (File) then
625 if Opt.Verbose_Mode then
626 if not Success then
627 Output.Write_Str (" (process died) ");
628 end if;
629 end if;
631 else
632 Line_Loop : while not End_Of_File (File) loop
633 Get_Line (File, Text_Line, Text_Last);
635 -- Find the first closing parenthesis
637 Char_Loop : for J in 1 .. Text_Last loop
638 if Text_Line (J) = ')' then
639 if J >= 13 and then
640 Text_Line (1 .. 4) = "Unit"
641 then
642 -- Add entry to Sources table
644 Name_Len := J - 12;
645 Name_Buffer (1 .. Name_Len) :=
646 Text_Line (6 .. J - 7);
647 Current_Source :=
648 (Unit_Name => Name_Find,
649 File_Name => File_Name_Id,
650 Index => 0,
651 Spec => Text_Line (J - 5 .. J) =
652 "(spec)");
654 Sources.Append (Current_Source);
655 end if;
657 exit Char_Loop;
658 end if;
659 end loop Char_Loop;
660 end loop Line_Loop;
661 end if;
663 if Save_Last_Source_Index = Sources.Last then
664 if Opt.Verbose_Mode then
665 Output.Write_Line (" not a unit");
666 end if;
668 else
669 if Sources.Last >
670 Save_Last_Source_Index + 1
671 then
672 for Index in Save_Last_Source_Index + 1 ..
673 Sources.Last
674 loop
675 Sources.Table (Index).Index :=
676 Int (Index - Save_Last_Source_Index);
677 end loop;
678 end if;
680 for Index in Save_Last_Source_Index + 1 ..
681 Sources.Last
682 loop
683 Current_Source := Sources.Table (Index);
684 pragma Annotate
685 (CodePeer, Modified, Current_Source);
687 if Opt.Verbose_Mode then
688 if Current_Source.Spec then
689 Output.Write_Str (" spec of ");
691 else
692 Output.Write_Str (" body of ");
693 end if;
695 Output.Write_Line
696 (Get_Name_String
697 (Current_Source.Unit_Name));
698 end if;
699 end loop;
700 end if;
702 Close (File);
704 Delete_File (Temp_File_Name.all, Success);
705 end;
706 end;
708 -- File name matches none of the regular expressions
710 else
711 -- If file is not excluded, see if this is foreign source
713 if Matched /= Excluded then
714 for Index in Foreign_Patterns'Range loop
715 if Match (Canon (1 .. Last),
716 Foreign_Patterns (Index))
717 then
718 Matched := True;
719 exit;
720 end if;
721 end loop;
722 end if;
724 if Very_Verbose then
725 case Matched is
726 when False =>
727 Output.Write_Line ("no match");
729 when Excluded =>
730 Output.Write_Line ("excluded");
732 when True =>
733 Output.Write_Line ("foreign source");
734 end case;
735 end if;
737 if Matched = True then
739 -- Add source file name without unit name
741 Name_Len := 0;
742 Add_Str_To_Name_Buffer (Canon (1 .. Last));
743 Sources.Append
744 ((File_Name => Name_Find,
745 Unit_Name => No_Name,
746 Index => 0,
747 Spec => False));
748 end if;
749 end if;
750 end if;
751 end loop File_Loop;
753 Close (Dir);
754 end if;
756 end Process_Directory;
758 -- Start of processing for Process
760 begin
761 Processed_Directories.Set_Last (0);
763 -- Process each directory
765 for Index in Directories'Range loop
766 Process_Directory (Directories (Index).all);
767 end loop;
768 end Process;
770 --------------------
771 -- Output_Version --
772 --------------------
774 procedure Output_Version is
775 begin
776 if not Version_Output then
777 Version_Output := True;
778 Output.Write_Eol;
779 Display_Version ("GNATNAME", "2001");
780 end if;
781 end Output_Version;
783 ---------------
784 -- Scan_Args --
785 ---------------
787 procedure Scan_Args is
789 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
791 Project_File_Name_Expected : Boolean;
793 Pragmas_File_Expected : Boolean;
795 Directory_Expected : Boolean;
797 Dir_File_Name_Expected : Boolean;
799 Foreign_Pattern_Expected : Boolean;
801 Excluded_Pattern_Expected : Boolean;
803 procedure Check_Regular_Expression (S : String);
804 -- Compile string S into a Regexp, fail if any error
806 -----------------------------
807 -- Check_Regular_Expression--
808 -----------------------------
810 procedure Check_Regular_Expression (S : String) is
811 Dummy : Regexp;
812 pragma Warnings (Off, Dummy);
813 begin
814 Dummy := Compile (S, Glob => True);
815 exception
816 when Error_In_Regexp =>
817 Fail ("invalid regular expression """ & S & """");
818 end Check_Regular_Expression;
820 -- Start of processing for Scan_Args
822 begin
823 -- First check for --version or --help
825 Check_Version_And_Help ("GNATNAME", "2001");
827 -- Now scan the other switches
829 Project_File_Name_Expected := False;
830 Pragmas_File_Expected := False;
831 Directory_Expected := False;
832 Dir_File_Name_Expected := False;
833 Foreign_Pattern_Expected := False;
834 Excluded_Pattern_Expected := False;
836 for Next_Arg in 1 .. Argument_Count loop
837 declare
838 Next_Argv : constant String := Argument (Next_Arg);
839 Arg : String (1 .. Next_Argv'Length) := Next_Argv;
841 begin
842 if Arg'Length > 0 then
844 -- -P xxx
846 if Project_File_Name_Expected then
847 if Arg (1) = '-' then
848 Fail ("project file name missing");
850 else
851 File_Set := True;
852 File_Path := new String'(Arg);
853 Project_File_Name_Expected := False;
854 end if;
856 -- -c file
858 elsif Pragmas_File_Expected then
859 File_Set := True;
860 File_Path := new String'(Arg);
861 Pragmas_File_Expected := False;
863 -- -d xxx
865 elsif Directory_Expected then
866 Add_Source_Directory (Arg);
867 Directory_Expected := False;
869 -- -D xxx
871 elsif Dir_File_Name_Expected then
872 Get_Directories (Arg);
873 Dir_File_Name_Expected := False;
875 -- -f xxx
877 elsif Foreign_Pattern_Expected then
878 Patterns.Append
879 (Arguments.Table (Arguments.Last).Foreign_Patterns,
880 new String'(Arg));
881 Check_Regular_Expression (Arg);
882 Foreign_Pattern_Expected := False;
884 -- -x xxx
886 elsif Excluded_Pattern_Expected then
887 Patterns.Append
888 (Arguments.Table (Arguments.Last).Excluded_Patterns,
889 new String'(Arg));
890 Check_Regular_Expression (Arg);
891 Excluded_Pattern_Expected := False;
893 -- There must be at least one Ada pattern or one foreign
894 -- pattern for the previous section.
896 -- --and
898 elsif Arg = "--and" then
900 if Patterns.Last
901 (Arguments.Table (Arguments.Last).Name_Patterns) = 0
902 and then
903 Patterns.Last
904 (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0
905 then
906 Try_Help;
907 return;
908 end if;
910 -- If no directory were specified for the previous section,
911 -- then the directory is the project directory.
913 if Patterns.Last
914 (Arguments.Table (Arguments.Last).Directories) = 0
915 then
916 Patterns.Append
917 (Arguments.Table (Arguments.Last).Directories,
918 new String'("."));
919 end if;
921 -- Add and initialize another component to Arguments table
923 declare
924 New_Arguments : Argument_Data;
925 pragma Warnings (Off, New_Arguments);
926 -- Declaring this defaulted initialized object ensures
927 -- that the new allocated component of table Arguments
928 -- is correctly initialized.
930 -- This is VERY ugly, Table should never be used with
931 -- data requiring default initialization. We should
932 -- find a way to avoid violating this rule ???
934 begin
935 Arguments.Append (New_Arguments);
936 end;
938 Patterns.Init
939 (Arguments.Table (Arguments.Last).Directories);
940 Patterns.Set_Last
941 (Arguments.Table (Arguments.Last).Directories, 0);
942 Patterns.Init
943 (Arguments.Table (Arguments.Last).Name_Patterns);
944 Patterns.Set_Last
945 (Arguments.Table (Arguments.Last).Name_Patterns, 0);
946 Patterns.Init
947 (Arguments.Table (Arguments.Last).Excluded_Patterns);
948 Patterns.Set_Last
949 (Arguments.Table (Arguments.Last).Excluded_Patterns, 0);
950 Patterns.Init
951 (Arguments.Table (Arguments.Last).Foreign_Patterns);
952 Patterns.Set_Last
953 (Arguments.Table (Arguments.Last).Foreign_Patterns, 0);
955 -- Subdirectory switch
957 elsif Arg'Length > Subdirs_Switch'Length
958 and then Arg (1 .. Subdirs_Switch'Length) = Subdirs_Switch
959 then
960 null;
961 -- Subdirs are only used in gprname
963 -- --no-backup
965 elsif Arg = "--no-backup" then
966 Opt.No_Backup := True;
968 -- -c
970 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-c" then
971 if File_Set then
972 Fail ("only one -P or -c switch may be specified");
973 end if;
975 if Arg'Length = 2 then
976 Pragmas_File_Expected := True;
978 if Next_Arg = Argument_Count then
979 Fail ("configuration pragmas file name missing");
980 end if;
982 else
983 File_Set := True;
984 File_Path := new String'(Arg (3 .. Arg'Last));
985 end if;
987 -- -d
989 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-d" then
990 if Arg'Length = 2 then
991 Directory_Expected := True;
993 if Next_Arg = Argument_Count then
994 Fail ("directory name missing");
995 end if;
997 else
998 Add_Source_Directory (Arg (3 .. Arg'Last));
999 end if;
1001 -- -D
1003 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-D" then
1004 if Arg'Length = 2 then
1005 Dir_File_Name_Expected := True;
1007 if Next_Arg = Argument_Count then
1008 Fail ("directory list file name missing");
1009 end if;
1011 else
1012 Get_Directories (Arg (3 .. Arg'Last));
1013 end if;
1015 -- -eL
1017 elsif Arg = "-eL" then
1018 Opt.Follow_Links_For_Files := True;
1019 Opt.Follow_Links_For_Dirs := True;
1021 -- -f
1023 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-f" then
1024 if Arg'Length = 2 then
1025 Foreign_Pattern_Expected := True;
1027 if Next_Arg = Argument_Count then
1028 Fail ("foreign pattern missing");
1029 end if;
1031 else
1032 Patterns.Append
1033 (Arguments.Table (Arguments.Last).Foreign_Patterns,
1034 new String'(Arg (3 .. Arg'Last)));
1035 Check_Regular_Expression (Arg (3 .. Arg'Last));
1036 end if;
1038 -- -gnatep or -gnateD
1040 elsif Arg'Length > 7 and then
1041 (Arg (1 .. 7) = "-gnatep" or else Arg (1 .. 7) = "-gnateD")
1042 then
1043 Preprocessor_Switches.Append (new String'(Arg));
1045 -- -h
1047 elsif Arg = "-h" then
1048 Usage_Needed := True;
1050 -- -P
1052 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-P" then
1053 if File_Set then
1054 Fail ("only one -c or -P switch may be specified");
1055 end if;
1057 if Arg'Length = 2 then
1058 if Next_Arg = Argument_Count then
1059 Fail ("project file name missing");
1061 else
1062 Project_File_Name_Expected := True;
1063 end if;
1065 else
1066 File_Set := True;
1067 File_Path := new String'(Arg (3 .. Arg'Last));
1068 end if;
1070 Create_Project := True;
1072 -- -v
1074 elsif Arg = "-v" then
1075 if Opt.Verbose_Mode then
1076 Very_Verbose := True;
1077 else
1078 Opt.Verbose_Mode := True;
1079 end if;
1081 -- -x
1083 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-x" then
1084 if Arg'Length = 2 then
1085 Excluded_Pattern_Expected := True;
1087 if Next_Arg = Argument_Count then
1088 Fail ("excluded pattern missing");
1089 end if;
1091 else
1092 Patterns.Append
1093 (Arguments.Table (Arguments.Last).Excluded_Patterns,
1094 new String'(Arg (3 .. Arg'Last)));
1095 Check_Regular_Expression (Arg (3 .. Arg'Last));
1096 end if;
1098 -- Junk switch starting with minus
1100 elsif Arg (1) = '-' then
1101 Fail ("wrong switch: " & Arg);
1103 -- Not a recognized switch, assume file name
1105 else
1106 Canonical_Case_File_Name (Arg);
1107 Patterns.Append
1108 (Arguments.Table (Arguments.Last).Name_Patterns,
1109 new String'(Arg));
1110 Check_Regular_Expression (Arg);
1111 end if;
1112 end if;
1113 end;
1114 end loop;
1115 end Scan_Args;
1117 -----------
1118 -- Usage --
1119 -----------
1121 procedure Usage is
1122 begin
1123 if not Usage_Output then
1124 Usage_Needed := False;
1125 Usage_Output := True;
1126 Output.Write_Str ("Usage: ");
1127 Osint.Write_Program_Name;
1128 Output.Write_Line (" [switches] naming-pattern [naming-patterns]");
1129 Output.Write_Line
1130 (" {--and [switches] naming-pattern [naming-patterns]}");
1131 Output.Write_Eol;
1132 Output.Write_Line ("switches:");
1134 Display_Usage_Version_And_Help;
1136 Output.Write_Line
1137 (" --subdirs=dir real obj/lib/exec dirs are subdirs");
1138 Output.Write_Line
1139 (" --no-backup do not create backup of project file");
1140 Output.Write_Eol;
1142 Output.Write_Line (" --and use different patterns");
1143 Output.Write_Eol;
1145 Output.Write_Line
1146 (" -cfile create configuration pragmas file");
1147 Output.Write_Line (" -ddir use dir as one of the source " &
1148 "directories");
1149 Output.Write_Line (" -Dfile get source directories from file");
1150 Output.Write_Line
1151 (" -eL follow symbolic links when processing " &
1152 "project files");
1153 Output.Write_Line (" -fpat foreign pattern");
1154 Output.Write_Line
1155 (" -gnateDsym=v preprocess with symbol definition");
1156 Output.Write_Line (" -gnatep=data preprocess files with data file");
1157 Output.Write_Line (" -h output this help message");
1158 Output.Write_Line
1159 (" -Pproj update or create project file proj");
1160 Output.Write_Line (" -v verbose output");
1161 Output.Write_Line (" -v -v very verbose output");
1162 Output.Write_Line (" -xpat exclude pattern pat");
1163 end if;
1164 end Usage;
1166 ---------------
1167 -- Write_Eol --
1168 ---------------
1170 procedure Write_Eol is
1171 begin
1172 Write_A_String ((1 => ASCII.LF));
1173 end Write_Eol;
1175 --------------------
1176 -- Write_A_String --
1177 --------------------
1179 procedure Write_A_String (S : String) is
1180 Str : String (1 .. S'Length);
1182 begin
1183 if S'Length > 0 then
1184 Str := S;
1186 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
1187 Fail_Program ("disk full");
1188 end if;
1189 end if;
1190 end Write_A_String;
1192 -- Start of processing for Gnatname
1194 begin
1195 -- Add the directory where gnatname is invoked in front of the
1196 -- path, if gnatname is invoked with directory information.
1198 declare
1199 Command : constant String := Command_Name;
1201 begin
1202 for Index in reverse Command'Range loop
1203 if Command (Index) = Directory_Separator then
1204 declare
1205 Absolute_Dir : constant String :=
1206 Normalize_Pathname
1207 (Command (Command'First .. Index));
1209 PATH : constant String :=
1210 Absolute_Dir &
1211 Path_Separator &
1212 Getenv ("PATH").all;
1214 begin
1215 Setenv ("PATH", PATH);
1216 end;
1218 exit;
1219 end if;
1220 end loop;
1221 end;
1223 -- Initialize tables
1225 Arguments.Set_Last (0);
1226 declare
1227 New_Arguments : Argument_Data;
1228 pragma Warnings (Off, New_Arguments);
1229 -- Declaring this defaulted initialized object ensures that the new
1230 -- allocated component of table Arguments is correctly initialized.
1231 begin
1232 Arguments.Append (New_Arguments);
1233 end;
1235 Patterns.Init (Arguments.Table (1).Directories);
1236 Patterns.Set_Last (Arguments.Table (1).Directories, 0);
1237 Patterns.Init (Arguments.Table (1).Name_Patterns);
1238 Patterns.Set_Last (Arguments.Table (1).Name_Patterns, 0);
1239 Patterns.Init (Arguments.Table (1).Excluded_Patterns);
1240 Patterns.Set_Last (Arguments.Table (1).Excluded_Patterns, 0);
1241 Patterns.Init (Arguments.Table (1).Foreign_Patterns);
1242 Patterns.Set_Last (Arguments.Table (1).Foreign_Patterns, 0);
1244 Preprocessor_Switches.Set_Last (0);
1246 -- Get the arguments
1248 Scan_Args;
1250 if Create_Project then
1251 declare
1252 Gprname_Path : constant String_Access :=
1253 Locate_Exec_On_Path ("gprname");
1254 Arg_Len : Natural := Argument_Count;
1255 Pos : Natural := 0;
1256 Target : String_Access := null;
1257 Success : Boolean := False;
1258 begin
1259 if Gprname_Path = null then
1260 Fail_Program
1261 ("project files are no longer supported by gnatname;" &
1262 " use gprname instead");
1263 end if;
1265 Find_Program_Name;
1267 if Name_Len > 9
1268 and then Name_Buffer (Name_Len - 7 .. Name_Len) = "gnatname"
1269 then
1270 Target := new String'(Name_Buffer (1 .. Name_Len - 9));
1271 Arg_Len := Arg_Len + 1;
1272 end if;
1274 declare
1275 Args : Argument_List (1 .. Arg_Len);
1276 begin
1277 if Target /= null then
1278 Args (1) := new String'("--target=" & Target.all);
1279 Pos := 1;
1280 end if;
1282 for J in 1 .. Argument_Count loop
1283 Pos := Pos + 1;
1284 Args (Pos) := new String'(Argument (J));
1285 end loop;
1287 Spawn (Gprname_Path.all, Args, Success);
1289 if Success then
1290 Exit_Program (E_Success);
1291 else
1292 Exit_Program (E_Errors);
1293 end if;
1294 end;
1295 end;
1296 end if;
1298 if Opt.Verbose_Mode then
1299 Output_Version;
1300 end if;
1302 if Usage_Needed then
1303 Usage;
1304 end if;
1306 -- If no Ada or foreign pattern was specified, print the usage and return
1308 if Patterns.Last (Arguments.Table (Arguments.Last).Name_Patterns) = 0
1309 and then
1310 Patterns.Last (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0
1311 then
1312 if Argument_Count = 0 then
1313 Usage;
1314 elsif not Usage_Output then
1315 Try_Help;
1316 end if;
1318 return;
1319 end if;
1321 -- If no source directory was specified, use the current directory as the
1322 -- unique directory. Note that if a file was specified with directory
1323 -- information, the current directory is the directory of the specified
1324 -- file.
1326 if Patterns.Last (Arguments.Table (Arguments.Last).Directories) = 0 then
1327 Patterns.Append
1328 (Arguments.Table (Arguments.Last).Directories, new String'("."));
1329 end if;
1331 -- Initialize
1333 declare
1334 Prep_Switches : Argument_List
1335 (1 .. Integer (Preprocessor_Switches.Last));
1337 begin
1338 for Index in Prep_Switches'Range loop
1339 Prep_Switches (Index) := Preprocessor_Switches.Table (Index);
1340 end loop;
1342 Initialize
1343 (File_Path => File_Path.all,
1344 Preproc_Switches => Prep_Switches);
1345 end;
1347 -- Process each section successively
1349 for J in 1 .. Arguments.Last loop
1350 declare
1351 Directories : Argument_List
1352 (1 .. Integer
1353 (Patterns.Last (Arguments.Table (J).Directories)));
1354 Name_Patterns : Regexp_List
1355 (1 .. Integer
1356 (Patterns.Last (Arguments.Table (J).Name_Patterns)));
1357 Excl_Patterns : Regexp_List
1358 (1 .. Integer
1359 (Patterns.Last (Arguments.Table (J).Excluded_Patterns)));
1360 Frgn_Patterns : Regexp_List
1361 (1 .. Integer
1362 (Patterns.Last (Arguments.Table (J).Foreign_Patterns)));
1364 begin
1365 -- Build the Directories and Patterns arguments
1367 for Index in Directories'Range loop
1368 Directories (Index) :=
1369 Arguments.Table (J).Directories.Table (Index);
1370 end loop;
1372 for Index in Name_Patterns'Range loop
1373 Name_Patterns (Index) :=
1374 Compile
1375 (Arguments.Table (J).Name_Patterns.Table (Index).all,
1376 Glob => True);
1377 end loop;
1379 for Index in Excl_Patterns'Range loop
1380 Excl_Patterns (Index) :=
1381 Compile
1382 (Arguments.Table (J).Excluded_Patterns.Table (Index).all,
1383 Glob => True);
1384 end loop;
1386 for Index in Frgn_Patterns'Range loop
1387 Frgn_Patterns (Index) :=
1388 Compile
1389 (Arguments.Table (J).Foreign_Patterns.Table (Index).all,
1390 Glob => True);
1391 end loop;
1393 -- Call Prj.Makr.Process where the real work is done
1395 Process
1396 (Directories => Directories,
1397 Name_Patterns => Name_Patterns,
1398 Excluded_Patterns => Excl_Patterns,
1399 Foreign_Patterns => Frgn_Patterns);
1400 end;
1401 end loop;
1403 -- Finalize
1405 Finalize;
1407 if Opt.Verbose_Mode then
1408 Output.Write_Eol;
1409 end if;
1410 end Gnatname;