?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
fixing pr42337
[official-gcc.git] / gcc / ada / gnatls.adb
blobb5a3f49df16fcaf1529e0bed53e5f061574195d9
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T L S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2009, 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 ALI; use ALI;
27 with ALI.Util; use ALI.Util;
28 with Binderr; use Binderr;
29 with Butil; use Butil;
30 with Csets; use Csets;
31 with Fname; use Fname;
32 with Gnatvsn; use Gnatvsn;
33 with GNAT.OS_Lib; use GNAT.OS_Lib;
34 with Namet; use Namet;
35 with Opt; use Opt;
36 with Osint; use Osint;
37 with Osint.L; use Osint.L;
38 with Output; use Output;
39 with Rident; use Rident;
40 with Sdefault;
41 with Snames;
42 with Switch; use Switch;
43 with Types; use Types;
44
45 with GNAT.Case_Util; use GNAT.Case_Util;
46
47 procedure Gnatls is
48 pragma Ident (Gnat_Static_Version_String);
49
50 Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
51 Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
52 -- Names of the env. variables that contains path name(s) of directories
53 -- where project files may reside. If GPR_PROJECT_PATH is defined, its
54 -- value is used, otherwise ADA_PROJECT_PATH is used, if defined.
55
56 -- NOTE : The following string may be used by other tools, such as GPS. So
57 -- it can only be modified if these other uses are checked and coordinated.
58
59 Project_Search_Path : constant String := "Project Search Path:";
60 -- Label displayed in verbose mode before the directories in the project
61 -- search path. Do not modify without checking NOTE above.
62
63 No_Project_Default_Dir : constant String := "-";
64
65 Max_Column : constant := 80;
66
67 No_Obj : aliased String := "<no_obj>";
68
69 type File_Status is (
70 OK, -- matching timestamp
71 Checksum_OK, -- only matching checksum
72 Not_Found, -- file not found on source PATH
73 Not_Same, -- neither checksum nor timestamp matching
74 Not_First_On_PATH); -- matching file hidden by Not_Same file on path
75
76 type Dir_Data;
77 type Dir_Ref is access Dir_Data;
78
79 type Dir_Data is record
80 Value : String_Access;
81 Next : Dir_Ref;
82 end record;
83 -- ??? comment needed
84
85 First_Source_Dir : Dir_Ref;
86 Last_Source_Dir : Dir_Ref;
87 -- The list of source directories from the command line.
88 -- These directories are added using Osint.Add_Src_Search_Dir
89 -- after those of the GNAT Project File, if any.
90
91 First_Lib_Dir : Dir_Ref;
92 Last_Lib_Dir : Dir_Ref;
93 -- The list of object directories from the command line.
94 -- These directories are added using Osint.Add_Lib_Search_Dir
95 -- after those of the GNAT Project File, if any.
96
97 Main_File : File_Name_Type;
98 Ali_File : File_Name_Type;
99 Text : Text_Buffer_Ptr;
100 Next_Arg : Positive;
101
102 Too_Long : Boolean := False;
103 -- When True, lines are too long for multi-column output and each
104 -- item of information is on a different line.
105
106 Selective_Output : Boolean := False;
107 Print_Usage : Boolean := False;
108 Print_Unit : Boolean := True;
109 Print_Source : Boolean := True;
110 Print_Object : Boolean := True;
111 -- Flags controlling the form of the output
112
113 Also_Predef : Boolean := False; -- -a
114 Dependable : Boolean := False; -- -d
115 License : Boolean := False; -- -l
116 Very_Verbose_Mode : Boolean := False; -- -V
117 -- Command line flags
118
119 Unit_Start : Integer;
120 Unit_End : Integer;
121 Source_Start : Integer;
122 Source_End : Integer;
123 Object_Start : Integer;
124 Object_End : Integer;
125 -- Various column starts and ends
126
127 Spaces : constant String (1 .. Max_Column) := (others => ' ');
128
129 RTS_Specified : String_Access := null;
130 -- Used to detect multiple use of --RTS= switch
131
132 -----------------------
133 -- Local Subprograms --
134 -----------------------
135
136 procedure Add_Lib_Dir (Dir : String);
137 -- Add an object directory in the list First_Lib_Dir-Last_Lib_Dir
138
139 procedure Add_Source_Dir (Dir : String);
140 -- Add a source directory in the list First_Source_Dir-Last_Source_Dir
141
142 procedure Find_General_Layout;
143 -- Determine the structure of the output (multi columns or not, etc)
144
145 procedure Find_Status
146 (FS : in out File_Name_Type;
147 Stamp : Time_Stamp_Type;
148 Checksum : Word;
149 Status : out File_Status);
150 -- Determine the file status (Status) of the file represented by FS
151 -- with the expected Stamp and checksum given as argument. FS will be
152 -- updated to the full file name if available.
153
154 function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id;
155 -- Give the Sdep entry corresponding to the unit U in ali record A
156
157 procedure Output_Object (O : File_Name_Type);
158 -- Print out the name of the object when requested
159
160 procedure Output_Source (Sdep_I : Sdep_Id);
161 -- Print out the name and status of the source corresponding to this
162 -- sdep entry.
163
164 procedure Output_Status (FS : File_Status; Verbose : Boolean);
165 -- Print out FS either in a coded form if verbose is false or in an
166 -- expanded form otherwise.
167
168 procedure Output_Unit (ALI : ALI_Id; U_Id : Unit_Id);
169 -- Print out information on the unit when requested
170
171 procedure Reset_Print;
172 -- Reset Print flags properly when selective output is chosen
173
174 procedure Scan_Ls_Arg (Argv : String);
175 -- Scan and process lser specific arguments. Argv is a single argument
176
177 procedure Usage;
178 -- Print usage message
179
180 procedure Output_License_Information;
181 -- Output license statement, and if not found, output reference to
182 -- COPYING.
183
184 function Image (Restriction : Restriction_Id) return String;
185 -- Returns the capitalized image of Restriction
186
187 ------------------------------------------
188 -- GNATDIST specific output subprograms --
189 ------------------------------------------
190
191 package GNATDIST is
192
193 -- Any modification to this subunit requires synchronization with the
194 -- GNATDIST sources.
195
196 procedure Output_ALI (A : ALI_Id);
197 -- Comment required saying what this routine does ???
198
199 procedure Output_No_ALI (Afile : File_Name_Type);
200 -- Comments required saying what this routine does ???
201
202 end GNATDIST;
203
204 -----------------
205 -- Add_Lib_Dir --
206 -----------------
207
208 procedure Add_Lib_Dir (Dir : String) is
209 begin
210 if First_Lib_Dir = null then
211 First_Lib_Dir :=
212 new Dir_Data'
213 (Value => new String'(Dir),
214 Next => null);
215 Last_Lib_Dir := First_Lib_Dir;
216
217 else
218 Last_Lib_Dir.Next :=
219 new Dir_Data'
220 (Value => new String'(Dir),
221 Next => null);
222 Last_Lib_Dir := Last_Lib_Dir.Next;
223 end if;
224 end Add_Lib_Dir;
225
226 -- -----------------
227 -- Add_Source_Dir --
228 --------------------
229
230 procedure Add_Source_Dir (Dir : String) is
231 begin
232 if First_Source_Dir = null then
233 First_Source_Dir :=
234 new Dir_Data'
235 (Value => new String'(Dir),
236 Next => null);
237 Last_Source_Dir := First_Source_Dir;
238
239 else
240 Last_Source_Dir.Next :=
241 new Dir_Data'
242 (Value => new String'(Dir),
243 Next => null);
244 Last_Source_Dir := Last_Source_Dir.Next;
245 end if;
246 end Add_Source_Dir;
247
248 ------------------------------
249 -- Corresponding_Sdep_Entry --
250 ------------------------------
251
252 function Corresponding_Sdep_Entry
253 (A : ALI_Id;
254 U : Unit_Id) return Sdep_Id
255 is
256 begin
257 for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop
258 if Sdep.Table (D).Sfile = Units.Table (U).Sfile then
259 return D;
260 end if;
261 end loop;
262
263 Error_Msg_Unit_1 := Units.Table (U).Uname;
264 Error_Msg_File_1 := ALIs.Table (A).Afile;
265 Write_Eol;
266 Error_Msg ("wrong ALI format, can't find dependency line for $ in {");
267 Exit_Program (E_Fatal);
268 return No_Sdep_Id;
269 end Corresponding_Sdep_Entry;
270
271 -------------------------
272 -- Find_General_Layout --
273 -------------------------
274
275 procedure Find_General_Layout is
276 Max_Unit_Length : Integer := 11;
277 Max_Src_Length : Integer := 11;
278 Max_Obj_Length : Integer := 11;
279
280 Len : Integer;
281 FS : File_Name_Type;
282
283 begin
284 -- Compute maximum of each column
285
286 for Id in ALIs.First .. ALIs.Last loop
287 Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname);
288 if Also_Predef or else not Is_Internal_Unit then
289
290 if Print_Unit then
291 Len := Name_Len - 1;
292 Max_Unit_Length := Integer'Max (Max_Unit_Length, Len);
293 end if;
294
295 if Print_Source then
296 FS := Full_Source_Name (ALIs.Table (Id).Sfile);
297
298 if FS = No_File then
299 Get_Name_String (ALIs.Table (Id).Sfile);
300 Name_Len := Name_Len + 13;
301 else
302 Get_Name_String (FS);
303 end if;
304
305 Max_Src_Length := Integer'Max (Max_Src_Length, Name_Len + 1);
306 end if;
307
308 if Print_Object then
309 if ALIs.Table (Id).No_Object then
310 Max_Obj_Length :=
311 Integer'Max (Max_Obj_Length, No_Obj'Length);
312 else
313 Get_Name_String (ALIs.Table (Id).Ofile_Full_Name);
314 Max_Obj_Length := Integer'Max (Max_Obj_Length, Name_Len + 1);
315 end if;
316 end if;
317 end if;
318 end loop;
319
320 -- Verify is output is not wider than maximum number of columns
321
322 Too_Long :=
323 Verbose_Mode
324 or else
325 (Max_Unit_Length + Max_Src_Length + Max_Obj_Length) > Max_Column;
326
327 -- Set start and end of columns
328
329 Object_Start := 1;
330 Object_End := Object_Start - 1;
331
332 if Print_Object then
333 Object_End := Object_Start + Max_Obj_Length;
334 end if;
335
336 Unit_Start := Object_End + 1;
337 Unit_End := Unit_Start - 1;
338
339 if Print_Unit then
340 Unit_End := Unit_Start + Max_Unit_Length;
341 end if;
342
343 Source_Start := Unit_End + 1;
344
345 if Source_Start > Spaces'Last then
346 Source_Start := Spaces'Last;
347 end if;
348
349 Source_End := Source_Start - 1;
350
351 if Print_Source then
352 Source_End := Source_Start + Max_Src_Length;
353 end if;
354 end Find_General_Layout;
355
356 -----------------
357 -- Find_Status --
358 -----------------
359
360 procedure Find_Status
361 (FS : in out File_Name_Type;
362 Stamp : Time_Stamp_Type;
363 Checksum : Word;
364 Status : out File_Status)
365 is
366 Tmp1 : File_Name_Type;
367 Tmp2 : File_Name_Type;
368
369 begin
370 Tmp1 := Full_Source_Name (FS);
371
372 if Tmp1 = No_File then
373 Status := Not_Found;
374
375 elsif File_Stamp (Tmp1) = Stamp then
376 FS := Tmp1;
377 Status := OK;
378
379 elsif Checksums_Match (Get_File_Checksum (FS), Checksum) then
380 FS := Tmp1;
381 Status := Checksum_OK;
382
383 else
384 Tmp2 := Matching_Full_Source_Name (FS, Stamp);
385
386 if Tmp2 = No_File then
387 Status := Not_Same;
388 FS := Tmp1;
389
390 else
391 Status := Not_First_On_PATH;
392 FS := Tmp2;
393 end if;
394 end if;
395 end Find_Status;
396
397 --------------
398 -- GNATDIST --
399 --------------
400
401 package body GNATDIST is
402
403 N_Flags : Natural;
404 N_Indents : Natural := 0;
405
406 type Token_Type is
407 (T_No_ALI,
408 T_ALI,
409 T_Unit,
410 T_With,
411 T_Source,
412 T_Afile,
413 T_Ofile,
414 T_Sfile,
415 T_Name,
416 T_Main,
417 T_Kind,
418 T_Flags,
419 T_Preelaborated,
420 T_Pure,
421 T_Has_RACW,
422 T_Remote_Types,
423 T_Shared_Passive,
424 T_RCI,
425 T_Predefined,
426 T_Internal,
427 T_Is_Generic,
428 T_Procedure,
429 T_Function,
430 T_Package,
431 T_Subprogram,
432 T_Spec,
433 T_Body);
434
435 Image : constant array (Token_Type) of String_Access :=
436 (T_No_ALI => new String'("No_ALI"),
437 T_ALI => new String'("ALI"),
438 T_Unit => new String'("Unit"),
439 T_With => new String'("With"),
440 T_Source => new String'("Source"),
441 T_Afile => new String'("Afile"),
442 T_Ofile => new String'("Ofile"),
443 T_Sfile => new String'("Sfile"),
444 T_Name => new String'("Name"),
445 T_Main => new String'("Main"),
446 T_Kind => new String'("Kind"),
447 T_Flags => new String'("Flags"),
448 T_Preelaborated => new String'("Preelaborated"),
449 T_Pure => new String'("Pure"),
450 T_Has_RACW => new String'("Has_RACW"),
451 T_Remote_Types => new String'("Remote_Types"),
452 T_Shared_Passive => new String'("Shared_Passive"),
453 T_RCI => new String'("RCI"),
454 T_Predefined => new String'("Predefined"),
455 T_Internal => new String'("Internal"),
456 T_Is_Generic => new String'("Is_Generic"),
457 T_Procedure => new String'("procedure"),
458 T_Function => new String'("function"),
459 T_Package => new String'("package"),
460 T_Subprogram => new String'("subprogram"),
461 T_Spec => new String'("spec"),
462 T_Body => new String'("body"));
463
464 procedure Output_Name (N : Name_Id);
465 -- Remove any encoding info (%b and %s) and output N
466
467 procedure Output_Afile (A : File_Name_Type);
468 procedure Output_Ofile (O : File_Name_Type);
469 procedure Output_Sfile (S : File_Name_Type);
470 -- Output various names. Check that the name is different from no name.
471 -- Otherwise, skip the output.
472
473 procedure Output_Token (T : Token_Type);
474 -- Output token using specific format. That is several indentations and:
475 --
476 -- T_No_ALI .. T_With : <token> & " =>" & NL
477 -- T_Source .. T_Kind : <token> & " => "
478 -- T_Flags : <token> & " =>"
479 -- T_Preelab .. T_Body : " " & <token>
480
481 procedure Output_Sdep (S : Sdep_Id);
482 procedure Output_Unit (U : Unit_Id);
483 procedure Output_With (W : With_Id);
484 -- Output this entry as a global section (like ALIs)
485
486 ------------------
487 -- Output_Afile --
488 ------------------
489
490 procedure Output_Afile (A : File_Name_Type) is
491 begin
492 if A /= No_File then
493 Output_Token (T_Afile);
494 Write_Name (A);
495 Write_Eol;
496 end if;
497 end Output_Afile;
498
499 ----------------
500 -- Output_ALI --
501 ----------------
502
503 procedure Output_ALI (A : ALI_Id) is
504 begin
505 Output_Token (T_ALI);
506 N_Indents := N_Indents + 1;
507
508 Output_Afile (ALIs.Table (A).Afile);
509 Output_Ofile (ALIs.Table (A).Ofile_Full_Name);
510 Output_Sfile (ALIs.Table (A).Sfile);
511
512 -- Output Main
513
514 if ALIs.Table (A).Main_Program /= None then
515 Output_Token (T_Main);
516
517 if ALIs.Table (A).Main_Program = Proc then
518 Output_Token (T_Procedure);
519 else
520 Output_Token (T_Function);
521 end if;
522
523 Write_Eol;
524 end if;
525
526 -- Output Units
527
528 for U in ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit loop
529 Output_Unit (U);
530 end loop;
531
532 -- Output Sdeps
533
534 for S in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop
535 Output_Sdep (S);
536 end loop;
537
538 N_Indents := N_Indents - 1;
539 end Output_ALI;
540
541 -------------------
542 -- Output_No_ALI --
543 -------------------
544
545 procedure Output_No_ALI (Afile : File_Name_Type) is
546 begin
547 Output_Token (T_No_ALI);
548 N_Indents := N_Indents + 1;
549 Output_Afile (Afile);
550 N_Indents := N_Indents - 1;
551 end Output_No_ALI;
552
553 -----------------
554 -- Output_Name --
555 -----------------
556
557 procedure Output_Name (N : Name_Id) is
558 begin
559 -- Remove any encoding info (%s or %b)
560
561 Get_Name_String (N);
562
563 if Name_Len > 2
564 and then Name_Buffer (Name_Len - 1) = '%'
565 then
566 Name_Len := Name_Len - 2;
567 end if;
568
569 Output_Token (T_Name);
570 Write_Str (Name_Buffer (1 .. Name_Len));
571 Write_Eol;
572 end Output_Name;
573
574 ------------------
575 -- Output_Ofile --
576 ------------------
577
578 procedure Output_Ofile (O : File_Name_Type) is
579 begin
580 if O /= No_File then
581 Output_Token (T_Ofile);
582 Write_Name (O);
583 Write_Eol;
584 end if;
585 end Output_Ofile;
586
587 -----------------
588 -- Output_Sdep --
589 -----------------
590
591 procedure Output_Sdep (S : Sdep_Id) is
592 begin
593 Output_Token (T_Source);
594 Write_Name (Sdep.Table (S).Sfile);
595 Write_Eol;
596 end Output_Sdep;
597
598 ------------------
599 -- Output_Sfile --
600 ------------------
601
602 procedure Output_Sfile (S : File_Name_Type) is
603 FS : File_Name_Type := S;
604
605 begin
606 if FS /= No_File then
607
608 -- We want to output the full source name
609
610 FS := Full_Source_Name (FS);
611
612 -- There is no full source name. This occurs for instance when a
613 -- withed unit has a spec file but no body file. This situation is
614 -- not a problem for GNATDIST since the unit may be located on a
615 -- partition we do not want to build. However, we need to locate
616 -- the spec file and to find its full source name. Replace the
617 -- body file name with the spec file name used to compile the
618 -- current unit when possible.
619
620 if FS = No_File then
621 Get_Name_String (S);
622
623 if Name_Len > 4
624 and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb"
625 then
626 Name_Buffer (Name_Len) := 's';
627 FS := Full_Source_Name (Name_Find);
628 end if;
629 end if;
630 end if;
631
632 if FS /= No_File then
633 Output_Token (T_Sfile);
634 Write_Name (FS);
635 Write_Eol;
636 end if;
637 end Output_Sfile;
638
639 ------------------
640 -- Output_Token --
641 ------------------
642
643 procedure Output_Token (T : Token_Type) is
644 begin
645 if T in T_No_ALI .. T_Flags then
646 for J in 1 .. N_Indents loop
647 Write_Str (" ");
648 end loop;
649
650 Write_Str (Image (T).all);
651
652 for J in Image (T)'Length .. 12 loop
653 Write_Char (' ');
654 end loop;
655
656 Write_Str ("=>");
657
658 if T in T_No_ALI .. T_With then
659 Write_Eol;
660 elsif T in T_Source .. T_Name then
661 Write_Char (' ');
662 end if;
663
664 elsif T in T_Preelaborated .. T_Body then
665 if T in T_Preelaborated .. T_Is_Generic then
666 if N_Flags = 0 then
667 Output_Token (T_Flags);
668 end if;
669
670 N_Flags := N_Flags + 1;
671 end if;
672
673 Write_Char (' ');
674 Write_Str (Image (T).all);
675
676 else
677 Write_Str (Image (T).all);
678 end if;
679 end Output_Token;
680
681 -----------------
682 -- Output_Unit --
683 -----------------
684
685 procedure Output_Unit (U : Unit_Id) is
686 begin
687 Output_Token (T_Unit);
688 N_Indents := N_Indents + 1;
689
690 -- Output Name
691
692 Output_Name (Name_Id (Units.Table (U).Uname));
693
694 -- Output Kind
695
696 Output_Token (T_Kind);
697
698 if Units.Table (U).Unit_Kind = 'p' then
699 Output_Token (T_Package);
700 else
701 Output_Token (T_Subprogram);
702 end if;
703
704 if Name_Buffer (Name_Len) = 's' then
705 Output_Token (T_Spec);
706 else
707 Output_Token (T_Body);
708 end if;
709
710 Write_Eol;
711
712 -- Output source file name
713
714 Output_Sfile (Units.Table (U).Sfile);
715
716 -- Output Flags
717
718 N_Flags := 0;
719
720 if Units.Table (U).Preelab then
721 Output_Token (T_Preelaborated);
722 end if;
723
724 if Units.Table (U).Pure then
725 Output_Token (T_Pure);
726 end if;
727
728 if Units.Table (U).Has_RACW then
729 Output_Token (T_Has_RACW);
730 end if;
731
732 if Units.Table (U).Remote_Types then
733 Output_Token (T_Remote_Types);
734 end if;
735
736 if Units.Table (U).Shared_Passive then
737 Output_Token (T_Shared_Passive);
738 end if;
739
740 if Units.Table (U).RCI then
741 Output_Token (T_RCI);
742 end if;
743
744 if Units.Table (U).Predefined then
745 Output_Token (T_Predefined);
746 end if;
747
748 if Units.Table (U).Internal then
749 Output_Token (T_Internal);
750 end if;
751
752 if Units.Table (U).Is_Generic then
753 Output_Token (T_Is_Generic);
754 end if;
755
756 if N_Flags > 0 then
757 Write_Eol;
758 end if;
759
760 -- Output Withs
761
762 for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
763 Output_With (W);
764 end loop;
765
766 N_Indents := N_Indents - 1;
767 end Output_Unit;
768
769 -----------------
770 -- Output_With --
771 -----------------
772
773 procedure Output_With (W : With_Id) is
774 begin
775 Output_Token (T_With);
776 N_Indents := N_Indents + 1;
777
778 Output_Name (Name_Id (Withs.Table (W).Uname));
779
780 -- Output Kind
781
782 Output_Token (T_Kind);
783
784 if Name_Buffer (Name_Len) = 's' then
785 Output_Token (T_Spec);
786 else
787 Output_Token (T_Body);
788 end if;
789
790 Write_Eol;
791
792 Output_Afile (Withs.Table (W).Afile);
793 Output_Sfile (Withs.Table (W).Sfile);
794
795 N_Indents := N_Indents - 1;
796 end Output_With;
797
798 end GNATDIST;
799
800 -----------
801 -- Image --
802 -----------
803
804 function Image (Restriction : Restriction_Id) return String is
805 Result : String := Restriction'Img;
806 Skip : Boolean := True;
807
808 begin
809 for J in Result'Range loop
810 if Skip then
811 Skip := False;
812 Result (J) := To_Upper (Result (J));
813
814 elsif Result (J) = '_' then
815 Skip := True;
816
817 else
818 Result (J) := To_Lower (Result (J));
819 end if;
820 end loop;
821
822 return Result;
823 end Image;
824
825 --------------------------------
826 -- Output_License_Information --
827 --------------------------------
828
829 procedure Output_License_Information is
830 Params_File_Name : constant String := "gnatlic.adl";
831 -- Name of license file
832
833 Lo : constant Source_Ptr := 1;
834 Hi : Source_Ptr;
835 Text : Source_Buffer_Ptr;
836
837 begin
838 Name_Len := 0;
839 Add_Str_To_Name_Buffer (Params_File_Name);
840 Read_Source_File (Name_Find, Lo, Hi, Text);
841
842 if Text /= null then
843
844 -- Omit last character (end-of-file marker) in output
845
846 Write_Str (String (Text (Lo .. Hi - 1)));
847 Write_Eol;
848
849 -- The following condition is determined at compile time: disable
850 -- "condition is always true/false" warning.
851
852 pragma Warnings (Off);
853 elsif Build_Type /= GPL and then Build_Type /= FSF then
854 pragma Warnings (On);
855
856 Write_Str ("License file missing, please contact AdaCore.");
857 Write_Eol;
858
859 else
860 Write_Str ("Please refer to file COPYING in your distribution"
861 & " for license terms.");
862 Write_Eol;
863
864 end if;
865
866 Exit_Program (E_Success);
867 end Output_License_Information;
868
869 -------------------
870 -- Output_Object --
871 -------------------
872
873 procedure Output_Object (O : File_Name_Type) is
874 Object_Name : String_Access;
875
876 begin
877 if Print_Object then
878 if O /= No_File then
879 Get_Name_String (O);
880 Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len));
881 else
882 Object_Name := No_Obj'Unchecked_Access;
883 end if;
884
885 Write_Str (Object_Name.all);
886
887 if Print_Source or else Print_Unit then
888 if Too_Long then
889 Write_Eol;
890 Write_Str (" ");
891 else
892 Write_Str (Spaces
893 (Object_Start + Object_Name'Length .. Object_End));
894 end if;
895 end if;
896 end if;
897 end Output_Object;
898
899 -------------------
900 -- Output_Source --
901 -------------------
902
903 procedure Output_Source (Sdep_I : Sdep_Id) is
904 Stamp : Time_Stamp_Type;
905 Checksum : Word;
906 FS : File_Name_Type;
907 Status : File_Status;
908 Object_Name : String_Access;
909
910 begin
911 if Sdep_I = No_Sdep_Id then
912 return;
913 end if;
914
915 Stamp := Sdep.Table (Sdep_I).Stamp;
916 Checksum := Sdep.Table (Sdep_I).Checksum;
917 FS := Sdep.Table (Sdep_I).Sfile;
918
919 if Print_Source then
920 Find_Status (FS, Stamp, Checksum, Status);
921 Get_Name_String (FS);
922
923 Object_Name := To_Host_File_Spec (Name_Buffer (1 .. Name_Len));
924
925 if Verbose_Mode then
926 Write_Str (" Source => ");
927 Write_Str (Object_Name.all);
928
929 if not Too_Long then
930 Write_Str
931 (Spaces (Source_Start + Object_Name'Length .. Source_End));
932 end if;
933
934 Output_Status (Status, Verbose => True);
935 Write_Eol;
936 Write_Str (" ");
937
938 else
939 if not Selective_Output then
940 Output_Status (Status, Verbose => False);
941 end if;
942
943 Write_Str (Object_Name.all);
944 end if;
945 end if;
946 end Output_Source;
947
948 -------------------
949 -- Output_Status --
950 -------------------
951
952 procedure Output_Status (FS : File_Status; Verbose : Boolean) is
953 begin
954 if Verbose then
955 case FS is
956 when OK =>
957 Write_Str (" unchanged");
958
959 when Checksum_OK =>
960 Write_Str (" slightly modified");
961
962 when Not_Found =>
963 Write_Str (" file not found");
964
965 when Not_Same =>
966 Write_Str (" modified");
967
968 when Not_First_On_PATH =>
969 Write_Str (" unchanged version not first on PATH");
970 end case;
971
972 else
973 case FS is
974 when OK =>
975 Write_Str (" OK ");
976
977 when Checksum_OK =>
978 Write_Str (" MOK ");
979
980 when Not_Found =>
981 Write_Str (" ??? ");
982
983 when Not_Same =>
984 Write_Str (" DIF ");
985
986 when Not_First_On_PATH =>
987 Write_Str (" HID ");
988 end case;
989 end if;
990 end Output_Status;
991
992 -----------------
993 -- Output_Unit --
994 -----------------
995
996 procedure Output_Unit (ALI : ALI_Id; U_Id : Unit_Id) is
997 Kind : Character;
998 U : Unit_Record renames Units.Table (U_Id);
999
1000 begin
1001 if Print_Unit then
1002 Get_Name_String (U.Uname);
1003 Kind := Name_Buffer (Name_Len);
1004 Name_Len := Name_Len - 2;
1005
1006 if not Verbose_Mode then
1007 Write_Str (Name_Buffer (1 .. Name_Len));
1008
1009 else
1010 Write_Str ("Unit => ");
1011 Write_Eol;
1012 Write_Str (" Name => ");
1013 Write_Str (Name_Buffer (1 .. Name_Len));
1014 Write_Eol;
1015 Write_Str (" Kind => ");
1016
1017 if Units.Table (U_Id).Unit_Kind = 'p' then
1018 Write_Str ("package ");
1019 else
1020 Write_Str ("subprogram ");
1021 end if;
1022
1023 if Kind = 's' then
1024 Write_Str ("spec");
1025 else
1026 Write_Str ("body");
1027 end if;
1028 end if;
1029
1030 if Verbose_Mode then
1031 if U.Preelab or else
1032 U.No_Elab or else
1033 U.Pure or else
1034 U.Dynamic_Elab or else
1035 U.Has_RACW or else
1036 U.Remote_Types or else
1037 U.Shared_Passive or else
1038 U.RCI or else
1039 U.Predefined or else
1040 U.Internal or else
1041 U.Is_Generic or else
1042 U.Init_Scalars or else
1043 U.SAL_Interface or else
1044 U.Body_Needed_For_SAL or else
1045 U.Elaborate_Body
1046 then
1047 Write_Eol;
1048 Write_Str (" Flags =>");
1049
1050 if U.Preelab then
1051 Write_Str (" Preelaborable");
1052 end if;
1053
1054 if U.No_Elab then
1055 Write_Str (" No_Elab_Code");
1056 end if;
1057
1058 if U.Pure then
1059 Write_Str (" Pure");
1060 end if;
1061
1062 if U.Dynamic_Elab then
1063 Write_Str (" Dynamic_Elab");
1064 end if;
1065
1066 if U.Has_RACW then
1067 Write_Str (" Has_RACW");
1068 end if;
1069
1070 if U.Remote_Types then
1071 Write_Str (" Remote_Types");
1072 end if;
1073
1074 if U.Shared_Passive then
1075 Write_Str (" Shared_Passive");
1076 end if;
1077
1078 if U.RCI then
1079 Write_Str (" RCI");
1080 end if;
1081
1082 if U.Predefined then
1083 Write_Str (" Predefined");
1084 end if;
1085
1086 if U.Internal then
1087 Write_Str (" Internal");
1088 end if;
1089
1090 if U.Is_Generic then
1091 Write_Str (" Is_Generic");
1092 end if;
1093
1094 if U.Init_Scalars then
1095 Write_Str (" Init_Scalars");
1096 end if;
1097
1098 if U.SAL_Interface then
1099 Write_Str (" SAL_Interface");
1100 end if;
1101
1102 if U.Body_Needed_For_SAL then
1103 Write_Str (" Body_Needed_For_SAL");
1104 end if;
1105
1106 if U.Elaborate_Body then
1107 Write_Str (" Elaborate Body");
1108 end if;
1109
1110 if U.Remote_Types then
1111 Write_Str (" Remote_Types");
1112 end if;
1113
1114 if U.Shared_Passive then
1115 Write_Str (" Shared_Passive");
1116 end if;
1117
1118 if U.Predefined then
1119 Write_Str (" Predefined");
1120 end if;
1121 end if;
1122
1123 declare
1124 Restrictions : constant Restrictions_Info :=
1125 ALIs.Table (ALI).Restrictions;
1126
1127 begin
1128 -- If the source was compiled with pragmas Restrictions,
1129 -- Display these restrictions.
1130
1131 if Restrictions.Set /= (All_Restrictions => False) then
1132 Write_Eol;
1133 Write_Str (" pragma Restrictions =>");
1134
1135 -- For boolean restrictions, just display the name of the
1136 -- restriction; for valued restrictions, also display the
1137 -- restriction value.
1138
1139 for Restriction in All_Restrictions loop
1140 if Restrictions.Set (Restriction) then
1141 Write_Eol;
1142 Write_Str (" ");
1143 Write_Str (Image (Restriction));
1144
1145 if Restriction in All_Parameter_Restrictions then
1146 Write_Str (" =>");
1147 Write_Str (Restrictions.Value (Restriction)'Img);
1148 end if;
1149 end if;
1150 end loop;
1151 end if;
1152
1153 -- If the unit violates some Restrictions, display the list of
1154 -- these restrictions.
1155
1156 if Restrictions.Violated /= (All_Restrictions => False) then
1157 Write_Eol;
1158 Write_Str (" Restrictions violated =>");
1159
1160 -- For boolean restrictions, just display the name of the
1161 -- restriction. For valued restrictions, also display the
1162 -- restriction value.
1163
1164 for Restriction in All_Restrictions loop
1165 if Restrictions.Violated (Restriction) then
1166 Write_Eol;
1167 Write_Str (" ");
1168 Write_Str (Image (Restriction));
1169
1170 if Restriction in All_Parameter_Restrictions then
1171 if Restrictions.Count (Restriction) > 0 then
1172 Write_Str (" =>");
1173
1174 if Restrictions.Unknown (Restriction) then
1175 Write_Str (" at least");
1176 end if;
1177
1178 Write_Str (Restrictions.Count (Restriction)'Img);
1179 end if;
1180 end if;
1181 end if;
1182 end loop;
1183 end if;
1184 end;
1185 end if;
1186
1187 if Print_Source then
1188 if Too_Long then
1189 Write_Eol;
1190 Write_Str (" ");
1191 else
1192 Write_Str (Spaces (Unit_Start + Name_Len + 1 .. Unit_End));
1193 end if;
1194 end if;
1195 end if;
1196 end Output_Unit;
1197
1198 -----------------
1199 -- Reset_Print --
1200 -----------------
1201
1202 procedure Reset_Print is
1203 begin
1204 if not Selective_Output then
1205 Selective_Output := True;
1206 Print_Source := False;
1207 Print_Object := False;
1208 Print_Unit := False;
1209 end if;
1210 end Reset_Print;
1211
1212 -------------------
1213 -- Scan_Ls_Arg --
1214 -------------------
1215
1216 procedure Scan_Ls_Arg (Argv : String) is
1217 FD : File_Descriptor;
1218 Len : Integer;
1219
1220 begin
1221 pragma Assert (Argv'First = 1);
1222
1223 if Argv'Length = 0 then
1224 return;
1225 end if;
1226
1227 if Argv (1) = '-' then
1228 if Argv'Length = 1 then
1229 Fail ("switch character cannot be followed by a blank");
1230
1231 -- Processing for -I-
1232
1233 elsif Argv (2 .. Argv'Last) = "I-" then
1234 Opt.Look_In_Primary_Dir := False;
1235
1236 -- Forbid -?- or -??- where ? is any character
1237
1238 elsif (Argv'Length = 3 and then Argv (3) = '-')
1239 or else (Argv'Length = 4 and then Argv (4) = '-')
1240 then
1241 Fail ("Trailing ""-"" at the end of " & Argv & " forbidden.");
1242
1243 -- Processing for -Idir
1244
1245 elsif Argv (2) = 'I' then
1246 Add_Source_Dir (Argv (3 .. Argv'Last));
1247 Add_Lib_Dir (Argv (3 .. Argv'Last));
1248
1249 -- Processing for -aIdir (to gcc this is like a -I switch)
1250
1251 elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aI" then
1252 Add_Source_Dir (Argv (4 .. Argv'Last));
1253
1254 -- Processing for -aOdir
1255
1256 elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aO" then
1257 Add_Lib_Dir (Argv (4 .. Argv'Last));
1258
1259 -- Processing for -aLdir (to gnatbind this is like a -aO switch)
1260
1261 elsif Argv'Length >= 3 and then Argv (2 .. 3) = "aL" then
1262 Add_Lib_Dir (Argv (4 .. Argv'Last));
1263
1264 -- Processing for -nostdinc
1265
1266 elsif Argv (2 .. Argv'Last) = "nostdinc" then
1267 Opt.No_Stdinc := True;
1268
1269 -- Processing for one character switches
1270
1271 elsif Argv'Length = 2 then
1272 case Argv (2) is
1273 when 'a' => Also_Predef := True;
1274 when 'h' => Print_Usage := True;
1275 when 'u' => Reset_Print; Print_Unit := True;
1276 when 's' => Reset_Print; Print_Source := True;
1277 when 'o' => Reset_Print; Print_Object := True;
1278 when 'v' => Verbose_Mode := True;
1279 when 'd' => Dependable := True;
1280 when 'l' => License := True;
1281 when 'V' => Very_Verbose_Mode := True;
1282
1283 when others => null;
1284 end case;
1285
1286 -- Processing for -files=file
1287
1288 elsif Argv'Length > 7 and then Argv (1 .. 7) = "-files=" then
1289 FD := Open_Read (Argv (8 .. Argv'Last), GNAT.OS_Lib.Text);
1290
1291 if FD = Invalid_FD then
1292 Osint.Fail ("could not find text file """ &
1293 Argv (8 .. Argv'Last) & '"');
1294 end if;
1295
1296 Len := Integer (File_Length (FD));
1297
1298 declare
1299 Buffer : String (1 .. Len + 1);
1300 Index : Positive := 1;
1301 Last : Positive;
1302
1303 begin
1304 -- Read the file
1305
1306 Len := Read (FD, Buffer (1)'Address, Len);
1307 Buffer (Buffer'Last) := ASCII.NUL;
1308 Close (FD);
1309
1310 -- Scan the file line by line
1311
1312 while Index < Buffer'Last loop
1313
1314 -- Find the end of line
1315
1316 Last := Index;
1317 while Last <= Buffer'Last
1318 and then Buffer (Last) /= ASCII.LF
1319 and then Buffer (Last) /= ASCII.CR
1320 loop
1321 Last := Last + 1;
1322 end loop;
1323
1324 -- Ignore empty lines
1325
1326 if Last > Index then
1327 Add_File (Buffer (Index .. Last - 1));
1328 end if;
1329
1330 -- Find the beginning of the next line
1331
1332 Index := Last;
1333 while Buffer (Index) = ASCII.CR or else
1334 Buffer (Index) = ASCII.LF
1335 loop
1336 Index := Index + 1;
1337 end loop;
1338 end loop;
1339 end;
1340
1341 -- Processing for --RTS=path
1342
1343 elsif Argv'Length >= 5 and then Argv (1 .. 5) = "--RTS" then
1344 if Argv'Length <= 6 or else Argv (6) /= '='then
1345 Osint.Fail ("missing path for --RTS");
1346
1347 else
1348 -- Check that it is the first time we see this switch or, if
1349 -- it is not the first time, the same path is specified.
1350
1351 if RTS_Specified = null then
1352 RTS_Specified := new String'(Argv (7 .. Argv'Last));
1353
1354 elsif RTS_Specified.all /= Argv (7 .. Argv'Last) then
1355 Osint.Fail ("--RTS cannot be specified multiple times");
1356 end if;
1357
1358 -- Valid --RTS switch
1359
1360 Opt.No_Stdinc := True;
1361 Opt.RTS_Switch := True;
1362
1363 declare
1364 Src_Path_Name : constant String_Ptr :=
1365 String_Ptr
1366 (Get_RTS_Search_Dir
1367 (Argv (7 .. Argv'Last), Include));
1368 Lib_Path_Name : constant String_Ptr :=
1369 String_Ptr
1370 (Get_RTS_Search_Dir
1371 (Argv (7 .. Argv'Last), Objects));
1372
1373 begin
1374 if Src_Path_Name /= null
1375 and then Lib_Path_Name /= null
1376 then
1377 Add_Search_Dirs (Src_Path_Name, Include);
1378 Add_Search_Dirs (Lib_Path_Name, Objects);
1379
1380 elsif Src_Path_Name = null
1381 and then Lib_Path_Name = null
1382 then
1383 Osint.Fail ("RTS path not valid: missing " &
1384 "adainclude and adalib directories");
1385
1386 elsif Src_Path_Name = null then
1387 Osint.Fail ("RTS path not valid: missing " &
1388 "adainclude directory");
1389
1390 elsif Lib_Path_Name = null then
1391 Osint.Fail ("RTS path not valid: missing " &
1392 "adalib directory");
1393 end if;
1394 end;
1395 end if;
1396 end if;
1397
1398 -- If not a switch, it must be a file name
1399
1400 else
1401 Add_File (Argv);
1402 end if;
1403 end Scan_Ls_Arg;
1404
1405 -----------
1406 -- Usage --
1407 -----------
1408
1409 procedure Usage is
1410 begin
1411 -- Usage line
1412
1413 Write_Str ("Usage: ");
1414 Osint.Write_Program_Name;
1415 Write_Str (" switches [list of object files]");
1416 Write_Eol;
1417 Write_Eol;
1418
1419 -- GNATLS switches
1420
1421 Write_Str ("switches:");
1422 Write_Eol;
1423
1424 -- Line for -a
1425
1426 Write_Str (" -a also output relevant predefined units");
1427 Write_Eol;
1428
1429 -- Line for -u
1430
1431 Write_Str (" -u output only relevant unit names");
1432 Write_Eol;
1433
1434 -- Line for -h
1435
1436 Write_Str (" -h output this help message");
1437 Write_Eol;
1438
1439 -- Line for -s
1440
1441 Write_Str (" -s output only relevant source names");
1442 Write_Eol;
1443
1444 -- Line for -o
1445
1446 Write_Str (" -o output only relevant object names");
1447 Write_Eol;
1448
1449 -- Line for -d
1450
1451 Write_Str (" -d output sources on which specified units " &
1452 "depend");
1453 Write_Eol;
1454
1455 -- Line for -l
1456
1457 Write_Str (" -l output license information");
1458 Write_Eol;
1459
1460 -- Line for -v
1461
1462 Write_Str (" -v verbose output, full path and unit " &
1463 "information");
1464 Write_Eol;
1465 Write_Eol;
1466
1467 -- Line for -files=
1468
1469 Write_Str (" -files=fil files are listed in text file 'fil'");
1470 Write_Eol;
1471
1472 -- Line for -aI switch
1473
1474 Write_Str (" -aIdir specify source files search path");
1475 Write_Eol;
1476
1477 -- Line for -aO switch
1478
1479 Write_Str (" -aOdir specify object files search path");
1480 Write_Eol;
1481
1482 -- Line for -I switch
1483
1484 Write_Str (" -Idir like -aIdir -aOdir");
1485 Write_Eol;
1486
1487 -- Line for -I- switch
1488
1489 Write_Str (" -I- do not look for sources & object files");
1490 Write_Str (" in the default directory");
1491 Write_Eol;
1492
1493 -- Line for -nostdinc
1494
1495 Write_Str (" -nostdinc do not look for source files");
1496 Write_Str (" in the system default directory");
1497 Write_Eol;
1498
1499 -- Line for --RTS
1500
1501 Write_Str (" --RTS=dir specify the default source and object search"
1502 & " path");
1503 Write_Eol;
1504
1505 -- File Status explanation
1506
1507 Write_Eol;
1508 Write_Str (" file status can be:");
1509 Write_Eol;
1510
1511 for ST in File_Status loop
1512 Write_Str (" ");
1513 Output_Status (ST, Verbose => False);
1514 Write_Str (" ==> ");
1515 Output_Status (ST, Verbose => True);
1516 Write_Eol;
1517 end loop;
1518 end Usage;
1519
1520 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
1521
1522 -- Start of processing for Gnatls
1523
1524 begin
1525 -- Initialize standard packages
1526
1527 Namet.Initialize;
1528 Csets.Initialize;
1529 Snames.Initialize;
1530
1531 -- First check for --version or --help
1532
1533 Check_Version_And_Help ("GNATLS", "1997");
1534
1535 -- Loop to scan out arguments
1536
1537 Next_Arg := 1;
1538 Scan_Args : while Next_Arg < Arg_Count loop
1539 declare
1540 Next_Argv : String (1 .. Len_Arg (Next_Arg));
1541 begin
1542 Fill_Arg (Next_Argv'Address, Next_Arg);
1543 Scan_Ls_Arg (Next_Argv);
1544 end;
1545
1546 Next_Arg := Next_Arg + 1;
1547 end loop Scan_Args;
1548
1549 -- If -l (output license information) is given, it must be the only switch
1550
1551 if License and then Arg_Count /= 2 then
1552 Write_Str ("Can't use -l with another switch");
1553 Write_Eol;
1554 Usage;
1555 Exit_Program (E_Fatal);
1556 end if;
1557
1558 -- Add the source and object directories specified on the command line, if
1559 -- any, to the searched directories.
1560
1561 while First_Source_Dir /= null loop
1562 Add_Src_Search_Dir (First_Source_Dir.Value.all);
1563 First_Source_Dir := First_Source_Dir.Next;
1564 end loop;
1565
1566 while First_Lib_Dir /= null loop
1567 Add_Lib_Search_Dir (First_Lib_Dir.Value.all);
1568 First_Lib_Dir := First_Lib_Dir.Next;
1569 end loop;
1570
1571 -- Finally, add the default directories and obtain target parameters
1572
1573 Osint.Add_Default_Search_Dirs;
1574
1575 if Verbose_Mode then
1576 Write_Eol;
1577 Display_Version ("GNATLS", "1997");
1578 Write_Eol;
1579 Write_Str ("Source Search Path:");
1580 Write_Eol;
1581
1582 for J in 1 .. Nb_Dir_In_Src_Search_Path loop
1583 Write_Str (" ");
1584
1585 if Dir_In_Src_Search_Path (J)'Length = 0 then
1586 Write_Str ("<Current_Directory>");
1587 else
1588 Write_Str (To_Host_Dir_Spec
1589 (Dir_In_Src_Search_Path (J).all, True).all);
1590 end if;
1591
1592 Write_Eol;
1593 end loop;
1594
1595 Write_Eol;
1596 Write_Eol;
1597 Write_Str ("Object Search Path:");
1598 Write_Eol;
1599
1600 for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
1601 Write_Str (" ");
1602
1603 if Dir_In_Obj_Search_Path (J)'Length = 0 then
1604 Write_Str ("<Current_Directory>");
1605 else
1606 Write_Str (To_Host_Dir_Spec
1607 (Dir_In_Obj_Search_Path (J).all, True).all);
1608 end if;
1609
1610 Write_Eol;
1611 end loop;
1612
1613 Write_Eol;
1614 Write_Eol;
1615 Write_Str (Project_Search_Path);
1616 Write_Eol;
1617 Write_Str (" <Current_Directory>");
1618 Write_Eol;
1619
1620 declare
1621 Project_Path : String_Access := Getenv (Gpr_Project_Path);
1622
1623 Lib : constant String :=
1624 Directory_Separator & "lib" & Directory_Separator;
1625
1626 First : Natural;
1627 Last : Natural;
1628
1629 Add_Default_Dir : Boolean := True;
1630
1631 begin
1632 -- If there is a project path, display each directory in the path
1633
1634 if Project_Path.all = "" then
1635 Project_Path := Getenv (Ada_Project_Path);
1636 end if;
1637
1638 if Project_Path.all /= "" then
1639 First := Project_Path'First;
1640 loop
1641 while First <= Project_Path'Last
1642 and then (Project_Path (First) = Path_Separator)
1643 loop
1644 First := First + 1;
1645 end loop;
1646
1647 exit when First > Project_Path'Last;
1648
1649 Last := First;
1650 while Last < Project_Path'Last
1651 and then Project_Path (Last + 1) /= Path_Separator
1652 loop
1653 Last := Last + 1;
1654 end loop;
1655
1656 -- If the directory is No_Default_Project_Dir, set
1657 -- Add_Default_Dir to False.
1658
1659 if Project_Path (First .. Last) = No_Project_Default_Dir then
1660 Add_Default_Dir := False;
1661
1662 elsif First /= Last or else Project_Path (First) /= '.' then
1663
1664 -- If the directory is ".", skip it as it is the current
1665 -- directory and it is already the first directory in the
1666 -- project path.
1667
1668 Write_Str (" ");
1669 Write_Str
1670 (To_Host_Dir_Spec
1671 (Project_Path (First .. Last), True).all);
1672 Write_Eol;
1673 end if;
1674
1675 First := Last + 1;
1676 end loop;
1677 end if;
1678
1679 -- Add the default dir, except if "-" was one of the "directories"
1680 -- specified in ADA_PROJECT_DIR.
1681
1682 if Add_Default_Dir then
1683 Name_Len := 0;
1684 Add_Str_To_Name_Buffer (Sdefault.Search_Dir_Prefix.all);
1685
1686 -- On Windows, make sure that all directory separators are '\'
1687
1688 if Directory_Separator /= '/' then
1689 for J in 1 .. Name_Len loop
1690 if Name_Buffer (J) = '/' then
1691 Name_Buffer (J) := Directory_Separator;
1692 end if;
1693 end loop;
1694 end if;
1695
1696 -- Find the sequence "/lib/"
1697
1698 while Name_Len >= Lib'Length
1699 and then Name_Buffer (Name_Len - 4 .. Name_Len) /= Lib
1700 loop
1701 Name_Len := Name_Len - 1;
1702 end loop;
1703
1704 -- If the sequence "/lib"/ was found, display the default
1705 -- directory <prefix>/lib/gnat/.
1706
1707 if Name_Len >= 5 then
1708 Name_Buffer (Name_Len + 1 .. Name_Len + 4) := "gnat";
1709 Name_Buffer (Name_Len + 5) := Directory_Separator;
1710 Name_Len := Name_Len + 5;
1711 Write_Str (" ");
1712 Write_Line
1713 (To_Host_Dir_Spec (Name_Buffer (1 .. Name_Len), True).all);
1714 end if;
1715 end if;
1716 end;
1717
1718 Write_Eol;
1719 end if;
1720
1721 -- Output usage information when requested
1722
1723 if Print_Usage then
1724 Usage;
1725 end if;
1726
1727 -- Output license information when requested
1728
1729 if License then
1730 Output_License_Information;
1731 Exit_Program (E_Success);
1732 end if;
1733
1734 if not More_Lib_Files then
1735 if not Print_Usage and then not Verbose_Mode then
1736 Usage;
1737 end if;
1738
1739 Exit_Program (E_Fatal);
1740 end if;
1741
1742 Initialize_ALI;
1743 Initialize_ALI_Source;
1744
1745 -- Print out all library for which no ALI files can be located
1746
1747 while More_Lib_Files loop
1748 Main_File := Next_Main_Lib_File;
1749 Ali_File := Full_Lib_File_Name (Lib_File_Name (Main_File));
1750
1751 if Ali_File = No_File then
1752 if Very_Verbose_Mode then
1753 GNATDIST.Output_No_ALI (Lib_File_Name (Main_File));
1754
1755 else
1756 Write_Str ("Can't find library info for ");
1757 Get_Name_String (Main_File);
1758 Write_Char ('"'); -- "
1759 Write_Str (Name_Buffer (1 .. Name_Len));
1760 Write_Char ('"'); -- "
1761 Write_Eol;
1762 end if;
1763
1764 else
1765 Ali_File := Strip_Directory (Ali_File);
1766
1767 if Get_Name_Table_Info (Ali_File) = 0 then
1768 Text := Read_Library_Info (Ali_File, True);
1769
1770 declare
1771 Discard : ALI_Id;
1772 pragma Unreferenced (Discard);
1773 begin
1774 Discard :=
1775 Scan_ALI
1776 (Ali_File,
1777 Text,
1778 Ignore_ED => False,
1779 Err => False,
1780 Ignore_Errors => True);
1781 end;
1782
1783 Free (Text);
1784 end if;
1785 end if;
1786 end loop;
1787
1788 if Very_Verbose_Mode then
1789 for A in ALIs.First .. ALIs.Last loop
1790 GNATDIST.Output_ALI (A);
1791 end loop;
1792
1793 return;
1794 end if;
1795
1796 Find_General_Layout;
1797
1798 for Id in ALIs.First .. ALIs.Last loop
1799 declare
1800 Last_U : Unit_Id;
1801
1802 begin
1803 Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname);
1804
1805 if Also_Predef or else not Is_Internal_Unit then
1806 if ALIs.Table (Id).No_Object then
1807 Output_Object (No_File);
1808 else
1809 Output_Object (ALIs.Table (Id).Ofile_Full_Name);
1810 end if;
1811
1812 -- In verbose mode print all main units in the ALI file, otherwise
1813 -- just print the first one to ease columnwise printout
1814
1815 if Verbose_Mode then
1816 Last_U := ALIs.Table (Id).Last_Unit;
1817 else
1818 Last_U := ALIs.Table (Id).First_Unit;
1819 end if;
1820
1821 for U in ALIs.Table (Id).First_Unit .. Last_U loop
1822 if U /= ALIs.Table (Id).First_Unit
1823 and then Selective_Output
1824 and then Print_Unit
1825 then
1826 Write_Eol;
1827 end if;
1828
1829 Output_Unit (Id, U);
1830
1831 -- Output source now, unless if it will be done as part of
1832 -- outputing dependencies.
1833
1834 if not (Dependable and then Print_Source) then
1835 Output_Source (Corresponding_Sdep_Entry (Id, U));
1836 end if;
1837 end loop;
1838
1839 -- Print out list of units on which this unit depends (D lines)
1840
1841 if Dependable and then Print_Source then
1842 if Verbose_Mode then
1843 Write_Str ("depends upon");
1844 Write_Eol;
1845 Write_Str (" ");
1846 else
1847 Write_Eol;
1848 end if;
1849
1850 for D in
1851 ALIs.Table (Id).First_Sdep .. ALIs.Table (Id).Last_Sdep
1852 loop
1853 if Also_Predef
1854 or else not Is_Internal_File_Name (Sdep.Table (D).Sfile)
1855 then
1856 if Verbose_Mode then
1857 Write_Str (" ");
1858 Output_Source (D);
1859
1860 elsif Too_Long then
1861 Write_Str (" ");
1862 Output_Source (D);
1863 Write_Eol;
1864
1865 else
1866 Write_Str (Spaces (1 .. Source_Start - 2));
1867 Output_Source (D);
1868 Write_Eol;
1869 end if;
1870 end if;
1871 end loop;
1872 end if;
1873
1874 Write_Eol;
1875 end if;
1876 end;
1877 end loop;
1878
1879 -- All done. Set proper exit status
1880
1881 Namet.Finalize;
1882 Exit_Program (E_Success);
1883 end Gnatls;
Mirror of the offical gcc git repository hosted at gcc.gnu.org