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.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
--                                  P R J                                   --
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 Debug;
27
with Osint;    use Osint;
28
with Output;   use Output;
29
with Prj.Attr;
30
with Prj.Err;  use Prj.Err;
31
with Snames;   use Snames;
32
with Uintp;    use Uintp;
33
 
34
with Ada.Characters.Handling;    use Ada.Characters.Handling;
35
with Ada.Unchecked_Deallocation;
36
 
37
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
38
 
39
with System.Case_Util; use System.Case_Util;
40
with System.HTable;
41
 
42
package body Prj is
43
 
44
   Object_Suffix : constant String := Get_Target_Object_Suffix.all;
45
   --  File suffix for object files
46
 
47
   Initial_Buffer_Size : constant := 100;
48
   --  Initial size for extensible buffer used in Add_To_Buffer
49
 
50
   The_Empty_String : Name_Id := No_Name;
51
 
52
   subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
53
 
54
   type Cst_String_Access is access constant String;
55
 
56
   All_Lower_Case_Image : aliased constant String := "lowercase";
57
   All_Upper_Case_Image : aliased constant String := "UPPERCASE";
58
   Mixed_Case_Image     : aliased constant String := "MixedCase";
59
 
60
   The_Casing_Images : constant array (Known_Casing) of Cst_String_Access :=
