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/] [prj-env.adb] - Blame information for rev 461

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
--                              P R J . E N V                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2001-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 Fmap;
27
with Opt;
28
with Osint;    use Osint;
29
with Output;   use Output;
30
with Prj.Com;  use Prj.Com;
31
with Tempdir;
32
 
33
package body Prj.Env is
34
 
35
   Buffer_Initial : constant := 1_000;
36
   --  Initial size of Buffer
37
 
38
   -----------------------
39
   -- Local Subprograms --
40
   -----------------------
41
 
42
   package Source_Path_Table is new GNAT.Dynamic_Tables
43
     (Table_Component_Type => Name_Id,
44
      Table_Index_Type     => Natural,
45
      Table_Low_Bound      => 1,
46
      Table_Initial        => 50,
47
      Table_Increment      => 100);
48
   --  A table to store the source dirs before creating the source path file
49
 
50
   package Object_Path_Table is new GNAT.Dynamic_Tables
51
     (Table_Component_Type => Path_Name_Type,
52
      Table_Index_Type     => Natural,
53
      Table_Low_Bound      => 1,
54
      Table_Initial        => 50,
55
      Table_Increment      => 100);
56
   --  A table to store the object dirs, before creating the object path file
57
 
58
   procedure Add_To_Buffer
59
     (S           : String;
60
      Buffer      : in out String_Access;
61
      Buffer_Last : in out Natural);
62
   --  Add a string to Buffer, extending Buffer if needed
63
 
64
   procedure Add_To_Path
65
     (Source_Dirs : String_List_Id;
66
      In_Tree     : Project_Tree_Ref;
67
      Buffer      : in out String_Access;
68
      Buffer_Last : in out Natural);
69
   --  Add to Ada_Path_Buffer all the source directories in string list
70
   --  Source_Dirs, if any.
71
 
72
   procedure Add_To_Path
73
     (Dir         : String;
74
      Buffer      : in out String_Access;
75
      Buffer_Last : in out Natural);
76
   --  If Dir is not already in the global variable Ada_Path_Buffer, add it.
77
   --  If Buffer_Last /= 0, prepend a Path_Separator character to Path.
78
 
79
   procedure Add_To_Source_Path
80
     (Source_Dirs  : String_List_Id;
81
      In_Tree      : Project_Tree_Ref;
82
      Source_Paths : in out Source_Path_Table.Instance);
83
   --  Add to Ada_Path_B all the source directories in string list
84
   --  Source_Dirs, if any. Increment Ada_Path_Length.
85
 
86
   procedure Add_To_Object_Path
87
     (Object_Dir   : Path_Name_Type;
88
      Object_Paths : in out Object_Path_Table.Instance);
89
   --  Add Object_Dir to object path table. Make sure it is not duplicate
90
   --  and it is the last one in the current table.
91
 
92
   procedure Set_Path_File_Var (Name : String; Value : String);
93
   --  Call Setenv, after calling To_Host_File_Spec
94
 
95
   function Ultimate_Extension_Of
96
     (Project : Project_Id) return Project_Id;
97
   --  Return a project that is either Project or an extended ancestor of
98
   --  Project that itself is not extended.
99
 
100
   ----------------------
101
   -- Ada_Include_Path --
102
   ----------------------
103
 
104
   function Ada_Include_Path
105
     (Project   : Project_Id;
106
      In_Tree   : Project_Tree_Ref;
107
      Recursive : Boolean := False) return String
108
   is
109
      Buffer      : String_Access;
110
      Buffer_Last : Natural := 0;
111
 
112
      procedure Add (Project : Project_Id; Dummy : in out Boolean);
113
      --  Add source dirs of Project to the path
114
 
115
      ---------
116
      -- Add --
117
      ---------
118
 
119
      procedure Add (Project : Project_Id; Dummy : in out Boolean) is
120
         pragma Unreferenced (Dummy);
121
      begin
122
         Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
123
      end Add;
124
 
125
      procedure For_All_Projects is
126
        new For_Every_Project_Imported (Boolean, Add);
127
 
128
      Dummy : Boolean := False;
129
 
130
   --  Start of processing for Ada_Include_Path
131
 
132
   begin
133
      if Recursive then
134
 
135
         --  If it is the first time we call this function for
136
         --  this project, compute the source path
137
 
138
         if Project.Ada_Include_Path = null then
139
            Buffer := new String (1 .. 4096);
140
            For_All_Projects (Project, Dummy);
141
            Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last));
142
            Free (Buffer);
143
         end if;
144
 
145
         return Project.Ada_Include_Path.all;
146
 
147
      else
148
         Buffer := new String (1 .. 4096);
149
         Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
150
 
151
         declare
152
            Result : constant String := Buffer (1 .. Buffer_Last);
153
         begin
154
            Free (Buffer);
155
            return Result;
156
         end;
157
      end if;
158
   end Ada_Include_Path;
159
 
160
   ----------------------
161
   -- Ada_Objects_Path --
162
   ----------------------
163
 
164
   function Ada_Objects_Path
165
     (Project             : Project_Id;
166
      Including_Libraries : Boolean := True) return String_Access
167
   is
168
      Buffer      : String_Access;
169
      Buffer_Last : Natural := 0;
170
 
171
      procedure Add (Project : Project_Id; Dummy : in out Boolean);
172
      --  Add all the object directories of a project to the path
173
 
174
      ---------
175
      -- Add --
176
      ---------
177
 
178
      procedure Add (Project : Project_Id; Dummy : in out Boolean) is
179
         pragma Unreferenced (Dummy);
180
         Path : constant Path_Name_Type :=
181
                  Get_Object_Directory
182
                    (Project,
183
                     Including_Libraries => Including_Libraries,
184
                     Only_If_Ada         => False);
185
      begin
186
         if Path /= No_Path then
187
            Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last);
188
         end if;
189
      end Add;
190
 
191
      procedure For_All_Projects is
192
        new For_Every_Project_Imported (Boolean, Add);
193
 
194
      Dummy : Boolean := False;
195
 
196
   --  Start of processing for Ada_Objects_Path
197
 
198
   begin
199
      --  If it is the first time we call this function for
200
      --  this project, compute the objects path
201
 
202
      if Project.Ada_Objects_Path = null then
203
         Buffer := new String (1 .. 4096);
204
         For_All_Projects (Project, Dummy);
205
 
206
         Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last));
207
         Free (Buffer);
208
      end if;
209
 
210
      return Project.Ada_Objects_Path;
211
   end Ada_Objects_Path;
212
 
213
   -------------------
214
   -- Add_To_Buffer --
215
   -------------------
216
 
217
   procedure Add_To_Buffer
218
     (S           : String;
219
      Buffer      : in out String_Access;
220
      Buffer_Last : in out Natural)
221
   is
222
      Last : constant Natural := Buffer_Last + S'Length;
223
 
224
   begin
225
      while Last > Buffer'Last loop
226
         declare
227
            New_Buffer : constant String_Access :=
