File : gnatname.adb
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-2015, 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 ------------------------------------------------------------------------------
25
26 with Ada.Command_Line; use Ada.Command_Line;
27 with Ada.Text_IO; use Ada.Text_IO;
28
29 with GNAT.Command_Line; use GNAT.Command_Line;
30 with GNAT.Dynamic_Tables;
31 with GNAT.OS_Lib; use GNAT.OS_Lib;
32
33 with Opt;
34 with Osint; use Osint;
35 with Output; use Output;
36 with Prj; use Prj;
37 with Prj.Makr;
38 with Switch; use Switch;
39 with Table;
40
41 with System.Regexp; use System.Regexp;
42
43 procedure Gnatname is
44
45 Subdirs_Switch : constant String := "--subdirs=";
46
47 Usage_Output : Boolean := False;
48 -- Set to True when usage is output, to avoid multiple output
49
50 Usage_Needed : Boolean := False;
51 -- Set to True by -h switch
52
53 Version_Output : Boolean := False;
54 -- Set to True when version is output, to avoid multiple output
55
56 Very_Verbose : Boolean := False;
57 -- Set to True with -v -v
58
59 Create_Project : Boolean := False;
60 -- Set to True with a -P switch
61
62 File_Path : String_Access := new String'("gnat.adc");
63 -- Path name of the file specified by -c or -P switch
64
65 File_Set : Boolean := False;
66 -- Set to True by -c or -P switch.
67 -- Used to detect multiple -c/-P switches.
68
69 package Patterns is new GNAT.Dynamic_Tables
70 (Table_Component_Type => String_Access,
71 Table_Index_Type => Natural,
72 Table_Low_Bound => 0,
73 Table_Initial => 10,
74 Table_Increment => 100);
75 -- Table to accumulate the patterns
76
77 type Argument_Data is record
78 Directories : Patterns.Instance;
79 Name_Patterns : Patterns.Instance;
80 Excluded_Patterns : Patterns.Instance;
81 Foreign_Patterns : Patterns.Instance;
82 end record;
83
84 package Arguments is new Table.Table
85 (Table_Component_Type => Argument_Data,
86 Table_Index_Type => Natural,
87 Table_Low_Bound => 0,
88 Table_Initial => 10,
89 Table_Increment => 100,
90 Table_Name => "Gnatname.Arguments");
91 -- Table to accumulate directories and patterns
92
93 package Preprocessor_Switches is new Table.Table
94 (Table_Component_Type => String_Access,
95 Table_Index_Type => Natural,
96 Table_Low_Bound => 0,
97 Table_Initial => 10,
98 Table_Increment => 100,
99 Table_Name => "Gnatname.Preprocessor_Switches");
100 -- Table to store the preprocessor switches to be used in the call
101 -- to the compiler.
102
103 procedure Output_Version;
104 -- Print name and version
105
106 procedure Usage;
107 -- Print usage
108
109 procedure Scan_Args;
110 -- Scan the command line arguments
111
112 procedure Add_Source_Directory (S : String);
113 -- Add S in the Source_Directories table
114
115 procedure Get_Directories (From_File : String);
116 -- Read a source directory text file
117
118 --------------------------
119 -- Add_Source_Directory --
120 --------------------------
121
122 procedure Add_Source_Directory (S : String) is
123 begin
124 Patterns.Append
125 (Arguments.Table (Arguments.Last).Directories, new String'(S));
126 end Add_Source_Directory;
127
128 ---------------------
129 -- Get_Directories --
130 ---------------------
131
132 procedure Get_Directories (From_File : String) is
133 File : Ada.Text_IO.File_Type;
134 Line : String (1 .. 2_000);
135 Last : Natural;
136
137 begin
138 Open (File, In_File, From_File);
139
140 while not End_Of_File (File) loop
141 Get_Line (File, Line, Last);
142
143 if Last /= 0 then
144 Add_Source_Directory (Line (1 .. Last));
145 end if;
146 end loop;
147
148 Close (File);
149
150 exception
151 when Name_Error =>
152 Fail ("cannot open source directory file """ & From_File & '"');
153 end Get_Directories;
154
155 --------------------
156 -- Output_Version --
157 --------------------
158
159 procedure Output_Version is
160 begin
161 if not Version_Output then
162 Version_Output := True;
163 Output.Write_Eol;
164 Display_Version ("GNATNAME", "2001");
165 end if;
166 end Output_Version;
167
168 ---------------
169 -- Scan_Args --
170 ---------------
171
172 procedure Scan_Args is
173
174 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
175
176 Project_File_Name_Expected : Boolean;
177
178 Pragmas_File_Expected : Boolean;
179
180 Directory_Expected : Boolean;
181
182 Dir_File_Name_Expected : Boolean;
183
184 Foreign_Pattern_Expected : Boolean;
185
186 Excluded_Pattern_Expected : Boolean;
187
188 procedure Check_Regular_Expression (S : String);
189 -- Compile string S into a Regexp, fail if any error
190
191 -----------------------------
192 -- Check_Regular_Expression--
193 -----------------------------
194
195 procedure Check_Regular_Expression (S : String) is
196 Dummy : Regexp;
197 pragma Warnings (Off, Dummy);
198 begin
199 Dummy := Compile (S, Glob => True);
200 exception
201 when Error_In_Regexp =>
202 Fail ("invalid regular expression """ & S & """");
203 end Check_Regular_Expression;
204
205 -- Start of processing for Scan_Args
206
207 begin
208 -- First check for --version or --help
209
210 Check_Version_And_Help ("GNATNAME", "2001");
211
212 -- Now scan the other switches
213
214 Project_File_Name_Expected := False;
215 Pragmas_File_Expected := False;
216 Directory_Expected := False;
217 Dir_File_Name_Expected := False;
218 Foreign_Pattern_Expected := False;
219 Excluded_Pattern_Expected := False;
220
221 for Next_Arg in 1 .. Argument_Count loop
222 declare
223 Next_Argv : constant String := Argument (Next_Arg);
224 Arg : String (1 .. Next_Argv'Length) := Next_Argv;
225
226 begin
227 if Arg'Length > 0 then
228
229 -- -P xxx
230
231 if Project_File_Name_Expected then
232 if Arg (1) = '-' then
233 Fail ("project file name missing");
234
235 else
236 File_Set := True;
237 File_Path := new String'(Arg);
238 Project_File_Name_Expected := False;
239 end if;
240
241 -- -c file
242
243 elsif Pragmas_File_Expected then
244 File_Set := True;
245 File_Path := new String'(Arg);
246 Create_Project := False;
247 Pragmas_File_Expected := False;
248
249 -- -d xxx
250
251 elsif Directory_Expected then
252 Add_Source_Directory (Arg);
253 Directory_Expected := False;
254
255 -- -D xxx
256
257 elsif Dir_File_Name_Expected then
258 Get_Directories (Arg);
259 Dir_File_Name_Expected := False;
260
261 -- -f xxx
262
263 elsif Foreign_Pattern_Expected then
264 Patterns.Append
265 (Arguments.Table (Arguments.Last).Foreign_Patterns,
266 new String'(Arg));
267 Check_Regular_Expression (Arg);
268 Foreign_Pattern_Expected := False;
269
270 -- -x xxx
271
272 elsif Excluded_Pattern_Expected then
273 Patterns.Append
274 (Arguments.Table (Arguments.Last).Excluded_Patterns,
275 new String'(Arg));
276 Check_Regular_Expression (Arg);
277 Excluded_Pattern_Expected := False;
278
279 -- There must be at least one Ada pattern or one foreign
280 -- pattern for the previous section.
281
282 -- --and
283
284 elsif Arg = "--and" then
285
286 if Patterns.Last
287 (Arguments.Table (Arguments.Last).Name_Patterns) = 0
288 and then
289 Patterns.Last
290 (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0
291 then
292 Try_Help;
293 return;
294 end if;
295
296 -- If no directory were specified for the previous section,
297 -- then the directory is the project directory.
298
299 if Patterns.Last
300 (Arguments.Table (Arguments.Last).Directories) = 0
301 then
302 Patterns.Append
303 (Arguments.Table (Arguments.Last).Directories,
304 new String'("."));
305 end if;
306
307 -- Add and initialize another component to Arguments table
308
309 declare
310 New_Arguments : Argument_Data;
311 pragma Warnings (Off, New_Arguments);
312 -- Declaring this defaulted initialized object ensures
313 -- that the new allocated component of table Arguments
314 -- is correctly initialized.
315
316 -- This is VERY ugly, Table should never be used with
317 -- data requiring default initialization. We should
318 -- find a way to avoid violating this rule ???
319
320 begin
321 Arguments.Append (New_Arguments);
322 end;
323
324 Patterns.Init
325 (Arguments.Table (Arguments.Last).Directories);
326 Patterns.Set_Last
327 (Arguments.Table (Arguments.Last).Directories, 0);
328 Patterns.Init
329 (Arguments.Table (Arguments.Last).Name_Patterns);
330 Patterns.Set_Last
331 (Arguments.Table (Arguments.Last).Name_Patterns, 0);
332 Patterns.Init
333 (Arguments.Table (Arguments.Last).Excluded_Patterns);
334 Patterns.Set_Last
335 (Arguments.Table (Arguments.Last).Excluded_Patterns, 0);
336 Patterns.Init
337 (Arguments.Table (Arguments.Last).Foreign_Patterns);
338 Patterns.Set_Last
339 (Arguments.Table (Arguments.Last).Foreign_Patterns, 0);
340
341 -- Subdirectory switch
342
343 elsif Arg'Length > Subdirs_Switch'Length
344 and then Arg (1 .. Subdirs_Switch'Length) = Subdirs_Switch
345 then
346 Subdirs :=
347 new String'(Arg (Subdirs_Switch'Length + 1 .. Arg'Last));
348
349 -- --no-backup
350
351 elsif Arg = "--no-backup" then
352 Opt.No_Backup := True;
353
354 -- -c
355
356 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-c" then
357 if File_Set then
358 Fail ("only one -P or -c switch may be specified");
359 end if;
360
361 if Arg'Length = 2 then
362 Pragmas_File_Expected := True;
363
364 if Next_Arg = Argument_Count then
365 Fail ("configuration pragmas file name missing");
366 end if;
367
368 else
369 File_Set := True;
370 File_Path := new String'(Arg (3 .. Arg'Last));
371 Create_Project := False;
372 end if;
373
374 -- -d
375
376 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-d" then
377 if Arg'Length = 2 then
378 Directory_Expected := True;
379
380 if Next_Arg = Argument_Count then
381 Fail ("directory name missing");
382 end if;
383
384 else
385 Add_Source_Directory (Arg (3 .. Arg'Last));
386 end if;
387
388 -- -D
389
390 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-D" then
391 if Arg'Length = 2 then
392 Dir_File_Name_Expected := True;
393
394 if Next_Arg = Argument_Count then
395 Fail ("directory list file name missing");
396 end if;
397
398 else
399 Get_Directories (Arg (3 .. Arg'Last));
400 end if;
401
402 -- -eL
403
404 elsif Arg = "-eL" then
405 Opt.Follow_Links_For_Files := True;
406 Opt.Follow_Links_For_Dirs := True;
407
408 -- -f
409
410 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-f" then
411 if Arg'Length = 2 then
412 Foreign_Pattern_Expected := True;
413
414 if Next_Arg = Argument_Count then
415 Fail ("foreign pattern missing");
416 end if;
417
418 else
419 Patterns.Append
420 (Arguments.Table (Arguments.Last).Foreign_Patterns,
421 new String'(Arg (3 .. Arg'Last)));
422 Check_Regular_Expression (Arg (3 .. Arg'Last));
423 end if;
424
425 -- -gnatep or -gnateD
426
427 elsif Arg'Length > 7 and then
428 (Arg (1 .. 7) = "-gnatep" or else Arg (1 .. 7) = "-gnateD")
429 then
430 Preprocessor_Switches.Append (new String'(Arg));
431
432 -- -h
433
434 elsif Arg = "-h" then
435 Usage_Needed := True;
436
437 -- -P
438
439 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-P" then
440 if File_Set then
441 Fail ("only one -c or -P switch may be specified");
442 end if;
443
444 if Arg'Length = 2 then
445 if Next_Arg = Argument_Count then
446 Fail ("project file name missing");
447
448 else
449 Project_File_Name_Expected := True;
450 end if;
451
452 else
453 File_Set := True;
454 File_Path := new String'(Arg (3 .. Arg'Last));
455 end if;
456
457 Create_Project := True;
458
459 -- -v
460
461 elsif Arg = "-v" then
462 if Opt.Verbose_Mode then
463 Very_Verbose := True;
464 else
465 Opt.Verbose_Mode := True;
466 end if;
467
468 -- -x
469
470 elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-x" then
471 if Arg'Length = 2 then
472 Excluded_Pattern_Expected := True;
473
474 if Next_Arg = Argument_Count then
475 Fail ("excluded pattern missing");
476 end if;
477
478 else
479 Patterns.Append
480 (Arguments.Table (Arguments.Last).Excluded_Patterns,
481 new String'(Arg (3 .. Arg'Last)));
482 Check_Regular_Expression (Arg (3 .. Arg'Last));
483 end if;
484
485 -- Junk switch starting with minus
486
487 elsif Arg (1) = '-' then
488 Fail ("wrong switch: " & Arg);
489
490 -- Not a recognized switch, assume file name
491
492 else
493 Canonical_Case_File_Name (Arg);
494 Patterns.Append
495 (Arguments.Table (Arguments.Last).Name_Patterns,
496 new String'(Arg));
497 Check_Regular_Expression (Arg);
498 end if;
499 end if;
500 end;
501 end loop;
502 end Scan_Args;
503
504 -----------
505 -- Usage --
506 -----------
507
508 procedure Usage is
509 begin
510 if not Usage_Output then
511 Usage_Needed := False;
512 Usage_Output := True;
513 Write_Str ("Usage: ");
514 Osint.Write_Program_Name;
515 Write_Line (" [switches] naming-pattern [naming-patterns]");
516 Write_Line (" {--and [switches] naming-pattern [naming-patterns]}");
517 Write_Eol;
518 Write_Line ("switches:");
519
520 Display_Usage_Version_And_Help;
521
522 Write_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs");
523 Write_Line (" --no-backup do not create backup of project file");
524 Write_Eol;
525
526 Write_Line (" --and use different patterns");
527 Write_Eol;
528
529 Write_Line (" -cfile create configuration pragmas file");
530 Write_Line (" -ddir use dir as one of the source " &
531 "directories");
532 Write_Line (" -Dfile get source directories from file");
533 Write_Line (" -eL follow symbolic links when processing " &
534 "project files");
535 Write_Line (" -fpat foreign pattern");
536 Write_Line (" -gnateDsym=v preprocess with symbol definition");
537 Write_Line (" -gnatep=data preprocess files with data file");
538 Write_Line (" -h output this help message");
539 Write_Line (" -Pproj update or create project file proj");
540 Write_Line (" -v verbose output");
541 Write_Line (" -v -v very verbose output");
542 Write_Line (" -xpat exclude pattern pat");
543 end if;
544 end Usage;
545
546 -- Start of processing for Gnatname
547
548 begin
549 -- Add the directory where gnatname is invoked in front of the
550 -- path, if gnatname is invoked with directory information.
551
552 declare
553 Command : constant String := Command_Name;
554
555 begin
556 for Index in reverse Command'Range loop
557 if Command (Index) = Directory_Separator then
558 declare
559 Absolute_Dir : constant String :=
560 Normalize_Pathname
561 (Command (Command'First .. Index));
562
563 PATH : constant String :=
564 Absolute_Dir &
565 Path_Separator &
566 Getenv ("PATH").all;
567
568 begin
569 Setenv ("PATH", PATH);
570 end;
571
572 exit;
573 end if;
574 end loop;
575 end;
576
577 -- Initialize tables
578
579 Arguments.Set_Last (0);
580 declare
581 New_Arguments : Argument_Data;
582 pragma Warnings (Off, New_Arguments);
583 -- Declaring this defaulted initialized object ensures that the new
584 -- allocated component of table Arguments is correctly initialized.
585 begin
586 Arguments.Append (New_Arguments);
587 end;
588
589 Patterns.Init (Arguments.Table (1).Directories);
590 Patterns.Set_Last (Arguments.Table (1).Directories, 0);
591 Patterns.Init (Arguments.Table (1).Name_Patterns);
592 Patterns.Set_Last (Arguments.Table (1).Name_Patterns, 0);
593 Patterns.Init (Arguments.Table (1).Excluded_Patterns);
594 Patterns.Set_Last (Arguments.Table (1).Excluded_Patterns, 0);
595 Patterns.Init (Arguments.Table (1).Foreign_Patterns);
596 Patterns.Set_Last (Arguments.Table (1).Foreign_Patterns, 0);
597
598 Preprocessor_Switches.Set_Last (0);
599
600 -- Get the arguments
601
602 Scan_Args;
603
604 if Opt.Verbose_Mode then
605 Output_Version;
606 end if;
607
608 if Usage_Needed then
609 Usage;
610 end if;
611
612 if Create_Project then
613 declare
614 Gnatname : constant String_Access :=
615 Program_Name ("gnatname", "gnatname");
616 Arg_Len : Positive := Argument_Count;
617 Target : String_Access := null;
618
619 begin
620 -- Find the target, if any
621
622 if Gnatname.all /= "gnatname" then
623 Target :=
624 new String'(Gnatname (Gnatname'First .. Gnatname'Last - 9));
625 Arg_Len := Arg_Len + 1;
626 end if;
627
628 declare
629 Args : Argument_List (1 .. Arg_Len);
630 Gprname : String_Access :=
631 Locate_Exec_On_Path (Exec_Name => "gprname");
632 Success : Boolean;
633
634 begin
635 if Gprname /= null then
636 for J in 1 .. Argument_Count loop
637 Args (J) := new String'(Argument (J));
638 end loop;
639
640 -- Add the target if there is one
641
642 if Target /= null then
643 Args (Args'Last) := new String'("--target=" & Target.all);
644 end if;
645
646 Spawn (Gprname.all, Args, Success);
647
648 Free (Gprname);
649
650 if Success then
651 Exit_Program (E_Success);
652 end if;
653 end if;
654 end;
655 end;
656 end if;
657
658 -- This only happens if gprname is not found or if the invocation of
659 -- gprname did not succeed.
660
661 if Create_Project then
662 Write_Line
663 ("warning: gnatname -P is obsolete and will not be available in the" &
664 " next release; use gprname instead");
665 end if;
666
667 -- If no Ada or foreign pattern was specified, print the usage and return
668
669 if Patterns.Last (Arguments.Table (Arguments.Last).Name_Patterns) = 0
670 and then
671 Patterns.Last (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0
672 then
673 if Argument_Count = 0 then
674 Usage;
675 elsif not Usage_Output then
676 Try_Help;
677 end if;
678
679 return;
680 end if;
681
682 -- If no source directory was specified, use the current directory as the
683 -- unique directory. Note that if a file was specified with directory
684 -- information, the current directory is the directory of the specified
685 -- file.
686
687 if Patterns.Last (Arguments.Table (Arguments.Last).Directories) = 0 then
688 Patterns.Append
689 (Arguments.Table (Arguments.Last).Directories, new String'("."));
690 end if;
691
692 -- Initialize
693
694 declare
695 Prep_Switches : Argument_List
696 (1 .. Integer (Preprocessor_Switches.Last));
697
698 begin
699 for Index in Prep_Switches'Range loop
700 Prep_Switches (Index) := Preprocessor_Switches.Table (Index);
701 end loop;
702
703 Prj.Makr.Initialize
704 (File_Path => File_Path.all,
705 Project_File => Create_Project,
706 Preproc_Switches => Prep_Switches,
707 Very_Verbose => Very_Verbose,
708 Flags => Gnatmake_Flags);
709 end;
710
711 -- Process each section successively
712
713 for J in 1 .. Arguments.Last loop
714 declare
715 Directories : Argument_List
716 (1 .. Integer
717 (Patterns.Last (Arguments.Table (J).Directories)));
718 Name_Patterns : Prj.Makr.Regexp_List
719 (1 .. Integer
720 (Patterns.Last (Arguments.Table (J).Name_Patterns)));
721 Excl_Patterns : Prj.Makr.Regexp_List
722 (1 .. Integer
723 (Patterns.Last (Arguments.Table (J).Excluded_Patterns)));
724 Frgn_Patterns : Prj.Makr.Regexp_List
725 (1 .. Integer
726 (Patterns.Last (Arguments.Table (J).Foreign_Patterns)));
727
728 begin
729 -- Build the Directories and Patterns arguments
730
731 for Index in Directories'Range loop
732 Directories (Index) :=
733 Arguments.Table (J).Directories.Table (Index);
734 end loop;
735
736 for Index in Name_Patterns'Range loop
737 Name_Patterns (Index) :=
738 Compile
739 (Arguments.Table (J).Name_Patterns.Table (Index).all,
740 Glob => True);
741 end loop;
742
743 for Index in Excl_Patterns'Range loop
744 Excl_Patterns (Index) :=
745 Compile
746 (Arguments.Table (J).Excluded_Patterns.Table (Index).all,
747 Glob => True);
748 end loop;
749
750 for Index in Frgn_Patterns'Range loop
751 Frgn_Patterns (Index) :=
752 Compile
753 (Arguments.Table (J).Foreign_Patterns.Table (Index).all,
754 Glob => True);
755 end loop;
756
757 -- Call Prj.Makr.Process where the real work is done
758
759 Prj.Makr.Process
760 (Directories => Directories,
761 Name_Patterns => Name_Patterns,
762 Excluded_Patterns => Excl_Patterns,
763 Foreign_Patterns => Frgn_Patterns);
764 end;
765 end loop;
766
767 -- Finalize
768
769 Prj.Makr.Finalize;
770
771 if Opt.Verbose_Mode then
772 Write_Eol;
773 end if;
774 end Gnatname;