61
                         (All_Lower_Case => All_Lower_Case_Image'Access,
62
                          All_Upper_Case => All_Upper_Case_Image'Access,
63
                          Mixed_Case     => Mixed_Case_Image'Access);
64
 
65
   Project_Empty : constant Project_Data :=
66
                     (Qualifier                      => Unspecified,
67
                      Externally_Built               => False,
68
                      Config                         => Default_Project_Config,
69
                      Name                           => No_Name,
70
                      Display_Name                   => No_Name,
71
                      Path                           => No_Path_Information,
72
                      Virtual                        => False,
73
                      Location                       => No_Location,
74
                      Mains                          => Nil_String,
75
                      Directory                      => No_Path_Information,
76
                      Library                        => False,
77
                      Library_Dir                    => No_Path_Information,
78
                      Library_Src_Dir                => No_Path_Information,
79
                      Library_ALI_Dir                => No_Path_Information,
80
                      Library_Name                   => No_Name,
81
                      Library_Kind                   => Static,
82
                      Lib_Internal_Name              => No_Name,
83
                      Standalone_Library             => False,
84
                      Lib_Interface_ALIs             => Nil_String,
85
                      Lib_Auto_Init                  => False,
86
                      Libgnarl_Needed                => Unknown,
87
                      Symbol_Data                    => No_Symbols,
88
                      Interfaces_Defined             => False,
89
                      Source_Dirs                    => Nil_String,
90
                      Source_Dir_Ranks               => No_Number_List,
91
                      Object_Directory               => No_Path_Information,
92
                      Library_TS                     => Empty_Time_Stamp,
93
                      Exec_Directory                 => No_Path_Information,
94
                      Extends                        => No_Project,
95
                      Extended_By                    => No_Project,
96
                      Languages                      => No_Language_Index,
97
                      Decl                           => No_Declarations,
98
                      Imported_Projects              => null,
99
                      Include_Path_File              => No_Path,
100
                      All_Imported_Projects          => null,
101
                      Ada_Include_Path               => null,
102
                      Ada_Objects_Path               => null,
103
                      Objects_Path                   => null,
104
                      Objects_Path_File_With_Libs    => No_Path,
105
                      Objects_Path_File_Without_Libs => No_Path,
106
                      Config_File_Name               => No_Path,
107
                      Config_File_Temp               => False,
108
                      Config_Checked                 => False,
109
                      Need_To_Build_Lib              => False,
110
                      Has_Multi_Unit_Sources         => False,
111
                      Depth                          => 0,
112
                      Unkept_Comments                => False);
113
 
114
   procedure Free (Project : in out Project_Id);
115
   --  Free memory allocated for Project
116
 
117
   procedure Free_List (Languages : in out Language_Ptr);
118
   procedure Free_List (Source : in out Source_Id);
119
   procedure Free_List (Languages : in out Language_List);
120
   --  Free memory allocated for the list of languages or sources
121
 
122
   procedure Free_Units (Table : in out Units_Htable.Instance);
123
   --  Free memory allocated for unit information in the project
124
 
125
   procedure Language_Changed (Iter : in out Source_Iterator);
126
   procedure Project_Changed (Iter : in out Source_Iterator);
127
   --  Called when a new project or language was selected for this iterator
128
 
129
   function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean;
130
   --  Return True if there is at least one ALI file in the directory Dir
131
 
132
   -------------------
133
   -- Add_To_Buffer --
134
   -------------------
135
 
136
   procedure Add_To_Buffer
137
     (S    : String;
138
      To   : in out String_Access;
139
      Last : in out Natural)
140
   is
141
   begin
142
      if To = null then
143
         To := new String (1 .. Initial_Buffer_Size);
144
         Last := 0;
145
      end if;
146
 
147
      --  If Buffer is too small, double its size
148
 
149
      while Last + S'Length > To'Last loop
150
         declare
151
            New_Buffer : constant  String_Access :=
152
                           new String (1 .. 2 * Last);
153
 
154
         begin
155
            New_Buffer (1 .. Last) := To (1 .. Last);
156
            Free (To);
157
            To := New_Buffer;
158
         end;
159
      end loop;
160
 
161
      To (Last + 1 .. Last + S'Length) := S;
162
      Last := Last + S'Length;
163
   end Add_To_Buffer;
164
 
165
   ---------------------------
166
   -- Delete_Temporary_File --
167
   ---------------------------
168
 
169
   procedure Delete_Temporary_File
170
     (Tree : Project_Tree_Ref;
171
      Path : Path_Name_Type)
172
   is
173
      Dont_Care : Boolean;
174
      pragma Warnings (Off, Dont_Care);
175
 
176
   begin
177
      if not Debug.Debug_Flag_N then
178
         if Current_Verbosity = High then
179
            Write_Line ("Removing temp file: " & Get_Name_String (Path));
180
         end if;
181
 
182
         Delete_File (Get_Name_String (Path), Dont_Care);
183
 
184
         for Index in
185
           1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files)
186
         loop
187
            if Tree.Private_Part.Temp_Files.Table (Index) = Path then
188
               Tree.Private_Part.Temp_Files.Table (Index) := No_Path;
189
            end if;
190
         end loop;
191
      end if;
192
   end Delete_Temporary_File;
193
 
194
   ---------------------------
195
   -- Delete_All_Temp_Files --
196
   ---------------------------
197
 
198
   procedure Delete_All_Temp_Files (Tree : Project_Tree_Ref) is
199
      Dont_Care : Boolean;
200
      pragma Warnings (Off, Dont_Care);
201
 
202
      Path : Path_Name_Type;
203
 
204
   begin
205
      if not Debug.Debug_Flag_N then
206
         for Index in
207
           1 .. Temp_Files_Table.Last (Tree.Private_Part.Temp_Files)
208
         loop
209
            Path := Tree.Private_Part.Temp_Files.Table (Index);
210
 
211
            if Path /= No_Path then
212
               if Current_Verbosity = High then
213
                  Write_Line ("Removing temp file: "
214
                              & Get_Name_String (Path));
215
               end if;
216
 
217
               Delete_File (Get_Name_String (Path), Dont_Care);
218
            end if;
219
         end loop;
220
 
221
         Temp_Files_Table.Free (Tree.Private_Part.Temp_Files);
222
         Temp_Files_Table.Init (Tree.Private_Part.Temp_Files);
223
      end if;
224
 
225
      --  If any of the environment variables ADA_PRJ_INCLUDE_FILE or
226
      --  ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
227
      --  the empty string. On VMS, this has the effect of deassigning
228
      --  the logical names.
229
 
230
      if Tree.Private_Part.Current_Source_Path_File /= No_Path then
231
         Setenv (Project_Include_Path_File, "");
232
      end if;
233
 
234
      if Tree.Private_Part.Current_Object_Path_File /= No_Path then
235
         Setenv (Project_Objects_Path_File, "");
236
      end if;
237
   end Delete_All_Temp_Files;
238
 
239
   ---------------------
240
   -- Dependency_Name --
241
   ---------------------
242
 
243
   function Dependency_Name
244
     (Source_File_Name : File_Name_Type;
245
      Dependency       : Dependency_File_Kind) return File_Name_Type
246
   is
247
   begin
248
      case Dependency is
249
         when None =>
250
            return No_File;
251
 
252
         when Makefile =>
253
            return
254
              File_Name_Type
255
                (Extend_Name
256
                   (Source_File_Name, Makefile_Dependency_Suffix));
257
 
258
         when ALI_File =>
259
            return
260
              File_Name_Type
261
                (Extend_Name
262
                   (Source_File_Name, ALI_Dependency_Suffix));
263
      end case;
264
   end Dependency_Name;
265
 
266
   ----------------
267
   -- Empty_File --
268
   ----------------
269
 
270
   function Empty_File return File_Name_Type is
271
   begin
272
      return File_Name_Type (The_Empty_String);
273
   end Empty_File;
274
 
275
   -------------------
276
   -- Empty_Project --
277
   -------------------
278
 
279
   function Empty_Project return Project_Data is
280
   begin
281
      Prj.Initialize (Tree => No_Project_Tree);
282
      return Project_Empty;
283
   end Empty_Project;
284
 
285
   ------------------
286
   -- Empty_String --
287
   ------------------
288
 
289
   function Empty_String return Name_Id is
290
   begin
291
      return The_Empty_String;
292
   end Empty_String;
293
 
294
   ------------
295
   -- Expect --
296
   ------------
297
 
298
   procedure Expect (The_Token : Token_Type; Token_Image : String) is
299
   begin
300
      if Token /= The_Token then
301
         --  ??? Should pass user flags here instead
302
         Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr);
303
      end if;
304
   end Expect;
305
 
306
   -----------------
307
   -- Extend_Name --
308
   -----------------
309
 
