?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* dwarf2out.c (loc_descriptor_from_tree, case CONSTRUCTOR): New case.
[official-gcc.git] / gcc / ada / gnatcmd.adb
blobb754aff0245b46e7d33879b754b6442620bd3b28
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T C M D --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1996-2002 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 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
28
29 with Csets;
30 with MLib.Tgt;
31 with MLib.Utl;
32 with Namet; use Namet;
33 with Opt;
34 with Osint; use Osint;
35 with Output;
36 with Prj; use Prj;
37 with Prj.Env;
38 with Prj.Ext; use Prj.Ext;
39 with Prj.Pars;
40 with Prj.Util; use Prj.Util;
41 with Sdefault; use Sdefault;
42 with Snames; use Snames;
43 with Stringt; use Stringt;
44 with Table;
45 with Types; use Types;
46 with Hostparm; use Hostparm;
47 -- Used to determine if we are in VMS or not for error message purposes
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
53 with Gnatvsn;
54 with GNAT.OS_Lib; use GNAT.OS_Lib;
55
56 with Table;
57
58 procedure GNATCmd is
59
60 Ada_Include_Path : constant String := "ADA_INCLUDE_PATH";
61 Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH";
62
63 Project_File : String_Access;
64 Project : Prj.Project_Id;
65 Current_Verbosity : Prj.Verbosity := Prj.Default;
66 Tool_Package_Name : Name_Id := No_Name;
67
68 -- This flag indicates a switch -p (for gnatxref and gnatfind) for
69 -- an old fashioned project file. -p cannot be used in conjonction
70 -- with -P.
71
72 Old_Project_File_Used : Boolean := False;
73
74 -- A table to keep the switches on the command line
75
76 package Last_Switches is new Table.Table
77 (Table_Component_Type => String_Access,
78 Table_Index_Type => Integer,
79 Table_Low_Bound => 1,
80 Table_Initial => 20,
81 Table_Increment => 100,
82 Table_Name => "Gnatcmd.Last_Switches");
83
84 -- A table to keep the switches from the project file
85
86 package First_Switches is new Table.Table
87 (Table_Component_Type => String_Access,
88 Table_Index_Type => Integer,
89 Table_Low_Bound => 1,
90 Table_Initial => 20,
91 Table_Increment => 100,
92 Table_Name => "Gnatcmd.First_Switches");
93
94 ------------------
95 -- SWITCH TABLE --
96 ------------------
97
98 -- The switch tables contain an entry for each switch recognized by the
99 -- command processor. The syntax of entries is as follows:
100
101 -- SWITCH_STRING ::= "/ command-qualifier-name TRANSLATION"
102
103 -- TRANSLATION ::=
104 -- DIRECT_TRANSLATION
105 -- | DIRECTORIES_TRANSLATION
106 -- | FILE_TRANSLATION
107 -- | NO_SPACE_FILE_TRANSL
108 -- | NUMERIC_TRANSLATION
109 -- | STRING_TRANSLATION
110 -- | OPTIONS_TRANSLATION
111 -- | COMMANDS_TRANSLATION
112 -- | ALPHANUMPLUS_TRANSLATION
113 -- | OTHER_TRANSLATION
114
115 -- DIRECT_TRANSLATION ::= space UNIX_SWITCHES
116 -- DIRECTORIES_TRANSLATION ::= =* UNIX_SWITCH *
117 -- DIRECTORY_TRANSLATION ::= =% UNIX_SWITCH %
118 -- FILE_TRANSLATION ::= =@ UNIX_SWITCH @
119 -- NO_SPACE_FILE_TRANSL ::= =< UNIX_SWITCH >
120 -- NUMERIC_TRANSLATION ::= =# UNIX_SWITCH # | # number #
121 -- STRING_TRANSLATION ::= =" UNIX_SWITCH "
122 -- OPTIONS_TRANSLATION ::= =OPTION {space OPTION}
123 -- COMMANDS_TRANSLATION ::= =? ARGS space command-name
124 -- ALPHANUMPLUS_TRANSLATION ::= =| UNIX_SWITCH |
125
126 -- UNIX_SWITCHES ::= UNIX_SWITCH {, UNIX_SWITCH}
127
128 -- UNIX_SWITCH ::= unix-switch-string | !unix-switch-string | `string'
129
130 -- OPTION ::= option-name space UNIX_SWITCHES
131
132 -- ARGS ::= -cargs | -bargs | -largs
133
134 -- Here command-qual is the name of the switch recognized by the GNATCmd.
135 -- This is always given in upper case in the templates, although in the
136 -- actual commands, either upper or lower case is allowed.
137
138 -- The unix-switch-string always starts with a minus, and has no commas
139 -- or spaces in it. Case is significant in the unix switch string. If a
140 -- unix switch string is preceded by the not sign (!) it means that the
141 -- effect of the corresponding command qualifer is to remove any previous
142 -- occurrence of the given switch in the command line.
143
144 -- The DIRECTORIES_TRANSLATION format is used where a list of directories
145 -- is given. This possible corresponding formats recognized by GNATCmd are
146 -- as shown by the following example for the case of PATH
147
148 -- PATH=direc
149 -- PATH=(direc,direc,direc,direc)
150
151 -- When more than one directory is present for the DIRECTORIES case, then
152 -- multiple instances of the corresponding unix switch are generated,
153 -- with the file name being substituted for the occurrence of *.
154
155 -- The FILE_TRANSLATION format is similar except that only a single
156 -- file is allowed, not a list of files, and only one unix switch is
157 -- generated as a result.
158
159 -- the NO_SPACE_FILE_TRANSL is similar to FILE_TRANSLATION, except that
160 -- no space is inserted between the switch and the file name.
161
162 -- The NUMERIC_TRANSLATION format is similar to the FILE_TRANSLATION case
163 -- except that the parameter is a decimal integer in the range 0 to 999.
164
165 -- For the OPTIONS_TRANSLATION case, GNATCmd similarly permits one or
166 -- more options to appear (although only in some cases does the use of
167 -- multiple options make logical sense). For example, taking the
168 -- case of ERRORS for GCC, the following are all allowed:
169
170 -- /ERRORS=BRIEF
171 -- /ERRORS=(FULL,VERBOSE)
172 -- /ERRORS=(BRIEF IMMEDIATE)
173
174 -- If no option is provided (e.g. just /ERRORS is written), then the
175 -- first option in the list is the default option. For /ERRORS this
176 -- is NORMAL, so /ERRORS with no option is equivalent to /ERRORS=NORMAL.
177
178 -- The COMMANDS_TRANSLATION case is only used for gnatmake, to correspond
179 -- to the use of -cargs, -bargs and -largs (the ARGS string as indicated
180 -- is one of these three possibilities). The name given by COMMAND is the
181 -- corresponding command name to be used to interprete the switches to be
182 -- passed on. Switches of this type set modes, e.g. /COMPILER_QUALIFIERS
183 -- sets the mode so that all subsequent switches, up to another switch
184 -- with COMMANDS_TRANSLATION apply to the corresponding commands issued
185 -- by the make utility. For example
186
187 -- /COMPILER_QUALIFIERS /LIST /BINDER_QUALIFIERS /MAIN
188 -- /COMPILER_QUALIFIERS /NOLIST /COMPILE_CHECKS=SYNTAX
189
190 -- Clearly these switches must come at the end of the list of switches
191 -- since all subsequent switches apply to an issued command.
192
193 -- For the DIRECT_TRANSLATION case, an implicit additional entry is
194 -- created by prepending NO to the name of the qualifer, and then
195 -- inverting the sense of the UNIX_SWITCHES string. For example,
196 -- given the entry:
197
198 -- "/LIST -gnatl"
199
200 -- An implicit entry is created:
201
202 -- "/NOLIST !-gnatl"
203
204 -- In the case where, a ! is already present, inverting the sense of the
205 -- switch means removing it.
206
207 subtype S is String;
208 -- A synonym to shorten the table
209
210 type String_Ptr is access constant String;
211 -- String pointer type used throughout
212
213 type Switches is array (Natural range <>) of String_Ptr;
214 -- Type used for array of swtiches
215
216 type Switches_Ptr is access constant Switches;
217
218 --------------------------------
219 -- Switches for project files --
220 --------------------------------
221
222 S_Ext_Ref : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
223 "-X" & '"';
224
225 S_Project_File : aliased constant S := "/PROJECT_FILE=<" &
226 "-P>";
227 S_Project_Verb : aliased constant S := "/PROJECT_FILE_VERBOSITY=" &
228 "DEFAULT " &
229 "-vP0 " &
230 "MEDIUM " &
231 "-vP1 " &
232 "HIGH " &
233 "-vP2";
234
235 ----------------------------
236 -- Switches for GNAT BIND --
237 ----------------------------
238
239 S_Bind_Bind : aliased constant S := "/BIND_FILE=" &
240 "ADA " &
241 "-A " &
242 "C " &
243 "-C";
244
245 S_Bind_Build : aliased constant S := "/BUILD_LIBRARY=|" &
246 "-L|";
247
248 S_Bind_Current : aliased constant S := "/CURRENT_DIRECTORY " &
249 "!-I-";
250
251 S_Bind_Debug : aliased constant S := "/DEBUG=" &
252 "TRACEBACK " &
253 "-g2 " &
254 "ALL " &
255 "-g3 " &
256 "NONE " &
257 "-g0 " &
258 "SYMBOLS " &
259 "-g1 " &
260 "NOSYMBOLS " &
261 "!-g1 " &
262 "LINK " &
263 "-g3 " &
264 "NOTRACEBACK " &
265 "!-g2";
266
267 S_Bind_DebugX : aliased constant S := "/NODEBUG " &
268 "!-g";
269
270 S_Bind_Elab : aliased constant S := "/ELABORATION_DEPENDENCIES " &
271 "-e";
272
273 S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" &
274 "-m#";
275
276 S_Bind_Help : aliased constant S := "/HELP " &
277 "-h";
278
279 S_Bind_Init : aliased constant S := "/INITIALIZE_SCALARS=" &
280 "INVALID " &
281 "-Sin " &
282 "LOW " &
283 "-Slo " &
284 "HIGH " &
285 "-Shi";
286
287 S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
288 "-aO*";
289
290 S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " &
291 "-K";
292
293 S_Bind_List : aliased constant S := "/LIST_RESTRICTIONS " &
294 "-r";
295
296 S_Bind_Main : aliased constant S := "/MAIN " &
297 "!-n";
298
299 S_Bind_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
300 "-nostdinc";
301
302 S_Bind_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
303 "-nostdlib";
304
305 S_Bind_No_Time : aliased constant S := "/NO_TIME_STAMP_CHECK " &
306 "-t";
307
308 S_Bind_Object : aliased constant S := "/OBJECT_LIST " &
309 "-O";
310
311 S_Bind_Order : aliased constant S := "/ORDER_OF_ELABORATION " &
312 "-l";
313
314 S_Bind_Output : aliased constant S := "/OUTPUT=@" &
315 "-o@";
316
317 S_Bind_OutputX : aliased constant S := "/NOOUTPUT " &
318 "-c";
319
320 S_Bind_Pess : aliased constant S := "/PESSIMISTIC_ELABORATION " &
321 "-p";
322
323 S_Bind_Read : aliased constant S := "/READ_SOURCES=" &
324 "ALL " &
325 "-s " &
326 "NONE " &
327 "-x " &
328 "AVAILABLE " &
329 "!-x,!-s";
330
331 S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " &
332 "-x";
333
334 S_Bind_Rename : aliased constant S := "/RENAME_MAIN=<" &
335 "-M>";
336
337 S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" &
338 "VERBOSE " &
339 "-v " &
340 "BRIEF " &
341 "-b " &
342 "DEFAULT " &
343 "!-b,!-v";
344
345 S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
346 "!-b,!-v";
347
348 S_Bind_Restr : aliased constant S := "/RESTRICTION_LIST " &
349 "-r";
350
351 S_Bind_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" &
352 "--RTS=|";
353
354 S_Bind_Search : aliased constant S := "/SEARCH=*" &
355 "-I*";
356
357 S_Bind_Shared : aliased constant S := "/SHARED " &
358 "-shared";
359
360 S_Bind_Slice : aliased constant S := "/TIME_SLICE=#" &
361 "-T#";
362
363 S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" &
364 "-aI*";
365
366 S_Bind_Time : aliased constant S := "/TIME_STAMP_CHECK " &
367 "!-t";
368
369 S_Bind_Verbose : aliased constant S := "/VERBOSE " &
370 "-v";
371
372 S_Bind_Warn : aliased constant S := "/WARNINGS=" &
373 "NORMAL " &
374 "!-ws,!-we " &
375 "SUPPRESS " &
376 "-ws " &
377 "ERROR " &
378 "-we";
379
380 S_Bind_WarnX : aliased constant S := "/NOWARNINGS " &
381 "-ws";
382
383 Bind_Switches : aliased constant Switches :=
384 (S_Bind_Bind 'Access,
385 S_Bind_Build 'Access,
386 S_Bind_Current 'Access,
387 S_Bind_Debug 'Access,
388 S_Bind_DebugX 'Access,
389 S_Bind_Elab 'Access,
390 S_Bind_Error 'Access,
391 S_Ext_Ref 'Access,
392 S_Bind_Help 'Access,
393 S_Bind_Init 'Access,
394 S_Bind_Library 'Access,
395 S_Bind_Linker 'Access,
396 S_Bind_List 'Access,
397 S_Bind_Main 'Access,
398 S_Bind_Nostinc 'Access,
399 S_Bind_Nostlib 'Access,
400 S_Bind_No_Time 'Access,
401 S_Bind_Object 'Access,
402 S_Bind_Order 'Access,
403 S_Bind_Output 'Access,
404 S_Bind_OutputX 'Access,
405 S_Bind_Pess 'Access,
406 S_Project_File 'Access,
407 S_Project_Verb 'Access,
408 S_Bind_Read 'Access,
409 S_Bind_ReadX 'Access,
410 S_Bind_Rename 'Access,
411 S_Bind_Report 'Access,
412 S_Bind_ReportX 'Access,
413 S_Bind_Restr 'Access,
414 S_Bind_RTS 'Access,
415 S_Bind_Search 'Access,
416 S_Bind_Shared 'Access,
417 S_Bind_Slice 'Access,
418 S_Bind_Source 'Access,
419 S_Bind_Time 'Access,
420 S_Bind_Verbose 'Access,
421 S_Bind_Warn 'Access,
422 S_Bind_WarnX 'Access);
423
424 ----------------------------
425 -- Switches for GNAT CHOP --
426 ----------------------------
427
428 S_Chop_Comp : aliased constant S := "/COMPILATION " &
429 "-c";
430
431 S_Chop_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
432 "-k#";
433
434 S_Chop_Help : aliased constant S := "/HELP " &
435 "-h";
436
437 S_Chop_Over : aliased constant S := "/OVERWRITE " &
438 "-w";
439
440 S_Chop_Pres : aliased constant S := "/PRESERVE " &
441 "-p";
442
443 S_Chop_Quiet : aliased constant S := "/QUIET " &
444 "-q";
445
446 S_Chop_Ref : aliased constant S := "/REFERENCE " &
447 "-r";
448
449 S_Chop_Verb : aliased constant S := "/VERBOSE " &
450 "-v";
451
452 Chop_Switches : aliased constant Switches :=
453 (S_Chop_Comp 'Access,
454 S_Chop_File 'Access,
455 S_Chop_Help 'Access,
456 S_Chop_Over 'Access,
457 S_Chop_Pres 'Access,
458 S_Chop_Quiet 'Access,
459 S_Chop_Ref 'Access,
460 S_Chop_Verb 'Access);
461
462 -------------------------------
463 -- Switches for GNAT COMPILE --
464 -------------------------------
465
466 S_GCC_Ada_83 : aliased constant S := "/83 " &
467 "-gnat83";
468
469 S_GCC_Ada_95 : aliased constant S := "/95 " &
470 "!-gnat83";
471
472 S_GCC_Asm : aliased constant S := "/ASM " &
473 "-S,!-c";
474
475 S_GCC_Checks : aliased constant S := "/CHECKS=" &
476 "FULL " &
477 "-gnato,!-gnatE,!-gnatp " &
478 "OVERFLOW " &
479 "-gnato " &
480 "ELABORATION " &
481 "-gnatE " &
482 "ASSERTIONS " &
483 "-gnata " &
484 "DEFAULT " &
485 "!-gnato,!-gnatp " &
486 "SUPPRESS_ALL " &
487 "-gnatp";
488
489 S_GCC_ChecksX : aliased constant S := "/NOCHECKS " &
490 "-gnatp,!-gnato,!-gnatE";
491
492 S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " &
493 "-gnatC";
494
495 S_GCC_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" &
496 "-gnatec>";
497
498 S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " &
499 "!-I-";
500
501 S_GCC_Debug : aliased constant S := "/DEBUG=" &
502 "SYMBOLS " &
503 "-g2 " &
504 "NOSYMBOLS " &
505 "!-g2 " &
506 "TRACEBACK " &
507 "-g1 " &
508 "ALL " &
509 "-g3 " &
510 "NONE " &
511 "-g0 " &
512 "NOTRACEBACK " &
513 "-g0";
514
515 S_GCC_DebugX : aliased constant S := "/NODEBUG " &
516 "!-g";
517
518 S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" &
519 "RECEIVER " &
520 "-gnatzr " &
521 "CALLER " &
522 "-gnatzc";
523
524 S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " &
525 "!-gnatzr,!-gnatzc";
526
527 S_GCC_Error : aliased constant S := "/ERROR_LIMIT=#" &
528 "-gnatm#";
529
530 S_GCC_ErrorX : aliased constant S := "/NOERROR_LIMIT " &
531 "-gnatm999";
532
533 S_GCC_Expand : aliased constant S := "/EXPAND_SOURCE " &
534 "-gnatG";
535
536 S_GCC_Extend : aliased constant S := "/EXTENSIONS_ALLOWED " &
537 "-gnatX";
538
539 S_GCC_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
540 "-gnatk#";
541
542 S_GCC_Force : aliased constant S := "/FORCE_ALI " &
543 "-gnatQ";
544
545 S_GCC_Help : aliased constant S := "/HELP " &
546 "-gnath";
547
548 S_GCC_Ident : aliased constant S := "/IDENTIFIER_CHARACTER_SET=" &
549 "DEFAULT " &
550 "-gnati1 " &
551 "1 " &
552 "-gnati1 " &
553 "2 " &
554 "-gnati2 " &
555 "3 " &
556 "-gnati3 " &
557 "4 " &
558 "-gnati4 " &
559 "5 " &
560 "-gnati5 " &
561 "PC " &
562 "-gnatip " &
563 "PC850 " &
564 "-gnati8 " &
565 "FULL_UPPER " &
566 "-gnatif " &
567 "NO_UPPER " &
568 "-gnatin " &
569 "WIDE " &
570 "-gnatiw";
571
572 S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " &
573 "-gnati1";
574
575 S_GCC_Immed : aliased constant S := "/IMMEDIATE_ERRORS " &
576 "-gnatdO";
577
578 S_GCC_Inline : aliased constant S := "/INLINE=" &
579 "PRAGMA " &
580 "-gnatn " &
581 "FULL " &
582 "-gnatN " &
583 "SUPPRESS " &
584 "-fno-inline";
585
586 S_GCC_InlineX : aliased constant S := "/NOINLINE " &
587 "!-gnatn";
588
589 S_GCC_Jumps : aliased constant S := "/LONGJMP_SETJMP " &
590 "-gnatL";
591
592 S_GCC_Length : aliased constant S := "/MAX_LINE_LENGTH=#" &
593 "-gnatyM#";
594
595 S_GCC_List : aliased constant S := "/LIST " &
596 "-gnatl";
597
598 S_GCC_Noadc : aliased constant S := "/NO_GNAT_ADC " &
599 "-gnatA";
600
601 S_GCC_Noload : aliased constant S := "/NOLOAD " &
602 "-gnatc";
603
604 S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
605 "-nostdinc";
606
607 S_GCC_Opt : aliased constant S := "/OPTIMIZE=" &
608 "ALL " &
609 "-O2,!-O0,!-O1,!-O3 " &
610 "NONE " &
611 "-O0,!-O1,!-O2,!-O3 " &
612 "SOME " &
613 "-O1,!-O0,!-O2,!-O3 " &
614 "DEVELOPMENT " &
615 "-O1,!-O0,!-O2,!-O3 " &
616 "UNROLL_LOOPS " &
617 "-funroll-loops " &
618 "INLINING " &
619 "-O3,!-O0,!-O1,!-O2";
620
621 S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " &
622 "-O0,!-O1,!-O2,!-O3";
623
624 S_GCC_Polling : aliased constant S := "/POLLING " &
625 "-gnatP";
626
627 S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" &
628 "VERBOSE " &
629 "-gnatv " &
630 "BRIEF " &
631 "-gnatb " &
632 "FULL " &
633 "-gnatf " &
634 "IMMEDIATE " &
635 "-gnate " &
636 "DEFAULT " &
637 "!-gnatb,!-gnatv";
638
639 S_GCC_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
640 "!-gnatb,!-gnatv";
641
642 S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" &
643 "ARRAYS " &
644 "-gnatR1 " &
645 "NONE " &
646 "-gnatR0 " &
647 "OBJECTS " &
648 "-gnatR2 " &
649 "SYMBOLIC " &
650 "-gnatR3 " &
651 "DEFAULT " &
652 "-gnatR";
653
654 S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " &
655 "!-gnatR";
656
657 S_GCC_Search : aliased constant S := "/SEARCH=*" &
658 "-I*";
659
660 S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" &
661 "ALL_BUILTIN " &
662 "-gnaty " &
663 "1 " &
664 "-gnaty1 " &
665 "2 " &
666 "-gnaty2 " &
667 "3 " &
668 "-gnaty3 " &
669 "4 " &
670 "-gnaty4 " &
671 "5 " &
672 "-gnaty5 " &
673 "6 " &
674 "-gnaty6 " &
675 "7 " &
676 "-gnaty7 " &
677 "8 " &
678 "-gnaty8 " &
679 "9 " &
680 "-gnaty9 " &
681 "ATTRIBUTE " &
682 "-gnatya " &
683 "BLANKS " &
684 "-gnatyb " &
685 "COMMENTS " &
686 "-gnatyc " &
687 "END " &
688 "-gnatye " &
689 "VTABS " &
690 "-gnatyf " &
691 "GNAT " &
692 "-gnatg " &
693 "HTABS " &
694 "-gnatyh " &
695 "IF_THEN " &
696 "-gnatyi " &
697 "KEYWORD " &
698 "-gnatyk " &
699 "LAYOUT " &
700 "-gnatyl " &
701 "LINE_LENGTH " &
702 "-gnatym " &
703 "STANDARD_CASING " &
704 "-gnatyn " &
705 "ORDERED_SUBPROGRAMS " &
706 "-gnatyo " &
707 "NONE " &
708 "!-gnatg,!-gnatr " &
709 "PRAGMA " &
710 "-gnatyp " &
711 "RM_COLUMN_LAYOUT " &
712 "-gnatr " &
713 "SPECS " &
714 "-gnatys " &
715 "TOKEN " &
716 "-gnatyt ";
717
718 S_GCC_StyleX : aliased constant S := "/NOSTYLE_CHECKS " &
719 "!-gnatg,!-gnatr";
720
721 S_GCC_Syntax : aliased constant S := "/SYNTAX_ONLY " &
722 "-gnats";
723
724 S_GCC_Trace : aliased constant S := "/TRACE_UNITS " &
725 "-gnatdc";
726
727 S_GCC_Tree : aliased constant S := "/TREE_OUTPUT " &
728 "-gnatt";
729
730 S_GCC_Trys : aliased constant S := "/TRY_SEMANTICS " &
731 "-gnatq";
732
733 S_GCC_Units : aliased constant S := "/UNITS_LIST " &
734 "-gnatu";
735
736 S_GCC_Unique : aliased constant S := "/UNIQUE_ERROR_TAG " &
737 "-gnatU";
738
739 S_GCC_Upcase : aliased constant S := "/UPPERCASE_EXTERNALS " &
740 "-gnatF";
741
742 S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" &
743 "DEFAULT " &
744 "-gnatVd " &
745 "NODEFAULT " &
746 "-gnatVD " &
747 "COPIES " &
748 "-gnatVc " &
749 "NOCOPIES " &
750 "-gnatVC " &
751 "FLOATS " &
752 "-gnatVf " &
753 "NOFLOATS " &
754 "-gnatVF " &
755 "IN_PARAMS " &
756 "-gnatVi " &
757 "NOIN_PARAMS " &
758 "-gnatVI " &
759 "MOD_PARAMS " &
760 "-gnatVm " &
761 "NOMOD_PARAMS " &
762 "-gnatVM " &
763 "OPERANDS " &
764 "-gnatVo " &
765 "NOOPERANDS " &
766 "-gnatVO " &
767 "RETURNS " &
768 "-gnatVr " &
769 "NORETURNS " &
770 "-gnatVR " &
771 "SUBSCRIPTS " &
772 "-gnatVs " &
773 "NOSUBSCRIPTS " &
774 "-gnatVS " &
775 "TESTS " &
776 "-gnatVt " &
777 "NOTESTS " &
778 "-gnatVT " &
779 "ALL " &
780 "-gnatVa " &
781 "NONE " &
782 "-gnatVn";
783
784 S_GCC_Verbose : aliased constant S := "/VERBOSE " &
785 "-v";
786
787 S_GCC_Warn : aliased constant S := "/WARNINGS=" &
788 "DEFAULT " &
789 "!-gnatws,!-gnatwe " &
790 "ALL_GCC " &
791 "-Wall " &
792 "BIASED_ROUNDING " &
793 "-gnatwb " &
794 "NOBIASED_ROUNDING " &
795 "-gnatwB " &
796 "CONDITIONALS " &
797 "-gnatwc " &
798 "NOCONDITIONALS " &
799 "-gnatwC " &
800 "IMPLICIT_DEREFERENCE " &
801 "-gnatwd " &
802 "NO_IMPLICIT_DEREFERENCE " &
803 "-gnatwD " &
804 "ELABORATION " &
805 "-gnatwl " &
806 "NOELABORATION " &
807 "-gnatwL " &
808 "ERRORS " &
809 "-gnatwe " &
810 "HIDING " &
811 "-gnatwh " &
812 "NOHIDING " &
813 "-gnatwH " &
814 "IMPLEMENTATION " &
815 "-gnatwi " &
816 "NOIMPLEMENTATION " &
817 "-gnatwI " &
818 "INEFFECTIVE_INLINE " &
819 "-gnatwp " &
820 "NOINEFFECTIVE_INLINE " &
821 "-gnatwP " &
822 "OPTIONAL " &
823 "-gnatwa " &
824 "NOOPTIONAL " &
825 "-gnatwA " &
826 "OVERLAYS " &
827 "-gnatwo " &
828 "NOOVERLAYS " &
829 "-gnatwO " &
830 "REDUNDANT " &
831 "-gnatwr " &
832 "NOREDUNDANT " &
833 "-gnatwR " &
834 "SUPPRESS " &
835 "-gnatws " &
836 "UNINITIALIZED " &
837 "-Wuninitialized " &
838 "UNREFERENCED_FORMALS " &
839 "-gnatwf " &
840 "NOUNREFERENCED_FORMALS " &
841 "-gnatwF " &
842 "UNUSED " &
843 "-gnatwu " &
844 "NOUNUSED " &
845 "-gnatwU";
846
847 S_GCC_WarnX : aliased constant S := "/NOWARNINGS " &
848 "-gnatws";
849
850 S_GCC_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" &
851 "BRACKETS " &
852 "-gnatWb " &
853 "NONE " &
854 "-gnatWn " &
855 "HEX " &
856 "-gnatWh " &
857 "UPPER " &
858 "-gnatWu " &
859 "SHIFT_JIS " &
860 "-gnatWs " &
861 "UTF8 " &
862 "-gnatW8 " &
863 "EUC " &
864 "-gnatWe";
865
866 S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " &
867 "-gnatWn";
868
869 S_GCC_Xdebug : aliased constant S := "/XDEBUG " &
870 "-gnatD";
871
872 S_GCC_Xref : aliased constant S := "/XREF=" &
873 "GENERATE " &
874 "!-gnatx " &
875 "SUPPRESS " &
876 "-gnatx";
877
878 GCC_Switches : aliased constant Switches :=
879 (S_GCC_Ada_83 'Access,
880 S_GCC_Ada_95 'Access,
881 S_GCC_Asm 'Access,
882 S_GCC_Checks 'Access,
883 S_GCC_ChecksX 'Access,
884 S_GCC_Compres 'Access,
885 S_GCC_Config 'Access,
886 S_GCC_Current 'Access,
887 S_GCC_Debug 'Access,
888 S_GCC_DebugX 'Access,
889 S_GCC_Dist 'Access,
890 S_GCC_DistX 'Access,
891 S_GCC_Error 'Access,
892 S_GCC_ErrorX 'Access,
893 S_GCC_Expand 'Access,
894 S_GCC_Extend 'Access,
895 S_Ext_Ref 'Access,
896 S_GCC_File 'Access,
897 S_GCC_Force 'Access,
898 S_GCC_Help 'Access,
899 S_GCC_Ident 'Access,
900 S_GCC_IdentX 'Access,
901 S_GCC_Immed 'Access,
902 S_GCC_Inline 'Access,
903 S_GCC_InlineX 'Access,
904 S_GCC_Jumps 'Access,
905 S_GCC_Length 'Access,
906 S_GCC_List 'Access,
907 S_GCC_Noadc 'Access,
908 S_GCC_Noload 'Access,
909 S_GCC_Nostinc 'Access,
910 S_GCC_Opt 'Access,
911 S_GCC_OptX 'Access,
912 S_GCC_Polling 'Access,
913 S_Project_File'Access,
914 S_Project_Verb'Access,
915 S_GCC_Report 'Access,
916 S_GCC_ReportX 'Access,
917 S_GCC_Repinfo 'Access,
918 S_GCC_RepinfX 'Access,
919 S_GCC_Search 'Access,
920 S_GCC_Style 'Access,
921 S_GCC_StyleX 'Access,
922 S_GCC_Syntax 'Access,
923 S_GCC_Trace 'Access,
924 S_GCC_Tree 'Access,
925 S_GCC_Trys 'Access,
926 S_GCC_Units 'Access,
927 S_GCC_Unique 'Access,
928 S_GCC_Upcase 'Access,
929 S_GCC_Valid 'Access,
930 S_GCC_Verbose 'Access,
931 S_GCC_Warn 'Access,
932 S_GCC_WarnX 'Access,
933 S_GCC_Wide 'Access,
934 S_GCC_WideX 'Access,
935 S_GCC_Xdebug 'Access,
936 S_GCC_Xref 'Access);
937
938 ----------------------------
939 -- Switches for GNAT ELIM --
940 ----------------------------
941
942 S_Elim_All : aliased constant S := "/ALL " &
943 "-a";
944
945 S_Elim_Bind : aliased constant S := "/BIND_FILE=<" &
946 "-b>";
947
948 S_Elim_Miss : aliased constant S := "/MISSED " &
949 "-m";
950
951 S_Elim_Quiet : aliased constant S := "/QUIET " &
952 "-q";
953
954 S_Elim_Tree : aliased constant S := "/TREE_DIRS=*" &
955 "-T*";
956
957 S_Elim_Verb : aliased constant S := "/VERBOSE " &
958 "-v";
959
960 Elim_Switches : aliased constant Switches :=
961 (S_Elim_All 'Access,
962 S_Elim_Bind 'Access,
963 S_Elim_Miss 'Access,
964 S_Elim_Quiet 'Access,
965 S_Elim_Tree 'Access,
966 S_Elim_Verb 'Access);
967
968 ----------------------------
969 -- Switches for GNAT FIND --
970 ----------------------------
971
972 S_Find_All : aliased constant S := "/ALL_FILES " &
973 "-a";
974
975 S_Find_Deriv : aliased constant S := "/DERIVED_TYPE_INFORMATION " &
976 "-d";
977
978 S_Find_Expr : aliased constant S := "/EXPRESSIONS " &
979 "-e";
980
981 S_Find_Full : aliased constant S := "/FULL_PATHNAME " &
982 "-f";
983
984 S_Find_Ignore : aliased constant S := "/IGNORE_LOCALS " &
985 "-g";
986
987 S_Find_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
988 "-nostdinc";
989
990 S_Find_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
991 "-nostdlib";
992
993 S_Find_Object : aliased constant S := "/OBJECT_SEARCH=*" &
994 "-aO*";
995
996 S_Find_Print : aliased constant S := "/PRINT_LINES " &
997 "-s";
998
999 S_Find_Project : aliased constant S := "/PROJECT=@" &
1000 "-p@";
1001
1002 S_Find_Ref : aliased constant S := "/REFERENCES " &
1003 "-r";
1004
1005 S_Find_Search : aliased constant S := "/SEARCH=*" &
1006 "-I*";
1007
1008 S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" &
1009 "-aI*";
1010
1011 S_Find_Types : aliased constant S := "/TYPE_HIERARCHY " &
1012 "-t";
1013
1014 Find_Switches : aliased constant Switches :=
1015 (S_Find_All 'Access,
1016 S_Find_Deriv 'Access,
1017 S_Find_Expr 'Access,
1018 S_Ext_Ref 'Access,
1019 S_Find_Full 'Access,
1020 S_Find_Ignore 'Access,
1021 S_Find_Nostinc 'Access,
1022 S_Find_Nostlib 'Access,
1023 S_Find_Object 'Access,
1024 S_Find_Print 'Access,
1025 S_Find_Project 'Access,
1026 S_Project_File 'Access,
1027 S_Project_Verb 'Access,
1028 S_Find_Ref 'Access,
1029 S_Find_Search 'Access,
1030 S_Find_Source 'Access,
1031 S_Find_Types 'Access);
1032
1033 ------------------------------
1034 -- Switches for GNAT KRUNCH --
1035 ------------------------------
1036
1037 S_Krunch_Count : aliased constant S := "/COUNT=#" &
1038 "`#";
1039
1040 Krunch_Switches : aliased constant Switches :=
1041 (1 .. 1 => S_Krunch_Count 'Access);
1042
1043 -------------------------------
1044 -- Switches for GNAT LIBRARY --
1045 -------------------------------
1046
1047 S_Lbr_Config : aliased constant S := "/CONFIG=@" &
1048 "--config=@";
1049
1050 S_Lbr_Create : aliased constant S := "/CREATE=%" &
1051 "--create=%";
1052
1053 S_Lbr_Delete : aliased constant S := "/DELETE=%" &
1054 "--delete=%";
1055
1056 S_Lbr_Set : aliased constant S := "/SET=%" &
1057 "--set=%";
1058
1059 Lbr_Switches : aliased constant Switches :=
1060 (S_Lbr_Config 'Access,
1061 S_Lbr_Create 'Access,
1062 S_Lbr_Delete 'Access,
1063 S_Lbr_Set 'Access);
1064
1065 ----------------------------
1066 -- Switches for GNAT LINK --
1067 ----------------------------
1068
1069 S_Link_Bind : aliased constant S := "/BIND_FILE=" &
1070 "ADA " &
1071 "-A " &
1072 "C " &
1073 "-C";
1074
1075 S_Link_Debug : aliased constant S := "/DEBUG=" &
1076 "ALL " &
1077 "-g3 " &
1078 "NONE " &
1079 "-g0 " &
1080 "TRACEBACK " &
1081 "-g1 " &
1082 "NOTRACEBACK " &
1083 "-g0";
1084
1085 S_Link_Execut : aliased constant S := "/EXECUTABLE=@" &
1086 "-o@";
1087
1088 S_Link_Force : aliased constant S := "/FORCE_OBJECT_FILE_LIST " &
1089 "-f";
1090
1091 S_Link_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
1092 "--for-linker=IDENT=" &
1093 '"';
1094
1095 S_Link_Nocomp : aliased constant S := "/NOCOMPILE " &
1096 "-n";
1097
1098 S_Link_Nofiles : aliased constant S := "/NOSTART_FILES " &
1099 "-nostartfiles";
1100
1101 S_Link_Noinhib : aliased constant S := "/NOINHIBIT-EXEC " &
1102 "--for-linker=--noinhibit-exec";
1103
1104 S_Link_Static : aliased constant S := "/STATIC " &
1105 "--for-linker=-static";
1106
1107 S_Link_Verb : aliased constant S := "/VERBOSE " &
1108 "-v";
1109
1110 S_Link_ZZZZZ : aliased constant S := "/<other> " &
1111 "--for-linker=";
1112
1113 Link_Switches : aliased constant Switches :=
1114 (S_Link_Bind 'Access,
1115 S_Link_Debug 'Access,
1116 S_Link_Execut 'Access,
1117 S_Ext_Ref 'Access,
1118 S_Link_Force 'Access,
1119 S_Link_Ident 'Access,
1120 S_Link_Nocomp 'Access,
1121 S_Link_Nofiles 'Access,
1122 S_Link_Noinhib 'Access,
1123 S_Project_File 'Access,
1124 S_Project_Verb 'Access,
1125 S_Link_Static 'Access,
1126 S_Link_Verb 'Access,
1127 S_Link_ZZZZZ 'Access);
1128
1129 ----------------------------
1130 -- Switches for GNAT LIST --
1131 ----------------------------
1132
1133 S_List_All : aliased constant S := "/ALL_UNITS " &
1134 "-a";
1135
1136 S_List_Current : aliased constant S := "/CURRENT_DIRECTORY " &
1137 "!-I-";
1138
1139 S_List_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
1140 "-nostdinc";
1141
1142 S_List_Object : aliased constant S := "/OBJECT_SEARCH=*" &
1143 "-aO*";
1144
1145 S_List_Output : aliased constant S := "/OUTPUT=" &
1146 "SOURCES " &
1147 "-s " &
1148 "DEPEND " &
1149 "-d " &
1150 "OBJECTS " &
1151 "-o " &
1152 "UNITS " &
1153 "-u " &
1154 "OPTIONS " &
1155 "-h " &
1156 "VERBOSE " &
1157 "-v ";
1158
1159 S_List_Search : aliased constant S := "/SEARCH=*" &
1160 "-I*";
1161
1162 S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" &
1163 "-aI*";
1164
1165 List_Switches : aliased constant Switches :=
1166 (S_List_All 'Access,
1167 S_List_Current 'Access,
1168 S_Ext_Ref 'Access,
1169 S_List_Nostinc 'Access,
1170 S_List_Object 'Access,
1171 S_List_Output 'Access,
1172 S_Project_File 'Access,
1173 S_Project_Verb 'Access,
1174 S_List_Search 'Access,
1175 S_List_Source 'Access);
1176
1177 ----------------------------
1178 -- Switches for GNAT MAKE --
1179 ----------------------------
1180
1181 S_Make_Actions : aliased constant S := "/ACTIONS=" &
1182 "COMPILE " &
1183 "-c " &
1184 "BIND " &
1185 "-b " &
1186 "LINK " &
1187 "-l ";
1188
1189 S_Make_All : aliased constant S := "/ALL_FILES " &
1190 "-a";
1191
1192 S_Make_Bind : aliased constant S := "/BINDER_QUALIFIERS=?" &
1193 "-bargs BIND";
1194
1195 S_Make_Comp : aliased constant S := "/COMPILER_QUALIFIERS=?" &
1196 "-cargs COMPILE";
1197
1198 S_Make_Cond : aliased constant S := "/CONDITIONAL_SOURCE_SEARCH=*" &
1199 "-A*";
1200
1201 S_Make_Cont : aliased constant S := "/CONTINUE_ON_ERROR " &
1202 "-k";
1203
1204 S_Make_Current : aliased constant S := "/CURRENT_DIRECTORY " &
1205 "!-I-";
1206
1207 S_Make_Dep : aliased constant S := "/DEPENDENCIES_LIST " &
1208 "-M";
1209
1210 S_Make_Doobj : aliased constant S := "/DO_OBJECT_CHECK " &
1211 "-n";
1212
1213 S_Make_Execut : aliased constant S := "/EXECUTABLE=@" &
1214 "-o@";
1215
1216 S_Make_Force : aliased constant S := "/FORCE_COMPILE " &
1217 "-f";
1218
1219 S_Make_Inplace : aliased constant S := "/IN_PLACE " &
1220 "-i";
1221
1222 S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
1223 "-L*";
1224
1225 S_Make_Link : aliased constant S := "/LINKER_QUALIFIERS=?" &
1226 "-largs LINK";
1227
1228 S_Make_Mapping : aliased constant S := "/MAPPING " &
1229 "-C";
1230
1231 S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " &
1232 "-m";
1233
1234 S_Make_Nolink : aliased constant S := "/NOLINK " &
1235 "-c";
1236
1237 S_Make_Nomain : aliased constant S := "/NOMAIN " &
1238 "-z";
1239
1240 S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
1241 "-nostdinc";
1242
1243 S_Make_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
1244 "-nostdlib";
1245
1246 S_Make_Object : aliased constant S := "/OBJECT_SEARCH=*" &
1247 "-aO*";
1248
1249 S_Make_Proc : aliased constant S := "/PROCESSES=#" &
1250 "-j#";
1251
1252 S_Make_Nojobs : aliased constant S := "/NOPROCESSES " &
1253 "-j1";
1254
1255 S_Make_Quiet : aliased constant S := "/QUIET " &
1256 "-q";
1257
1258 S_Make_Reason : aliased constant S := "/REASONS " &
1259 "-v";
1260
1261 S_Make_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" &
1262 "--RTS=|";
1263
1264 S_Make_Search : aliased constant S := "/SEARCH=*" &
1265 "-I*";
1266
1267 S_Make_Skip : aliased constant S := "/SKIP_MISSING=*" &
1268 "-aL*";
1269
1270 S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" &
1271 "-aI*";
1272
1273 S_Make_Switch : aliased constant S := "/SWITCH_CHECK " &
1274 "-s";
1275
1276 S_Make_Unique : aliased constant S := "/UNIQUE " &
1277 "-u";
1278
1279 S_Make_Verbose : aliased constant S := "/VERBOSE " &
1280 "-v";
1281
1282 Make_Switches : aliased constant Switches :=
1283 (S_Make_Actions 'Access,
1284 S_Make_All 'Access,
1285 S_Make_Bind 'Access,
1286 S_Make_Comp 'Access,
1287 S_Make_Cond 'Access,
1288 S_Make_Cont 'Access,
1289 S_Make_Current 'Access,
1290 S_Make_Dep 'Access,
1291 S_Make_Doobj 'Access,
1292 S_Make_Execut 'Access,
1293 S_Ext_Ref 'Access,
1294 S_Make_Force 'Access,
1295 S_Make_Inplace 'Access,
1296 S_Make_Library 'Access,
1297 S_Make_Link 'Access,
1298 S_Make_Mapping 'Access,
1299 S_Make_Minimal 'Access,
1300 S_Make_Nolink 'Access,
1301 S_Make_Nomain 'Access,
1302 S_Make_Nostinc 'Access,
1303 S_Make_Nostlib 'Access,
1304 S_Make_Object 'Access,
1305 S_Make_Proc 'Access,
1306 S_Project_File 'Access,
1307 S_Project_Verb 'Access,
1308 S_Make_Nojobs 'Access,
1309 S_Make_Quiet 'Access,
1310 S_Make_Reason 'Access,
1311 S_Make_RTS 'Access,
1312 S_Make_Search 'Access,
1313 S_Make_Skip 'Access,
1314 S_Make_Source 'Access,
1315 S_Make_Switch 'Access,
1316 S_Make_Unique 'Access,
1317 S_Make_Verbose 'Access);
1318
1319 ----------------------------
1320 -- Switches for GNAT Name --
1321 ----------------------------
1322
1323 S_Name_Conf : aliased constant S := "/CONFIG_FILE=<" &
1324 "-c>";
1325
1326 S_Name_Dirs : aliased constant S := "/SOURCE_DIRS=*" &
1327 "-d*";
1328
1329 S_Name_Dfile : aliased constant S := "/DIRS_FILE=<" &
1330 "-D>";
1331
1332 S_Name_Help : aliased constant S := "/HELP" &
1333 " -h";
1334
1335 S_Name_Proj : aliased constant S := "/PROJECT_FILE=<" &
1336 "-P>";
1337
1338 S_Name_Verbose : aliased constant S := "/VERBOSE" &
1339 " -v";
1340
1341 Name_Switches : aliased constant Switches :=
1342 (S_Name_Conf 'Access,
1343 S_Name_Dirs 'Access,
1344 S_Name_Dfile 'Access,
1345 S_Name_Help 'Access,
1346 S_Name_Proj 'Access,
1347 S_Name_Verbose 'Access);
1348
1349 ----------------------------------
1350 -- Switches for GNAT PREPROCESS --
1351 ----------------------------------
1352
1353 S_Prep_Assoc : aliased constant S := "/ASSOCIATE=" & '"' &
1354 "-D" & '"';
1355
1356 S_Prep_Blank : aliased constant S := "/BLANK_LINES " &
1357 "-b";
1358
1359 S_Prep_Com : aliased constant S := "/COMMENTS " &
1360 "-c";
1361
1362 S_Prep_Ref : aliased constant S := "/REFERENCE " &
1363 "-r";
1364
1365 S_Prep_Remove : aliased constant S := "/REMOVE " &
1366 "!-b,!-c";
1367
1368 S_Prep_Symbols : aliased constant S := "/SYMBOLS " &
1369 "-s";
1370
1371 S_Prep_Undef : aliased constant S := "/UNDEFINED " &
1372 "-u";
1373
1374 Prep_Switches : aliased constant Switches :=
1375 (S_Prep_Assoc 'Access,
1376 S_Prep_Blank 'Access,
1377 S_Prep_Com 'Access,
1378 S_Prep_Ref 'Access,
1379 S_Prep_Remove 'Access,
1380 S_Prep_Symbols 'Access,
1381 S_Prep_Undef 'Access);
1382
1383 ------------------------------
1384 -- Switches for GNAT SHARED --
1385 ------------------------------
1386
1387 S_Shared_Debug : aliased constant S := "/DEBUG=" &
1388 "ALL " &
1389 "-g3 " &
1390 "NONE " &
1391 "-g0 " &
1392 "TRACEBACK " &
1393 "-g1 " &
1394 "NOTRACEBACK " &
1395 "-g0";
1396
1397 S_Shared_Image : aliased constant S := "/IMAGE=@" &
1398 "-o@";
1399
1400 S_Shared_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
1401 "--for-linker=IDENT=" &
1402 '"';
1403
1404 S_Shared_Nofiles : aliased constant S := "/NOSTART_FILES " &
1405 "-nostartfiles";
1406
1407 S_Shared_Noinhib : aliased constant S := "/NOINHIBIT-IMAGE " &
1408 "--for-linker=--noinhibit-exec";
1409
1410 S_Shared_Verb : aliased constant S := "/VERBOSE " &
1411 "-v";
1412
1413 S_Shared_ZZZZZ : aliased constant S := "/<other> " &
1414 "--for-linker=";
1415
1416 Shared_Switches : aliased constant Switches :=
1417 (S_Shared_Debug 'Access,
1418 S_Shared_Image 'Access,
1419 S_Shared_Ident 'Access,
1420 S_Shared_Nofiles 'Access,
1421 S_Shared_Noinhib 'Access,
1422 S_Shared_Verb 'Access,
1423 S_Shared_ZZZZZ 'Access);
1424
1425 --------------------------------
1426 -- Switches for GNAT STANDARD --
1427 --------------------------------
1428
1429 Standard_Switches : aliased constant Switches := (1 .. 0 => null);
1430
1431 ----------------------------
1432 -- Switches for GNAT STUB --
1433 ----------------------------
1434
1435 S_Stub_Current : aliased constant S := "/CURRENT_DIRECTORY " &
1436 "!-I-";
1437
1438 S_Stub_Full : aliased constant S := "/FULL " &
1439 "-f";
1440
1441 S_Stub_Header : aliased constant S := "/HEADER=" &
1442 "GENERAL " &
1443 "-hg " &
1444 "SPEC " &
1445 "-hs";
1446
1447 S_Stub_Indent : aliased constant S := "/INDENTATION=#" &
1448 "-i#";
1449
1450 S_Stub_Length : aliased constant S := "/LINE_LENGTH=#" &
1451 "-l#";
1452
1453 S_Stub_Quiet : aliased constant S := "/QUIET " &
1454 "-q";
1455
1456 S_Stub_Search : aliased constant S := "/SEARCH=*" &
1457 "-I*";
1458
1459 S_Stub_Tree : aliased constant S := "/TREE_FILE=" &
1460 "OVERWRITE " &
1461 "-t " &
1462 "SAVE " &
1463 "-k " &
1464 "REUSE " &
1465 "-r";
1466
1467 S_Stub_Verbose : aliased constant S := "/VERBOSE " &
1468 "-v";
1469
1470 Stub_Switches : aliased constant Switches :=
1471 (S_Stub_Current 'Access,
1472 S_Stub_Full 'Access,
1473 S_Stub_Header 'Access,
1474 S_Stub_Indent 'Access,
1475 S_Stub_Length 'Access,
1476 S_Stub_Quiet 'Access,
1477 S_Stub_Search 'Access,
1478 S_Stub_Tree 'Access,
1479 S_Stub_Verbose 'Access);
1480
1481 ----------------------------
1482 -- Switches for GNAT XREF --
1483 ----------------------------
1484
1485 S_Xref_All : aliased constant S := "/ALL_FILES " &
1486 "-a";
1487
1488 S_Xref_Deriv : aliased constant S := "/DERIVED_TYPES " &
1489 "-d";
1490
1491 S_Xref_Full : aliased constant S := "/FULL_PATHNAME " &
1492 "-f";
1493
1494 S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " &
1495 "-g";
1496
1497 S_Xref_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
1498 "-nostdinc";
1499
1500 S_Xref_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
1501 "-nostdlib";
1502
1503 S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" &
1504 "-aO*";
1505
1506 S_Xref_Project : aliased constant S := "/PROJECT=@" &
1507 "-p@";
1508
1509 S_Xref_Search : aliased constant S := "/SEARCH=*" &
1510 "-I*";
1511
1512 S_Xref_Source : aliased constant S := "/SOURCE_SEARCH=*" &
1513 "-aI*";
1514
1515 S_Xref_Output : aliased constant S := "/UNUSED " &
1516 "-u";
1517
1518 S_Xref_Tags : aliased constant S := "/TAGS " &
1519 "-v";
1520
1521 Xref_Switches : aliased constant Switches :=
1522 (S_Xref_All 'Access,
1523 S_Xref_Deriv 'Access,
1524 S_Ext_Ref 'Access,
1525 S_Xref_Full 'Access,
1526 S_Xref_Global 'Access,
1527 S_Xref_Nostinc 'Access,
1528 S_Xref_Nostlib 'Access,
1529 S_Xref_Object 'Access,
1530 S_Xref_Project 'Access,
1531 S_Project_File 'Access,
1532 S_Project_Verb 'Access,
1533 S_Xref_Search 'Access,
1534 S_Xref_Source 'Access,
1535 S_Xref_Output 'Access,
1536 S_Xref_Tags 'Access);
1537
1538 -------------------
1539 -- COMMAND TABLE --
1540 -------------------
1541
1542 -- The command table contains an entry for each command recognized by
1543 -- GNATCmd. The entries are represented by an array of records.
1544
1545 type Parameter_Type is
1546 -- A parameter is defined as a whitespace bounded string, not begining
1547 -- with a slash. (But see note under FILES_OR_WILDCARD).
1548 (File,
1549 -- A required file or directory parameter.
1550
1551 Optional_File,
1552 -- An optional file or directory parameter.
1553
1554 Other_As_Is,
1555 -- A parameter that's passed through as is (not canonicalized)
1556
1557 Unlimited_Files,
1558 -- An unlimited number of whitespace separate file or directory
1559 -- parameters including wildcard specifications.
1560
1561 Unlimited_As_Is,
1562 -- Un unlimited number of whitespace separated paameters that are
1563 -- passed through as is (not canonicalized).
1564
1565 Files_Or_Wildcard);
1566 -- A comma separated list of files and/or wildcard file specifications.
1567 -- A comma preceded by or followed by whitespace is considered as a
1568 -- single comma character w/o whitespace.
1569
1570 type Parameter_Array is array (Natural range <>) of Parameter_Type;
1571 type Parameter_Ref is access all Parameter_Array;
1572
1573 type Command_Type is
1574 (Bind, Chop, Compile, Elim, Find, Krunch, Library, Link, List,
1575 Make, Name, Preprocess, Shared, Standard, Stub, Xref, Undefined);
1576
1577 type Alternate_Command is (Comp, Ls, Kr, Prep, Psta);
1578 -- Alternate command libel for non VMS system
1579
1580 Corresponding_To : constant array (Alternate_Command) of Command_Type :=
1581 (Comp => Compile,
1582 Ls => List,
1583 Kr => Krunch,
1584 Prep => Preprocess,
1585 Psta => Standard);
1586 -- Mapping of alternate commands to commands
1587
1588 subtype Real_Command_Type is Command_Type range Bind .. Xref;
1589
1590 type Command_Entry is record
1591 Cname : String_Ptr;
1592 -- Command name for GNAT xxx command
1593
1594 Usage : String_Ptr;
1595 -- A usage string, used for error messages
1596
1597 Unixcmd : String_Ptr;
1598 -- Corresponding Unix command
1599
1600 Unixsws : Argument_List_Access;
1601 -- Switches for the Unix command
1602
1603 VMS_Only : Boolean;
1604 -- When True, the command can only be used on VMS
1605
1606 Switches : Switches_Ptr;
1607 -- Pointer to array of switch strings
1608
1609 Params : Parameter_Ref;
1610 -- Describes the allowable types of parameters.
1611 -- Params (1) is the type of the first parameter, etc.
1612 -- An empty parameter array means this command takes no parameters.
1613
1614 Defext : String (1 .. 3);
1615 -- Default extension. If non-blank, then this extension is supplied by
1616 -- default as the extension for any file parameter which does not have
1617 -- an extension already.
1618 end record;
1619
1620 -------------------------
1621 -- INTERNAL STRUCTURES --
1622 -------------------------
1623
1624 -- The switches and commands are defined by strings in the previous
1625 -- section so that they are easy to modify, but internally, they are
1626 -- kept in a more conveniently accessible form described in this
1627 -- section.
1628
1629 -- Commands, command qualifers and options have a similar common format
1630 -- so that searching for matching names can be done in a common manner.
1631
1632 type Item_Id is (Id_Command, Id_Switch, Id_Option);
1633
1634 type Translation_Type is
1635 (
1636 T_Direct,
1637 -- A qualifier with no options.
1638 -- Example: GNAT MAKE /VERBOSE
1639
1640 T_Directories,
1641 -- A qualifier followed by a list of directories
1642 -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR])
1643
1644 T_Directory,
1645 -- A qualifier followed by one directory
1646 -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB]
1647
1648 T_File,
1649 -- A qualifier followed by a filename
1650 -- Example: GNAT LINK /EXECUTABLE=FOO.EXE
1651
1652 T_No_Space_File,
1653 -- A qualifier followed by a filename
1654 -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR
1655
1656 T_Numeric,
1657 -- A qualifier followed by a numeric value.
1658 -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39
1659
1660 T_String,
1661 -- A qualifier followed by a quoted string. Only used by
1662 -- /IDENTIFICATION qualfier.
1663 -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version"
1664
1665 T_Options,
1666 -- A qualifier followed by a list of options.
1667 -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS)
1668
1669 T_Commands,
1670 -- A qualifier followed by a list. Only used for
1671 -- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS
1672 -- (gnatmake -cargs -bargs -largs )
1673 -- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ
1674
1675 T_Other,
1676 -- A qualifier passed directly to the linker. Only used
1677 -- for LINK and SHARED if no other match is found.
1678 -- Example: GNAT LINK FOO.ALI /SYSSHR
1679
1680 T_Alphanumplus
1681 -- A qualifier followed by a legal linker symbol prefix. Only used
1682 -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz).
1683 -- Example: GNAT BIND /BUILD_LIBRARY=foobar
1684 );
1685
1686 type Item (Id : Item_Id);
1687 type Item_Ptr is access all Item;
1688
1689 type Item (Id : Item_Id) is record
1690 Name : String_Ptr;
1691 -- Name of the command, switch (with slash) or option
1692
1693 Next : Item_Ptr;
1694 -- Pointer to next item on list, always has the same Id value
1695
1696 Command : Command_Type := Undefined;
1697
1698 Unix_String : String_Ptr := null;
1699 -- Corresponding Unix string. For a command, this is the unix command
1700 -- name and possible default switches. For a switch or option it is
1701 -- the unix switch string.
1702
1703 case Id is
1704
1705 when Id_Command =>
1706
1707 Switches : Item_Ptr;
1708 -- Pointer to list of switch items for the command, linked
1709 -- through the Next fields with null terminating the list.
1710
1711 Usage : String_Ptr;
1712 -- Usage information, used only for errors and the default
1713 -- list of commands output.
1714
1715 Params : Parameter_Ref;
1716 -- Array of parameters
1717
1718 Defext : String (1 .. 3);
1719 -- Default extension. If non-blank, then this extension is
1720 -- supplied by default as the extension for any file parameter
1721 -- which does not have an extension already.
1722
1723 when Id_Switch =>
1724
1725 Translation : Translation_Type;
1726 -- Type of switch translation. For all cases, except Options,
1727 -- this is the only field needed, since the Unix translation
1728 -- is found in Unix_String.
1729
1730 Options : Item_Ptr;
1731 -- For the Options case, this field is set to point to a list
1732 -- of options item (for this case Unix_String is null in the
1733 -- main switch item). The end of the list is marked by null.
1734
1735 when Id_Option =>
1736
1737 null;
1738 -- No special fields needed, since Name and Unix_String are
1739 -- sufficient to completely described an option.
1740
1741 end case;
1742 end record;
1743
1744 subtype Command_Item is Item (Id_Command);
1745 subtype Switch_Item is Item (Id_Switch);
1746 subtype Option_Item is Item (Id_Option);
1747
1748 ----------------------------------
1749 -- Declarations for GNATCMD use --
1750 ----------------------------------
1751
1752 Commands : Item_Ptr;
1753 -- Pointer to head of list of command items, one for each command, with
1754 -- the end of the list marked by a null pointer.
1755
1756 Last_Command : Item_Ptr;
1757 -- Pointer to last item in Commands list
1758
1759 Normal_Exit : exception;
1760 -- Raise this exception for normal program termination
1761
1762 Error_Exit : exception;
1763 -- Raise this exception if error detected
1764
1765 Errors : Natural := 0;
1766 -- Count errors detected
1767
1768 Command_Arg : Positive := 1;
1769
1770 Command : Item_Ptr;
1771 -- Pointer to command item for current command
1772
1773 Make_Commands_Active : Item_Ptr := null;
1774 -- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate
1775 -- if a COMMANDS_TRANSLATION switch has been encountered while processing
1776 -- a MAKE Command.
1777
1778 My_Exit_Status : Exit_Status := Success;
1779
1780 package Buffer is new Table.Table
1781 (Table_Component_Type => Character,
1782 Table_Index_Type => Integer,
1783 Table_Low_Bound => 1,
1784 Table_Initial => 4096,
1785 Table_Increment => 2,
1786 Table_Name => "Buffer");
1787
1788 Param_Count : Natural := 0;
1789 -- Number of parameter arguments so far
1790
1791 Arg_Num : Natural;
1792 -- Argument number
1793
1794 Display_Command : Boolean := False;
1795 -- Set true if /? switch causes display of generated command (on VMS)
1796
1797 The_Command : Command_Type;
1798 -- The command used
1799
1800 -----------------------
1801 -- Local Subprograms --
1802 -----------------------
1803
1804 function Index (Char : Character; Str : String) return Natural;
1805 -- Returns the first occurrence of Char in Str.
1806 -- Returns 0 if Char is not in Str.
1807
1808 function Init_Object_Dirs return Argument_List;
1809
1810 function Invert_Sense (S : String) return String_Ptr;
1811 -- Given a unix switch string S, computes the inverse (adding or
1812 -- removing ! characters as required), and returns a pointer to
1813 -- the allocated result on the heap.
1814
1815 function Is_Extensionless (F : String) return Boolean;
1816 -- Returns true if the filename has no extension.
1817
1818 function Match (S1, S2 : String) return Boolean;
1819 -- Determines whether S1 and S2 match. This is a case insensitive match.
1820
1821 function Match_Prefix (S1, S2 : String) return Boolean;
1822 -- Determines whether S1 matches a prefix of S2. This is also a case
1823 -- insensitive match (for example Match ("AB","abc") is True).
1824
1825 function Matching_Name
1826 (S : String;
1827 Itm : Item_Ptr;
1828 Quiet : Boolean := False)
1829 return Item_Ptr;
1830 -- Determines if the item list headed by Itm and threaded through the
1831 -- Next fields (with null marking the end of the list), contains an
1832 -- entry that uniquely matches the given string. The match is case
1833 -- insensitive and permits unique abbreviation. If the match succeeds,
1834 -- then a pointer to the matching item is returned. Otherwise, an
1835 -- appropriate error message is written. Note that the discriminant
1836 -- of Itm is used to determine the appropriate form of this message.
1837 -- Quiet is normally False as shown, if it is set to True, then no
1838 -- error message is generated in a not found situation (null is still
1839 -- returned to indicate the not-found situation).
1840
1841 procedure Non_VMS_Usage;
1842 -- Display usage for platforms other than VMS
1843
1844 function OK_Alphanumerplus (S : String) return Boolean;
1845 -- Checks that S is a string of alphanumeric characters,
1846 -- returning True if all alphanumeric characters,
1847 -- False if empty or a non-alphanumeric character is present.
1848
1849 function OK_Integer (S : String) return Boolean;
1850 -- Checks that S is a string of digits, returning True if all digits,
1851 -- False if empty or a non-digit is present.
1852
1853 procedure Output_Version;
1854 -- Output the version of this program
1855
1856 procedure Place (C : Character);
1857 -- Place a single character in the buffer, updating Ptr
1858
1859 procedure Place (S : String);
1860 -- Place a string character in the buffer, updating Ptr
1861
1862 procedure Place_Lower (S : String);
1863 -- Place string in buffer, forcing letters to lower case, updating Ptr
1864
1865 procedure Place_Unix_Switches (S : String_Ptr);
1866 -- Given a unix switch string, place corresponding switches in Buffer,
1867 -- updating Ptr appropriatelly. Note that in the case of use of ! the
1868 -- result may be to remove a previously placed switch.
1869
1870 procedure Set_Library_For
1871 (Project : Project_Id;
1872 There_Are_Libraries : in out Boolean);
1873 -- If Project is a library project, add the correct
1874 -- -L and -l switches to the linker invocation.
1875
1876 procedure Set_Libraries is
1877 new For_Every_Project_Imported (Boolean, Set_Library_For);
1878 -- Add the -L and -l switches to the linker for all
1879 -- of the library projects.
1880
1881 procedure Validate_Command_Or_Option (N : String_Ptr);
1882 -- Check that N is a valid command or option name, i.e. that it is of the
1883 -- form of an Ada identifier with upper case letters and underscores.
1884
1885 procedure Validate_Unix_Switch (S : String_Ptr);
1886 -- Check that S is a valid switch string as described in the syntax for
1887 -- the switch table item UNIX_SWITCH or else begins with a backquote.
1888
1889 procedure VMS_Conversion (The_Command : out Command_Type);
1890 -- Converts VMS command line to equivalent Unix command line
1891
1892 -----------
1893 -- Index --
1894 -----------
1895
1896 function Index (Char : Character; Str : String) return Natural is
1897 begin
1898 for Index in Str'Range loop
1899 if Str (Index) = Char then
1900 return Index;
1901 end if;
1902 end loop;
1903
1904 return 0;
1905 end Index;
1906
1907 ----------------------
1908 -- Init_Object_Dirs --
1909 ----------------------
1910
1911 function Init_Object_Dirs return Argument_List is
1912 Object_Dirs : Integer;
1913 Object_Dir : Argument_List (1 .. 256);
1914 Object_Dir_Name : String_Access;
1915
1916 begin
1917 Object_Dirs := 0;
1918 Object_Dir_Name := String_Access (Object_Dir_Default_Name);
1919 Get_Next_Dir_In_Path_Init (Object_Dir_Name);
1920
1921 loop
1922 declare
1923 Dir : String_Access := String_Access
1924 (Get_Next_Dir_In_Path (Object_Dir_Name));
1925 begin
1926 exit when Dir = null;
1927 Object_Dirs := Object_Dirs + 1;
1928 Object_Dir (Object_Dirs) :=
1929 new String'("-L" &
1930 To_Canonical_Dir_Spec
1931 (To_Host_Dir_Spec
1932 (Normalize_Directory_Name (Dir.all).all,
1933 True).all, True).all);
1934 end;
1935 end loop;
1936
1937 Object_Dirs := Object_Dirs + 1;
1938 Object_Dir (Object_Dirs) := new String'("-lgnat");
1939
1940 if Hostparm.OpenVMS then
1941 Object_Dirs := Object_Dirs + 1;
1942 Object_Dir (Object_Dirs) := new String'("-ldecgnat");
1943 end if;
1944
1945 return Object_Dir (1 .. Object_Dirs);
1946 end Init_Object_Dirs;
1947
1948 ------------------
1949 -- Invert_Sense --
1950 ------------------
1951
1952 function Invert_Sense (S : String) return String_Ptr is
1953 Sinv : String (1 .. S'Length * 2);
1954 -- Result (for sure long enough)
1955
1956 Sinvp : Natural := 0;
1957 -- Pointer to output string
1958
1959 begin
1960 for Sp in S'Range loop
1961 if Sp = S'First or else S (Sp - 1) = ',' then
1962 if S (Sp) = '!' then
1963 null;
1964 else
1965 Sinv (Sinvp + 1) := '!';
1966 Sinv (Sinvp + 2) := S (Sp);
1967 Sinvp := Sinvp + 2;
1968 end if;
1969
1970 else
1971 Sinv (Sinvp + 1) := S (Sp);
1972 Sinvp := Sinvp + 1;
1973 end if;
1974 end loop;
1975
1976 return new String'(Sinv (1 .. Sinvp));
1977 end Invert_Sense;
1978
1979 ----------------------
1980 -- Is_Extensionless --
1981 ----------------------
1982
1983 function Is_Extensionless (F : String) return Boolean is
1984 begin
1985 for J in reverse F'Range loop
1986 if F (J) = '.' then
1987 return False;
1988 elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then
1989 return True;
1990 end if;
1991 end loop;
1992
1993 return True;
1994 end Is_Extensionless;
1995
1996 -----------
1997 -- Match --
1998 -----------
1999
2000 function Match (S1, S2 : String) return Boolean is
2001 Dif : constant Integer := S2'First - S1'First;
2002
2003 begin
2004
2005 if S1'Length /= S2'Length then
2006 return False;
2007
2008 else
2009 for J in S1'Range loop
2010 if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then
2011 return False;
2012 end if;
2013 end loop;
2014
2015 return True;
2016 end if;
2017 end Match;
2018
2019 ------------------
2020 -- Match_Prefix --
2021 ------------------
2022
2023 function Match_Prefix (S1, S2 : String) return Boolean is
2024 begin
2025 if S1'Length > S2'Length then
2026 return False;
2027 else
2028 return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1));
2029 end if;
2030 end Match_Prefix;
2031
2032 -------------------
2033 -- Matching_Name --
2034 -------------------
2035
2036 function Matching_Name
2037 (S : String;
2038 Itm : Item_Ptr;
2039 Quiet : Boolean := False)
2040 return Item_Ptr
2041 is
2042 P1, P2 : Item_Ptr;
2043
2044 procedure Err;
2045 -- Little procedure to output command/qualifier/option as appropriate
2046 -- and bump error count.
2047
2048 ---------
2049 -- Err --
2050 ---------
2051
2052 procedure Err is
2053 begin
2054 if Quiet then
2055 return;
2056 end if;
2057
2058 Errors := Errors + 1;
2059
2060 if Itm /= null then
2061 case Itm.Id is
2062 when Id_Command =>
2063 Put (Standard_Error, "command");
2064
2065 when Id_Switch =>
2066 if OpenVMS then
2067 Put (Standard_Error, "qualifier");
2068 else
2069 Put (Standard_Error, "switch");
2070 end if;
2071
2072 when Id_Option =>
2073 Put (Standard_Error, "option");
2074
2075 end case;
2076 else
2077 Put (Standard_Error, "input");
2078
2079 end if;
2080
2081 Put (Standard_Error, ": ");
2082 Put (Standard_Error, S);
2083 end Err;
2084
2085 -- Start of processing for Matching_Name
2086
2087 begin
2088 -- If exact match, that's the one we want
2089
2090 P1 := Itm;
2091 while P1 /= null loop
2092 if Match (S, P1.Name.all) then
2093 return P1;
2094 else
2095 P1 := P1.Next;
2096 end if;
2097 end loop;
2098
2099 -- Now check for prefix matches
2100
2101 P1 := Itm;
2102 while P1 /= null loop
2103 if P1.Name.all = "/<other>" then
2104 return P1;
2105
2106 elsif not Match_Prefix (S, P1.Name.all) then
2107 P1 := P1.Next;
2108
2109 else
2110 -- Here we have found one matching prefix, so see if there is
2111 -- another one (which is an ambiguity)
2112
2113 P2 := P1.Next;
2114 while P2 /= null loop
2115 if Match_Prefix (S, P2.Name.all) then
2116 if not Quiet then
2117 Put (Standard_Error, "ambiguous ");
2118 Err;
2119 Put (Standard_Error, " (matches ");
2120 Put (Standard_Error, P1.Name.all);
2121
2122 while P2 /= null loop
2123 if Match_Prefix (S, P2.Name.all) then
2124 Put (Standard_Error, ',');
2125 Put (Standard_Error, P2.Name.all);
2126 end if;
2127
2128 P2 := P2.Next;
2129 end loop;
2130
2131 Put_Line (Standard_Error, ")");
2132 end if;
2133
2134 return null;
2135 end if;
2136
2137 P2 := P2.Next;
2138 end loop;
2139
2140 -- If we fall through that loop, then there was only one match
2141
2142 return P1;
2143 end if;
2144 end loop;
2145
2146 -- If we fall through outer loop, there was no match
2147
2148 if not Quiet then
2149 Put (Standard_Error, "unrecognized ");
2150 Err;
2151 New_Line (Standard_Error);
2152 end if;
2153
2154 return null;
2155 end Matching_Name;
2156
2157 -----------------------
2158 -- OK_Alphanumerplus --
2159 -----------------------
2160
2161 function OK_Alphanumerplus (S : String) return Boolean is
2162 begin
2163 if S'Length = 0 then
2164 return False;
2165
2166 else
2167 for J in S'Range loop
2168 if not (Is_Alphanumeric (S (J)) or else
2169 S (J) = '_' or else S (J) = '$')
2170 then
2171 return False;
2172 end if;
2173 end loop;
2174
2175 return True;
2176 end if;
2177 end OK_Alphanumerplus;
2178
2179 ----------------
2180 -- OK_Integer --
2181 ----------------
2182
2183 function OK_Integer (S : String) return Boolean is
2184 begin
2185 if S'Length = 0 then
2186 return False;
2187
2188 else
2189 for J in S'Range loop
2190 if not Is_Digit (S (J)) then
2191 return False;
2192 end if;
2193 end loop;
2194
2195 return True;
2196 end if;
2197 end OK_Integer;
2198
2199 --------------------
2200 -- Output_Version --
2201 --------------------
2202
2203 procedure Output_Version is
2204 begin
2205 Put ("GNAT ");
2206 Put (Gnatvsn.Gnat_Version_String);
2207 Put_Line (" Copyright 1996-2002 Free Software Foundation, Inc.");
2208 end Output_Version;
2209
2210 -----------
2211 -- Place --
2212 -----------
2213
2214 procedure Place (C : Character) is
2215 begin
2216 Buffer.Increment_Last;
2217 Buffer.Table (Buffer.Last) := C;
2218
2219 -- Do not put a space as the first character in the buffer
2220 if C = ' ' and then Buffer.Last = 1 then
2221 Buffer.Decrement_Last;
2222 end if;
2223 end Place;
2224
2225 procedure Place (S : String) is
2226 begin
2227 for J in S'Range loop
2228 Place (S (J));
2229 end loop;
2230 end Place;
2231
2232 -----------------
2233 -- Place_Lower --
2234 -----------------
2235
2236 procedure Place_Lower (S : String) is
2237 begin
2238 for J in S'Range loop
2239 Place (To_Lower (S (J)));
2240 end loop;
2241 end Place_Lower;
2242
2243 -------------------------
2244 -- Place_Unix_Switches --
2245 -------------------------
2246
2247 procedure Place_Unix_Switches (S : String_Ptr) is
2248 P1, P2, P3 : Natural;
2249 Remove : Boolean;
2250 Slen : Natural;
2251
2252 begin
2253 P1 := S'First;
2254 while P1 <= S'Last loop
2255 if S (P1) = '!' then
2256 P1 := P1 + 1;
2257 Remove := True;
2258 else
2259 Remove := False;
2260 end if;
2261
2262 P2 := P1;
2263 pragma Assert (S (P1) = '-' or else S (P1) = '`');
2264
2265 while P2 < S'Last and then S (P2 + 1) /= ',' loop
2266 P2 := P2 + 1;
2267 end loop;
2268
2269 -- Switch is now in S (P1 .. P2)
2270
2271 Slen := P2 - P1 + 1;
2272
2273 if Remove then
2274 P3 := 2;
2275 while P3 <= Buffer.Last - Slen loop
2276 if Buffer.Table (P3) = ' '
2277 and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) =
2278 S (P1 .. P2)
2279 and then (P3 + Slen = Buffer.Last
2280 or else
2281 Buffer.Table (P3 + Slen + 1) = ' ')
2282 then
2283 Buffer.Table (P3 .. Buffer.Last - Slen - 1) :=
2284 Buffer.Table (P3 + Slen + 1 .. Buffer.Last);
2285 Buffer.Set_Last (Buffer.Last - Slen - 1);
2286
2287 else
2288 P3 := P3 + 1;
2289 end if;
2290 end loop;
2291
2292 else
2293 Place (' ');
2294
2295 if S (P1) = '`' then
2296 P1 := P1 + 1;
2297 end if;
2298
2299 Place (S (P1 .. P2));
2300 end if;
2301
2302 P1 := P2 + 2;
2303 end loop;
2304 end Place_Unix_Switches;
2305
2306 ---------------------
2307 -- Set_Library_For --
2308 ---------------------
2309
2310 procedure Set_Library_For
2311 (Project : Project_Id;
2312 There_Are_Libraries : in out Boolean)
2313 is
2314 begin
2315 -- Case of library project
2316
2317 if Projects.Table (Project).Library then
2318 There_Are_Libraries := True;
2319
2320 -- Add the -L switch
2321
2322 Last_Switches.Increment_Last;
2323 Last_Switches.Table (Last_Switches.Last) :=
2324 new String'("-L" &
2325 Get_Name_String
2326 (Projects.Table (Project).Library_Dir));
2327
2328 -- Add the -l switch
2329
2330 Last_Switches.Increment_Last;
2331 Last_Switches.Table (Last_Switches.Last) :=
2332 new String'("-l" &
2333 Get_Name_String
2334 (Projects.Table (Project).Library_Name));
2335
2336 -- Add the Wl,-rpath switch if library non static
2337
2338 if Projects.Table (Project).Library_Kind /= Static then
2339 declare
2340 Option : constant String_Access :=
2341 MLib.Tgt.Linker_Library_Path_Option
2342 (Get_Name_String
2343 (Projects.Table (Project).Library_Dir));
2344
2345 begin
2346 if Option /= null then
2347 Last_Switches.Increment_Last;
2348 Last_Switches.Table (Last_Switches.Last) :=
2349 Option;
2350 end if;
2351
2352 end;
2353
2354 end if;
2355
2356 end if;
2357 end Set_Library_For;
2358
2359 --------------------------------
2360 -- Validate_Command_Or_Option --
2361 --------------------------------
2362
2363 procedure Validate_Command_Or_Option (N : String_Ptr) is
2364 begin
2365 pragma Assert (N'Length > 0);
2366
2367 for J in N'Range loop
2368 if N (J) = '_' then
2369 pragma Assert (N (J - 1) /= '_');
2370 null;
2371 else
2372 pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
2373 null;
2374 end if;
2375 end loop;
2376 end Validate_Command_Or_Option;
2377
2378 --------------------------
2379 -- Validate_Unix_Switch --
2380 --------------------------
2381
2382 procedure Validate_Unix_Switch (S : String_Ptr) is
2383 begin
2384 if S (S'First) = '`' then
2385 return;
2386 end if;
2387
2388 pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
2389
2390 for J in S'First + 1 .. S'Last loop
2391 pragma Assert (S (J) /= ' ');
2392
2393 if S (J) = '!' then
2394 pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
2395 null;
2396 end if;
2397 end loop;
2398 end Validate_Unix_Switch;
2399
2400 ----------------------
2401 -- List of Commands --
2402 ----------------------
2403
2404 -- Note that we put this after all the local bodies (except Non_VMS_Usage
2405 -- and VMS_Conversion that use Command_List) to avoid some access before
2406 -- elaboration problems.
2407
2408 Command_List : constant array (Real_Command_Type) of Command_Entry :=
2409 (Bind =>
2410 (Cname => new S'("BIND"),
2411 Usage => new S'("GNAT BIND file[.ali] /qualifiers"),
2412 VMS_Only => False,
2413 Unixcmd => new S'("gnatbind"),
2414 Unixsws => null,
2415 Switches => Bind_Switches'Access,
2416 Params => new Parameter_Array'(1 => File),
2417 Defext => "ali"),
2418
2419 Chop =>
2420 (Cname => new S'("CHOP"),
2421 Usage => new S'("GNAT CHOP file [directory] /qualifiers"),
2422 VMS_Only => False,
2423 Unixcmd => new S'("gnatchop"),
2424 Unixsws => null,
2425 Switches => Chop_Switches'Access,
2426 Params => new Parameter_Array'(1 => File, 2 => Optional_File),
2427 Defext => " "),
2428
2429 Compile =>
2430 (Cname => new S'("COMPILE"),
2431 Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"),
2432 VMS_Only => False,
2433 Unixcmd => new S'("gnatmake"),
2434 Unixsws => new Argument_List' (1 => new String'("-f"),
2435 2 => new String'("-u"),
2436 3 => new String'("-c")),
2437 Switches => GCC_Switches'Access,
2438 Params => new Parameter_Array'(1 => Files_Or_Wildcard),
2439 Defext => " "),
2440
2441 Elim =>
2442 (Cname => new S'("ELIM"),
2443 Usage => new S'("GNAT ELIM name /qualifiers"),
2444 VMS_Only => False,
2445 Unixcmd => new S'("gnatelim"),
2446 Unixsws => null,
2447 Switches => Elim_Switches'Access,
2448 Params => new Parameter_Array'(1 => Other_As_Is),
2449 Defext => "ali"),
2450
2451 Find =>
2452 (Cname => new S'("FIND"),
2453 Usage => new S'("GNAT FIND pattern[:sourcefile[:line"
2454 & "[:column]]] filespec[,...] /qualifiers"),
2455 VMS_Only => False,
2456 Unixcmd => new S'("gnatfind"),
2457 Unixsws => null,
2458 Switches => Find_Switches'Access,
2459 Params => new Parameter_Array'(1 => Other_As_Is,
2460 2 => Files_Or_Wildcard),
2461 Defext => "ali"),
2462
2463 Krunch =>
2464 (Cname => new S'("KRUNCH"),
2465 Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"),
2466 VMS_Only => False,
2467 Unixcmd => new S'("gnatkr"),
2468 Unixsws => null,
2469 Switches => Krunch_Switches'Access,
2470 Params => new Parameter_Array'(1 => File),
2471 Defext => " "),
2472
2473 Library =>
2474 (Cname => new S'("LIBRARY"),
2475 Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]"
2476 & "=directory [/CONFIG=file]"),
2477 VMS_Only => True,
2478 Unixcmd => new S'("gnatlbr"),
2479 Unixsws => null,
2480 Switches => Lbr_Switches'Access,
2481 Params => new Parameter_Array'(1 .. 0 => File),
2482 Defext => " "),
2483
2484 Link =>
2485 (Cname => new S'("LINK"),
2486 Usage => new S'("GNAT LINK file[.ali]"
2487 & " [extra obj_&_lib_&_exe_&_opt files]"
2488 & " /qualifiers"),
2489 VMS_Only => False,
2490 Unixcmd => new S'("gnatlink"),
2491 Unixsws => null,
2492 Switches => Link_Switches'Access,
2493 Params => new Parameter_Array'(1 => Unlimited_Files),
2494 Defext => "ali"),
2495
2496 List =>
2497 (Cname => new S'("LIST"),
2498 Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"),
2499 VMS_Only => False,
2500 Unixcmd => new S'("gnatls"),
2501 Unixsws => null,
2502 Switches => List_Switches'Access,
2503 Params => new Parameter_Array'(1 => File),
2504 Defext => "ali"),
2505
2506 Make =>
2507 (Cname => new S'("MAKE"),
2508 Usage => new S'("GNAT MAKE file /qualifiers (includes "
2509 & "COMPILE /qualifiers)"),
2510 VMS_Only => False,
2511 Unixcmd => new S'("gnatmake"),
2512 Unixsws => null,
2513 Switches => Make_Switches'Access,
2514 Params => new Parameter_Array'(1 => File),
2515 Defext => " "),
2516
2517 Name =>
2518 (Cname => new S'("NAME"),
2519 Usage => new S'("GNAT NAME /qualifiers naming-pattern "
2520 & "[naming-patterns]"),
2521 VMS_Only => False,
2522 Unixcmd => new S'("gnatname"),
2523 Unixsws => null,
2524 Switches => Name_Switches'Access,
2525 Params => new Parameter_Array'(1 => Unlimited_As_Is),
2526 Defext => " "),
2527
2528 Preprocess =>
2529 (Cname => new S'("PREPROCESS"),
2530 Usage => new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"),
2531 VMS_Only => False,
2532 Unixcmd => new S'("gnatprep"),
2533 Unixsws => null,
2534 Switches => Prep_Switches'Access,
2535 Params => new Parameter_Array'(1 .. 3 => File),
2536 Defext => " "),
2537
2538 Shared =>
2539 (Cname => new S'("SHARED"),
2540 Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt"
2541 & "files] /qualifiers"),
2542 VMS_Only => True,
2543 Unixcmd => new S'("gcc"),
2544 Unixsws => new Argument_List'(new String'("-shared")
2545 & Init_Object_Dirs),
2546 Switches => Shared_Switches'Access,
2547 Params => new Parameter_Array'(1 => Unlimited_Files),
2548 Defext => " "),
2549
2550 Standard =>
2551 (Cname => new S'("STANDARD"),
2552 Usage => new S'("GNAT STANDARD"),
2553 VMS_Only => False,
2554 Unixcmd => new S'("gnatpsta"),
2555 Unixsws => null,
2556 Switches => Standard_Switches'Access,
2557 Params => new Parameter_Array'(1 .. 0 => File),
2558 Defext => " "),
2559
2560 Stub =>
2561 (Cname => new S'("STUB"),
2562 Usage => new S'("GNAT STUB file [directory]/qualifiers"),
2563 VMS_Only => False,
2564 Unixcmd => new S'("gnatstub"),
2565 Unixsws => null,
2566 Switches => Stub_Switches'Access,
2567 Params => new Parameter_Array'(1 => File, 2 => Optional_File),
2568 Defext => " "),
2569
2570 Xref =>
2571 (Cname => new S'("XREF"),
2572 Usage => new S'("GNAT XREF filespec[,...] /qualifiers"),
2573 VMS_Only => False,
2574 Unixcmd => new S'("gnatxref"),
2575 Unixsws => null,
2576 Switches => Xref_Switches'Access,
2577 Params => new Parameter_Array'(1 => Files_Or_Wildcard),
2578 Defext => "ali")
2579 );
2580
2581 -------------------
2582 -- Non_VMS_Usage --
2583 -------------------
2584
2585 procedure Non_VMS_Usage is
2586 begin
2587 Output_Version;
2588 New_Line;
2589 Put_Line ("List of available commands");
2590 New_Line;
2591
2592 for C in Command_List'Range loop
2593 if not Command_List (C).VMS_Only then
2594 Put ("GNAT " & Command_List (C).Cname.all);
2595 Set_Col (25);
2596 Put (Command_List (C).Unixcmd.all);
2597
2598 declare
2599 Sws : Argument_List_Access renames Command_List (C).Unixsws;
2600 begin
2601 if Sws /= null then
2602 for J in Sws'Range loop
2603 Put (' ');
2604 Put (Sws (J).all);
2605 end loop;
2606 end if;
2607 end;
2608
2609 New_Line;
2610 end if;
2611 end loop;
2612
2613 New_Line;
2614 Put_Line ("Commands FIND, LIST and XREF accept project file " &
2615 "switches -vPx, -Pprj and -Xnam=val");
2616 New_Line;
2617 end Non_VMS_Usage;
2618
2619 --------------------
2620 -- VMS_Conversion --
2621 --------------------
2622
2623 procedure VMS_Conversion (The_Command : out Command_Type) is
2624 begin
2625 Buffer.Init;
2626
2627 -- First we must preprocess the string form of the command and options
2628 -- list into the internal form that we use.
2629
2630 for C in Real_Command_Type loop
2631
2632 declare
2633 Command : Item_Ptr := new Command_Item;
2634
2635 Last_Switch : Item_Ptr;
2636 -- Last switch in list
2637
2638 begin
2639 -- Link new command item into list of commands
2640
2641 if Last_Command = null then
2642 Commands := Command;
2643 else
2644 Last_Command.Next := Command;
2645 end if;
2646
2647 Last_Command := Command;
2648
2649 -- Fill in fields of new command item
2650
2651 Command.Name := Command_List (C).Cname;
2652 Command.Usage := Command_List (C).Usage;
2653 Command.Command := C;
2654
2655 if Command_List (C).Unixsws = null then
2656 Command.Unix_String := Command_List (C).Unixcmd;
2657 else
2658 declare
2659 Cmd : String (1 .. 5_000);
2660 Last : Natural := 0;
2661 Sws : Argument_List_Access := Command_List (C).Unixsws;
2662
2663 begin
2664 Cmd (1 .. Command_List (C).Unixcmd'Length) :=
2665 Command_List (C).Unixcmd.all;
2666 Last := Command_List (C).Unixcmd'Length;
2667
2668 for J in Sws'Range loop
2669 Last := Last + 1;
2670 Cmd (Last) := ' ';
2671 Cmd (Last + 1 .. Last + Sws (J)'Length) :=
2672 Sws (J).all;
2673 Last := Last + Sws (J)'Length;
2674 end loop;
2675
2676 Command.Unix_String := new String'(Cmd (1 .. Last));
2677 end;
2678 end if;
2679
2680 Command.Params := Command_List (C).Params;
2681 Command.Defext := Command_List (C).Defext;
2682
2683 Validate_Command_Or_Option (Command.Name);
2684
2685 -- Process the switch list
2686
2687 for S in Command_List (C).Switches'Range loop
2688 declare
2689 SS : constant String_Ptr := Command_List (C).Switches (S);
2690
2691 P : Natural := SS'First;
2692 Sw : Item_Ptr := new Switch_Item;
2693
2694 Last_Opt : Item_Ptr;
2695 -- Pointer to last option
2696
2697 begin
2698 -- Link new switch item into list of switches
2699
2700 if Last_Switch = null then
2701 Command.Switches := Sw;
2702 else
2703 Last_Switch.Next := Sw;
2704 end if;
2705
2706 Last_Switch := Sw;
2707
2708 -- Process switch string, first get name
2709
2710 while SS (P) /= ' ' and SS (P) /= '=' loop
2711 P := P + 1;
2712 end loop;
2713
2714 Sw.Name := new String'(SS (SS'First .. P - 1));
2715
2716 -- Direct translation case
2717
2718 if SS (P) = ' ' then
2719 Sw.Translation := T_Direct;
2720 Sw.Unix_String := new String'(SS (P + 1 .. SS'Last));
2721 Validate_Unix_Switch (Sw.Unix_String);
2722
2723 if SS (P - 1) = '>' then
2724 Sw.Translation := T_Other;
2725
2726 elsif SS (P + 1) = '`' then
2727 null;
2728
2729 -- Create the inverted case (/NO ..)
2730
2731 elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then
2732 Sw := new Switch_Item;
2733 Last_Switch.Next := Sw;
2734 Last_Switch := Sw;
2735
2736 Sw.Name :=
2737 new String'("/NO" & SS (SS'First + 1 .. P - 1));
2738 Sw.Translation := T_Direct;
2739 Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last));
2740 Validate_Unix_Switch (Sw.Unix_String);
2741 end if;
2742
2743 -- Directories translation case
2744
2745 elsif SS (P + 1) = '*' then
2746 pragma Assert (SS (SS'Last) = '*');
2747 Sw.Translation := T_Directories;
2748 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
2749 Validate_Unix_Switch (Sw.Unix_String);
2750
2751 -- Directory translation case
2752
2753 elsif SS (P + 1) = '%' then
2754 pragma Assert (SS (SS'Last) = '%');
2755 Sw.Translation := T_Directory;
2756 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
2757 Validate_Unix_Switch (Sw.Unix_String);
2758
2759 -- File translation case
2760
2761 elsif SS (P + 1) = '@' then
2762 pragma Assert (SS (SS'Last) = '@');
2763 Sw.Translation := T_File;
2764 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
2765 Validate_Unix_Switch (Sw.Unix_String);
2766
2767 -- No space file translation case
2768
2769 elsif SS (P + 1) = '<' then
2770 pragma Assert (SS (SS'Last) = '>');
2771 Sw.Translation := T_No_Space_File;
2772 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
2773 Validate_Unix_Switch (Sw.Unix_String);
2774
2775 -- Numeric translation case
2776
2777 elsif SS (P + 1) = '#' then
2778 pragma Assert (SS (SS'Last) = '#');
2779 Sw.Translation := T_Numeric;
2780 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
2781 Validate_Unix_Switch (Sw.Unix_String);
2782
2783 -- Alphanumerplus translation case
2784
2785 elsif SS (P + 1) = '|' then
2786 pragma Assert (SS (SS'Last) = '|');
2787 Sw.Translation := T_Alphanumplus;
2788 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
2789 Validate_Unix_Switch (Sw.Unix_String);
2790
2791 -- String translation case
2792
2793 elsif SS (P + 1) = '"' then
2794 pragma Assert (SS (SS'Last) = '"');
2795 Sw.Translation := T_String;
2796 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
2797 Validate_Unix_Switch (Sw.Unix_String);
2798
2799 -- Commands translation case
2800
2801 elsif SS (P + 1) = '?' then
2802 Sw.Translation := T_Commands;
2803 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last));
2804
2805 -- Options translation case
2806
2807 else
2808 Sw.Translation := T_Options;
2809 Sw.Unix_String := new String'("");
2810
2811 P := P + 1; -- bump past =
2812 while P <= SS'Last loop
2813 declare
2814 Opt : Item_Ptr := new Option_Item;
2815 Q : Natural;
2816
2817 begin
2818 -- Link new option item into options list
2819
2820 if Last_Opt = null then
2821 Sw.Options := Opt;
2822 else
2823 Last_Opt.Next := Opt;
2824 end if;
2825
2826 Last_Opt := Opt;
2827
2828 -- Fill in fields of new option item
2829
2830 Q := P;
2831 while SS (Q) /= ' ' loop
2832 Q := Q + 1;
2833 end loop;
2834
2835 Opt.Name := new String'(SS (P .. Q - 1));
2836 Validate_Command_Or_Option (Opt.Name);
2837
2838 P := Q + 1;
2839 Q := P;
2840
2841 while Q <= SS'Last and then SS (Q) /= ' ' loop
2842 Q := Q + 1;
2843 end loop;
2844
2845 Opt.Unix_String := new String'(SS (P .. Q - 1));
2846 Validate_Unix_Switch (Opt.Unix_String);
2847 P := Q + 1;
2848 end;
2849 end loop;
2850 end if;
2851 end;
2852 end loop;
2853 end;
2854 end loop;
2855
2856 -- If no parameters, give complete list of commands
2857
2858 if Argument_Count = 0 then
2859 Output_Version;
2860 New_Line;
2861 Put_Line ("List of available commands");
2862 New_Line;
2863
2864 while Commands /= null loop
2865 Put (Commands.Usage.all);
2866 Set_Col (53);
2867 Put_Line (Commands.Unix_String.all);
2868 Commands := Commands.Next;
2869 end loop;
2870
2871 raise Normal_Exit;
2872 end if;
2873
2874 Arg_Num := 1;
2875
2876 -- Loop through arguments
2877
2878 while Arg_Num <= Argument_Count loop
2879
2880 Process_Argument : declare
2881 Argv : String_Access;
2882 Arg_Idx : Integer;
2883
2884 function Get_Arg_End
2885 (Argv : String;
2886 Arg_Idx : Integer)
2887 return Integer;
2888 -- Begins looking at Arg_Idx + 1 and returns the index of the
2889 -- last character before a slash or else the index of the last
2890 -- character in the string Argv.
2891
2892 -----------------
2893 -- Get_Arg_End --
2894 -----------------
2895
2896 function Get_Arg_End
2897 (Argv : String;
2898 Arg_Idx : Integer)
2899 return Integer
2900 is
2901 begin
2902 for J in Arg_Idx + 1 .. Argv'Last loop
2903 if Argv (J) = '/' then
2904 return J - 1;
2905 end if;
2906 end loop;
2907
2908 return Argv'Last;
2909 end Get_Arg_End;
2910
2911 -- Start of processing for Process_Argument
2912
2913 begin
2914 Argv := new String'(Argument (Arg_Num));
2915 Arg_Idx := Argv'First;
2916
2917 <<Tryagain_After_Coalesce>>
2918 loop
2919 declare
2920 Next_Arg_Idx : Integer;
2921 Arg : String_Access;
2922
2923 begin
2924 Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
2925 Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
2926
2927 -- The first one must be a command name
2928
2929 if Arg_Num = 1 and then Arg_Idx = Argv'First then
2930
2931 Command := Matching_Name (Arg.all, Commands);
2932
2933 if Command = null then
2934 raise Error_Exit;
2935 end if;
2936
2937 The_Command := Command.Command;
2938
2939 -- Give usage information if only command given
2940
2941 if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last
2942 and then Command.Command /= Standard
2943 then
2944 Output_Version;
2945 New_Line;
2946 Put_Line
2947 ("List of available qualifiers and options");
2948 New_Line;
2949
2950 Put (Command.Usage.all);
2951 Set_Col (53);
2952 Put_Line (Command.Unix_String.all);
2953
2954 declare
2955 Sw : Item_Ptr := Command.Switches;
2956
2957 begin
2958 while Sw /= null loop
2959 Put (" ");
2960 Put (Sw.Name.all);
2961
2962 case Sw.Translation is
2963
2964 when T_Other =>
2965 Set_Col (53);
2966 Put_Line (Sw.Unix_String.all &
2967 "/<other>");
2968
2969 when T_Direct =>
2970 Set_Col (53);
2971 Put_Line (Sw.Unix_String.all);
2972
2973 when T_Directories =>
2974 Put ("=(direc,direc,..direc)");
2975 Set_Col (53);
2976 Put (Sw.Unix_String.all);
2977 Put (" direc ");
2978 Put (Sw.Unix_String.all);
2979 Put_Line (" direc ...");
2980
2981 when T_Directory =>
2982 Put ("=directory");
2983 Set_Col (53);
2984 Put (Sw.Unix_String.all);
2985
2986 if Sw.Unix_String (Sw.Unix_String'Last)
2987 /= '='
2988 then
2989 Put (' ');
2990 end if;
2991
2992 Put_Line ("directory ");
2993
2994 when T_File | T_No_Space_File =>
2995 Put ("=file");
2996 Set_Col (53);
2997 Put (Sw.Unix_String.all);
2998
2999 if Sw.Translation = T_File
3000 and then Sw.Unix_String
3001 (Sw.Unix_String'Last)
3002 /= '='
3003 then
3004 Put (' ');
3005 end if;
3006
3007 Put_Line ("file ");
3008
3009 when T_Numeric =>
3010 Put ("=nnn");
3011 Set_Col (53);
3012
3013 if Sw.Unix_String (Sw.Unix_String'First)
3014 = '`'
3015 then
3016 Put (Sw.Unix_String
3017 (Sw.Unix_String'First + 1
3018 .. Sw.Unix_String'Last));
3019 else
3020 Put (Sw.Unix_String.all);
3021 end if;
3022
3023 Put_Line ("nnn");
3024
3025 when T_Alphanumplus =>
3026 Put ("=xyz");
3027 Set_Col (53);
3028
3029 if Sw.Unix_String (Sw.Unix_String'First)
3030 = '`'
3031 then
3032 Put (Sw.Unix_String
3033 (Sw.Unix_String'First + 1
3034 .. Sw.Unix_String'Last));
3035 else
3036 Put (Sw.Unix_String.all);
3037 end if;
3038
3039 Put_Line ("xyz");
3040
3041 when T_String =>
3042 Put ("=");
3043 Put ('"');
3044 Put ("<string>");
3045 Put ('"');
3046 Set_Col (53);
3047
3048 Put (Sw.Unix_String.all);
3049
3050 if Sw.Unix_String (Sw.Unix_String'Last)
3051 /= '='
3052 then
3053 Put (' ');
3054 end if;
3055
3056 Put ("<string>");
3057 New_Line;
3058
3059 when T_Commands =>
3060 Put (" (switches for ");
3061 Put (Sw.Unix_String
3062 (Sw.Unix_String'First + 7
3063 .. Sw.Unix_String'Last));
3064 Put (')');
3065 Set_Col (53);
3066 Put (Sw.Unix_String
3067 (Sw.Unix_String'First
3068 .. Sw.Unix_String'First + 5));
3069 Put_Line (" switches");
3070
3071 when T_Options =>
3072 declare
3073 Opt : Item_Ptr := Sw.Options;
3074
3075 begin
3076 Put_Line ("=(option,option..)");
3077
3078 while Opt /= null loop
3079 Put (" ");
3080 Put (Opt.Name.all);
3081
3082 if Opt = Sw.Options then
3083 Put (" (D)");
3084 end if;
3085
3086 Set_Col (53);
3087 Put_Line (Opt.Unix_String.all);
3088 Opt := Opt.Next;
3089 end loop;
3090 end;
3091
3092 end case;
3093
3094 Sw := Sw.Next;
3095 end loop;
3096 end;
3097
3098 raise Normal_Exit;
3099 end if;
3100
3101 -- Place (Command.Unix_String.all);
3102
3103 -- Special handling for internal debugging switch /?
3104
3105 elsif Arg.all = "/?" then
3106 Display_Command := True;
3107
3108 -- Copy -switch unchanged
3109
3110 elsif Arg (Arg'First) = '-' then
3111 Place (' ');
3112 Place (Arg.all);
3113
3114 -- Copy quoted switch with quotes stripped
3115
3116 elsif Arg (Arg'First) = '"' then
3117 if Arg (Arg'Last) /= '"' then
3118 Put (Standard_Error, "misquoted argument: ");
3119 Put_Line (Standard_Error, Arg.all);
3120 Errors := Errors + 1;
3121
3122 else
3123 Place (' ');
3124 Place (Arg (Arg'First + 1 .. Arg'Last - 1));
3125 end if;
3126
3127 -- Parameter Argument
3128
3129 elsif Arg (Arg'First) /= '/'
3130 and then Make_Commands_Active = null
3131 then
3132 Param_Count := Param_Count + 1;
3133
3134 if Param_Count <= Command.Params'Length then
3135
3136 case Command.Params (Param_Count) is
3137
3138 when File | Optional_File =>
3139 declare
3140 Normal_File : String_Access
3141 := To_Canonical_File_Spec (Arg.all);
3142 begin
3143 Place (' ');
3144 Place_Lower (Normal_File.all);
3145
3146 if Is_Extensionless (Normal_File.all)
3147 and then Command.Defext /= " "
3148 then
3149 Place ('.');
3150 Place (Command.Defext);
3151 end if;
3152 end;
3153
3154 when Unlimited_Files =>
3155 declare
3156 Normal_File : String_Access
3157 := To_Canonical_File_Spec (Arg.all);
3158
3159 File_Is_Wild : Boolean := False;
3160 File_List : String_Access_List_Access;
3161 begin
3162 for I in Arg'Range loop
3163 if Arg (I) = '*'
3164 or else Arg (I) = '%'
3165 then
3166 File_Is_Wild := True;
3167 end if;
3168 end loop;
3169
3170 if File_Is_Wild then
3171 File_List := To_Canonical_File_List
3172 (Arg.all, False);
3173
3174 for I in File_List.all'Range loop
3175 Place (' ');
3176 Place_Lower (File_List.all (I).all);
3177 end loop;
3178 else
3179 Place (' ');
3180 Place_Lower (Normal_File.all);
3181
3182 if Is_Extensionless (Normal_File.all)
3183 and then Command.Defext /= " "
3184 then
3185 Place ('.');
3186 Place (Command.Defext);
3187 end if;
3188 end if;
3189
3190 Param_Count := Param_Count - 1;
3191 end;
3192
3193 when Other_As_Is =>
3194 Place (' ');
3195 Place (Arg.all);
3196
3197 when Unlimited_As_Is =>
3198 Place (' ');
3199 Place (Arg.all);
3200 Param_Count := Param_Count - 1;
3201
3202 when Files_Or_Wildcard =>
3203
3204 -- Remove spaces from a comma separated list
3205 -- of file names and adjust control variables
3206 -- accordingly.
3207
3208 while Arg_Num < Argument_Count and then
3209 (Argv (Argv'Last) = ',' xor
3210 Argument (Arg_Num + 1)
3211 (Argument (Arg_Num + 1)'First) = ',')
3212 loop
3213 Argv := new String'
3214 (Argv.all & Argument (Arg_Num + 1));
3215 Arg_Num := Arg_Num + 1;
3216 Arg_Idx := Argv'First;
3217 Next_Arg_Idx :=
3218 Get_Arg_End (Argv.all, Arg_Idx);
3219 Arg := new String'
3220 (Argv (Arg_Idx .. Next_Arg_Idx));
3221 end loop;
3222
3223 -- Parse the comma separated list of VMS
3224 -- filenames and place them on the command
3225 -- line as space separated Unix style
3226 -- filenames. Lower case and add default
3227 -- extension as appropriate.
3228
3229 declare
3230 Arg1_Idx : Integer := Arg'First;
3231
3232 function Get_Arg1_End
3233 (Arg : String; Arg_Idx : Integer)
3234 return Integer;
3235 -- Begins looking at Arg_Idx + 1 and
3236 -- returns the index of the last character
3237 -- before a comma or else the index of the
3238 -- last character in the string Arg.
3239
3240 function Get_Arg1_End
3241 (Arg : String; Arg_Idx : Integer)
3242 return Integer
3243 is
3244 begin
3245 for I in Arg_Idx + 1 .. Arg'Last loop
3246 if Arg (I) = ',' then
3247 return I - 1;
3248 end if;
3249 end loop;
3250
3251 return Arg'Last;
3252 end Get_Arg1_End;
3253
3254 begin
3255 loop
3256 declare
3257 Next_Arg1_Idx : Integer :=
3258 Get_Arg1_End (Arg.all, Arg1_Idx);
3259
3260 Arg1 : String :=
3261 Arg (Arg1_Idx .. Next_Arg1_Idx);
3262
3263 Normal_File : String_Access :=
3264 To_Canonical_File_Spec (Arg1);
3265
3266 begin
3267 Place (' ');
3268 Place_Lower (Normal_File.all);
3269
3270 if Is_Extensionless (Normal_File.all)
3271 and then Command.Defext /= " "
3272 then
3273 Place ('.');
3274 Place (Command.Defext);
3275 end if;
3276
3277 Arg1_Idx := Next_Arg1_Idx + 1;
3278 end;
3279
3280 exit when Arg1_Idx > Arg'Last;
3281
3282 -- Don't allow two or more commas in
3283 -- a row
3284
3285 if Arg (Arg1_Idx) = ',' then
3286 Arg1_Idx := Arg1_Idx + 1;
3287 if Arg1_Idx > Arg'Last or else
3288 Arg (Arg1_Idx) = ','
3289 then
3290 Put_Line
3291 (Standard_Error,
3292 "Malformed Parameter: " &
3293 Arg.all);
3294 Put (Standard_Error, "usage: ");
3295 Put_Line (Standard_Error,
3296 Command.Usage.all);
3297 raise Error_Exit;
3298 end if;
3299 end if;
3300
3301 end loop;
3302 end;
3303 end case;
3304 end if;
3305
3306 -- Qualifier argument
3307
3308 else
3309 declare
3310 Sw : Item_Ptr;
3311 SwP : Natural;
3312 P2 : Natural;
3313 Endp : Natural := 0; -- avoid warning!
3314 Opt : Item_Ptr;
3315
3316 begin
3317 SwP := Arg'First;
3318 while SwP < Arg'Last
3319 and then Arg (SwP + 1) /= '='
3320 loop
3321 SwP := SwP + 1;
3322 end loop;
3323
3324 -- At this point, the switch name is in
3325 -- Arg (Arg'First..SwP) and if that is not the
3326 -- whole switch, then there is an equal sign at
3327 -- Arg (SwP + 1) and the rest of Arg is what comes
3328 -- after the equal sign.
3329
3330 -- If make commands are active, see if we have
3331 -- another COMMANDS_TRANSLATION switch belonging
3332 -- to gnatmake.
3333
3334 if Make_Commands_Active /= null then
3335 Sw :=
3336 Matching_Name
3337 (Arg (Arg'First .. SwP),
3338 Command.Switches,
3339 Quiet => True);
3340
3341 if Sw /= null
3342 and then Sw.Translation = T_Commands
3343 then
3344 null;
3345
3346 else
3347 Sw :=
3348 Matching_Name
3349 (Arg (Arg'First .. SwP),
3350 Make_Commands_Active.Switches,
3351 Quiet => False);
3352 end if;
3353
3354 -- For case of GNAT MAKE or CHOP, if we cannot
3355 -- find the switch, then see if it is a
3356 -- recognized compiler switch instead, and if
3357 -- so process the compiler switch.
3358
3359 elsif Command.Name.all = "MAKE"
3360 or else Command.Name.all = "CHOP" then
3361 Sw :=
3362 Matching_Name
3363 (Arg (Arg'First .. SwP),
3364 Command.Switches,
3365 Quiet => True);
3366
3367 if Sw = null then
3368 Sw :=
3369 Matching_Name
3370 (Arg (Arg'First .. SwP),
3371 Matching_Name
3372 ("COMPILE", Commands).Switches,
3373 Quiet => False);
3374 end if;
3375
3376 -- For all other cases, just search the relevant
3377 -- command.
3378
3379 else
3380 Sw :=
3381 Matching_Name
3382 (Arg (Arg'First .. SwP),
3383 Command.Switches,
3384 Quiet => False);
3385 end if;
3386
3387 if Sw /= null then
3388 case Sw.Translation is
3389
3390 when T_Direct =>
3391 Place_Unix_Switches (Sw.Unix_String);
3392 if SwP < Arg'Last
3393 and then Arg (SwP + 1) = '='
3394 then
3395 Put (Standard_Error,
3396 "qualifier options ignored: ");
3397 Put_Line (Standard_Error, Arg.all);
3398 end if;
3399
3400 when T_Directories =>
3401 if SwP + 1 > Arg'Last then
3402 Put (Standard_Error,
3403 "missing directories for: ");
3404 Put_Line (Standard_Error, Arg.all);
3405 Errors := Errors + 1;
3406
3407 elsif Arg (SwP + 2) /= '(' then
3408 SwP := SwP + 2;
3409 Endp := Arg'Last;
3410
3411 elsif Arg (Arg'Last) /= ')' then
3412
3413 -- Remove spaces from a comma separated
3414 -- list of file names and adjust
3415 -- control variables accordingly.
3416
3417 if Arg_Num < Argument_Count and then
3418 (Argv (Argv'Last) = ',' xor
3419 Argument (Arg_Num + 1)
3420 (Argument (Arg_Num + 1)'First) = ',')
3421 then
3422 Argv :=
3423 new String'(Argv.all
3424 & Argument
3425 (Arg_Num + 1));
3426 Arg_Num := Arg_Num + 1;
3427 Arg_Idx := Argv'First;
3428 Next_Arg_Idx
3429 := Get_Arg_End (Argv.all, Arg_Idx);
3430 Arg := new String'
3431 (Argv (Arg_Idx .. Next_Arg_Idx));
3432 goto Tryagain_After_Coalesce;
3433 end if;
3434
3435 Put (Standard_Error,
3436 "incorrectly parenthesized " &
3437 "or malformed argument: ");
3438 Put_Line (Standard_Error, Arg.all);
3439 Errors := Errors + 1;
3440
3441 else
3442 SwP := SwP + 3;
3443 Endp := Arg'Last - 1;
3444 end if;
3445
3446 while SwP <= Endp loop
3447 declare
3448 Dir_Is_Wild : Boolean := False;
3449 Dir_Maybe_Is_Wild : Boolean := False;
3450 Dir_List : String_Access_List_Access;
3451 begin
3452 P2 := SwP;
3453
3454 while P2 < Endp
3455 and then Arg (P2 + 1) /= ','
3456 loop
3457
3458 -- A wildcard directory spec on
3459 -- VMS will contain either * or
3460 -- % or ...
3461
3462 if Arg (P2) = '*' then
3463 Dir_Is_Wild := True;
3464
3465 elsif Arg (P2) = '%' then
3466 Dir_Is_Wild := True;
3467
3468 elsif Dir_Maybe_Is_Wild
3469 and then Arg (P2) = '.'
3470 and then Arg (P2 + 1) = '.'
3471 then
3472 Dir_Is_Wild := True;
3473 Dir_Maybe_Is_Wild := False;
3474
3475 elsif Dir_Maybe_Is_Wild then
3476 Dir_Maybe_Is_Wild := False;
3477
3478 elsif Arg (P2) = '.'
3479 and then Arg (P2 + 1) = '.'
3480 then
3481 Dir_Maybe_Is_Wild := True;
3482
3483 end if;
3484
3485 P2 := P2 + 1;
3486 end loop;
3487
3488 if (Dir_Is_Wild) then
3489 Dir_List := To_Canonical_File_List
3490 (Arg (SwP .. P2), True);
3491
3492 for I in Dir_List.all'Range loop
3493 Place_Unix_Switches
3494 (Sw.Unix_String);
3495 Place_Lower
3496 (Dir_List.all (I).all);
3497 end loop;
3498 else
3499 Place_Unix_Switches
3500 (Sw.Unix_String);
3501 Place_Lower
3502 (To_Canonical_Dir_Spec
3503 (Arg (SwP .. P2), False).all);
3504 end if;
3505
3506 SwP := P2 + 2;
3507 end;
3508 end loop;
3509
3510 when T_Directory =>
3511 if SwP + 1 > Arg'Last then
3512 Put (Standard_Error,
3513 "missing directory for: ");
3514 Put_Line (Standard_Error, Arg.all);
3515 Errors := Errors + 1;
3516
3517 else
3518 Place_Unix_Switches (Sw.Unix_String);
3519
3520 -- Some switches end in "=". No space
3521 -- here
3522
3523 if Sw.Unix_String
3524 (Sw.Unix_String'Last) /= '='
3525 then
3526 Place (' ');
3527 end if;
3528
3529 Place_Lower
3530 (To_Canonical_Dir_Spec
3531 (Arg (SwP + 2 .. Arg'Last),
3532 False).all);
3533 end if;
3534
3535 when T_File | T_No_Space_File =>
3536 if SwP + 1 > Arg'Last then
3537 Put (Standard_Error,
3538 "missing file for: ");
3539 Put_Line (Standard_Error, Arg.all);
3540 Errors := Errors + 1;
3541
3542 else
3543 Place_Unix_Switches (Sw.Unix_String);
3544
3545 -- Some switches end in "=". No space
3546 -- here.
3547
3548 if Sw.Translation = T_File
3549 and then Sw.Unix_String
3550 (Sw.Unix_String'Last) /= '='
3551 then
3552 Place (' ');
3553 end if;
3554
3555 Place_Lower
3556 (To_Canonical_File_Spec
3557 (Arg (SwP + 2 .. Arg'Last)).all);
3558 end if;
3559
3560 when T_Numeric =>
3561 if
3562 OK_Integer (Arg (SwP + 2 .. Arg'Last))
3563 then
3564 Place_Unix_Switches (Sw.Unix_String);
3565 Place (Arg (SwP + 2 .. Arg'Last));
3566
3567 else
3568 Put (Standard_Error, "argument for ");
3569 Put (Standard_Error, Sw.Name.all);
3570 Put_Line
3571 (Standard_Error, " must be numeric");
3572 Errors := Errors + 1;
3573 end if;
3574
3575 when T_Alphanumplus =>
3576 if
3577 OK_Alphanumerplus
3578 (Arg (SwP + 2 .. Arg'Last))
3579 then
3580 Place_Unix_Switches (Sw.Unix_String);
3581 Place (Arg (SwP + 2 .. Arg'Last));
3582
3583 else
3584 Put (Standard_Error, "argument for ");
3585 Put (Standard_Error, Sw.Name.all);
3586 Put_Line (Standard_Error,
3587 " must be alphanumeric");
3588 Errors := Errors + 1;
3589 end if;
3590
3591 when T_String =>
3592
3593 -- A String value must be extended to the
3594 -- end of the Argv, otherwise strings like
3595 -- "foo/bar" get split at the slash.
3596 --
3597 -- The begining and ending of the string
3598 -- are flagged with embedded nulls which
3599 -- are removed when building the Spawn
3600 -- call. Nulls are use because they won't
3601 -- show up in a /? output. Quotes aren't
3602 -- used because that would make it
3603 -- difficult to embed them.
3604
3605 Place_Unix_Switches (Sw.Unix_String);
3606 if Next_Arg_Idx /= Argv'Last then
3607 Next_Arg_Idx := Argv'Last;
3608 Arg := new String'
3609 (Argv (Arg_Idx .. Next_Arg_Idx));
3610
3611 SwP := Arg'First;
3612 while SwP < Arg'Last and then
3613 Arg (SwP + 1) /= '=' loop
3614 SwP := SwP + 1;
3615 end loop;
3616 end if;
3617 Place (ASCII.NUL);
3618 Place (Arg (SwP + 2 .. Arg'Last));
3619 Place (ASCII.NUL);
3620
3621 when T_Commands =>
3622
3623 -- Output -largs/-bargs/-cargs
3624
3625 Place (' ');
3626 Place (Sw.Unix_String
3627 (Sw.Unix_String'First ..
3628 Sw.Unix_String'First + 5));
3629
3630 -- Set source of new commands, also
3631 -- setting this non-null indicates that
3632 -- we are in the special commands mode
3633 -- for processing the -xargs case.
3634
3635 Make_Commands_Active :=
3636 Matching_Name
3637 (Sw.Unix_String
3638 (Sw.Unix_String'First + 7 ..
3639 Sw.Unix_String'Last),
3640 Commands);
3641
3642 when T_Options =>
3643 if SwP + 1 > Arg'Last then
3644 Place_Unix_Switches
3645 (Sw.Options.Unix_String);
3646 SwP := Endp + 1;
3647
3648 elsif Arg (SwP + 2) /= '(' then
3649 SwP := SwP + 2;
3650 Endp := Arg'Last;
3651
3652 elsif Arg (Arg'Last) /= ')' then
3653 Put
3654 (Standard_Error,
3655 "incorrectly parenthesized " &
3656 "argument: ");
3657 Put_Line (Standard_Error, Arg.all);
3658 Errors := Errors + 1;
3659 SwP := Endp + 1;
3660
3661 else
3662 SwP := SwP + 3;
3663 Endp := Arg'Last - 1;
3664 end if;
3665
3666 while SwP <= Endp loop
3667 P2 := SwP;
3668
3669 while P2 < Endp
3670 and then Arg (P2 + 1) /= ','
3671 loop
3672 P2 := P2 + 1;
3673 end loop;
3674
3675 -- Option name is in Arg (SwP .. P2)
3676
3677 Opt := Matching_Name (Arg (SwP .. P2),
3678 Sw.Options);
3679
3680 if Opt /= null then
3681 Place_Unix_Switches
3682 (Opt.Unix_String);
3683 end if;
3684
3685 SwP := P2 + 2;
3686 end loop;
3687
3688 when T_Other =>
3689 Place_Unix_Switches
3690 (new String'(Sw.Unix_String.all &
3691 Arg.all));
3692
3693 end case;
3694 end if;
3695 end;
3696 end if;
3697
3698 Arg_Idx := Next_Arg_Idx + 1;
3699 end;
3700
3701 exit when Arg_Idx > Argv'Last;
3702
3703 end loop;
3704 end Process_Argument;
3705
3706 Arg_Num := Arg_Num + 1;
3707 end loop;
3708
3709 if Display_Command then
3710 Put (Standard_Error, "generated command -->");
3711 Put (Standard_Error, Command_List (The_Command).Unixcmd.all);
3712
3713 if Command_List (The_Command).Unixsws /= null then
3714 for J in Command_List (The_Command).Unixsws'Range loop
3715 Put (Standard_Error, " ");
3716 Put (Standard_Error,
3717 Command_List (The_Command).Unixsws (J).all);
3718 end loop;
3719 end if;
3720
3721 Put (Standard_Error, " ");
3722 Put (Standard_Error, String (Buffer.Table (1 .. Buffer.Last)));
3723 Put (Standard_Error, "<--");
3724 New_Line (Standard_Error);
3725 raise Normal_Exit;
3726 end if;
3727
3728 -- Gross error checking that the number of parameters is correct.
3729 -- Not applicable to Unlimited_Files parameters.
3730
3731 if (Param_Count = Command.Params'Length - 1
3732 and then Command.Params (Param_Count + 1) = Unlimited_Files)
3733 or else Param_Count <= Command.Params'Length
3734 then
3735 null;
3736
3737 else
3738 Put_Line (Standard_Error,
3739 "Parameter count of "
3740 & Integer'Image (Param_Count)
3741 & " not equal to expected "
3742 & Integer'Image (Command.Params'Length));
3743 Put (Standard_Error, "usage: ");
3744 Put_Line (Standard_Error, Command.Usage.all);
3745 Errors := Errors + 1;
3746 end if;
3747
3748 if Errors > 0 then
3749 raise Error_Exit;
3750 else
3751 -- Prepare arguments for a call to spawn, filtering out
3752 -- embedded nulls place there to delineate strings.
3753
3754 declare
3755 P1, P2 : Natural;
3756 Inside_Nul : Boolean := False;
3757 Arg : String (1 .. 1024);
3758 Arg_Ctr : Natural;
3759
3760 begin
3761 P1 := 1;
3762
3763 while P1 <= Buffer.Last and then Buffer.Table (P1) = ' ' loop
3764 P1 := P1 + 1;
3765 end loop;
3766
3767 Arg_Ctr := 1;
3768 Arg (Arg_Ctr) := Buffer.Table (P1);
3769
3770 while P1 <= Buffer.Last loop
3771
3772 if Buffer.Table (P1) = ASCII.NUL then
3773 if Inside_Nul then
3774 Inside_Nul := False;
3775 else
3776 Inside_Nul := True;
3777 end if;
3778 end if;
3779
3780 if Buffer.Table (P1) = ' ' and then not Inside_Nul then
3781 P1 := P1 + 1;
3782 Arg_Ctr := Arg_Ctr + 1;
3783 Arg (Arg_Ctr) := Buffer.Table (P1);
3784
3785 else
3786 Last_Switches.Increment_Last;
3787 P2 := P1;
3788
3789 while P2 < Buffer.Last
3790 and then (Buffer.Table (P2 + 1) /= ' ' or else
3791 Inside_Nul)
3792 loop
3793 P2 := P2 + 1;
3794 Arg_Ctr := Arg_Ctr + 1;
3795 Arg (Arg_Ctr) := Buffer.Table (P2);
3796 if Buffer.Table (P2) = ASCII.NUL then
3797 Arg_Ctr := Arg_Ctr - 1;
3798 if Inside_Nul then
3799 Inside_Nul := False;
3800 else
3801 Inside_Nul := True;
3802 end if;
3803 end if;
3804 end loop;
3805
3806 Last_Switches.Table (Last_Switches.Last) :=
3807 new String'(String (Arg (1 .. Arg_Ctr)));
3808 P1 := P2 + 2;
3809 Arg_Ctr := 1;
3810 Arg (Arg_Ctr) := Buffer.Table (P1);
3811 end if;
3812 end loop;
3813 end;
3814 end if;
3815 end VMS_Conversion;
3816
3817 -------------------------------------
3818 -- Start of processing for GNATCmd --
3819 -------------------------------------
3820
3821 begin
3822 -- Initializations
3823
3824 Namet.Initialize;
3825 Csets.Initialize;
3826
3827 Snames.Initialize;
3828
3829 Prj.Initialize;
3830
3831 Last_Switches.Init;
3832 Last_Switches.Set_Last (0);
3833
3834 First_Switches.Init;
3835 First_Switches.Set_Last (0);
3836
3837 -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
3838 -- filenames and pathnames to Unix style.
3839
3840 if Hostparm.OpenVMS
3841 or else To_Lower (Getenv ("EMULATE_VMS").all) = "true"
3842 then
3843 VMS_Conversion (The_Command);
3844
3845 -- If not on VMS, scan the command line directly
3846
3847 else
3848 if Argument_Count = 0 then
3849 Non_VMS_Usage;
3850 return;
3851 else
3852 begin
3853 if Argument_Count > 1 and then Argument (1) = "-v" then
3854 Opt.Verbose_Mode := True;
3855 Command_Arg := 2;
3856 end if;
3857
3858 The_Command := Real_Command_Type'Value (Argument (Command_Arg));
3859
3860 if Command_List (The_Command).VMS_Only then
3861 Non_VMS_Usage;
3862 Fail ("Command """ & Command_List (The_Command).Cname.all &
3863 """ can only be used on VMS");
3864 end if;
3865 exception
3866 when Constraint_Error =>
3867
3868 -- Check if it is an alternate command
3869 declare
3870 Alternate : Alternate_Command;
3871
3872 begin
3873 Alternate := Alternate_Command'Value
3874 (Argument (Command_Arg));
3875 The_Command := Corresponding_To (Alternate);
3876
3877 exception
3878 when Constraint_Error =>
3879 Non_VMS_Usage;
3880 Fail ("Unknown command: " & Argument (Command_Arg));
3881 end;
3882 end;
3883
3884 for Arg in Command_Arg + 1 .. Argument_Count loop
3885 Last_Switches.Increment_Last;
3886 Last_Switches.Table (Last_Switches.Last) :=
3887 new String'(Argument (Arg));
3888 end loop;
3889 end if;
3890 end if;
3891
3892 declare
3893 Program : constant String :=
3894 Program_Name (Command_List (The_Command).Unixcmd.all).all;
3895
3896 Exec_Path : String_Access;
3897
3898 begin
3899 -- Locate the executable for the command
3900
3901 Exec_Path := Locate_Exec_On_Path (Program);
3902
3903 if Exec_Path = null then
3904 Put_Line (Standard_Error, "Couldn't locate " & Program);
3905 raise Error_Exit;
3906 end if;
3907
3908 -- If there are switches for the executable, put them as first switches
3909
3910 if Command_List (The_Command).Unixsws /= null then
3911 for J in Command_List (The_Command).Unixsws'Range loop
3912 First_Switches.Increment_Last;
3913 First_Switches.Table (First_Switches.Last) :=
3914 Command_List (The_Command).Unixsws (J);
3915 end loop;
3916 end if;
3917
3918 -- For BIND, FIND, LINK, LIST and XREF, look for project file related
3919 -- switches.
3920
3921 if The_Command = Bind
3922 or else The_Command = Find
3923 or else The_Command = Link
3924 or else The_Command = List
3925 or else The_Command = Xref
3926 then
3927 case The_Command is
3928 when Bind =>
3929 Tool_Package_Name := Name_Binder;
3930 when Find =>
3931 Tool_Package_Name := Name_Finder;
3932 when Link =>
3933 Tool_Package_Name := Name_Linker;
3934 when List =>
3935 Tool_Package_Name := Name_Gnatls;
3936 when Xref =>
3937 Tool_Package_Name := Name_Cross_Reference;
3938 when others =>
3939 null;
3940 end case;
3941
3942 declare
3943 Arg_Num : Positive := 1;
3944 Argv : String_Access;
3945
3946 procedure Remove_Switch (Num : Positive);
3947 -- Remove a project related switch from table Last_Switches
3948
3949 -------------------
3950 -- Remove_Switch --
3951 -------------------
3952
3953 procedure Remove_Switch (Num : Positive) is
3954 begin
3955 Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
3956 Last_Switches.Table (Num + 1 .. Last_Switches.Last);
3957 Last_Switches.Decrement_Last;
3958 end Remove_Switch;
3959
3960 -- Start of processing for ??? (need block name here)
3961
3962 begin
3963 while Arg_Num <= Last_Switches.Last loop
3964 Argv := Last_Switches.Table (Arg_Num);
3965
3966 if Argv (Argv'First) = '-' then
3967 if Argv'Length = 1 then
3968 Fail ("switch character cannot be followed by a blank");
3969 end if;
3970
3971 -- The two style project files (-p and -P) cannot be used
3972 -- together
3973
3974 if (The_Command = Find or else The_Command = Xref)
3975 and then Argv (2) = 'p'
3976 then
3977 Old_Project_File_Used := True;
3978 if Project_File /= null then
3979 Fail ("-P and -p cannot be used together");
3980 end if;
3981 end if;
3982
3983 -- -vPx Specify verbosity while parsing project files
3984
3985 if Argv'Length = 4
3986 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
3987 then
3988 case Argv (Argv'Last) is
3989 when '0' =>
3990 Current_Verbosity := Prj.Default;
3991 when '1' =>
3992 Current_Verbosity := Prj.Medium;
3993 when '2' =>
3994 Current_Verbosity := Prj.High;
3995 when others =>
3996 Fail ("Invalid switch: " & Argv.all);
3997 end case;
3998
3999 Remove_Switch (Arg_Num);
4000
4001 -- -Pproject_file Specify project file to be used
4002
4003 elsif Argv'Length >= 3
4004 and then Argv (Argv'First + 1) = 'P'
4005 then
4006
4007 -- Only one -P switch can be used
4008
4009 if Project_File /= null then
4010 Fail (Argv.all &
4011 ": second project file forbidden (first is """ &
4012 Project_File.all & """)");
4013
4014 -- The two style project files (-p and -P) cannot be
4015 -- used together.
4016
4017 elsif Old_Project_File_Used then
4018 Fail ("-p and -P cannot be used together");
4019
4020 else
4021 Project_File :=
4022 new String'(Argv (Argv'First + 2 .. Argv'Last));
4023 end if;
4024
4025 Remove_Switch (Arg_Num);
4026
4027 -- -Xexternal=value Specify an external reference to be
4028 -- used in project files
4029
4030 elsif Argv'Length >= 5
4031 and then Argv (Argv'First + 1) = 'X'
4032 then
4033 declare
4034 Equal_Pos : constant Natural :=
4035 Index ('=', Argv (Argv'First + 2 .. Argv'Last));
4036 begin
4037 if Equal_Pos >= Argv'First + 3 and then
4038 Equal_Pos /= Argv'Last then
4039 Add (External_Name =>
4040 Argv (Argv'First + 2 .. Equal_Pos - 1),
4041 Value => Argv (Equal_Pos + 1 .. Argv'Last));
4042 else
4043 Fail (Argv.all &
4044 " is not a valid external assignment.");
4045 end if;
4046 end;
4047
4048 Remove_Switch (Arg_Num);
4049
4050 else
4051 Arg_Num := Arg_Num + 1;
4052 end if;
4053
4054 else
4055 Arg_Num := Arg_Num + 1;
4056 end if;
4057 end loop;
4058 end;
4059 end if;
4060
4061 -- If there is a project file specified, parse it, get the switches
4062 -- for the tool and setup PATH environment variables.
4063
4064 if Project_File /= null then
4065 Prj.Pars.Set_Verbosity (To => Current_Verbosity);
4066
4067 Prj.Pars.Parse
4068 (Project => Project,
4069 Project_File_Name => Project_File.all);
4070
4071 if Project = Prj.No_Project then
4072 Fail ("""" & Project_File.all & """ processing failed");
4073 end if;
4074
4075 -- Check if a package with the name of the tool is in the project
4076 -- file and if there is one, get the switches, if any, and scan them.
4077
4078 declare
4079 Data : Prj.Project_Data := Prj.Projects.Table (Project);
4080 Pkg : Prj.Package_Id :=
4081 Prj.Util.Value_Of
4082 (Name => Tool_Package_Name,
4083 In_Packages => Data.Decl.Packages);
4084
4085 Element : Package_Element;
4086
4087 Default_Switches_Array : Array_Element_Id;
4088
4089 The_Switches : Prj.Variable_Value;
4090 Current : Prj.String_List_Id;
4091 The_String : String_Element;
4092
4093 begin
4094 if Pkg /= No_Package then
4095 Element := Packages.Table (Pkg);
4096
4097 -- Packages Gnatls has a single attribute Switches, that is
4098 -- not an associative array.
4099
4100 if The_Command = List then
4101 The_Switches :=
4102 Prj.Util.Value_Of
4103 (Variable_Name => Snames.Name_Switches,
4104 In_Variables => Element.Decl.Attributes);
4105
4106 -- Packages Binder (for gnatbind), Cross_Reference (for
4107 -- gnatxref), Linker (for gnatlink) and Finder
4108 -- (for gnatfind) have an attributed Default_Switches,
4109 -- an associative array, indexed by the name of the
4110 -- programming language.
4111 else
4112 Default_Switches_Array :=
4113 Prj.Util.Value_Of
4114 (Name => Name_Default_Switches,
4115 In_Arrays => Packages.Table (Pkg).Decl.Arrays);
4116 The_Switches := Prj.Util.Value_Of
4117 (Index => Name_Ada,
4118 In_Array => Default_Switches_Array);
4119
4120 end if;
4121
4122 -- If there are switches specified in the package of the
4123 -- project file corresponding to the tool, scan them.
4124
4125 case The_Switches.Kind is
4126 when Prj.Undefined =>
4127 null;
4128
4129 when Prj.Single =>
4130 if String_Length (The_Switches.Value) > 0 then
4131 String_To_Name_Buffer (The_Switches.Value);
4132 First_Switches.Increment_Last;
4133 First_Switches.Table (First_Switches.Last) :=
4134 new String'(Name_Buffer (1 .. Name_Len));
4135 end if;
4136
4137 when Prj.List =>
4138 Current := The_Switches.Values;
4139 while Current /= Prj.Nil_String loop
4140 The_String := String_Elements.Table (Current);
4141
4142 if String_Length (The_String.Value) > 0 then
4143 String_To_Name_Buffer (The_String.Value);
4144 First_Switches.Increment_Last;
4145 First_Switches.Table (First_Switches.Last) :=
4146 new String'(Name_Buffer (1 .. Name_Len));
4147 end if;
4148
4149 Current := The_String.Next;
4150 end loop;
4151 end case;
4152 end if;
4153 end;
4154
4155 -- Set up the environment variables ADA_INCLUDE_PATH and
4156 -- ADA_OBJECTS_PATH.
4157
4158 Setenv
4159 (Name => Ada_Include_Path,
4160 Value => Prj.Env.Ada_Include_Path (Project).all);
4161 Setenv
4162 (Name => Ada_Objects_Path,
4163 Value => Prj.Env.Ada_Objects_Path
4164 (Project, Including_Libraries => False).all);
4165
4166 if The_Command = Bind or else The_Command = Link then
4167 Change_Dir
4168 (Get_Name_String
4169 (Projects.Table (Project).Object_Directory));
4170 end if;
4171
4172 if The_Command = Link then
4173
4174 -- Add the default search directories, to be able to find
4175 -- libgnat in call to MLib.Utl.Lib_Directory.
4176
4177 Add_Default_Search_Dirs;
4178
4179 declare
4180 There_Are_Libraries : Boolean := False;
4181
4182 begin
4183 -- Check if there are library project files
4184
4185 if MLib.Tgt.Libraries_Are_Supported then
4186 Set_Libraries (Project, There_Are_Libraries);
4187 end if;
4188
4189 -- If there are, add the necessary additional switches
4190
4191 if There_Are_Libraries then
4192
4193 -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
4194
4195 Last_Switches.Increment_Last;
4196 Last_Switches.Table (Last_Switches.Last) :=
4197 new String'("-L" & MLib.Utl.Lib_Directory);
4198 Last_Switches.Increment_Last;
4199 Last_Switches.Table (Last_Switches.Last) :=
4200 new String'("-lgnarl");
4201 Last_Switches.Increment_Last;
4202 Last_Switches.Table (Last_Switches.Last) :=
4203 new String'("-lgnat");
4204
4205 declare
4206 Option : constant String_Access :=
4207 MLib.Tgt.Linker_Library_Path_Option
4208 (MLib.Utl.Lib_Directory);
4209
4210 begin
4211 if Option /= null then
4212 Last_Switches.Increment_Last;
4213 Last_Switches.Table (Last_Switches.Last) :=
4214 Option;
4215 end if;
4216 end;
4217 end if;
4218 end;
4219 end if;
4220 end if;
4221
4222 -- Gather all the arguments and invoke the executable
4223
4224 declare
4225 The_Args : Argument_List
4226 (1 .. First_Switches.Last + Last_Switches.Last);
4227 Arg_Num : Natural := 0;
4228 begin
4229 for J in 1 .. First_Switches.Last loop
4230 Arg_Num := Arg_Num + 1;
4231 The_Args (Arg_Num) := First_Switches.Table (J);
4232 end loop;
4233
4234 for J in 1 .. Last_Switches.Last loop
4235 Arg_Num := Arg_Num + 1;
4236 The_Args (Arg_Num) := Last_Switches.Table (J);
4237 end loop;
4238
4239 if Opt.Verbose_Mode then
4240 Output.Write_Str (Exec_Path.all);
4241
4242 for Arg in The_Args'Range loop
4243 Output.Write_Char (' ');
4244 Output.Write_Str (The_Args (Arg).all);
4245 end loop;
4246
4247 Output.Write_Eol;
4248 end if;
4249
4250 My_Exit_Status
4251 := Exit_Status (Spawn (Exec_Path.all, The_Args));
4252 raise Normal_Exit;
4253 end;
4254 end;
4255
4256 exception
4257 when Error_Exit =>
4258 Set_Exit_Status (Failure);
4259
4260 when Normal_Exit =>
4261 Set_Exit_Status (My_Exit_Status);
4262
4263 end GNATCmd;
Mirror of the offical gcc git repository hosted at gcc.gnu.org