Daily bump.
[official-gcc.git] / gcc / ada / gnatlbr.adb
blob7be1d494baf02ace04c777df7f57a1f78cf74b0d
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T L B R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1997-2008, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 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 ------------------------------------------------------------------------------
26 -- Program to create, set, or delete an alternate runtime library
28 -- Works by calling an appropriate target specific Makefile residing
29 -- in the default library object (e.g. adalib) directory from the context
30 -- of the new library objects directory.
32 -- Command line arguments are:
33 -- 1st: --[create | set | delete]=<directory_spec>
34 -- --create : Build a library
35 -- --set : Set environment variables to point to a library
36 -- --delete : Delete a library
38 -- 2nd: --config=<file_spec>
39 -- A -gnatg valid file containing desired configuration pragmas
41 -- This program is currently used only on Alpha/VMS
43 with Ada.Command_Line; use Ada.Command_Line;
44 with Ada.Text_IO; use Ada.Text_IO;
45 with GNAT.OS_Lib; use GNAT.OS_Lib;
46 with Gnatvsn; use Gnatvsn;
47 with Interfaces.C_Streams; use Interfaces.C_Streams;
48 with Osint; use Osint;
49 with System;
51 procedure GnatLbr is
52 pragma Ident (Gnat_Static_Version_String);
54 type Lib_Mode is (None, Create, Set, Delete);
55 Next_Arg : Integer;
56 Mode : Lib_Mode := None;
57 ADC_File : String_Access := null;
58 Lib_Dir : String_Access := null;
59 Make : constant String := "make";
60 Make_Path : String_Access;
62 procedure Create_Directory (Name : System.Address; Mode : Integer);
63 pragma Import (C, Create_Directory, "decc$mkdir");
65 begin
66 if Argument_Count = 0 then
67 Put ("Usage: ");
68 Put_Line
69 ("gnatlbr --[create|set|delete]=<directory> [--config=<file>]");
70 Exit_Program (E_Fatal);
71 end if;
73 Next_Arg := 1;
75 loop
76 exit when Next_Arg > Argument_Count;
78 Process_One_Arg : declare
79 Arg : constant String := Argument (Next_Arg);
81 begin
82 if Arg'Length > 9 and then Arg (1 .. 9) = "--create=" then
83 if Mode = None then
84 Mode := Create;
85 Lib_Dir := new String'(Arg (10 .. Arg'Last));
86 else
87 Put_Line (Standard_Error, "Error: Multiple modes specified");
88 Exit_Program (E_Fatal);
89 end if;
91 elsif Arg'Length > 6 and then Arg (1 .. 6) = "--set=" then
92 if Mode = None then
93 Mode := Set;
94 Lib_Dir := new String'(Arg (7 .. Arg'Last));
95 else
96 Put_Line (Standard_Error, "Error: Multiple modes specified");
97 Exit_Program (E_Fatal);
98 end if;
100 elsif Arg'Length > 9 and then Arg (1 .. 9) = "--delete=" then
101 if Mode = None then
102 Mode := Delete;
103 Lib_Dir := new String'(Arg (10 .. Arg'Last));
104 else
105 Put_Line (Standard_Error, "Error: Multiple modes specified");
106 Exit_Program (E_Fatal);
107 end if;
109 elsif Arg'Length > 9 and then Arg (1 .. 9) = "--config=" then
110 if ADC_File /= null then
111 Put_Line (Standard_Error,
112 "Error: Multiple gnat.adc files specified");
113 Exit_Program (E_Fatal);
114 end if;
116 ADC_File := new String'(Arg (10 .. Arg'Last));
118 else
119 Put_Line (Standard_Error, "Error: Unrecognized option: " & Arg);
120 Exit_Program (E_Fatal);
122 end if;
123 end Process_One_Arg;
125 Next_Arg := Next_Arg + 1;
126 end loop;
128 case Mode is
129 when Create =>
131 -- Validate arguments
133 if Lib_Dir = null then
134 Put_Line (Standard_Error, "Error: No library directory specified");
135 Exit_Program (E_Fatal);
136 end if;
138 if Is_Directory (Lib_Dir.all) then
139 Put_Line (Standard_Error,
140 "Error:" & Lib_Dir.all & " already exists");
141 Exit_Program (E_Fatal);
142 end if;
144 if ADC_File = null then
145 Put_Line (Standard_Error,
146 "Error: No configuration file specified");
147 Exit_Program (E_Fatal);
148 end if;
150 if not Is_Regular_File (ADC_File.all) then
151 Put_Line (Standard_Error,
152 "Error: " & ADC_File.all & " doesn't exist");
153 Exit_Program (E_Fatal);
154 end if;
156 Create_Block : declare
157 Success : Boolean;
158 Make_Args : Argument_List (1 .. 9);
159 C_Lib_Dir : String := Lib_Dir.all & ASCII.NUL;
160 C_ADC_File : String := ADC_File.all & ASCII.NUL;
161 F_ADC_File : String (1 .. max_path_len);
162 F_ADC_File_Len : Integer := max_path_len;
163 Include_Dirs : Integer;
164 Object_Dirs : Integer;
165 Include_Dir : array (Integer range 1 .. 256) of String_Access;
166 Object_Dir : array (Integer range 1 .. 256) of String_Access;
167 Include_Dir_Name : String_Access;
168 Object_Dir_Name : String_Access;
170 begin
171 -- Create the new top level library directory
173 if not Is_Directory (Lib_Dir.all) then
174 Create_Directory (C_Lib_Dir'Address, 8#755#);
175 end if;
177 full_name (C_ADC_File'Address, F_ADC_File'Address);
179 for I in 1 .. max_path_len loop
180 if F_ADC_File (I) = ASCII.NUL then
181 F_ADC_File_Len := I - 1;
182 exit;
183 end if;
184 end loop;
187 -- Make a list of the default library source and object
188 -- directories. Usually only one, except on VMS where
189 -- there are two.
191 Include_Dirs := 0;
192 Include_Dir_Name := new String'(Include_Dir_Default_Prefix);
193 Get_Next_Dir_In_Path_Init (Include_Dir_Name);
195 loop
196 declare
197 Dir : constant String_Access := String_Access
198 (Get_Next_Dir_In_Path (Include_Dir_Name));
199 begin
200 exit when Dir = null;
201 Include_Dirs := Include_Dirs + 1;
202 Include_Dir (Include_Dirs) :=
203 String_Access (Normalize_Directory_Name (Dir.all));
204 end;
205 end loop;
207 Object_Dirs := 0;
208 Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
209 Get_Next_Dir_In_Path_Init (Object_Dir_Name);
211 loop
212 declare
213 Dir : constant String_Access :=
214 String_Access
215 (Get_Next_Dir_In_Path (Object_Dir_Name));
216 begin
217 exit when Dir = null;
218 Object_Dirs := Object_Dirs + 1;
219 Object_Dir (Object_Dirs)
220 := String_Access (Normalize_Directory_Name (Dir.all));
221 end;
222 end loop;
224 -- "Make" an alternate sublibrary for each default sublibrary
226 for Dirs in 1 .. Object_Dirs loop
227 Make_Args (1) :=
228 new String'("-C");
230 Make_Args (2) :=
231 new String'(Lib_Dir.all);
233 -- Resolve /gnu on VMS by converting to host format and then
234 -- convert resolved path back to canonical format for the
235 -- make program. This fixes the problem that can occur when
236 -- GNU: is a search path pointing to multiple versions of GNAT.
238 Make_Args (3) :=
239 new String'("ADA_INCLUDE_PATH=" &
240 To_Canonical_Dir_Spec
241 (To_Host_Dir_Spec
242 (Include_Dir (Dirs).all, True).all, True).all);
244 Make_Args (4) :=
245 new String'("ADA_OBJECTS_PATH=" &
246 To_Canonical_Dir_Spec
247 (To_Host_Dir_Spec
248 (Object_Dir (Dirs).all, True).all, True).all);
250 Make_Args (5) :=
251 new String'("GNAT_ADC_FILE="
252 & F_ADC_File (1 .. F_ADC_File_Len));
254 Make_Args (6) :=
255 new String'("LIBRARY_VERSION=" & '"' &
256 Verbose_Library_Version & '"');
258 Make_Args (7) :=
259 new String'("-f");
261 Make_Args (8) :=
262 new String'(Object_Dir (Dirs).all & "Makefile.lib");
264 Make_Args (9) :=
265 new String'("create");
267 Make_Path := Locate_Exec_On_Path (Make);
268 Put (Make);
270 for J in 1 .. Make_Args'Last loop
271 Put (" ");
272 Put (Make_Args (J).all);
273 end loop;
275 New_Line;
276 Spawn (Make_Path.all, Make_Args, Success);
278 if not Success then
279 Put_Line (Standard_Error, "Error: Make failed");
280 Exit_Program (E_Fatal);
281 end if;
282 end loop;
283 end Create_Block;
285 when Set =>
287 -- Validate arguments
289 if Lib_Dir = null then
290 Put_Line (Standard_Error,
291 "Error: No library directory specified");
292 Exit_Program (E_Fatal);
293 end if;
295 if not Is_Directory (Lib_Dir.all) then
296 Put_Line (Standard_Error,
297 "Error: " & Lib_Dir.all & " doesn't exist");
298 Exit_Program (E_Fatal);
299 end if;
301 if ADC_File = null then
302 Put_Line (Standard_Error,
303 "Error: No configuration file specified");
304 Exit_Program (E_Fatal);
305 end if;
307 if not Is_Regular_File (ADC_File.all) then
308 Put_Line (Standard_Error,
309 "Error: " & ADC_File.all & " doesn't exist");
310 Exit_Program (E_Fatal);
311 end if;
313 -- Give instructions
315 Put_Line ("Copy the contents of "
316 & ADC_File.all & " into your GNAT.ADC file");
317 Put_Line ("and use GNAT Make qualifier /OBJECT_SEARCH=("
318 & To_Host_Dir_Spec
319 (Lib_Dir (Lib_Dir'First .. Lib_Dir'Last) & "/declib", False).all
320 & ","
321 & To_Host_Dir_Spec
322 (Lib_Dir (Lib_Dir'First .. Lib_Dir'Last) & "/adalib", False).all
323 & ")");
324 Put_Line ("or else define ADA_OBJECTS_PATH as " & '"'
325 & To_Host_Dir_Spec
326 (Lib_Dir (Lib_Dir'First .. Lib_Dir'Last) & "/declib", False).all
327 & ','
328 & To_Host_Dir_Spec
329 (Lib_Dir (Lib_Dir'First .. Lib_Dir'Last) & "/adalib", False).all
330 & '"');
332 when Delete =>
334 -- Give instructions
336 Put_Line ("GNAT Librarian DELETE not yet implemented.");
337 Put_Line ("Use appropriate system tools to remove library");
339 when None =>
340 Put_Line (Standard_Error,
341 "Error: No mode (create|set|delete) specified");
342 Exit_Program (E_Fatal);
344 end case;
346 end GnatLbr;