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