?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge form mainline (hopefully)
[official-gcc.git] / gcc / ada / mlib-prj.adb
blob2a2d858e5d1f966a4ae768c065548a7c176a5e58
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- M L I B . P R J --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2005, Ada Core Technologies, 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 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with ALI; use ALI;
28 with Gnatvsn; use Gnatvsn;
29 with Hostparm;
30 with MLib.Fil; use MLib.Fil;
31 with MLib.Tgt; use MLib.Tgt;
32 with MLib.Utl; use MLib.Utl;
33 with Namet; use Namet;
34 with Opt;
35 with Output; use Output;
36 with Prj.Com; use Prj.Com;
37 with Prj.Env; use Prj.Env;
38 with Prj.Util; use Prj.Util;
39 with Sinput.P;
40 with Snames; use Snames;
41 with Switch; use Switch;
42 with Table;
43
44 with Ada.Characters.Handling;
45
46 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
47 with GNAT.HTable;
48 with Interfaces.C_Streams; use Interfaces.C_Streams;
49 with System; use System;
50 with System.Case_Util; use System.Case_Util;
51
52 package body MLib.Prj is
53
54 Prj_Add_Obj_Files : Types.Int;
55 pragma Import (C, Prj_Add_Obj_Files, "__gnat_prj_add_obj_files");
56 Add_Object_Files : constant Boolean := Prj_Add_Obj_Files /= 0;
57 -- Indicates if object files in pragmas Linker_Options (found in the
58 -- binder generated file) should be taken when linking aq stand-alone
59 -- library.
60 -- False for Windows, True for other platforms.
61
62 ALI_Suffix : constant String := ".ali";
63 B_Start : String := "b~";
64
65 S_Osinte_Ads : Name_Id := No_Name;
66 -- Name_Id for "s-osinte.ads"
67
68 S_Dec_Ads : Name_Id := No_Name;
69 -- Name_Id for "dec.ads"
70
71 G_Trasym_Ads : Name_Id := No_Name;
72 -- Name_Id for "g-trasym.ads"
73
74 No_Argument_List : aliased String_List := (1 .. 0 => null);
75 No_Argument : constant String_List_Access := No_Argument_List'Access;
76
77 Arguments : String_List_Access := No_Argument;
78 -- Used to accumulate arguments for the invocation of gnatbind and of
79 -- the compiler. Also used to collect the interface ALI when copying
80 -- the ALI files to the library directory.
81
82 Argument_Number : Natural := 0;
83 -- Index of the last argument in Arguments
84
85 Initial_Argument_Max : constant := 10;
86
87 No_Main_String : aliased String := "-n";
88 No_Main : constant String_Access := No_Main_String'Access;
89
90 Output_Switch_String : aliased String := "-o";
91 Output_Switch : constant String_Access := Output_Switch_String'Access;
92
93 Compile_Switch_String : aliased String := "-c";
94 Compile_Switch : constant String_Access := Compile_Switch_String'Access;
95
96 Auto_Initialize : constant String := "-a";
97
98 -- List of objects to put inside the library
99
100 Object_Files : Argument_List_Access;
101
102 package Objects is new Table.Table
103 (Table_Name => "Mlib.Prj.Objects",
104 Table_Component_Type => String_Access,
105 Table_Index_Type => Natural,
106 Table_Low_Bound => 1,
107 Table_Initial => 50,
108 Table_Increment => 100);
109
110 package Objects_Htable is new GNAT.HTable.Simple_HTable
111 (Header_Num => Header_Num,
112 Element => Boolean,
113 No_Element => False,
114 Key => Name_Id,
115 Hash => Hash,
116 Equal => "=");
117
118 -- List of non-Ada object files
119
120 Foreign_Objects : Argument_List_Access;
121
122 package Foreigns is new Table.Table
123 (Table_Name => "Mlib.Prj.Foreigns",
124 Table_Component_Type => String_Access,
125 Table_Index_Type => Natural,
126 Table_Low_Bound => 1,
127 Table_Initial => 20,
128 Table_Increment => 100);
129
130 -- List of ALI files
131
132 Ali_Files : Argument_List_Access;
133
134 package ALIs is new Table.Table
135 (Table_Name => "Mlib.Prj.Alis",
136 Table_Component_Type => String_Access,
137 Table_Index_Type => Natural,
138 Table_Low_Bound => 1,
139 Table_Initial => 50,
140 Table_Increment => 100);
141
142 -- List of options set in the command line.
143
144 Options : Argument_List_Access;
145
146 package Opts is new Table.Table
147 (Table_Name => "Mlib.Prj.Opts",
148 Table_Component_Type => String_Access,
149 Table_Index_Type => Natural,
150 Table_Low_Bound => 1,
151 Table_Initial => 5,
152 Table_Increment => 100);
153
154 -- All the ALI file in the library
155
156 package Library_ALIs is new GNAT.HTable.Simple_HTable
157 (Header_Num => Header_Num,
158 Element => Boolean,
159 No_Element => False,
160 Key => Name_Id,
161 Hash => Hash,
162 Equal => "=");
163
164 -- The ALI files in the interface sets
165
166 package Interface_ALIs is new GNAT.HTable.Simple_HTable
167 (Header_Num => Header_Num,
168 Element => Boolean,
169 No_Element => False,
170 Key => Name_Id,
171 Hash => Hash,
172 Equal => "=");
173
174 -- The ALI files that have been processed to check if the corresponding
175 -- library unit is in the interface set.
176
177 package Processed_ALIs is new GNAT.HTable.Simple_HTable
178 (Header_Num => Header_Num,
179 Element => Boolean,
180 No_Element => False,
181 Key => Name_Id,
182 Hash => Hash,
183 Equal => "=");
184
185 -- The projects imported directly or indirectly.
186
187 package Processed_Projects is new GNAT.HTable.Simple_HTable
188 (Header_Num => Header_Num,
189 Element => Boolean,
190 No_Element => False,
191 Key => Name_Id,
192 Hash => Hash,
193 Equal => "=");
194
195 -- The library projects imported directly or indirectly.
196
197 package Library_Projs is new Table.Table (
198 Table_Component_Type => Project_Id,
199 Table_Index_Type => Integer,
200 Table_Low_Bound => 1,
201 Table_Initial => 10,
202 Table_Increment => 10,
203 Table_Name => "Make.Library_Projs");
204
205 type Build_Mode_State is (None, Static, Dynamic, Relocatable);
206
207 procedure Add_Argument (S : String);
208 -- Add one argument to the array Arguments.
209 -- If Arguments is full, double its size.
210
211 function ALI_File_Name (Source : String) return String;
212 -- Return the ALI file name corresponding to a source.
213
214 procedure Check (Filename : String);
215 -- Check if filename is a regular file. Fail if it is not.
216
217 procedure Check_Context;
218 -- Check each object files in table Object_Files
219 -- Fail if any of them is not a regular file
220
221 procedure Clean (Directory : Name_Id);
222 -- Attempt to delete all files in Directory, but not subdirectories
223
224 procedure Copy_Interface_Sources
225 (For_Project : Project_Id;
226 In_Tree : Project_Tree_Ref;
227 Interfaces : Argument_List;
228 To_Dir : Name_Id);
229 -- Copy the interface sources of a SAL to directory To_Dir
230
231 procedure Display (Executable : String);
232 -- Display invocation of gnatbind and of the compiler with the arguments
233 -- in Arguments, except when Quiet_Output is True.
234
235 procedure Process_Binder_File (Name : String);
236 -- For Stand-Alone libraries, get the Linker Options in the binder
237 -- generated file.
238
239 procedure Reset_Tables;
240 -- Make sure that all the above tables are empty
241 -- (Objects, Foreign_Objects, Ali_Files, Options).
242
243 function SALs_Use_Constructors return Boolean;
244 -- Indicate if Stand-Alone Libraries are automatically initialized using
245 -- the constructor mechanism.
246
247 ------------------
248 -- Add_Argument --
249 ------------------
250
251 procedure Add_Argument (S : String) is
252 begin
253 if Argument_Number = Arguments'Last then
254 declare
255 New_Args : constant String_List_Access :=
256 new String_List (1 .. 2 * Arguments'Last);
257
258 begin
259 -- Copy the String_Accesses and set them to null in Arguments
260 -- so that they will not be deallocated by the call to
261 -- Free (Arguments).
262
263 New_Args (Arguments'Range) := Arguments.all;
264 Arguments.all := (others => null);
265 Free (Arguments);
266 Arguments := New_Args;
267 end;
268 end if;
269
270 Argument_Number := Argument_Number + 1;
271 Arguments (Argument_Number) := new String'(S);
272 end Add_Argument;
273
274 -------------------
275 -- ALI_File_Name --
276 -------------------
277
278 function ALI_File_Name (Source : String) return String is
279 begin
280 -- If the source name has an extension, then replace it with
281 -- the ALI suffix.
282
283 for Index in reverse Source'First + 1 .. Source'Last loop
284 if Source (Index) = '.' then
285 return Source (Source'First .. Index - 1) & ALI_Suffix;
286 end if;
287 end loop;
288
289 -- If there is no dot, or if it is the first character, just add the
290 -- ALI suffix.
291
292 return Source & ALI_Suffix;
293 end ALI_File_Name;
294
295 -------------------
296 -- Build_Library --
297 -------------------
298
299 procedure Build_Library
300 (For_Project : Project_Id;
301 In_Tree : Project_Tree_Ref;
302 Gnatbind : String;
303 Gnatbind_Path : String_Access;
304 Gcc : String;
305 Gcc_Path : String_Access;
306 Bind : Boolean := True;
307 Link : Boolean := True)
308 is
309 Warning_For_Library : Boolean := False;
310 -- Set to True for the first warning about a unit missing from the
311 -- interface set.
312
313 Libgnarl_Needed : Boolean := False;
314 -- Set to True if library needs to be linked with libgnarl
315
316 Libdecgnat_Needed : Boolean := False;
317 -- On OpenVMS, set to True if library needs to be linked with libdecgnat
318
319 Gtrasymobj_Needed : Boolean := False;
320 -- On OpenVMS, set to True if library needs to be linked with
321 -- g-trasym.obj.
322
323 Data : Project_Data := In_Tree.Projects.Table (For_Project);
324
325 Object_Directory_Path : constant String :=
326 Get_Name_String (Data.Object_Directory);
327
328 Standalone : constant Boolean := Data.Standalone_Library;
329
330 Project_Name : constant String := Get_Name_String (Data.Name);
331
332 Current_Dir : constant String := Get_Current_Dir;
333
334 Lib_Filename : String_Access;
335 Lib_Dirpath : String_Access;
336 Lib_Version : String_Access := new String'("");
337
338 The_Build_Mode : Build_Mode_State := None;
339
340 Success : Boolean := False;
341
342 Library_Options : Variable_Value := Nil_Variable_Value;
343
344 Library_GCC : Variable_Value := Nil_Variable_Value;
345
346 Driver_Name : Name_Id := No_Name;
347
348 In_Main_Object_Directory : Boolean := True;
349
350 Rpath : String_Access := null;
351 -- Allocated only if Path Option is supported
352
353 Rpath_Last : Natural := 0;
354 -- Index of last valid character of Rpath
355
356 Initial_Rpath_Length : constant := 200;
357 -- Initial size of Rpath, when first allocated
358
359 Path_Option : String_Access := Linker_Library_Path_Option;
360 -- If null, Path Option is not supported.
361 -- Not a constant so that it can be deallocated.
362
363 Copy_Dir : Name_Id;
364 -- Directory where to copy ALI files and possibly interface sources
365
366 First_ALI : Name_Id := No_Name;
367 -- Store the ALI file name of a source of the library (the first found)
368
369 procedure Add_ALI_For (Source : Name_Id);
370 -- Add the name of the ALI file corresponding to Source to the
371 -- Arguments.
372
373 procedure Add_Rpath (Path : String);
374 -- Add a path name to Rpath
375
376 function Check_Project (P : Project_Id) return Boolean;
377 -- Returns True if P is For_Project or a project extended by For_Project
378
379 procedure Check_Libs (ALI_File : String);
380 -- Set Libgnarl_Needed if the ALI_File indicates that there is a need
381 -- to link with -lgnarl (this is the case when there is a dependency
382 -- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file
383 -- indicates that there is a need to link with -ldecgnat (this is the
384 -- case when there is a dependency on dec.ads), and set
385 -- Gtrasymobj_Needed if there is a dependency on g-trasym.ads.
386
387 procedure Process (The_ALI : File_Name_Type);
388 -- Check if the closure of a library unit which is or should be in the
389 -- interface set is also in the interface set. Issue a warning for each
390 -- missing library unit.
391
392 procedure Process_Imported_Libraries;
393 -- Add the -L and -l switches for the imported Library Project Files,
394 -- and, if Path Option is supported, the library directory path names
395 -- to Rpath.
396
397 -----------------
398 -- Add_ALI_For --
399 -----------------
400
401 procedure Add_ALI_For (Source : Name_Id) is
402 ALI : constant String := ALI_File_Name (Get_Name_String (Source));
403 ALI_Id : Name_Id;
404
405 begin
406 if Bind then
407 Add_Argument (ALI);
408 end if;
409
410 Name_Len := 0;
411 Add_Str_To_Name_Buffer (S => ALI);
412 ALI_Id := Name_Find;
413
414 -- Add the ALI file name to the library ALIs
415
416 if Bind then
417 Library_ALIs.Set (ALI_Id, True);
418 end if;
419
420 -- Set First_ALI, if not already done
421
422 if First_ALI = No_Name then
423 First_ALI := ALI_Id;
424 end if;
425 end Add_ALI_For;
426
427 ---------------
428 -- Add_Rpath --
429 ---------------
430
431 procedure Add_Rpath (Path : String) is
432
433 procedure Double;
434 -- Double Rpath size
435
436 ------------
437 -- Double --
438 ------------
439
440 procedure Double is
441 New_Rpath : constant String_Access :=
442 new String (1 .. 2 * Rpath'Length);
443 begin
444 New_Rpath (1 .. Rpath_Last) := Rpath (1 .. Rpath_Last);
445 Free (Rpath);
446 Rpath := New_Rpath;
447 end Double;
448
449 -- Start of processing for Add_Rpath
450
451 begin
452 -- If firt path, allocate initial Rpath
453
454 if Rpath = null then
455 Rpath := new String (1 .. Initial_Rpath_Length);
456 Rpath_Last := 0;
457
458 else
459 -- Otherwise, add a path separator between two path names
460
461 if Rpath_Last = Rpath'Last then
462 Double;
463 end if;
464
465 Rpath_Last := Rpath_Last + 1;
466 Rpath (Rpath_Last) := Path_Separator;
467 end if;
468
469 -- Increase Rpath size until it is large enough
470
471 while Rpath_Last + Path'Length > Rpath'Last loop
472 Double;
473 end loop;
474
475 -- Add the path name
476
477 Rpath (Rpath_Last + 1 .. Rpath_Last + Path'Length) := Path;
478 Rpath_Last := Rpath_Last + Path'Length;
479 end Add_Rpath;
480
481 -------------------
482 -- Check_Project --
483 -------------------
484
485 function Check_Project (P : Project_Id) return Boolean is
486 begin
487 if P = For_Project then
488 return True;
489
490 elsif P /= No_Project then
491 declare
492 Data : Project_Data :=
493 In_Tree.Projects.Table (For_Project);
494 begin
495 while Data.Extends /= No_Project loop
496 if P = Data.Extends then
497 return True;
498 end if;
499
500 Data := In_Tree.Projects.Table (Data.Extends);
501 end loop;
502 end;
503 end if;
504
505 return False;
506 end Check_Project;
507
508 ----------------
509 -- Check_Libs --
510 ----------------
511
512 procedure Check_Libs (ALI_File : String) is
513 Lib_File : Name_Id;
514 Text : Text_Buffer_Ptr;
515 Id : ALI.ALI_Id;
516
517 begin
518 if not Libgnarl_Needed or
519 (Hostparm.OpenVMS and then
520 ((not Libdecgnat_Needed) or
521 (not Gtrasymobj_Needed)))
522 then
523 -- Scan the ALI file
524
525 Name_Len := ALI_File'Length;
526 Name_Buffer (1 .. Name_Len) := ALI_File;
527 Lib_File := Name_Find;
528 Text := Read_Library_Info (Lib_File, True);
529
530 Id := ALI.Scan_ALI
531 (F => Lib_File,
532 T => Text,
533 Ignore_ED => False,
534 Err => True,
535 Read_Lines => "D");
536 Free (Text);
537
538 -- Look for s-osinte.ads in the dependencies
539
540 for Index in ALI.ALIs.Table (Id).First_Sdep ..
541 ALI.ALIs.Table (Id).Last_Sdep
542 loop
543 if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then
544 Libgnarl_Needed := True;
545
546 elsif Hostparm.OpenVMS then
547 if ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then
548 Libdecgnat_Needed := True;
549
550 elsif ALI.Sdep.Table (Index).Sfile = G_Trasym_Ads then
551 Gtrasymobj_Needed := True;
552 end if;
553 end if;
554 end loop;
555 end if;
556 end Check_Libs;
557
558 -------------
559 -- Process --
560 -------------
561
562 procedure Process (The_ALI : File_Name_Type) is
563 Text : Text_Buffer_Ptr;
564 Idread : ALI_Id;
565 First_Unit : ALI.Unit_Id;
566 Last_Unit : ALI.Unit_Id;
567 Unit_Data : Unit_Record;
568 Afile : File_Name_Type;
569
570 begin
571 -- Nothing to do if the ALI file has already been processed.
572 -- This happens if an interface imports another interface.
573
574 if not Processed_ALIs.Get (The_ALI) then
575 Processed_ALIs.Set (The_ALI, True);
576 Text := Read_Library_Info (The_ALI);
577
578 if Text /= null then
579 Idread :=
580 Scan_ALI
581 (F => The_ALI,
582 T => Text,
583 Ignore_ED => False,
584 Err => True);
585 Free (Text);
586
587 if Idread /= No_ALI_Id then
588 First_Unit := ALI.ALIs.Table (Idread).First_Unit;
589 Last_Unit := ALI.ALIs.Table (Idread).Last_Unit;
590
591 -- Process both unit (spec and body) if the body is needed
592 -- by the spec (inline or generic). Otherwise, just process
593 -- the spec.
594
595 if First_Unit /= Last_Unit and then
596 not ALI.Units.Table (Last_Unit).Body_Needed_For_SAL
597 then
598 First_Unit := Last_Unit;
599 end if;
600
601 for Unit in First_Unit .. Last_Unit loop
602 Unit_Data := ALI.Units.Table (Unit);
603
604 -- Check if each withed unit which is in the library is
605 -- also in the interface set, if it has not yet been
606 -- processed.
607
608 for W in Unit_Data.First_With .. Unit_Data.Last_With loop
609 Afile := Withs.Table (W).Afile;
610
611 if Afile /= No_Name and then Library_ALIs.Get (Afile)
612 and then not Processed_ALIs.Get (Afile)
613 then
614 if not Interface_ALIs.Get (Afile) then
615 if not Warning_For_Library then
616 Write_Str ("Warning: In library project """);
617 Get_Name_String (Data.Name);
618 To_Mixed (Name_Buffer (1 .. Name_Len));
619 Write_Str (Name_Buffer (1 .. Name_Len));
620 Write_Line ("""");
621 Warning_For_Library := True;
622 end if;
623
624 Write_Str (" Unit """);
625 Get_Name_String (Withs.Table (W).Uname);
626 To_Mixed (Name_Buffer (1 .. Name_Len - 2));
627 Write_Str (Name_Buffer (1 .. Name_Len - 2));
628 Write_Line (""" is not in the interface set");
629 Write_Str (" but it is needed by ");
630
631 case Unit_Data.Utype is
632 when Is_Spec =>
633 Write_Str ("the spec of ");
634
635 when Is_Body =>
636 Write_Str ("the body of ");
637
638 when others =>
639 null;
640 end case;
641
642 Write_Str ("""");
643 Get_Name_String (Unit_Data.Uname);
644 To_Mixed (Name_Buffer (1 .. Name_Len - 2));
645 Write_Str (Name_Buffer (1 .. Name_Len - 2));
646 Write_Line ("""");
647 end if;
648
649 -- Now, process this unit
650
651 Process (Afile);
652 end if;
653 end loop;
654 end loop;
655 end if;
656 end if;
657 end if;
658 end Process;
659
660 --------------------------------
661 -- Process_Imported_Libraries --
662 --------------------------------
663
664 procedure Process_Imported_Libraries is
665 Current : Project_Id;
666
667 procedure Process_Project (Project : Project_Id);
668 -- Process Project and its imported projects recursively.
669 -- Add any library projects to table Library_Projs.
670
671 ---------------------
672 -- Process_Project --
673 ---------------------
674
675 procedure Process_Project (Project : Project_Id) is
676 Data : constant Project_Data :=
677 In_Tree.Projects.Table (Project);
678 Imported : Project_List := Data.Imported_Projects;
679 Element : Project_Element;
680
681 begin
682 -- Nothing to do if process has already been processed
683
684 if not Processed_Projects.Get (Data.Name) then
685 Processed_Projects.Set (Data.Name, True);
686
687 -- Call Process_Project recursively for any imported project.
688 -- We first process the imported projects to guarantee that
689 -- we have a proper reverse order for the libraries.
690
691 while Imported /= Empty_Project_List loop
692 Element :=
693 In_Tree.Project_Lists.Table (Imported);
694
695 if Element.Project /= No_Project then
696 Process_Project (Element.Project);
697 end if;
698
699 Imported := Element.Next;
700 end loop;
701
702 -- If it is a library project, add it to Library_Projs
703
704 if Project /= For_Project and then Data.Library then
705 Library_Projs.Increment_Last;
706 Library_Projs.Table (Library_Projs.Last) := Project;
707 end if;
708
709 end if;
710 end Process_Project;
711
712 -- Start of processing for Process_Imported_Libraries
713
714 begin
715 -- Build list of library projects imported directly or indirectly,
716 -- in the reverse order.
717
718 Process_Project (For_Project);
719
720 -- Add the -L and -l switches and, if the Rpath option is supported,
721 -- add the directory to the Rpath.
722 -- As the library projects are in the wrong order, process from the
723 -- last to the first.
724
725 for Index in reverse 1 .. Library_Projs.Last loop
726 Current := Library_Projs.Table (Index);
727
728 Get_Name_String
729 (In_Tree.Projects.Table (Current).Library_Dir);
730 Opts.Increment_Last;
731 Opts.Table (Opts.Last) :=
732 new String'("-L" & Name_Buffer (1 .. Name_Len));
733
734 if Path_Option /= null then
735 Add_Rpath (Name_Buffer (1 .. Name_Len));
736 end if;
737
738 Opts.Increment_Last;
739 Opts.Table (Opts.Last) :=
740 new String'
741 ("-l" &
742 Get_Name_String
743 (In_Tree.Projects.Table
744 (Current).Library_Name));
745 end loop;
746 end Process_Imported_Libraries;
747
748 -- Start of processing for Build_Library
749
750 begin
751 Reset_Tables;
752
753 -- Fail if project is not a library project
754
755 if not Data.Library then
756 Com.Fail ("project """, Project_Name, """ has no library");
757 end if;
758
759 -- If this is the first time Build_Library is called, get the Name_Id
760 -- of "s-osinte.ads".
761
762 if S_Osinte_Ads = No_Name then
763 Name_Len := 0;
764 Add_Str_To_Name_Buffer ("s-osinte.ads");
765 S_Osinte_Ads := Name_Find;
766 end if;
767
768 if S_Dec_Ads = No_Name then
769 Name_Len := 0;
770 Add_Str_To_Name_Buffer ("dec.ads");
771 S_Dec_Ads := Name_Find;
772 end if;
773
774 if G_Trasym_Ads = No_Name then
775 Name_Len := 0;
776 Add_Str_To_Name_Buffer ("g-trasym.ads");
777 G_Trasym_Ads := Name_Find;
778 end if;
779
780 -- We work in the object directory
781
782 Change_Dir (Object_Directory_Path);
783
784 if Standalone then
785 -- Call gnatbind only if Bind is True
786
787 if Bind then
788 if Gnatbind_Path = null then
789 Com.Fail ("unable to locate ", Gnatbind);
790 end if;
791
792 if Gcc_Path = null then
793 Com.Fail ("unable to locate ", Gcc);
794 end if;
795
796 -- Allocate Arguments, if it is the first time we see a standalone
797 -- library.
798
799 if Arguments = No_Argument then
800 Arguments := new String_List (1 .. Initial_Argument_Max);
801 end if;
802
803 -- Add "-n -o b~<lib>.adb (b$<lib>.adb on VMS) -L<lib>"
804
805 Argument_Number := 2;
806 Arguments (1) := No_Main;
807 Arguments (2) := Output_Switch;
808
809 if Hostparm.OpenVMS then
810 B_Start (B_Start'Last) := '$';
811 end if;
812
813 Add_Argument
814 (B_Start & Get_Name_String (Data.Library_Name) & ".adb");
815 Add_Argument ("-L" & Get_Name_String (Data.Library_Name));
816
817 if Data.Lib_Auto_Init and then SALs_Use_Constructors then
818 Add_Argument (Auto_Initialize);
819 end if;
820
821 -- Check if Binder'Default_Switches ("Ada") is defined. If it is,
822 -- add these switches to call gnatbind.
823
824 declare
825 Binder_Package : constant Package_Id :=
826 Value_Of
827 (Name => Name_Binder,
828 In_Packages => Data.Decl.Packages,
829 In_Tree => In_Tree);
830
831 begin
832 if Binder_Package /= No_Package then
833 declare
834 Defaults : constant Array_Element_Id :=
835 Value_Of
836 (Name => Name_Default_Switches,
837 In_Arrays =>
838 In_Tree.Packages.Table
839 (Binder_Package).Decl.Arrays,
840 In_Tree => In_Tree);
841 Switches : Variable_Value := Nil_Variable_Value;
842
843 Switch : String_List_Id := Nil_String;
844
845 begin
846 if Defaults /= No_Array_Element then
847 Switches :=
848 Value_Of
849 (Index => Name_Ada,
850 Src_Index => 0,
851 In_Array => Defaults,
852 In_Tree => In_Tree);
853
854 if not Switches.Default then
855 Switch := Switches.Values;
856
857 while Switch /= Nil_String loop
858 Add_Argument
859 (Get_Name_String
860 (In_Tree.String_Elements.Table
861 (Switch).Value));
862 Switch := In_Tree.String_Elements.
863 Table (Switch).Next;
864 end loop;
865 end if;
866 end if;
867 end;
868 end if;
869 end;
870 end if;
871
872 -- Get all the ALI files of the project file. We do that even if
873 -- Bind is False, so that First_ALI is set.
874
875 declare
876 Unit : Unit_Data;
877
878 begin
879 Library_ALIs.Reset;
880 Interface_ALIs.Reset;
881 Processed_ALIs.Reset;
882
883 for Source in Unit_Table.First ..
884 Unit_Table.Last (In_Tree.Units)
885 loop
886 Unit := In_Tree.Units.Table (Source);
887
888 if Unit.File_Names (Body_Part).Name /= No_Name
889 and then Unit.File_Names (Body_Part).Path /= Slash
890 then
891 if
892 Check_Project (Unit.File_Names (Body_Part).Project)
893 then
894 if Unit.File_Names (Specification).Name = No_Name then
895 declare
896 Src_Ind : Source_File_Index;
897
898 begin
899 Src_Ind := Sinput.P.Load_Project_File
900 (Get_Name_String
901 (Unit.File_Names
902 (Body_Part).Path));
903
904 -- Add the ALI file only if it is not a subunit
905
906 if
907 not Sinput.P.Source_File_Is_Subunit (Src_Ind)
908 then
909 Add_ALI_For
910 (Unit.File_Names (Body_Part).Name);
911 exit when not Bind;
912 end if;
913 end;
914
915 else
916 Add_ALI_For (Unit.File_Names (Body_Part).Name);
917 exit when not Bind;
918 end if;
919 end if;
920
921 elsif Unit.File_Names (Specification).Name /= No_Name
922 and then Unit.File_Names (Specification).Path /= Slash
923 and then Check_Project
924 (Unit.File_Names (Specification).Project)
925 then
926 Add_ALI_For (Unit.File_Names (Specification).Name);
927 exit when not Bind;
928 end if;
929 end loop;
930 end;
931
932 -- Continue setup and call gnatbind if Bind is True
933
934 if Bind then
935
936 -- Get an eventual --RTS from the ALI file
937
938 if First_ALI /= No_Name then
939 declare
940 T : Text_Buffer_Ptr;
941 A : ALI_Id;
942
943 begin
944 -- Load the ALI file
945
946 T := Read_Library_Info (First_ALI, True);
947
948 -- Read it
949
950 A := Scan_ALI
951 (First_ALI, T, Ignore_ED => False, Err => False);
952
953 if A /= No_ALI_Id then
954 for Index in
955 ALI.Units.Table
956 (ALI.ALIs.Table (A).First_Unit).First_Arg ..
957 ALI.Units.Table
958 (ALI.ALIs.Table (A).First_Unit).Last_Arg
959 loop
960 -- Look for --RTS. If found, add the switch to call
961 -- gnatbind.
962
963 declare
964 Arg : String_Ptr renames Args.Table (Index);
965 begin
966 if Arg'Length >= 6 and then
967 Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
968 then
969 Add_Argument (Arg.all);
970 exit;
971 end if;
972 end;
973 end loop;
974 end if;
975 end;
976 end if;
977
978 -- Set the paths
979
980 Set_Ada_Paths
981 (Project => For_Project,
982 In_Tree => In_Tree,
983 Including_Libraries => True);
984
985 -- Display the gnatbind command, if not in quiet output
986
987 Display (Gnatbind);
988
989 -- Invoke gnatbind
990
991 GNAT.OS_Lib.Spawn
992 (Gnatbind_Path.all, Arguments (1 .. Argument_Number), Success);
993
994 if not Success then
995 Com.Fail ("could not bind standalone library ",
996 Get_Name_String (Data.Library_Name));
997 end if;
998 end if;
999
1000 -- Compile the binder generated file only if Link is true
1001
1002 if Link then
1003 -- Set the paths
1004
1005 Set_Ada_Paths
1006 (Project => For_Project,
1007 In_Tree => In_Tree,
1008 Including_Libraries => True);
1009
1010 -- Invoke <gcc> -c b$$<lib>.adb
1011
1012 -- Allocate Arguments, if it is the first time we see a standalone
1013 -- library.
1014
1015 if Arguments = No_Argument then
1016 Arguments := new String_List (1 .. Initial_Argument_Max);
1017 end if;
1018
1019 Argument_Number := 1;
1020 Arguments (1) := Compile_Switch;
1021
1022 if Hostparm.OpenVMS then
1023 B_Start (B_Start'Last) := '$';
1024 end if;
1025
1026 Add_Argument
1027 (B_Start & Get_Name_String (Data.Library_Name) & ".adb");
1028
1029 -- If necessary, add the PIC option
1030
1031 if PIC_Option /= "" then
1032 Add_Argument (PIC_Option);
1033 end if;
1034
1035 -- Get the back-end switches and --RTS from the ALI file
1036
1037 if First_ALI /= No_Name then
1038 declare
1039 T : Text_Buffer_Ptr;
1040 A : ALI_Id;
1041
1042 begin
1043 -- Load the ALI file
1044
1045 T := Read_Library_Info (First_ALI, True);
1046
1047 -- Read it
1048
1049 A := Scan_ALI
1050 (First_ALI, T, Ignore_ED => False, Err => False);
1051
1052 if A /= No_ALI_Id then
1053 for Index in
1054 ALI.Units.Table
1055 (ALI.ALIs.Table (A).First_Unit).First_Arg ..
1056 ALI.Units.Table
1057 (ALI.ALIs.Table (A).First_Unit).Last_Arg
1058 loop
1059 -- Do not compile with the front end switches except
1060 -- for --RTS.
1061
1062 declare
1063 Arg : String_Ptr renames Args.Table (Index);
1064 begin
1065 if not Is_Front_End_Switch (Arg.all)
1066 or else
1067 Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
1068 then
1069 Add_Argument (Arg.all);
1070 end if;
1071 end;
1072 end loop;
1073 end if;
1074 end;
1075 end if;
1076
1077 -- Now that all the arguments are set, compile the binder
1078 -- generated file.
1079
1080 Display (Gcc);
1081 GNAT.OS_Lib.Spawn
1082 (Gcc_Path.all, Arguments (1 .. Argument_Number), Success);
1083
1084 if not Success then
1085 Com.Fail
1086 ("could not compile binder generated file for library ",
1087 Get_Name_String (Data.Library_Name));
1088 end if;
1089
1090 -- Process binder generated file for pragmas Linker_Options
1091
1092 Process_Binder_File (Arguments (2).all & ASCII.NUL);
1093 end if;
1094 end if;
1095
1096 -- Build the library only if Link is True
1097
1098 if Link then
1099 -- If attribute Library_GCC was specified, get the driver name
1100
1101 Library_GCC :=
1102 Value_Of (Name_Library_GCC, Data.Decl.Attributes, In_Tree);
1103
1104 if not Library_GCC.Default then
1105 Driver_Name := Library_GCC.Value;
1106 end if;
1107
1108 -- If attribute Library_Options was specified, add these additional
1109 -- options.
1110
1111 Library_Options :=
1112 Value_Of (Name_Library_Options, Data.Decl.Attributes, In_Tree);
1113
1114 if not Library_Options.Default then
1115 declare
1116 Current : String_List_Id := Library_Options.Values;
1117 Element : String_Element;
1118
1119 begin
1120 while Current /= Nil_String loop
1121 Element :=
1122 In_Tree.String_Elements.Table (Current);
1123 Get_Name_String (Element.Value);
1124
1125 if Name_Len /= 0 then
1126 Opts.Increment_Last;
1127 Opts.Table (Opts.Last) :=
1128 new String'(Name_Buffer (1 .. Name_Len));
1129 end if;
1130
1131 Current := Element.Next;
1132 end loop;
1133 end;
1134 end if;
1135
1136 Lib_Dirpath := new String'(Get_Name_String (Data.Library_Dir));
1137 Lib_Filename := new String'(Get_Name_String (Data.Library_Name));
1138
1139 case Data.Library_Kind is
1140 when Static =>
1141 The_Build_Mode := Static;
1142
1143 when Dynamic =>
1144 The_Build_Mode := Dynamic;
1145
1146 when Relocatable =>
1147 The_Build_Mode := Relocatable;
1148
1149 if PIC_Option /= "" then
1150 Opts.Increment_Last;
1151 Opts.Table (Opts.Last) := new String'(PIC_Option);
1152 end if;
1153 end case;
1154
1155 -- Get the library version, if any
1156
1157 if Data.Lib_Internal_Name /= No_Name then
1158 Lib_Version :=
1159 new String'(Get_Name_String (Data.Lib_Internal_Name));
1160 end if;
1161
1162 -- Add the objects found in the object directory and the object
1163 -- directories of the extended files, if any, except for generated
1164 -- object files (b~.. or B$..) from extended projects.
1165 -- When there are one or more extended files, only add an object file
1166 -- if no object file with the same name have already been added.
1167
1168 In_Main_Object_Directory := True;
1169
1170 loop
1171 declare
1172 Object_Dir_Path : constant String :=
1173 Get_Name_String (Data.Object_Directory);
1174 Object_Dir : Dir_Type;
1175 Filename : String (1 .. 255);
1176 Last : Natural;
1177 Id : Name_Id;
1178
1179 begin
1180 Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path);
1181
1182 -- For all entries in the object directory
1183
1184 loop
1185 Read (Object_Dir, Filename, Last);
1186
1187 exit when Last = 0;
1188
1189 -- Check if it is an object file
1190
1191 if Is_Obj (Filename (1 .. Last)) then
1192 declare
1193 Object_Path : String :=
1194 Normalize_Pathname
1195 (Object_Dir_Path & Directory_Separator &
1196 Filename (1 .. Last));
1197
1198 begin
1199 Canonical_Case_File_Name (Object_Path);
1200 Canonical_Case_File_Name (Filename (1 .. Last));
1201
1202 -- If in the object directory of an extended project,
1203 -- do not consider generated object files.
1204
1205 if In_Main_Object_Directory
1206 or else Last < 5
1207 or else Filename (1 .. B_Start'Length) /= B_Start
1208 then
1209 Name_Len := Last;
1210 Name_Buffer (1 .. Name_Len) := Filename (1 .. Last);
1211 Id := Name_Find;
1212
1213 if not Objects_Htable.Get (Id) then
1214
1215 -- Record this object file
1216
1217 Objects_Htable.Set (Id, True);
1218 Objects.Increment_Last;
1219 Objects.Table (Objects.Last) :=
1220 new String'(Object_Path);
1221
1222 declare
1223 ALI_File : constant String :=
1224 Ext_To (Object_Path, "ali");
1225
1226 begin
1227 if Is_Regular_File (ALI_File) then
1228
1229 -- Record the ALI file
1230
1231 ALIs.Increment_Last;
1232 ALIs.Table (ALIs.Last) :=
1233 new String'(ALI_File);
1234
1235 -- Find out if for this ALI file,
1236 -- libgnarl or libdecgnat or g-trasym.obj
1237 -- (on OpenVMS) is necessary.
1238
1239 Check_Libs (ALI_File);
1240
1241 else
1242 -- Object file is a foreign object file
1243
1244 Foreigns.Increment_Last;
1245 Foreigns.Table (Foreigns.Last) :=
1246 new String'(Object_Path);
1247 end if;
1248 end;
1249 end if;
1250 end if;
1251 end;
1252 end if;
1253 end loop;
1254
1255 Close (Dir => Object_Dir);
1256
1257 exception
1258 when Directory_Error =>
1259 Com.Fail ("cannot find object directory """,
1260 Get_Name_String (Data.Object_Directory),
1261 """");
1262 end;
1263
1264 exit when Data.Extends = No_Project;
1265
1266 In_Main_Object_Directory := False;
1267 Data := In_Tree.Projects.Table (Data.Extends);
1268 end loop;
1269
1270 -- Add the -L and -l switches for the imported Library Project Files,
1271 -- and, if Path Option is supported, the library directory path names
1272 -- to Rpath.
1273
1274 Process_Imported_Libraries;
1275
1276 -- Link with libgnat and possibly libgnarl
1277
1278 Opts.Increment_Last;
1279 Opts.Table (Opts.Last) := new String'("-L" & Lib_Directory);
1280
1281 -- If Path Option is supported, add libgnat directory path name to
1282 -- Rpath.
1283
1284 if Path_Option /= null then
1285 Add_Rpath (Lib_Directory);
1286 end if;
1287
1288 if Libgnarl_Needed then
1289 Opts.Increment_Last;
1290
1291 if The_Build_Mode = Static then
1292 Opts.Table (Opts.Last) := new String'("-lgnarl");
1293 else
1294 Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnarl"));
1295 end if;
1296 end if;
1297
1298 if Gtrasymobj_Needed then
1299 Opts.Increment_Last;
1300 Opts.Table (Opts.Last) :=
1301 new String'(Lib_Directory & "/g-trasym.obj");
1302 end if;
1303
1304 if Libdecgnat_Needed then
1305 Opts.Increment_Last;
1306 Opts.Table (Opts.Last) :=
1307 new String'("-L" & Lib_Directory & "/../declib");
1308 Opts.Increment_Last;
1309 Opts.Table (Opts.Last) := new String'("-ldecgnat");
1310 end if;
1311
1312 Opts.Increment_Last;
1313
1314 if The_Build_Mode = Static then
1315 Opts.Table (Opts.Last) := new String'("-lgnat");
1316 else
1317 Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnat"));
1318 end if;
1319
1320 -- If Path Option is supported, add the necessary switch with the
1321 -- content of Rpath. As Rpath contains at least libgnat directory
1322 -- path name, it is guaranteed that it is not null.
1323
1324 if Path_Option /= null then
1325 Opts.Increment_Last;
1326 Opts.Table (Opts.Last) :=
1327 new String'(Path_Option.all & Rpath (1 .. Rpath_Last));
1328 Free (Path_Option);
1329 Free (Rpath);
1330 end if;
1331
1332 Object_Files :=
1333 new Argument_List'
1334 (Argument_List (Objects.Table (1 .. Objects.Last)));
1335
1336 Foreign_Objects :=
1337 new Argument_List'(Argument_List
1338 (Foreigns.Table (1 .. Foreigns.Last)));
1339
1340 Ali_Files :=
1341 new Argument_List'(Argument_List (ALIs.Table (1 .. ALIs.Last)));
1342
1343 Options :=
1344 new Argument_List'(Argument_List (Opts.Table (1 .. Opts.Last)));
1345
1346 -- We fail if there are no object to put in the library
1347 -- (Ada or foreign objects).
1348
1349 if Object_Files'Length = 0 then
1350 Com.Fail ("no object files for library """ &
1351 Lib_Filename.all & '"');
1352 end if;
1353
1354 if not Opt.Quiet_Output then
1355 Write_Eol;
1356 Write_Str ("building ");
1357 Write_Str (Ada.Characters.Handling.To_Lower
1358 (Build_Mode_State'Image (The_Build_Mode)));
1359 Write_Str (" library for project ");
1360 Write_Line (Project_Name);
1361
1362 Write_Eol;
1363
1364 Write_Line ("object files:");
1365
1366 for Index in Object_Files'Range loop
1367 Write_Str (" ");
1368 Write_Line (Object_Files (Index).all);
1369 end loop;
1370
1371 Write_Eol;
1372
1373 if Ali_Files'Length = 0 then
1374 Write_Line ("NO ALI files");
1375
1376 else
1377 Write_Line ("ALI files:");
1378
1379 for Index in Ali_Files'Range loop
1380 Write_Str (" ");
1381 Write_Line (Ali_Files (Index).all);
1382 end loop;
1383 end if;
1384
1385 Write_Eol;
1386 end if;
1387
1388 -- We check that all object files are regular files
1389
1390 Check_Context;
1391
1392 -- Delete the existing library file, if it exists.
1393 -- Fail if the library file is not writable, or if it is not possible
1394 -- to delete the file.
1395
1396 declare
1397 DLL_Name : aliased String :=
1398 Lib_Dirpath.all & "/lib" &
1399 Lib_Filename.all & "." & DLL_Ext;
1400
1401 Archive_Name : aliased String :=
1402 Lib_Dirpath.all & "/lib" &
1403 Lib_Filename.all & "." & Archive_Ext;
1404
1405 type Str_Ptr is access all String;
1406 -- This type is necessary to meet the accessibility rules of Ada.
1407 -- It is not possible to use String_Access here.
1408
1409 Full_Lib_Name : Str_Ptr;
1410 -- Designates the full library path name. Either DLL_Name or
1411 -- Archive_Name, depending on the library kind.
1412
1413 Success : Boolean := False;
1414 -- Used to call Delete_File
1415
1416 begin
1417 if The_Build_Mode = Static then
1418 Full_Lib_Name := Archive_Name'Access;
1419 else
1420 Full_Lib_Name := DLL_Name'Access;
1421 end if;
1422
1423 if Is_Regular_File (Full_Lib_Name.all) then
1424 if Is_Writable_File (Full_Lib_Name.all) then
1425 Delete_File (Full_Lib_Name.all, Success);
1426 end if;
1427
1428 if Is_Regular_File (Full_Lib_Name.all) then
1429 Com.Fail ("could not delete """ & Full_Lib_Name.all & """");
1430 end if;
1431 end if;
1432 end;
1433
1434 Argument_Number := 0;
1435
1436 -- If we have a standalone library, gather all the interface ALI.
1437 -- They are passed to Build_Dynamic_Library, where they are used by
1438 -- some platforms (VMS, for example) to decide what symbols should be
1439 -- exported. They are also flagged as Interface when we copy them to
1440 -- the library directory (by Copy_ALI_Files, below).
1441
1442 if Standalone then
1443 Data := In_Tree.Projects.Table (For_Project);
1444
1445 declare
1446 Iface : String_List_Id := Data.Lib_Interface_ALIs;
1447 ALI : File_Name_Type;
1448
1449 begin
1450 while Iface /= Nil_String loop
1451 ALI :=
1452 In_Tree.String_Elements.Table (Iface).Value;
1453 Interface_ALIs.Set (ALI, True);
1454 Get_Name_String
1455 (In_Tree.String_Elements.Table (Iface).Value);
1456 Add_Argument (Name_Buffer (1 .. Name_Len));
1457 Iface :=
1458 In_Tree.String_Elements.Table (Iface).Next;
1459 end loop;
1460
1461 Iface := Data.Lib_Interface_ALIs;
1462
1463 if not Opt.Quiet_Output then
1464
1465 -- Check that the interface set is complete: any unit in the
1466 -- library that is needed by an interface should also be an
1467 -- interface. If it is not the case, output a warning.
1468
1469 while Iface /= Nil_String loop
1470 ALI := In_Tree.String_Elements.Table
1471 (Iface).Value;
1472 Process (ALI);
1473 Iface :=
1474 In_Tree.String_Elements.Table (Iface).Next;
1475 end loop;
1476 end if;
1477 end;
1478 end if;
1479
1480 -- Clean the library directory, if it is also the directory where
1481 -- the ALI files are copied, either because there is no interface
1482 -- copy directory or because the interface copy directory is the
1483 -- same as the library directory.
1484
1485 Copy_Dir :=
1486 In_Tree.Projects.Table (For_Project).Library_Dir;
1487 Clean (Copy_Dir);
1488
1489 -- Call procedure to build the library, depending on the build mode
1490
1491 case The_Build_Mode is
1492 when Dynamic | Relocatable =>
1493 Build_Dynamic_Library
1494 (Ofiles => Object_Files.all,
1495 Foreign => Foreign_Objects.all,
1496 Afiles => Ali_Files.all,
1497 Options => Options.all,
1498 Options_2 => No_Argument_List,
1499 Interfaces => Arguments (1 .. Argument_Number),
1500 Lib_Filename => Lib_Filename.all,
1501 Lib_Dir => Lib_Dirpath.all,
1502 Symbol_Data => Data.Symbol_Data,
1503 Driver_Name => Driver_Name,
1504 Lib_Version => Lib_Version.all,
1505 Auto_Init => Data.Lib_Auto_Init);
1506
1507 when Static =>
1508 MLib.Build_Library
1509 (Object_Files.all,
1510 Ali_Files.all,
1511 Lib_Filename.all,
1512 Lib_Dirpath.all);
1513
1514 when None =>
1515 null;
1516 end case;
1517
1518 -- We need to copy the ALI files from the object directory to
1519 -- the library directory, so that the linker find them there,
1520 -- and does not need to look in the object directory where it
1521 -- would also find the object files; and we don't want that:
1522 -- we want the linker to use the library.
1523
1524 -- Copy the ALI files and make the copies read-only. For interfaces,
1525 -- mark the copies as interfaces.
1526
1527 Copy_ALI_Files
1528 (Files => Ali_Files.all,
1529 To => Copy_Dir,
1530 Interfaces => Arguments (1 .. Argument_Number));
1531
1532 -- Copy interface sources if Library_Src_Dir specified
1533
1534 if Standalone
1535 and then In_Tree.Projects.Table
1536 (For_Project).Library_Src_Dir /= No_Name
1537 then
1538 -- Clean the interface copy directory, if it is not also the
1539 -- library directory. If it is also the library directory, it
1540 -- has already been cleaned before generation of the library.
1541
1542 if In_Tree.Projects.Table
1543 (For_Project).Library_Src_Dir /= Copy_Dir
1544 then
1545 Copy_Dir := In_Tree.Projects.Table
1546 (For_Project).Library_Src_Dir;
1547 Clean (Copy_Dir);
1548 end if;
1549
1550 Copy_Interface_Sources
1551 (For_Project => For_Project,
1552 In_Tree => In_Tree,
1553 Interfaces => Arguments (1 .. Argument_Number),
1554 To_Dir => Copy_Dir);
1555 end if;
1556 end if;
1557
1558 -- Reset the current working directory to its previous value
1559
1560 Change_Dir (Current_Dir);
1561 end Build_Library;
1562
1563 -----------
1564 -- Check --
1565 -----------
1566
1567 procedure Check (Filename : String) is
1568 begin
1569 if not Is_Regular_File (Filename) then
1570 Com.Fail (Filename, " not found.");
1571 end if;
1572 end Check;
1573
1574 -------------------
1575 -- Check_Context --
1576 -------------------
1577
1578 procedure Check_Context is
1579 begin
1580 -- Check that each object file exists
1581
1582 for F in Object_Files'Range loop
1583 Check (Object_Files (F).all);
1584 end loop;
1585 end Check_Context;
1586
1587 -------------------
1588 -- Check_Library --
1589 -------------------
1590
1591 procedure Check_Library
1592 (For_Project : Project_Id; In_Tree : Project_Tree_Ref)
1593 is
1594 Data : constant Project_Data :=
1595 In_Tree.Projects.Table (For_Project);
1596
1597 begin
1598 -- No need to build the library if there is no object directory,
1599 -- hence no object files to build the library.
1600
1601 if Data.Library
1602 and then not Data.Need_To_Build_Lib
1603 and then Data.Object_Directory /= No_Name
1604 then
1605 declare
1606 Current : constant Dir_Name_Str := Get_Current_Dir;
1607 Lib_Name : constant Name_Id :=
1608 Library_File_Name_For (For_Project, In_Tree);
1609 Lib_TS : Time_Stamp_Type;
1610 Obj_TS : Time_Stamp_Type;
1611
1612 Object_Dir : Dir_Type;
1613
1614 begin
1615 if Hostparm.OpenVMS then
1616 B_Start (B_Start'Last) := '$';
1617 end if;
1618
1619 Change_Dir (Get_Name_String (Data.Library_Dir));
1620
1621 Lib_TS := File_Stamp (Lib_Name);
1622
1623 -- If the library file does not exist, then the time stamp will
1624 -- be Empty_Time_Stamp, earlier than any other time stamp.
1625
1626 Change_Dir (Get_Name_String (Data.Object_Directory));
1627 Open (Dir => Object_Dir, Dir_Name => ".");
1628
1629 -- For all entries in the object directory
1630
1631 loop
1632 Read (Object_Dir, Name_Buffer, Name_Len);
1633 exit when Name_Len = 0;
1634
1635 -- Check if it is an object file, but ignore any binder
1636 -- generated file.
1637
1638 if Is_Obj (Name_Buffer (1 .. Name_Len))
1639 and then Name_Buffer (1 .. B_Start'Length) /= B_Start
1640 then
1641 -- Get the object file time stamp
1642
1643 Obj_TS := File_Stamp (Name_Find);
1644
1645 -- If library file time stamp is earlier, set
1646 -- Need_To_Build_Lib and return. String comparaison is used,
1647 -- otherwise time stamps may be too close and the
1648 -- comparaison would return True, which would trigger
1649 -- an unnecessary rebuild of the library.
1650
1651 if String (Lib_TS) < String (Obj_TS) then
1652
1653 -- Library must be rebuilt
1654
1655 In_Tree.Projects.Table
1656 (For_Project).Need_To_Build_Lib := True;
1657 exit;
1658 end if;
1659 end if;
1660 end loop;
1661
1662 Change_Dir (Current);
1663 end;
1664 end if;
1665 end Check_Library;
1666
1667 -----------
1668 -- Clean --
1669 -----------
1670
1671 procedure Clean (Directory : Name_Id) is
1672 Current : constant Dir_Name_Str := Get_Current_Dir;
1673
1674 Dir : Dir_Type;
1675
1676 Name : String (1 .. 200);
1677 Last : Natural;
1678
1679 Disregard : Boolean;
1680
1681 begin
1682 Get_Name_String (Directory);
1683
1684 -- Change the working directory to the directory to clean
1685
1686 begin
1687 Change_Dir (Name_Buffer (1 .. Name_Len));
1688
1689 exception
1690 when others =>
1691 Com.Fail
1692 ("unable to access directory """,
1693 Name_Buffer (1 .. Name_Len),
1694 """");
1695 end;
1696
1697 Open (Dir, ".");
1698
1699 -- For each regular file in the directory, make it writable and
1700 -- delete the file.
1701
1702 loop
1703 Read (Dir, Name, Last);
1704 exit when Last = 0;
1705
1706 if Is_Regular_File (Name (1 .. Last)) then
1707 Set_Writable (Name (1 .. Last));
1708 Delete_File (Name (1 .. Last), Disregard);
1709 end if;
1710 end loop;
1711
1712 Close (Dir);
1713
1714 -- Restore the initial working directory
1715
1716 Change_Dir (Current);
1717 end Clean;
1718
1719 ----------------------------
1720 -- Copy_Interface_Sources --
1721 ----------------------------
1722
1723 procedure Copy_Interface_Sources
1724 (For_Project : Project_Id;
1725 In_Tree : Project_Tree_Ref;
1726 Interfaces : Argument_List;
1727 To_Dir : Name_Id)
1728 is
1729 Current : constant Dir_Name_Str := Get_Current_Dir;
1730 -- The current directory, where to return to at the end
1731
1732 Target : constant Dir_Name_Str := Get_Name_String (To_Dir);
1733 -- The directory where to copy sources
1734
1735 Text : Text_Buffer_Ptr;
1736 The_ALI : ALI.ALI_Id;
1737 Lib_File : Name_Id;
1738
1739 First_Unit : ALI.Unit_Id;
1740 Second_Unit : ALI.Unit_Id;
1741
1742 Data : Unit_Data;
1743
1744 Copy_Subunits : Boolean := False;
1745 -- When True, indicates that subunits, if any, need to be copied too
1746
1747 procedure Copy (File_Name : Name_Id);
1748 -- Copy one source of the project to the target directory
1749
1750 function Is_Same_Or_Extension
1751 (Extending : Project_Id;
1752 Extended : Project_Id)
1753 return Boolean;
1754 -- Return True if project Extending is equal to or extends project
1755 -- Extended.
1756
1757 ----------
1758 -- Copy --
1759 ----------
1760
1761 procedure Copy (File_Name : Name_Id) is
1762 Success : Boolean := False;
1763
1764 begin
1765 Unit_Loop :
1766 for Index in Unit_Table.First ..
1767 Unit_Table.Last (In_Tree.Units)
1768 loop
1769 Data := In_Tree.Units.Table (Index);
1770
1771 -- Find and copy the immediate or inherited source
1772
1773 for J in Data.File_Names'Range loop
1774 if Is_Same_Or_Extension
1775 (For_Project, Data.File_Names (J).Project)
1776 and then Data.File_Names (J).Name = File_Name
1777 then
1778 Copy_File
1779 (Get_Name_String (Data.File_Names (J).Path),
1780 Target,
1781 Success,
1782 Mode => Overwrite,
1783 Preserve => Preserve);
1784 exit Unit_Loop;
1785 end if;
1786 end loop;
1787 end loop Unit_Loop;
1788 end Copy;
1789
1790 --------------------------
1791 -- Is_Same_Or_Extension --
1792 --------------------------
1793
1794 function Is_Same_Or_Extension
1795 (Extending : Project_Id;
1796 Extended : Project_Id)
1797 return Boolean
1798 is
1799 Ext : Project_Id := Extending;
1800
1801 begin
1802 while Ext /= No_Project loop
1803 if Ext = Extended then
1804 return True;
1805 end if;
1806
1807 Ext := In_Tree.Projects.Table (Ext).Extends;
1808 end loop;
1809
1810 return False;
1811 end Is_Same_Or_Extension;
1812
1813 -- Start of processing for Copy_Interface_Sources
1814
1815 begin
1816 -- Change the working directory to the object directory
1817
1818 Change_Dir
1819 (Get_Name_String
1820 (In_Tree.Projects.Table
1821 (For_Project).Object_Directory));
1822
1823 for Index in Interfaces'Range loop
1824
1825 -- First, load the ALI file
1826
1827 Name_Len := 0;
1828 Add_Str_To_Name_Buffer (Interfaces (Index).all);
1829 Lib_File := Name_Find;
1830 Text := Read_Library_Info (Lib_File);
1831 The_ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
1832 Free (Text);
1833
1834 Second_Unit := No_Unit_Id;
1835 First_Unit := ALI.ALIs.Table (The_ALI).First_Unit;
1836 Copy_Subunits := True;
1837
1838 -- If there is both a spec and a body, check if they are both needed
1839
1840 if ALI.Units.Table (First_Unit).Utype = Is_Body then
1841 Second_Unit := ALI.ALIs.Table (The_ALI).Last_Unit;
1842
1843 -- If the body is not needed, then reset First_Unit
1844
1845 if not ALI.Units.Table (Second_Unit).Body_Needed_For_SAL then
1846 First_Unit := No_Unit_Id;
1847 Copy_Subunits := False;
1848 end if;
1849
1850 elsif ALI.Units.Table (First_Unit).Utype = Is_Spec_Only then
1851 Copy_Subunits := False;
1852 end if;
1853
1854 -- Copy the file(s) that need to be copied
1855
1856 if First_Unit /= No_Unit_Id then
1857 Copy (File_Name => ALI.Units.Table (First_Unit).Sfile);
1858 end if;
1859
1860 if Second_Unit /= No_Unit_Id then
1861 Copy (File_Name => ALI.Units.Table (Second_Unit).Sfile);
1862 end if;
1863
1864 -- Copy all the separates, if any
1865
1866 if Copy_Subunits then
1867 for Dep in ALI.ALIs.Table (The_ALI).First_Sdep ..
1868 ALI.ALIs.Table (The_ALI).Last_Sdep
1869 loop
1870 if Sdep.Table (Dep).Subunit_Name /= No_Name then
1871 Copy (File_Name => Sdep.Table (Dep).Sfile);
1872 end if;
1873 end loop;
1874 end if;
1875 end loop;
1876
1877 -- Restore the initial working directory
1878
1879 Change_Dir (Current);
1880 end Copy_Interface_Sources;
1881
1882 -------------
1883 -- Display --
1884 -------------
1885
1886 procedure Display (Executable : String) is
1887 begin
1888 if not Opt.Quiet_Output then
1889 Write_Str (Executable);
1890
1891 for Index in 1 .. Argument_Number loop
1892 Write_Char (' ');
1893 Write_Str (Arguments (Index).all);
1894 end loop;
1895
1896 Write_Eol;
1897 end if;
1898 end Display;
1899
1900 -------------------------
1901 -- Process_Binder_File --
1902 -------------------------
1903
1904 procedure Process_Binder_File (Name : String) is
1905 Fd : FILEs;
1906 -- Binder file's descriptor
1907
1908 Read_Mode : constant String := "r" & ASCII.Nul;
1909 -- For fopen
1910
1911 Status : Interfaces.C_Streams.int;
1912 pragma Unreferenced (Status);
1913 -- For fclose
1914
1915 Begin_Info : constant String := "-- BEGIN Object file/option list";
1916 End_Info : constant String := "-- END Object file/option list ";
1917
1918 Next_Line : String (1 .. 1000);
1919 -- Current line value
1920 -- Where does this odd constant 1000 come from, looks suspicious ???
1921
1922 Nlast : Integer;
1923 -- End of line slice (the slice does not contain the line terminator)
1924
1925 procedure Get_Next_Line;
1926 -- Read the next line from the binder file without the line terminator
1927
1928 -------------------
1929 -- Get_Next_Line --
1930 -------------------
1931
1932 procedure Get_Next_Line is
1933 Fchars : chars;
1934
1935 begin
1936 Fchars := fgets (Next_Line'Address, Next_Line'Length, Fd);
1937
1938 if Fchars = System.Null_Address then
1939 Fail ("Error reading binder output");
1940 end if;
1941
1942 Nlast := 1;
1943 while Nlast <= Next_Line'Last
1944 and then Next_Line (Nlast) /= ASCII.LF
1945 and then Next_Line (Nlast) /= ASCII.CR
1946 loop
1947 Nlast := Nlast + 1;
1948 end loop;
1949
1950 Nlast := Nlast - 1;
1951 end Get_Next_Line;
1952
1953 -- Start of processing for Process_Binder_File
1954
1955 begin
1956 Fd := fopen (Name'Address, Read_Mode'Address);
1957
1958 if Fd = NULL_Stream then
1959 Fail ("Failed to open binder output");
1960 end if;
1961
1962 -- Skip up to the Begin Info line
1963
1964 loop
1965 Get_Next_Line;
1966 exit when Next_Line (1 .. Nlast) = Begin_Info;
1967 end loop;
1968
1969 -- Find the first switch
1970
1971 loop
1972 Get_Next_Line;
1973
1974 exit when Next_Line (1 .. Nlast) = End_Info;
1975
1976 -- As the binder generated file is in Ada, remove the first eight
1977 -- characters " -- ".
1978
1979 Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast);
1980 Nlast := Nlast - 8;
1981
1982 -- Stop when the first switch is found
1983
1984 exit when Next_Line (1) = '-';
1985 end loop;
1986
1987 if Next_Line (1 .. Nlast) /= End_Info then
1988 loop
1989 -- Ignore -static and -shared, since -shared will be used
1990 -- in any case.
1991
1992 -- Ignore -lgnat, -lgnarl and -ldecgnat as they will be added
1993 -- later, because they are also needed for non Stand-Alone shared
1994 -- libraries.
1995
1996 -- Also ignore the shared libraries which are :
1997
1998 -- UNIX / Windows VMS
1999 -- -lgnat-<version> -lgnat_<version> (7 + version'length chars)
2000 -- -lgnarl-<version> -lgnarl_<version> (8 + version'length chars)
2001
2002 if Next_Line (1 .. Nlast) /= "-static" and then
2003 Next_Line (1 .. Nlast) /= "-shared" and then
2004 Next_Line (1 .. Nlast) /= "-ldecgnat" and then
2005 Next_Line (1 .. Nlast) /= "-lgnarl" and then
2006 Next_Line (1 .. Nlast) /= "-lgnat" and then
2007 Next_Line
2008 (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) /=
2009 Shared_Lib ("gnarl") and then
2010 Next_Line
2011 (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) /=
2012 Shared_Lib ("gnat")
2013 then
2014 if Next_Line (1) /= '-' then
2015
2016 -- This is not an option, should we add it?
2017
2018 if Add_Object_Files then
2019 Opts.Increment_Last;
2020 Opts.Table (Opts.Last) :=
2021 new String'(Next_Line (1 .. Nlast));
2022 end if;
2023
2024 else
2025 -- Add all other options
2026
2027 Opts.Increment_Last;
2028 Opts.Table (Opts.Last) :=
2029 new String'(Next_Line (1 .. Nlast));
2030 end if;
2031 end if;
2032
2033 -- Next option, if any
2034
2035 Get_Next_Line;
2036 exit when Next_Line (1 .. Nlast) = End_Info;
2037
2038 -- Remove first eight characters " -- "
2039
2040 Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast);
2041 Nlast := Nlast - 8;
2042 end loop;
2043 end if;
2044
2045 Status := fclose (Fd);
2046
2047 -- Is it really right to ignore any close error ???
2048
2049 end Process_Binder_File;
2050
2051 ------------------
2052 -- Reset_Tables --
2053 ------------------
2054
2055 procedure Reset_Tables is
2056 begin
2057 Objects.Init;
2058 Objects_Htable.Reset;
2059 Foreigns.Init;
2060 ALIs.Init;
2061 Opts.Init;
2062 Processed_Projects.Reset;
2063 Library_Projs.Init;
2064 end Reset_Tables;
2065
2066 ---------------------------
2067 -- SALs_Use_Constructors --
2068 ---------------------------
2069
2070 function SALs_Use_Constructors return Boolean is
2071 function C_SALs_Init_Using_Constructors return Integer;
2072 pragma Import (C, C_SALs_Init_Using_Constructors,
2073 "__gnat_sals_init_using_constructors");
2074 begin
2075 return C_SALs_Init_Using_Constructors /= 0;
2076 end SALs_Use_Constructors;
2077
2078 end MLib.Prj;
Mirror of the offical gcc git repository hosted at gcc.gnu.org