228
                           new String (1 .. 2 * Buffer'Last);
229
         begin
230
            New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
231
            Free (Buffer);
232
            Buffer := New_Buffer;
233
         end;
234
      end loop;
235
 
236
      Buffer (Buffer_Last + 1 .. Last) := S;
237
      Buffer_Last := Last;
238
   end Add_To_Buffer;
239
 
240
   ------------------------
241
   -- Add_To_Object_Path --
242
   ------------------------
243
 
244
   procedure Add_To_Object_Path
245
     (Object_Dir   : Path_Name_Type;
246
      Object_Paths : in out Object_Path_Table.Instance)
247
   is
248
   begin
249
      --  Check if the directory is already in the table
250
 
251
      for Index in Object_Path_Table.First ..
252
                   Object_Path_Table.Last (Object_Paths)
253
      loop
254
 
255
         --  If it is, remove it, and add it as the last one
256
 
257
         if Object_Paths.Table (Index) = Object_Dir then
258
            for Index2 in Index + 1 ..
259
                          Object_Path_Table.Last (Object_Paths)
260
            loop
261
               Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2);
262
            end loop;
263
 
264
            Object_Paths.Table
265
              (Object_Path_Table.Last (Object_Paths)) := Object_Dir;
266
            return;
267
         end if;
268
      end loop;
269
 
270
      --  The directory is not already in the table, add it
271
 
272
      Object_Path_Table.Append (Object_Paths, Object_Dir);
273
   end Add_To_Object_Path;
274
 
275
   -----------------
276
   -- Add_To_Path --
277
   -----------------
278
 
279
   procedure Add_To_Path
280
     (Source_Dirs : String_List_Id;
281
      In_Tree     : Project_Tree_Ref;
282
      Buffer      : in out String_Access;
283
      Buffer_Last : in out Natural)
284
   is
285
      Current    : String_List_Id := Source_Dirs;
286
      Source_Dir : String_Element;
287
   begin
288
      while Current /= Nil_String loop
289
         Source_Dir := In_Tree.String_Elements.Table (Current);
290
         Add_To_Path (Get_Name_String (Source_Dir.Display_Value),
291
                      Buffer, Buffer_Last);
292
         Current := Source_Dir.Next;
293
      end loop;
294
   end Add_To_Path;
295
 
296
   procedure Add_To_Path
297
     (Dir         : String;
298
      Buffer      : in out String_Access;
299
      Buffer_Last : in out Natural)
300
   is
301
      Len        : Natural;
302
      New_Buffer : String_Access;
303
      Min_Len    : Natural;
304
 
305
      function Is_Present (Path : String; Dir : String) return Boolean;
306
      --  Return True if Dir is part of Path
307
 
308
      ----------------
309
      -- Is_Present --
310
      ----------------
311
 
312
      function Is_Present (Path : String; Dir : String) return Boolean is
313
         Last : constant Integer := Path'Last - Dir'Length + 1;
314
 
315
      begin
316
         for J in Path'First .. Last loop
317
 
318
            --  Note: the order of the conditions below is important, since
319
            --  it ensures a minimal number of string comparisons.
320
 
321
            if (J = Path'First
322
                or else Path (J - 1) = Path_Separator)
323
              and then
