]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/ada/prj-env.adb
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
3psoccon.ads, [...]: Files added.
[thirdparty/gcc.git] / gcc / ada / prj-env.adb
CommitLineData
19235870
RK		 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- P R J . E N V --
6-- --
7-- B o d y --
8-- --
fbf5a39b 9-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
19235870
RK		 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 2, 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 COPYING. If not, write --
19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20-- MA 02111-1307, USA. --
21-- --
22-- GNAT was originally developed by the GNAT team at New York University. --
71ff80dc 23-- Extensive contributions were provided by Ada Core Technologies Inc. --
19235870
RK		 24-- --
25------------------------------------------------------------------------------
26
fbf5a39b 27with Namet; use Namet;
19235870 28with Opt;
fbf5a39b
AC		 29with Osint; use Osint;
30with Output; use Output;
31with Prj.Com; use Prj.Com;
19235870 32with Table;
fbf5a39b
AC		 33with Tempdir;
34
35with GNAT.OS_Lib; use GNAT.OS_Lib;
19235870
RK		 36
37package body Prj.Env is
38
39 type Naming_Id is new Nat;
19235870 40
fbf5a39b
AC		 41 Current_Source_Path_File : Name_Id := No_Name;
42 -- Current value of project source path file env var.
43 -- Used to avoid setting the env var to the same value.
44
45 Current_Object_Path_File : Name_Id := No_Name;
46 -- Current value of project object path file env var.
47 -- Used to avoid setting the env var to the same value.
48
49 Ada_Path_Buffer : String_Access := new String (1 .. 1024);
19235870
RK		 50 -- A buffer where values for ADA_INCLUDE_PATH
51 -- and ADA_OBJECTS_PATH are stored.
52
53 Ada_Path_Length : Natural := 0;
54 -- Index of the last valid character in Ada_Path_Buffer.
55
fbf5a39b
AC		 56 Ada_Prj_Include_File_Set : Boolean := False;
57 Ada_Prj_Objects_File_Set : Boolean := False;
58 -- These flags are set to True when the corresponding environment variables
59 -- are set and are used to give these environment variables an empty string
60 -- value at the end of the program. This has no practical effect on most
61 -- platforms, except on VMS where the logical names are deassigned, thus
62 -- avoiding the pollution of the environment of the caller.
63
19235870
RK		 64 package Namings is new Table.Table (
65 Table_Component_Type => Naming_Data,
66 Table_Index_Type => Naming_Id,
67 Table_Low_Bound => 1,
68 Table_Initial => 5,
69 Table_Increment => 100,
70 Table_Name => "Prj.Env.Namings");
71
72 Default_Naming : constant Naming_Id := Namings.First;
73
07fc65c4
GB		 74 Fill_Mapping_File : Boolean := True;
75
fbf5a39b
AC		 76 package Path_Files is new Table.Table (
77 Table_Component_Type => Name_Id,
78 Table_Index_Type => Natural,
79 Table_Low_Bound => 1,
80 Table_Initial => 50,
81 Table_Increment => 50,
82 Table_Name => "Prj.Env.Path_Files");
83 -- Table storing all the temp path file names.
84 -- Used by Delete_All_Path_Files.
85
86 type Project_Flags is array (Project_Id range <>) of Boolean;
87 -- A Boolean array type used in Create_Mapping_File to select the projects
88 -- in the closure of a specific project.
89
19235870
RK		 90 -----------------------
91 -- Local Subprograms --
92 -----------------------
93
94 function Body_Path_Name_Of (Unit : Unit_Id) return String;
95 -- Returns the path name of the body of a unit.
96 -- Compute it first, if necessary.
97
98 function Spec_Path_Name_Of (Unit : Unit_Id) return String;
99 -- Returns the path name of the spec of a unit.
100 -- Compute it first, if necessary.
101
07fc65c4
GB		 102 procedure Add_To_Path (Source_Dirs : String_List_Id);
103 -- Add to Ada_Path_Buffer all the source directories in string list
104 -- Source_Dirs, if any. Increment Ada_Path_Length.
105
fbf5a39b
AC		 106 procedure Add_To_Path (Dir : String);
107 -- If Dir is not already in the global variable Ada_Path_Buffer, add it.
108 -- Increment Ada_Path_Length.
109 -- If Ada_Path_Length /= 0, prepend a Path_Separator character to
110 -- Path.
111
112 procedure Add_To_Path_File
113 (Source_Dirs : String_List_Id;
114 Path_File : File_Descriptor);
115 -- Add to Ada_Path_Buffer all the source directories in string list
116 -- Source_Dirs, if any. Increment Ada_Path_Length.
117
118 procedure Add_To_Path_File
119 (Path : String;
120 Path_File : File_Descriptor);
121 -- Add Path to path file
122
123 procedure Create_New_Path_File
124 (Path_FD : out File_Descriptor;
125 Path_Name : out Name_Id);
126 -- Create a new temporary path file. Get the file name in Path_Name.
127 -- The name is normally obtained by increasing the number in
128 -- Temp_Path_File_Name by 1.
129
130 procedure Set_Path_File_Var (Name : String; Value : String);
131 -- Call Setenv, after calling To_Host_File_Spec
132
133 function Ultimate_Extension_Of (Project : in Project_Id) return Project_Id;
134 -- Return a project that is either Project or an extended ancestor of
135 -- Project that itself is not extended.
19235870
RK		 136
137 ----------------------
138 -- Ada_Include_Path --
139 ----------------------
140
141 function Ada_Include_Path (Project : Project_Id) return String_Access is
142
143 procedure Add (Project : Project_Id);
07fc65c4
GB		 144 -- Add all the source directories of a project to the path only if
145 -- this project has not been visited. Calls itself recursively for
fbf5a39b 146 -- projects being extended, and imported projects. Adds the project
07fc65c4 147 -- to the list Seen if this is the call to Add for this project.
19235870
RK		 148
149 ---------
150 -- Add --
151 ---------
152
153 procedure Add (Project : Project_Id) is
154 begin
07fc65c4 155 -- If Seen is empty, then the project cannot have been visited
19235870
RK		 156
157 if not Projects.Table (Project).Seen then
158 Projects.Table (Project).Seen := True;
159
160 declare
fbf5a39b 161 Data : constant Project_Data := Projects.Table (Project);
19235870
RK		 162 List : Project_List := Data.Imported_Projects;
163
19235870
RK		 164 begin
165 -- Add to path all source directories of this project
166
07fc65c4 167 Add_To_Path (Data.Source_Dirs);
19235870 168
fbf5a39b 169 -- Call Add to the project being extended, if any
19235870 170
fbf5a39b
AC		 171 if Data.Extends /= No_Project then
172 Add (Data.Extends);
19235870
RK		 173 end if;
174
175 -- Call Add for each imported project, if any
176
177 while List /= Empty_Project_List loop
178 Add (Project_Lists.Table (List).Project);
179 List := Project_Lists.Table (List).Next;
180 end loop;
181 end;
182 end if;
19235870
RK		 183 end Add;
184
185 -- Start of processing for Ada_Include_Path
186
187 begin
188 -- If it is the first time we call this function for
189 -- this project, compute the source path
190
fbf5a39b 191 if Projects.Table (Project).Ada_Include_Path = null then
19235870
RK		 192 Ada_Path_Length := 0;
193
194 for Index in 1 .. Projects.Last loop
195 Projects.Table (Index).Seen := False;
196 end loop;
197
198 Add (Project);
fbf5a39b 199 Projects.Table (Project).Ada_Include_Path :=
19235870
RK		 200 new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
201 end if;
202
fbf5a39b 203 return Projects.Table (Project).Ada_Include_Path;
19235870
RK		 204 end Ada_Include_Path;
205
07fc65c4
GB		 206 function Ada_Include_Path
207 (Project : Project_Id;
208 Recursive : Boolean)
209 return String
210 is
211 begin
212 if Recursive then
213 return Ada_Include_Path (Project).all;
214 else
215 Ada_Path_Length := 0;
216 Add_To_Path (Projects.Table (Project).Source_Dirs);
217 return Ada_Path_Buffer (1 .. Ada_Path_Length);
218 end if;
219 end Ada_Include_Path;
220
19235870
RK		 221 ----------------------
222 -- Ada_Objects_Path --
223 ----------------------
224
225 function Ada_Objects_Path
226 (Project : Project_Id;
227 Including_Libraries : Boolean := True)
07fc65c4
GB		 228 return String_Access
229 is
19235870 230 procedure Add (Project : Project_Id);
07fc65c4
GB		 231 -- Add all the object directories of a project to the path only if
232 -- this project has not been visited. Calls itself recursively for
fbf5a39b 233 -- projects being extended, and imported projects. Adds the project
07fc65c4 234 -- to the list Seen if this is the first call to Add for this project.
19235870
RK		 235
236 ---------
237 -- Add --
238 ---------
239
240 procedure Add (Project : Project_Id) is
241 begin
19235870
RK		 242 -- If this project has not been seen yet
243
244 if not Projects.Table (Project).Seen then
245 Projects.Table (Project).Seen := True;
246
247 declare
fbf5a39b 248 Data : constant Project_Data := Projects.Table (Project);
19235870
RK		 249 List : Project_List := Data.Imported_Projects;
250
251 begin
252 -- Add to path the object directory of this project
253 -- except if we don't include library project and
254 -- this is a library project.
255
256 if (Data.Library and then Including_Libraries)
257 or else
258 (Data.Object_Directory /= No_Name
259 and then
260 (not Including_Libraries or else not Data.Library))
261 then
fbf5a39b 262 -- For a library project, add the library directory
19235870
RK		 263
264 if Data.Library then
fbf5a39b 265 Add_To_Path (Get_Name_String (Data.Library_Dir));
19235870 266
fbf5a39b 267 else
19235870 268 -- For a non library project, add the object directory
fbf5a39b
AC		 269
270 Add_To_Path (Get_Name_String (Data.Object_Directory));
19235870
RK		 271 end if;
272 end if;
273
fbf5a39b 274 -- Call Add to the project being extended, if any
19235870 275
fbf5a39b
AC		 276 if Data.Extends /= No_Project then
277 Add (Data.Extends);
19235870
RK		 278 end if;
279
280 -- Call Add for each imported project, if any
281
282 while List /= Empty_Project_List loop
283 Add (Project_Lists.Table (List).Project);
284 List := Project_Lists.Table (List).Next;
285 end loop;
286 end;
287
288 end if;
289 end Add;
290
291 -- Start of processing for Ada_Objects_Path
292
293 begin
294 -- If it is the first time we call this function for
295 -- this project, compute the objects path
296
fbf5a39b 297 if Projects.Table (Project).Ada_Objects_Path = null then
19235870
RK		 298 Ada_Path_Length := 0;
299
300 for Index in 1 .. Projects.Last loop
301 Projects.Table (Index).Seen := False;
302 end loop;
303
304 Add (Project);
fbf5a39b 305 Projects.Table (Project).Ada_Objects_Path :=
19235870
RK		 306 new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
307 end if;
308
fbf5a39b 309 return Projects.Table (Project).Ada_Objects_Path;
19235870
RK		 310 end Ada_Objects_Path;
311
312 -----------------
313 -- Add_To_Path --
314 -----------------
315
07fc65c4
GB		 316 procedure Add_To_Path (Source_Dirs : String_List_Id) is
317 Current : String_List_Id := Source_Dirs;
318 Source_Dir : String_Element;
319
320 begin
321 while Current /= Nil_String loop
07fc65c4 322 Source_Dir := String_Elements.Table (Current);
fbf5a39b 323 Add_To_Path (Get_Name_String (Source_Dir.Value));
07fc65c4
GB		 324 Current := Source_Dir.Next;
325 end loop;
326 end Add_To_Path;
327
fbf5a39b
AC		 328 procedure Add_To_Path (Dir : String) is
329 Len : Natural;
330 New_Buffer : String_Access;
331 Min_Len : Natural;
332
333 function Is_Present (Path : String; Dir : String) return Boolean;
334 -- Return True if Dir is part of Path
335
336 ----------------
337 -- Is_Present --
338 ----------------
339
340 function Is_Present (Path : String; Dir : String) return Boolean is
341 Last : constant Integer := Path'Last - Dir'Length + 1;
342 begin
343 for J in Path'First .. Last loop
344 -- Note: the order of the conditions below is important, since
345 -- it ensures a minimal number of string comparisons.
346
347 if (J = Path'First
348 or else Path (J - 1) = Path_Separator)
349 and then
350 (J + Dir'Length > Path'Last
351 or else Path (J + Dir'Length) = Path_Separator)
352 and then Dir = Path (J .. J + Dir'Length - 1)
353 then
354 return True;
355 end if;
356 end loop;
357
358 return False;
359 end Is_Present;
360
19235870 361 begin
fbf5a39b
AC		 362 if Is_Present (Ada_Path_Buffer (1 .. Ada_Path_Length), Dir) then
363 -- Dir is already in the path, nothing to do
19235870 364
fbf5a39b
AC		 365 return;
366 end if;
19235870 367
fbf5a39b
AC		 368 Min_Len := Ada_Path_Length + Dir'Length;
369
370 if Ada_Path_Length > 0 then
371 -- Add 1 for the Path_Separator character
372
373 Min_Len := Min_Len + 1;
374 end if;
375
376 -- If Ada_Path_Buffer is too small, increase it
377
378 Len := Ada_Path_Buffer'Last;
379
380 if Len < Min_Len then
381 loop
382 Len := Len * 2;
383 exit when Len >= Min_Len;
384 end loop;
385
386 New_Buffer := new String (1 .. Len);
387 New_Buffer (1 .. Ada_Path_Length) :=
388 Ada_Path_Buffer (1 .. Ada_Path_Length);
389 Free (Ada_Path_Buffer);
390 Ada_Path_Buffer := New_Buffer;
391 end if;
392
393 if Ada_Path_Length > 0 then
394 Ada_Path_Length := Ada_Path_Length + 1;
395 Ada_Path_Buffer (Ada_Path_Length) := Path_Separator;
19235870
RK		 396 end if;
397
398 Ada_Path_Buffer
fbf5a39b
AC		 399 (Ada_Path_Length + 1 .. Ada_Path_Length + Dir'Length) := Dir;
400 Ada_Path_Length := Ada_Path_Length + Dir'Length;
19235870
RK		 401 end Add_To_Path;
402
fbf5a39b
AC		 403 ----------------------
404 -- Add_To_Path_File --
405 ----------------------
406
407 procedure Add_To_Path_File
408 (Source_Dirs : String_List_Id;
409 Path_File : File_Descriptor)
410 is
411 Current : String_List_Id := Source_Dirs;
412 Source_Dir : String_Element;
413
414 begin
415 while Current /= Nil_String loop
416 Source_Dir := String_Elements.Table (Current);
417 Add_To_Path_File (Get_Name_String (Source_Dir.Value), Path_File);
418 Current := Source_Dir.Next;
419 end loop;
420 end Add_To_Path_File;
421
422 procedure Add_To_Path_File
423 (Path : String;
424 Path_File : File_Descriptor)
425 is
426 Line : String (1 .. Path'Length + 1);
427 Len : Natural;
428
429 begin
430 Line (1 .. Path'Length) := Path;
431 Line (Line'Last) := ASCII.LF;
432 Len := Write (Path_File, Line (1)'Address, Line'Length);
433
434 if Len /= Line'Length then
435 Prj.Com.Fail ("disk full");
436 end if;
437 end Add_To_Path_File;
438
19235870
RK		 439 -----------------------
440 -- Body_Path_Name_Of --
441 -----------------------
442
443 function Body_Path_Name_Of (Unit : Unit_Id) return String is
444 Data : Unit_Data := Units.Table (Unit);
445
446 begin
447 -- If we don't know the path name of the body of this unit,
448 -- we compute it, and we store it.
449
450 if Data.File_Names (Body_Part).Path = No_Name then
451 declare
452 Current_Source : String_List_Id :=
453 Projects.Table (Data.File_Names (Body_Part).Project).Sources;
454 Path : GNAT.OS_Lib.String_Access;
455
456 begin
457 -- By default, put the file name
458
459 Data.File_Names (Body_Part).Path :=
460 Data.File_Names (Body_Part).Name;
461
462 -- For each source directory
463
464 while Current_Source /= Nil_String loop
19235870
RK		 465 Path :=
466 Locate_Regular_File
fbf5a39b
AC		 467 (Namet.Get_Name_String
468 (Data.File_Names (Body_Part).Name),
469 Namet.Get_Name_String
470 (String_Elements.Table (Current_Source).Value));
19235870
RK		 471
472 -- If the file is in this directory,
473 -- then we store the path, and we are done.
474
475 if Path /= null then
476 Name_Len := Path'Length;
477 Name_Buffer (1 .. Name_Len) := Path.all;
478 Data.File_Names (Body_Part).Path := Name_Enter;
479 exit;
480
481 else
482 Current_Source :=
483 String_Elements.Table (Current_Source).Next;
484 end if;
485 end loop;
486
487 Units.Table (Unit) := Data;
488 end;
489 end if;
490
491 -- Returned the value stored
492
493 return Namet.Get_Name_String (Data.File_Names (Body_Part).Path);
494 end Body_Path_Name_Of;
495
496 --------------------------------
497 -- Create_Config_Pragmas_File --
498 --------------------------------
499
500 procedure Create_Config_Pragmas_File
fbf5a39b
AC		 501 (For_Project : Project_Id;
502 Main_Project : Project_Id;
503 Include_Config_Files : Boolean := True)
19235870 504 is
fbf5a39b
AC		 505 pragma Unreferenced (Main_Project);
506 pragma Unreferenced (Include_Config_Files);
19235870 507
fbf5a39b
AC		 508 File_Name : Name_Id := No_Name;
509 File : File_Descriptor := Invalid_FD;
19235870
RK		 510
511 Current_Unit : Unit_Id := Units.First;
512
513 First_Project : Project_List := Empty_Project_List;
514
515 Current_Project : Project_List;
516 Current_Naming : Naming_Id;
517
fbf5a39b
AC		 518 Status : Boolean;
519 -- For call to Close
19235870
RK		 520
521 procedure Check (Project : Project_Id);
522
523 procedure Check_Temp_File;
524 -- Check that a temporary file has been opened.
525 -- If not, create one, and put its name in the project data,
526 -- with the indication that it is a temporary file.
527
19235870
RK		 528 procedure Put
529 (Unit_Name : Name_Id;
530 File_Name : Name_Id;
531 Unit_Kind : Spec_Or_Body);
532 -- Put an SFN pragma in the temporary file.
533
534 procedure Put (File : File_Descriptor; S : String);
535
536 procedure Put_Line (File : File_Descriptor; S : String);
537
538 -----------
539 -- Check --
540 -----------
541
542 procedure Check (Project : Project_Id) is
543 Data : constant Project_Data := Projects.Table (Project);
544
545 begin
546 if Current_Verbosity = High then
547 Write_Str ("Checking project file """);
548 Write_Str (Namet.Get_Name_String (Data.Name));
549 Write_Str (""".");
550 Write_Eol;
551 end if;
552
553 -- Is this project in the list of the visited project?
554
555 Current_Project := First_Project;
556 while Current_Project /= Empty_Project_List
557 and then Project_Lists.Table (Current_Project).Project /= Project
558 loop
559 Current_Project := Project_Lists.Table (Current_Project).Next;
560 end loop;
561
562 -- If it is not, put it in the list, and visit it
563
564 if Current_Project = Empty_Project_List then
565 Project_Lists.Increment_Last;
566 Project_Lists.Table (Project_Lists.Last) :=
567 (Project => Project, Next => First_Project);
568 First_Project := Project_Lists.Last;
569
570 -- Is the naming scheme of this project one that we know?
571
572 Current_Naming := Default_Naming;
573 while Current_Naming <= Namings.Last and then
574 not Same_Naming_Scheme
575 (Left => Namings.Table (Current_Naming),
576 Right => Data.Naming) loop
577 Current_Naming := Current_Naming + 1;
578 end loop;
579
580 -- If we don't know it, add it
581
582 if Current_Naming > Namings.Last then
583 Namings.Increment_Last;
584 Namings.Table (Namings.Last) := Data.Naming;
585
586 -- We need a temporary file to be created
587
588 Check_Temp_File;
589
590 -- Put the SFN pragmas for the naming scheme
591
592 -- Spec
593
594 Put_Line
fbf5a39b 595 (File, "pragma Source_File_Name_Project");
19235870
RK		 596 Put_Line
597 (File, " (Spec_File_Name => ""*" &
b30668b7 598 Namet.Get_Name_String (Data.Naming.Current_Spec_Suffix) &
19235870
RK		 599 """,");
600 Put_Line
601 (File, " Casing => " &
602 Image (Data.Naming.Casing) & ",");
603 Put_Line
604 (File, " Dot_Replacement => """ &
605 Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
606 """);");
607
608 -- and body
609
610 Put_Line
fbf5a39b 611 (File, "pragma Source_File_Name_Project");
19235870
RK		 612 Put_Line
613 (File, " (Body_File_Name => ""*" &
fbf5a39b 614 Namet.Get_Name_String (Data.Naming.Current_Body_Suffix) &
19235870
RK		 615 """,");
616 Put_Line
617 (File, " Casing => " &
618 Image (Data.Naming.Casing) & ",");
619 Put_Line
620 (File, " Dot_Replacement => """ &
621 Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
622 """);");
623
624 -- and maybe separate
625
b30668b7 626 if
fbf5a39b 627 Data.Naming.Current_Body_Suffix /= Data.Naming.Separate_Suffix
b30668b7 628 then
19235870 629 Put_Line
fbf5a39b 630 (File, "pragma Source_File_Name_Project");
19235870
RK		 631 Put_Line
632 (File, " (Subunit_File_Name => ""*" &
b30668b7 633 Namet.Get_Name_String (Data.Naming.Separate_Suffix) &
19235870
RK		 634 """,");
635 Put_Line
636 (File, " Casing => " &
637 Image (Data.Naming.Casing) &
638 ",");
639 Put_Line
640 (File, " Dot_Replacement => """ &
641 Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
642 """);");
643 end if;
644 end if;
645
fbf5a39b
AC		 646 if Data.Extends /= No_Project then
647 Check (Data.Extends);
19235870
RK		 648 end if;
649
650 declare
651 Current : Project_List := Data.Imported_Projects;
652
653 begin
654 while Current /= Empty_Project_List loop
655 Check (Project_Lists.Table (Current).Project);
656 Current := Project_Lists.Table (Current).Next;
657 end loop;
658 end;
659 end if;
660 end Check;
661
662 ---------------------
663 -- Check_Temp_File --
664 ---------------------
665
666 procedure Check_Temp_File is
667 begin
668 if File = Invalid_FD then
fbf5a39b
AC		 669 Tempdir.Create_Temp_File (File, Name => File_Name);
670
19235870 671 if File = Invalid_FD then
fbf5a39b 672 Prj.Com.Fail
19235870
RK		 673 ("unable to create temporary configuration pragmas file");
674 elsif Opt.Verbose_Mode then
675 Write_Str ("Creating temp file """);
fbf5a39b 676 Write_Str (Get_Name_String (File_Name));
19235870
RK		 677 Write_Line ("""");
678 end if;
679 end if;
680 end Check_Temp_File;
681
19235870
RK		 682 ---------
683 -- Put --
684 ---------
685
686 procedure Put
687 (Unit_Name : Name_Id;
688 File_Name : Name_Id;
689 Unit_Kind : Spec_Or_Body)
690 is
691 begin
692 -- A temporary file needs to be open
693
694 Check_Temp_File;
695
696 -- Put the pragma SFN for the unit kind (spec or body)
697
fbf5a39b 698 Put (File, "pragma Source_File_Name_Project (");
19235870
RK		 699 Put (File, Namet.Get_Name_String (Unit_Name));
700
701 if Unit_Kind = Specification then
702 Put (File, ", Spec_File_Name => """);
703 else
704 Put (File, ", Body_File_Name => """);
705 end if;
706
707 Put (File, Namet.Get_Name_String (File_Name));
708 Put_Line (File, """);");
709 end Put;
710
711 procedure Put (File : File_Descriptor; S : String) is
712 Last : Natural;
713
714 begin
715 Last := Write (File, S (S'First)'Address, S'Length);
716
717 if Last /= S'Length then
fbf5a39b 718 Prj.Com.Fail ("Disk full");
19235870
RK		 719 end if;
720
721 if Current_Verbosity = High then
722 Write_Str (S);
723 end if;
724 end Put;
725
726 --------------
727 -- Put_Line --
728 --------------
729
730 procedure Put_Line (File : File_Descriptor; S : String) is
731 S0 : String (1 .. S'Length + 1);
732 Last : Natural;
733
734 begin
07fc65c4
GB		 735 -- Add an ASCII.LF to the string. As this gnat.adc is supposed to
736 -- be used only by the compiler, we don't care about the characters
737 -- for the end of line. In fact we could have put a space, but
738 -- it is more convenient to be able to read gnat.adc during
739 -- development, for which the ASCII.LF is fine.
19235870
RK		 740
741 S0 (1 .. S'Length) := S;
742 S0 (S0'Last) := ASCII.LF;
743 Last := Write (File, S0'Address, S0'Length);
744
745 if Last /= S'Length + 1 then
fbf5a39b 746 Prj.Com.Fail ("Disk full");
19235870
RK		 747 end if;
748
749 if Current_Verbosity = High then
750 Write_Line (S);
751 end if;
752 end Put_Line;
753
754 -- Start of processing for Create_Config_Pragmas_File
755
756 begin
19235870
RK		 757 if not Projects.Table (For_Project).Config_Checked then
758
759 -- Remove any memory of processed naming schemes, if any
760
761 Namings.Set_Last (Default_Naming);
762
763 -- Check the naming schemes
764
765 Check (For_Project);
766
767 -- Visit all the units and process those that need an SFN pragma
768
769 while Current_Unit <= Units.Last loop
770 declare
771 Unit : constant Unit_Data :=
772 Units.Table (Current_Unit);
773
774 begin
775 if Unit.File_Names (Specification).Needs_Pragma then
776 Put (Unit.Name,
777 Unit.File_Names (Specification).Name,
778 Specification);
779 end if;
780
781 if Unit.File_Names (Body_Part).Needs_Pragma then
782 Put (Unit.Name,
783 Unit.File_Names (Body_Part).Name,
784 Body_Part);
785 end if;
786
787 Current_Unit := Current_Unit + 1;
788 end;
789 end loop;
790
fbf5a39b
AC		 791 -- If there are no non standard naming scheme, issue the GNAT
792 -- standard naming scheme. This will tell the compiler that
793 -- a project file is used and will forbid any pragma SFN.
19235870 794
fbf5a39b
AC		 795 if File = Invalid_FD then
796 Check_Temp_File;
19235870 797
fbf5a39b
AC		 798 Put_Line (File, "pragma Source_File_Name_Project");
799 Put_Line (File, " (Spec_File_Name => ""*.ads"",");
800 Put_Line (File, " Dot_Replacement => ""-"",");
801 Put_Line (File, " Casing => lowercase);");
07fc65c4 802
fbf5a39b
AC		 803 Put_Line (File, "pragma Source_File_Name_Project");
804 Put_Line (File, " (Body_File_Name => ""*.adb"",");
805 Put_Line (File, " Dot_Replacement => ""-"",");
806 Put_Line (File, " Casing => lowercase);");
19235870
RK		 807 end if;
808
fbf5a39b 809 -- Close the temporary file
19235870 810
fbf5a39b 811 GNAT.OS_Lib.Close (File, Status);
19235870 812
fbf5a39b
AC		 813 if not Status then
814 Prj.Com.Fail ("disk full");
815 end if;
19235870 816
fbf5a39b
AC		 817 if Opt.Verbose_Mode then
818 Write_Str ("Closing configuration file """);
819 Write_Str (Get_Name_String (File_Name));
820 Write_Line ("""");
19235870
RK		 821 end if;
822
fbf5a39b
AC		 823 Projects.Table (For_Project).Config_File_Name := File_Name;
824 Projects.Table (For_Project).Config_File_Temp := True;
825
19235870 826 Projects.Table (For_Project).Config_Checked := True;
19235870 827 end if;
19235870
RK		 828 end Create_Config_Pragmas_File;
829
6510f4c9
GB		 830 -------------------------
831 -- Create_Mapping_File --
832 -------------------------
833
fbf5a39b
AC		 834 procedure Create_Mapping_File
835 (Project : Project_Id;
836 Name : out Name_Id)
837 is
6510f4c9
GB		 838 File : File_Descriptor := Invalid_FD;
839 The_Unit_Data : Unit_Data;
840 Data : File_Name_Data;
841
fbf5a39b
AC		 842 Status : Boolean;
843 -- For call to Close
844
845 Present : Project_Flags (No_Project .. Projects.Last) :=
846 (others => False);
847 -- For each project in the closure of Project, the corresponding flag
848 -- will be set to True;
849
07fc65c4
GB		 850 procedure Put_Name_Buffer;
851 -- Put the line contained in the Name_Buffer in the mapping file
6510f4c9
GB		 852
853 procedure Put_Data (Spec : Boolean);
854 -- Put the mapping of the spec or body contained in Data in the file
855 -- (3 lines).
856
fbf5a39b
AC		 857 procedure Recursive_Flag (Prj : Project_Id);
858 -- Set the flags corresponding to Prj, the projects it imports
859 -- (directly or indirectly) or extends to True. Call itself recursively.
860
17c5c8a5
GB		 861 ---------
862 -- Put --
863 ---------
864
07fc65c4 865 procedure Put_Name_Buffer is
6510f4c9
GB		 866 Last : Natural;
867
868 begin
07fc65c4
GB		 869 Name_Len := Name_Len + 1;
870 Name_Buffer (Name_Len) := ASCII.LF;
871 Last := Write (File, Name_Buffer (1)'Address, Name_Len);
6510f4c9 872
07fc65c4 873 if Last /= Name_Len then
fbf5a39b 874 Prj.Com.Fail ("Disk full");
6510f4c9 875 end if;
07fc65c4 876 end Put_Name_Buffer;
6510f4c9 877
17c5c8a5
GB		 878 --------------
879 -- Put_Data --
880 --------------
881
6510f4c9
GB		 882 procedure Put_Data (Spec : Boolean) is
883 begin
07fc65c4
GB		 884 -- Line with the unit name
885
886 Get_Name_String (The_Unit_Data.Name);
887 Name_Len := Name_Len + 1;
888 Name_Buffer (Name_Len) := '%';
889 Name_Len := Name_Len + 1;
6510f4c9
GB		 890
891 if Spec then
07fc65c4 892 Name_Buffer (Name_Len) := 's';
6510f4c9 893 else
07fc65c4 894 Name_Buffer (Name_Len) := 'b';
6510f4c9
GB		 895 end if;
896
07fc65c4
GB		 897 Put_Name_Buffer;
898
fbf5a39b 899 -- Line with the file name
07fc65c4
GB		 900
901 Get_Name_String (Data.Name);
902 Put_Name_Buffer;
903
904 -- Line with the path name
905
906 Get_Name_String (Data.Path);
907 Put_Name_Buffer;
908
6510f4c9
GB		 909 end Put_Data;
910
fbf5a39b
AC		 911 --------------------
912 -- Recursive_Flag --
913 --------------------
914
915 procedure Recursive_Flag (Prj : Project_Id) is
916 Imported : Project_List;
917 Proj : Project_Id;
918
919 begin
920 -- Nothing to do for non existent project or project that has
921 -- already been flagged.
922
923 if Prj = No_Project or else Present (Prj) then
924 return;
925 end if;
926
927 -- Flag the current project
928
929 Present (Prj) := True;
930 Imported := Projects.Table (Prj).Imported_Projects;
931
932 -- Call itself for each project directly imported
933
934 while Imported /= Empty_Project_List loop
935 Proj := Project_Lists.Table (Imported).Project;
936 Imported := Project_Lists.Table (Imported).Next;
937 Recursive_Flag (Proj);
938 end loop;
939
940 -- Call itself for an eventual project being extended
941
942 Recursive_Flag (Projects.Table (Prj).Extends);
943 end Recursive_Flag;
944
17c5c8a5
GB		 945 -- Start of processing for Create_Mapping_File
946
6510f4c9 947 begin
fbf5a39b
AC		 948 -- Flag the necessary projects
949
950 Recursive_Flag (Project);
951
952 -- Create the temporary file
953
954 Tempdir.Create_Temp_File (File, Name => Name);
6510f4c9
GB		 955
956 if File = Invalid_FD then
fbf5a39b 957 Prj.Com.Fail ("unable to create temporary mapping file");
6510f4c9
GB		 958
959 elsif Opt.Verbose_Mode then
960 Write_Str ("Creating temp mapping file """);
fbf5a39b 961 Write_Str (Get_Name_String (Name));
6510f4c9
GB		 962 Write_Line ("""");
963 end if;
964
07fc65c4
GB		 965 if Fill_Mapping_File then
966 -- For all units in table Units
6510f4c9 967
07fc65c4
GB		 968 for Unit in 1 .. Units.Last loop
969 The_Unit_Data := Units.Table (Unit);
6510f4c9 970
07fc65c4 971 -- If the unit has a valid name
6510f4c9 972
07fc65c4
GB		 973 if The_Unit_Data.Name /= No_Name then
974 Data := The_Unit_Data.File_Names (Specification);
6510f4c9 975
fbf5a39b
AC		 976 -- If there is a spec, put it mapping in the file if it is
977 -- from a project in the closure of Project.
6510f4c9 978
fbf5a39b 979 if Data.Name /= No_Name and then Present (Data.Project) then
07fc65c4
GB		 980 Put_Data (Spec => True);
981 end if;
6510f4c9 982
07fc65c4 983 Data := The_Unit_Data.File_Names (Body_Part);
6510f4c9 984
07fc65c4 985 -- If there is a body (or subunit) put its mapping in the file
fbf5a39b 986 -- if it is from a project in the closure of Project.
6510f4c9 987
fbf5a39b 988 if Data.Name /= No_Name and then Present (Data.Project) then
07fc65c4
GB		 989 Put_Data (Spec => False);
990 end if;
6510f4c9 991
07fc65c4
GB		 992 end if;
993 end loop;
994 end if;
6510f4c9 995
fbf5a39b
AC		 996 GNAT.OS_Lib.Close (File, Status);
997
998 if not Status then
999 Prj.Com.Fail ("disk full");
1000 end if;
6510f4c9
GB		 1001
1002 end Create_Mapping_File;
1003
fbf5a39b
AC		 1004 --------------------------
1005 -- Create_New_Path_File --
1006 --------------------------
1007
1008 procedure Create_New_Path_File
1009 (Path_FD : out File_Descriptor;
1010 Path_Name : out Name_Id)
1011 is
1012 begin
1013 Tempdir.Create_Temp_File (Path_FD, Path_Name);
1014
1015 if Path_Name /= No_Name then
1016
1017 -- Record the name, so that the temp path file will be deleted
1018 -- at the end of the program.
1019
1020 Path_Files.Increment_Last;
1021 Path_Files.Table (Path_Files.Last) := Path_Name;
1022 end if;
1023 end Create_New_Path_File;
1024
1025 ---------------------------
1026 -- Delete_All_Path_Files --
1027 ---------------------------
1028
1029 procedure Delete_All_Path_Files is
1030 Disregard : Boolean := True;
1031
1032 begin
1033 for Index in 1 .. Path_Files.Last loop
1034 if Path_Files.Table (Index) /= No_Name then
1035 Delete_File
1036 (Get_Name_String (Path_Files.Table (Index)), Disregard);
1037 end if;
1038 end loop;
1039
1040 -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1041 -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1042 -- the empty string. On VMS, this has the effect of deassigning
1043 -- the logical names.
1044
1045 if Ada_Prj_Include_File_Set then
1046 Setenv (Project_Include_Path_File, "");
1047 Ada_Prj_Include_File_Set := False;
1048 end if;
1049
1050 if Ada_Prj_Objects_File_Set then
1051 Setenv (Project_Objects_Path_File, "");
1052 Ada_Prj_Objects_File_Set := False;
1053 end if;
1054 end Delete_All_Path_Files;
1055
19235870
RK		 1056 ------------------------------------
1057 -- File_Name_Of_Library_Unit_Body --
1058 ------------------------------------
1059
1060 function File_Name_Of_Library_Unit_Body
fbf5a39b
AC		 1061 (Name : String;
1062 Project : Project_Id;
1063 Main_Project_Only : Boolean := True)
1064 return String
19235870 1065 is
fbf5a39b
AC		 1066 The_Project : Project_Id := Project;
1067 Data : Project_Data := Projects.Table (Project);
19235870
RK		 1068 Original_Name : String := Name;
1069
1070 Extended_Spec_Name : String :=
1071 Name & Namet.Get_Name_String
b30668b7 1072 (Data.Naming.Current_Spec_Suffix);
19235870
RK		 1073 Extended_Body_Name : String :=
1074 Name & Namet.Get_Name_String
fbf5a39b 1075 (Data.Naming.Current_Body_Suffix);
19235870
RK		 1076
1077 Unit : Unit_Data;
1078
1079 The_Original_Name : Name_Id;
1080 The_Spec_Name : Name_Id;
1081 The_Body_Name : Name_Id;
1082
1083 begin
1084 Canonical_Case_File_Name (Original_Name);
1085 Name_Len := Original_Name'Length;
1086 Name_Buffer (1 .. Name_Len) := Original_Name;
1087 The_Original_Name := Name_Find;
1088
1089 Canonical_Case_File_Name (Extended_Spec_Name);
1090 Name_Len := Extended_Spec_Name'Length;
1091 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1092 The_Spec_Name := Name_Find;
1093
1094 Canonical_Case_File_Name (Extended_Body_Name);
1095 Name_Len := Extended_Body_Name'Length;
1096 Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1097 The_Body_Name := Name_Find;
1098
1099 if Current_Verbosity = High then
1100 Write_Str ("Looking for file name of """);
1101 Write_Str (Name);
1102 Write_Char ('"');
1103 Write_Eol;
1104 Write_Str (" Extended Spec Name = """);
1105 Write_Str (Extended_Spec_Name);
1106 Write_Char ('"');
1107 Write_Eol;
1108 Write_Str (" Extended Body Name = """);
1109 Write_Str (Extended_Body_Name);
1110 Write_Char ('"');
1111 Write_Eol;
1112 end if;
1113
fbf5a39b
AC		 1114 -- For extending project, search in the extended project
1115 -- if the source is not found. For non extending projects,
1116 -- this loop will be run only once.
19235870 1117
fbf5a39b
AC		 1118 loop
1119 -- For every unit
19235870 1120
fbf5a39b
AC		 1121 for Current in reverse Units.First .. Units.Last loop
1122 Unit := Units.Table (Current);
19235870 1123
fbf5a39b 1124 -- Check for body
19235870 1125
fbf5a39b
AC		 1126 if not Main_Project_Only
1127 or else Unit.File_Names (Body_Part).Project = The_Project
1128 then
1129 declare
1130 Current_Name : constant Name_Id :=
1131 Unit.File_Names (Body_Part).Name;
19235870 1132
fbf5a39b
AC		 1133 begin
1134 -- Case of a body present
19235870 1135
fbf5a39b 1136 if Current_Name /= No_Name then
19235870 1137 if Current_Verbosity = High then
fbf5a39b
AC		 1138 Write_Str (" Comparing with """);
1139 Write_Str (Get_Name_String (Current_Name));
1140 Write_Char ('"');
1141 Write_Eol;
19235870
RK		 1142 end if;
1143
fbf5a39b
AC		 1144 -- If it has the name of the original name,
1145 -- return the original name
19235870 1146
fbf5a39b
AC		 1147 if Unit.Name = The_Original_Name
1148 or else Current_Name = The_Original_Name
1149 then
1150 if Current_Verbosity = High then
1151 Write_Line (" OK");
1152 end if;
19235870 1153
fbf5a39b 1154 return Get_Name_String (Current_Name);
19235870 1155
fbf5a39b
AC		 1156 -- If it has the name of the extended body name,
1157 -- return the extended body name
19235870 1158
fbf5a39b
AC		 1159 elsif Current_Name = The_Body_Name then
1160 if Current_Verbosity = High then
1161 Write_Line (" OK");
1162 end if;
19235870 1163
fbf5a39b 1164 return Extended_Body_Name;
19235870 1165
fbf5a39b
AC		 1166 else
1167 if Current_Verbosity = High then
1168 Write_Line (" not good");
1169 end if;
1170 end if;
1171 end if;
1172 end;
1173 end if;
19235870 1174
fbf5a39b 1175 -- Check for spec
19235870 1176
fbf5a39b
AC		 1177 if not Main_Project_Only
1178 or else Unit.File_Names (Specification).Project = The_Project
1179 then
1180 declare
1181 Current_Name : constant Name_Id :=
1182 Unit.File_Names (Specification).Name;
19235870 1183
fbf5a39b
AC		 1184 begin
1185 -- Case of spec present
19235870 1186
fbf5a39b 1187 if Current_Name /= No_Name then
19235870 1188 if Current_Verbosity = High then
fbf5a39b
AC		 1189 Write_Str (" Comparing with """);
1190 Write_Str (Get_Name_String (Current_Name));
1191 Write_Char ('"');
1192 Write_Eol;
19235870
RK		 1193 end if;
1194
fbf5a39b
AC		 1195 -- If name same as the original name, return original
1196 -- name.
19235870 1197
fbf5a39b
AC		 1198 if Unit.Name = The_Original_Name
1199 or else Current_Name = The_Original_Name
1200 then
1201 if Current_Verbosity = High then
1202 Write_Line (" OK");
1203 end if;
19235870 1204
fbf5a39b 1205 return Get_Name_String (Current_Name);
19235870 1206
fbf5a39b
AC		 1207 -- If it has the same name as the extended spec name,
1208 -- return the extended spec name.
19235870 1209
fbf5a39b
AC		 1210 elsif Current_Name = The_Spec_Name then
1211 if Current_Verbosity = High then
1212 Write_Line (" OK");
1213 end if;
1214
1215 return Extended_Spec_Name;
1216
1217 else
1218 if Current_Verbosity = High then
1219 Write_Line (" not good");
1220 end if;
19235870
RK		 1221 end if;
1222 end if;
fbf5a39b
AC		 1223 end;
1224 end if;
1225 end loop;
1226
1227 -- If we are not in an extending project, give up
1228
1229 exit when (not Main_Project_Only) or else Data.Extends = No_Project;
1230
1231 -- Otherwise, look in the project we are extending
1232
1233 The_Project := Data.Extends;
1234 Data := Projects.Table (The_Project);
19235870
RK		 1235 end loop;
1236
1237 -- We don't know this file name, return an empty string
1238
1239 return "";
1240 end File_Name_Of_Library_Unit_Body;
1241
1242 -------------------------
1243 -- For_All_Object_Dirs --
1244 -------------------------
1245
1246 procedure For_All_Object_Dirs (Project : Project_Id) is
1247 Seen : Project_List := Empty_Project_List;
1248
1249 procedure Add (Project : Project_Id);
1250 -- Process a project. Remember the processes visited to avoid
1251 -- processing a project twice. Recursively process an eventual
fbf5a39b 1252 -- extended project, and all imported projects.
19235870
RK		 1253
1254 ---------
1255 -- Add --
1256 ---------
1257
1258 procedure Add (Project : Project_Id) is
1259 Data : constant Project_Data := Projects.Table (Project);
1260 List : Project_List := Data.Imported_Projects;
1261
1262 begin
1263 -- If the list of visited project is empty, then
1264 -- for sure we never visited this project.
1265
1266 if Seen = Empty_Project_List then
1267 Project_Lists.Increment_Last;
1268 Seen := Project_Lists.Last;
1269 Project_Lists.Table (Seen) :=
1270 (Project => Project, Next => Empty_Project_List);
1271
1272 else
1273 -- Check if the project is in the list
1274
1275 declare
1276 Current : Project_List := Seen;
1277
1278 begin
1279 loop
1280 -- If it is, then there is nothing else to do
1281
1282 if Project_Lists.Table (Current).Project = Project then
1283 return;
1284 end if;
1285
1286 exit when Project_Lists.Table (Current).Next =
1287 Empty_Project_List;
1288 Current := Project_Lists.Table (Current).Next;
1289 end loop;
1290
1291 -- This project has never been visited, add it
1292 -- to the list.
1293
1294 Project_Lists.Increment_Last;
1295 Project_Lists.Table (Current).Next := Project_Lists.Last;
1296 Project_Lists.Table (Project_Lists.Last) :=
1297 (Project => Project, Next => Empty_Project_List);
1298 end;
1299 end if;
1300
1301 -- If there is an object directory, call Action
1302 -- with its name
1303
1304 if Data.Object_Directory /= No_Name then
1305 Get_Name_String (Data.Object_Directory);
1306 Action (Name_Buffer (1 .. Name_Len));
1307 end if;
1308
fbc9a404 1309 -- If we are extending a project, visit it
19235870 1310
fbf5a39b
AC		 1311 if Data.Extends /= No_Project then
1312 Add (Data.Extends);
19235870
RK		 1313 end if;
1314
1315 -- And visit all imported projects
1316
1317 while List /= Empty_Project_List loop
1318 Add (Project_Lists.Table (List).Project);
1319 List := Project_Lists.Table (List).Next;
1320 end loop;
1321 end Add;
1322
1323 -- Start of processing for For_All_Object_Dirs
1324
1325 begin
1326 -- Visit this project, and its imported projects,
1327 -- recursively
1328
1329 Add (Project);
1330 end For_All_Object_Dirs;
1331
1332 -------------------------
1333 -- For_All_Source_Dirs --
1334 -------------------------
1335
1336 procedure For_All_Source_Dirs (Project : Project_Id) is
1337 Seen : Project_List := Empty_Project_List;
1338
1339 procedure Add (Project : Project_Id);
1340 -- Process a project. Remember the processes visited to avoid
1341 -- processing a project twice. Recursively process an eventual
fbf5a39b 1342 -- extended project, and all imported projects.
19235870
RK		 1343
1344 ---------
1345 -- Add --
1346 ---------
1347
1348 procedure Add (Project : Project_Id) is
1349 Data : constant Project_Data := Projects.Table (Project);
1350 List : Project_List := Data.Imported_Projects;
1351
1352 begin
1353 -- If the list of visited project is empty, then
1354 -- for sure we never visited this project.
1355
1356 if Seen = Empty_Project_List then
1357 Project_Lists.Increment_Last;
1358 Seen := Project_Lists.Last;
1359 Project_Lists.Table (Seen) :=
1360 (Project => Project, Next => Empty_Project_List);
1361
1362 else
1363 -- Check if the project is in the list
1364
1365 declare
1366 Current : Project_List := Seen;
1367
1368 begin
1369 loop
1370 -- If it is, then there is nothing else to do
1371
1372 if Project_Lists.Table (Current).Project = Project then
1373 return;
1374 end if;
1375
1376 exit when Project_Lists.Table (Current).Next =
1377 Empty_Project_List;
1378 Current := Project_Lists.Table (Current).Next;
1379 end loop;
1380
1381 -- This project has never been visited, add it
1382 -- to the list.
1383
1384 Project_Lists.Increment_Last;
1385 Project_Lists.Table (Current).Next := Project_Lists.Last;
1386 Project_Lists.Table (Project_Lists.Last) :=
1387 (Project => Project, Next => Empty_Project_List);
1388 end;
1389 end if;
1390
1391 declare
1392 Current : String_List_Id := Data.Source_Dirs;
1393 The_String : String_Element;
1394
1395 begin
1396 -- Call action with the name of every source directorie
1397
1398 while Current /= Nil_String loop
1399 The_String := String_Elements.Table (Current);
fbf5a39b 1400 Action (Get_Name_String (The_String.Value));
19235870
RK		 1401 Current := The_String.Next;
1402 end loop;
1403 end;
1404
fbc9a404 1405 -- If we are extending a project, visit it
19235870 1406
fbf5a39b
AC		 1407 if Data.Extends /= No_Project then
1408 Add (Data.Extends);
19235870
RK		 1409 end if;
1410
1411 -- And visit all imported projects
1412
1413 while List /= Empty_Project_List loop
1414 Add (Project_Lists.Table (List).Project);
1415 List := Project_Lists.Table (List).Next;
1416 end loop;
1417 end Add;
1418
1419 -- Start of processing for For_All_Source_Dirs
1420
1421 begin
1422 -- Visit this project, and its imported projects recursively
1423
1424 Add (Project);
1425 end For_All_Source_Dirs;
1426
1427 -------------------
1428 -- Get_Reference --
1429 -------------------
1430
1431 procedure Get_Reference
1432 (Source_File_Name : String;
1433 Project : out Project_Id;
1434 Path : out Name_Id)
1435 is
1436 begin
1437 if Current_Verbosity > Default then
1438 Write_Str ("Getting Reference_Of (""");
1439 Write_Str (Source_File_Name);
1440 Write_Str (""") ... ");
1441 end if;
1442
1443 declare
1444 Original_Name : String := Source_File_Name;
1445 Unit : Unit_Data;
1446
1447 begin
1448 Canonical_Case_File_Name (Original_Name);
1449
1450 for Id in Units.First .. Units.Last loop
1451 Unit := Units.Table (Id);
1452
1453 if (Unit.File_Names (Specification).Name /= No_Name
1454 and then
1455 Namet.Get_Name_String
1456 (Unit.File_Names (Specification).Name) = Original_Name)
1457 or else (Unit.File_Names (Specification).Path /= No_Name
1458 and then
1459 Namet.Get_Name_String
1460 (Unit.File_Names (Specification).Path) =
1461 Original_Name)
1462 then
fbf5a39b
AC		 1463 Project := Ultimate_Extension_Of
1464 (Unit.File_Names (Specification).Project);
1465 Path := Unit.File_Names (Specification).Display_Path;
19235870
RK		 1466
1467 if Current_Verbosity > Default then
1468 Write_Str ("Done: Specification.");
1469 Write_Eol;
1470 end if;
1471
1472 return;
1473
1474 elsif (Unit.File_Names (Body_Part).Name /= No_Name
1475 and then
1476 Namet.Get_Name_String
1477 (Unit.File_Names (Body_Part).Name) = Original_Name)
1478 or else (Unit.File_Names (Body_Part).Path /= No_Name
1479 and then Namet.Get_Name_String
1480 (Unit.File_Names (Body_Part).Path) =
1481 Original_Name)
1482 then
fbf5a39b
AC		 1483 Project := Ultimate_Extension_Of
1484 (Unit.File_Names (Body_Part).Project);
1485 Path := Unit.File_Names (Body_Part).Display_Path;
19235870
RK		 1486
1487 if Current_Verbosity > Default then
1488 Write_Str ("Done: Body.");
1489 Write_Eol;
1490 end if;
1491
1492 return;
1493 end if;
1494
1495 end loop;
1496 end;
1497
1498 Project := No_Project;
1499 Path := No_Name;
1500
1501 if Current_Verbosity > Default then
1502 Write_Str ("Cannot be found.");
1503 Write_Eol;
1504 end if;
1505 end Get_Reference;
1506
1507 ----------------
1508 -- Initialize --
1509 ----------------
1510
1511 procedure Initialize is
19235870 1512 begin
fbf5a39b
AC		 1513 -- There is nothing to do anymore
1514
1515 null;
19235870
RK		 1516 end Initialize;
1517
1518 ------------------------------------
1519 -- Path_Name_Of_Library_Unit_Body --
1520 ------------------------------------
1521
1522 function Path_Name_Of_Library_Unit_Body
1523 (Name : String;
1524 Project : Project_Id)
1525 return String
1526 is
1527 Data : constant Project_Data := Projects.Table (Project);
1528 Original_Name : String := Name;
1529
1530 Extended_Spec_Name : String :=
1531 Name & Namet.Get_Name_String
b30668b7 1532 (Data.Naming.Current_Spec_Suffix);
19235870
RK		 1533 Extended_Body_Name : String :=
1534 Name & Namet.Get_Name_String
fbf5a39b 1535 (Data.Naming.Current_Body_Suffix);
19235870
RK		 1536
1537 First : Unit_Id := Units.First;
1538 Current : Unit_Id;
1539 Unit : Unit_Data;
1540
1541 begin
1542 Canonical_Case_File_Name (Original_Name);
1543 Canonical_Case_File_Name (Extended_Spec_Name);
fbf5a39b 1544 Canonical_Case_File_Name (Extended_Body_Name);
19235870
RK		 1545
1546 if Current_Verbosity = High then
1547 Write_Str ("Looking for path name of """);
1548 Write_Str (Name);
1549 Write_Char ('"');
1550 Write_Eol;
1551 Write_Str (" Extended Spec Name = """);
1552 Write_Str (Extended_Spec_Name);
1553 Write_Char ('"');
1554 Write_Eol;
1555 Write_Str (" Extended Body Name = """);
1556 Write_Str (Extended_Body_Name);
1557 Write_Char ('"');
1558 Write_Eol;
1559 end if;
1560
1561 while First <= Units.Last
1562 and then Units.Table (First).File_Names (Body_Part).Project /= Project
1563 loop
1564 First := First + 1;
1565 end loop;
1566
1567 Current := First;
1568 while Current <= Units.Last loop
1569 Unit := Units.Table (Current);
1570
1571 if Unit.File_Names (Body_Part).Project = Project
1572 and then Unit.File_Names (Body_Part).Name /= No_Name
1573 then
1574 declare
1575 Current_Name : constant String :=
1576 Namet.Get_Name_String (Unit.File_Names (Body_Part).Name);
1577 begin
1578 if Current_Verbosity = High then
1579 Write_Str (" Comparing with """);
1580 Write_Str (Current_Name);
1581 Write_Char ('"');
1582 Write_Eol;
1583 end if;
1584
1585 if Current_Name = Original_Name then
1586 if Current_Verbosity = High then
1587 Write_Line (" OK");
1588 end if;
1589
1590 return Body_Path_Name_Of (Current);
1591
1592 elsif Current_Name = Extended_Body_Name then
1593 if Current_Verbosity = High then
1594 Write_Line (" OK");
1595 end if;
1596
1597 return Body_Path_Name_Of (Current);
1598
1599 else
1600 if Current_Verbosity = High then
1601 Write_Line (" not good");
1602 end if;
1603 end if;
1604 end;
1605
1606 elsif Unit.File_Names (Specification).Name /= No_Name then
1607 declare
1608 Current_Name : constant String :=
1609 Namet.Get_Name_String
1610 (Unit.File_Names (Specification).Name);
1611
1612 begin
1613 if Current_Verbosity = High then
1614 Write_Str (" Comparing with """);
1615 Write_Str (Current_Name);
1616 Write_Char ('"');
1617 Write_Eol;
1618 end if;
1619
1620 if Current_Name = Original_Name then
1621 if Current_Verbosity = High then
1622 Write_Line (" OK");
1623 end if;
1624
1625 return Spec_Path_Name_Of (Current);
1626
1627 elsif Current_Name = Extended_Spec_Name then
1628
1629 if Current_Verbosity = High then
1630 Write_Line (" OK");
1631 end if;
1632
1633 return Spec_Path_Name_Of (Current);
1634
1635 else
1636 if Current_Verbosity = High then
1637 Write_Line (" not good");
1638 end if;
1639 end if;
1640 end;
1641 end if;
1642 Current := Current + 1;
1643 end loop;
1644
1645 return "";
1646 end Path_Name_Of_Library_Unit_Body;
1647
1648 -------------------
1649 -- Print_Sources --
1650 -------------------
1651
1652 procedure Print_Sources is
1653 Unit : Unit_Data;
1654
1655 begin
1656 Write_Line ("List of Sources:");
1657
1658 for Id in Units.First .. Units.Last loop
1659 Unit := Units.Table (Id);
1660 Write_Str (" ");
1661 Write_Line (Namet.Get_Name_String (Unit.Name));
1662
1663 if Unit.File_Names (Specification).Name /= No_Name then
1664 if Unit.File_Names (Specification).Project = No_Project then
1665 Write_Line (" No project");
1666
1667 else
1668 Write_Str (" Project: ");
1669 Get_Name_String
1670 (Projects.Table
1671 (Unit.File_Names (Specification).Project).Path_Name);
1672 Write_Line (Name_Buffer (1 .. Name_Len));
1673 end if;
1674
1675 Write_Str (" spec: ");
1676 Write_Line
1677 (Namet.Get_Name_String
1678 (Unit.File_Names (Specification).Name));
1679 end if;
1680
1681 if Unit.File_Names (Body_Part).Name /= No_Name then
1682 if Unit.File_Names (Body_Part).Project = No_Project then
1683 Write_Line (" No project");
1684
1685 else
1686 Write_Str (" Project: ");
1687 Get_Name_String
1688 (Projects.Table
1689 (Unit.File_Names (Body_Part).Project).Path_Name);
1690 Write_Line (Name_Buffer (1 .. Name_Len));
1691 end if;
1692
1693 Write_Str (" body: ");
1694 Write_Line
1695 (Namet.Get_Name_String
1696 (Unit.File_Names (Body_Part).Name));
1697 end if;
1698
1699 end loop;
1700
1701 Write_Line ("end of List of Sources.");
1702 end Print_Sources;
1703
fbf5a39b
AC		 1704 -------------------
1705 -- Set_Ada_Paths --
1706 -------------------
1707
1708 procedure Set_Ada_Paths
1709 (Project : Project_Id;
1710 Including_Libraries : Boolean)
1711 is
1712 Source_FD : File_Descriptor := Invalid_FD;
1713 Object_FD : File_Descriptor := Invalid_FD;
1714
1715 Process_Source_Dirs : Boolean := False;
1716 Process_Object_Dirs : Boolean := False;
1717
1718 Status : Boolean;
1719 -- For calls to Close
1720
1721 procedure Add (Project : Project_Id);
1722 -- Add all the source/object directories of a project to the path only
1723 -- if this project has not been visited. Calls itself recursively for
1724 -- projects being extended, and imported projects.
1725
1726 ---------
1727 -- Add --
1728 ---------
1729
1730 procedure Add (Project : Project_Id) is
1731 begin
1732 -- If Seen is False, then the project has not yet been visited
1733
1734 if not Projects.Table (Project).Seen then
1735 Projects.Table (Project).Seen := True;
1736
1737 declare
1738 Data : constant Project_Data := Projects.Table (Project);
1739 List : Project_List := Data.Imported_Projects;
1740
1741 begin
1742 if Process_Source_Dirs then
1743
1744 -- Add to path all source directories of this project
1745
1746 Add_To_Path_File (Data.Source_Dirs, Source_FD);
1747 end if;
1748
1749 if Process_Object_Dirs then
1750
1751 -- Add to path the object directory of this project
1752 -- except if we don't include library project and
1753 -- this is a library project.
1754
1755 if (Data.Library and then Including_Libraries)
1756 or else
1757 (Data.Object_Directory /= No_Name
1758 and then
1759 (not Including_Libraries or else not Data.Library))
1760 then
1761 -- For a library project, add the library directory
1762
1763 if Data.Library then
1764 declare
1765 New_Path : constant String :=
1766 Get_Name_String (Data.Library_Dir);
1767
1768 begin
1769 Add_To_Path_File (New_Path, Object_FD);
1770 end;
1771
1772 else
1773 -- For a non library project, add the object directory
1774
1775 declare
1776 New_Path : constant String :=
1777 Get_Name_String (Data.Object_Directory);
1778 begin
1779 Add_To_Path_File (New_Path, Object_FD);
1780 end;
1781 end if;
1782 end if;
1783 end if;
1784
1785 -- Call Add to the project being extended, if any
1786
1787 if Data.Extends /= No_Project then
1788 Add (Data.Extends);
1789 end if;
1790
1791 -- Call Add for each imported project, if any
1792
1793 while List /= Empty_Project_List loop
1794 Add (Project_Lists.Table (List).Project);
1795 List := Project_Lists.Table (List).Next;
1796 end loop;
1797 end;
1798 end if;
1799 end Add;
1800
1801 -- Start of processing for Set_Ada_Paths
1802
1803 begin
1804 -- If it is the first time we call this procedure for
1805 -- this project, compute the source path and/or the object path.
1806
1807 if Projects.Table (Project).Include_Path_File = No_Name then
1808 Process_Source_Dirs := True;
1809 Create_New_Path_File
1810 (Source_FD, Projects.Table (Project).Include_Path_File);
1811 end if;
1812
1813 -- For the object path, we make a distinction depending on
1814 -- Including_Libraries.
1815
1816 if Including_Libraries then
1817 if Projects.Table (Project).Objects_Path_File_With_Libs = No_Name then
1818 Process_Object_Dirs := True;
1819 Create_New_Path_File
1820 (Object_FD, Projects.Table (Project).
1821 Objects_Path_File_With_Libs);
1822 end if;
1823
1824 else
1825 if
1826 Projects.Table (Project).Objects_Path_File_Without_Libs = No_Name
1827 then
1828 Process_Object_Dirs := True;
1829 Create_New_Path_File
1830 (Object_FD, Projects.Table (Project).
1831 Objects_Path_File_Without_Libs);
1832 end if;
1833 end if;
1834
1835 -- If there is something to do, set Seen to False for all projects,
1836 -- then call the recursive procedure Add for Project.
1837
1838 if Process_Source_Dirs or Process_Object_Dirs then
1839 for Index in 1 .. Projects.Last loop
1840 Projects.Table (Index).Seen := False;
1841 end loop;
1842
1843 Add (Project);
1844 end if;
1845
1846 -- Close any file that has been created.
1847
1848 if Source_FD /= Invalid_FD then
1849 Close (Source_FD, Status);
1850
1851 if not Status then
1852 Prj.Com.Fail ("disk full");
1853 end if;
1854 end if;
1855
1856 if Object_FD /= Invalid_FD then
1857 Close (Object_FD, Status);
1858
1859 if not Status then
1860 Prj.Com.Fail ("disk full");
1861 end if;
1862 end if;
1863
1864 -- Set the env vars, if they need to be changed, and set the
1865 -- corresponding flags.
1866
1867 if
1868 Current_Source_Path_File /= Projects.Table (Project).Include_Path_File
1869 then
1870 Current_Source_Path_File :=
1871 Projects.Table (Project).Include_Path_File;
1872 Set_Path_File_Var
1873 (Project_Include_Path_File,
1874 Get_Name_String (Current_Source_Path_File));
1875 Ada_Prj_Include_File_Set := True;
1876 end if;
1877
1878 if Including_Libraries then
1879 if Current_Object_Path_File
1880 /= Projects.Table (Project).Objects_Path_File_With_Libs
1881 then
1882 Current_Object_Path_File :=
1883 Projects.Table (Project).Objects_Path_File_With_Libs;
1884 Set_Path_File_Var
1885 (Project_Objects_Path_File,
1886 Get_Name_String (Current_Object_Path_File));
1887 Ada_Prj_Objects_File_Set := True;
1888 end if;
1889
1890 else
1891 if Current_Object_Path_File
1892 /= Projects.Table (Project).Objects_Path_File_Without_Libs
1893 then
1894 Current_Object_Path_File :=
1895 Projects.Table (Project).Objects_Path_File_Without_Libs;
1896 Set_Path_File_Var
1897 (Project_Objects_Path_File,
1898 Get_Name_String (Current_Object_Path_File));
1899 Ada_Prj_Objects_File_Set := True;
1900 end if;
1901 end if;
1902 end Set_Ada_Paths;
1903
07fc65c4
GB		 1904 ---------------------------------------------
1905 -- Set_Mapping_File_Initial_State_To_Empty --
1906 ---------------------------------------------
1907
1908 procedure Set_Mapping_File_Initial_State_To_Empty is
1909 begin
1910 Fill_Mapping_File := False;
1911 end Set_Mapping_File_Initial_State_To_Empty;
1912
fbf5a39b
AC		 1913 -----------------------
1914 -- Set_Path_File_Var --
1915 -----------------------
1916
1917 procedure Set_Path_File_Var (Name : String; Value : String) is
1918 Host_Spec : String_Access := To_Host_File_Spec (Value);
1919
1920 begin
1921 if Host_Spec = null then
1922 Prj.Com.Fail
1923 ("could not convert file name """, Value, """ to host spec");
1924 else
1925 Setenv (Name, Host_Spec.all);
1926 Free (Host_Spec);
1927 end if;
1928 end Set_Path_File_Var;
1929
19235870
RK		 1930 -----------------------
1931 -- Spec_Path_Name_Of --
1932 -----------------------
1933
1934 function Spec_Path_Name_Of (Unit : Unit_Id) return String is
1935 Data : Unit_Data := Units.Table (Unit);
1936
1937 begin
1938 if Data.File_Names (Specification).Path = No_Name then
1939 declare
1940 Current_Source : String_List_Id :=
1941 Projects.Table (Data.File_Names (Specification).Project).Sources;
1942 Path : GNAT.OS_Lib.String_Access;
1943
1944 begin
1945 Data.File_Names (Specification).Path :=
1946 Data.File_Names (Specification).Name;
1947
1948 while Current_Source /= Nil_String loop
19235870
RK		 1949 Path := Locate_Regular_File
1950 (Namet.Get_Name_String
1951 (Data.File_Names (Specification).Name),
fbf5a39b
AC		 1952 Namet.Get_Name_String
1953 (String_Elements.Table (Current_Source).Value));
19235870
RK		 1954
1955 if Path /= null then
1956 Name_Len := Path'Length;
1957 Name_Buffer (1 .. Name_Len) := Path.all;
1958 Data.File_Names (Specification).Path := Name_Enter;
1959 exit;
1960 else
1961 Current_Source :=
1962 String_Elements.Table (Current_Source).Next;
1963 end if;
1964 end loop;
1965
1966 Units.Table (Unit) := Data;
1967 end;
1968 end if;
1969
1970 return Namet.Get_Name_String (Data.File_Names (Specification).Path);
1971 end Spec_Path_Name_Of;
1972
fbf5a39b
AC		 1973 ---------------------------
1974 -- Ultimate_Extension_Of --
1975 ---------------------------
1976
1977 function Ultimate_Extension_Of (Project : in Project_Id) return Project_Id
1978 is
1979 Result : Project_Id := Project;
1980
1981 begin
1982 while Projects.Table (Result).Extended_By /= No_Project loop
1983 Result := Projects.Table (Result).Extended_By;
1984 end loop;
1985
1986 return Result;
1987 end Ultimate_Extension_Of;
1988
1989begin
1990 Path_Files.Set_Last (0);
19235870 1991end Prj.Env;
Mirror of https://gcc.gnu.org/git/gcc.git