310
   function Extend_Name
311
     (File        : File_Name_Type;
312
      With_Suffix : String) return File_Name_Type
313
   is
314
      Last : Positive;
315
 
316
   begin
317
      Get_Name_String (File);
318
      Last := Name_Len + 1;
319
 
320
      while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
321
         Name_Len := Name_Len - 1;
322
      end loop;
323
 
324
      if Name_Len <= 1 then
325
         Name_Len := Last;
326
      end if;
327
 
328
      for J in With_Suffix'Range loop
329
         Name_Buffer (Name_Len) := With_Suffix (J);
330
         Name_Len := Name_Len + 1;
331
      end loop;
332
 
333
      Name_Len := Name_Len - 1;
334
      return Name_Find;
335
 
336
   end Extend_Name;
337
 
338
   ---------------------
339
   -- Project_Changed --
340
   ---------------------
341
 
342
   procedure Project_Changed (Iter : in out Source_Iterator) is
343
   begin
344
      Iter.Language := Iter.Project.Project.Languages;
345
      Language_Changed (Iter);
346
   end Project_Changed;
347
 
348
   ----------------------
349
   -- Language_Changed --
350
   ----------------------
351
 
352
   procedure Language_Changed (Iter : in out Source_Iterator) is
353
   begin
354
      Iter.Current  := No_Source;
355
 
356
      if Iter.Language_Name /= No_Name then
357
         while Iter.Language /= null
358
           and then Iter.Language.Name /= Iter.Language_Name
359
         loop
360
            Iter.Language := Iter.Language.Next;
361
         end loop;
362
      end if;
363
 
364
      --  If there is no matching language in this project, move to next
365
 
366
      if Iter.Language = No_Language_Index then
367
         if Iter.All_Projects then
368
            Iter.Project := Iter.Project.Next;
369
 
370
            if Iter.Project /= null then
371
               Project_Changed (Iter);
372
            end if;
373
 
374
         else
375
            Iter.Project := null;
376
         end if;
377
 
378
      else
379
         Iter.Current := Iter.Language.First_Source;
380
 
381
         if Iter.Current = No_Source then
382
            Iter.Language := Iter.Language.Next;
383
            Language_Changed (Iter);
384
         end if;
385
      end if;
386
   end Language_Changed;
387
 
388
   ---------------------
389
   -- For_Each_Source --
390
   ---------------------
391
 
392
   function For_Each_Source
393
     (In_Tree  : Project_Tree_Ref;
394
      Project  : Project_Id := No_Project;
395
      Language : Name_Id := No_Name) return Source_Iterator
396
   is
397
      Iter : Source_Iterator;
398
   begin
399
      Iter := Source_Iterator'
400
        (In_Tree       => In_Tree,
401
         Project       => In_Tree.Projects,
402
         All_Projects  => Project = No_Project,
403
         Language_Name => Language,
404
         Language      => No_Language_Index,
405
         Current       => No_Source);
406
 
407
      if Project /= null then
408
         while Iter.Project /= null
409
           and then Iter.Project.Project /= Project
410
         loop
411
            Iter.Project := Iter.Project.Next;
412
         end loop;
413
      end if;
414
 
415
      Project_Changed (Iter);
416
 
417
      return Iter;
418
   end For_Each_Source;
419
 
420
   -------------
421
   -- Element --
422
   -------------
423
 
424
   function Element (Iter : Source_Iterator) return Source_Id is
425
   begin
426
      return Iter.Current;
427
   end Element;
428
 
429
   ----------
430
   -- Next --
431
   ----------
432
 
433
   procedure Next (Iter : in out Source_Iterator) is
434
   begin
435
      Iter.Current := Iter.Current.Next_In_Lang;
436
      if Iter.Current = No_Source then
437
         Iter.Language := Iter.Language.Next;
438
         Language_Changed (Iter);
439
      end if;
440
   end Next;
441
 
442
   --------------------------------
443
   -- For_Every_Project_Imported --
444
   --------------------------------
445
 
446
   procedure For_Every_Project_Imported
447
     (By             : Project_Id;
448
      With_State     : in out State;
449
      Imported_First : Boolean := False)
450
   is
451
      use Project_Boolean_Htable;
452
      Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil;
453
 
454
      procedure Recursive_Check (Project : Project_Id);
455
      --  Check if a project has already been seen. If not seen, mark it as
456
      --  Seen, Call Action, and check all its imported projects.
457
 
458
      ---------------------
459
      -- Recursive_Check --
460
      ---------------------
461
 
462
      procedure Recursive_Check (Project : Project_Id) is
463
         List : Project_List;
464
 
465
      begin
466
         if not Get (Seen, Project) then
467
            Set (Seen, Project, True);
468
 
469
            if not Imported_First then
470
               Action (Project, With_State);
471
            end if;
472
 
473
            --  Visited all extended projects
474
 
475
            if Project.Extends /= No_Project then
476
               Recursive_Check (Project.Extends);
477
            end if;
478
 
479
            --  Visited all imported projects
480
 
481
            List := Project.Imported_Projects;
482
            while List /= null loop
