?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* builtins.def (BUILT_IN_STACK_ALLOC): Remove.
[official-gcc.git] / gcc / ada / gprcmd.adb
blob323059e395e37d18b9bb860eed8f663eda6d017c
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
303 exit when Last = 0;
304
305 if Buffer (1 .. Last) /= "."
306 and then Buffer (1 .. Last) /= ".."
307 then
308 declare
309 Abs_Dir : constant String := D & Buffer (1 .. Last);
310
311 begin
312 if Is_Directory (Abs_Dir)
313 and then not Is_Symbolic_Link (Abs_Dir)
314 then
315 Put (' ' & Abs_Dir);
316 Recursive_Extend (Abs_Dir & '/');
317 end if;
318 end;
319 end if;
320 end loop;
321
322 Close (Iter);
323
324 exception
325 when Directory_Error =>
326 null;
327 end Recursive_Extend;
328
329 -- Start of processing for Extend
330
331 begin
332 if Dir'Length < 3
333 or else (Dir (Dir'Last - 2) /= '/'
334 and then Dir (Dir'Last - 2) /= Directory_Separator)
335 or else Dir (Dir'Last - 1 .. Dir'Last) /= "**"
336 then
337 Put (Dir);
338 return;
339 end if;
340
341 declare
342 D : constant String := Dir (Dir'First .. Dir'Last - 2);
343 begin
344 Put (D);
345 Recursive_Extend (D);
346 end;
347 end Extend;
348
349 -----------
350 -- Usage --
351 -----------
352
353 procedure Usage is
354 begin
355 Put_Line (Standard_Error, "usage: gprcmd cmd [arguments]");
356 Put_Line (Standard_Error, "where cmd is one of the following commands:");
357 Put_Line (Standard_Error, " pwd " &
358 "display current directory");
359 Put_Line (Standard_Error, " to_lower " &
360 "display next argument in lower case");
361 Put_Line (Standard_Error, " to_absolute " &
362 "convert pathnames to absolute " &
363 "directories when needed");
364 Put_Line (Standard_Error, " cat " &
365 "dump contents of a given file");
366 Put_Line (Standard_Error, " extend " &
367 "handle recursive directories " &
368 "(""/**"" notation)");
369 Put_Line (Standard_Error, " deps " &
370 "post process dependency makefiles");
371 Put_Line (Standard_Error, " stamp " &
372 "copy file time stamp from file1 to file2");
373 Put_Line (Standard_Error, " prefix " &
374 "get the prefix of the GNAT installation");
375 Put_Line (Standard_Error, " path_sep " &
376 "returns the path separator");
377 Put_Line (Standard_Error, " linkopts " &
378 "process attribute Linker'Linker_Options");
379 Put_Line (Standard_Error, " ignore " &
380 "do nothing");
381 OS_Exit (1);
382 end Usage;
383
384 -- Start of processing for Gprcmd
385
386 begin
387 if Debug then
388 Display_Command;
389 end if;
390
391 Check_Args (Argument_Count > 0);
392
393 declare
394 Cmd : constant String := Argument (1);
395
396 begin
397 if Cmd = "-v" then
398
399 -- Output on standard error, because only returned values should
400 -- go to standard output.
401
402 Put (Standard_Error, "GPRCMD ");
403 Put (Standard_Error, Gnatvsn.Gnat_Version_String);
404 Put_Line (Standard_Error,
405 " Copyright 2002-2004, Free Software Fundation, Inc.");
406 Usage;
407
408 elsif Cmd = "pwd" then
409 Put (Format_Pathname (Get_Current_Dir, UNIX));
410
411 elsif Cmd = "cat" then
412 Check_Args (Argument_Count = 2);
413 Cat (Argument (2));
414
415 elsif Cmd = "to_lower" then
416 Check_Args (Argument_Count >= 2);
417
418 for J in 2 .. Argument_Count loop
419 Put (To_Lower (Argument (J)));
420
421 if J < Argument_Count then
422 Put (' ');
423 end if;
424 end loop;
425
426 elsif Cmd = "to_absolute" then
427 Check_Args (Argument_Count > 2);
428
429 declare
430 Dir : constant String := Argument (2);
431
432 begin
433 for J in 3 .. Argument_Count loop
434 if Is_Absolute_Path (Argument (J)) then
435 Put (Format_Pathname (Argument (J), UNIX));
436 else
437 Put (Format_Pathname
438 (Normalize_Pathname
439 (Format_Pathname (Argument (J)),
440 Format_Pathname (Dir)),
441 UNIX));
442 end if;
443
444 if J < Argument_Count then
445 Put (' ');
446 end if;
447 end loop;
448 end;
449
450 elsif Cmd = "extend" then
451 Check_Args (Argument_Count >= 2);
452
453 declare
454 Dir : constant String := Argument (2);
455
456 begin
457 -- Loop to remove quotes that may have been added around arguments
458
459 for J in 3 .. Argument_Count loop
460 declare
461 Arg : constant String := Argument (J);
462 First : Natural := Arg'First;
463 Last : Natural := Arg'Last;
464
465 begin
466 if Arg (First) = '"' and then Arg (Last) = '"' then
467 First := First + 1;
468 Last := Last - 1;
469 end if;
470
471 if Is_Absolute_Path (Arg (First .. Last)) then
472 Extend (Format_Pathname (Arg (First .. Last), UNIX));
473 else
474 Extend
475 (Format_Pathname
476 (Normalize_Pathname
477 (Format_Pathname (Arg (First .. Last)),
478 Format_Pathname (Dir)),
479 UNIX));
480 end if;
481
482 if J < Argument_Count then
483 Put (' ');
484 end if;
485 end;
486 end loop;
487 end;
488
489 elsif Cmd = "deps" then
490 Check_Args (Argument_Count in 3 .. 4);
491 Deps (Argument (2), Argument (3), GCC => Argument_Count = 4);
492
493 elsif Cmd = "stamp" then
494 Check_Args (Argument_Count = 3);
495 Copy_Time_Stamp (Argument (2), Argument (3));
496
497 elsif Cmd = "prefix" then
498
499 -- Find the GNAT prefix. gprcmd is found in <prefix>/bin.
500 -- So we find the full path of gprcmd, verify that it is in a
501 -- subdirectory "bin", and return the <prefix> if it is the case.
502 -- Otherwise, nothing is returned.
503
504 Find_Program_Name;
505
506 declare
507 Path : constant String_Access :=
508 Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
509 Index : Natural;
510
511 begin
512 if Path /= null then
513 Index := Path'Last;
514
515 while Index >= Path'First + 4 loop
516 exit when Path (Index) = Directory_Separator;
517 Index := Index - 1;
518 end loop;
519
520 if Index > Path'First + 5
521 and then Path (Index - 3 .. Index - 1) = "bin"
522 and then Path (Index - 4) = Directory_Separator
523 then
524 -- We have found the <prefix>, return it
525
526 Put (Path (Path'First .. Index - 5));
527 end if;
528 end if;
529 end;
530
531 -- For "path" just add path separator after each directory argument
532
533 elsif Cmd = "path_sep" then
534 Put (Path_Separator);
535
536 -- Check the linker options for relative paths. Insert the project
537 -- base dir before relative paths.
538
539 elsif Cmd = "linkopts" then
540 Check_Args (Argument_Count >= 2);
541
542 -- First argument is the base directory of the project file
543
544 declare
545 Base_Dir : constant String := Argument (2) & '/';
546 begin
547 -- process the remainder of the arguments
548
549 for J in 3 .. Argument_Count loop
550 declare
551 Arg : constant String := Argument (J);
552 begin
553 -- If it is a switch other than a -L switch, just send back
554 -- the argument.
555
556 if Arg (Arg'First) = '-' and then
557 (Arg'Length <= 2 or else Arg (Arg'First + 1) /= 'L')
558 then
559 Put (Arg);
560
561 else
562 -- If it is a file, check if its path is relative, and
563 -- if it is relative, add <project base dir>/ in front.
564 -- Otherwise just send back the argument.
565
566 if Arg'Length <= 2
567 or else Arg (Arg'First .. Arg'First + 1) /= "-L"
568 then
569 if not Is_Absolute_Path (Arg) then
570 Put (Base_Dir);
571 end if;
572
573 Put (Arg);
574
575 -- For -L switches, check if the path is relative and
576 -- proceed similarly.
577
578 else
579 Put ("-L");
580
581 if
582 not Is_Absolute_Path (Arg (Arg'First + 2 .. Arg'Last))
583 then
584 Put (Base_Dir);
585 end if;
586
587 Put (Arg (Arg'First + 2 .. Arg'Last));
588 end if;
589 end if;
590 end;
591
592 -- Insert a space between each processed argument
593
594 if J /= Argument_Count then
595 Put (' ');
596 end if;
597 end loop;
598 end;
599
600 -- For "ignore" do nothing
601
602 elsif Cmd = "ignore" then
603 null;
604
605 -- Unknown command
606
607 else
608 Check_Args (False);
609 end if;
610 end;
611 end Gprcmd;
Mirror of the offical gcc git repository hosted at gcc.gnu.org