?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2013-05-03 Richard Biener <rguenther@suse.de>
[official-gcc.git] / gcc / ada / vms_conv.adb
bloba499b9dd2d62264d50386bad01421b33da2e0e82
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-2012, 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 Command.Name.all = "CHOP" then
1788 Sw :=
1789 Matching_Name
1790 (Arg (Arg'First .. SwP),
1791 Command.Switches,
1792 Quiet => True);
1793
1794 if Sw = null then
1795 Sw :=
1796 Matching_Name
1797 (Arg (Arg'First .. SwP),
1798 Matching_Name
1799 ("COMPILE", Commands).Switches,
1800 Quiet => False);
1801 end if;
1802
1803 -- For all other cases, just search the relevant
1804 -- command.
1805
1806 else
1807 Sw :=
1808 Matching_Name
1809 (Arg (Arg'First .. SwP),
1810 Command.Switches,
1811 Quiet => False);
1812
1813 -- Special case for GNAT COMPILE /UNCHECKED...
1814 -- because the corresponding switch --unchecked... is
1815 -- for gnatmake, not for the compiler.
1816
1817 if Cargs
1818 and then Sw.Name.all = "/UNCHECKED_SHARED_LIB_IMPORTS"
1819 then
1820 Cargs := False;
1821 end if;
1822 end if;
1823
1824 if Sw /= null then
1825 if Cargs
1826 and then Sw.Name /= null
1827 and then
1828 (Sw.Name.all = "/PROJECT_FILE" or else
1829 Sw.Name.all = "/MESSAGES_PROJECT_FILE" or else
1830 Sw.Name.all = "/EXTERNAL_REFERENCE")
1831 then
1832 Cargs := False;
1833 end if;
1834
1835 case Sw.Translation is
1836 when T_Direct =>
1837 Place_Unix_Switches (Sw.Unix_String);
1838
1839 if SwP < Arg'Last
1840 and then Arg (SwP + 1) = '='
1841 then
1842 Put (Standard_Error,
1843 "qualifier options ignored: ");
1844 Put_Line (Standard_Error, Arg.all);
1845 end if;
1846
1847 when T_Directories =>
1848 if SwP + 1 > Arg'Last then
1849 Put (Standard_Error,
1850 "missing directories for: ");
1851 Put_Line (Standard_Error, Arg.all);
1852 Errors := Errors + 1;
1853
1854 elsif Arg (SwP + 2) /= '(' then
1855 SwP := SwP + 2;
1856 Endp := Arg'Last;
1857
1858 elsif Arg (Arg'Last) /= ')' then
1859
1860 -- Remove spaces from a comma separated
1861 -- list of file names and adjust
1862 -- control variables accordingly.
1863
1864 if Arg_Num < Argument_Count and then
1865 (Argv (Argv'Last) = ',' xor
1866 Argument (Arg_Num + 1)
1867 (Argument (Arg_Num + 1)'First) = ',')
1868 then
1869 Argv :=
1870 new String'(Argv.all
1871 & Argument
1872 (Arg_Num + 1));
1873 Arg_Num := Arg_Num + 1;
1874 Arg_Idx := Argv'First;
1875 Next_Arg_Idx :=
1876 Get_Arg_End (Argv.all, Arg_Idx);
1877 Arg :=
1878 new String'(Argv (Arg_Idx .. Next_Arg_Idx));
1879 goto Tryagain_After_Coalesce;
1880 end if;
1881
1882 Put (Standard_Error,
1883 "incorrectly parenthesized " &
1884 "or malformed argument: ");
1885 Put_Line (Standard_Error, Arg.all);
1886 Errors := Errors + 1;
1887
1888 else
1889 SwP := SwP + 3;
1890 Endp := Arg'Last - 1;
1891 end if;
1892
1893 while SwP <= Endp loop
1894 declare
1895 Dir_Is_Wild : Boolean := False;
1896 Dir_Maybe_Is_Wild : Boolean := False;
1897
1898 Dir_List : String_Access_List_Access;
1899
1900 begin
1901 P2 := SwP;
1902
1903 while P2 < Endp
1904 and then Arg (P2 + 1) /= ','
1905 loop
1906 -- A wildcard directory spec on VMS will
1907 -- contain either * or % or ...
1908
1909 if Arg (P2) = '*' then
1910 Dir_Is_Wild := True;
1911
1912 elsif Arg (P2) = '%' then
1913 Dir_Is_Wild := True;
1914
1915 elsif Dir_Maybe_Is_Wild
1916 and then Arg (P2) = '.'
1917 and then Arg (P2 + 1) = '.'
1918 then
1919 Dir_Is_Wild := True;
1920 Dir_Maybe_Is_Wild := False;
1921
1922 elsif Dir_Maybe_Is_Wild then
1923 Dir_Maybe_Is_Wild := False;
1924
1925 elsif Arg (P2) = '.'
1926 and then Arg (P2 + 1) = '.'
1927 then
1928 Dir_Maybe_Is_Wild := True;
1929
1930 end if;
1931
1932 P2 := P2 + 1;
1933 end loop;
1934
1935 if Dir_Is_Wild then
1936 Dir_List :=
1937 To_Canonical_File_List
1938 (Arg (SwP .. P2), True);
1939
1940 for J in Dir_List.all'Range loop
1941 Place_Unix_Switches (Sw.Unix_String);
1942 Place_Lower (Dir_List.all (J).all);
1943 end loop;
1944
1945 else
1946 Place_Unix_Switches (Sw.Unix_String);
1947 Place_Lower
1948 (To_Canonical_Dir_Spec
1949 (Arg (SwP .. P2), False).all);
1950 end if;
1951
1952 SwP := P2 + 2;
1953 end;
1954 end loop;
1955
1956 when T_Directory =>
1957 if SwP + 1 > Arg'Last then
1958 Put (Standard_Error,
1959 "missing directory for: ");
1960 Put_Line (Standard_Error, Arg.all);
1961 Errors := Errors + 1;
1962
1963 else
1964 Place_Unix_Switches (Sw.Unix_String);
1965
1966 -- Some switches end in "=", no space here
1967
1968 if Sw.Unix_String
1969 (Sw.Unix_String'Last) /= '='
1970 then
1971 Place (' ');
1972 end if;
1973
1974 Place_Lower
1975 (To_Canonical_Dir_Spec
1976 (Arg (SwP + 2 .. Arg'Last), False).all);
1977 end if;
1978
1979 when T_File | T_No_Space_File =>
1980 if SwP + 2 > Arg'Last then
1981 Put (Standard_Error, "missing file for: ");
1982 Put_Line (Standard_Error, Arg.all);
1983 Errors := Errors + 1;
1984
1985 else
1986 Place_Unix_Switches (Sw.Unix_String);
1987
1988 -- Some switches end in "=", no space here.
1989
1990 if Sw.Translation = T_File
1991 and then Sw.Unix_String
1992 (Sw.Unix_String'Last) /= '='
1993 then
1994 Place (' ');
1995 end if;
1996
1997 Place_Lower
1998 (To_Canonical_File_Spec
1999 (Arg (SwP + 2 .. Arg'Last)).all);
2000 end if;
2001
2002 when T_Numeric =>
2003 if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then
2004 Place_Unix_Switches (Sw.Unix_String);
2005 Place (Arg (SwP + 2 .. Arg'Last));
2006
2007 else
2008 Put (Standard_Error, "argument for ");
2009 Put (Standard_Error, Sw.Name.all);
2010 Put_Line (Standard_Error, " must be numeric");
2011 Errors := Errors + 1;
2012 end if;
2013
2014 when T_Alphanumplus =>
2015 if OK_Alphanumerplus
2016 (Arg (SwP + 2 .. Arg'Last))
2017 then
2018 Place_Unix_Switches (Sw.Unix_String);
2019 Place (Arg (SwP + 2 .. Arg'Last));
2020
2021 else
2022 Put (Standard_Error, "argument for ");
2023 Put (Standard_Error, Sw.Name.all);
2024 Put_Line (Standard_Error,
2025 " must be alphanumeric");
2026 Errors := Errors + 1;
2027 end if;
2028
2029 when T_String =>
2030
2031 -- A String value must be extended to the end of
2032 -- the Argv, otherwise strings like "foo/bar" get
2033 -- split at the slash.
2034
2035 -- The beginning and ending of the string are
2036 -- flagged with embedded nulls which are removed
2037 -- when building the Spawn call. Nulls are use
2038 -- because they won't show up in a /? output.
2039 -- Quotes aren't used because that would make it
2040 -- difficult to embed them.
2041
2042 Place_Unix_Switches (Sw.Unix_String);
2043
2044 if Next_Arg_Idx /= Argv'Last then
2045 Next_Arg_Idx := Argv'Last;
2046 Arg :=
2047 new String'(Argv (Arg_Idx .. Next_Arg_Idx));
2048
2049 SwP := Arg'First;
2050 while SwP < Arg'Last
2051 and then Arg (SwP + 1) /= '='
2052 loop
2053 SwP := SwP + 1;
2054 end loop;
2055 end if;
2056
2057 Place (ASCII.NUL);
2058 Place (Arg (SwP + 2 .. Arg'Last));
2059 Place (ASCII.NUL);
2060
2061 when T_Commands =>
2062
2063 -- Output -largs/-bargs/-cargs
2064
2065 Place (' ');
2066 Place (Sw.Unix_String
2067 (Sw.Unix_String'First ..
2068 Sw.Unix_String'First + 5));
2069
2070 if Sw.Unix_String
2071 (Sw.Unix_String'First + 7 ..
2072 Sw.Unix_String'Last) = "MAKE"
2073 then
2074 Make_Commands_Active := null;
2075
2076 else
2077 -- Set source of new commands, also setting this
2078 -- non-null indicates that we are in the special
2079 -- commands mode for processing the -xargs case.
2080
2081 Make_Commands_Active :=
2082 Matching_Name
2083 (Sw.Unix_String
2084 (Sw.Unix_String'First + 7 ..
2085 Sw.Unix_String'Last),
2086 Commands);
2087 end if;
2088
2089 when T_Options =>
2090 if SwP + 1 > Arg'Last then
2091 Place_Unix_Switches (Sw.Options.Unix_String);
2092 SwP := Endp + 1;
2093
2094 elsif Arg (SwP + 2) /= '(' then
2095 SwP := SwP + 2;
2096 Endp := Arg'Last;
2097
2098 elsif Arg (Arg'Last) /= ')' then
2099 Put (Standard_Error,
2100 "incorrectly parenthesized argument: ");
2101 Put_Line (Standard_Error, Arg.all);
2102 Errors := Errors + 1;
2103 SwP := Endp + 1;
2104
2105 else
2106 SwP := SwP + 3;
2107 Endp := Arg'Last - 1;
2108 end if;
2109
2110 while SwP <= Endp loop
2111 P2 := SwP;
2112 while P2 < Endp
2113 and then Arg (P2 + 1) /= ','
2114 loop
2115 P2 := P2 + 1;
2116 end loop;
2117
2118 -- Option name is in Arg (SwP .. P2)
2119
2120 Opt := Matching_Name (Arg (SwP .. P2),
2121 Sw.Options);
2122
2123 if Opt /= null then
2124 Place_Unix_Switches (Opt.Unix_String);
2125 end if;
2126
2127 SwP := P2 + 2;
2128 end loop;
2129
2130 when T_Other =>
2131 Place_Unix_Switches
2132 (new String'(Sw.Unix_String.all & Arg.all));
2133
2134 end case;
2135 end if;
2136 end;
2137 end if;
2138
2139 Arg_Idx := Next_Arg_Idx + 1;
2140 end;
2141
2142 exit when Arg_Idx > Argv'Last;
2143
2144 end loop;
2145
2146 if not Is_Open (Arg_File) then
2147 Arg_Num := Arg_Num + 1;
2148 end if;
2149 end Process_Argument;
2150
2151 --------------------
2152 -- Process_Buffer --
2153 --------------------
2154
2155 procedure Process_Buffer (S : String) is
2156 P1, P2 : Natural;
2157 Inside_Nul : Boolean := False;
2158 Arg : String (1 .. 1024);
2159 Arg_Ctr : Natural;
2160
2161 begin
2162 P1 := 1;
2163 while P1 <= S'Last and then S (P1) = ' ' loop
2164 P1 := P1 + 1;
2165 end loop;
2166
2167 Arg_Ctr := 1;
2168 Arg (Arg_Ctr) := S (P1);
2169
2170 while P1 <= S'Last loop
2171 if S (P1) = ASCII.NUL then
2172 if Inside_Nul then
2173 Inside_Nul := False;
2174 else
2175 Inside_Nul := True;
2176 end if;
2177 end if;
2178
2179 if S (P1) = ' ' and then not Inside_Nul then
2180 P1 := P1 + 1;
2181 Arg_Ctr := Arg_Ctr + 1;
2182 Arg (Arg_Ctr) := S (P1);
2183
2184 else
2185 Last_Switches.Increment_Last;
2186 P2 := P1;
2187
2188 while P2 < S'Last
2189 and then (S (P2 + 1) /= ' ' or else
2190 Inside_Nul)
2191 loop
2192 P2 := P2 + 1;
2193 Arg_Ctr := Arg_Ctr + 1;
2194 Arg (Arg_Ctr) := S (P2);
2195 if S (P2) = ASCII.NUL then
2196 Arg_Ctr := Arg_Ctr - 1;
2197
2198 if Inside_Nul then
2199 Inside_Nul := False;
2200 else
2201 Inside_Nul := True;
2202 end if;
2203 end if;
2204 end loop;
2205
2206 Last_Switches.Table (Last_Switches.Last) :=
2207 new String'(String (Arg (1 .. Arg_Ctr)));
2208 P1 := P2 + 2;
2209
2210 exit when P1 > S'Last;
2211
2212 Arg_Ctr := 1;
2213 Arg (Arg_Ctr) := S (P1);
2214 end if;
2215 end loop;
2216 end Process_Buffer;
2217
2218 --------------------------------
2219 -- Validate_Command_Or_Option --
2220 --------------------------------
2221
2222 procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is
2223 begin
2224 pragma Assert (N'Length > 0);
2225
2226 for J in N'Range loop
2227 if N (J) = '_' then
2228 pragma Assert (N (J - 1) /= '_');
2229 null;
2230 else
2231 pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
2232 null;
2233 end if;
2234 end loop;
2235 end Validate_Command_Or_Option;
2236
2237 --------------------------
2238 -- Validate_Unix_Switch --
2239 --------------------------
2240
2241 procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is
2242 begin
2243 if S (S'First) = '`' then
2244 return;
2245 end if;
2246
2247 pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
2248
2249 for J in S'First + 1 .. S'Last loop
2250 pragma Assert (S (J) /= ' ');
2251
2252 if S (J) = '!' then
2253 pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
2254 null;
2255 end if;
2256 end loop;
2257 end Validate_Unix_Switch;
2258
2259 --------------------
2260 -- VMS_Conversion --
2261 --------------------
2262
2263 procedure VMS_Conversion (The_Command : out Command_Type) is
2264 Result : Command_Type := Undefined;
2265 Result_Set : Boolean := False;
2266
2267 begin
2268 Buffer.Init;
2269
2270 -- First we must preprocess the string form of the command and options
2271 -- list into the internal form that we use.
2272
2273 Preprocess_Command_Data;
2274
2275 -- If no parameters, give complete list of commands
2276
2277 if Argument_Count = 0 then
2278 Output_Version;
2279 New_Line;
2280 Put_Line ("List of available commands");
2281 New_Line;
2282
2283 while Commands /= null loop
2284
2285 -- No usage for GNAT SYNC
2286
2287 if Commands.Command /= Sync then
2288 Put (Commands.Usage.all);
2289 Set_Col (53);
2290 Put_Line (Commands.Unix_String.all);
2291 end if;
2292
2293 Commands := Commands.Next;
2294 end loop;
2295
2296 raise Normal_Exit;
2297 end if;
2298
2299 -- Loop through arguments
2300
2301 Arg_Num := 1;
2302 while Arg_Num <= Argument_Count loop
2303 Process_Argument (Result);
2304
2305 if not Result_Set then
2306 The_Command := Result;
2307 Result_Set := True;
2308 end if;
2309 end loop;
2310
2311 -- Gross error checking that the number of parameters is correct.
2312 -- Not applicable to Unlimited_Files parameters.
2313
2314 if (Param_Count = Command.Params'Length - 1
2315 and then Command.Params (Param_Count + 1) = Unlimited_Files)
2316 or else Param_Count <= Command.Params'Length
2317 then
2318 null;
2319
2320 else
2321 Put_Line (Standard_Error,
2322 "Parameter count of "
2323 & Integer'Image (Param_Count)
2324 & " not equal to expected "
2325 & Integer'Image (Command.Params'Length));
2326 Put (Standard_Error, "usage: ");
2327 Put_Line (Standard_Error, Command.Usage.all);
2328 Errors := Errors + 1;
2329 end if;
2330
2331 if Errors > 0 then
2332 raise Error_Exit;
2333 else
2334 -- Prepare arguments for a call to spawn, filtering out
2335 -- embedded nulls place there to delineate strings.
2336
2337 Process_Buffer (String (Buffer.Table (1 .. Buffer.Last)));
2338
2339 if Cargs_Buffer.Last > 1 then
2340 Last_Switches.Append (new String'("-cargs"));
2341 Process_Buffer
2342 (String (Cargs_Buffer.Table (1 .. Cargs_Buffer.Last)));
2343 end if;
2344 end if;
2345 end VMS_Conversion;
2346
2347 end VMS_Conv;
Mirror of the offical gcc git repository hosted at gcc.gnu.org