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