?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge -r 127928:132243 from trunk
[official-gcc.git] / gcc / ada / vms_conv.adb
blobefd3ab1bd791f7fa10554b30032dbdf07719f890
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- V M S _ C O N V --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1996-2007, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Gnatvsn; use Gnatvsn;
27 with Hostparm;
28 with Opt;
29 with Osint; use Osint;
30 with Targparm; use Targparm;
31
32 with Ada.Characters.Handling; use Ada.Characters.Handling;
33 with Ada.Command_Line; use Ada.Command_Line;
34 with Ada.Text_IO; use Ada.Text_IO;
35
36 package body VMS_Conv is
37
38 -------------------------
39 -- Internal Structures --
40 -------------------------
41
42 -- The switches and commands are defined by strings in the previous
43 -- section so that they are easy to modify, but internally, they are
44 -- kept in a more conveniently accessible form described in this
45 -- section.
46
47 -- Commands, command qualifers and options have a similar common format
48 -- so that searching for matching names can be done in a common manner.
49
50 type Item_Id is (Id_Command, Id_Switch, Id_Option);
51
52 type Translation_Type is
53 (
54 T_Direct,
55 -- A qualifier with no options.
56 -- Example: GNAT MAKE /VERBOSE
57
58 T_Directories,
59 -- A qualifier followed by a list of directories
60 -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR])
61
62 T_Directory,
63 -- A qualifier followed by one directory
64 -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB]
65
66 T_File,
67 -- A qualifier followed by a filename
68 -- Example: GNAT LINK /EXECUTABLE=FOO.EXE
69
70 T_No_Space_File,
71 -- A qualifier followed by a filename
72 -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR
73
74 T_Numeric,
75 -- A qualifier followed by a numeric value.
76 -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39
77
78 T_String,
79 -- A qualifier followed by a quoted string. Only used by
80 -- /IDENTIFICATION qualifier.
81 -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version"
82
83 T_Options,
84 -- A qualifier followed by a list of options.
85 -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS)
86
87 T_Commands,
88 -- A qualifier followed by a list. Only used for
89 -- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS
90 -- (gnatmake -cargs -bargs -largs )
91 -- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ
92
93 T_Other,
94 -- A qualifier passed directly to the linker. Only used
95 -- for LINK and SHARED if no other match is found.
96 -- Example: GNAT LINK FOO.ALI /SYSSHR
97
98 T_Alphanumplus
99 -- A qualifier followed by a legal linker symbol prefix. Only used
100 -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz).
101 -- Example: GNAT BIND /BUILD_LIBRARY=foobar
102 );
103
104 type Item (Id : Item_Id);
105 type Item_Ptr is access all Item;
106
107 type Item (Id : Item_Id) is record
108 Name : String_Ptr;
109 -- Name of the command, switch (with slash) or option
110
111 Next : Item_Ptr;
112 -- Pointer to next item on list, always has the same Id value
113
114 Command : Command_Type := Undefined;
115
116 Unix_String : String_Ptr := null;
117 -- Corresponding Unix string. For a command, this is the unix command
118 -- name and possible default switches. For a switch or option it is
119 -- the unix switch string.
120
121 case Id is
122
123 when Id_Command =>
124
125 Switches : Item_Ptr;
126 -- Pointer to list of switch items for the command, linked
127 -- through the Next fields with null terminating the list.
128
129 Usage : String_Ptr;
130 -- Usage information, used only for errors and the default
131 -- list of commands output.
132
133 Params : Parameter_Ref;
134 -- Array of parameters
135
136 Defext : String (1 .. 3);
137 -- Default extension. If non-blank, then this extension is
138 -- supplied by default as the extension for any file parameter
139 -- which does not have an extension already.
140
141 when Id_Switch =>
142
143 Translation : Translation_Type;
144 -- Type of switch translation. For all cases, except Options,
145 -- this is the only field needed, since the Unix translation
146 -- is found in Unix_String.
147
148 Options : Item_Ptr;
149 -- For the Options case, this field is set to point to a list
150 -- of options item (for this case Unix_String is null in the
151 -- main switch item). The end of the list is marked by null.
152
153 when Id_Option =>
154
155 null;
156 -- No special fields needed, since Name and Unix_String are
157 -- sufficient to completely described an option.
158
159 end case;
160 end record;
161
162 subtype Command_Item is Item (Id_Command);
163 subtype Switch_Item is Item (Id_Switch);
164 subtype Option_Item is Item (Id_Option);
165
166 Keep_Temps_Option : constant Item_Ptr :=
167 new Item'
168 (Id => Id_Option,
169 Name =>
170 new String'("/KEEP_TEMPORARY_FILES"),
171 Next => null,
172 Command => Undefined,
173 Unix_String => null);
174
175 Param_Count : Natural := 0;
176 -- Number of parameter arguments so far
177
178 Arg_Num : Natural;
179 -- Argument number
180
181 Arg_File : Ada.Text_IO.File_Type;
182 -- A file where arguments are read from
183
184 Commands : Item_Ptr;
185 -- Pointer to head of list of command items, one for each command, with
186 -- the end of the list marked by a null pointer.
187
188 Last_Command : Item_Ptr;
189 -- Pointer to last item in Commands list
190
191 Command : Item_Ptr;
192 -- Pointer to command item for current command
193
194 Make_Commands_Active : Item_Ptr := null;
195 -- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate
196 -- if a COMMANDS_TRANSLATION switch has been encountered while processing
197 -- a MAKE Command.
198
199 Output_File_Expected : Boolean := False;
200 -- True for GNAT LINK after -o switch, so that the ".ali" extension is
201 -- not added to the executable file name.
202
203 package Buffer is new Table.Table
204 (Table_Component_Type => Character,
205 Table_Index_Type => Integer,
206 Table_Low_Bound => 1,
207 Table_Initial => 4096,
208 Table_Increment => 100,
209 Table_Name => "Buffer");
210 -- Table to store the command to be used
211
212 package Cargs_Buffer is new Table.Table
213 (Table_Component_Type => Character,
214 Table_Index_Type => Integer,
215 Table_Low_Bound => 1,
216 Table_Initial => 4096,
217 Table_Increment => 100,
218 Table_Name => "Cargs_Buffer");
219 -- Table to store the compiler switches for GNAT COMPILE
220
221 Cargs : Boolean := False;
222 -- When True, commands should go to Cargs_Buffer instead of Buffer table
223
224 function Init_Object_Dirs return Argument_List;
225 -- Get the list of the object directories
226
227 function Invert_Sense (S : String) return VMS_Data.String_Ptr;
228 -- Given a unix switch string S, computes the inverse (adding or
229 -- removing ! characters as required), and returns a pointer to
230 -- the allocated result on the heap.
231
232 function Is_Extensionless (F : String) return Boolean;
233 -- Returns true if the filename has no extension
234
235 function Match (S1, S2 : String) return Boolean;
236 -- Determines whether S1 and S2 match (this is a case insensitive match)
237
238 function Match_Prefix (S1, S2 : String) return Boolean;
239 -- Determines whether S1 matches a prefix of S2. This is also a case
240 -- insensitive match (for example Match ("AB","abc") is True).
241
242 function Matching_Name
243 (S : String;
244 Itm : Item_Ptr;
245 Quiet : Boolean := False) return Item_Ptr;
246 -- Determines if the item list headed by Itm and threaded through the
247 -- Next fields (with null marking the end of the list), contains an
248 -- entry that uniquely matches the given string. The match is case
249 -- insensitive and permits unique abbreviation. If the match succeeds,
250 -- then a pointer to the matching item is returned. Otherwise, an
251 -- appropriate error message is written. Note that the discriminant
252 -- of Itm is used to determine the appropriate form of this message.
253 -- Quiet is normally False as shown, if it is set to True, then no
254 -- error message is generated in a not found situation (null is still
255 -- returned to indicate the not-found situation).
256
257 function OK_Alphanumerplus (S : String) return Boolean;
258 -- Checks that S is a string of alphanumeric characters,
259 -- returning True if all alphanumeric characters,
260 -- False if empty or a non-alphanumeric character is present.
261
262 function OK_Integer (S : String) return Boolean;
263 -- Checks that S is a string of digits, returning True if all digits,
264 -- False if empty or a non-digit is present.
265
266 procedure Place (C : Character);
267 -- Place a single character in the buffer, updating Ptr
268
269 procedure Place (S : String);
270 -- Place a string character in the buffer, updating Ptr
271
272 procedure Place_Lower (S : String);
273 -- Place string in buffer, forcing letters to lower case, updating Ptr
274
275 procedure Place_Unix_Switches (S : VMS_Data.String_Ptr);
276 -- Given a unix switch string, place corresponding switches in Buffer,
277 -- updating Ptr appropriatelly. Note that in the case of use of ! the
278 -- result may be to remove a previously placed switch.
279
280 procedure Preprocess_Command_Data;
281 -- Preprocess the string form of the command and options list into the
282 -- internal form.
283
284 procedure Process_Argument (The_Command : in out Command_Type);
285 -- Process one argument from the command line, or one line from
286 -- from a command line file. For the first call, set The_Command.
287
288 procedure Process_Buffer (S : String);
289 -- Process the characters in the Buffer table or the Cargs_Buffer table
290 -- to convert these into arguments.
291
292 procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr);
293 -- Check that N is a valid command or option name, i.e. that it is of the
294 -- form of an Ada identifier with upper case letters and underscores.
295
296 procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr);
297 -- Check that S is a valid switch string as described in the syntax for
298 -- the switch table item UNIX_SWITCH or else begins with a backquote.
299
300 ----------------------
301 -- Init_Object_Dirs --
302 ----------------------
303
304 function Init_Object_Dirs return Argument_List is
305 Object_Dirs : Integer;
306 Object_Dir : Argument_List (1 .. 256);
307 Object_Dir_Name : String_Access;
308
309 begin
310 Object_Dirs := 0;
311 Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
312 Get_Next_Dir_In_Path_Init (Object_Dir_Name);
313
314 loop
315 declare
316 Dir : constant String_Access :=
317 String_Access (Get_Next_Dir_In_Path (Object_Dir_Name));
318 begin
319 exit when Dir = null;
320 Object_Dirs := Object_Dirs + 1;
321 Object_Dir (Object_Dirs) :=
322 new String'("-L" &
323 To_Canonical_Dir_Spec
324 (To_Host_Dir_Spec
325 (Normalize_Directory_Name (Dir.all).all,
326 True).all, True).all);
327 end;
328 end loop;
329
330 Object_Dirs := Object_Dirs + 1;
331 Object_Dir (Object_Dirs) := new String'("-lgnat");
332
333 if OpenVMS_On_Target then
334 Object_Dirs := Object_Dirs + 1;
335 Object_Dir (Object_Dirs) := new String'("-ldecgnat");
336 end if;
337
338 return Object_Dir (1 .. Object_Dirs);
339 end Init_Object_Dirs;
340
341 ----------------
342 -- Initialize --
343 ----------------
344
345 procedure Initialize is
346 begin
347 Command_List :=
348 (Bind =>
349 (Cname => new S'("BIND"),
350 Usage => new S'("GNAT BIND file[.ali] /qualifiers"),
351 VMS_Only => False,
352 Unixcmd => new S'("gnatbind"),
353 Unixsws => null,
354 Switches => Bind_Switches'Access,
355 Params => new Parameter_Array'(1 => Unlimited_Files),
356 Defext => "ali"),
357
358 Chop =>
359 (Cname => new S'("CHOP"),
360 Usage => new S'("GNAT CHOP file [directory] /qualifiers"),
361 VMS_Only => False,
362 Unixcmd => new S'("gnatchop"),
363 Unixsws => null,
364 Switches => Chop_Switches'Access,
365 Params => new Parameter_Array'(1 => File, 2 => Optional_File),
366 Defext => " "),
367
368 Clean =>
369 (Cname => new S'("CLEAN"),
370 Usage => new S'("GNAT CLEAN /qualifiers files"),
371 VMS_Only => False,
372 Unixcmd => new S'("gnatclean"),
373 Unixsws => null,
374 Switches => Clean_Switches'Access,
375 Params => new Parameter_Array'(1 => File),
376 Defext => " "),
377
378 Compile =>
379 (Cname => new S'("COMPILE"),
380 Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"),
381 VMS_Only => False,
382 Unixcmd => new S'("gnatmake"),
383 Unixsws => new Argument_List'(1 => new String'("-f"),
384 2 => new String'("-u"),
385 3 => new String'("-c")),
386 Switches => GCC_Switches'Access,
387 Params => new Parameter_Array'(1 => Files_Or_Wildcard),
388 Defext => " "),
389
390 Check =>
391 (Cname => new S'("CHECK"),
392 Usage => new S'("GNAT CHECK name /qualifiers"),
393 VMS_Only => False,
394 Unixcmd => new S'("gnatcheck"),
395 Unixsws => null,
396 Switches => Check_Switches'Access,
397 Params => new Parameter_Array'(1 => Unlimited_Files),
398 Defext => " "),
399
400 Elim =>
401 (Cname => new S'("ELIM"),
402 Usage => new S'("GNAT ELIM name /qualifiers"),
403 VMS_Only => False,
404 Unixcmd => new S'("gnatelim"),
405 Unixsws => null,
406 Switches => Elim_Switches'Access,
407 Params => new Parameter_Array'(1 => Other_As_Is),
408 Defext => "ali"),
409
410 Find =>
411 (Cname => new S'("FIND"),
412 Usage => new S'("GNAT FIND pattern[:sourcefile[:line"
413 & "[:column]]] filespec[,...] /qualifiers"),
414 VMS_Only => False,
415 Unixcmd => new S'("gnatfind"),
416 Unixsws => null,
417 Switches => Find_Switches'Access,
418 Params => new Parameter_Array'(1 => Other_As_Is,
419 2 => Files_Or_Wildcard),
420 Defext => "ali"),
421
422 Krunch =>
423 (Cname => new S'("KRUNCH"),
424 Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"),
425 VMS_Only => False,
426 Unixcmd => new S'("gnatkr"),
427 Unixsws => null,
428 Switches => Krunch_Switches'Access,
429 Params => new Parameter_Array'(1 => File),
430 Defext => " "),
431
432 Link =>
433 (Cname => new S'("LINK"),
434 Usage => new S'("GNAT LINK file[.ali]"
435 & " [extra obj_&_lib_&_exe_&_opt files]"
436 & " /qualifiers"),
437 VMS_Only => False,
438 Unixcmd => new S'("gnatlink"),
439 Unixsws => null,
440 Switches => Link_Switches'Access,
441 Params => new Parameter_Array'(1 => Unlimited_Files),
442 Defext => "ali"),
443
444 List =>
445 (Cname => new S'("LIST"),
446 Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"),
447 VMS_Only => False,
448 Unixcmd => new S'("gnatls"),
449 Unixsws => null,
450 Switches => List_Switches'Access,
451 Params => new Parameter_Array'(1 => Unlimited_Files),
452 Defext => "ali"),
453
454 Make =>
455 (Cname => new S'("MAKE"),
456 Usage => new S'("GNAT MAKE file(s) /qualifiers (includes "
457 & "COMPILE /qualifiers)"),
458 VMS_Only => False,
459 Unixcmd => new S'("gnatmake"),
460 Unixsws => null,
461 Switches => Make_Switches'Access,
462 Params => new Parameter_Array'(1 => Unlimited_Files),
463 Defext => " "),
464
465 Metric =>
466 (Cname => new S'("METRIC"),
467 Usage => new S'("GNAT METRIC /qualifiers source_file"),
468 VMS_Only => False,
469 Unixcmd => new S'("gnatmetric"),
470 Unixsws => null,
471 Switches => Metric_Switches'Access,
472 Params => new Parameter_Array'(1 => Unlimited_Files),
473 Defext => " "),
474
475 Name =>
476 (Cname => new S'("NAME"),
477 Usage => new S'("GNAT NAME /qualifiers naming-pattern "
478 & "[naming-patterns]"),
479 VMS_Only => False,
480 Unixcmd => new S'("gnatname"),
481 Unixsws => null,
482 Switches => Name_Switches'Access,
483 Params => new Parameter_Array'(1 => Unlimited_As_Is),
484 Defext => " "),
485
486 Preprocess =>
487 (Cname => new S'("PREPROCESS"),
488 Usage =>
489 new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"),
490 VMS_Only => False,
491 Unixcmd => new S'("gnatprep"),
492 Unixsws => null,
493 Switches => Prep_Switches'Access,
494 Params => new Parameter_Array'(1 .. 3 => File),
495 Defext => " "),
496
497 Pretty =>
498 (Cname => new S'("PRETTY"),
499 Usage => new S'("GNAT PRETTY /qualifiers source_file"),
500 VMS_Only => False,
501 Unixcmd => new S'("gnatpp"),
502 Unixsws => null,
503 Switches => Pretty_Switches'Access,
504 Params => new Parameter_Array'(1 => Unlimited_Files),
505 Defext => " "),
506
507 Shared =>
508 (Cname => new S'("SHARED"),
509 Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt"
510 & "files] /qualifiers"),
511 VMS_Only => True,
512 Unixcmd => new S'("gcc"),
513 Unixsws =>
514 new Argument_List'(new String'("-shared") & Init_Object_Dirs),
515 Switches => Shared_Switches'Access,
516 Params => new Parameter_Array'(1 => Unlimited_Files),
517 Defext => " "),
518
519 Stack =>
520 (Cname => new S'("STACK"),
521 Usage => new S'("GNAT STACK /qualifiers ci_files"),
522 VMS_Only => False,
523 Unixcmd => new S'("gnatstack"),
524 Unixsws => null,
525 Switches => Stack_Switches'Access,
526 Params => new Parameter_Array'(1 => Unlimited_Files),
527 Defext => "ci" & ASCII.NUL),
528
529 Stub =>
530 (Cname => new S'("STUB"),
531 Usage => new S'("GNAT STUB file [directory]/qualifiers"),
532 VMS_Only => False,
533 Unixcmd => new S'("gnatstub"),
534 Unixsws => null,
535 Switches => Stub_Switches'Access,
536 Params => new Parameter_Array'(1 => File, 2 => Optional_File),
537 Defext => " "),
538
539 Xref =>
540 (Cname => new S'("XREF"),
541 Usage => new S'("GNAT XREF filespec[,...] /qualifiers"),
542 VMS_Only => False,
543 Unixcmd => new S'("gnatxref"),
544 Unixsws => null,
545 Switches => Xref_Switches'Access,
546 Params => new Parameter_Array'(1 => Files_Or_Wildcard),
547 Defext => "ali")
548 );
549 end Initialize;
550
551 ------------------
552 -- Invert_Sense --
553 ------------------
554
555 function Invert_Sense (S : String) return VMS_Data.String_Ptr is
556 Sinv : String (1 .. S'Length * 2);
557 -- Result (for sure long enough)
558
559 Sinvp : Natural := 0;
560 -- Pointer to output string
561
562 begin
563 for Sp in S'Range loop
564 if Sp = S'First or else S (Sp - 1) = ',' then
565 if S (Sp) = '!' then
566 null;
567 else
568 Sinv (Sinvp + 1) := '!';
569 Sinv (Sinvp + 2) := S (Sp);
570 Sinvp := Sinvp + 2;
571 end if;
572
573 else
574 Sinv (Sinvp + 1) := S (Sp);
575 Sinvp := Sinvp + 1;
576 end if;
577 end loop;
578
579 return new String'(Sinv (1 .. Sinvp));
580 end Invert_Sense;
581
582 ----------------------
583 -- Is_Extensionless --
584 ----------------------
585
586 function Is_Extensionless (F : String) return Boolean is
587 begin
588 for J in reverse F'Range loop
589 if F (J) = '.' then
590 return False;
591 elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then
592 return True;
593 end if;
594 end loop;
595
596 return True;
597 end Is_Extensionless;
598
599 -----------
600 -- Match --
601 -----------
602
603 function Match (S1, S2 : String) return Boolean is
604 Dif : constant Integer := S2'First - S1'First;
605
606 begin
607
608 if S1'Length /= S2'Length then
609 return False;
610
611 else
612 for J in S1'Range loop
613 if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then
614 return False;
615 end if;
616 end loop;
617
618 return True;
619 end if;
620 end Match;
621
622 ------------------
623 -- Match_Prefix --
624 ------------------
625
626 function Match_Prefix (S1, S2 : String) return Boolean is
627 begin
628 if S1'Length > S2'Length then
629 return False;
630 else
631 return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1));
632 end if;
633 end Match_Prefix;
634
635 -------------------
636 -- Matching_Name --
637 -------------------
638
639 function Matching_Name
640 (S : String;
641 Itm : Item_Ptr;
642 Quiet : Boolean := False) return Item_Ptr
643 is
644 P1, P2 : Item_Ptr;
645
646 procedure Err;
647 -- Little procedure to output command/qualifier/option as appropriate
648 -- and bump error count.
649
650 ---------
651 -- Err --
652 ---------
653
654 procedure Err is
655 begin
656 if Quiet then
657 return;
658 end if;
659
660 Errors := Errors + 1;
661
662 if Itm /= null then
663 case Itm.Id is
664 when Id_Command =>
665 Put (Standard_Error, "command");
666
667 when Id_Switch =>
668 if Hostparm.OpenVMS then
669 Put (Standard_Error, "qualifier");
670 else
671 Put (Standard_Error, "switch");
672 end if;
673
674 when Id_Option =>
675 Put (Standard_Error, "option");
676
677 end case;
678 else
679 Put (Standard_Error, "input");
680
681 end if;
682
683 Put (Standard_Error, ": ");
684 Put (Standard_Error, S);
685 end Err;
686
687 -- Start of processing for Matching_Name
688
689 begin
690 -- If exact match, that's the one we want
691
692 P1 := Itm;
693 while P1 /= null loop
694 if Match (S, P1.Name.all) then
695 return P1;
696 else
697 P1 := P1.Next;
698 end if;
699 end loop;
700
701 -- Now check for prefix matches
702
703 P1 := Itm;
704 while P1 /= null loop
705 if P1.Name.all = "/<other>" then
706 return P1;
707
708 elsif not Match_Prefix (S, P1.Name.all) then
709 P1 := P1.Next;
710
711 else
712 -- Here we have found one matching prefix, so see if there is
713 -- another one (which is an ambiguity)
714
715 P2 := P1.Next;
716 while P2 /= null loop
717 if Match_Prefix (S, P2.Name.all) then
718 if not Quiet then
719 Put (Standard_Error, "ambiguous ");
720 Err;
721 Put (Standard_Error, " (matches ");
722 Put (Standard_Error, P1.Name.all);
723
724 while P2 /= null loop
725 if Match_Prefix (S, P2.Name.all) then
726 Put (Standard_Error, ',');
727 Put (Standard_Error, P2.Name.all);
728 end if;
729
730 P2 := P2.Next;
731 end loop;
732
733 Put_Line (Standard_Error, ")");
734 end if;
735
736 return null;
737 end if;
738
739 P2 := P2.Next;
740 end loop;
741
742 -- If we fall through that loop, then there was only one match
743
744 return P1;
745 end if;
746 end loop;
747
748 -- If we fall through outer loop, there was no match
749
750 if not Quiet then
751 Put (Standard_Error, "unrecognized ");
752 Err;
753 New_Line (Standard_Error);
754 end if;
755
756 return null;
757 end Matching_Name;
758
759 -----------------------
760 -- OK_Alphanumerplus --
761 -----------------------
762
763 function OK_Alphanumerplus (S : String) return Boolean is
764 begin
765 if S'Length = 0 then
766 return False;
767
768 else
769 for J in S'Range loop
770 if not (Is_Alphanumeric (S (J)) or else
771 S (J) = '_' or else S (J) = '$')
772 then
773 return False;
774 end if;
775 end loop;
776
777 return True;
778 end if;
779 end OK_Alphanumerplus;
780
781 ----------------
782 -- OK_Integer --
783 ----------------
784
785 function OK_Integer (S : String) return Boolean is
786 begin
787 if S'Length = 0 then
788 return False;
789
790 else
791 for J in S'Range loop
792 if not Is_Digit (S (J)) then
793 return False;
794 end if;
795 end loop;
796
797 return True;
798 end if;
799 end OK_Integer;
800
801 --------------------
802 -- Output_Version --
803 --------------------
804
805 procedure Output_Version is
806 begin
807 Put ("GNAT ");
808 Put_Line (Gnatvsn.Gnat_Version_String);
809 Put_Line ("Copyright 1996-" &
810 Current_Year &
811 ", Free Software Foundation, Inc.");
812 end Output_Version;
813
814 -----------
815 -- Place --
816 -----------
817
818 procedure Place (C : Character) is
819 begin
820 if Cargs then
821 Cargs_Buffer.Append (C);
822 else
823 Buffer.Append (C);
824 end if;
825 end Place;
826
827 procedure Place (S : String) is
828 begin
829 for J in S'Range loop
830 Place (S (J));
831 end loop;
832 end Place;
833
834 -----------------
835 -- Place_Lower --
836 -----------------
837
838 procedure Place_Lower (S : String) is
839 begin
840 for J in S'Range loop
841 Place (To_Lower (S (J)));
842 end loop;
843 end Place_Lower;
844
845 -------------------------
846 -- Place_Unix_Switches --
847 -------------------------
848
849 procedure Place_Unix_Switches (S : VMS_Data.String_Ptr) is
850 P1, P2, P3 : Natural;
851 Remove : Boolean;
852 Slen, Sln2 : Natural;
853 Wild_Card : Boolean := False;
854
855 begin
856 P1 := S'First;
857 while P1 <= S'Last loop
858 if S (P1) = '!' then
859 P1 := P1 + 1;
860 Remove := True;
861 else
862 Remove := False;
863 end if;
864
865 P2 := P1;
866 pragma Assert (S (P1) = '-' or else S (P1) = '`');
867
868 while P2 < S'Last and then S (P2 + 1) /= ',' loop
869 P2 := P2 + 1;
870 end loop;
871
872 -- Switch is now in S (P1 .. P2)
873
874 Slen := P2 - P1 + 1;
875
876 if Remove then
877 Wild_Card := S (P2) = '*';
878
879 if Wild_Card then
880 Slen := Slen - 1;
881 P2 := P2 - 1;
882 end if;
883
884 P3 := 1;
885 while P3 <= Buffer.Last - Slen loop
886 if Buffer.Table (P3) = ' '
887 and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) =
888 S (P1 .. P2)
889 and then (Wild_Card
890 or else
891 P3 + Slen = Buffer.Last
892 or else
893 Buffer.Table (P3 + Slen + 1) = ' ')
894 then
895 Sln2 := Slen;
896
897 if Wild_Card then
898 while P3 + Sln2 /= Buffer.Last
899 and then Buffer.Table (P3 + Sln2 + 1) /= ' '
900 loop
901 Sln2 := Sln2 + 1;
902 end loop;
903 end if;
904
905 Buffer.Table (P3 .. Buffer.Last - Sln2 - 1) :=
906 Buffer.Table (P3 + Sln2 + 1 .. Buffer.Last);
907 Buffer.Set_Last (Buffer.Last - Sln2 - 1);
908
909 else
910 P3 := P3 + 1;
911 end if;
912 end loop;
913
914 if Wild_Card then
915 P2 := P2 + 1;
916 end if;
917
918 else
919 pragma Assert (S (P2) /= '*');
920 Place (' ');
921
922 if S (P1) = '`' then
923 P1 := P1 + 1;
924 end if;
925
926 Place (S (P1 .. P2));
927 end if;
928
929 P1 := P2 + 2;
930 end loop;
931 end Place_Unix_Switches;
932
933 -----------------------------
934 -- Preprocess_Command_Data --
935 -----------------------------
936
937 procedure Preprocess_Command_Data is
938 begin
939 for C in Real_Command_Type loop
940 declare
941 Command : constant Item_Ptr := new Command_Item;
942
943 Last_Switch : Item_Ptr;
944 -- Last switch in list
945
946 begin
947 -- Link new command item into list of commands
948
949 if Last_Command = null then
950 Commands := Command;
951 else
952 Last_Command.Next := Command;
953 end if;
954
955 Last_Command := Command;
956
957 -- Fill in fields of new command item
958
959 Command.Name := Command_List (C).Cname;
960 Command.Usage := Command_List (C).Usage;
961 Command.Command := C;
962
963 if Command_List (C).Unixsws = null then
964 Command.Unix_String := Command_List (C).Unixcmd;
965 else
966 declare
967 Cmd : String (1 .. 5_000);
968 Last : Natural := 0;
969 Sws : constant Argument_List_Access :=
970 Command_List (C).Unixsws;
971
972 begin
973 Cmd (1 .. Command_List (C).Unixcmd'Length) :=
974 Command_List (C).Unixcmd.all;
975 Last := Command_List (C).Unixcmd'Length;
976
977 for J in Sws'Range loop
978 Last := Last + 1;
979 Cmd (Last) := ' ';
980 Cmd (Last + 1 .. Last + Sws (J)'Length) :=
981 Sws (J).all;
982 Last := Last + Sws (J)'Length;
983 end loop;
984
985 Command.Unix_String := new String'(Cmd (1 .. Last));
986 end;
987 end if;
988
989 Command.Params := Command_List (C).Params;
990 Command.Defext := Command_List (C).Defext;
991
992 Validate_Command_Or_Option (Command.Name);
993
994 -- Process the switch list
995
996 for S in Command_List (C).Switches'Range loop
997 declare
998 SS : constant VMS_Data.String_Ptr :=
999 Command_List (C).Switches (S);
1000 P : Natural := SS'First;
1001 Sw : Item_Ptr := new Switch_Item;
1002
1003 Last_Opt : Item_Ptr;
1004 -- Pointer to last option
1005
1006 begin
1007 -- Link new switch item into list of switches
1008
1009 if Last_Switch = null then
1010 Command.Switches := Sw;
1011 else
1012 Last_Switch.Next := Sw;
1013 end if;
1014
1015 Last_Switch := Sw;
1016
1017 -- Process switch string, first get name
1018
1019 while SS (P) /= ' ' and SS (P) /= '=' loop
1020 P := P + 1;
1021 end loop;
1022
1023 Sw.Name := new String'(SS (SS'First .. P - 1));
1024
1025 -- Direct translation case
1026
1027 if SS (P) = ' ' then
1028 Sw.Translation := T_Direct;
1029 Sw.Unix_String := new String'(SS (P + 1 .. SS'Last));
1030 Validate_Unix_Switch (Sw.Unix_String);
1031
1032 if SS (P - 1) = '>' then
1033 Sw.Translation := T_Other;
1034
1035 elsif SS (P + 1) = '`' then
1036 null;
1037
1038 -- Create the inverted case (/NO ..)
1039
1040 elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then
1041 Sw := new Switch_Item;
1042 Last_Switch.Next := Sw;
1043 Last_Switch := Sw;
1044
1045 Sw.Name :=
1046 new String'("/NO" & SS (SS'First + 1 .. P - 1));
1047 Sw.Translation := T_Direct;
1048 Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last));
1049 Validate_Unix_Switch (Sw.Unix_String);
1050 end if;
1051
1052 -- Directories translation case
1053
1054 elsif SS (P + 1) = '*' then
1055 pragma Assert (SS (SS'Last) = '*');
1056 Sw.Translation := T_Directories;
1057 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1058 Validate_Unix_Switch (Sw.Unix_String);
1059
1060 -- Directory translation case
1061
1062 elsif SS (P + 1) = '%' then
1063 pragma Assert (SS (SS'Last) = '%');
1064 Sw.Translation := T_Directory;
1065 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1066 Validate_Unix_Switch (Sw.Unix_String);
1067
1068 -- File translation case
1069
1070 elsif SS (P + 1) = '@' then
1071 pragma Assert (SS (SS'Last) = '@');
1072 Sw.Translation := T_File;
1073 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1074 Validate_Unix_Switch (Sw.Unix_String);
1075
1076 -- No space file translation case
1077
1078 elsif SS (P + 1) = '<' then
1079 pragma Assert (SS (SS'Last) = '>');
1080 Sw.Translation := T_No_Space_File;
1081 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1082 Validate_Unix_Switch (Sw.Unix_String);
1083
1084 -- Numeric translation case
1085
1086 elsif SS (P + 1) = '#' then
1087 pragma Assert (SS (SS'Last) = '#');
1088 Sw.Translation := T_Numeric;
1089 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1090 Validate_Unix_Switch (Sw.Unix_String);
1091
1092 -- Alphanumerplus translation case
1093
1094 elsif SS (P + 1) = '|' then
1095 pragma Assert (SS (SS'Last) = '|');
1096 Sw.Translation := T_Alphanumplus;
1097 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1098 Validate_Unix_Switch (Sw.Unix_String);
1099
1100 -- String translation case
1101
1102 elsif SS (P + 1) = '"' then
1103 pragma Assert (SS (SS'Last) = '"');
1104 Sw.Translation := T_String;
1105 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1106 Validate_Unix_Switch (Sw.Unix_String);
1107
1108 -- Commands translation case
1109
1110 elsif SS (P + 1) = '?' then
1111 Sw.Translation := T_Commands;
1112 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last));
1113
1114 -- Options translation case
1115
1116 else
1117 Sw.Translation := T_Options;
1118 Sw.Unix_String := new String'("");
1119
1120 P := P + 1; -- bump past =
1121 while P <= SS'Last loop
1122 declare
1123 Opt : constant Item_Ptr := new Option_Item;
1124 Q : Natural;
1125
1126 begin
1127 -- Link new option item into options list
1128
1129 if Last_Opt = null then
1130 Sw.Options := Opt;
1131 else
1132 Last_Opt.Next := Opt;
1133 end if;
1134
1135 Last_Opt := Opt;
1136
1137 -- Fill in fields of new option item
1138
1139 Q := P;
1140 while SS (Q) /= ' ' loop
1141 Q := Q + 1;
1142 end loop;
1143
1144 Opt.Name := new String'(SS (P .. Q - 1));
1145 Validate_Command_Or_Option (Opt.Name);
1146
1147 P := Q + 1;
1148 Q := P;
1149
1150 while Q <= SS'Last and then SS (Q) /= ' ' loop
1151 Q := Q + 1;
1152 end loop;
1153
1154 Opt.Unix_String := new String'(SS (P .. Q - 1));
1155 Validate_Unix_Switch (Opt.Unix_String);
1156 P := Q + 1;
1157 end;
1158 end loop;
1159 end if;
1160 end;
1161 end loop;
1162 end;
1163 end loop;
1164 end Preprocess_Command_Data;
1165
1166 ----------------------
1167 -- Process_Argument --
1168 ----------------------
1169
1170 procedure Process_Argument (The_Command : in out Command_Type) is
1171 Argv : String_Access;
1172 Arg_Idx : Integer;
1173
1174 function Get_Arg_End
1175 (Argv : String;
1176 Arg_Idx : Integer) return Integer;
1177 -- Begins looking at Arg_Idx + 1 and returns the index of the
1178 -- last character before a slash or else the index of the last
1179 -- character in the string Argv.
1180
1181 -----------------
1182 -- Get_Arg_End --
1183 -----------------
1184
1185 function Get_Arg_End
1186 (Argv : String;
1187 Arg_Idx : Integer) return Integer
1188 is
1189 begin
1190 for J in Arg_Idx + 1 .. Argv'Last loop
1191 if Argv (J) = '/' then
1192 return J - 1;
1193 end if;
1194 end loop;
1195
1196 return Argv'Last;
1197 end Get_Arg_End;
1198
1199 -- Start of processing for Process_Argument
1200
1201 begin
1202 Cargs := False;
1203
1204 -- If an argument file is open, read the next non empty line
1205
1206 if Is_Open (Arg_File) then
1207 declare
1208 Line : String (1 .. 256);
1209 Last : Natural;
1210 begin
1211 loop
1212 Get_Line (Arg_File, Line, Last);
1213 exit when Last /= 0 or else End_Of_File (Arg_File);
1214 end loop;
1215
1216 -- If the end of the argument file has been reached, close it
1217
1218 if End_Of_File (Arg_File) then
1219 Close (Arg_File);
1220
1221 -- If the last line was empty, return after increasing Arg_Num
1222 -- to go to the next argument on the comment line.
1223
1224 if Last = 0 then
1225 Arg_Num := Arg_Num + 1;
1226 return;
1227 end if;
1228 end if;
1229
1230 Argv := new String'(Line (1 .. Last));
1231 Arg_Idx := 1;
1232
1233 if Argv (1) = '@' then
1234 Put_Line (Standard_Error, "argument file cannot contain @cmd");
1235 raise Error_Exit;
1236 end if;
1237 end;
1238
1239 else
1240 -- No argument file is open, get the argument on the command line
1241
1242 Argv := new String'(Argument (Arg_Num));
1243 Arg_Idx := Argv'First;
1244
1245 -- Check if this is the specification of an argument file
1246
1247 if Argv (Arg_Idx) = '@' then
1248 -- The first argument on the command line cannot be an argument
1249 -- file.
1250
1251 if Arg_Num = 1 then
1252 Put_Line
1253 (Standard_Error,
1254 "Cannot specify argument line before command");
1255 raise Error_Exit;
1256 end if;
1257
1258 -- Open the file, after conversion of the name to canonical form.
1259 -- Fail if file is not found.
1260
1261 declare
1262 Canonical_File_Name : String_Access :=
1263 To_Canonical_File_Spec (Argv (Arg_Idx + 1 .. Argv'Last));
1264 begin
1265 Open (Arg_File, In_File, Canonical_File_Name.all);
1266 Free (Canonical_File_Name);
1267 return;
1268
1269 exception
1270 when others =>
1271 Put (Standard_Error, "Cannot open argument file """);
1272 Put (Standard_Error, Argv (Arg_Idx + 1 .. Argv'Last));
1273 Put_Line (Standard_Error, """");
1274 raise Error_Exit;
1275 end;
1276 end if;
1277 end if;
1278
1279 <<Tryagain_After_Coalesce>>
1280 loop
1281 declare
1282 Next_Arg_Idx : Integer;
1283 Arg : String_Access;
1284
1285 begin
1286 Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
1287 Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
1288
1289 -- The first one must be a command name
1290
1291 if Arg_Num = 1 and then Arg_Idx = Argv'First then
1292 Command := Matching_Name (Arg.all, Commands);
1293
1294 if Command = null then
1295 raise Error_Exit;
1296 end if;
1297
1298 The_Command := Command.Command;
1299 Output_File_Expected := False;
1300
1301 -- Give usage information if only command given
1302
1303 if Argument_Count = 1
1304 and then Next_Arg_Idx = Argv'Last
1305 then
1306 Output_Version;
1307 New_Line;
1308 Put_Line
1309 ("List of available qualifiers and options");
1310 New_Line;
1311
1312 Put (Command.Usage.all);
1313 Set_Col (53);
1314 Put_Line (Command.Unix_String.all);
1315
1316 declare
1317 Sw : Item_Ptr := Command.Switches;
1318
1319 begin
1320 while Sw /= null loop
1321 Put (" ");
1322 Put (Sw.Name.all);
1323
1324 case Sw.Translation is
1325
1326 when T_Other =>
1327 Set_Col (53);
1328 Put_Line (Sw.Unix_String.all &
1329 "/<other>");
1330
1331 when T_Direct =>
1332 Set_Col (53);
1333 Put_Line (Sw.Unix_String.all);
1334
1335 when T_Directories =>
1336 Put ("=(direc,direc,..direc)");
1337 Set_Col (53);
1338 Put (Sw.Unix_String.all);
1339 Put (" direc ");
1340 Put (Sw.Unix_String.all);
1341 Put_Line (" direc ...");
1342
1343 when T_Directory =>
1344 Put ("=directory");
1345 Set_Col (53);
1346 Put (Sw.Unix_String.all);
1347
1348 if Sw.Unix_String (Sw.Unix_String'Last)
1349 /= '='
1350 then
1351 Put (' ');
1352 end if;
1353
1354 Put_Line ("directory ");
1355
1356 when T_File | T_No_Space_File =>
1357 Put ("=file");
1358 Set_Col (53);
1359 Put (Sw.Unix_String.all);
1360
1361 if Sw.Translation = T_File
1362 and then Sw.Unix_String
1363 (Sw.Unix_String'Last) /= '='
1364 then
1365 Put (' ');
1366 end if;
1367
1368 Put_Line ("file ");
1369
1370 when T_Numeric =>
1371 Put ("=nnn");
1372 Set_Col (53);
1373
1374 if Sw.Unix_String
1375 (Sw.Unix_String'First) = '`'
1376 then
1377 Put (Sw.Unix_String
1378 (Sw.Unix_String'First + 1
1379 .. Sw.Unix_String'Last));
1380 else
1381 Put (Sw.Unix_String.all);
1382 end if;
1383
1384 Put_Line ("nnn");
1385
1386 when T_Alphanumplus =>
1387 Put ("=xyz");
1388 Set_Col (53);
1389
1390 if Sw.Unix_String
1391 (Sw.Unix_String'First) = '`'
1392 then
1393 Put (Sw.Unix_String
1394 (Sw.Unix_String'First + 1
1395 .. Sw.Unix_String'Last));
1396 else
1397 Put (Sw.Unix_String.all);
1398 end if;
1399
1400 Put_Line ("xyz");
1401
1402 when T_String =>
1403 Put ("=");
1404 Put ('"');
1405 Put ("<string>");
1406 Put ('"');
1407 Set_Col (53);
1408
1409 Put (Sw.Unix_String.all);
1410
1411 if Sw.Unix_String
1412 (Sw.Unix_String'Last) /= '='
1413 then
1414 Put (' ');
1415 end if;
1416
1417 Put ("<string>");
1418 New_Line;
1419
1420 when T_Commands =>
1421 Put (" (switches for ");
1422 Put (Sw.Unix_String
1423 (Sw.Unix_String'First + 7
1424 .. Sw.Unix_String'Last));
1425 Put (')');
1426 Set_Col (53);
1427 Put (Sw.Unix_String
1428 (Sw.Unix_String'First
1429 .. Sw.Unix_String'First + 5));
1430 Put_Line (" switches");
1431
1432 when T_Options =>
1433 declare
1434 Opt : Item_Ptr := Sw.Options;
1435
1436 begin
1437 Put_Line ("=(option,option..)");
1438
1439 while Opt /= null loop
1440 Put (" ");
1441 Put (Opt.Name.all);
1442
1443 if Opt = Sw.Options then
1444 Put (" (D)");
1445 end if;
1446
1447 Set_Col (53);
1448 Put_Line (Opt.Unix_String.all);
1449 Opt := Opt.Next;
1450 end loop;
1451 end;
1452
1453 end case;
1454
1455 Sw := Sw.Next;
1456 end loop;
1457 end;
1458
1459 raise Normal_Exit;
1460 end if;
1461
1462 -- Special handling for internal debugging switch /?
1463
1464 elsif Arg.all = "/?" then
1465 Display_Command := True;
1466 Output_File_Expected := False;
1467
1468 -- Special handling of internal option /KEEP_TEMPORARY_FILES
1469
1470 elsif Arg'Length >= 7
1471 and then Matching_Name
1472 (Arg.all, Keep_Temps_Option, True) /= null
1473 then
1474 Opt.Keep_Temporary_Files := True;
1475
1476 -- Copy -switch unchanged, as well as +rule
1477
1478 elsif Arg (Arg'First) = '-' or else Arg (Arg'First) = '+' then
1479 Place (' ');
1480 Place (Arg.all);
1481
1482 -- Set Output_File_Expected for the next argument
1483
1484 Output_File_Expected :=
1485 Arg.all = "-o" and then The_Command = Link;
1486
1487 -- Copy quoted switch with quotes stripped
1488
1489 elsif Arg (Arg'First) = '"' then
1490 if Arg (Arg'Last) /= '"' then
1491 Put (Standard_Error, "misquoted argument: ");
1492 Put_Line (Standard_Error, Arg.all);
1493 Errors := Errors + 1;
1494
1495 else
1496 Place (' ');
1497 Place (Arg (Arg'First + 1 .. Arg'Last - 1));
1498 end if;
1499
1500 Output_File_Expected := False;
1501
1502 -- Parameter Argument
1503
1504 elsif Arg (Arg'First) /= '/'
1505 and then Make_Commands_Active = null
1506 then
1507 Param_Count := Param_Count + 1;
1508
1509 if Param_Count <= Command.Params'Length then
1510
1511 case Command.Params (Param_Count) is
1512
1513 when File | Optional_File =>
1514 declare
1515 Normal_File : constant String_Access :=
1516 To_Canonical_File_Spec
1517 (Arg.all);
1518
1519 begin
1520 Place (' ');
1521 Place_Lower (Normal_File.all);
1522
1523 if Is_Extensionless (Normal_File.all)
1524 and then Command.Defext /= " "
1525 then
1526 Place ('.');
1527 Place (Command.Defext);
1528 end if;
1529 end;
1530
1531 when Unlimited_Files =>
1532 declare
1533 Normal_File : constant String_Access :=
1534 To_Canonical_File_Spec
1535 (Arg.all);
1536
1537 File_Is_Wild : Boolean := False;
1538 File_List : String_Access_List_Access;
1539
1540 begin
1541 for J in Arg'Range loop
1542 if Arg (J) = '*'
1543 or else Arg (J) = '%'
1544 then
1545 File_Is_Wild := True;
1546 end if;
1547 end loop;
1548
1549 if File_Is_Wild then
1550 File_List := To_Canonical_File_List
1551 (Arg.all, False);
1552
1553 for J in File_List.all'Range loop
1554 Place (' ');
1555 Place_Lower (File_List.all (J).all);
1556 end loop;
1557
1558 else
1559 Place (' ');
1560 Place_Lower (Normal_File.all);
1561
1562 -- Add extension if not present, except after
1563 -- switch -o.
1564
1565 if Is_Extensionless (Normal_File.all)
1566 and then Command.Defext /= " "
1567 and then not Output_File_Expected
1568 then
1569 Place ('.');
1570 Place (Command.Defext);
1571 end if;
1572 end if;
1573
1574 Param_Count := Param_Count - 1;
1575 end;
1576
1577 when Other_As_Is =>
1578 Place (' ');
1579 Place (Arg.all);
1580
1581 when Unlimited_As_Is =>
1582 Place (' ');
1583 Place (Arg.all);
1584 Param_Count := Param_Count - 1;
1585
1586 when Files_Or_Wildcard =>
1587
1588 -- Remove spaces from a comma separated list
1589 -- of file names and adjust control variables
1590 -- accordingly.
1591
1592 while Arg_Num < Argument_Count and then
1593 (Argv (Argv'Last) = ',' xor
1594 Argument (Arg_Num + 1)
1595 (Argument (Arg_Num + 1)'First) = ',')
1596 loop
1597 Argv := new String'
1598 (Argv.all & Argument (Arg_Num + 1));
1599 Arg_Num := Arg_Num + 1;
1600 Arg_Idx := Argv'First;
1601 Next_Arg_Idx :=
1602 Get_Arg_End (Argv.all, Arg_Idx);
1603 Arg := new String'
1604 (Argv (Arg_Idx .. Next_Arg_Idx));
1605 end loop;
1606
1607 -- Parse the comma separated list of VMS
1608 -- filenames and place them on the command
1609 -- line as space separated Unix style
1610 -- filenames. Lower case and add default
1611 -- extension as appropriate.
1612
1613 declare
1614 Arg1_Idx : Integer := Arg'First;
1615
1616 function Get_Arg1_End
1617 (Arg : String;
1618 Arg_Idx : Integer) return Integer;
1619 -- Begins looking at Arg_Idx + 1 and
1620 -- returns the index of the last character
1621 -- before a comma or else the index of the
1622 -- last character in the string Arg.
1623
1624 ------------------
1625 -- Get_Arg1_End --
1626 ------------------
1627
1628 function Get_Arg1_End
1629 (Arg : String;
1630 Arg_Idx : Integer) return Integer
1631 is
1632 begin
1633 for J in Arg_Idx + 1 .. Arg'Last loop
1634 if Arg (J) = ',' then
1635 return J - 1;
1636 end if;
1637 end loop;
1638
1639 return Arg'Last;
1640 end Get_Arg1_End;
1641
1642 begin
1643 loop
1644 declare
1645 Next_Arg1_Idx :
1646 constant Integer :=
1647 Get_Arg1_End (Arg.all, Arg1_Idx);
1648
1649 Arg1 :
1650 constant String :=
1651 Arg (Arg1_Idx .. Next_Arg1_Idx);
1652
1653 Normal_File :
1654 constant String_Access :=
1655 To_Canonical_File_Spec (Arg1);
1656
1657 begin
1658 Place (' ');
1659 Place_Lower (Normal_File.all);
1660
1661 if Is_Extensionless (Normal_File.all)
1662 and then Command.Defext /= " "
1663 then
1664 Place ('.');
1665 Place (Command.Defext);
1666 end if;
1667
1668 Arg1_Idx := Next_Arg1_Idx + 1;
1669 end;
1670
1671 exit when Arg1_Idx > Arg'Last;
1672
1673 -- Don't allow two or more commas in
1674 -- a row
1675
1676 if Arg (Arg1_Idx) = ',' then
1677 Arg1_Idx := Arg1_Idx + 1;
1678 if Arg1_Idx > Arg'Last or else
1679 Arg (Arg1_Idx) = ','
1680 then
1681 Put_Line
1682 (Standard_Error,
1683 "Malformed Parameter: " &
1684 Arg.all);
1685 Put (Standard_Error, "usage: ");
1686 Put_Line (Standard_Error,
1687 Command.Usage.all);
1688 raise Error_Exit;
1689 end if;
1690 end if;
1691
1692 end loop;
1693 end;
1694 end case;
1695 end if;
1696
1697 -- Reset Output_File_Expected, in case it was True
1698
1699 Output_File_Expected := False;
1700
1701 -- Qualifier argument
1702
1703 else
1704 Output_File_Expected := False;
1705
1706 Cargs := Command.Name.all = "COMPILE";
1707
1708 -- This code is too heavily nested, should be
1709 -- separated out as separate subprogram ???
1710
1711 declare
1712 Sw : Item_Ptr;
1713 SwP : Natural;
1714 P2 : Natural;
1715 Endp : Natural := 0; -- avoid warning!
1716 Opt : Item_Ptr;
1717
1718 begin
1719 SwP := Arg'First;
1720 while SwP < Arg'Last
1721 and then Arg (SwP + 1) /= '='
1722 loop
1723 SwP := SwP + 1;
1724 end loop;
1725
1726 -- At this point, the switch name is in
1727 -- Arg (Arg'First..SwP) and if that is not the
1728 -- whole switch, then there is an equal sign at
1729 -- Arg (SwP + 1) and the rest of Arg is what comes
1730 -- after the equal sign.
1731
1732 -- If make commands are active, see if we have
1733 -- another COMMANDS_TRANSLATION switch belonging
1734 -- to gnatmake.
1735
1736 if Make_Commands_Active /= null then
1737 Sw :=
1738 Matching_Name
1739 (Arg (Arg'First .. SwP),
1740 Command.Switches,
1741 Quiet => True);
1742
1743 if Sw /= null
1744 and then Sw.Translation = T_Commands
1745 then
1746 null;
1747
1748 else
1749 Sw :=
1750 Matching_Name
1751 (Arg (Arg'First .. SwP),
1752 Make_Commands_Active.Switches,
1753 Quiet => False);
1754 end if;
1755
1756 -- For case of GNAT MAKE or CHOP, if we cannot
1757 -- find the switch, then see if it is a
1758 -- recognized compiler switch instead, and if
1759 -- so process the compiler switch.
1760
1761 elsif Command.Name.all = "MAKE"
1762 or else Command.Name.all = "CHOP" then
1763 Sw :=
1764 Matching_Name
1765 (Arg (Arg'First .. SwP),
1766 Command.Switches,
1767 Quiet => True);
1768
1769 if Sw = null then
1770 Sw :=
1771 Matching_Name
1772 (Arg (Arg'First .. SwP),
1773 Matching_Name
1774 ("COMPILE", Commands).Switches,
1775 Quiet => False);
1776 end if;
1777
1778 -- For all other cases, just search the relevant
1779 -- command.
1780
1781 else
1782 Sw :=
1783 Matching_Name
1784 (Arg (Arg'First .. SwP),
1785 Command.Switches,
1786 Quiet => False);
1787 end if;
1788
1789 if Sw /= null then
1790 if Cargs
1791 and then Sw.Name /= null
1792 and then
1793 (Sw.Name.all = "/PROJECT_FILE" or else
1794 Sw.Name.all = "/MESSAGES_PROJECT_FILE" or else
1795 Sw.Name.all = "/EXTERNAL_REFERENCE")
1796 then
1797 Cargs := False;
1798 end if;
1799
1800 case Sw.Translation is
1801 when T_Direct =>
1802 Place_Unix_Switches (Sw.Unix_String);
1803 if SwP < Arg'Last
1804 and then Arg (SwP + 1) = '='
1805 then
1806 Put (Standard_Error,
1807 "qualifier options ignored: ");
1808 Put_Line (Standard_Error, Arg.all);
1809 end if;
1810
1811 when T_Directories =>
1812 if SwP + 1 > Arg'Last then
1813 Put (Standard_Error,
1814 "missing directories for: ");
1815 Put_Line (Standard_Error, Arg.all);
1816 Errors := Errors + 1;
1817
1818 elsif Arg (SwP + 2) /= '(' then
1819 SwP := SwP + 2;
1820 Endp := Arg'Last;
1821
1822 elsif Arg (Arg'Last) /= ')' then
1823
1824 -- Remove spaces from a comma separated
1825 -- list of file names and adjust
1826 -- control variables accordingly.
1827
1828 if Arg_Num < Argument_Count and then
1829 (Argv (Argv'Last) = ',' xor
1830 Argument (Arg_Num + 1)
1831 (Argument (Arg_Num + 1)'First) = ',')
1832 then
1833 Argv :=
1834 new String'(Argv.all
1835 & Argument
1836 (Arg_Num + 1));
1837 Arg_Num := Arg_Num + 1;
1838 Arg_Idx := Argv'First;
1839 Next_Arg_Idx :=
1840 Get_Arg_End (Argv.all, Arg_Idx);
1841 Arg := new String'
1842 (Argv (Arg_Idx .. Next_Arg_Idx));
1843 goto Tryagain_After_Coalesce;
1844 end if;
1845
1846 Put (Standard_Error,
1847 "incorrectly parenthesized " &
1848 "or malformed argument: ");
1849 Put_Line (Standard_Error, Arg.all);
1850 Errors := Errors + 1;
1851
1852 else
1853 SwP := SwP + 3;
1854 Endp := Arg'Last - 1;
1855 end if;
1856
1857 while SwP <= Endp loop
1858 declare
1859 Dir_Is_Wild : Boolean := False;
1860 Dir_Maybe_Is_Wild : Boolean := False;
1861
1862 Dir_List : String_Access_List_Access;
1863
1864 begin
1865 P2 := SwP;
1866
1867 while P2 < Endp
1868 and then Arg (P2 + 1) /= ','
1869 loop
1870 -- A wildcard directory spec on
1871 -- VMS will contain either * or
1872 -- % or ...
1873
1874 if Arg (P2) = '*' then
1875 Dir_Is_Wild := True;
1876
1877 elsif Arg (P2) = '%' then
1878 Dir_Is_Wild := True;
1879
1880 elsif Dir_Maybe_Is_Wild
1881 and then Arg (P2) = '.'
1882 and then Arg (P2 + 1) = '.'
1883 then
1884 Dir_Is_Wild := True;
1885 Dir_Maybe_Is_Wild := False;
1886
1887 elsif Dir_Maybe_Is_Wild then
1888 Dir_Maybe_Is_Wild := False;
1889
1890 elsif Arg (P2) = '.'
1891 and then Arg (P2 + 1) = '.'
1892 then
1893 Dir_Maybe_Is_Wild := True;
1894
1895 end if;
1896
1897 P2 := P2 + 1;
1898 end loop;
1899
1900 if Dir_Is_Wild then
1901 Dir_List :=
1902 To_Canonical_File_List
1903 (Arg (SwP .. P2), True);
1904
1905 for J in Dir_List.all'Range loop
1906 Place_Unix_Switches
1907 (Sw.Unix_String);
1908 Place_Lower
1909 (Dir_List.all (J).all);
1910 end loop;
1911
1912 else
1913 Place_Unix_Switches
1914 (Sw.Unix_String);
1915 Place_Lower
1916 (To_Canonical_Dir_Spec
1917 (Arg (SwP .. P2), False).all);
1918 end if;
1919
1920 SwP := P2 + 2;
1921 end;
1922 end loop;
1923
1924 when T_Directory =>
1925 if SwP + 1 > Arg'Last then
1926 Put (Standard_Error,
1927 "missing directory for: ");
1928 Put_Line (Standard_Error, Arg.all);
1929 Errors := Errors + 1;
1930
1931 else
1932 Place_Unix_Switches (Sw.Unix_String);
1933
1934 -- Some switches end in "=". No space
1935 -- here
1936
1937 if Sw.Unix_String
1938 (Sw.Unix_String'Last) /= '='
1939 then
1940 Place (' ');
1941 end if;
1942
1943 Place_Lower
1944 (To_Canonical_Dir_Spec
1945 (Arg (SwP + 2 .. Arg'Last),
1946 False).all);
1947 end if;
1948
1949 when T_File | T_No_Space_File =>
1950 if SwP + 1 > Arg'Last then
1951 Put (Standard_Error,
1952 "missing file for: ");
1953 Put_Line (Standard_Error, Arg.all);
1954 Errors := Errors + 1;
1955
1956 else
1957 Place_Unix_Switches (Sw.Unix_String);
1958
1959 -- Some switches end in "=". No space
1960 -- here.
1961
1962 if Sw.Translation = T_File
1963 and then Sw.Unix_String
1964 (Sw.Unix_String'Last) /= '='
1965 then
1966 Place (' ');
1967 end if;
1968
1969 Place_Lower
1970 (To_Canonical_File_Spec
1971 (Arg (SwP + 2 .. Arg'Last)).all);
1972 end if;
1973
1974 when T_Numeric =>
1975 if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then
1976 Place_Unix_Switches (Sw.Unix_String);
1977 Place (Arg (SwP + 2 .. Arg'Last));
1978
1979 else
1980 Put (Standard_Error, "argument for ");
1981 Put (Standard_Error, Sw.Name.all);
1982 Put_Line
1983 (Standard_Error, " must be numeric");
1984 Errors := Errors + 1;
1985 end if;
1986
1987 when T_Alphanumplus =>
1988 if OK_Alphanumerplus
1989 (Arg (SwP + 2 .. Arg'Last))
1990 then
1991 Place_Unix_Switches (Sw.Unix_String);
1992 Place (Arg (SwP + 2 .. Arg'Last));
1993
1994 else
1995 Put (Standard_Error, "argument for ");
1996 Put (Standard_Error, Sw.Name.all);
1997 Put_Line (Standard_Error,
1998 " must be alphanumeric");
1999 Errors := Errors + 1;
2000 end if;
2001
2002 when T_String =>
2003
2004 -- A String value must be extended to the
2005 -- end of the Argv, otherwise strings like
2006 -- "foo/bar" get split at the slash.
2007
2008 -- The begining and ending of the string
2009 -- are flagged with embedded nulls which
2010 -- are removed when building the Spawn
2011 -- call. Nulls are use because they won't
2012 -- show up in a /? output. Quotes aren't
2013 -- used because that would make it
2014 -- difficult to embed them.
2015
2016 Place_Unix_Switches (Sw.Unix_String);
2017
2018 if Next_Arg_Idx /= Argv'Last then
2019 Next_Arg_Idx := Argv'Last;
2020 Arg := new String'
2021 (Argv (Arg_Idx .. Next_Arg_Idx));
2022
2023 SwP := Arg'First;
2024 while SwP < Arg'Last and then
2025 Arg (SwP + 1) /= '=' loop
2026 SwP := SwP + 1;
2027 end loop;
2028 end if;
2029
2030 Place (ASCII.NUL);
2031 Place (Arg (SwP + 2 .. Arg'Last));
2032 Place (ASCII.NUL);
2033
2034 when T_Commands =>
2035
2036 -- Output -largs/-bargs/-cargs
2037
2038 Place (' ');
2039 Place (Sw.Unix_String
2040 (Sw.Unix_String'First ..
2041 Sw.Unix_String'First + 5));
2042
2043 if Sw.Unix_String
2044 (Sw.Unix_String'First + 7 ..
2045 Sw.Unix_String'Last) = "MAKE"
2046 then
2047 Make_Commands_Active := null;
2048
2049 else
2050 -- Set source of new commands, also
2051 -- setting this non-null indicates that
2052 -- we are in the special commands mode
2053 -- for processing the -xargs case.
2054
2055 Make_Commands_Active :=
2056 Matching_Name
2057 (Sw.Unix_String
2058 (Sw.Unix_String'First + 7 ..
2059 Sw.Unix_String'Last),
2060 Commands);
2061 end if;
2062
2063 when T_Options =>
2064 if SwP + 1 > Arg'Last then
2065 Place_Unix_Switches
2066 (Sw.Options.Unix_String);
2067 SwP := Endp + 1;
2068
2069 elsif Arg (SwP + 2) /= '(' then
2070 SwP := SwP + 2;
2071 Endp := Arg'Last;
2072
2073 elsif Arg (Arg'Last) /= ')' then
2074 Put (Standard_Error,
2075 "incorrectly parenthesized argument: ");
2076 Put_Line (Standard_Error, Arg.all);
2077 Errors := Errors + 1;
2078 SwP := Endp + 1;
2079
2080 else
2081 SwP := SwP + 3;
2082 Endp := Arg'Last - 1;
2083 end if;
2084
2085 while SwP <= Endp loop
2086 P2 := SwP;
2087
2088 while P2 < Endp
2089 and then Arg (P2 + 1) /= ','
2090 loop
2091 P2 := P2 + 1;
2092 end loop;
2093
2094 -- Option name is in Arg (SwP .. P2)
2095
2096 Opt := Matching_Name (Arg (SwP .. P2),
2097 Sw.Options);
2098
2099 if Opt /= null then
2100 Place_Unix_Switches
2101 (Opt.Unix_String);
2102 end if;
2103
2104 SwP := P2 + 2;
2105 end loop;
2106
2107 when T_Other =>
2108 Place_Unix_Switches
2109 (new String'(Sw.Unix_String.all &
2110 Arg.all));
2111
2112 end case;
2113 end if;
2114 end;
2115 end if;
2116
2117 Arg_Idx := Next_Arg_Idx + 1;
2118 end;
2119
2120 exit when Arg_Idx > Argv'Last;
2121
2122 end loop;
2123
2124 if not Is_Open (Arg_File) then
2125 Arg_Num := Arg_Num + 1;
2126 end if;
2127 end Process_Argument;
2128
2129 --------------------
2130 -- Process_Buffer --
2131 --------------------
2132
2133 procedure Process_Buffer (S : String) is
2134 P1, P2 : Natural;
2135 Inside_Nul : Boolean := False;
2136 Arg : String (1 .. 1024);
2137 Arg_Ctr : Natural;
2138
2139 begin
2140 P1 := 1;
2141 while P1 <= S'Last and then S (P1) = ' ' loop
2142 P1 := P1 + 1;
2143 end loop;
2144
2145 Arg_Ctr := 1;
2146 Arg (Arg_Ctr) := S (P1);
2147
2148 while P1 <= S'Last loop
2149 if S (P1) = ASCII.NUL then
2150 if Inside_Nul then
2151 Inside_Nul := False;
2152 else
2153 Inside_Nul := True;
2154 end if;
2155 end if;
2156
2157 if S (P1) = ' ' and then not Inside_Nul then
2158 P1 := P1 + 1;
2159 Arg_Ctr := Arg_Ctr + 1;
2160 Arg (Arg_Ctr) := S (P1);
2161
2162 else
2163 Last_Switches.Increment_Last;
2164 P2 := P1;
2165
2166 while P2 < S'Last
2167 and then (S (P2 + 1) /= ' ' or else
2168 Inside_Nul)
2169 loop
2170 P2 := P2 + 1;
2171 Arg_Ctr := Arg_Ctr + 1;
2172 Arg (Arg_Ctr) := S (P2);
2173 if S (P2) = ASCII.NUL then
2174 Arg_Ctr := Arg_Ctr - 1;
2175
2176 if Inside_Nul then
2177 Inside_Nul := False;
2178 else
2179 Inside_Nul := True;
2180 end if;
2181 end if;
2182 end loop;
2183
2184 Last_Switches.Table (Last_Switches.Last) :=
2185 new String'(String (Arg (1 .. Arg_Ctr)));
2186 P1 := P2 + 2;
2187
2188 exit when P1 > S'Last;
2189
2190 Arg_Ctr := 1;
2191 Arg (Arg_Ctr) := S (P1);
2192 end if;
2193 end loop;
2194 end Process_Buffer;
2195
2196 --------------------------------
2197 -- Validate_Command_Or_Option --
2198 --------------------------------
2199
2200 procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is
2201 begin
2202 pragma Assert (N'Length > 0);
2203
2204 for J in N'Range loop
2205 if N (J) = '_' then
2206 pragma Assert (N (J - 1) /= '_');
2207 null;
2208 else
2209 pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
2210 null;
2211 end if;
2212 end loop;
2213 end Validate_Command_Or_Option;
2214
2215 --------------------------
2216 -- Validate_Unix_Switch --
2217 --------------------------
2218
2219 procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is
2220 begin
2221 if S (S'First) = '`' then
2222 return;
2223 end if;
2224
2225 pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
2226
2227 for J in S'First + 1 .. S'Last loop
2228 pragma Assert (S (J) /= ' ');
2229
2230 if S (J) = '!' then
2231 pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
2232 null;
2233 end if;
2234 end loop;
2235 end Validate_Unix_Switch;
2236
2237 --------------------
2238 -- VMS_Conversion --
2239 --------------------
2240
2241 procedure VMS_Conversion (The_Command : out Command_Type) is
2242 Result : Command_Type := Undefined;
2243 Result_Set : Boolean := False;
2244
2245 begin
2246 Buffer.Init;
2247
2248 -- First we must preprocess the string form of the command and options
2249 -- list into the internal form that we use.
2250
2251 Preprocess_Command_Data;
2252
2253 -- If no parameters, give complete list of commands
2254
2255 if Argument_Count = 0 then
2256 Output_Version;
2257 New_Line;
2258 Put_Line ("List of available commands");
2259 New_Line;
2260
2261 while Commands /= null loop
2262 Put (Commands.Usage.all);
2263 Set_Col (53);
2264 Put_Line (Commands.Unix_String.all);
2265 Commands := Commands.Next;
2266 end loop;
2267
2268 raise Normal_Exit;
2269 end if;
2270
2271 -- Loop through arguments
2272
2273 Arg_Num := 1;
2274 while Arg_Num <= Argument_Count loop
2275 Process_Argument (Result);
2276
2277 if not Result_Set then
2278 The_Command := Result;
2279 Result_Set := True;
2280 end if;
2281 end loop;
2282
2283 -- Gross error checking that the number of parameters is correct.
2284 -- Not applicable to Unlimited_Files parameters.
2285
2286 if (Param_Count = Command.Params'Length - 1
2287 and then Command.Params (Param_Count + 1) = Unlimited_Files)
2288 or else Param_Count <= Command.Params'Length
2289 then
2290 null;
2291
2292 else
2293 Put_Line (Standard_Error,
2294 "Parameter count of "
2295 & Integer'Image (Param_Count)
2296 & " not equal to expected "
2297 & Integer'Image (Command.Params'Length));
2298 Put (Standard_Error, "usage: ");
2299 Put_Line (Standard_Error, Command.Usage.all);
2300 Errors := Errors + 1;
2301 end if;
2302
2303 if Errors > 0 then
2304 raise Error_Exit;
2305 else
2306 -- Prepare arguments for a call to spawn, filtering out
2307 -- embedded nulls place there to delineate strings.
2308
2309 Process_Buffer (String (Buffer.Table (1 .. Buffer.Last)));
2310
2311 if Cargs_Buffer.Last > 1 then
2312 Last_Switches.Append (new String'("-cargs"));
2313 Process_Buffer
2314 (String (Cargs_Buffer.Table (1 .. Cargs_Buffer.Last)));
2315 end if;
2316 end if;
2317 end VMS_Conversion;
2318
2319 end VMS_Conv;
Mirror of the offical gcc git repository hosted at gcc.gnu.org