483
               Recursive_Check (List.Project);
484
               List := List.Next;
485
            end loop;
486
 
487
            if Imported_First then
488
               Action (Project, With_State);
489
            end if;
490
         end if;
491
      end Recursive_Check;
492
 
493
   --  Start of processing for For_Every_Project_Imported
494
 
495
   begin
496
      Recursive_Check (Project => By);
497
      Reset (Seen);
498
   end For_Every_Project_Imported;
499
 
500
   -----------------
501
   -- Find_Source --
502
   -----------------
503
 
504
   function Find_Source
505
     (In_Tree          : Project_Tree_Ref;
506
      Project          : Project_Id;
507
      In_Imported_Only : Boolean := False;
508
      In_Extended_Only : Boolean := False;
509
      Base_Name        : File_Name_Type) return Source_Id
510
   is
511
      Result : Source_Id  := No_Source;
512
 
513
      procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id);
514
      --  Look for Base_Name in the sources of Proj
515
 
516
      ----------------------
517
      -- Look_For_Sources --
518
      ----------------------
519
 
520
      procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id) is
521
         Iterator : Source_Iterator;
522
 
523
      begin
524
         Iterator := For_Each_Source (In_Tree => In_Tree, Project => Proj);
525
         while Element (Iterator) /= No_Source loop
526
            if Element (Iterator).File = Base_Name then
527
               Src := Element (Iterator);
528
               return;
529
            end if;
530
 
531
            Next (Iterator);
532
         end loop;
533
      end Look_For_Sources;
534
 
535
      procedure For_Imported_Projects is new For_Every_Project_Imported
536
        (State => Source_Id, Action => Look_For_Sources);
537
 
538
      Proj : Project_Id;
539
 
540
   --  Start of processing for Find_Source
541
 
542
   begin
543
      if In_Extended_Only then
544
         Proj := Project;
545
         while Proj /= No_Project loop
546
            Look_For_Sources (Proj, Result);
547
            exit when Result /= No_Source;
548
 
549
            Proj := Proj.Extends;
550
         end loop;
551
 
552
      elsif In_Imported_Only then
553
         Look_For_Sources (Project, Result);
554
 
555
         if Result = No_Source then
556
            For_Imported_Projects
557
              (By         => Project,
558
               With_State => Result);
559
         end if;
560
      else
561
         Look_For_Sources (No_Project, Result);
562
      end if;
563
 
564
      return Result;
565
   end Find_Source;
566
 
567
   ----------
568
   -- Hash --
569
   ----------
570
 
571
   function Hash is new System.HTable.Hash (Header_Num => Header_Num);
572
   --  Used in implementation of other functions Hash below
573
 
574
   function Hash (Name : File_Name_Type) return Header_Num is
575
   begin
576
      return Hash (Get_Name_String (Name));
577
   end Hash;
578
 
579
   function Hash (Name : Name_Id) return Header_Num is
580
   begin
581
      return Hash (Get_Name_String (Name));
582
   end Hash;
583
 
584
   function Hash (Name : Path_Name_Type) return Header_Num is
585
   begin
586
      return Hash (Get_Name_String (Name));
587
   end Hash;
588
 
589
   function Hash (Project : Project_Id) return Header_Num is
590
   begin
591
      if Project = No_Project then
592
         return Header_Num'First;
593
      else
594
         return Hash (Get_Name_String (Project.Name));
595
      end if;
596
   end Hash;
597
 
598
   -----------
599
   -- Image --
600
   -----------
601
 
602
   function Image (The_Casing : Casing_Type) return String is
603
   begin
604
      return The_Casing_Images (The_Casing).all;
605
   end Image;
606
 
607
   -----------------------------
608
   -- Is_Standard_GNAT_Naming --
609
   -----------------------------
610
 
611
   function Is_Standard_GNAT_Naming
612
     (Naming : Lang_Naming_Data) return Boolean
613
   is
614
   begin
615
      return Get_Name_String (Naming.Spec_Suffix) = ".ads"
616
        and then Get_Name_String (Naming.Body_Suffix) = ".adb"
617
        and then Get_Name_String (Naming.Dot_Replacement) = "-";
618
   end Is_Standard_GNAT_Naming;
619
 
620
   ----------------
621
   -- Initialize --
622
   ----------------
623
 
624
   procedure Initialize (Tree : Project_Tree_Ref) is
625
   begin
626
      if The_Empty_String = No_Name then
627
         Uintp.Initialize;
628
         Name_Len := 0;
629
         The_Empty_String := Name_Find;
630
 
631
         Prj.Attr.Initialize;
