1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B --
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2004, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Interfaces.C.Strings;
with Hostparm;
with Opt;
with Output; use Output;
with Namet; use Namet;
with MLib.Utl; use MLib.Utl;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
package body MLib is
-------------------
-- Build_Library --
-------------------
procedure Build_Library
(Ofiles : Argument_List;
Afiles : Argument_List;
Output_File : String;
Output_Dir : String)
is
pragma Warnings (Off, Afiles);
use GNAT.OS_Lib;
begin
if not Opt.Quiet_Output then
Write_Line ("building a library...");
Write_Str (" make ");
Write_Line (Output_File);
end if;
Ar (Output_Dir & "/lib" & Output_File & ".a", Objects => Ofiles);
end Build_Library;
------------------------
-- Check_Library_Name --
------------------------
procedure Check_Library_Name (Name : String) is
begin
if Name'Length = 0 then
Fail ("library name cannot be empty");
end if;
if Name'Length > Max_Characters_In_Library_Name then
Fail ("illegal library name """, Name, """: too long");
end if;
if not Is_Letter (Name (Name'First)) then
Fail ("illegal library name """,
Name,
""": should start with a letter");
end if;
for Index in Name'Range loop
if not Is_Alphanumeric (Name (Index)) then
Fail ("illegal library name """,
Name,
""": should include only letters and digits");
end if;
end loop;
end Check_Library_Name;
--------------------
-- Copy_ALI_Files --
--------------------
procedure Copy_ALI_Files
(Files : Argument_List;
To : Name_Id;
Interfaces : String_List)
is
Success : Boolean := False;
To_Dir : constant String := Get_Name_String (To);
Interface : Boolean := False;
procedure Verbose_Copy (Index : Positive);
-- In verbose mode, output a message that the indexed file is copied
-- to the destination directory.
------------------
-- Verbose_Copy --
------------------
procedure Verbose_Copy (Index : Positive) is
begin
if Opt.Verbose_Mode then
Write_Str ("Copying """);
Write_Str (Files (Index).all);
Write_Str (""" to """);
Write_Str (To_Dir);
Write_Line ("""");
end if;
end Verbose_Copy;
begin
if Interfaces'Length = 0 then
-- If there are no Interfaces, copy all the ALI files as is
for Index in Files'Range loop
Verbose_Copy (Index);
Copy_File
(Files (Index).all,
To_Dir,
Success,
Mode => Overwrite,
Preserve => Preserve);
exit when not Success;
end loop;
else
-- Copy only the interface ALI file, and put the special indicator
-- "SL" on the P line.
for Index in Files'Range loop
declare
File_Name : String := Base_Name (Files (Index).all);
begin
Canonical_Case_File_Name (File_Name);
-- Check if this is one of the interface ALIs
Interface := False;
for Index in Interfaces'Range loop
if File_Name = Interfaces (Index).all then
Interface := True;
exit;
end if;
end loop;
-- If it is an interface ALI, copy line by line. Insert
-- the interface indication at the end of the P line.
-- Do not copy ALI files that are not Interfaces.
if Interface then
Success := False;
Verbose_Copy (Index);
declare
FD : File_Descriptor;
Len : Integer;
Actual_Len : Integer;
S : String_Access;
Curr : Natural;
P_Line_Found : Boolean;
Status : Boolean;
begin
-- Open the file
Name_Len := Files (Index)'Length;
Name_Buffer (1 .. Name_Len) := Files (Index).all;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ASCII.NUL;
FD := Open_Read (Name_Buffer'Address, Binary);
if FD /= Invalid_FD then
Len := Integer (File_Length (FD));
S := new String (1 .. Len + 3);
-- Read the file. Note that the loop is not necessary
-- since the whole file is read at once except on VMS.
Curr := 1;
Actual_Len := Len;
while Actual_Len /= 0 loop
Actual_Len := Read (FD, S (Curr)'Address, Len);
Curr := Curr + Actual_Len;
end loop;
-- We are done with the input file, so we close it
Close (FD, Status);
-- We simply ignore any bad status
P_Line_Found := False;
-- Look for the P line. When found, add marker SL
-- at the beginning of the P line.
for Index in 1 .. Len - 3 loop
if (S (Index) = ASCII.LF or else
S (Index) = ASCII.CR)
and then
S (Index + 1) = 'P'
then
S (Index + 5 .. Len + 3) := S (Index + 2 .. Len);
S (Index + 2 .. Index + 4) := " SL";
P_Line_Found := True;
exit;
end if;
end loop;
if P_Line_Found then
-- Create new modified ALI file
Name_Len := To_Dir'Length;
Name_Buffer (1 .. Name_Len) := To_Dir;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Directory_Separator;
Name_Buffer
(Name_Len + 1 .. Name_Len + File_Name'Length) :=
File_Name;
Name_Len := Name_Len + File_Name'Length + 1;
Name_Buffer (Name_Len) := ASCII.NUL;
FD := Create_File (Name_Buffer'Address, Binary);
-- Write the modified text and close the newly
-- created file.
if FD /= Invalid_FD then
Actual_Len := Write (FD, S (1)'Address, Len + 3);
Close (FD, Status);
-- Set Success to True only if the newly
-- created file has been correctly written.
Success := Status and Actual_Len = Len + 3;
if Success then
Set_Read_Only (
Name_Buffer (1 .. Name_Len - 1));
end if;
end if;
end if;
end if;
end;
else
-- This is not an interface ALI
Success := True;
end if;
end;
if not Success then
Fail ("could not copy ALI files to library dir");
end if;
end loop;
end if;
end Copy_ALI_Files;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
function Linker_Library_Path_Option return String_Access is
Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
-- Pointer to string representing the native linker option which
-- specifies the path where the dynamic loader should find shared
-- libraries. Equal to null string if this system doesn't support it.
S : constant String := Interfaces.C.Strings.Value (Run_Path_Option_Ptr);
begin
if S'Length = 0 then
return null;
else
return new String'(S);
end if;
end Linker_Library_Path_Option;
-- Package elaboration
begin
-- Copy_Attributes always fails on VMS
if Hostparm.OpenVMS then
Preserve := None;
end if;
end MLib;
|
