OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [makeutl.adb] - Blame information for rev 283

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.