632
         Set_Name_Table_Byte (Name_Project,  Token_Type'Pos (Tok_Project));
633
         Set_Name_Table_Byte (Name_Extends,  Token_Type'Pos (Tok_Extends));
634
         Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
635
      end if;
636
 
637
      if Tree /= No_Project_Tree then
638
         Reset (Tree);
639
      end if;
640
   end Initialize;
641
 
642
   ------------------
643
   -- Is_Extending --
644
   ------------------
645
 
646
   function Is_Extending
647
     (Extending : Project_Id;
648
      Extended  : Project_Id) return Boolean
649
   is
650
      Proj : Project_Id;
651
 
652
   begin
653
      Proj := Extending;
654
      while Proj /= No_Project loop
655
         if Proj = Extended then
656
            return True;
657
         end if;
658
 
659
         Proj := Proj.Extends;
660
      end loop;
661
 
662
      return False;
663
   end Is_Extending;
664
 
665
   -----------------
666
   -- Object_Name --
667
   -----------------
668
 
669
   function Object_Name
670
     (Source_File_Name   : File_Name_Type;
671
      Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
672
   is
673
   begin
674
      if Object_File_Suffix = No_Name then
675
         return Extend_Name
676
           (Source_File_Name, Object_Suffix);
677
      else
678
         return Extend_Name
679
           (Source_File_Name, Get_Name_String (Object_File_Suffix));
680
      end if;
681
   end Object_Name;
682
 
683
   function Object_Name
684
     (Source_File_Name   : File_Name_Type;
685
      Source_Index       : Int;
686
      Index_Separator    : Character;
687
      Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
688
   is
689
      Index_Img : constant String := Source_Index'Img;
690
      Last      : Natural;
691
 
692
   begin
693
      Get_Name_String (Source_File_Name);
694
 
695
      Last := Name_Len;
696
      while Last > 1 and then Name_Buffer (Last) /= '.' loop
697
         Last := Last - 1;
698
      end loop;
699
 
700
      if Last > 1 then
701
         Name_Len := Last - 1;
702
      end if;
703
 
704
      Add_Char_To_Name_Buffer (Index_Separator);
705
      Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
706
 
707
      if Object_File_Suffix = No_Name then
708
         Add_Str_To_Name_Buffer (Object_Suffix);
709
      else
710
         Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix));
711
      end if;
712
 
713
      return Name_Find;
714
   end Object_Name;
715
 
716
   ----------------------
717
   -- Record_Temp_File --
718
   ----------------------
719
 
720
   procedure Record_Temp_File
721
     (Tree : Project_Tree_Ref;
722
      Path : Path_Name_Type)
723
   is
724
   begin
725
      Temp_Files_Table.Append (Tree.Private_Part.Temp_Files, Path);
726
   end Record_Temp_File;
727
 
728
   ----------
729
   -- Free --
730
   ----------
731
 
732
   procedure Free (Project : in out Project_Id) is
733
      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
734
        (Project_Data, Project_Id);
735
 
736
   begin
737
      if Project /= null then
738
         Free (Project.Ada_Include_Path);
739
         Free (Project.Objects_Path);
740
         Free (Project.Ada_Objects_Path);
741
         Free_List (Project.Imported_Projects, Free_Project => False);
742
         Free_List (Project.All_Imported_Projects, Free_Project => False);
743
         Free_List (Project.Languages);
744
 
745
         Unchecked_Free (Project);
746
      end if;
747
   end Free;
748
 
749
   ---------------
750
   -- Free_List --
751
   ---------------
752
 
753
   procedure Free_List (Languages : in out Language_List) is
754
      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
755
        (Language_List_Element, Language_List);
756
      Tmp : Language_List;
757
   begin
758
      while Languages /= null loop
759
         Tmp := Languages.Next;
760
         Unchecked_Free (Languages);
761
         Languages := Tmp;
762
      end loop;
763
   end Free_List;
764
 
765
   ---------------
766
   -- Free_List --
767
   ---------------
768
 
769
   procedure Free_List (Source : in out Source_Id) is
770
      procedure Unchecked_Free is new
771
        Ada.Unchecked_Deallocation (Source_Data, Source_Id);
772
 
773
      Tmp : Source_Id;
774
 
775
   begin
776
      while Source /= No_Source loop
777
         Tmp := Source.Next_In_Lang;
778
         Free_List (Source.Alternate_Languages);
779
 
780
         if Source.Unit /= null
781
           and then Source.Kind in Spec_Or_Body
782
         then
783
            Source.Unit.File_Names (Source.Kind) := null;
784
         end if;
785
 
786
         Unchecked_Free (Source);
787
         Source := Tmp;
788
      end loop;
789
   end Free_List;
790
 
791
   ---------------
792
   -- Free_List --
793
   ---------------
794
 
795
   procedure Free_List
796
     (List         : in out Project_List;
797
      Free_Project : Boolean)
798
   is
799
      procedure Unchecked_Free is new
800
        Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
801
 
802
      Tmp : Project_List;
803
 
804
   begin
805
      while List /= null loop
806
         Tmp := List.Next;
807
 
808
         if Free_Project then
809
            Free (List.Project);
810
         end if;
811
 
812
         Unchecked_Free (List);
813
         List := Tmp;
814
      end loop;
815
   end Free_List;
816
 
817
   ---------------
818
   -- Free_List --
819
   ---------------
820
 
821
   procedure Free_List (Languages : in out Language_Ptr) is
822
      procedure Unchecked_Free is new
823
        Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
824
 
825
      Tmp : Language_Ptr;
826
 
827
   begin
828
      while Languages /= null loop
829
         Tmp := Languages.Next;
830
         Free_List (Languages.First_Source);
831
         Unchecked_Free (Languages);
832
         Languages := Tmp;
833
      end loop;
834
   end Free_List;
835
 
836
   ----------------
837
   -- Free_Units --
838
   ----------------
839
 
840
   procedure Free_Units (Table : in out Units_Htable.Instance) is
841
      procedure Unchecked_Free is new
842
        Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
843
 
844
      Unit : Unit_Index;
845
 
846
   begin
847
      Unit := Units_Htable.Get_First (Table);
848
      while Unit /= No_Unit_Index loop
849
         if Unit.File_Names (Spec) /= null then
850
            Unit.File_Names (Spec).Unit := No_Unit_Index;
851
         end if;
852
 
853
         if Unit.File_Names (Impl) /= null then
854
            Unit.File_Names (Impl).Unit := No_Unit_Index;
855
         end if;
856
 
857
         Unchecked_Free (Unit);
858
         Unit := Units_Htable.Get_Next (Table);
859
      end loop;
860
 
861
      Units_Htable.Reset (Table);
862
   end Free_Units;
863
 
864
   ----------
865
   -- Free --
866
   ----------
867
 
868
   procedure Free (Tree : in out Project_Tree_Ref) is
869
      procedure Unchecked_Free is new
870
        Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref);
871
 
872
   begin
873
      if Tree /= null then
874
         Name_List_Table.Free (Tree.Name_Lists);
875
         Number_List_Table.Free (Tree.Number_Lists);
876
         String_Element_Table.Free (Tree.String_Elements);
877
         Variable_Element_Table.Free (Tree.Variable_Elements);
878
         Array_Element_Table.Free (Tree.Array_Elements);
879
         Array_Table.Free (Tree.Arrays);
880
         Package_Table.Free (Tree.Packages);
881
         Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
882
 
883
         Free_List (Tree.Projects, Free_Project => True);
884
         Free_Units (Tree.Units_HT);
885
 
886
         --  Private part
887
 
888
         Temp_Files_Table.Free  (Tree.Private_Part.Temp_Files);
889
 
890
         Unchecked_Free (Tree);
891
      end if;
892
   end Free;
893
 
894
   -----------
895
   -- Reset --
896
   -----------
897
 
898
   procedure Reset (Tree : Project_Tree_Ref) is
899
   begin
900
      --  Visible tables
901
 
902
      Name_List_Table.Init          (Tree.Name_Lists);
903
      Number_List_Table.Init        (Tree.Number_Lists);
904
      String_Element_Table.Init     (Tree.String_Elements);
905
      Variable_Element_Table.Init   (Tree.Variable_Elements);
906
      Array_Element_Table.Init      (Tree.Array_Elements);
907
      Array_Table.Init              (Tree.Arrays);
908
      Package_Table.Init            (Tree.Packages);
909
      Source_Paths_Htable.Reset     (Tree.Source_Paths_HT);
910
 
911
      Free_List (Tree.Projects, Free_Project => True);
912
      Free_Units (Tree.Units_HT);
913
 
914
      --  Private part table
915
 
916
      Temp_Files_Table.Init       (Tree.Private_Part.Temp_Files);
917
 
918
      Tree.Private_Part.Current_Source_Path_File := No_Path;
919
      Tree.Private_Part.Current_Object_Path_File := No_Path;
920
   end Reset;
921
 
922
   -------------------
923
   -- Switches_Name --
924
   -------------------
925
 
926
   function Switches_Name
927
     (Source_File_Name : File_Name_Type) return File_Name_Type
928
   is
929
   begin
930
      return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
931
   end Switches_Name;
932
 
933
   -----------
934
   -- Value --
935
   -----------
936
 
937
   function Value (Image : String) return Casing_Type is
938
   begin
939
      for Casing in The_Casing_Images'Range loop
940
         if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
941
            return Casing;
942
         end if;
943
      end loop;
944
 
945
      raise Constraint_Error;
946
   end Value;
947
 
948
   ---------------------
949
   -- Has_Ada_Sources --
950
   ---------------------
951
 
952
   function Has_Ada_Sources (Data : Project_Id) return Boolean is
953
      Lang : Language_Ptr;
954
 
955
   begin
956
      Lang := Data.Languages;
957
      while Lang /= No_Language_Index loop
958
         if Lang.Name = Name_Ada then
959
            return Lang.First_Source /= No_Source;
960
         end if;
961
         Lang := Lang.Next;
962
      end loop;
963
 
964
      return False;
965
   end Has_Ada_Sources;
966
 
967
   ------------------------
968
   -- Contains_ALI_Files --
969
   ------------------------
970
 
971
   function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
972
      Dir_Name : constant String := Get_Name_String (Dir);
973
      Direct   : Dir_Type;
974
      Name     : String (1 .. 1_000);
975
      Last     : Natural;
976
      Result   : Boolean := False;
977
 
978
   begin
979
      Open (Direct, Dir_Name);
980
 
981
      --  For each file in the directory, check if it is an ALI file
982
 
983
      loop
984
         Read (Direct, Name, Last);
985
         exit when Last = 0;
986
         Canonical_Case_File_Name (Name (1 .. Last));
987
         Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
988
         exit when Result;
989
      end loop;
990
 
991
      Close (Direct);
992
      return Result;
993
 
994
   exception
995
      --  If there is any problem, close the directory if open and return True.
996
      --  The library directory will be added to the path.
997
 
998
      when others =>
999
         if Is_Open (Direct) then
1000
            Close (Direct);
1001
         end if;
1002
 
1003
         return True;
1004
   end Contains_ALI_Files;
1005
 
1006
   --------------------------
1007
   -- Get_Object_Directory --
1008
   --------------------------
1009
 
1010
   function Get_Object_Directory
1011
     (Project             : Project_Id;
1012
      Including_Libraries : Boolean;
1013
      Only_If_Ada         : Boolean := False) return Path_Name_Type
1014
   is
1015
   begin
1016
      if (Project.Library and then Including_Libraries)
1017
        or else
1018
          (Project.Object_Directory /= No_Path_Information
1019
            and then (not Including_Libraries or else not Project.Library))
1020
      then
1021
         --  For a library project, add the library ALI directory if there is
1022
         --  no object directory or if the library ALI directory contains ALI
1023
         --  files; otherwise add the object directory.
1024
 
1025
         if Project.Library then
1026
            if Project.Object_Directory = No_Path_Information
1027
              or else Contains_ALI_Files (Project.Library_ALI_Dir.Name)
1028
            then
1029
               return Project.Library_ALI_Dir.Name;
1030
            else
1031
               return Project.Object_Directory.Name;
1032
            end if;
1033
 
1034
            --  For a non-library project, add object directory if it is not a
1035
            --  virtual project, and if there are Ada sources in the project or
1036
            --  one of the projects it extends. If there are no Ada sources,
1037
            --  adding the object directory could disrupt the order of the
1038
            --  object dirs in the path.
1039
 
1040
         elsif not Project.Virtual then
1041
            declare
1042
               Add_Object_Dir : Boolean;
1043
               Prj            : Project_Id;
1044
 
1045
            begin
1046
               Add_Object_Dir := not Only_If_Ada;
1047
               Prj := Project;
1048
               while not Add_Object_Dir and then Prj /= No_Project loop
1049
                  if Has_Ada_Sources (Prj) then
1050
                     Add_Object_Dir := True;
1051
                  else
1052
                     Prj := Prj.Extends;
1053
                  end if;
1054
               end loop;
1055
 
1056
               if Add_Object_Dir then
1057
                  return Project.Object_Directory.Name;
1058
               end if;
1059
            end;
1060
         end if;
1061
      end if;
1062
 
1063
      return No_Path;
1064
   end Get_Object_Directory;
1065
 
1066
   -----------------------------------
1067
   -- Ultimate_Extending_Project_Of --
1068
   -----------------------------------
1069
 
1070
   function Ultimate_Extending_Project_Of
1071
     (Proj : Project_Id) return Project_Id
1072
   is
1073
      Prj : Project_Id;
1074
 
1075
   begin
1076
      Prj := Proj;
1077
      while Prj /= null and then Prj.Extended_By /= No_Project loop
1078
         Prj := Prj.Extended_By;
1079
      end loop;
1080
 
1081
      return Prj;
1082
   end Ultimate_Extending_Project_Of;
1083
 
1084
   -----------------------------------
1085
   -- Compute_All_Imported_Projects --
1086
   -----------------------------------
1087
 
1088
   procedure Compute_All_Imported_Projects (Tree : Project_Tree_Ref) is
1089
      Project : Project_Id;
1090
 
1091
      procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean);
