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