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