1092
      --  Recursively add the projects imported by project Project, but not
1093
      --  those that are extended.
1094
 
1095
      -------------------
1096
      -- Recursive_Add --
1097
      -------------------
1098
 
1099
      procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean) is
1100
         pragma Unreferenced (Dummy);
1101
         List    : Project_List;
1102
         Prj2    : Project_Id;
1103
 
1104
      begin
1105
         --  A project is not importing itself
1106
 
1107
         Prj2 := Ultimate_Extending_Project_Of (Prj);
1108
 
1109
         if Project /= Prj2 then
1110
 
1111
            --  Check that the project is not already in the list. We know the
1112
            --  one passed to Recursive_Add have never been visited before, but
1113
            --  the one passed it are the extended projects.
1114
 
1115
            List := Project.All_Imported_Projects;
1116
            while List /= null loop
1117
               if List.Project = Prj2 then
1118
                  return;
1119
               end if;
1120
 
1121
               List := List.Next;
1122
            end loop;
1123
 
1124
            --  Add it to the list
1125
 
1126
            Project.All_Imported_Projects :=
1127
              new Project_List_Element'
1128
                (Project => Prj2,
1129
                 Next    => Project.All_Imported_Projects);
1130
         end if;
1131
      end Recursive_Add;
1132
 
