?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge from mainline (167278:168000).
[official-gcc/graphite-test-results.git] / gcc / ada / makeutl.adb
blob1ac84a2b3f894f920392f24404d8214c5136026d
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- M A K E U T L --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2010, 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 Debug;
28 with Fname;
29 with Hostparm;
30 with Osint; use Osint;
31 with Output; use Output;
32 with Opt; use Opt;
33 with Prj.Ext;
34 with Prj.Util;
35 with Snames; use Snames;
36 with Table;
37 with Tempdir;
38
39 with Ada.Command_Line; use Ada.Command_Line;
40
41 with GNAT.Case_Util; use GNAT.Case_Util;
42 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
43 with GNAT.HTable;
44
45 package body Makeutl is
46
47 type Mark_Key is record
48 File : File_Name_Type;
49 Index : Int;
50 end record;
51 -- Identify either a mono-unit source (when Index = 0) or a specific unit
52 -- (index = 1's origin index of unit) in a multi-unit source.
53
54 -- There follow many global undocumented declarations, comments needed ???
55
56 Max_Mask_Num : constant := 2048;
57
58 subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1;
59
60 function Hash (Key : Mark_Key) return Mark_Num;
61
62 package Marks is new GNAT.HTable.Simple_HTable
63 (Header_Num => Mark_Num,
64 Element => Boolean,
65 No_Element => False,
66 Key => Mark_Key,
67 Hash => Hash,
68 Equal => "=");
69 -- A hash table to keep tracks of the marked units
70
71 type Linker_Options_Data is record
72 Project : Project_Id;
73 Options : String_List_Id;
74 end record;
75
76 Linker_Option_Initial_Count : constant := 20;
77
78 Linker_Options_Buffer : String_List_Access :=
79 new String_List (1 .. Linker_Option_Initial_Count);
80
81 Last_Linker_Option : Natural := 0;
82
83 package Linker_Opts is new Table.Table (
84 Table_Component_Type => Linker_Options_Data,
85 Table_Index_Type => Integer,
86 Table_Low_Bound => 1,
87 Table_Initial => 10,
88 Table_Increment => 100,
89 Table_Name => "Make.Linker_Opts");
90
91 procedure Add_Linker_Option (Option : String);
92
93 ---------
94 -- Add --
95 ---------
96
97 procedure Add
98 (Option : String_Access;
99 To : in out String_List_Access;
100 Last : in out Natural)
101 is
102 begin
103 if Last = To'Last then
104 declare
105 New_Options : constant String_List_Access :=
106 new String_List (1 .. To'Last * 2);
107
108 begin
109 New_Options (To'Range) := To.all;
110
111 -- Set all elements of the original options to null to avoid
112 -- deallocation of copies.
113
114 To.all := (others => null);
115
116 Free (To);
117 To := New_Options;
118 end;
119 end if;
120
121 Last := Last + 1;
122 To (Last) := Option;
123 end Add;
124
125 procedure Add
126 (Option : String;
127 To : in out String_List_Access;
128 Last : in out Natural)
129 is
130 begin
131 Add (Option => new String'(Option), To => To, Last => Last);
132 end Add;
133
134 -----------------------
135 -- Add_Linker_Option --
136 -----------------------
137
138 procedure Add_Linker_Option (Option : String) is
139 begin
140 if Option'Length > 0 then
141 if Last_Linker_Option = Linker_Options_Buffer'Last then
142 declare
143 New_Buffer : constant String_List_Access :=
144 new String_List
145 (1 .. Linker_Options_Buffer'Last +
146 Linker_Option_Initial_Count);
147 begin
148 New_Buffer (Linker_Options_Buffer'Range) :=
149 Linker_Options_Buffer.all;
150 Linker_Options_Buffer.all := (others => null);
151 Free (Linker_Options_Buffer);
152 Linker_Options_Buffer := New_Buffer;
153 end;
154 end if;
155
156 Last_Linker_Option := Last_Linker_Option + 1;
157 Linker_Options_Buffer (Last_Linker_Option) := new String'(Option);
158 end if;
159 end Add_Linker_Option;
160
161 -------------------------
162 -- Base_Name_Index_For --
163 -------------------------
164
165 function Base_Name_Index_For
166 (Main : String;
167 Main_Index : Int;
168 Index_Separator : Character) return File_Name_Type
169 is
170 Result : File_Name_Type;
171
172 begin
173 Name_Len := 0;
174 Add_Str_To_Name_Buffer (Base_Name (Main));
175
176 -- Remove the extension, if any, that is the last part of the base name
177 -- starting with a dot and following some characters.
178
179 for J in reverse 2 .. Name_Len loop
180 if Name_Buffer (J) = '.' then
181 Name_Len := J - 1;
182 exit;
183 end if;
184 end loop;
185
186 -- Add the index info, if index is different from 0
187
188 if Main_Index > 0 then
189 Add_Char_To_Name_Buffer (Index_Separator);
190
191 declare
192 Img : constant String := Main_Index'Img;
193 begin
194 Add_Str_To_Name_Buffer (Img (2 .. Img'Last));
195 end;
196 end if;
197
198 Result := Name_Find;
199 return Result;
200 end Base_Name_Index_For;
201
202 ------------------------------
203 -- Check_Source_Info_In_ALI --
204 ------------------------------
205
206 function Check_Source_Info_In_ALI
207 (The_ALI : ALI_Id;
208 Tree : Project_Tree_Ref) return Boolean
209 is
210 Unit_Name : Name_Id;
211
212 begin
213 -- Loop through units
214
215 for U in ALIs.Table (The_ALI).First_Unit ..
216 ALIs.Table (The_ALI).Last_Unit
217 loop
218 -- Check if the file name is one of the source of the unit
219
220 Get_Name_String (Units.Table (U).Uname);
221 Name_Len := Name_Len - 2;
222 Unit_Name := Name_Find;
223
224 if File_Not_A_Source_Of (Unit_Name, Units.Table (U).Sfile) then
225 return False;
226 end if;
227
228 -- Loop to do same check for each of the withed units
229
230 for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
231 declare
232 WR : ALI.With_Record renames Withs.Table (W);
233
234 begin
235 if WR.Sfile /= No_File then
236 Get_Name_String (WR.Uname);
237 Name_Len := Name_Len - 2;
238 Unit_Name := Name_Find;
239
240 if File_Not_A_Source_Of (Unit_Name, WR.Sfile) then
241 return False;
242 end if;
243 end if;
244 end;
245 end loop;
246 end loop;
247
248 -- Loop to check subunits and replaced sources
249
250 for D in ALIs.Table (The_ALI).First_Sdep ..
251 ALIs.Table (The_ALI).Last_Sdep
252 loop
253 declare
254 SD : Sdep_Record renames Sdep.Table (D);
255
256 begin
257 Unit_Name := SD.Subunit_Name;
258
259 if Unit_Name = No_Name then
260 -- Check if this source file has been replaced by a source with
261 -- a different file name.
262
263 if Tree /= null and then Tree.Replaced_Source_Number > 0 then
264 declare
265 Replacement : constant File_Name_Type :=
266 Replaced_Source_HTable.Get
267 (Tree.Replaced_Sources, SD.Sfile);
268
269 begin
270 if Replacement /= No_File then
271 if Verbose_Mode then
272 Write_Line
273 ("source file" &
274 Get_Name_String (SD.Sfile) &
275 " has been replaced by " &
276 Get_Name_String (Replacement));
277 end if;
278
279 return False;
280 end if;
281 end;
282 end if;
283
284 else
285 -- For separates, the file is no longer associated with the
286 -- unit ("proc-sep.adb" is not associated with unit "proc.sep")
287 -- so we need to check whether the source file still exists in
288 -- the source tree: it will if it matches the naming scheme
289 -- (and then will be for the same unit).
290
291 if Find_Source
292 (In_Tree => Project_Tree,
293 Project => No_Project,
294 Base_Name => SD.Sfile) = No_Source
295 then
296 -- If this is not a runtime file or if, when gnatmake switch
297 -- -a is used, we are not able to find this subunit in the
298 -- source directories, then recompilation is needed.
299
300 if not Fname.Is_Internal_File_Name (SD.Sfile)
301 or else
302 (Check_Readonly_Files
303 and then Full_Source_Name (SD.Sfile) = No_File)
304 then
305 if Verbose_Mode then
306 Write_Line
307 ("While parsing ALI file, file "
308 & Get_Name_String (SD.Sfile)
309 & " is indicated as containing subunit "
310 & Get_Name_String (Unit_Name)
311 & " but this does not match what was found while"
312 & " parsing the project. Will recompile");
313 end if;
314
315 return False;
316 end if;
317 end if;
318 end if;
319 end;
320 end loop;
321
322 return True;
323 end Check_Source_Info_In_ALI;
324
325 --------------------------------
326 -- Create_Binder_Mapping_File --
327 --------------------------------
328
329 function Create_Binder_Mapping_File return Path_Name_Type is
330 Mapping_Path : Path_Name_Type := No_Path;
331
332 Mapping_FD : File_Descriptor := Invalid_FD;
333 -- A File Descriptor for an eventual mapping file
334
335 ALI_Unit : Unit_Name_Type := No_Unit_Name;
336 -- The unit name of an ALI file
337
338 ALI_Name : File_Name_Type := No_File;
339 -- The file name of the ALI file
340
341 ALI_Project : Project_Id := No_Project;
342 -- The project of the ALI file
343
344 Bytes : Integer;
345 OK : Boolean := False;
346 Unit : Unit_Index;
347
348 Status : Boolean;
349 -- For call to Close
350
351 begin
352 Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path);
353 Record_Temp_File (Project_Tree, Mapping_Path);
354
355 if Mapping_FD /= Invalid_FD then
356 OK := True;
357
358 -- Traverse all units
359
360 Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
361 while Unit /= No_Unit_Index loop
362 if Unit.Name /= No_Name then
363
364 -- If there is a body, put it in the mapping
365
366 if Unit.File_Names (Impl) /= No_Source
367 and then Unit.File_Names (Impl).Project /= No_Project
368 then
369 Get_Name_String (Unit.Name);
370 Add_Str_To_Name_Buffer ("%b");
371 ALI_Unit := Name_Find;
372 ALI_Name :=
373 Lib_File_Name (Unit.File_Names (Impl).Display_File);
374 ALI_Project := Unit.File_Names (Impl).Project;
375
376 -- Otherwise, if there is a spec, put it in the mapping
377
378 elsif Unit.File_Names (Spec) /= No_Source
379 and then Unit.File_Names (Spec).Project /= No_Project
380 then
381 Get_Name_String (Unit.Name);
382 Add_Str_To_Name_Buffer ("%s");
383 ALI_Unit := Name_Find;
384 ALI_Name :=
385 Lib_File_Name (Unit.File_Names (Spec).Display_File);
386 ALI_Project := Unit.File_Names (Spec).Project;
387
388 else
389 ALI_Name := No_File;
390 end if;
391
392 -- If we have something to put in the mapping then do it now.
393 -- However, if the project is extended, we don't put anything
394 -- in the mapping file, since we don't know where the ALI file
395 -- is: it might be in the extended project object directory as
396 -- well as in the extending project object directory.
397
398 if ALI_Name /= No_File
399 and then ALI_Project.Extended_By = No_Project
400 and then ALI_Project.Extends = No_Project
401 then
402 -- First check if the ALI file exists. If it does not, do
403 -- not put the unit in the mapping file.
404
405 declare
406 ALI : constant String := Get_Name_String (ALI_Name);
407
408 begin
409 -- For library projects, use the library ALI directory,
410 -- for other projects, use the object directory.
411
412 if ALI_Project.Library then
413 Get_Name_String
414 (ALI_Project.Library_ALI_Dir.Display_Name);
415 else
416 Get_Name_String
417 (ALI_Project.Object_Directory.Display_Name);
418 end if;
419
420 if not
421 Is_Directory_Separator (Name_Buffer (Name_Len))
422 then
423 Add_Char_To_Name_Buffer (Directory_Separator);
424 end if;
425
426 Add_Str_To_Name_Buffer (ALI);
427 Add_Char_To_Name_Buffer (ASCII.LF);
428
429 declare
430 ALI_Path_Name : constant String :=
431 Name_Buffer (1 .. Name_Len);
432
433 begin
434 if Is_Regular_File
435 (ALI_Path_Name (1 .. ALI_Path_Name'Last - 1))
436 then
437 -- First line is the unit name
438
439 Get_Name_String (ALI_Unit);
440 Add_Char_To_Name_Buffer (ASCII.LF);
441 Bytes :=
442 Write
443 (Mapping_FD,
444 Name_Buffer (1)'Address,
445 Name_Len);
446 OK := Bytes = Name_Len;
447
448 exit when not OK;
449
450 -- Second line it the ALI file name
451
452 Get_Name_String (ALI_Name);
453 Add_Char_To_Name_Buffer (ASCII.LF);
454 Bytes :=
455 Write
456 (Mapping_FD,
457 Name_Buffer (1)'Address,
458 Name_Len);
459 OK := (Bytes = Name_Len);
460
461 exit when not OK;
462
463 -- Third line it the ALI path name
464
465 Bytes :=
466 Write
467 (Mapping_FD,
468 ALI_Path_Name (1)'Address,
469 ALI_Path_Name'Length);
470 OK := (Bytes = ALI_Path_Name'Length);
471
472 -- If OK is False, it means we were unable to
473 -- write a line. No point in continuing with the
474 -- other units.
475
476 exit when not OK;
477 end if;
478 end;
479 end;
480 end if;
481 end if;
482
483 Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
484 end loop;
485
486 Close (Mapping_FD, Status);
487
488 OK := OK and Status;
489 end if;
490
491 -- If the creation of the mapping file was successful, we add the switch
492 -- to the arguments of gnatbind.
493
494 if OK then
495 return Mapping_Path;
496
497 else
498 return No_Path;
499 end if;
500 end Create_Binder_Mapping_File;
501
502 -----------------
503 -- Create_Name --
504 -----------------
505
506 function Create_Name (Name : String) return File_Name_Type is
507 begin
508 Name_Len := 0;
509 Add_Str_To_Name_Buffer (Name);
510 return Name_Find;
511 end Create_Name;
512
513 function Create_Name (Name : String) return Name_Id is
514 begin
515 Name_Len := 0;
516 Add_Str_To_Name_Buffer (Name);
517 return Name_Find;
518 end Create_Name;
519
520 function Create_Name (Name : String) return Path_Name_Type is
521 begin
522 Name_Len := 0;
523 Add_Str_To_Name_Buffer (Name);
524 return Name_Find;
525 end Create_Name;
526
527 ----------------------
528 -- Delete_All_Marks --
529 ----------------------
530
531 procedure Delete_All_Marks is
532 begin
533 Marks.Reset;
534 end Delete_All_Marks;
535
536 ----------------------------
537 -- Executable_Prefix_Path --
538 ----------------------------
539
540 function Executable_Prefix_Path return String is
541 Exec_Name : constant String := Command_Name;
542
543 function Get_Install_Dir (S : String) return String;
544 -- S is the executable name preceded by the absolute or relative path,
545 -- e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin"
546 -- lies (in the example "C:\usr"). If the executable is not in a "bin"
547 -- directory, return "".
548
549 ---------------------
550 -- Get_Install_Dir --
551 ---------------------
552
553 function Get_Install_Dir (S : String) return String is
554 Exec : String := S;
555 Path_Last : Integer := 0;
556
557 begin
558 for J in reverse Exec'Range loop
559 if Exec (J) = Directory_Separator then
560 Path_Last := J - 1;
561 exit;
562 end if;
563 end loop;
564
565 if Path_Last >= Exec'First + 2 then
566 To_Lower (Exec (Path_Last - 2 .. Path_Last));
567 end if;
568
569 if Path_Last < Exec'First + 2
570 or else Exec (Path_Last - 2 .. Path_Last) /= "bin"
571 or else (Path_Last - 3 >= Exec'First
572 and then Exec (Path_Last - 3) /= Directory_Separator)
573 then
574 return "";
575 end if;
576
577 return Normalize_Pathname
578 (Exec (Exec'First .. Path_Last - 4),
579 Resolve_Links => Opt.Follow_Links_For_Dirs)
580 & Directory_Separator;
581 end Get_Install_Dir;
582
583 -- Beginning of Executable_Prefix_Path
584
585 begin
586 -- For VMS, the path returned is always /gnu/
587
588 if Hostparm.OpenVMS then
589 return "/gnu/";
590 end if;
591
592 -- First determine if a path prefix was placed in front of the
593 -- executable name.
594
595 for J in reverse Exec_Name'Range loop
596 if Exec_Name (J) = Directory_Separator then
597 return Get_Install_Dir (Exec_Name);
598 end if;
599 end loop;
600
601 -- If we get here, the user has typed the executable name with no
602 -- directory prefix.
603
604 declare
605 Path : String_Access := Locate_Exec_On_Path (Exec_Name);
606 begin
607 if Path = null then
608 return "";
609 else
610 declare
611 Dir : constant String := Get_Install_Dir (Path.all);
612 begin
613 Free (Path);
614 return Dir;
615 end;
616 end if;
617 end;
618 end Executable_Prefix_Path;
619
620 --------------------------
621 -- File_Not_A_Source_Of --
622 --------------------------
623
624 function File_Not_A_Source_Of
625 (Uname : Name_Id;
626 Sfile : File_Name_Type) return Boolean
627 is
628 Unit : constant Unit_Index :=
629 Units_Htable.Get (Project_Tree.Units_HT, Uname);
630
631 At_Least_One_File : Boolean := False;
632
633 begin
634 if Unit /= No_Unit_Index then
635 for F in Unit.File_Names'Range loop
636 if Unit.File_Names (F) /= null then
637 At_Least_One_File := True;
638 if Unit.File_Names (F).File = Sfile then
639 return False;
640 end if;
641 end if;
642 end loop;
643
644 if not At_Least_One_File then
645
646 -- The unit was probably created initially for a separate unit
647 -- (which are initially created as IMPL when both suffixes are the
648 -- same). Later on, Override_Kind changed the type of the file,
649 -- and the unit is no longer valid in fact.
650
651 return False;
652 end if;
653
654 Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile));
655 return True;
656 end if;
657
658 return False;
659 end File_Not_A_Source_Of;
660
661 ----------
662 -- Hash --
663 ----------
664
665 function Hash (Key : Mark_Key) return Mark_Num is
666 begin
667 return Union_Id (Key.File) mod Max_Mask_Num;
668 end Hash;
669
670 ------------
671 -- Inform --
672 ------------
673
674 procedure Inform (N : File_Name_Type; Msg : String) is
675 begin
676 Inform (Name_Id (N), Msg);
677 end Inform;
678
679 procedure Inform (N : Name_Id := No_Name; Msg : String) is
680 begin
681 Osint.Write_Program_Name;
682
683 Write_Str (": ");
684
685 if N /= No_Name then
686 Write_Str ("""");
687
688 declare
689 Name : constant String := Get_Name_String (N);
690 begin
691 if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then
692 Write_Str (File_Name (Name));
693 else
694 Write_Str (Name);
695 end if;
696 end;
697
698 Write_Str (""" ");
699 end if;
700
701 Write_Str (Msg);
702 Write_Eol;
703 end Inform;
704
705 ----------------------------
706 -- Is_External_Assignment --
707 ----------------------------
708
709 function Is_External_Assignment
710 (Tree : Prj.Tree.Project_Node_Tree_Ref;
711 Argv : String) return Boolean
712 is
713 Start : Positive := 3;
714 Finish : Natural := Argv'Last;
715
716 pragma Assert (Argv'First = 1);
717 pragma Assert (Argv (1 .. 2) = "-X");
718
719 begin
720 if Argv'Last < 5 then
721 return False;
722
723 elsif Argv (3) = '"' then
724 if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then
725 return False;
726 else
727 Start := 4;
728 Finish := Argv'Last - 1;
729 end if;
730 end if;
731
732 return Prj.Ext.Check
733 (Tree => Tree,
734 Declaration => Argv (Start .. Finish));
735 end Is_External_Assignment;
736
737 ---------------
738 -- Is_Marked --
739 ---------------
740
741 function Is_Marked
742 (Source_File : File_Name_Type;
743 Index : Int := 0) return Boolean
744 is
745 begin
746 return Marks.Get (K => (File => Source_File, Index => Index));
747 end Is_Marked;
748
749 -----------------------------
750 -- Linker_Options_Switches --
751 -----------------------------
752
753 function Linker_Options_Switches
754 (Project : Project_Id;
755 In_Tree : Project_Tree_Ref) return String_List
756 is
757 procedure Recursive_Add (Proj : Project_Id; Dummy : in out Boolean);
758 -- The recursive routine used to add linker options
759
760 -------------------
761 -- Recursive_Add --
762 -------------------
763
764 procedure Recursive_Add (Proj : Project_Id; Dummy : in out Boolean) is
765 pragma Unreferenced (Dummy);
766
767 Linker_Package : Package_Id;
768 Options : Variable_Value;
769
770 begin
771 Linker_Package :=
772 Prj.Util.Value_Of
773 (Name => Name_Linker,
774 In_Packages => Proj.Decl.Packages,
775 In_Tree => In_Tree);
776
777 Options :=
778 Prj.Util.Value_Of
779 (Name => Name_Ada,
780 Index => 0,
781 Attribute_Or_Array_Name => Name_Linker_Options,
782 In_Package => Linker_Package,
783 In_Tree => In_Tree);
784
785 -- If attribute is present, add the project with
786 -- the attribute to table Linker_Opts.
787
788 if Options /= Nil_Variable_Value then
789 Linker_Opts.Increment_Last;
790 Linker_Opts.Table (Linker_Opts.Last) :=
791 (Project => Proj, Options => Options.Values);
792 end if;
793 end Recursive_Add;
794
795 procedure For_All_Projects is
796 new For_Every_Project_Imported (Boolean, Recursive_Add);
797
798 Dummy : Boolean := False;
799
800 -- Start of processing for Linker_Options_Switches
801
802 begin
803 Linker_Opts.Init;
804
805 For_All_Projects (Project, Dummy, Imported_First => True);
806
807 Last_Linker_Option := 0;
808
809 for Index in reverse 1 .. Linker_Opts.Last loop
810 declare
811 Options : String_List_Id;
812 Proj : constant Project_Id :=
813 Linker_Opts.Table (Index).Project;
814 Option : Name_Id;
815 Dir_Path : constant String :=
816 Get_Name_String (Proj.Directory.Name);
817
818 begin
819 Options := Linker_Opts.Table (Index).Options;
820 while Options /= Nil_String loop
821 Option := In_Tree.String_Elements.Table (Options).Value;
822 Get_Name_String (Option);
823
824 -- Do not consider empty linker options
825
826 if Name_Len /= 0 then
827 Add_Linker_Option (Name_Buffer (1 .. Name_Len));
828
829 -- Object files and -L switches specified with relative
830 -- paths must be converted to absolute paths.
831
832 Test_If_Relative_Path
833 (Switch => Linker_Options_Buffer (Last_Linker_Option),
834 Parent => Dir_Path,
835 Including_L_Switch => True);
836 end if;
837
838 Options := In_Tree.String_Elements.Table (Options).Next;
839 end loop;
840 end;
841 end loop;
842
843 return Linker_Options_Buffer (1 .. Last_Linker_Option);
844 end Linker_Options_Switches;
845
846 -----------
847 -- Mains --
848 -----------
849
850 package body Mains is
851
852 type File_And_Loc is record
853 File_Name : File_Name_Type;
854 Index : Int := 0;
855 Location : Source_Ptr := No_Location;
856 end record;
857
858 package Names is new Table.Table
859 (Table_Component_Type => File_And_Loc,
860 Table_Index_Type => Integer,
861 Table_Low_Bound => 1,
862 Table_Initial => 10,
863 Table_Increment => 100,
864 Table_Name => "Makeutl.Mains.Names");
865 -- The table that stores the mains
866
867 Current : Natural := 0;
868 -- The index of the last main retrieved from the table
869
870 --------------
871 -- Add_Main --
872 --------------
873
874 procedure Add_Main (Name : String) is
875 begin
876 Name_Len := 0;
877 Add_Str_To_Name_Buffer (Name);
878 Names.Increment_Last;
879 Names.Table (Names.Last) := (Name_Find, 0, No_Location);
880 end Add_Main;
881
882 ------------
883 -- Delete --
884 ------------
885
886 procedure Delete is
887 begin
888 Names.Set_Last (0);
889 Mains.Reset;
890 end Delete;
891
892 ---------------
893 -- Get_Index --
894 ---------------
895
896 function Get_Index return Int is
897 begin
898 if Current in Names.First .. Names.Last then
899 return Names.Table (Current).Index;
900 else
901 return 0;
902 end if;
903 end Get_Index;
904
905 ------------------
906 -- Get_Location --
907 ------------------
908
909 function Get_Location return Source_Ptr is
910 begin
911 if Current in Names.First .. Names.Last then
912 return Names.Table (Current).Location;
913 else
914 return No_Location;
915 end if;
916 end Get_Location;
917
918 ---------------
919 -- Next_Main --
920 ---------------
921
922 function Next_Main return String is
923 begin
924 if Current >= Names.Last then
925 return "";
926 else
927 Current := Current + 1;
928 return Get_Name_String (Names.Table (Current).File_Name);
929 end if;
930 end Next_Main;
931
932 ---------------------
933 -- Number_Of_Mains --
934 ---------------------
935
936 function Number_Of_Mains return Natural is
937 begin
938 return Names.Last;
939 end Number_Of_Mains;
940
941 -----------
942 -- Reset --
943 -----------
944
945 procedure Reset is
946 begin
947 Current := 0;
948 end Reset;
949
950 ---------------
951 -- Set_Index --
952 ---------------
953
954 procedure Set_Index (Index : Int) is
955 begin
956 if Names.Last > 0 then
957 Names.Table (Names.Last).Index := Index;
958 end if;
959 end Set_Index;
960
961 ------------------
962 -- Set_Location --
963 ------------------
964
965 procedure Set_Location (Location : Source_Ptr) is
966 begin
967 if Names.Last > 0 then
968 Names.Table (Names.Last).Location := Location;
969 end if;
970 end Set_Location;
971
972 -----------------
973 -- Update_Main --
974 -----------------
975
976 procedure Update_Main (Name : String) is
977 begin
978 if Current in Names.First .. Names.Last then
979 Name_Len := 0;
980 Add_Str_To_Name_Buffer (Name);
981 Names.Table (Current).File_Name := Name_Find;
982 end if;
983 end Update_Main;
984 end Mains;
985
986 ----------
987 -- Mark --
988 ----------
989
990 procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is
991 begin
992 Marks.Set (K => (File => Source_File, Index => Index), E => True);
993 end Mark;
994
995 -----------------------
996 -- Path_Or_File_Name --
997 -----------------------
998
999 function Path_Or_File_Name (Path : Path_Name_Type) return String is
1000 Path_Name : constant String := Get_Name_String (Path);
1001 begin
1002 if Debug.Debug_Flag_F then
1003 return File_Name (Path_Name);
1004 else
1005 return Path_Name;
1006 end if;
1007 end Path_Or_File_Name;
1008
1009 ---------------------------
1010 -- Test_If_Relative_Path --
1011 ---------------------------
1012
1013 procedure Test_If_Relative_Path
1014 (Switch : in out String_Access;
1015 Parent : String;
1016 Including_L_Switch : Boolean := True;
1017 Including_Non_Switch : Boolean := True;
1018 Including_RTS : Boolean := False)
1019 is
1020 begin
1021 if Switch /= null then
1022 declare
1023 Sw : String (1 .. Switch'Length);
1024 Start : Positive;
1025
1026 begin
1027 Sw := Switch.all;
1028
1029 if Sw (1) = '-' then
1030 if Sw'Length >= 3
1031 and then (Sw (2) = 'A'
1032 or else Sw (2) = 'I'
1033 or else (Including_L_Switch and then Sw (2) = 'L'))
1034 then
1035 Start := 3;
1036
1037 if Sw = "-I-" then
1038 return;
1039 end if;
1040
1041 elsif Sw'Length >= 4
1042 and then (Sw (2 .. 3) = "aL"
1043 or else Sw (2 .. 3) = "aO"
1044 or else Sw (2 .. 3) = "aI")
1045 then
1046 Start := 4;
1047
1048 elsif Including_RTS
1049 and then Sw'Length >= 7
1050 and then Sw (2 .. 6) = "-RTS="
1051 then
1052 Start := 7;
1053
1054 else
1055 return;
1056 end if;
1057
1058 -- Because relative path arguments to --RTS= may be relative
1059 -- to the search directory prefix, those relative path
1060 -- arguments are converted only when they include directory
1061 -- information.
1062
1063 if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
1064 if Parent'Length = 0 then
1065 Do_Fail
1066 ("relative search path switches ("""
1067 & Sw
1068 & """) are not allowed");
1069
1070 elsif Including_RTS then
1071 for J in Start .. Sw'Last loop
1072 if Sw (J) = Directory_Separator then
1073 Switch :=
1074 new String'
1075 (Sw (1 .. Start - 1) &
1076 Parent &
1077 Directory_Separator &
1078 Sw (Start .. Sw'Last));
1079 return;
1080 end if;
1081 end loop;
1082
1083 else
1084 Switch :=
1085 new String'
1086 (Sw (1 .. Start - 1) &
1087 Parent &
1088 Directory_Separator &
1089 Sw (Start .. Sw'Last));
1090 end if;
1091 end if;
1092
1093 elsif Including_Non_Switch then
1094 if not Is_Absolute_Path (Sw) then
1095 if Parent'Length = 0 then
1096 Do_Fail
1097 ("relative paths (""" & Sw & """) are not allowed");
1098 else
1099 Switch := new String'(Parent & Directory_Separator & Sw);
1100 end if;
1101 end if;
1102 end if;
1103 end;
1104 end if;
1105 end Test_If_Relative_Path;
1106
1107 -------------------
1108 -- Unit_Index_Of --
1109 -------------------
1110
1111 function Unit_Index_Of (ALI_File : File_Name_Type) return Int is
1112 Start : Natural;
1113 Finish : Natural;
1114 Result : Int := 0;
1115
1116 begin
1117 Get_Name_String (ALI_File);
1118
1119 -- First, find the last dot
1120
1121 Finish := Name_Len;
1122
1123 while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop
1124 Finish := Finish - 1;
1125 end loop;
1126
1127 if Finish = 1 then
1128 return 0;
1129 end if;
1130
1131 -- Now check that the dot is preceded by digits
1132
1133 Start := Finish;
1134 Finish := Finish - 1;
1135
1136 while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop
1137 Start := Start - 1;
1138 end loop;
1139
1140 -- If there are no digits, or if the digits are not preceded by the
1141 -- character that precedes a unit index, this is not the ALI file of
1142 -- a unit in a multi-unit source.
1143
1144 if Start > Finish
1145 or else Start = 1
1146 or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character
1147 then
1148 return 0;
1149 end if;
1150
1151 -- Build the index from the digit(s)
1152
1153 while Start <= Finish loop
1154 Result := Result * 10 +
1155 Character'Pos (Name_Buffer (Start)) - Character'Pos ('0');
1156 Start := Start + 1;
1157 end loop;
1158
1159 return Result;
1160 end Unit_Index_Of;
1161
1162 -----------------
1163 -- Verbose_Msg --
1164 -----------------
1165
1166 procedure Verbose_Msg
1167 (N1 : Name_Id;
1168 S1 : String;
1169 N2 : Name_Id := No_Name;
1170 S2 : String := "";
1171 Prefix : String := " -> ";
1172 Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
1173 is
1174 begin
1175 if not Opt.Verbose_Mode
1176 or else Minimum_Verbosity > Opt.Verbosity_Level
1177 then
1178 return;
1179 end if;
1180
1181 Write_Str (Prefix);
1182 Write_Str ("""");
1183 Write_Name (N1);
1184 Write_Str (""" ");
1185 Write_Str (S1);
1186
1187 if N2 /= No_Name then
1188 Write_Str (" """);
1189 Write_Name (N2);
1190 Write_Str (""" ");
1191 end if;
1192
1193 Write_Str (S2);
1194 Write_Eol;
1195 end Verbose_Msg;
1196
1197 procedure Verbose_Msg
1198 (N1 : File_Name_Type;
1199 S1 : String;
1200 N2 : File_Name_Type := No_File;
1201 S2 : String := "";
1202 Prefix : String := " -> ";
1203 Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
1204 is
1205 begin
1206 Verbose_Msg
1207 (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
1208 end Verbose_Msg;
1209
1210 end Makeutl;
GCC graphite test results