324
                (J + Dir'Length > Path'Last
325
                 or else Path (J + Dir'Length) = Path_Separator)
326
              and then Dir = Path (J .. J + Dir'Length - 1)
327
            then
328
               return True;
329
            end if;
330
         end loop;
331
 
332
         return False;
333
      end Is_Present;
334
 
335
   --  Start of processing for Add_To_Path
336
 
337
   begin
338
      if Is_Present (Buffer (1 .. Buffer_Last), Dir) then
339
 
340
         --  Dir is already in the path, nothing to do
341
 
342
         return;
343
      end if;
344
 
345
      Min_Len := Buffer_Last + Dir'Length;
346
 
347
      if Buffer_Last > 0 then
348
 
349
         --  Add 1 for the Path_Separator character
350
 
351
         Min_Len := Min_Len + 1;
352
      end if;
353
 
354
      --  If Ada_Path_Buffer is too small, increase it
355
 
356
      Len := Buffer'Last;
357
 
358
      if Len < Min_Len then
359
         loop
360
            Len := Len * 2;
361
            exit when Len >= Min_Len;
362
         end loop;
363
 
364
         New_Buffer := new String (1 .. Len);
365
         New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
366
         Free (Buffer);
367
         Buffer := New_Buffer;
368
      end if;
369
 
370
      if Buffer_Last > 0 then
371
         Buffer_Last := Buffer_Last + 1;
372
         Buffer (Buffer_Last) := Path_Separator;
373
      end if;
374
 
375
      Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir;
376
      Buffer_Last := Buffer_Last + Dir'Length;
377
   end Add_To_Path;
378
 
379
   ------------------------
380
   -- Add_To_Source_Path --
381
   ------------------------
382
 
383
   procedure Add_To_Source_Path
384
     (Source_Dirs  : String_List_Id;
385
      In_Tree      : Project_Tree_Ref;
386
      Source_Paths : in out Source_Path_Table.Instance)
387
   is
388
      Current    : String_List_Id := Source_Dirs;
389
      Source_Dir : String_Element;
390
      Add_It     : Boolean;
391
 
392
   begin
393
      --  Add each source directory
394
 
395
      while Current /= Nil_String loop
396
         Source_Dir := In_Tree.String_Elements.Table (Current);
397
         Add_It := True;
398
 
399
         --  Check if the source directory is already in the table
400
 
401
         for Index in Source_Path_Table.First ..
402
                      Source_Path_Table.Last (Source_Paths)
403
         loop
404
            --  If it is already, no need to add it
405
 
406
            if Source_Paths.Table (Index) = Source_Dir.Value then
407
               Add_It := False;
408
               exit;
409
            end if;
410
         end loop;
411
 
412
         if Add_It then
413
            Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value);
414
         end if;
415
 
416
         --  Next source directory
417
 
418
         Current := Source_Dir.Next;
419
      end loop;
420
   end Add_To_Source_Path;
421
 
422
   --------------------------------
423
   -- Create_Config_Pragmas_File --
424
   --------------------------------
425
 
426
   procedure Create_Config_Pragmas_File
427
     (For_Project : Project_Id;
428
      In_Tree     : Project_Tree_Ref)
429
   is
430
      type Naming_Id is new Nat;
431
      package Naming_Table is new GNAT.Dynamic_Tables
432
        (Table_Component_Type => Lang_Naming_Data,
433
         Table_Index_Type     => Naming_Id,
434
         Table_Low_Bound      => 1,
435
         Table_Initial        => 5,
436
         Table_Increment      => 100);
437
      Default_Naming : constant Naming_Id := Naming_Table.First;
438
      Namings        : Naming_Table.Instance;
439
      --  Table storing the naming data for gnatmake/gprmake
440
 
441
      Buffer      : String_Access := new String (1 .. Buffer_Initial);
442
      Buffer_Last : Natural := 0;
443
 
444
      File_Name : Path_Name_Type  := No_Path;
445
      File      : File_Descriptor := Invalid_FD;
446
 
447
      Current_Naming  : Naming_Id;
448
      Iter            : Source_Iterator;
449
      Source          : Source_Id;
450
 
451
      procedure Check (Project : Project_Id; State : in out Integer);
452
      --  Recursive procedure that put in the config pragmas file any non
453
      --  standard naming schemes, if it is not already in the file, then call
454
      --  itself for any imported project.
455
 
456
      procedure Put (Source : Source_Id);
457
      --  Put an SFN pragma in the temporary file
458
 
459
      procedure Put (S : String);
460
      procedure Put_Line (S : String);
461
      --  Output procedures, analogous to normal Text_IO procs of same name.
462
      --  The text is put in Buffer, then it will be writen into a temporary
463
      --  file with procedure Write_Temp_File below.
464
 
465
      procedure Write_Temp_File;
466
      --  Create a temporary file and put the content of the buffer in it
467
 
468
      -----------
469
      -- Check --
470
      -----------
471
 
472
      procedure Check (Project : Project_Id; State : in out Integer) is
473
         pragma Unreferenced (State);
474
         Lang   : constant Language_Ptr :=
475
                    Get_Language_From_Name (Project, "ada");
476
         Naming : Lang_Naming_Data;
477
 
478
      begin
479
         if Current_Verbosity = High then
480
            Write_Str ("Checking project file """);
481
            Write_Str (Namet.Get_Name_String (Project.Name));
482
            Write_Str (""".");
483
            Write_Eol;
484
         end if;
485
 
486
         if Lang = null then
487
            if Current_Verbosity = High then
488
               Write_Line ("   Languages does not contain Ada, nothing to do");
489
            end if;
490
 
491
            return;
492
         end if;
493
 
494
         Naming := Lang.Config.Naming_Data;
495
 
496
         --  Is the naming scheme of this project one that we know?
497
 
498
         Current_Naming := Default_Naming;
499
         while Current_Naming <= Naming_Table.Last (Namings)
500
           and then Namings.Table (Current_Naming).Dot_Replacement =
501
                                                    Naming.Dot_Replacement
502
           and then Namings.Table (Current_Naming).Casing =
503
                                                    Naming.Casing
504
           and then Namings.Table (Current_Naming).Separate_Suffix =
505
                                                    Naming.Separate_Suffix
506
         loop
507
            Current_Naming := Current_Naming + 1;
508
         end loop;
509
 
510
         --  If we don't know it, add it
511
 
512
         if Current_Naming > Naming_Table.Last (Namings) then
513
            Naming_Table.Increment_Last (Namings);
514
            Namings.Table (Naming_Table.Last (Namings)) := Naming;
515
 
516
            --  Put the SFN pragmas for the naming scheme
517
 
518
            --  Spec
519
 
520
            Put_Line
521
              ("pragma Source_File_Name_Project");
522
            Put_Line
523
              ("  (Spec_File_Name  => ""*" &
524
               Get_Name_String (Naming.Spec_Suffix) & """,");
525
            Put_Line
526
              ("   Casing          => " &
527
               Image (Naming.Casing) & ",");
528
            Put_Line
529
              ("   Dot_Replacement => """ &
530
               Get_Name_String (Naming.Dot_Replacement) & """);");
531
 
532
            --  and body
533
 
534
            Put_Line
535
              ("pragma Source_File_Name_Project");
536
            Put_Line
537
              ("  (Body_File_Name  => ""*" &
538
               Get_Name_String (Naming.Body_Suffix) & """,");
539
            Put_Line
540
              ("   Casing          => " &
541
               Image (Naming.Casing) & ",");
542
            Put_Line
543
              ("   Dot_Replacement => """ &
544
               Get_Name_String (Naming.Dot_Replacement) &
545
               """);");
546
 
547
            --  and maybe separate
548
 
549
            if Naming.Body_Suffix /= Naming.Separate_Suffix then
550
               Put_Line ("pragma Source_File_Name_Project");
551
               Put_Line
552
                 ("  (Subunit_File_Name  => ""*" &
553
                  Get_Name_String (Naming.Separate_Suffix) & """,");
554
               Put_Line
555
                 ("   Casing          => " &
556
                  Image (Naming.Casing) & ",");
557
               Put_Line
558
                 ("   Dot_Replacement => """ &
559
                  Get_Name_String (Naming.Dot_Replacement) &
560
                  """);");
561
            end if;
562
         end if;
563
      end Check;
564
 
565
      ---------
566
      -- Put --
567
      ---------
568
 
569
      procedure Put (Source : Source_Id) is
570
      begin
571
         --  Put the pragma SFN for the unit kind (spec or body)
572
 
573
         Put ("pragma Source_File_Name_Project (");
574
         Put (Namet.Get_Name_String (Source.Unit.Name));
575
 
576
         if Source.Kind = Spec then
577
            Put (", Spec_File_Name => """);
578
         else
579
            Put (", Body_File_Name => """);
580
         end if;
581
 
582
         Put (Namet.Get_Name_String (Source.File));
583
         Put ("""");
584
 
585
         if Source.Index /= 0 then
586
            Put (", Index =>");
587
            Put (Source.Index'Img);
588
         end if;
589
 
590
         Put_Line (");");
591
      end Put;
592
 
593
      procedure Put (S : String) is
594
      begin
595
         Add_To_Buffer (S, Buffer, Buffer_Last);
596
 
597
         if Current_Verbosity = High then
598
            Write_Str (S);
599
         end if;
600
      end Put;
601
 
602
      --------------
603
      -- Put_Line --
604
      --------------
605
 
606
      procedure Put_Line (S : String) is
607
      begin
608
         --  Add an ASCII.LF to the string. As this config file is supposed to
609
         --  be used only by the compiler, we don't care about the characters
610
         --  for the end of line. In fact we could have put a space, but
611
         --  it is more convenient to be able to read gnat.adc during
612
         --  development, for which the ASCII.LF is fine.
613
 
614
         Put (S);
615
         Put (S => (1 => ASCII.LF));
616
      end Put_Line;
617
 
618
      ---------------------
619
      -- Write_Temp_File --
620
      ---------------------
621
 
622
      procedure Write_Temp_File is
623
         Status : Boolean := False;
624
         Last   : Natural;
625
 
626
      begin
627
         Tempdir.Create_Temp_File (File, File_Name);
628
 
629
         if File /= Invalid_FD then
630
            Last := Write (File, Buffer (1)'Address, Buffer_Last);
631
 
632
            if Last = Buffer_Last then
633
               Close (File, Status);
634
            end if;
635
         end if;
636
 
637
         if not Status then
638
            Prj.Com.Fail ("unable to create temporary file");
639
         end if;
640
      end Write_Temp_File;
641
 
642
      procedure Check_Imported_Projects is
643
        new For_Every_Project_Imported (Integer, Check);
644
 
645
      Dummy : Integer := 0;
646
 
647
   --  Start of processing for Create_Config_Pragmas_File
648
 
649
   begin
650
      if not For_Project.Config_Checked then
651
         Naming_Table.Init (Namings);
652
 
653
         --  Check the naming schemes
654
 
655
         Check_Imported_Projects (For_Project, Dummy, Imported_First => False);
656
 
657
         --  Visit all the files and process those that need an SFN pragma
658
 
659
         Iter := For_Each_Source (In_Tree, For_Project);
660
         while Element (Iter) /= No_Source loop
661
            Source := Element (Iter);
662
 
663
            if Source.Index >= 1
664
              and then not Source.Locally_Removed
665
              and then Source.Unit /= null
666
            then
667
               Put (Source);
668
            end if;
669
 
670
            Next (Iter);
671
         end loop;
672
 
673
         --  If there are no non standard naming scheme, issue the GNAT
674
         --  standard naming scheme. This will tell the compiler that
675
         --  a project file is used and will forbid any pragma SFN.
676
 
677
         if Buffer_Last = 0 then
678
 
679
            Put_Line ("pragma Source_File_Name_Project");
680
            Put_Line ("   (Spec_File_Name  => ""*.ads"",");
681
            Put_Line ("    Dot_Replacement => ""-"",");
682
            Put_Line ("    Casing          => lowercase);");
683
 
684
            Put_Line ("pragma Source_File_Name_Project");
685
            Put_Line ("   (Body_File_Name  => ""*.adb"",");
686
            Put_Line ("    Dot_Replacement => ""-"",");
687
            Put_Line ("    Casing          => lowercase);");
688
         end if;
689
 
690
         --  Close the temporary file
691
 
692
         Write_Temp_File;
693
 
694
         if Opt.Verbose_Mode then
695
            Write_Str ("Created configuration file """);
696
            Write_Str (Get_Name_String (File_Name));
697
            Write_Line ("""");
698
         end if;
699
 
700
         For_Project.Config_File_Name := File_Name;
701
         For_Project.Config_File_Temp := True;
702
         For_Project.Config_Checked   := True;
703
      end if;
704
 
705
      Free (Buffer);
706
   end Create_Config_Pragmas_File;
707
 
708
   --------------------
709
   -- Create_Mapping --
710
   --------------------
711
 
712
   procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
713
      Data : Source_Id;
714
      Iter : Source_Iterator;
715
 
716
   begin
717
      Fmap.Reset_Tables;
718
 
719
      Iter := For_Each_Source (In_Tree);
720
      loop
721
         Data := Element (Iter);
722
         exit when Data = No_Source;
723
 
724
         if Data.Unit /= No_Unit_Index then
725
            if Data.Locally_Removed then
726
               Fmap.Add_Forbidden_File_Name (Data.File);
727
            else
728
               Fmap.Add_To_File_Map
729
                 (Unit_Name => Unit_Name_Type (Data.Unit.Name),
730
                  File_Name => Data.File,
731
                  Path_Name => File_Name_Type (Data.Path.Name));
732
            end if;
733
         end if;
734
 
735
         Next (Iter);
736
      end loop;
737
   end Create_Mapping;
738
 
739
   -------------------------
740
   -- Create_Mapping_File --
741
   -------------------------
742
 
743
   procedure Create_Mapping_File
744
     (Project  : Project_Id;
745
      Language : Name_Id;
746
      In_Tree  : Project_Tree_Ref;
747
      Name     : out Path_Name_Type)
748
   is
749
      File   : File_Descriptor := Invalid_FD;
750
 
751
      Buffer : String_Access := new String (1 .. Buffer_Initial);
752
      Buffer_Last : Natural := 0;
753
 
754
      procedure Put_Name_Buffer;
755
      --  Put the line contained in the Name_Buffer in the global buffer
756
 
757
      procedure Process (Project : Project_Id; State : in out Integer);
758
      --  Generate the mapping file for Project (not recursively)
759
 
760
      ---------------------
761
      -- Put_Name_Buffer --
762
      ---------------------
763
 
764
      procedure Put_Name_Buffer is
765
      begin
766
         Name_Len := Name_Len + 1;
767
         Name_Buffer (Name_Len) := ASCII.LF;
768
 
769
         if Current_Verbosity = High then
770
            Write_Str ("Mapping file: " & Name_Buffer (1 .. Name_Len));
771
         end if;
772
 
773
         Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
774
      end Put_Name_Buffer;
775
 
776
      -------------
777
      -- Process --
778
      -------------
779
 
780
      procedure Process (Project : Project_Id; State : in out Integer) is
781
         pragma Unreferenced (State);
782
         Source : Source_Id;
783
         Suffix : File_Name_Type;
784
         Iter   : Source_Iterator;
785
 
786
      begin
787
         Iter := For_Each_Source (In_Tree, Project, Language => Language);
788
 
789
         loop
790
            Source := Prj.Element (Iter);
791
            exit when Source = No_Source;
792
 
793
            if Source.Replaced_By = No_Source
794
              and then Source.Path.Name /= No_Path
795
              and then
796
                (Source.Language.Config.Kind = File_Based
797
                  or else Source.Unit /= No_Unit_Index)
798
            then
799
               if Source.Unit /= No_Unit_Index then
800
                  Get_Name_String (Source.Unit.Name);
801
 
802
                  if Source.Language.Config.Kind = Unit_Based then
803
 
804
                     --  ??? Mapping_Spec_Suffix could be set in the case of
805
                     --  gnatmake as well
806
 
807
                     Add_Char_To_Name_Buffer ('%');
808
 
809
                     if Source.Kind = Spec then
810
                        Add_Char_To_Name_Buffer ('s');
811
                     else
812
                        Add_Char_To_Name_Buffer ('b');
813
                     end if;
814
 
815
                  else
816
                     case Source.Kind is
817
                        when Spec =>
818
                           Suffix :=
819
                             Source.Language.Config.Mapping_Spec_Suffix;
820
                        when Impl | Sep =>
821
                           Suffix :=
822
                             Source.Language.Config.Mapping_Body_Suffix;
823
                     end case;
824
 
825
                     if Suffix /= No_File then
826
                        Add_Str_To_Name_Buffer
827
                          (Get_Name_String (Suffix));
828
                     end if;
829
                  end if;
830
 
831
                  Put_Name_Buffer;
832
               end if;
833
 
834
               Get_Name_String (Source.File);
835
               Put_Name_Buffer;
836
 
837
               if Source.Locally_Removed then
838
                  Name_Len := 1;
839
                  Name_Buffer (1) := '/';
840
               else
841
                  Get_Name_String (Source.Path.Name);
842
               end if;
843
 
844
               Put_Name_Buffer;
845
            end if;
846
 
847
            Next (Iter);
848
         end loop;
849
      end Process;
850
 
851
      procedure For_Every_Imported_Project is new
852
        For_Every_Project_Imported (State => Integer, Action => Process);
853
 
854
      Dummy : Integer := 0;
855
 
856
   --  Start of processing for Create_Mapping_File
857
 
858
   begin
859
      For_Every_Imported_Project (Project, Dummy);
860
 
861
      declare
862
         Last   : Natural;
863
         Status : Boolean := False;
864
 
865
      begin
866
         Create_Temp_File (In_Tree, File, Name, "mapping");
867
 
868
         if File /= Invalid_FD then
869
            Last := Write (File, Buffer (1)'Address, Buffer_Last);
870
 
871
            if Last = Buffer_Last then
872
               GNAT.OS_Lib.Close (File, Status);
873
            end if;
874
         end if;
875
 
876
         if not Status then
877
            Prj.Com.Fail ("could not write mapping file");
878
         end if;
879
      end;
880
 
881
      Free (Buffer);
882
   end Create_Mapping_File;
883
 
884
   ----------------------
885
   -- Create_Temp_File --
886
   ----------------------
887
 
888
   procedure Create_Temp_File
889
     (In_Tree   : Project_Tree_Ref;
890
      Path_FD   : out File_Descriptor;
891
      Path_Name : out Path_Name_Type;
892
      File_Use  : String)
893
   is
894
   begin
895
      Tempdir.Create_Temp_File (Path_FD, Path_Name);
896
 
897
      if Path_Name /= No_Path then
898
         if Current_Verbosity = High then
899
            Write_Line ("Create temp file (" & File_Use & ") "
900
                        & Get_Name_String (Path_Name));
901
         end if;
902
 
903
         Record_Temp_File (In_Tree, Path_Name);
904
 
905
      else
906
         Prj.Com.Fail
907
           ("unable to create temporary " & File_Use & " file");
908
      end if;
909
   end Create_Temp_File;
910
 
911
   --------------------------
912
   -- Create_New_Path_File --
913
   --------------------------
914
 
915
   procedure Create_New_Path_File
916
     (In_Tree   : Project_Tree_Ref;
917
      Path_FD   : out File_Descriptor;
918
      Path_Name : out Path_Name_Type)
919
   is
920
   begin
921
      Create_Temp_File (In_Tree, Path_FD, Path_Name, "path file");
922
   end Create_New_Path_File;
923
 
924
   ------------------------------------
925
   -- File_Name_Of_Library_Unit_Body --
926
   ------------------------------------
927
 
928
   function File_Name_Of_Library_Unit_Body
929
     (Name              : String;
930
      Project           : Project_Id;
931
      In_Tree           : Project_Tree_Ref;
932
      Main_Project_Only : Boolean := True;
933
      Full_Path         : Boolean := False) return String
934
   is
935
      The_Project   : Project_Id := Project;
936
      Original_Name : String := Name;
937
 
938
      Lang   : constant Language_Ptr :=
939
        Get_Language_From_Name (Project, "ada");
940
 
941
      Unit              : Unit_Index;
942
      The_Original_Name : Name_Id;
943
      The_Spec_Name     : Name_Id;
944
      The_Body_Name     : Name_Id;
945
 
946
   begin
947
      --  ??? Same block in Project_Of
948
      Canonical_Case_File_Name (Original_Name);
949
      Name_Len := Original_Name'Length;
950
      Name_Buffer (1 .. Name_Len) := Original_Name;
951
      The_Original_Name := Name_Find;
952
 
953
      if Lang /= null then
954
         declare
955
            Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data;
956
            Extended_Spec_Name : String :=
957
                                   Name & Namet.Get_Name_String
958
                                            (Naming.Spec_Suffix);
959
            Extended_Body_Name : String :=
960
                                   Name & Namet.Get_Name_String
961
                                            (Naming.Body_Suffix);
962
 
963
         begin
964
            Canonical_Case_File_Name (Extended_Spec_Name);
965
            Name_Len := Extended_Spec_Name'Length;
966
            Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
967
            The_Spec_Name := Name_Find;
968
 
969
            Canonical_Case_File_Name (Extended_Body_Name);
970
            Name_Len := Extended_Body_Name'Length;
971
            Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
972
            The_Body_Name := Name_Find;
973
         end;
974
 
975
      else
976
         Name_Len := Name'Length;
977
         Name_Buffer (1 .. Name_Len) := Name;
978
         Canonical_Case_File_Name (Name_Buffer);
979
         The_Spec_Name := Name_Find;
980
         The_Body_Name := The_Spec_Name;
981
      end if;
982
 
983
      if Current_Verbosity = High then
984
         Write_Str  ("Looking for file name of """);
985
         Write_Str  (Name);
986
         Write_Char ('"');
987
         Write_Eol;
988
         Write_Str  ("   Extended Spec Name = """);
989
         Write_Str  (Get_Name_String (The_Spec_Name));
990
         Write_Char ('"');
991
         Write_Eol;
992
         Write_Str  ("   Extended Body Name = """);
993
         Write_Str  (Get_Name_String (The_Body_Name));
994
         Write_Char ('"');
995
         Write_Eol;
996
      end if;
997
 
998
      --  For extending project, search in the extended project if the source
999
      --  is not found. For non extending projects, this loop will be run only
1000
      --  once.
1001
 
1002
      loop
1003
         --  Loop through units
1004
 
1005
         Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1006
         while Unit /= null loop
1007
            --  Check for body
1008
 
1009
            if not Main_Project_Only
1010
              or else
1011
                (Unit.File_Names (Impl) /= null
1012
                 and then Unit.File_Names (Impl).Project = The_Project)
1013
            then
1014
               declare
1015
                  Current_Name : File_Name_Type;
1016
               begin
1017
                  --  Case of a body present
1018
 
1019
                  if Unit.File_Names (Impl) /= null then
1020
                     Current_Name := Unit.File_Names (Impl).File;
1021
 
1022
                     if Current_Verbosity = High then
1023
                        Write_Str  ("   Comparing with """);
1024
                        Write_Str  (Get_Name_String (Current_Name));
1025
                        Write_Char ('"');
1026
                        Write_Eol;
1027
                     end if;
1028
 
1029
                     --  If it has the name of the original name, return the
1030
                     --  original name.
1031
 
1032
                     if Unit.Name = The_Original_Name
1033
                       or else
1034
                         Current_Name = File_Name_Type (The_Original_Name)
1035
                     then
1036
                        if Current_Verbosity = High then
1037
                           Write_Line ("   OK");
1038
                        end if;
1039
 
1040
                        if Full_Path then
1041
                           return Get_Name_String
1042
                             (Unit.File_Names (Impl).Path.Name);
1043
 
1044
                        else
1045
                           return Get_Name_String (Current_Name);
1046
                        end if;
1047
 
1048
                        --  If it has the name of the extended body name,
1049
                        --  return the extended body name
1050
 
1051
                     elsif Current_Name = File_Name_Type (The_Body_Name) then
1052
                        if Current_Verbosity = High then
1053
                           Write_Line ("   OK");
1054
                        end if;
1055
 
1056
                        if Full_Path then
1057
                           return Get_Name_String
1058
                             (Unit.File_Names (Impl).Path.Name);
1059
 
1060
                        else
1061
                           return Get_Name_String (The_Body_Name);
1062
                        end if;
1063
 
1064
                     else
1065
                        if Current_Verbosity = High then
1066
                           Write_Line ("   not good");
1067
                        end if;
1068
                     end if;
1069
                  end if;
1070
               end;
1071
            end if;
1072
 
1073
            --  Check for spec
1074
 
1075
            if not Main_Project_Only
1076
              or else
1077
                (Unit.File_Names (Spec) /= null
1078
                 and then Unit.File_Names (Spec).Project =
1079
                   The_Project)
1080
            then
1081
               declare
1082
                  Current_Name : File_Name_Type;
1083
 
1084
               begin
1085
                  --  Case of spec present
1086
 
1087
                  if Unit.File_Names (Spec) /= null then
1088
                     Current_Name := Unit.File_Names (Spec).File;
1089
                     if Current_Verbosity = High then
1090
                        Write_Str  ("   Comparing with """);
1091
                        Write_Str  (Get_Name_String (Current_Name));
1092
                        Write_Char ('"');
1093
                        Write_Eol;
1094
                     end if;
1095
 
1096
                     --  If name same as original name, return original name
1097
 
1098
                     if Unit.Name = The_Original_Name
1099
                       or else
1100
                         Current_Name = File_Name_Type (The_Original_Name)
1101
                     then
1102
                        if Current_Verbosity = High then
1103
                           Write_Line ("   OK");
1104
                        end if;
1105
 
1106
                        if Full_Path then
1107
                           return Get_Name_String
1108
                             (Unit.File_Names (Spec).Path.Name);
1109
                        else
1110
                           return Get_Name_String (Current_Name);
1111
                        end if;
1112
 
1113
                        --  If it has the same name as the extended spec name,
1114
                        --  return the extended spec name.
1115
 
1116
                     elsif Current_Name = File_Name_Type (The_Spec_Name) then
1117
                        if Current_Verbosity = High then
1118
                           Write_Line ("   OK");
1119
                        end if;
1120
 
1121
                        if Full_Path then
1122
                           return Get_Name_String
1123
                             (Unit.File_Names (Spec).Path.Name);
1124
                        else
1125
                           return Get_Name_String (The_Spec_Name);
1126
                        end if;
1127
 
1128
                     else
1129
                        if Current_Verbosity = High then
1130
                           Write_Line ("   not good");
1131
                        end if;
1132
                     end if;
1133
                  end if;
1134
               end;
1135
            end if;
1136
 
1137
            Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1138
         end loop;
1139
 
1140
         --  If we are not in an extending project, give up
1141
 
1142
         exit when not Main_Project_Only
1143
           or else The_Project.Extends = No_Project;
1144
 
1145
         --  Otherwise, look in the project we are extending
1146
 
1147
         The_Project := The_Project.Extends;
1148
      end loop;
1149
 
1150
      --  We don't know this file name, return an empty string
1151
 
1152
      return "";
1153
   end File_Name_Of_Library_Unit_Body;
1154
 
1155
   -------------------------
1156
   -- For_All_Object_Dirs --
1157
   -------------------------
1158
 
1159
   procedure For_All_Object_Dirs (Project : Project_Id) is
1160
      procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1161
      --  Get all object directories of Prj
1162
 
1163
      -----------------
1164
      -- For_Project --
1165
      -----------------
1166
 
1167
      procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1168
         pragma Unreferenced (Dummy);
1169
      begin
1170
         --  ??? Set_Ada_Paths has a different behavior for library project
1171
         --  files, should we have the same ?
1172
 
1173
         if Prj.Object_Directory /= No_Path_Information then
1174
            Get_Name_String (Prj.Object_Directory.Display_Name);
1175
            Action (Name_Buffer (1 .. Name_Len));
1176
         end if;
1177
      end For_Project;
1178
 
1179
      procedure Get_Object_Dirs is
1180
        new For_Every_Project_Imported (Integer, For_Project);
1181
      Dummy : Integer := 1;
1182
 
1183
   --  Start of processing for For_All_Object_Dirs
1184
 
1185
   begin
1186
      Get_Object_Dirs (Project, Dummy);
1187
   end For_All_Object_Dirs;
1188
 
1189
   -------------------------
1190
   -- For_All_Source_Dirs --
1191
   -------------------------
1192
 
1193
   procedure For_All_Source_Dirs
1194
     (Project : Project_Id;
1195
      In_Tree : Project_Tree_Ref)
1196
   is
1197
      procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1198
      --  Get all object directories of Prj
1199
 
1200
      -----------------
1201
      -- For_Project --
1202
      -----------------
1203
 
1204
      procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1205
         pragma Unreferenced (Dummy);
1206
         Current    : String_List_Id := Prj.Source_Dirs;
1207
         The_String : String_Element;
1208
 
1209
      begin
1210
         --  If there are Ada sources, call action with the name of every
1211
         --  source directory.
1212
 
1213
         if Has_Ada_Sources (Project) then
1214
            while Current /= Nil_String loop
1215
               The_String := In_Tree.String_Elements.Table (Current);
1216
               Action (Get_Name_String (The_String.Display_Value));
1217
               Current := The_String.Next;
1218
            end loop;
1219
         end if;
1220
      end For_Project;
1221
 
1222
      procedure Get_Source_Dirs is
1223
        new For_Every_Project_Imported (Integer, For_Project);
1224
      Dummy : Integer := 1;
1225
 
1226
   --  Start of processing for For_All_Source_Dirs
1227
 
1228
   begin
1229
      Get_Source_Dirs (Project, Dummy);
1230
   end For_All_Source_Dirs;
1231
 
1232
   -------------------
1233
   -- Get_Reference --
1234
   -------------------
1235
 
1236
   procedure Get_Reference
1237
     (Source_File_Name : String;
1238
      In_Tree          : Project_Tree_Ref;
1239
      Project          : out Project_Id;
1240
      Path             : out Path_Name_Type)
1241
   is
1242
   begin
1243
      --  Body below could use some comments ???
1244
 
1245
      if Current_Verbosity > Default then
1246
         Write_Str ("Getting Reference_Of (""");
1247
         Write_Str (Source_File_Name);
1248
         Write_Str (""") ... ");
1249
      end if;
1250
 
1251
      declare
1252
         Original_Name : String := Source_File_Name;
1253
         Unit          : Unit_Index;
1254
 
1255
      begin
1256
         Canonical_Case_File_Name (Original_Name);
1257
         Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1258
 
1259
         while Unit /= null loop
1260
            if Unit.File_Names (Spec) /= null
1261
              and then Unit.File_Names (Spec).File /= No_File
1262
              and then
1263
                (Namet.Get_Name_String
1264
                     (Unit.File_Names (Spec).File) = Original_Name
1265
                 or else (Unit.File_Names (Spec).Path /=
1266
                            No_Path_Information
1267
                          and then
1268
                            Namet.Get_Name_String
1269
                              (Unit.File_Names (Spec).Path.Name) =
1270
                            Original_Name))
1271
            then
1272
               Project := Ultimate_Extension_Of
1273
                          (Project => Unit.File_Names (Spec).Project);
1274
               Path := Unit.File_Names (Spec).Path.Display_Name;
1275
 
1276
               if Current_Verbosity > Default then
1277
                  Write_Str ("Done: Spec.");
1278
                  Write_Eol;
1279
               end if;
1280
 
1281
               return;
1282
 
1283
            elsif Unit.File_Names (Impl) /= null
1284
              and then Unit.File_Names (Impl).File /= No_File
1285
              and then
1286
                (Namet.Get_Name_String
1287
                   (Unit.File_Names (Impl).File) = Original_Name
1288
                 or else (Unit.File_Names (Impl).Path /=
1289
                            No_Path_Information
1290
                          and then Namet.Get_Name_String
1291
                            (Unit.File_Names (Impl).Path.Name) =
1292
                            Original_Name))
1293
            then
1294
               Project := Ultimate_Extension_Of
1295
                            (Project => Unit.File_Names (Impl).Project);
1296
               Path := Unit.File_Names (Impl).Path.Display_Name;
1297
 
1298
               if Current_Verbosity > Default then
1299
                  Write_Str ("Done: Body.");
1300
                  Write_Eol;
1301
               end if;
1302
 
1303
               return;
1304
            end if;
1305
 
1306
            Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1307
         end loop;
1308
      end;
1309
 
1310
      Project := No_Project;
1311
      Path    := No_Path;
1312
 
1313
      if Current_Verbosity > Default then
1314
         Write_Str ("Cannot be found.");
1315
         Write_Eol;
1316
      end if;
1317
   end Get_Reference;
1318
 
1319
   ----------------
1320
   -- Initialize --
1321
   ----------------
1322
 
1323
   procedure Initialize (In_Tree : Project_Tree_Ref) is
1324
   begin
1325
      In_Tree.Private_Part.Current_Source_Path_File := No_Path;
1326
      In_Tree.Private_Part.Current_Object_Path_File := No_Path;
1327
   end Initialize;
1328
 
1329
   -------------------
1330
   -- Print_Sources --
1331
   -------------------
1332
 
1333
   --  Could use some comments in this body ???
1334
 
1335
   procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1336
      Unit : Unit_Index;
1337
 
1338
   begin
1339
      Write_Line ("List of Sources:");
1340
 
1341
      Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1342
 
1343
      while Unit /= No_Unit_Index loop
1344
         Write_Str  ("   ");
1345
         Write_Line (Namet.Get_Name_String (Unit.Name));
1346
 
1347
         if Unit.File_Names (Spec).File /= No_File then
1348
            if Unit.File_Names (Spec).Project = No_Project then
1349
               Write_Line ("   No project");
1350
 
1351
            else
1352
               Write_Str  ("   Project: ");
1353
               Get_Name_String
1354
                 (Unit.File_Names (Spec).Project.Path.Name);
1355
               Write_Line (Name_Buffer (1 .. Name_Len));
1356
            end if;
1357
 
1358
            Write_Str  ("      spec: ");
1359
            Write_Line
1360
              (Namet.Get_Name_String
1361
               (Unit.File_Names (Spec).File));
1362
         end if;
1363
 
1364
         if Unit.File_Names (Impl).File /= No_File then
1365
            if Unit.File_Names (Impl).Project = No_Project then
1366
               Write_Line ("   No project");
1367
 
1368
            else
1369
               Write_Str  ("   Project: ");
1370
               Get_Name_String
1371
                 (Unit.File_Names (Impl).Project.Path.Name);
1372
               Write_Line (Name_Buffer (1 .. Name_Len));
1373
            end if;
1374
 
1375
            Write_Str  ("      body: ");
1376
            Write_Line
1377
              (Namet.Get_Name_String (Unit.File_Names (Impl).File));
1378
         end if;
1379
 
1380
         Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1381
      end loop;
1382
 
1383
      Write_Line ("end of List of Sources.");
1384
   end Print_Sources;
1385
 
1386
   ----------------
1387
   -- Project_Of --
1388
   ----------------
1389
 
1390
   function Project_Of
1391
     (Name         : String;
1392
      Main_Project : Project_Id;
1393
      In_Tree      : Project_Tree_Ref) return Project_Id
1394
   is
1395
      Result : Project_Id := No_Project;
1396
 
1397
      Original_Name : String := Name;
1398
 
1399
      Lang : constant Language_Ptr :=
1400
               Get_Language_From_Name (Main_Project, "ada");
1401
 
1402
      Unit : Unit_Index;
1403
 
1404
      Current_Name      : File_Name_Type;
1405
      The_Original_Name : File_Name_Type;
1406
      The_Spec_Name     : File_Name_Type;
1407
      The_Body_Name     : File_Name_Type;
1408
 
1409
   begin
1410
      --  ??? Same block in File_Name_Of_Library_Unit_Body
1411
      Canonical_Case_File_Name (Original_Name);
1412
      Name_Len := Original_Name'Length;
1413
      Name_Buffer (1 .. Name_Len) := Original_Name;
1414
      The_Original_Name := Name_Find;
1415
 
1416
      if Lang /= null then
1417
         declare
1418
            Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
1419
            Extended_Spec_Name : String :=
1420
                                   Name & Namet.Get_Name_String
1421
                                            (Naming.Spec_Suffix);
1422
            Extended_Body_Name : String :=
1423
                                   Name & Namet.Get_Name_String
1424
                                            (Naming.Body_Suffix);
1425
 
1426
         begin
1427
            Canonical_Case_File_Name (Extended_Spec_Name);
1428
            Name_Len := Extended_Spec_Name'Length;
1429
            Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1430
            The_Spec_Name := Name_Find;
1431
 
1432
            Canonical_Case_File_Name (Extended_Body_Name);
1433
            Name_Len := Extended_Body_Name'Length;
1434
            Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1435
            The_Body_Name := Name_Find;
1436
         end;
1437
 
1438
      else
1439
         The_Spec_Name := The_Original_Name;
1440
         The_Body_Name := The_Original_Name;
1441
      end if;
1442
 
1443
      Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1444
      while Unit /= null loop
1445
 
1446
         --  Case of a body present
1447
 
1448
         if Unit.File_Names (Impl) /= null then
1449
            Current_Name := Unit.File_Names (Impl).File;
1450
 
1451
            --  If it has the name of the original name or the body name,
1452
            --  we have found the project.
1453
 
1454
            if Unit.Name = Name_Id (The_Original_Name)
1455
              or else Current_Name = The_Original_Name
1456
              or else Current_Name = The_Body_Name
1457
            then
1458
               Result := Unit.File_Names (Impl).Project;
1459
               exit;
1460
            end if;
1461
         end if;
1462
 
1463
         --  Check for spec
1464
 
1465
         if Unit.File_Names (Spec) /= null then
1466
            Current_Name := Unit.File_Names (Spec).File;
1467
 
1468
            --  If name same as the original name, or the spec name, we have
1469
            --  found the project.
1470
 
1471
            if Unit.Name = Name_Id (The_Original_Name)
1472
              or else Current_Name = The_Original_Name
1473
              or else Current_Name = The_Spec_Name
1474
            then
1475
               Result := Unit.File_Names (Spec).Project;
1476
               exit;
1477
            end if;
1478
         end if;
1479
 
1480
         Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1481
      end loop;
1482
 
1483
      --  Get the ultimate extending project
1484
 
1485
      if Result /= No_Project then
1486
         while Result.Extended_By /= No_Project loop
1487
            Result := Result.Extended_By;
1488
         end loop;
1489
      end if;
1490
 
1491
      return Result;
1492
   end Project_Of;
1493
 
1494
   -------------------
1495
   -- Set_Ada_Paths --
1496
   -------------------
1497
 
1498
   procedure Set_Ada_Paths
1499
     (Project             : Project_Id;
1500
      In_Tree             : Project_Tree_Ref;
1501
      Including_Libraries : Boolean)
1502
 
1503
   is
1504
      Source_Paths : Source_Path_Table.Instance;
1505
      Object_Paths : Object_Path_Table.Instance;
1506
      --  List of source or object dirs. Only computed the first time this
1507
      --  procedure is called (since Source_FD is then reused)
1508
 
1509
      Source_FD : File_Descriptor := Invalid_FD;
1510
      Object_FD : File_Descriptor := Invalid_FD;
1511
      --  The temporary files to store the paths. These are only created the
1512
      --  first time this procedure is called, and reused from then on.
1513
 
1514
      Process_Source_Dirs : Boolean := False;
1515
      Process_Object_Dirs : Boolean := False;
1516
 
1517
      Status : Boolean;
1518
      --  For calls to Close
1519
 
1520
      Last        : Natural;
1521
      Buffer      : String_Access := new String (1 .. Buffer_Initial);
1522
      Buffer_Last : Natural := 0;
1523
 
1524
      procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean);
1525
      --  Recursive procedure to add the source/object paths of extended/
1526
      --  imported projects.
1527
 
1528
      -------------------
1529
      -- Recursive_Add --
1530
      -------------------
1531
 
1532
      procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean) is
1533
         pragma Unreferenced (Dummy);
1534
 
1535
         Path : Path_Name_Type;
1536
 
1537
      begin
1538
         --  ??? This is almost the equivalent of For_All_Source_Dirs
1539
 
1540
         if Process_Source_Dirs then
1541
 
1542
            --  Add to path all source directories of this project if there are
1543
            --  Ada sources.
1544
 
1545
            if Has_Ada_Sources (Project) then
1546
               Add_To_Source_Path (Project.Source_Dirs, In_Tree, Source_Paths);
1547
            end if;
1548
         end if;
1549
 
1550
         if Process_Object_Dirs then
1551
            Path := Get_Object_Directory
1552
              (Project,
1553
               Including_Libraries => Including_Libraries,
1554
               Only_If_Ada         => True);
1555
 
1556
            if Path /= No_Path then
1557
               Add_To_Object_Path (Path, Object_Paths);
1558
            end if;
1559
         end if;
1560
      end Recursive_Add;
1561
 
1562
      procedure For_All_Projects is
1563
        new For_Every_Project_Imported (Boolean, Recursive_Add);
1564
 
1565
      Dummy : Boolean := False;
1566
 
1567
   --  Start of processing for Set_Ada_Paths
1568
 
1569
   begin
1570
      --  If it is the first time we call this procedure for this project,
1571
      --  compute the source path and/or the object path.
1572
 
1573
      if Project.Include_Path_File = No_Path then
1574
         Source_Path_Table.Init (Source_Paths);
1575
         Process_Source_Dirs := True;
1576
         Create_New_Path_File
1577
           (In_Tree, Source_FD, Project.Include_Path_File);
1578
      end if;
1579
 
1580
      --  For the object path, we make a distinction depending on
1581
      --  Including_Libraries.
1582
 
1583
      if Including_Libraries then
1584
         if Project.Objects_Path_File_With_Libs = No_Path then
1585
            Object_Path_Table.Init (Object_Paths);
1586
            Process_Object_Dirs := True;
1587
            Create_New_Path_File
1588
              (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs);
1589
         end if;
1590
 
1591
      else
1592
         if Project.Objects_Path_File_Without_Libs = No_Path then
1593
            Object_Path_Table.Init (Object_Paths);
1594
            Process_Object_Dirs := True;
1595
            Create_New_Path_File
1596
              (In_Tree, Object_FD, Project.Objects_Path_File_Without_Libs);
1597
         end if;
1598
      end if;
1599
 
1600
      --  If there is something to do, set Seen to False for all projects,
1601
      --  then call the recursive procedure Add for Project.
1602
 
1603
      if Process_Source_Dirs or Process_Object_Dirs then
1604
         For_All_Projects (Project, Dummy);
1605
      end if;
1606
 
1607
      --  Write and close any file that has been created. Source_FD is not set
1608
      --  when this subprogram is called a second time or more, since we reuse
1609
      --  the previous version of the file.
1610
 
1611
      if Source_FD /= Invalid_FD then
1612
         Buffer_Last := 0;
1613
 
1614
         for Index in Source_Path_Table.First ..
1615
                      Source_Path_Table.Last (Source_Paths)
1616
         loop
1617
            Get_Name_String (Source_Paths.Table (Index));
1618
            Name_Len := Name_Len + 1;
1619
            Name_Buffer (Name_Len) := ASCII.LF;
1620
            Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1621
         end loop;
1622
 
1623
         Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last);
1624
 
1625
         if Last = Buffer_Last then
1626
            Close (Source_FD, Status);
1627
 
1628
         else
1629
            Status := False;
1630
         end if;
1631
 
1632
         if not Status then
1633
            Prj.Com.Fail ("could not write temporary file");
1634
         end if;
1635
      end if;
1636
 
1637
      if Object_FD /= Invalid_FD then
1638
         Buffer_Last := 0;
1639
 
1640
         for Index in Object_Path_Table.First ..
1641
                      Object_Path_Table.Last (Object_Paths)
1642
         loop
1643
            Get_Name_String (Object_Paths.Table (Index));
1644
            Name_Len := Name_Len + 1;
1645
            Name_Buffer (Name_Len) := ASCII.LF;
1646
            Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1647
         end loop;
1648
 
1649
         Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last);
1650
 
1651
         if Last = Buffer_Last then
1652
            Close (Object_FD, Status);
1653
         else
1654
            Status := False;
1655
         end if;
1656
 
1657
         if not Status then
1658
            Prj.Com.Fail ("could not write temporary file");
1659
         end if;
1660
      end if;
1661
 
1662
      --  Set the env vars, if they need to be changed, and set the
1663
      --  corresponding flags.
1664
 
1665
      if In_Tree.Private_Part.Current_Source_Path_File /=
1666
           Project.Include_Path_File
1667
      then
1668
         In_Tree.Private_Part.Current_Source_Path_File :=
1669
           Project.Include_Path_File;
1670
         Set_Path_File_Var
1671
           (Project_Include_Path_File,
1672
            Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File));
1673
      end if;
1674
 
1675
      if Including_Libraries then
1676
         if In_Tree.Private_Part.Current_Object_Path_File /=
1677
            Project.Objects_Path_File_With_Libs
1678
         then
1679
            In_Tree.Private_Part.Current_Object_Path_File :=
1680
              Project.Objects_Path_File_With_Libs;
1681
            Set_Path_File_Var
1682
              (Project_Objects_Path_File,
1683
               Get_Name_String
1684
                 (In_Tree.Private_Part.Current_Object_Path_File));
1685
         end if;
1686
 
1687
      else
1688
         if In_Tree.Private_Part.Current_Object_Path_File /=
1689
            Project.Objects_Path_File_Without_Libs
1690
         then
1691
            In_Tree.Private_Part.Current_Object_Path_File :=
1692
              Project.Objects_Path_File_Without_Libs;
1693
            Set_Path_File_Var
1694
              (Project_Objects_Path_File,
1695
               Get_Name_String
1696
                 (In_Tree.Private_Part.Current_Object_Path_File));
1697
         end if;
1698
      end if;
1699
 
1700
      Free (Buffer);
1701
   end Set_Ada_Paths;
1702
 
1703
   -----------------------
1704
   -- Set_Path_File_Var --
1705
   -----------------------
1706
 
1707
   procedure Set_Path_File_Var (Name : String; Value : String) is
1708
      Host_Spec : String_Access := To_Host_File_Spec (Value);
1709
   begin
1710
      if Host_Spec = null then
1711
         Prj.Com.Fail
1712
           ("could not convert file name """ & Value & """ to host spec");
1713
      else
1714
         Setenv (Name, Host_Spec.all);
1715
         Free (Host_Spec);
1716
      end if;
1717
   end Set_Path_File_Var;
1718
 
1719
   ---------------------------
1720
   -- Ultimate_Extension_Of --
1721
   ---------------------------
1722
 
1723
   function Ultimate_Extension_Of
1724
     (Project : Project_Id) return Project_Id
1725
   is
1726
      Result : Project_Id;
1727
 
1728
   begin
1729
      Result := Project;
1730
      while Result.Extended_By /= No_Project loop
1731
         Result := Result.Extended_By;
1732
      end loop;
1733
 
1734
      return Result;
1735
   end Ultimate_Extension_Of;
1736
 
1737
end Prj.Env;

powered by: WebSVN 2.1.0

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