1133
      procedure For_All_Projects is
1134
        new For_Every_Project_Imported (Boolean, Recursive_Add);
1135
 
1136
      Dummy : Boolean := False;
1137
      List  : Project_List;
1138
 
1139
   begin
1140
      List := Tree.Projects;
1141
      while List /= null loop
1142
         Project := List.Project;
1143
         Free_List (Project.All_Imported_Projects, Free_Project => False);
1144
         For_All_Projects (Project, Dummy);
1145
         List := List.Next;
1146
      end loop;
1147
   end Compute_All_Imported_Projects;
1148
 
1149
   -------------------
1150
   -- Is_Compilable --
1151
   -------------------
1152
 
1153
   function Is_Compilable (Source : Source_Id) return Boolean is
1154
   begin
1155
      return Source.Language.Config.Compiler_Driver /= No_File
1156
        and then Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0
1157
        and then not Source.Locally_Removed;
1158
   end Is_Compilable;
1159
 
1160
   ------------------------------
1161
   -- Object_To_Global_Archive --
1162
   ------------------------------
1163
 
1164
   function Object_To_Global_Archive (Source : Source_Id) return Boolean is
1165
   begin
1166
      return Source.Language.Config.Kind = File_Based
1167
        and then Source.Kind = Impl
1168
        and then Source.Language.Config.Objects_Linked
