?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge with main truk.
[official-gcc.git] / gcc / ada / vms_conv.adb
blobfbb19e58b01a1e09c16adb7a1d5c5541be68be29
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-2013, 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 qualifiers 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 appropriately. 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 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 Sync =>
401 (Cname => new S'("SYNC"),
402 Usage => new S'("GNAT SYNC name /qualifiers"),
403 VMS_Only => False,
404 Unixcmd => new S'("gnatsync"),
405 Unixsws => null,
406 Switches => Sync_Switches'Access,
407 Params => new Parameter_Array'(1 => Unlimited_Files),
408 Defext => " "),
409
410 Elim =>
411 (Cname => new S'("ELIM"),
412 Usage => new S'("GNAT ELIM name /qualifiers"),
413 VMS_Only => False,
414 Unixcmd => new S'("gnatelim"),
415 Unixsws => null,
416 Switches => Elim_Switches'Access,
417 Params => new Parameter_Array'(1 => Other_As_Is),
418 Defext => "ali"),
419
420 Find =>
421 (Cname => new S'("FIND"),
422 Usage => new S'("GNAT FIND pattern[:sourcefile[:line"
423 & "[:column]]] filespec[,...] /qualifiers"),
424 VMS_Only => False,
425 Unixcmd => new S'("gnatfind"),
426 Unixsws => null,
427 Switches => Find_Switches'Access,
428 Params => new Parameter_Array'(1 => Other_As_Is,
429 2 => Files_Or_Wildcard),
430 Defext => "ali"),
431
432 Krunch =>
433 (Cname => new S'("KRUNCH"),
434 Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"),
435 VMS_Only => False,
436 Unixcmd => new S'("gnatkr"),
437 Unixsws => null,
438 Switches => Krunch_Switches'Access,
439 Params => new Parameter_Array'(1 => File),
440 Defext => " "),
441
442 Link =>
443 (Cname => new S'("LINK"),
444 Usage => new S'("GNAT LINK file[.ali]"
445 & " [extra obj_&_lib_&_exe_&_opt files]"
446 & " /qualifiers"),
447 VMS_Only => False,
448 Unixcmd => new S'("gnatlink"),
449 Unixsws => null,
450 Switches => Link_Switches'Access,
451 Params => new Parameter_Array'(1 => Unlimited_Files),
452 Defext => "ali"),
453
454 List =>
455 (Cname => new S'("LIST"),
456 Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"),
457 VMS_Only => False,
458 Unixcmd => new S'("gnatls"),
459 Unixsws => null,
460 Switches => List_Switches'Access,
461 Params => new Parameter_Array'(1 => Unlimited_Files),
462 Defext => "ali"),
463
464 Make =>
465 (Cname => new S'("MAKE"),
466 Usage => new S'("GNAT MAKE file(s) /qualifiers (includes "
467 & "COMPILE /qualifiers)"),
468 VMS_Only => False,
469 Unixcmd => new S'("gnatmake"),
470 Unixsws => null,
471 Switches => Make_Switches'Access,
472 Params => new Parameter_Array'(1 => Unlimited_Files),
473 Defext => " "),
474
475 Metric =>
476 (Cname => new S'("METRIC"),
477 Usage => new S'("GNAT METRIC /qualifiers source_file"),
478 VMS_Only => False,
479 Unixcmd => new S'("gnatmetric"),
480 Unixsws => null,
481 Switches => Metric_Switches'Access,
482 Params => new Parameter_Array'(1 => Unlimited_Files),
483 Defext => " "),
484
485 Name =>
486 (Cname => new S'("NAME"),
487 Usage => new S'("GNAT NAME /qualifiers naming-pattern "
488 & "[naming-patterns]"),
489 VMS_Only => False,
490 Unixcmd => new S'("gnatname"),
491 Unixsws => null,
492 Switches => Name_Switches'Access,
493 Params => new Parameter_Array'(1 => Unlimited_As_Is),
494 Defext => " "),
495
496 Preprocess =>
497 (Cname => new S'("PREPROCESS"),
498 Usage =>
499 new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"),
500 VMS_Only => False,
501 Unixcmd => new S'("gnatprep"),
502 Unixsws => null,
503 Switches => Prep_Switches'Access,
504 Params => new Parameter_Array'(1 .. 3 => File),
505 Defext => " "),
506
507 Pretty =>
508 (Cname => new S'("PRETTY"),
509 Usage => new S'("GNAT PRETTY /qualifiers source_file"),
510 VMS_Only => False,
511 Unixcmd => new S'("gnatpp"),
512 Unixsws => null,
513 Switches => Pretty_Switches'Access,
514 Params => new Parameter_Array'(1 => Unlimited_Files),
515 Defext => " "),
516
517 Shared =>
518 (Cname => new S'("SHARED"),
519 Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt"
520 & "files] /qualifiers"),
521 VMS_Only => True,
522 Unixcmd => new S'("gcc"),
523 Unixsws =>
524 new Argument_List'(new String'("-shared") & Init_Object_Dirs),
525 Switches => Shared_Switches'Access,
526 Params => new Parameter_Array'(1 => Unlimited_Files),
527 Defext => " "),
528
529 Stack =>
530 (Cname => new S'("STACK"),
531 Usage => new S'("GNAT STACK /qualifiers ci_files"),
532 VMS_Only => False,
533 Unixcmd => new S'("gnatstack"),
534 Unixsws => null,
535 Switches => Stack_Switches'Access,
536 Params => new Parameter_Array'(1 => Unlimited_Files),
537 Defext => "ci" & ASCII.NUL),
538
539 Stub =>
540 (Cname => new S'("STUB"),
541 Usage => new S'("GNAT STUB file [directory]/qualifiers"),
542 VMS_Only => False,
543 Unixcmd => new S'("gnatstub"),
544 Unixsws => null,
545 Switches => Stub_Switches'Access,
546 Params => new Parameter_Array'(1 => File, 2 => Optional_File),
547 Defext => " "),
548
549 Test =>
550 (Cname => new S'("TEST"),
551 Usage => new S'("GNAT TEST file(s) /qualifiers"),
552 VMS_Only => False,
553 Unixcmd => new S'("gnattest"),
554 Unixsws => null,
555 Switches => Make_Switches'Access,
556 Params => new Parameter_Array'(1 => Unlimited_Files),
557 Defext => " "),
558
559 Xref =>
560 (Cname => new S'("XREF"),
561 Usage => new S'("GNAT XREF filespec[,...] /qualifiers"),
562 VMS_Only => False,
563 Unixcmd => new S'("gnatxref"),
564 Unixsws => null,
565 Switches => Xref_Switches'Access,
566 Params => new Parameter_Array'(1 => Files_Or_Wildcard),
567 Defext => "ali")
568 );
569 end Initialize;
570
571 ------------------
572 -- Invert_Sense --
573 ------------------
574
575 function Invert_Sense (S : String) return VMS_Data.String_Ptr is
576 Sinv : String (1 .. S'Length * 2);
577 -- Result (for sure long enough)
578
579 Sinvp : Natural := 0;
580 -- Pointer to output string
581
582 begin
583 for Sp in S'Range loop
584 if Sp = S'First or else S (Sp - 1) = ',' then
585 if S (Sp) = '!' then
586 null;
587 else
588 Sinv (Sinvp + 1) := '!';
589 Sinv (Sinvp + 2) := S (Sp);
590 Sinvp := Sinvp + 2;
591 end if;
592
593 else
594 Sinv (Sinvp + 1) := S (Sp);
595 Sinvp := Sinvp + 1;
596 end if;
597 end loop;
598
599 return new String'(Sinv (1 .. Sinvp));
600 end Invert_Sense;
601
602 ----------------------
603 -- Is_Extensionless --
604 ----------------------
605
606 function Is_Extensionless (F : String) return Boolean is
607 begin
608 for J in reverse F'Range loop
609 if F (J) = '.' then
610 return False;
611 elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then
612 return True;
613 end if;
614 end loop;
615
616 return True;
617 end Is_Extensionless;
618
619 -----------
620 -- Match --
621 -----------
622
623 function Match (S1, S2 : String) return Boolean is
624 Dif : constant Integer := S2'First - S1'First;
625
626 begin
627
628 if S1'Length /= S2'Length then
629 return False;
630
631 else
632 for J in S1'Range loop
633 if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then
634 return False;
635 end if;
636 end loop;
637
638 return True;
639 end if;
640 end Match;
641
642 ------------------
643 -- Match_Prefix --
644 ------------------
645
646 function Match_Prefix (S1, S2 : String) return Boolean is
647 begin
648 if S1'Length > S2'Length then
649 return False;
650 else
651 return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1));
652 end if;
653 end Match_Prefix;
654
655 -------------------
656 -- Matching_Name --
657 -------------------
658
659 function Matching_Name
660 (S : String;
661 Itm : Item_Ptr;
662 Quiet : Boolean := False) return Item_Ptr
663 is
664 P1, P2 : Item_Ptr;
665
666 procedure Err;
667 -- Little procedure to output command/qualifier/option as appropriate
668 -- and bump error count.
669
670 ---------
671 -- Err --
672 ---------
673
674 procedure Err is
675 begin
676 if Quiet then
677 return;
678 end if;
679
680 Errors := Errors + 1;
681
682 if Itm /= null then
683 case Itm.Id is
684 when Id_Command =>
685 Put (Standard_Error, "command");
686
687 when Id_Switch =>
688 if Hostparm.OpenVMS then
689 Put (Standard_Error, "qualifier");
690 else
691 Put (Standard_Error, "switch");
692 end if;
693
694 when Id_Option =>
695 Put (Standard_Error, "option");
696
697 end case;
698 else
699 Put (Standard_Error, "input");
700
701 end if;
702
703 Put (Standard_Error, ": ");
704 Put (Standard_Error, S);
705 end Err;
706
707 -- Start of processing for Matching_Name
708
709 begin
710 -- If exact match, that's the one we want
711
712 P1 := Itm;
713 while P1 /= null loop
714 if Match (S, P1.Name.all) then
715 return P1;
716 else
717 P1 := P1.Next;
718 end if;
719 end loop;
720
721 -- Now check for prefix matches
722
723 P1 := Itm;
724 while P1 /= null loop
725 if P1.Name.all = "/<other>" then
726 return P1;
727
728 elsif not Match_Prefix (S, P1.Name.all) then
729 P1 := P1.Next;
730
731 else
732 -- Here we have found one matching prefix, so see if there is
733 -- another one (which is an ambiguity)
734
735 P2 := P1.Next;
736 while P2 /= null loop
737 if Match_Prefix (S, P2.Name.all) then
738 if not Quiet then
739 Put (Standard_Error, "ambiguous ");
740 Err;
741 Put (Standard_Error, " (matches ");
742 Put (Standard_Error, P1.Name.all);
743
744 while P2 /= null loop
745 if Match_Prefix (S, P2.Name.all) then
746 Put (Standard_Error, ',');
747 Put (Standard_Error, P2.Name.all);
748 end if;
749
750 P2 := P2.Next;
751 end loop;
752
753 Put_Line (Standard_Error, ")");
754 end if;
755
756 return null;
757 end if;
758
759 P2 := P2.Next;
760 end loop;
761
762 -- If we fall through that loop, then there was only one match
763
764 return P1;
765 end if;
766 end loop;
767
768 -- If we fall through outer loop, there was no match
769
770 if not Quiet then
771 Put (Standard_Error, "unrecognized ");
772 Err;
773 New_Line (Standard_Error);
774 end if;
775
776 return null;
777 end Matching_Name;
778
779 -----------------------
780 -- OK_Alphanumerplus --
781 -----------------------
782
783 function OK_Alphanumerplus (S : String) return Boolean is
784 begin
785 if S'Length = 0 then
786 return False;
787
788 else
789 for J in S'Range loop
790 if not (Is_Alphanumeric (S (J)) or else
791 S (J) = '_' or else S (J) = '$')
792 then
793 return False;
794 end if;
795 end loop;
796
797 return True;
798 end if;
799 end OK_Alphanumerplus;
800
801 ----------------
802 -- OK_Integer --
803 ----------------
804
805 function OK_Integer (S : String) return Boolean is
806 begin
807 if S'Length = 0 then
808 return False;
809
810 else
811 for J in S'Range loop
812 if not Is_Digit (S (J)) then
813 return False;
814 end if;
815 end loop;
816
817 return True;
818 end if;
819 end OK_Integer;
820
821 --------------------
822 -- Output_Version --
823 --------------------
824
825 procedure Output_Version is
826 begin
827 if AAMP_On_Target then
828 Put ("GNAAMP ");
829 else
830 Put ("GNAT ");
831 end if;
832
833 Put_Line (Gnatvsn.Gnat_Version_String);
834 Put_Line ("Copyright 1996-" &
835 Current_Year &
836 ", Free Software Foundation, Inc.");
837 end Output_Version;
838
839 -----------
840 -- Place --
841 -----------
842
843 procedure Place (C : Character) is
844 begin
845 if Cargs then
846 Cargs_Buffer.Append (C);
847 else
848 Buffer.Append (C);
849 end if;
850 end Place;
851
852 procedure Place (S : String) is
853 begin
854 for J in S'Range loop
855 Place (S (J));
856 end loop;
857 end Place;
858
859 -----------------
860 -- Place_Lower --
861 -----------------
862
863 procedure Place_Lower (S : String) is
864 begin
865 for J in S'Range loop
866 Place (To_Lower (S (J)));
867 end loop;
868 end Place_Lower;
869
870 -------------------------
871 -- Place_Unix_Switches --
872 -------------------------
873
874 procedure Place_Unix_Switches (S : VMS_Data.String_Ptr) is
875 P1, P2, P3 : Natural;
876 Remove : Boolean;
877 Slen, Sln2 : Natural;
878 Wild_Card : Boolean := False;
879
880 begin
881 P1 := S'First;
882 while P1 <= S'Last loop
883 if S (P1) = '!' then
884 P1 := P1 + 1;
885 Remove := True;
886 else
887 Remove := False;
888 end if;
889
890 P2 := P1;
891 pragma Assert (S (P1) = '-' or else S (P1) = '`');
892
893 while P2 < S'Last and then S (P2 + 1) /= ',' loop
894 P2 := P2 + 1;
895 end loop;
896
897 -- Switch is now in S (P1 .. P2)
898
899 Slen := P2 - P1 + 1;
900
901 if Remove then
902 Wild_Card := S (P2) = '*';
903
904 if Wild_Card then
905 Slen := Slen - 1;
906 P2 := P2 - 1;
907 end if;
908
909 P3 := 1;
910 while P3 <= Buffer.Last - Slen loop
911 if Buffer.Table (P3) = ' '
912 and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) =
913 S (P1 .. P2)
914 and then (Wild_Card
915 or else
916 P3 + Slen = Buffer.Last
917 or else
918 Buffer.Table (P3 + Slen + 1) = ' ')
919 then
920 Sln2 := Slen;
921
922 if Wild_Card then
923 while P3 + Sln2 /= Buffer.Last
924 and then Buffer.Table (P3 + Sln2 + 1) /= ' '
925 loop
926 Sln2 := Sln2 + 1;
927 end loop;
928 end if;
929
930 Buffer.Table (P3 .. Buffer.Last - Sln2 - 1) :=
931 Buffer.Table (P3 + Sln2 + 1 .. Buffer.Last);
932 Buffer.Set_Last (Buffer.Last - Sln2 - 1);
933
934 else
935 P3 := P3 + 1;
936 end if;
937 end loop;
938
939 if Wild_Card then
940 P2 := P2 + 1;
941 end if;
942
943 else
944 pragma Assert (S (P2) /= '*');
945 Place (' ');
946
947 if S (P1) = '`' then
948 P1 := P1 + 1;
949 end if;
950
951 Place (S (P1 .. P2));
952 end if;
953
954 P1 := P2 + 2;
955 end loop;
956 end Place_Unix_Switches;
957
958 -----------------------------
959 -- Preprocess_Command_Data --
960 -----------------------------
961
962 procedure Preprocess_Command_Data is
963 begin
964 for C in Real_Command_Type loop
965 declare
966 Command : constant Item_Ptr := new Command_Item;
967
968 Last_Switch : Item_Ptr;
969 -- Last switch in list
970
971 begin
972 -- Link new command item into list of commands
973
974 if Last_Command = null then
975 Commands := Command;
976 else
977 Last_Command.Next := Command;
978 end if;
979
980 Last_Command := Command;
981
982 -- Fill in fields of new command item
983
984 Command.Name := Command_List (C).Cname;
985 Command.Usage := Command_List (C).Usage;
986 Command.Command := C;
987
988 if Command_List (C).Unixsws = null then
989 Command.Unix_String := Command_List (C).Unixcmd;
990 else
991 declare
992 Cmd : String (1 .. 5_000);
993 Last : Natural := 0;
994 Sws : constant Argument_List_Access :=
995 Command_List (C).Unixsws;
996
997 begin
998 Cmd (1 .. Command_List (C).Unixcmd'Length) :=
999 Command_List (C).Unixcmd.all;
1000 Last := Command_List (C).Unixcmd'Length;
1001
1002 for J in Sws'Range loop
1003 Last := Last + 1;
1004 Cmd (Last) := ' ';
1005 Cmd (Last + 1 .. Last + Sws (J)'Length) :=
1006 Sws (J).all;
1007 Last := Last + Sws (J)'Length;
1008 end loop;
1009
1010 Command.Unix_String := new String'(Cmd (1 .. Last));
1011 end;
1012 end if;
1013
1014 Command.Params := Command_List (C).Params;
1015 Command.Defext := Command_List (C).Defext;
1016
1017 Validate_Command_Or_Option (Command.Name);
1018
1019 -- Process the switch list
1020
1021 for S in Command_List (C).Switches'Range loop
1022 declare
1023 SS : constant VMS_Data.String_Ptr :=
1024 Command_List (C).Switches (S);
1025 P : Natural := SS'First;
1026 Sw : Item_Ptr := new Switch_Item;
1027
1028 Last_Opt : Item_Ptr;
1029 -- Pointer to last option
1030
1031 begin
1032 -- Link new switch item into list of switches
1033
1034 if Last_Switch = null then
1035 Command.Switches := Sw;
1036 else
1037 Last_Switch.Next := Sw;
1038 end if;
1039
1040 Last_Switch := Sw;
1041
1042 -- Process switch string, first get name
1043
1044 while SS (P) /= ' ' and then SS (P) /= '=' loop
1045 P := P + 1;
1046 end loop;
1047
1048 Sw.Name := new String'(SS (SS'First .. P - 1));
1049
1050 -- Direct translation case
1051
1052 if SS (P) = ' ' then
1053 Sw.Translation := T_Direct;
1054 Sw.Unix_String := new String'(SS (P + 1 .. SS'Last));
1055 Validate_Unix_Switch (Sw.Unix_String);
1056
1057 if SS (P - 1) = '>' then
1058 Sw.Translation := T_Other;
1059
1060 elsif SS (P + 1) = '`' then
1061 null;
1062
1063 -- Create the inverted case (/NO ..)
1064
1065 elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then
1066 Sw := new Switch_Item;
1067 Last_Switch.Next := Sw;
1068 Last_Switch := Sw;
1069
1070 Sw.Name :=
1071 new String'("/NO" & SS (SS'First + 1 .. P - 1));
1072 Sw.Translation := T_Direct;
1073 Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last));
1074 Validate_Unix_Switch (Sw.Unix_String);
1075 end if;
1076
1077 -- Directories translation case
1078
1079 elsif SS (P + 1) = '*' then
1080 pragma Assert (SS (SS'Last) = '*');
1081 Sw.Translation := T_Directories;
1082 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1083 Validate_Unix_Switch (Sw.Unix_String);
1084
1085 -- Directory translation case
1086
1087 elsif SS (P + 1) = '%' then
1088 pragma Assert (SS (SS'Last) = '%');
1089 Sw.Translation := T_Directory;
1090 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1091 Validate_Unix_Switch (Sw.Unix_String);
1092
1093 -- File translation case
1094
1095 elsif SS (P + 1) = '@' then
1096 pragma Assert (SS (SS'Last) = '@');
1097 Sw.Translation := T_File;
1098 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1099 Validate_Unix_Switch (Sw.Unix_String);
1100
1101 -- No space file translation case
1102
1103 elsif SS (P + 1) = '<' then
1104 pragma Assert (SS (SS'Last) = '>');
1105 Sw.Translation := T_No_Space_File;
1106 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1107 Validate_Unix_Switch (Sw.Unix_String);
1108
1109 -- Numeric translation case
1110
1111 elsif SS (P + 1) = '#' then
1112 pragma Assert (SS (SS'Last) = '#');
1113 Sw.Translation := T_Numeric;
1114 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1115 Validate_Unix_Switch (Sw.Unix_String);
1116
1117 -- Alphanumerplus translation case
1118
1119 elsif SS (P + 1) = '|' then
1120 pragma Assert (SS (SS'Last) = '|');
1121 Sw.Translation := T_Alphanumplus;
1122 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1123 Validate_Unix_Switch (Sw.Unix_String);
1124
1125 -- String translation case
1126
1127 elsif SS (P + 1) = '"' then
1128 pragma Assert (SS (SS'Last) = '"');
1129 Sw.Translation := T_String;
1130 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
1131 Validate_Unix_Switch (Sw.Unix_String);
1132
1133 -- Commands translation case
1134
1135 elsif SS (P + 1) = '?' then
1136 Sw.Translation := T_Commands;
1137 Sw.Unix_String := new String'(SS (P + 2 .. SS'Last));
1138
1139 -- Options translation case
1140
1141 else
1142 Sw.Translation := T_Options;
1143 Sw.Unix_String := new String'("");
1144
1145 P := P + 1; -- bump past =
1146 while P <= SS'Last loop
1147 declare
1148 Opt : constant Item_Ptr := new Option_Item;
1149 Q : Natural;
1150
1151 begin
1152 -- Link new option item into options list
1153
1154 if Last_Opt = null then
1155 Sw.Options := Opt;
1156 else
1157 Last_Opt.Next := Opt;
1158 end if;
1159
1160 Last_Opt := Opt;
1161
1162 -- Fill in fields of new option item
1163
1164 Q := P;
1165 while SS (Q) /= ' ' loop
1166 Q := Q + 1;
1167 end loop;
1168
1169 Opt.Name := new String'(SS (P .. Q - 1));
1170 Validate_Command_Or_Option (Opt.Name);
1171
1172 P := Q + 1;
1173 Q := P;
1174
1175 while Q <= SS'Last and then SS (Q) /= ' ' loop
1176 Q := Q + 1;
1177 end loop;
1178
1179 Opt.Unix_String := new String'(SS (P .. Q - 1));
1180 Validate_Unix_Switch (Opt.Unix_String);
1181 P := Q + 1;
1182 end;
1183 end loop;
1184 end if;
1185 end;
1186 end loop;
1187 end;
1188 end loop;
1189 end Preprocess_Command_Data;
1190
1191 ----------------------
1192 -- Process_Argument --
1193 ----------------------
1194
1195 procedure Process_Argument (The_Command : in out Command_Type) is
1196 Argv : String_Access;
1197 Arg_Idx : Integer;
1198
1199 function Get_Arg_End
1200 (Argv : String;
1201 Arg_Idx : Integer) return Integer;
1202 -- Begins looking at Arg_Idx + 1 and returns the index of the
1203 -- last character before a slash or else the index of the last
1204 -- character in the string Argv.
1205
1206 -----------------
1207 -- Get_Arg_End --
1208 -----------------
1209
1210 function Get_Arg_End
1211 (Argv : String;
1212 Arg_Idx : Integer) return Integer
1213 is
1214 begin
1215 for J in Arg_Idx + 1 .. Argv'Last loop
1216 if Argv (J) = '/' then
1217 return J - 1;
1218 end if;
1219 end loop;
1220
1221 return Argv'Last;
1222 end Get_Arg_End;
1223
1224 -- Start of processing for Process_Argument
1225
1226 begin
1227 Cargs := False;
1228
1229 -- If an argument file is open, read the next non empty line
1230
1231 if Is_Open (Arg_File) then
1232 declare
1233 Line : String (1 .. 256);
1234 Last : Natural;
1235 begin
1236 loop
1237 Get_Line (Arg_File, Line, Last);
1238 exit when Last /= 0 or else End_Of_File (Arg_File);
1239 end loop;
1240
1241 -- If the end of the argument file has been reached, close it
1242
1243 if End_Of_File (Arg_File) then
1244 Close (Arg_File);
1245
1246 -- If the last line was empty, return after increasing Arg_Num
1247 -- to go to the next argument on the comment line.
1248
1249 if Last = 0 then
1250 Arg_Num := Arg_Num + 1;
1251 return;
1252 end if;
1253 end if;
1254
1255 Argv := new String'(Line (1 .. Last));
1256 Arg_Idx := 1;
1257
1258 if Argv (1) = '@' then
1259 Put_Line (Standard_Error, "argument file cannot contain @cmd");
1260 raise Error_Exit;
1261 end if;
1262 end;
1263
1264 else
1265 -- No argument file is open, get the argument on the command line
1266
1267 Argv := new String'(Argument (Arg_Num));
1268 Arg_Idx := Argv'First;
1269
1270 -- Check if this is the specification of an argument file
1271
1272 if Argv (Arg_Idx) = '@' then
1273 -- The first argument on the command line cannot be an argument
1274 -- file.
1275
1276 if Arg_Num = 1 then
1277 Put_Line
1278 (Standard_Error,
1279 "Cannot specify argument line before command");
1280 raise Error_Exit;
1281 end if;
1282
1283 -- Open the file, after conversion of the name to canonical form.
1284 -- Fail if file is not found.
1285
1286 declare
1287 Canonical_File_Name : String_Access :=
1288 To_Canonical_File_Spec (Argv (Arg_Idx + 1 .. Argv'Last));
1289 begin
1290 Open (Arg_File, In_File, Canonical_File_Name.all);
1291 Free (Canonical_File_Name);
1292 return;
1293
1294 exception
1295 when others =>
1296 Put (Standard_Error, "Cannot open argument file """);
1297 Put (Standard_Error, Argv (Arg_Idx + 1 .. Argv'Last));
1298 Put_Line (Standard_Error, """");
1299 raise Error_Exit;
1300 end;
1301 end if;
1302 end if;
1303
1304 <<Tryagain_After_Coalesce>>
1305 loop
1306 declare
1307 Next_Arg_Idx : Integer;
1308 Arg : String_Access;
1309
1310 begin
1311 Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
1312 Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
1313
1314 -- The first one must be a command name
1315
1316 if Arg_Num = 1 and then Arg_Idx = Argv'First then
1317 Command := Matching_Name (Arg.all, Commands);
1318
1319 if Command = null then
1320 raise Error_Exit;
1321 end if;
1322
1323 The_Command := Command.Command;
1324 Output_File_Expected := False;
1325
1326 -- Give usage information if only command given
1327
1328 if Argument_Count = 1
1329 and then Next_Arg_Idx = Argv'Last
1330 then
1331 Output_Version;
1332 New_Line;
1333 Put_Line
1334 ("List of available qualifiers and options");
1335 New_Line;
1336
1337 Put (Command.Usage.all);
1338 Set_Col (53);
1339 Put_Line (Command.Unix_String.all);
1340
1341 declare
1342 Sw : Item_Ptr := Command.Switches;
1343
1344 begin
1345 while Sw /= null loop
1346 Put (" ");
1347 Put (Sw.Name.all);
1348
1349 case Sw.Translation is
1350
1351 when T_Other =>
1352 Set_Col (53);
1353 Put_Line (Sw.Unix_String.all &
1354 "/<other>");
1355
1356 when T_Direct =>
1357 Set_Col (53);
1358 Put_Line (Sw.Unix_String.all);
1359
1360 when T_Directories =>
1361 Put ("=(direc,direc,..direc)");
1362 Set_Col (53);
1363 Put (Sw.Unix_String.all);
1364 Put (" direc ");
1365 Put (Sw.Unix_String.all);
1366 Put_Line (" direc ...");
1367
1368 when T_Directory =>
1369 Put ("=directory");
1370 Set_Col (53);
1371 Put (Sw.Unix_String.all);
1372
1373 if Sw.Unix_String (Sw.Unix_String'Last)
1374 /= '='
1375 then
1376 Put (' ');
1377 end if;
1378
1379 Put_Line ("directory ");
1380
1381 when T_File | T_No_Space_File =>
1382 Put ("=file");
1383 Set_Col (53);
1384 Put (Sw.Unix_String.all);
1385
1386 if Sw.Translation = T_File
1387 and then Sw.Unix_String
1388 (Sw.Unix_String'Last) /= '='
1389 then
1390 Put (' ');
1391 end if;
1392
1393 Put_Line ("file ");
1394
1395 when T_Numeric =>
1396 Put ("=nnn");
1397 Set_Col (53);
1398
1399 if Sw.Unix_String
1400 (Sw.Unix_String'First) = '`'
1401 then
1402 Put (Sw.Unix_String
1403 (Sw.Unix_String'First + 1
1404 .. Sw.Unix_String'Last));
1405 else
1406 Put (Sw.Unix_String.all);
1407 end if;
1408
1409 Put_Line ("nnn");
1410
1411 when T_Alphanumplus =>
1412 Put ("=xyz");
1413 Set_Col (53);
1414
1415 if Sw.Unix_String
1416 (Sw.Unix_String'First) = '`'
1417 then
1418 Put (Sw.Unix_String
1419 (Sw.Unix_String'First + 1
1420 .. Sw.Unix_String'Last));
1421 else
1422 Put (Sw.Unix_String.all);
1423 end if;
1424
1425 Put_Line ("xyz");
1426
1427 when T_String =>
1428 Put ("=");
1429 Put ('"');
1430 Put ("<string>");
1431 Put ('"');
1432 Set_Col (53);
1433
1434 Put (Sw.Unix_String.all);
1435
1436 if Sw.Unix_String
1437 (Sw.Unix_String'Last) /= '='
1438 then
1439 Put (' ');
1440 end if;
1441
1442 Put ("<string>");
1443 New_Line;
1444
1445 when T_Commands =>
1446 Put (" (switches for ");
1447 Put (Sw.Unix_String
1448 (Sw.Unix_String'First + 7
1449 .. Sw.Unix_String'Last));
1450 Put (')');
1451 Set_Col (53);
1452 Put (Sw.Unix_String
1453 (Sw.Unix_String'First
1454 .. Sw.Unix_String'First + 5));
1455 Put_Line (" switches");
1456
1457 when T_Options =>
1458 declare
1459 Opt : Item_Ptr := Sw.Options;
1460
1461 begin
1462 Put_Line ("=(option,option..)");
1463
1464 while Opt /= null loop
1465 Put (" ");
1466 Put (Opt.Name.all);
1467
1468 if Opt = Sw.Options then
1469 Put (" (D)");
1470 end if;
1471
1472 Set_Col (53);
1473 Put_Line (Opt.Unix_String.all);
1474 Opt := Opt.Next;
1475 end loop;
1476 end;
1477
1478 end case;
1479
1480 Sw := Sw.Next;
1481 end loop;
1482 end;
1483
1484 raise Normal_Exit;
1485 end if;
1486
1487 -- Special handling for internal debugging switch /?
1488
1489 elsif Arg.all = "/?" then
1490 Display_Command := True;
1491 Output_File_Expected := False;
1492
1493 -- Special handling of internal option /KEEP_TEMPORARY_FILES
1494
1495 elsif Arg'Length >= 7
1496 and then Matching_Name
1497 (Arg.all, Keep_Temps_Option, True) /= null
1498 then
1499 Opt.Keep_Temporary_Files := True;
1500
1501 -- Copy -switch unchanged, as well as +rule
1502
1503 elsif Arg (Arg'First) = '-' or else Arg (Arg'First) = '+' then
1504 Place (' ');
1505 Place (Arg.all);
1506
1507 -- Set Output_File_Expected for the next argument
1508
1509 Output_File_Expected :=
1510 Arg.all = "-o" and then The_Command = Link;
1511
1512 -- Copy quoted switch with quotes stripped
1513
1514 elsif Arg (Arg'First) = '"' then
1515 if Arg (Arg'Last) /= '"' then
1516 Put (Standard_Error, "misquoted argument: ");
1517 Put_Line (Standard_Error, Arg.all);
1518 Errors := Errors + 1;
1519
1520 else
1521 Place (' ');
1522 Place (Arg (Arg'First + 1 .. Arg'Last - 1));
1523 end if;
1524
1525 Output_File_Expected := False;
1526
1527 -- Parameter Argument
1528
1529 elsif Arg (Arg'First) /= '/'
1530 and then Make_Commands_Active = null
1531 then
1532 Param_Count := Param_Count + 1;
1533
1534 if Param_Count <= Command.Params'Length then
1535
1536 case Command.Params (Param_Count) is
1537
1538 when File | Optional_File =>
1539 declare
1540 Normal_File : constant String_Access :=
1541 To_Canonical_File_Spec
1542 (Arg.all);
1543
1544 begin
1545 Place (' ');
1546 Place_Lower (Normal_File.all);
1547
1548 if Is_Extensionless (Normal_File.all)
1549 and then Command.Defext /= " "
1550 then
1551 Place ('.');
1552 Place (Command.Defext);
1553 end if;
1554 end;
1555
1556 when Unlimited_Files =>
1557 declare
1558 Normal_File : constant String_Access :=
1559 To_Canonical_File_Spec
1560 (Arg.all);
1561
1562 File_Is_Wild : Boolean := False;
1563 File_List : String_Access_List_Access;
1564
1565 begin
1566 for J in Arg'Range loop
1567 if Arg (J) = '*'
1568 or else Arg (J) = '%'
1569 then
1570 File_Is_Wild := True;
1571 end if;
1572 end loop;
1573
1574 if File_Is_Wild then
1575 File_List := To_Canonical_File_List
1576 (Arg.all, False);
1577
1578 for J in File_List.all'Range loop
1579 Place (' ');
1580 Place_Lower (File_List.all (J).all);
1581 end loop;
1582
1583 else
1584 Place (' ');
1585 Place_Lower (Normal_File.all);
1586
1587 -- Add extension if not present, except after
1588 -- switch -o.
1589
1590 if Is_Extensionless (Normal_File.all)
1591 and then Command.Defext /= " "
1592 and then not Output_File_Expected
1593 then
1594 Place ('.');
1595 Place (Command.Defext);
1596 end if;
1597 end if;
1598
1599 Param_Count := Param_Count - 1;
1600 end;
1601
1602 when Other_As_Is =>
1603 Place (' ');
1604 Place (Arg.all);
1605
1606 when Unlimited_As_Is =>
1607 Place (' ');
1608 Place (Arg.all);
1609 Param_Count := Param_Count - 1;
1610
1611 when Files_Or_Wildcard =>
1612
1613 -- Remove spaces from a comma separated list
1614 -- of file names and adjust control variables
1615 -- accordingly.
1616
1617 while Arg_Num < Argument_Count and then
1618 (Argv (Argv'Last) = ',' xor
1619 Argument (Arg_Num + 1)
1620 (Argument (Arg_Num + 1)'First) = ',')
1621 loop
1622 Argv := new String'
1623 (Argv.all & Argument (Arg_Num + 1));
1624 Arg_Num := Arg_Num + 1;
1625 Arg_Idx := Argv'First;
1626 Next_Arg_Idx :=
1627 Get_Arg_End (Argv.all, Arg_Idx);
1628 Arg := new String'
1629 (Argv (Arg_Idx .. Next_Arg_Idx));
1630 end loop;
1631
1632 -- Parse the comma separated list of VMS
1633 -- filenames and place them on the command
1634 -- line as space separated Unix style
1635 -- filenames. Lower case and add default
1636 -- extension as appropriate.
1637
1638 declare
1639 Arg1_Idx : Integer := Arg'First;
1640
1641 function Get_Arg1_End
1642 (Arg : String;
1643 Arg_Idx : Integer) return Integer;
1644 -- Begins looking at Arg_Idx + 1 and
1645 -- returns the index of the last character
1646 -- before a comma or else the index of the
1647 -- last character in the string Arg.
1648
1649 ------------------
1650 -- Get_Arg1_End --
1651 ------------------
1652
1653 function Get_Arg1_End
1654 (Arg : String;
1655 Arg_Idx : Integer) return Integer
1656 is
1657 begin
1658 for J in Arg_Idx + 1 .. Arg'Last loop
1659 if Arg (J) = ',' then
1660 return J - 1;
1661 end if;
1662 end loop;
1663
1664 return Arg'Last;
1665 end Get_Arg1_End;
1666
1667 begin
1668 loop
1669 declare
1670 Next_Arg1_Idx :
1671 constant Integer :=
1672 Get_Arg1_End (Arg.all, Arg1_Idx);
1673
1674 Arg1 :
1675 constant String :=
1676 Arg (Arg1_Idx .. Next_Arg1_Idx);
1677
1678 Normal_File :
1679 constant String_Access :=
1680 To_Canonical_File_Spec (Arg1);
1681
1682 begin
1683 Place (' ');
1684 Place_Lower (Normal_File.all);
1685
1686 if Is_Extensionless (Normal_File.all)
1687 and then Command.Defext /= " "
1688 then
1689 Place ('.');
1690 Place (Command.Defext);
1691 end if;
1692
1693 Arg1_Idx := Next_Arg1_Idx + 1;
1694 end;
1695
1696 exit when Arg1_Idx > Arg'Last;
1697
1698 -- Don't allow two or more commas in
1699 -- a row
1700
1701 if Arg (Arg1_Idx) = ',' then
1702 Arg1_Idx := Arg1_Idx + 1;
1703 if Arg1_Idx > Arg'Last or else
1704 Arg (Arg1_Idx) = ','
1705 then
1706 Put_Line
1707 (Standard_Error,
1708 "Malformed Parameter: " &
1709 Arg.all);
1710 Put (Standard_Error, "usage: ");
1711 Put_Line (Standard_Error,
1712 Command.Usage.all);
1713 raise Error_Exit;
1714 end if;
1715 end if;
1716
1717 end loop;
1718 end;
1719 end case;
1720 end if;
1721
1722 -- Reset Output_File_Expected, in case it was True
1723
1724 Output_File_Expected := False;
1725
1726 -- Qualifier argument
1727
1728 else
1729 Output_File_Expected := False;
1730
1731 Cargs := Command.Name.all = "COMPILE";
1732
1733 -- This code is too heavily nested, should be
1734 -- separated out as separate subprogram ???
1735
1736 declare
1737 Sw : Item_Ptr;
1738 SwP : Natural;
1739 P2 : Natural;
1740 Endp : Natural := 0; -- avoid warning
1741 Opt : Item_Ptr;
1742
1743 begin
1744 SwP := Arg'First;
1745 while SwP < Arg'Last
1746 and then Arg (SwP + 1) /= '='
1747 loop
1748 SwP := SwP + 1;
1749 end loop;
1750
1751 -- At this point, the switch name is in
1752 -- Arg (Arg'First..SwP) and if that is not the
1753 -- whole switch, then there is an equal sign at
1754 -- Arg (SwP + 1) and the rest of Arg is what comes
1755 -- after the equal sign.
1756
1757 -- If make commands are active, see if we have
1758 -- another COMMANDS_TRANSLATION switch belonging
1759 -- to gnatmake.
1760
1761 if Make_Commands_Active /= null then
1762 Sw :=
1763 Matching_Name
1764 (Arg (Arg'First .. SwP),
1765 Command.Switches,
1766 Quiet => True);
1767
1768 if Sw /= null
1769 and then Sw.Translation = T_Commands
1770 then
1771 null;
1772
1773 else
1774 Sw :=
1775 Matching_Name
1776 (Arg (Arg'First .. SwP),
1777 Make_Commands_Active.Switches,
1778 Quiet => False);
1779 end if;
1780
1781 -- For case of GNAT MAKE or CHOP, if we cannot
1782 -- find the switch, then see if it is a
1783 -- recognized compiler switch instead, and if
1784 -- so process the compiler switch.
1785
1786 elsif Command.Name.all = "MAKE"
1787 or else
1788 Command.Name.all = "CHOP"
1789 then
1790 Sw :=
1791 Matching_Name
1792 (Arg (Arg'First .. SwP),
1793 Command.Switches,
1794 Quiet => True);
1795
1796 if Sw = null then
1797 Sw :=
1798 Matching_Name
1799 (Arg (Arg'First .. SwP),
1800 Matching_Name
1801 ("COMPILE", Commands).Switches,
1802 Quiet => False);
1803 end if;
1804
1805 -- For all other cases, just search the relevant
1806 -- command.
1807
1808 else
1809 Sw :=
1810 Matching_Name
1811 (Arg (Arg'First .. SwP),
1812 Command.Switches,
1813 Quiet => False);
1814
1815 -- Special case for GNAT COMPILE /UNCHECKED...
1816 -- because the corresponding switch --unchecked... is
1817 -- for gnatmake, not for the compiler.
1818
1819 if Cargs
1820 and then Sw.Name.all = "/UNCHECKED_SHARED_LIB_IMPORTS"
1821 then
1822 Cargs := False;
1823 end if;
1824 end if;
1825
1826 if Sw /= null then
1827 if Cargs
1828 and then Sw.Name /= null
1829 and then
1830 (Sw.Name.all = "/PROJECT_FILE" or else
1831 Sw.Name.all = "/MESSAGES_PROJECT_FILE" or else
1832 Sw.Name.all = "/EXTERNAL_REFERENCE")
1833 then
1834 Cargs := False;
1835 end if;
1836
1837 case Sw.Translation is
1838 when T_Direct =>
1839 Place_Unix_Switches (Sw.Unix_String);
1840
1841 if SwP < Arg'Last
1842 and then Arg (SwP + 1) = '='
1843 then
1844 Put (Standard_Error,
1845 "qualifier options ignored: ");
1846 Put_Line (Standard_Error, Arg.all);
1847 end if;
1848
1849 when T_Directories =>
1850 if SwP + 1 > Arg'Last then
1851 Put (Standard_Error,
1852 "missing directories for: ");
1853 Put_Line (Standard_Error, Arg.all);
1854 Errors := Errors + 1;
1855
1856 elsif Arg (SwP + 2) /= '(' then
1857 SwP := SwP + 2;
1858 Endp := Arg'Last;
1859
1860 elsif Arg (Arg'Last) /= ')' then
1861
1862 -- Remove spaces from a comma separated
1863 -- list of file names and adjust
1864 -- control variables accordingly.
1865
1866 if Arg_Num < Argument_Count and then
1867 (Argv (Argv'Last) = ',' xor
1868 Argument (Arg_Num + 1)
1869 (Argument (Arg_Num + 1)'First) = ',')
1870 then
1871 Argv :=
1872 new String'(Argv.all
1873 & Argument
1874 (Arg_Num + 1));
1875 Arg_Num := Arg_Num + 1;
1876 Arg_Idx := Argv'First;
1877 Next_Arg_Idx :=
1878 Get_Arg_End (Argv.all, Arg_Idx);
1879 Arg :=
1880 new String'(Argv (Arg_Idx .. Next_Arg_Idx));
1881 goto Tryagain_After_Coalesce;
1882 end if;
1883
1884 Put (Standard_Error,
1885 "incorrectly parenthesized " &
1886 "or malformed argument: ");
1887 Put_Line (Standard_Error, Arg.all);
1888 Errors := Errors + 1;
1889
1890 else
1891 SwP := SwP + 3;
1892 Endp := Arg'Last - 1;
1893 end if;
1894
1895 while SwP <= Endp loop
1896 declare
1897 Dir_Is_Wild : Boolean := False;
1898 Dir_Maybe_Is_Wild : Boolean := False;
1899
1900 Dir_List : String_Access_List_Access;
1901
1902 begin
1903 P2 := SwP;
1904
1905 while P2 < Endp
1906 and then Arg (P2 + 1) /= ','
1907 loop
1908 -- A wildcard directory spec on VMS will
1909 -- contain either * or % or ...
1910
1911 if Arg (P2) = '*' then
1912 Dir_Is_Wild := True;
1913
1914 elsif Arg (P2) = '%' then
1915 Dir_Is_Wild := True;
1916
1917 elsif Dir_Maybe_Is_Wild
1918 and then Arg (P2) = '.'
1919 and then Arg (P2 + 1) = '.'
1920 then
1921 Dir_Is_Wild := True;
1922 Dir_Maybe_Is_Wild := False;
1923
1924 elsif Dir_Maybe_Is_Wild then
1925 Dir_Maybe_Is_Wild := False;
1926
1927 elsif Arg (P2) = '.'
1928 and then Arg (P2 + 1) = '.'
1929 then
1930 Dir_Maybe_Is_Wild := True;
1931
1932 end if;
1933
1934 P2 := P2 + 1;
1935 end loop;
1936
1937 if Dir_Is_Wild then
1938 Dir_List :=
1939 To_Canonical_File_List
1940 (Arg (SwP .. P2), True);
1941
1942 for J in Dir_List.all'Range loop
1943 Place_Unix_Switches (Sw.Unix_String);
1944 Place_Lower (Dir_List.all (J).all);
1945 end loop;
1946
1947 else
1948 Place_Unix_Switches (Sw.Unix_String);
1949 Place_Lower
1950 (To_Canonical_Dir_Spec
1951 (Arg (SwP .. P2), False).all);
1952 end if;
1953
1954 SwP := P2 + 2;
1955 end;
1956 end loop;
1957
1958 when T_Directory =>
1959 if SwP + 1 > Arg'Last then
1960 Put (Standard_Error,
1961 "missing directory for: ");
1962 Put_Line (Standard_Error, Arg.all);
1963 Errors := Errors + 1;
1964
1965 else
1966 Place_Unix_Switches (Sw.Unix_String);
1967
1968 -- Some switches end in "=", no space here
1969
1970 if Sw.Unix_String
1971 (Sw.Unix_String'Last) /= '='
1972 then
1973 Place (' ');
1974 end if;
1975
1976 Place_Lower
1977 (To_Canonical_Dir_Spec
1978 (Arg (SwP + 2 .. Arg'Last), False).all);
1979 end if;
1980
1981 when T_File | T_No_Space_File =>
1982 if SwP + 2 > Arg'Last then
1983 Put (Standard_Error, "missing file for: ");
1984 Put_Line (Standard_Error, Arg.all);
1985 Errors := Errors + 1;
1986
1987 else
1988 Place_Unix_Switches (Sw.Unix_String);
1989
1990 -- Some switches end in "=", no space here.
1991
1992 if Sw.Translation = T_File
1993 and then Sw.Unix_String
1994 (Sw.Unix_String'Last) /= '='
1995 then
1996 Place (' ');
1997 end if;
1998
1999 Place_Lower
2000 (To_Canonical_File_Spec
2001 (Arg (SwP + 2 .. Arg'Last)).all);
2002 end if;
2003
2004 when T_Numeric =>
2005 if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then
2006 Place_Unix_Switches (Sw.Unix_String);
2007 Place (Arg (SwP + 2 .. Arg'Last));
2008
2009 else
2010 Put (Standard_Error, "argument for ");
2011 Put (Standard_Error, Sw.Name.all);
2012 Put_Line (Standard_Error, " must be numeric");
2013 Errors := Errors + 1;
2014 end if;
2015
2016 when T_Alphanumplus =>
2017 if OK_Alphanumerplus
2018 (Arg (SwP + 2 .. Arg'Last))
2019 then
2020 Place_Unix_Switches (Sw.Unix_String);
2021 Place (Arg (SwP + 2 .. Arg'Last));
2022
2023 else
2024 Put (Standard_Error, "argument for ");
2025 Put (Standard_Error, Sw.Name.all);
2026 Put_Line (Standard_Error,
2027 " must be alphanumeric");
2028 Errors := Errors + 1;
2029 end if;
2030
2031 when T_String =>
2032
2033 -- A String value must be extended to the end of
2034 -- the Argv, otherwise strings like "foo/bar" get
2035 -- split at the slash.
2036
2037 -- The beginning and ending of the string are
2038 -- flagged with embedded nulls which are removed
2039 -- when building the Spawn call. Nulls are use
2040 -- because they won't show up in a /? output.
2041 -- Quotes aren't used because that would make it
2042 -- difficult to embed them.
2043
2044 Place_Unix_Switches (Sw.Unix_String);
2045
2046 if Next_Arg_Idx /= Argv'Last then
2047 Next_Arg_Idx := Argv'Last;
2048 Arg :=
2049 new String'(Argv (Arg_Idx .. Next_Arg_Idx));
2050
2051 SwP := Arg'First;
2052 while SwP < Arg'Last
2053 and then Arg (SwP + 1) /= '='
2054 loop
2055 SwP := SwP + 1;
2056 end loop;
2057 end if;
2058
2059 Place (ASCII.NUL);
2060 Place (Arg (SwP + 2 .. Arg'Last));
2061 Place (ASCII.NUL);
2062
2063 when T_Commands =>
2064
2065 -- Output -largs/-bargs/-cargs
2066
2067 Place (' ');
2068 Place (Sw.Unix_String
2069 (Sw.Unix_String'First ..
2070 Sw.Unix_String'First + 5));
2071
2072 if Sw.Unix_String
2073 (Sw.Unix_String'First + 7 ..
2074 Sw.Unix_String'Last) = "MAKE"
2075 then
2076 Make_Commands_Active := null;
2077
2078 else
2079 -- Set source of new commands, also setting this
2080 -- non-null indicates that we are in the special
2081 -- commands mode for processing the -xargs case.
2082
2083 Make_Commands_Active :=
2084 Matching_Name
2085 (Sw.Unix_String
2086 (Sw.Unix_String'First + 7 ..
2087 Sw.Unix_String'Last),
2088 Commands);
2089 end if;
2090
2091 when T_Options =>
2092 if SwP + 1 > Arg'Last then
2093 Place_Unix_Switches (Sw.Options.Unix_String);
2094 SwP := Endp + 1;
2095
2096 elsif Arg (SwP + 2) /= '(' then
2097 SwP := SwP + 2;
2098 Endp := Arg'Last;
2099
2100 elsif Arg (Arg'Last) /= ')' then
2101 Put (Standard_Error,
2102 "incorrectly parenthesized argument: ");
2103 Put_Line (Standard_Error, Arg.all);
2104 Errors := Errors + 1;
2105 SwP := Endp + 1;
2106
2107 else
2108 SwP := SwP + 3;
2109 Endp := Arg'Last - 1;
2110 end if;
2111
2112 while SwP <= Endp loop
2113 P2 := SwP;
2114 while P2 < Endp
2115 and then Arg (P2 + 1) /= ','
2116 loop
2117 P2 := P2 + 1;
2118 end loop;
2119
2120 -- Option name is in Arg (SwP .. P2)
2121
2122 Opt := Matching_Name (Arg (SwP .. P2),
2123 Sw.Options);
2124
2125 if Opt /= null then
2126 Place_Unix_Switches (Opt.Unix_String);
2127 end if;
2128
2129 SwP := P2 + 2;
2130 end loop;
2131
2132 when T_Other =>
2133 Place_Unix_Switches
2134 (new String'(Sw.Unix_String.all & Arg.all));
2135
2136 end case;
2137 end if;
2138 end;
2139 end if;
2140
2141 Arg_Idx := Next_Arg_Idx + 1;
2142 end;
2143
2144 exit when Arg_Idx > Argv'Last;
2145
2146 end loop;
2147
2148 if not Is_Open (Arg_File) then
2149 Arg_Num := Arg_Num + 1;
2150 end if;
2151 end Process_Argument;
2152
2153 --------------------
2154 -- Process_Buffer --
2155 --------------------
2156
2157 procedure Process_Buffer (S : String) is
2158 P1, P2 : Natural;
2159 Inside_Nul : Boolean := False;
2160 Arg : String (1 .. 1024);
2161 Arg_Ctr : Natural;
2162
2163 begin
2164 P1 := 1;
2165 while P1 <= S'Last and then S (P1) = ' ' loop
2166 P1 := P1 + 1;
2167 end loop;
2168
2169 Arg_Ctr := 1;
2170 Arg (Arg_Ctr) := S (P1);
2171
2172 while P1 <= S'Last loop
2173 if S (P1) = ASCII.NUL then
2174 if Inside_Nul then
2175 Inside_Nul := False;
2176 else
2177 Inside_Nul := True;
2178 end if;
2179 end if;
2180
2181 if S (P1) = ' ' and then not Inside_Nul then
2182 P1 := P1 + 1;
2183 Arg_Ctr := Arg_Ctr + 1;
2184 Arg (Arg_Ctr) := S (P1);
2185
2186 else
2187 Last_Switches.Increment_Last;
2188 P2 := P1;
2189
2190 while P2 < S'Last
2191 and then (S (P2 + 1) /= ' ' or else
2192 Inside_Nul)
2193 loop
2194 P2 := P2 + 1;
2195 Arg_Ctr := Arg_Ctr + 1;
2196 Arg (Arg_Ctr) := S (P2);
2197 if S (P2) = ASCII.NUL then
2198 Arg_Ctr := Arg_Ctr - 1;
2199
2200 if Inside_Nul then
2201 Inside_Nul := False;
2202 else
2203 Inside_Nul := True;
2204 end if;
2205 end if;
2206 end loop;
2207
2208 Last_Switches.Table (Last_Switches.Last) :=
2209 new String'(String (Arg (1 .. Arg_Ctr)));
2210 P1 := P2 + 2;
2211
2212 exit when P1 > S'Last;
2213
2214 Arg_Ctr := 1;
2215 Arg (Arg_Ctr) := S (P1);
2216 end if;
2217 end loop;
2218 end Process_Buffer;
2219
2220 --------------------------------
2221 -- Validate_Command_Or_Option --
2222 --------------------------------
2223
2224 procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is
2225 begin
2226 pragma Assert (N'Length > 0);
2227
2228 for J in N'Range loop
2229 if N (J) = '_' then
2230 pragma Assert (N (J - 1) /= '_');
2231 null;
2232 else
2233 pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
2234 null;
2235 end if;
2236 end loop;
2237 end Validate_Command_Or_Option;
2238
2239 --------------------------
2240 -- Validate_Unix_Switch --
2241 --------------------------
2242
2243 procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is
2244 begin
2245 if S (S'First) = '`' then
2246 return;
2247 end if;
2248
2249 pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
2250
2251 for J in S'First + 1 .. S'Last loop
2252 pragma Assert (S (J) /= ' ');
2253
2254 if S (J) = '!' then
2255 pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
2256 null;
2257 end if;
2258 end loop;
2259 end Validate_Unix_Switch;
2260
2261 --------------------
2262 -- VMS_Conversion --
2263 --------------------
2264
2265 procedure VMS_Conversion (The_Command : out Command_Type) is
2266 Result : Command_Type := Undefined;
2267 Result_Set : Boolean := False;
2268
2269 begin
2270 Buffer.Init;
2271
2272 -- First we must preprocess the string form of the command and options
2273 -- list into the internal form that we use.
2274
2275 Preprocess_Command_Data;
2276
2277 -- If no parameters, give complete list of commands
2278
2279 if Argument_Count = 0 then
2280 Output_Version;
2281 New_Line;
2282 Put_Line ("List of available commands");
2283 New_Line;
2284
2285 while Commands /= null loop
2286
2287 -- No usage for GNAT SYNC
2288
2289 if Commands.Command /= Sync then
2290 Put (Commands.Usage.all);
2291 Set_Col (53);
2292 Put_Line (Commands.Unix_String.all);
2293 end if;
2294
2295 Commands := Commands.Next;
2296 end loop;
2297
2298 raise Normal_Exit;
2299 end if;
2300
2301 -- Loop through arguments
2302
2303 Arg_Num := 1;
2304 while Arg_Num <= Argument_Count loop
2305 Process_Argument (Result);
2306
2307 if not Result_Set then
2308 The_Command := Result;
2309 Result_Set := True;
2310 end if;
2311 end loop;
2312
2313 -- Gross error checking that the number of parameters is correct.
2314 -- Not applicable to Unlimited_Files parameters.
2315
2316 if (Param_Count = Command.Params'Length - 1
2317 and then Command.Params (Param_Count + 1) = Unlimited_Files)
2318 or else Param_Count <= Command.Params'Length
2319 then
2320 null;
2321
2322 else
2323 Put_Line (Standard_Error,
2324 "Parameter count of "
2325 & Integer'Image (Param_Count)
2326 & " not equal to expected "
2327 & Integer'Image (Command.Params'Length));
2328 Put (Standard_Error, "usage: ");
2329 Put_Line (Standard_Error, Command.Usage.all);
2330 Errors := Errors + 1;
2331 end if;
2332
2333 if Errors > 0 then
2334 raise Error_Exit;
2335 else
2336 -- Prepare arguments for a call to spawn, filtering out
2337 -- embedded nulls place there to delineate strings.
2338
2339 Process_Buffer (String (Buffer.Table (1 .. Buffer.Last)));
2340
2341 if Cargs_Buffer.Last > 1 then
2342 Last_Switches.Append (new String'("-cargs"));
2343 Process_Buffer
2344 (String (Cargs_Buffer.Table (1 .. Cargs_Buffer.Last)));
2345 end if;
2346 end if;
2347 end VMS_Conversion;
2348
2349 end VMS_Conv;
Mirror of the offical gcc git repository hosted at gcc.gnu.org