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