?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
This commit was manufactured by cvs2svn to create branch 'gomp-branch'.
[official-gcc.git] / gcc / ada / gprcmd.adb
blob64bc74fd61d63d5a9d38db51f89586e6550ce7a7
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G P R C M D --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2002-2004 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 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 -- A utility used by Makefile.generic to handle multi-language builds.
28 -- gprcmd provides a set of commands so that the makefiles do not need
29 -- to depend on unix utilities not available on all targets.
30
31 -- The list of commands recognized by gprcmd are:
32
33 -- pwd display current directory
34 -- to_lower display next argument in lower case
35 -- to_absolute convert pathnames to absolute directories when needed
36 -- cat dump contents of a given file
37 -- extend handle recursive directories ("/**" notation)
38 -- deps post process dependency makefiles
39 -- stamp copy file time stamp from file1 to file2
40 -- prefix get the prefix of the GNAT installation
41 -- path convert a list of directories to a path list, inserting a
42 -- path separator after each directory, including the last one
43 -- ignore do nothing
44
45 with Gnatvsn;
46 with Osint; use Osint;
47 with Namet; use Namet;
48
49 with Ada.Characters.Handling; use Ada.Characters.Handling;
50 with Ada.Command_Line; use Ada.Command_Line;
51 with Ada.Text_IO; use Ada.Text_IO;
52 with GNAT.OS_Lib; use GNAT.OS_Lib;
53 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
54 with GNAT.Regpat; use GNAT.Regpat;
55
56
57 procedure Gprcmd is
58
59 -- ??? comments are thin throughout this unit
60
61 Gprdebug : constant String := To_Lower (Getenv ("GPRDEBUG").all);
62 Debug : constant Boolean := Gprdebug = "true";
63 -- When Debug is True, gprcmd displays its arguments to Standard_Error.
64 -- This is to help to debug.
65
66 procedure Cat (File : String);
67 -- Print the contents of file on standard output.
68 -- If the file cannot be read, exit the process with an error code.
69
70 procedure Check_Args (Condition : Boolean);
71 -- If Condition is false, print command invoked, then the usage,
72 -- and exit the process.
73
74 procedure Deps (Objext : String; File : String; GCC : Boolean);
75 -- Process $(CC) dependency file. If GCC is True, add a rule so that make
76 -- will not complain when a file is removed/added. If GCC is False, add a
77 -- rule to recompute the dependency file when needed
78
79 procedure Extend (Dir : String);
80 -- If Dir ends with /**, Put all subdirs recursively on standard output,
81 -- otherwise put Dir.
82
83 procedure Usage;
84 -- Display the command line options and exit the process.
85
86 procedure Copy_Time_Stamp (From, To : String);
87 -- Copy file time stamp from file From to file To.
88
89 procedure Display_Command;
90 -- Display the invoked command to Standard_Error
91
92 ---------
93 -- Cat --
94 ---------
95
96 procedure Cat (File : String) is
97 FD : File_Descriptor;
98 Buffer : String_Access;
99 Length : Integer;
100
101 begin
102 FD := Open_Read (File, Fmode => Binary);
103
104 if FD = Invalid_FD then
105 OS_Exit (2);
106 end if;
107
108 Length := Integer (File_Length (FD));
109 Buffer := new String (1 .. Length);
110 Length := Read (FD, Buffer.all'Address, Length);
111 Close (FD);
112 Put (Buffer.all);
113 Free (Buffer);
114 end Cat;
115
116 ----------------
117 -- Check_Args --
118 ----------------
119
120 procedure Check_Args (Condition : Boolean) is
121 begin
122 if not Condition then
123 Put_Line
124 (Standard_Error,
125 "bad call to gprcmd with" & Argument_Count'Img & " arguments.");
126
127 for J in 0 .. Argument_Count loop
128 Put (Standard_Error, Argument (J) & " ");
129 end loop;
130
131 New_Line (Standard_Error);
132
133 Usage;
134 end if;
135 end Check_Args;
136
137 ---------------------
138 -- Copy_Time_Stamp --
139 ---------------------
140
141 procedure Copy_Time_Stamp (From, To : String) is
142 function Copy_Attributes
143 (From, To : String;
144 Mode : Integer) return Integer;
145 pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
146 -- Mode = 0 - copy only time stamps.
147 -- Mode = 1 - copy time stamps and read/write/execute attributes
148
149 FD : File_Descriptor;
150
151 begin
152 if not Is_Regular_File (From) then
153 return;
154 end if;
155
156 FD := Create_File (To, Fmode => Binary);
157
158 if FD = Invalid_FD then
159 OS_Exit (2);
160 end if;
161
162 Close (FD);
163
164 if Copy_Attributes (From & ASCII.NUL, To & ASCII.NUL, 0) /= 0 then
165 OS_Exit (2);
166 end if;
167 end Copy_Time_Stamp;
168
169 ----------
170 -- Deps --
171 ----------
172
173 procedure Deps (Objext : String; File : String; GCC : Boolean) is
174 Colon : constant String := ':' & ASCII.LF;
175 NL : constant String := (1 => ASCII.LF);
176 Base : constant String := ' ' & Base_Name (File) & ": ";
177 FD : File_Descriptor;
178 Buffer : String_Access;
179 Length : Integer;
180 Obj_Regexp : constant Pattern_Matcher :=
181 Compile ("^.*\" & Objext & ": ");
182 Matched : Match_Array (0 .. 0);
183 Start : Natural;
184 First : Natural;
185 Last : Natural;
186
187 begin
188 FD := Open_Read_Write (File, Fmode => Binary);
189
190 if FD = Invalid_FD then
191 return;
192 end if;
193
194 Length := Integer (File_Length (FD));
195 Buffer := new String (1 .. Length);
196 Length := Read (FD, Buffer.all'Address, Length);
197
198 if GCC then
199 Lseek (FD, 0, Seek_End);
200 else
201 Close (FD);
202 FD := Create_File (File, Fmode => Binary);
203 end if;
204
205 Start := Buffer'First;
206
207 while Start <= Buffer'Last loop
208
209 -- Parse Buffer line by line
210
211 while Start < Buffer'Last
212 and then (Buffer (Start) = ASCII.CR
213 or else Buffer (Start) = ASCII.LF)
214 loop
215 Start := Start + 1;
216 end loop;
217
218 Last := Start;
219
220 while Last < Buffer'Last
221 and then Buffer (Last + 1) /= ASCII.CR
222 and then Buffer (Last + 1) /= ASCII.LF
223 loop
224 Last := Last + 1;
225 end loop;
226
227 Match (Obj_Regexp, Buffer (Start .. Last), Matched);
228
229 if GCC then
230 if Matched (0) = No_Match then
231 First := Start;
232 else
233 First := Matched (0).Last + 1;
234 end if;
235
236 Length := Write (FD, Buffer (First)'Address, Last - First + 1);
237
238 if Start = Last or else Buffer (Last) = '\' then
239 Length := Write (FD, NL (1)'Address, NL'Length);
240 else
241 Length := Write (FD, Colon (1)'Address, Colon'Length);
242 end if;
243
244 else
245 if Matched (0) = No_Match then
246 First := Start;
247 else
248 Length :=
249 Write (FD, Buffer (Start)'Address,
250 Matched (0).Last - Start - 1);
251 Length := Write (FD, Base (Base'First)'Address, Base'Length);
252 First := Matched (0).Last + 1;
253 end if;
254
255 Length := Write (FD, Buffer (First)'Address, Last - First + 1);
256 Length := Write (FD, NL (1)'Address, NL'Length);
257 end if;
258
259 Start := Last + 1;
260 end loop;
261
262 Close (FD);
263 Free (Buffer);
264 end Deps;
265
266 ---------------------
267 -- Display_Command --
268 ---------------------
269
270 procedure Display_Command is
271 begin
272 for J in 0 .. Argument_Count loop
273 Put (Standard_Error, Argument (J) & ' ');
274 end loop;
275
276 New_Line (Standard_Error);
277 end Display_Command;
278
279 ------------
280 -- Extend --
281 ------------
282
283 procedure Extend (Dir : String) is
284
285 procedure Recursive_Extend (D : String);
286 -- Recursively display all subdirectories of D
287
288 ----------------------
289 -- Recursive_Extend --
290 ----------------------
291
292 procedure Recursive_Extend (D : String) is
293 Iter : Dir_Type;
294 Buffer : String (1 .. 8192);
295 Last : Natural;
296
297 begin
298 Open (Iter, D);
299
300 loop
301 Read (Iter, Buffer, Last);
302 exit when Last = 0;
303
304 if Buffer (1 .. Last) /= "."
305 and then Buffer (1 .. Last) /= ".."
306 then
307 declare
308 Abs_Dir : constant String := D & "/" & Buffer (1 .. Last);
309 begin
310 if Is_Directory (Abs_Dir)
311 and then not Is_Symbolic_Link (Abs_Dir)
312 then
313 Put (' ' & Abs_Dir);
314 Recursive_Extend (Abs_Dir);
315 end if;
316 end;
317 end if;
318 end loop;
319
320 Close (Iter);
321
322 exception
323 when Directory_Error =>
324 null;
325 end Recursive_Extend;
326
327 -- Start of processing for Extend
328
329 begin
330 if Dir'Length < 3
331 or else (Dir (Dir'Last - 2) /= '/'
332 and then Dir (Dir'Last - 2) /= Directory_Separator)
333 or else Dir (Dir'Last - 1 .. Dir'Last) /= "**"
334 then
335 Put (Dir);
336 return;
337 end if;
338
339 declare
340 D : constant String := Dir (Dir'First .. Dir'Last - 3);
341 begin
342 Put (D);
343 Recursive_Extend (D);
344 end;
345 end Extend;
346
347 -----------
348 -- Usage --
349 -----------
350
351 procedure Usage is
352 begin
353 Put_Line (Standard_Error, "usage: gprcmd cmd [arguments]");
354 Put_Line (Standard_Error, "where cmd is one of the following commands:");
355 Put_Line (Standard_Error, " pwd " &
356 "display current directory");
357 Put_Line (Standard_Error, " to_lower " &
358 "display next argument in lower case");
359 Put_Line (Standard_Error, " to_absolute " &
360 "convert pathnames to absolute " &
361 "directories when needed");
362 Put_Line (Standard_Error, " cat " &
363 "dump contents of a given file");
364 Put_Line (Standard_Error, " extend " &
365 "handle recursive directories " &
366 "(""/**"" notation)");
367 Put_Line (Standard_Error, " deps " &
368 "post process dependency makefiles");
369 Put_Line (Standard_Error, " stamp " &
370 "copy file time stamp from file1 to file2");
371 Put_Line (Standard_Error, " prefix " &
372 "get the prefix of the GNAT installation");
373 Put_Line (Standard_Error, " path_sep " &
374 "returns the path separator");
375 Put_Line (Standard_Error, " linkopts " &
376 "process attribute Linker'Linker_Options");
377 Put_Line (Standard_Error, " ignore " &
378 "do nothing");
379 OS_Exit (1);
380 end Usage;
381
382 -- Start of processing for Gprcmd
383
384 begin
385 if Debug then
386 Display_Command;
387 end if;
388
389 Check_Args (Argument_Count > 0);
390
391 declare
392 Cmd : constant String := Argument (1);
393
394 begin
395 if Cmd = "-v" then
396
397 -- Output on standard error, because only returned values should
398 -- go to standard output.
399
400 Put (Standard_Error, "GPRCMD ");
401 Put (Standard_Error, Gnatvsn.Gnat_Version_String);
402 Put_Line (Standard_Error,
403 " Copyright 2002-2004, Free Software Fundation, Inc.");
404 Usage;
405
406 elsif Cmd = "pwd" then
407 declare
408 CD : constant String := Get_Current_Dir;
409 begin
410 Put (Format_Pathname (CD (CD'First .. CD'Last - 1), UNIX));
411 end;
412
413 elsif Cmd = "cat" then
414 Check_Args (Argument_Count = 2);
415 Cat (Argument (2));
416
417 elsif Cmd = "to_lower" then
418 Check_Args (Argument_Count >= 2);
419
420 for J in 2 .. Argument_Count loop
421 Put (To_Lower (Argument (J)));
422
423 if J < Argument_Count then
424 Put (' ');
425 end if;
426 end loop;
427
428 elsif Cmd = "to_absolute" then
429 Check_Args (Argument_Count > 2);
430
431 declare
432 Dir : constant String := Argument (2);
433
434 begin
435 for J in 3 .. Argument_Count loop
436 if Is_Absolute_Path (Argument (J)) then
437 Put (Format_Pathname (Argument (J), UNIX));
438 else
439 Put (Format_Pathname
440 (Normalize_Pathname
441 (Format_Pathname (Argument (J)),
442 Format_Pathname (Dir)),
443 UNIX));
444 end if;
445
446 if J < Argument_Count then
447 Put (' ');
448 end if;
449 end loop;
450 end;
451
452 elsif Cmd = "extend" then
453 Check_Args (Argument_Count >= 2);
454
455 declare
456 Dir : constant String := Argument (2);
457
458 begin
459 -- Loop to remove quotes that may have been added around arguments
460
461 for J in 3 .. Argument_Count loop
462 declare
463 Arg : constant String := Argument (J);
464 First : Natural := Arg'First;
465 Last : Natural := Arg'Last;
466
467 begin
468 if Arg (First) = '"' and then Arg (Last) = '"' then
469 First := First + 1;
470 Last := Last - 1;
471 end if;
472
473 if Is_Absolute_Path (Arg (First .. Last)) then
474 Extend (Format_Pathname (Arg (First .. Last), UNIX));
475 else
476 Extend
477 (Format_Pathname
478 (Normalize_Pathname
479 (Format_Pathname (Arg (First .. Last)),
480 Format_Pathname (Dir)),
481 UNIX));
482 end if;
483
484 if J < Argument_Count then
485 Put (' ');
486 end if;
487 end;
488 end loop;
489 end;
490
491 elsif Cmd = "deps" then
492 Check_Args (Argument_Count in 3 .. 4);
493 Deps (Argument (2), Argument (3), GCC => Argument_Count = 4);
494
495 elsif Cmd = "stamp" then
496 Check_Args (Argument_Count = 3);
497 Copy_Time_Stamp (Argument (2), Argument (3));
498
499 elsif Cmd = "prefix" then
500
501 -- Find the GNAT prefix. gprcmd is found in <prefix>/bin.
502 -- So we find the full path of gprcmd, verify that it is in a
503 -- subdirectory "bin", and return the <prefix> if it is the case.
504 -- Otherwise, nothing is returned.
505
506 Find_Program_Name;
507
508 declare
509 Path : constant String_Access :=
510 Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
511 Index : Natural;
512
513 begin
514 if Path /= null then
515 Index := Path'Last;
516
517 while Index >= Path'First + 4 loop
518 exit when Path (Index) = Directory_Separator;
519 Index := Index - 1;
520 end loop;
521
522 if Index > Path'First + 5
523 and then Path (Index - 3 .. Index - 1) = "bin"
524 and then Path (Index - 4) = Directory_Separator
525 then
526 -- We have found the <prefix>, return it
527
528 Put (Path (Path'First .. Index - 5));
529 end if;
530 end if;
531 end;
532
533 -- For "path" just add path separator after each directory argument
534
535 elsif Cmd = "path_sep" then
536 Put (Path_Separator);
537
538 -- Check the linker options for relative paths. Insert the project
539 -- base dir before relative paths.
540
541 elsif Cmd = "linkopts" then
542 Check_Args (Argument_Count >= 2);
543
544 -- First argument is the base directory of the project file
545
546 declare
547 Base_Dir : constant String := Argument (2) & '/';
548 begin
549 -- process the remainder of the arguments
550
551 for J in 3 .. Argument_Count loop
552 declare
553 Arg : constant String := Argument (J);
554 begin
555 -- If it is a switch other than a -L switch, just send back
556 -- the argument.
557
558 if Arg (Arg'First) = '-' and then
559 (Arg'Length <= 2 or else Arg (Arg'First + 1) /= 'L')
560 then
561 Put (Arg);
562
563 else
564 -- If it is a file, check if its path is relative, and
565 -- if it is relative, add <project base dir>/ in front.
566 -- Otherwise just send back the argument.
567
568 if Arg'Length <= 2
569 or else Arg (Arg'First .. Arg'First + 1) /= "-L"
570 then
571 if not Is_Absolute_Path (Arg) then
572 Put (Base_Dir);
573 end if;
574
575 Put (Arg);
576
577 -- For -L switches, check if the path is relative and
578 -- proceed similarly.
579
580 else
581 Put ("-L");
582
583 if
584 not Is_Absolute_Path (Arg (Arg'First + 2 .. Arg'Last))
585 then
586 Put (Base_Dir);
587 end if;
588
589 Put (Arg (Arg'First + 2 .. Arg'Last));
590 end if;
591 end if;
592 end;
593
594 -- Insert a space between each processed argument
595
596 if J /= Argument_Count then
597 Put (' ');
598 end if;
599 end loop;
600 end;
601
602 -- For "ignore" do nothing
603
604 elsif Cmd = "ignore" then
605 null;
606
607 -- Unknown command
608
609 else
610 Check_Args (False);
611 end if;
612 end;
613 end Gprcmd;
Mirror of the offical gcc git repository hosted at gcc.gnu.org