1169
        and then Is_Compilable (Source)
1170
        and then Source.Language.Config.Object_Generated;
1171
   end Object_To_Global_Archive;
1172
 
1173
   ----------------------------
1174
   -- Get_Language_From_Name --
1175
   ----------------------------
1176
 
1177
   function Get_Language_From_Name
1178
     (Project : Project_Id;
1179
      Name    : String) return Language_Ptr
1180
   is
1181
      N      : Name_Id;
1182
      Result : Language_Ptr;
1183
 
1184
   begin
1185
      Name_Len := Name'Length;
1186
      Name_Buffer (1 .. Name_Len) := Name;
1187
      To_Lower (Name_Buffer (1 .. Name_Len));
1188
      N := Name_Find;
1189
 
1190
      Result := Project.Languages;
1191
      while Result /= No_Language_Index loop
1192
         if Result.Name = N then
1193
            return Result;
1194
         end if;
1195
 
1196
         Result := Result.Next;
1197
      end loop;
1198
 
1199
      return No_Language_Index;
1200
   end Get_Language_From_Name;
1201
 
1202
   ----------------
1203
   -- Other_Part --
1204
   ----------------
1205
 
1206
   function Other_Part (Source : Source_Id) return Source_Id is
1207
   begin
1208
      if Source.Unit /= No_Unit_Index then
1209
         case Source.Kind is
1210
            when Impl =>
1211
               return Source.Unit.File_Names (Spec);
1212
            when Spec =>
1213
               return Source.Unit.File_Names (Impl);
1214
            when Sep =>
1215
               return No_Source;
1216
         end case;
1217
      else
1218
         return No_Source;
1219
      end if;
1220
   end Other_Part;
1221
 
1222
   ------------------
1223
   -- Create_Flags --
1224
   ------------------
1225
 
1226
   function Create_Flags
1227
     (Report_Error               : Error_Handler;
1228
      When_No_Sources            : Error_Warning;
1229
      Require_Sources_Other_Lang : Boolean := True;
1230
      Allow_Duplicate_Basenames  : Boolean := True;
1231
      Compiler_Driver_Mandatory  : Boolean := False;
1232
      Error_On_Unknown_Language  : Boolean := True;
1233
      Require_Obj_Dirs           : Error_Warning := Error)
1234
      return Processing_Flags
1235
   is
1236
   begin
1237
      return Processing_Flags'
1238
        (Report_Error               => Report_Error,
1239
         When_No_Sources            => When_No_Sources,
1240
         Require_Sources_Other_Lang => Require_Sources_Other_Lang,
1241
         Allow_Duplicate_Basenames  => Allow_Duplicate_Basenames,
1242
         Error_On_Unknown_Language  => Error_On_Unknown_Language,
1243
         Compiler_Driver_Mandatory  => Compiler_Driver_Mandatory,
1244
         Require_Obj_Dirs           => Require_Obj_Dirs);
1245
   end Create_Flags;
1246
 
1247
   ------------
1248
   -- Length --
1249
   ------------
1250
 
1251
   function Length
1252
     (Table : Name_List_Table.Instance;
1253
      List  : Name_List_Index) return Natural
1254
   is
1255
      Count : Natural := 0;
1256
      Tmp   : Name_List_Index;
1257
 
1258
   begin
1259
      Tmp := List;
1260
      while Tmp /= No_Name_List loop
1261
         Count := Count + 1;
1262
         Tmp := Table.Table (Tmp).Next;
1263
      end loop;
1264
 
1265
      return Count;
1266
   end Length;
1267
 
1268
begin
1269
   --  Make sure that the standard config and user project file extensions are
1270
   --  compatible with canonical case file naming.
1271
 
1272
   Canonical_Case_File_Name (Config_Project_File_Extension);
1273
   Canonical_Case_File_Name (Project_File_Extension);
1274
end Prj;

powered by: WebSVN 2.1.0

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