OSDN Git Service

2009-07-28 Emmanuel Briot <briot@adacore.com>
[pf3gnuchains/gcc-fork.git] / gcc / ada / makeutl.adb
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-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 Debug;
27 with Osint;    use Osint;
28 with Output;   use Output;
29 with Opt;      use Opt;
30 with Prj.Ext;
31 with Prj.Util;
32 with Snames;   use Snames;
33 with Table;
34
35 with Ada.Command_Line;  use Ada.Command_Line;
36
37 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
38
39 with System.Case_Util; use System.Case_Util;
40 with System.HTable;
41
42 package body Makeutl is
43
44    type Mark_Key is record
45       File  : File_Name_Type;
46       Index : Int;
47    end record;
48    --  Identify either a mono-unit source (when Index = 0) or a specific unit
49    --  (index = 1's origin index of unit) in a multi-unit source.
50
51    --  There follow many global undocumented declarations, comments needed ???
52
53    Max_Mask_Num : constant := 2048;
54
55    subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1;
56
57    function Hash (Key : Mark_Key) return Mark_Num;
58
59    package Marks is new System.HTable.Simple_HTable
60      (Header_Num => Mark_Num,
61       Element    => Boolean,
62       No_Element => False,
63       Key        => Mark_Key,
64       Hash       => Hash,
65       Equal      => "=");
66    --  A hash table to keep tracks of the marked units
67
68    type Linker_Options_Data is record
69       Project : Project_Id;
70       Options : String_List_Id;
71    end record;
72
73    Linker_Option_Initial_Count : constant := 20;
74
75    Linker_Options_Buffer : String_List_Access :=
76      new String_List (1 .. Linker_Option_Initial_Count);
77
78    Last_Linker_Option : Natural := 0;
79
80    package Linker_Opts is new Table.Table (
81      Table_Component_Type => Linker_Options_Data,
82      Table_Index_Type     => Integer,
83      Table_Low_Bound      => 1,
84      Table_Initial        => 10,
85      Table_Increment      => 100,
86      Table_Name           => "Make.Linker_Opts");
87
88    procedure Add_Linker_Option (Option : String);
89
90    ---------
91    -- Add --
92    ---------
93
94    procedure Add
95      (Option : String_Access;
96       To     : in out String_List_Access;
97       Last   : in out Natural)
98    is
99    begin
100       if Last = To'Last then
101          declare
102             New_Options : constant String_List_Access :=
103                             new String_List (1 .. To'Last * 2);
104
105          begin
106             New_Options (To'Range) := To.all;
107
108             --  Set all elements of the original options to null to avoid
109             --  deallocation of copies.
110
111             To.all := (others => null);
112
113             Free (To);
114             To := New_Options;
115          end;
116       end if;
117
118       Last := Last + 1;
119       To (Last) := Option;
120    end Add;
121
122    procedure Add
123      (Option : String;
124       To     : in out String_List_Access;
125       Last   : in out Natural)
126    is
127    begin
128       Add (Option => new String'(Option), To => To, Last => Last);
129    end Add;
130
131    -----------------------
132    -- Add_Linker_Option --
133    -----------------------
134
135    procedure Add_Linker_Option (Option : String) is
136    begin
137       if Option'Length > 0 then
138          if Last_Linker_Option = Linker_Options_Buffer'Last then
139             declare
140                New_Buffer : constant String_List_Access :=
141                               new String_List
142                                 (1 .. Linker_Options_Buffer'Last +
143                                         Linker_Option_Initial_Count);
144             begin
145                New_Buffer (Linker_Options_Buffer'Range) :=
146                  Linker_Options_Buffer.all;
147                Linker_Options_Buffer.all := (others => null);
148                Free (Linker_Options_Buffer);
149                Linker_Options_Buffer := New_Buffer;
150             end;
151          end if;
152
153          Last_Linker_Option := Last_Linker_Option + 1;
154          Linker_Options_Buffer (Last_Linker_Option) := new String'(Option);
155       end if;
156    end Add_Linker_Option;
157
158    -----------------
159    -- Create_Name --
160    -----------------
161
162    function Create_Name (Name : String) return File_Name_Type is
163    begin
164       Name_Len := 0;
165       Add_Str_To_Name_Buffer (Name);
166       return Name_Find;
167    end Create_Name;
168
169    function Create_Name (Name : String) return Name_Id is
170    begin
171       Name_Len := 0;
172       Add_Str_To_Name_Buffer (Name);
173       return Name_Find;
174    end Create_Name;
175
176    function Create_Name (Name : String) return Path_Name_Type is
177    begin
178       Name_Len := 0;
179       Add_Str_To_Name_Buffer (Name);
180       return Name_Find;
181    end Create_Name;
182
183    ----------------------
184    -- Delete_All_Marks --
185    ----------------------
186
187    procedure Delete_All_Marks is
188    begin
189       Marks.Reset;
190    end Delete_All_Marks;
191
192    ----------------------------
193    -- Executable_Prefix_Path --
194    ----------------------------
195
196    function Executable_Prefix_Path return String is
197       Exec_Name : constant String := Command_Name;
198
199       function Get_Install_Dir (S : String) return String;
200       --  S is the executable name preceded by the absolute or relative path,
201       --  e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin"
202       --  lies (in the example "C:\usr"). If the executable is not in a "bin"
203       --  directory, return "".
204
205       ---------------------
206       -- Get_Install_Dir --
207       ---------------------
208
209       function Get_Install_Dir (S : String) return String is
210          Exec      : String  := S;
211          Path_Last : Integer := 0;
212
213       begin
214          for J in reverse Exec'Range loop
215             if Exec (J) = Directory_Separator then
216                Path_Last := J - 1;
217                exit;
218             end if;
219          end loop;
220
221          if Path_Last >= Exec'First + 2 then
222             To_Lower (Exec (Path_Last - 2 .. Path_Last));
223          end if;
224
225          if Path_Last < Exec'First + 2
226            or else Exec (Path_Last - 2 .. Path_Last) /= "bin"
227            or else (Path_Last - 3 >= Exec'First
228                      and then Exec (Path_Last - 3) /= Directory_Separator)
229          then
230             return "";
231          end if;
232
233          return Normalize_Pathname (Exec (Exec'First .. Path_Last - 4))
234            & Directory_Separator;
235       end Get_Install_Dir;
236
237    --  Beginning of Executable_Prefix_Path
238
239    begin
240       --  First determine if a path prefix was placed in front of the
241       --  executable name.
242
243       for J in reverse Exec_Name'Range loop
244          if Exec_Name (J) = Directory_Separator then
245             return Get_Install_Dir (Exec_Name);
246          end if;
247       end loop;
248
249       --  If we get here, the user has typed the executable name with no
250       --  directory prefix.
251
252       declare
253          Path : String_Access := Locate_Exec_On_Path (Exec_Name);
254       begin
255          if Path = null then
256             return "";
257          else
258             declare
259                Dir : constant String := Get_Install_Dir (Path.all);
260             begin
261                Free (Path);
262                return Dir;
263             end;
264          end if;
265       end;
266    end Executable_Prefix_Path;
267
268    --------------------------
269    -- File_Not_A_Source_Of --
270    --------------------------
271
272    function File_Not_A_Source_Of
273      (Uname : Name_Id;
274       Sfile : File_Name_Type) return Boolean
275    is
276       Unit : constant Unit_Index :=
277                Units_Htable.Get (Project_Tree.Units_HT, Uname);
278
279       At_Least_One_File : Boolean := False;
280
281    begin
282       if Unit /= No_Unit_Index then
283          for F in Unit.File_Names'Range loop
284             if Unit.File_Names (F) /= null then
285                At_Least_One_File := True;
286                if Unit.File_Names (F).File = Sfile then
287                   return False;
288                end if;
289             end if;
290          end loop;
291
292          if not At_Least_One_File then
293
294             --  The unit was probably created initially for a separate unit
295             --  (which are initially created as IMPL when both suffixes are the
296             --  same). Later on, Override_Kind changed the type of the file,
297             --  and the unit is no longer valid in fact.
298
299             return False;
300          end if;
301
302          Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile));
303          return True;
304       end if;
305
306       return False;
307    end File_Not_A_Source_Of;
308
309    ----------
310    -- Hash --
311    ----------
312
313    function Hash (Key : Mark_Key) return Mark_Num is
314    begin
315       return Union_Id (Key.File) mod Max_Mask_Num;
316    end Hash;
317
318    ------------
319    -- Inform --
320    ------------
321
322    procedure Inform (N : File_Name_Type; Msg : String) is
323    begin
324       Inform (Name_Id (N), Msg);
325    end Inform;
326
327    procedure Inform (N : Name_Id := No_Name; Msg : String) is
328    begin
329       Osint.Write_Program_Name;
330
331       Write_Str (": ");
332
333       if N /= No_Name then
334          Write_Str ("""");
335
336          declare
337             Name : constant String := Get_Name_String (N);
338          begin
339             if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then
340                Write_Str (File_Name (Name));
341             else
342                Write_Str (Name);
343             end if;
344          end;
345
346          Write_Str (""" ");
347       end if;
348
349       Write_Str (Msg);
350       Write_Eol;
351    end Inform;
352
353    ----------------------------
354    -- Is_External_Assignment --
355    ----------------------------
356
357    function Is_External_Assignment (Argv : String) return Boolean is
358       Start     : Positive := 3;
359       Finish    : Natural := Argv'Last;
360       Equal_Pos : Natural;
361
362       pragma Assert (Argv'First = 1);
363       pragma Assert (Argv (1 .. 2) = "-X");
364
365    begin
366       if Argv'Last < 5 then
367          return False;
368
369       elsif Argv (3) = '"' then
370          if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then
371             return False;
372          else
373             Start := 4;
374             Finish := Argv'Last - 1;
375          end if;
376       end if;
377
378       Equal_Pos := Start;
379
380       while Equal_Pos <= Finish and then Argv (Equal_Pos) /= '=' loop
381          Equal_Pos := Equal_Pos + 1;
382       end loop;
383
384       if Equal_Pos = Start or else Equal_Pos > Finish then
385          return False;
386       else
387          Prj.Ext.Add
388            (External_Name => Argv (Start .. Equal_Pos - 1),
389             Value         => Argv (Equal_Pos + 1 .. Finish));
390          return True;
391       end if;
392    end Is_External_Assignment;
393
394    ---------------
395    -- Is_Marked --
396    ---------------
397
398    function Is_Marked
399      (Source_File : File_Name_Type;
400       Index       : Int := 0) return Boolean
401    is
402    begin
403       return Marks.Get (K => (File => Source_File, Index => Index));
404    end Is_Marked;
405
406    -----------------------------
407    -- Linker_Options_Switches --
408    -----------------------------
409
410    function Linker_Options_Switches
411      (Project  : Project_Id;
412       In_Tree  : Project_Tree_Ref) return String_List
413    is
414       procedure Recursive_Add (Proj : Project_Id; Dummy : in out Boolean);
415       --  The recursive routine used to add linker options
416
417       -------------------
418       -- Recursive_Add --
419       -------------------
420
421       procedure Recursive_Add (Proj : Project_Id; Dummy : in out Boolean) is
422          pragma Unreferenced (Dummy);
423
424          Linker_Package : Package_Id;
425          Options        : Variable_Value;
426
427       begin
428          Linker_Package :=
429            Prj.Util.Value_Of
430              (Name        => Name_Linker,
431               In_Packages => Proj.Decl.Packages,
432               In_Tree     => In_Tree);
433
434          Options :=
435            Prj.Util.Value_Of
436              (Name                    => Name_Ada,
437               Index                   => 0,
438               Attribute_Or_Array_Name => Name_Linker_Options,
439               In_Package              => Linker_Package,
440               In_Tree                 => In_Tree);
441
442          --  If attribute is present, add the project with
443          --  the attribute to table Linker_Opts.
444
445          if Options /= Nil_Variable_Value then
446             Linker_Opts.Increment_Last;
447             Linker_Opts.Table (Linker_Opts.Last) :=
448               (Project => Proj, Options => Options.Values);
449          end if;
450       end Recursive_Add;
451
452       procedure For_All_Projects is
453         new For_Every_Project_Imported (Boolean, Recursive_Add);
454
455       Dummy : Boolean := False;
456
457    --  Start of processing for Linker_Options_Switches
458
459    begin
460       Linker_Opts.Init;
461
462       For_All_Projects (Project, Dummy, Imported_First => True);
463
464       Last_Linker_Option := 0;
465
466       for Index in reverse 1 .. Linker_Opts.Last loop
467          declare
468             Options : String_List_Id;
469             Proj    : constant Project_Id :=
470                         Linker_Opts.Table (Index).Project;
471             Option  : Name_Id;
472             Dir_Path : constant String :=
473                          Get_Name_String (Proj.Directory.Name);
474
475          begin
476             Options := Linker_Opts.Table (Index).Options;
477             while Options /= Nil_String loop
478                Option := In_Tree.String_Elements.Table (Options).Value;
479                Get_Name_String (Option);
480
481                --  Do not consider empty linker options
482
483                if Name_Len /= 0 then
484                   Add_Linker_Option (Name_Buffer (1 .. Name_Len));
485
486                   --  Object files and -L switches specified with relative
487                   --  paths must be converted to absolute paths.
488
489                   Test_If_Relative_Path
490                     (Switch => Linker_Options_Buffer (Last_Linker_Option),
491                      Parent => Dir_Path,
492                      Including_L_Switch => True);
493                end if;
494
495                Options := In_Tree.String_Elements.Table (Options).Next;
496             end loop;
497          end;
498       end loop;
499
500       return Linker_Options_Buffer (1 .. Last_Linker_Option);
501    end Linker_Options_Switches;
502
503    -----------
504    -- Mains --
505    -----------
506
507    package body Mains is
508
509       type File_And_Loc is record
510          File_Name : File_Name_Type;
511          Location  : Source_Ptr := No_Location;
512       end record;
513
514       package Names is new Table.Table
515         (Table_Component_Type => File_And_Loc,
516          Table_Index_Type     => Integer,
517          Table_Low_Bound      => 1,
518          Table_Initial        => 10,
519          Table_Increment      => 100,
520          Table_Name           => "Makeutl.Mains.Names");
521       --  The table that stores the mains
522
523       Current : Natural := 0;
524       --  The index of the last main retrieved from the table
525
526       --------------
527       -- Add_Main --
528       --------------
529
530       procedure Add_Main (Name : String) is
531       begin
532          Name_Len := 0;
533          Add_Str_To_Name_Buffer (Name);
534          Names.Increment_Last;
535          Names.Table (Names.Last) := (Name_Find, No_Location);
536       end Add_Main;
537
538       ------------
539       -- Delete --
540       ------------
541
542       procedure Delete is
543       begin
544          Names.Set_Last (0);
545          Mains.Reset;
546       end Delete;
547
548       ------------------
549       -- Get_Location --
550       ------------------
551
552       function Get_Location return Source_Ptr is
553       begin
554          if Current in Names.First .. Names.Last then
555             return Names.Table (Current).Location;
556          else
557             return No_Location;
558          end if;
559       end Get_Location;
560
561       ---------------
562       -- Next_Main --
563       ---------------
564
565       function Next_Main return String is
566       begin
567          if Current >= Names.Last then
568             return "";
569          else
570             Current := Current + 1;
571             return Get_Name_String (Names.Table (Current).File_Name);
572          end if;
573       end Next_Main;
574
575       ---------------------
576       -- Number_Of_Mains --
577       ---------------------
578
579       function Number_Of_Mains return Natural is
580       begin
581          return Names.Last;
582       end Number_Of_Mains;
583
584       -----------
585       -- Reset --
586       -----------
587
588       procedure Reset is
589       begin
590          Current := 0;
591       end Reset;
592
593       ------------------
594       -- Set_Location --
595       ------------------
596
597       procedure Set_Location (Location : Source_Ptr) is
598       begin
599          if Names.Last > 0 then
600             Names.Table (Names.Last).Location := Location;
601          end if;
602       end Set_Location;
603
604       -----------------
605       -- Update_Main --
606       -----------------
607
608       procedure Update_Main (Name : String) is
609       begin
610          if Current in Names.First .. Names.Last then
611             Name_Len := 0;
612             Add_Str_To_Name_Buffer (Name);
613             Names.Table (Current).File_Name := Name_Find;
614          end if;
615       end Update_Main;
616    end Mains;
617
618    ----------
619    -- Mark --
620    ----------
621
622    procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is
623    begin
624       Marks.Set (K => (File => Source_File, Index => Index), E => True);
625    end Mark;
626
627    -----------------------
628    -- Path_Or_File_Name --
629    -----------------------
630
631    function Path_Or_File_Name (Path : Path_Name_Type) return String is
632       Path_Name : constant String := Get_Name_String (Path);
633    begin
634       if Debug.Debug_Flag_F then
635          return File_Name (Path_Name);
636       else
637          return Path_Name;
638       end if;
639    end Path_Or_File_Name;
640
641    ---------------------------
642    -- Test_If_Relative_Path --
643    ---------------------------
644
645    procedure Test_If_Relative_Path
646      (Switch               : in out String_Access;
647       Parent               : String;
648       Including_L_Switch   : Boolean := True;
649       Including_Non_Switch : Boolean := True;
650       Including_RTS        : Boolean := False)
651    is
652    begin
653       if Switch /= null then
654          declare
655             Sw    : String (1 .. Switch'Length);
656             Start : Positive;
657
658          begin
659             Sw := Switch.all;
660
661             if Sw (1) = '-' then
662                if Sw'Length >= 3
663                  and then (Sw (2) = 'A'
664                             or else Sw (2) = 'I'
665                             or else (Including_L_Switch and then Sw (2) = 'L'))
666                then
667                   Start := 3;
668
669                   if Sw = "-I-" then
670                      return;
671                   end if;
672
673                elsif Sw'Length >= 4
674                  and then (Sw (2 .. 3) = "aL"
675                             or else Sw (2 .. 3) = "aO"
676                             or else Sw (2 .. 3) = "aI")
677                then
678                   Start := 4;
679
680                elsif Including_RTS
681                  and then Sw'Length >= 7
682                  and then Sw (2 .. 6) = "-RTS="
683                then
684                   Start := 7;
685
686                else
687                   return;
688                end if;
689
690                --  Because relative path arguments to --RTS= may be relative
691                --  to the search directory prefix, those relative path
692                --  arguments are converted only when they include directory
693                --  information.
694
695                if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
696                   if Parent'Length = 0 then
697                      Do_Fail
698                        ("relative search path switches ("""
699                         & Sw
700                         & """) are not allowed");
701
702                   elsif Including_RTS then
703                      for J in Start .. Sw'Last loop
704                         if Sw (J) = Directory_Separator then
705                            Switch :=
706                              new String'
707                                (Sw (1 .. Start - 1) &
708                                 Parent &
709                                 Directory_Separator &
710                                 Sw (Start .. Sw'Last));
711                            return;
712                         end if;
713                      end loop;
714
715                   else
716                      Switch :=
717                        new String'
718                          (Sw (1 .. Start - 1) &
719                           Parent &
720                           Directory_Separator &
721                           Sw (Start .. Sw'Last));
722                   end if;
723                end if;
724
725             elsif Including_Non_Switch then
726                if not Is_Absolute_Path (Sw) then
727                   if Parent'Length = 0 then
728                      Do_Fail
729                        ("relative paths (""" & Sw & """) are not allowed");
730                   else
731                      Switch := new String'(Parent & Directory_Separator & Sw);
732                   end if;
733                end if;
734             end if;
735          end;
736       end if;
737    end Test_If_Relative_Path;
738
739    -------------------
740    -- Unit_Index_Of --
741    -------------------
742
743    function Unit_Index_Of (ALI_File : File_Name_Type) return Int is
744       Start  : Natural;
745       Finish : Natural;
746       Result : Int := 0;
747
748    begin
749       Get_Name_String (ALI_File);
750
751       --  First, find the last dot
752
753       Finish := Name_Len;
754
755       while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop
756          Finish := Finish - 1;
757       end loop;
758
759       if Finish = 1 then
760          return 0;
761       end if;
762
763       --  Now check that the dot is preceded by digits
764
765       Start := Finish;
766       Finish := Finish - 1;
767
768       while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop
769          Start := Start - 1;
770       end loop;
771
772       --  If there are no digits, or if the digits are not preceded by the
773       --  character that precedes a unit index, this is not the ALI file of
774       --  a unit in a multi-unit source.
775
776       if Start > Finish
777         or else Start = 1
778         or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character
779       then
780          return 0;
781       end if;
782
783       --  Build the index from the digit(s)
784
785       while Start <= Finish loop
786          Result := Result * 10 +
787                      Character'Pos (Name_Buffer (Start)) - Character'Pos ('0');
788          Start := Start + 1;
789       end loop;
790
791       return Result;
792    end Unit_Index_Of;
793
794    -----------------
795    -- Verbose_Msg --
796    -----------------
797
798    procedure Verbose_Msg
799      (N1                : Name_Id;
800       S1                : String;
801       N2                : Name_Id := No_Name;
802       S2                : String  := "";
803       Prefix            : String := "  -> ";
804       Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
805    is
806    begin
807       if not Opt.Verbose_Mode
808         or else Minimum_Verbosity > Opt.Verbosity_Level
809       then
810          return;
811       end if;
812
813       Write_Str (Prefix);
814       Write_Str ("""");
815       Write_Name (N1);
816       Write_Str (""" ");
817       Write_Str (S1);
818
819       if N2 /= No_Name then
820          Write_Str (" """);
821          Write_Name (N2);
822          Write_Str (""" ");
823       end if;
824
825       Write_Str (S2);
826       Write_Eol;
827    end Verbose_Msg;
828
829    procedure Verbose_Msg
830      (N1                : File_Name_Type;
831       S1                : String;
832       N2                : File_Name_Type := No_File;
833       S2                : String  := "";
834       Prefix            : String := "  -> ";
835       Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
836    is
837    begin
838       Verbose_Msg
839         (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
840    end Verbose_Msg;
841
842 end Makeutl;