1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2004 Free Software Foundation, Inc. --
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. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
29 with Osint
; use Osint
;
31 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
32 with Ada
.Command_Line
; use Ada
.Command_Line
;
33 with Ada
.Text_IO
; use Ada
.Text_IO
;
35 package body VMS_Conv
is
37 Param_Count
: Natural := 0;
38 -- Number of parameter arguments so far
43 Arg_File
: Ada
.Text_IO
.File_Type
;
44 -- A file where arguments are read from
47 -- Pointer to head of list of command items, one for each command, with
48 -- the end of the list marked by a null pointer.
50 Last_Command
: Item_Ptr
;
51 -- Pointer to last item in Commands list
54 -- Pointer to command item for current command
56 Make_Commands_Active
: Item_Ptr
:= null;
57 -- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate
58 -- if a COMMANDS_TRANSLATION switch has been encountered while processing
61 Output_File_Expected
: Boolean := False;
62 -- True for GNAT LINK after -o switch, so that the ".ali" extension is
63 -- not added to the executable file name.
65 package Buffer
is new Table
.Table
66 (Table_Component_Type
=> Character,
67 Table_Index_Type
=> Integer,
69 Table_Initial
=> 4096,
71 Table_Name
=> "Buffer");
73 function Init_Object_Dirs
return Argument_List
;
74 -- Get the list of the object directories
76 function Invert_Sense
(S
: String) return VMS_Data
.String_Ptr
;
77 -- Given a unix switch string S, computes the inverse (adding or
78 -- removing ! characters as required), and returns a pointer to
79 -- the allocated result on the heap.
81 function Is_Extensionless
(F
: String) return Boolean;
82 -- Returns true if the filename has no extension.
84 function Match
(S1
, S2
: String) return Boolean;
85 -- Determines whether S1 and S2 match. This is a case insensitive match.
87 function Match_Prefix
(S1
, S2
: String) return Boolean;
88 -- Determines whether S1 matches a prefix of S2. This is also a case
89 -- insensitive match (for example Match ("AB","abc") is True).
91 function Matching_Name
94 Quiet
: Boolean := False) return Item_Ptr
;
95 -- Determines if the item list headed by Itm and threaded through the
96 -- Next fields (with null marking the end of the list), contains an
97 -- entry that uniquely matches the given string. The match is case
98 -- insensitive and permits unique abbreviation. If the match succeeds,
99 -- then a pointer to the matching item is returned. Otherwise, an
100 -- appropriate error message is written. Note that the discriminant
101 -- of Itm is used to determine the appropriate form of this message.
102 -- Quiet is normally False as shown, if it is set to True, then no
103 -- error message is generated in a not found situation (null is still
104 -- returned to indicate the not-found situation).
106 function OK_Alphanumerplus
(S
: String) return Boolean;
107 -- Checks that S is a string of alphanumeric characters,
108 -- returning True if all alphanumeric characters,
109 -- False if empty or a non-alphanumeric character is present.
111 function OK_Integer
(S
: String) return Boolean;
112 -- Checks that S is a string of digits, returning True if all digits,
113 -- False if empty or a non-digit is present.
115 procedure Place
(C
: Character);
116 -- Place a single character in the buffer, updating Ptr
118 procedure Place
(S
: String);
119 -- Place a string character in the buffer, updating Ptr
121 procedure Place_Lower
(S
: String);
122 -- Place string in buffer, forcing letters to lower case, updating Ptr
124 procedure Place_Unix_Switches
(S
: VMS_Data
.String_Ptr
);
125 -- Given a unix switch string, place corresponding switches in Buffer,
126 -- updating Ptr appropriatelly. Note that in the case of use of ! the
127 -- result may be to remove a previously placed switch.
129 procedure Preprocess_Command_Data
;
130 -- Preprocess the string form of the command and options list into the
133 procedure Process_Argument
(The_Command
: in out Command_Type
);
134 -- Process one argument from the command line, or one line from
135 -- from a command line file. For the first call, set The_Command.
137 procedure Validate_Command_Or_Option
(N
: VMS_Data
.String_Ptr
);
138 -- Check that N is a valid command or option name, i.e. that it is of the
139 -- form of an Ada identifier with upper case letters and underscores.
141 procedure Validate_Unix_Switch
(S
: VMS_Data
.String_Ptr
);
142 -- Check that S is a valid switch string as described in the syntax for
143 -- the switch table item UNIX_SWITCH or else begins with a backquote.
145 ----------------------
146 -- Init_Object_Dirs --
147 ----------------------
149 function Init_Object_Dirs
return Argument_List
is
150 Object_Dirs
: Integer;
151 Object_Dir
: Argument_List
(1 .. 256);
152 Object_Dir_Name
: String_Access
;
156 Object_Dir_Name
:= new String'(Object_Dir_Default_Prefix);
157 Get_Next_Dir_In_Path_Init (Object_Dir_Name);
161 Dir : constant String_Access :=
162 String_Access (Get_Next_Dir_In_Path (Object_Dir_Name));
164 exit when Dir = null;
165 Object_Dirs := Object_Dirs + 1;
166 Object_Dir (Object_Dirs) :=
168 To_Canonical_Dir_Spec
170 (Normalize_Directory_Name
(Dir
.all).all,
171 True).all, True).all);
175 Object_Dirs
:= Object_Dirs
+ 1;
176 Object_Dir
(Object_Dirs
) := new String'("-lgnat");
178 if Hostparm.OpenVMS then
179 Object_Dirs := Object_Dirs + 1;
180 Object_Dir (Object_Dirs) := new String'("-ldecgnat");
183 return Object_Dir
(1 .. Object_Dirs
);
184 end Init_Object_Dirs
;
190 procedure Initialize
is
194 (Cname
=> new S
'("BIND"),
195 Usage => new S'("GNAT BIND file[.ali] /qualifiers"),
197 Unixcmd
=> new S
'("gnatbind"),
199 Switches => Bind_Switches'Access,
200 Params => new Parameter_Array'(1 => File
),
204 (Cname
=> new S
'("CHOP"),
205 Usage => new S'("GNAT CHOP file [directory] /qualifiers"),
207 Unixcmd
=> new S
'("gnatchop"),
209 Switches => Chop_Switches'Access,
210 Params => new Parameter_Array'(1 => File
, 2 => Optional_File
),
214 (Cname
=> new S
'("CLEAN"),
215 Usage => new S'("GNAT CLEAN /qualifiers files"),
217 Unixcmd
=> new S
'("gnatclean"),
219 Switches => Clean_Switches'Access,
220 Params => new Parameter_Array'(1 => File
),
224 (Cname
=> new S
'("COMPILE"),
225 Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"),
227 Unixcmd
=> new S
'("gnatmake"),
228 Unixsws => new Argument_List'(1 => new String'("-f"),
229 2 => new String'("-u"),
230 3 => new String'("-c")),
231 Switches => GCC_Switches'Access,
232 Params => new Parameter_Array'(1 => Files_Or_Wildcard
),
236 (Cname
=> new S
'("ELIM"),
237 Usage => new S'("GNAT ELIM name /qualifiers"),
239 Unixcmd
=> new S
'("gnatelim"),
241 Switches => Elim_Switches'Access,
242 Params => new Parameter_Array'(1 => Other_As_Is
),
246 (Cname
=> new S
'("FIND"),
247 Usage => new S'("GNAT FIND pattern[:sourcefile[:line"
248 & "[:column]]] filespec[,...] /qualifiers"),
250 Unixcmd
=> new S
'("gnatfind"),
252 Switches => Find_Switches'Access,
253 Params => new Parameter_Array'(1 => Other_As_Is
,
254 2 => Files_Or_Wildcard
),
258 (Cname
=> new S
'("KRUNCH"),
259 Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"),
261 Unixcmd
=> new S
'("gnatkr"),
263 Switches => Krunch_Switches'Access,
264 Params => new Parameter_Array'(1 => File
),
268 (Cname
=> new S
'("LIBRARY"),
269 Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]"
270 & "=directory [/CONFIG=file]"),
272 Unixcmd
=> new S
'("gnatlbr"),
274 Switches => Lbr_Switches'Access,
275 Params => new Parameter_Array'(1 .. 0 => File
),
279 (Cname
=> new S
'("LINK"),
280 Usage => new S'("GNAT LINK file[.ali]"
281 & " [extra obj_&_lib_&_exe_&_opt files]"
284 Unixcmd
=> new S
'("gnatlink"),
286 Switches => Link_Switches'Access,
287 Params => new Parameter_Array'(1 => Unlimited_Files
),
291 (Cname
=> new S
'("LIST"),
292 Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"),
294 Unixcmd
=> new S
'("gnatls"),
296 Switches => List_Switches'Access,
297 Params => new Parameter_Array'(1 => Unlimited_Files
),
301 (Cname
=> new S
'("MAKE"),
302 Usage => new S'("GNAT MAKE file(s) /qualifiers (includes "
303 & "COMPILE /qualifiers)"),
305 Unixcmd
=> new S
'("gnatmake"),
307 Switches => Make_Switches'Access,
308 Params => new Parameter_Array'(1 => Unlimited_Files
),
312 (Cname
=> new S
'("NAME"),
313 Usage => new S'("GNAT NAME /qualifiers naming-pattern "
314 & "[naming-patterns]"),
316 Unixcmd
=> new S
'("gnatname"),
318 Switches => Name_Switches'Access,
319 Params => new Parameter_Array'(1 => Unlimited_As_Is
),
323 (Cname
=> new S
'("PREPROCESS"),
325 new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"),
327 Unixcmd
=> new S
'("gnatprep"),
329 Switches => Prep_Switches'Access,
330 Params => new Parameter_Array'(1 .. 3 => File
),
334 (Cname
=> new S
'("PRETTY"),
335 Usage => new S'("GNAT PRETTY /qualifiers source_file"),
337 Unixcmd
=> new S
'("gnatpp"),
339 Switches => Pretty_Switches'Access,
340 Params => new Parameter_Array'(1 => Unlimited_Files
),
344 (Cname
=> new S
'("SHARED"),
345 Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt"
346 & "files] /qualifiers"),
348 Unixcmd
=> new S
'("gcc"),
350 new Argument_List'(new String'("-shared") & Init_Object_Dirs),
351 Switches => Shared_Switches'Access,
352 Params => new Parameter_Array'(1 => Unlimited_Files
),
356 (Cname
=> new S
'("STUB"),
357 Usage => new S'("GNAT STUB file [directory]/qualifiers"),
359 Unixcmd
=> new S
'("gnatstub"),
361 Switches => Stub_Switches'Access,
362 Params => new Parameter_Array'(1 => File
, 2 => Optional_File
),
366 (Cname
=> new S
'("XREF"),
367 Usage => new S'("GNAT XREF filespec[,...] /qualifiers"),
369 Unixcmd
=> new S
'("gnatxref"),
371 Switches => Xref_Switches'Access,
372 Params => new Parameter_Array'(1 => Files_Or_Wildcard
),
381 function Invert_Sense
(S
: String) return VMS_Data
.String_Ptr
is
382 Sinv
: String (1 .. S
'Length * 2);
383 -- Result (for sure long enough)
385 Sinvp
: Natural := 0;
386 -- Pointer to output string
389 for Sp
in S
'Range loop
390 if Sp
= S
'First or else S
(Sp
- 1) = ',' then
394 Sinv
(Sinvp
+ 1) := '!';
395 Sinv
(Sinvp
+ 2) := S
(Sp
);
400 Sinv
(Sinvp
+ 1) := S
(Sp
);
405 return new String'(Sinv (1 .. Sinvp));
408 ----------------------
409 -- Is_Extensionless --
410 ----------------------
412 function Is_Extensionless (F : String) return Boolean is
414 for J in reverse F'Range loop
417 elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then
423 end Is_Extensionless;
429 function Match (S1, S2 : String) return Boolean is
430 Dif : constant Integer := S2'First - S1'First;
434 if S1'Length /= S2'Length then
438 for J in S1'Range loop
439 if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then
452 function Match_Prefix (S1, S2 : String) return Boolean is
454 if S1'Length > S2'Length then
457 return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1));
465 function Matching_Name
468 Quiet : Boolean := False) return Item_Ptr
473 -- Little procedure to output command/qualifier/option as appropriate
474 -- and bump error count.
486 Errors := Errors + 1;
491 Put (Standard_Error, "command");
494 if Hostparm.OpenVMS then
495 Put (Standard_Error, "qualifier");
497 Put (Standard_Error, "switch");
501 Put (Standard_Error, "option");
505 Put (Standard_Error, "input");
509 Put (Standard_Error, ": ");
510 Put (Standard_Error, S);
513 -- Start of processing for Matching_Name
516 -- If exact match, that's the one we want
519 while P1 /= null loop
520 if Match (S, P1.Name.all) then
527 -- Now check for prefix matches
530 while P1 /= null loop
531 if P1.Name.all = "/<other>" then
534 elsif not Match_Prefix (S, P1.Name.all) then
538 -- Here we have found one matching prefix, so see if there is
539 -- another one (which is an ambiguity)
542 while P2 /= null loop
543 if Match_Prefix (S, P2.Name.all) then
545 Put (Standard_Error, "ambiguous ");
547 Put (Standard_Error, " (matches ");
548 Put (Standard_Error, P1.Name.all);
550 while P2 /= null loop
551 if Match_Prefix (S, P2.Name.all) then
552 Put (Standard_Error, ',');
553 Put (Standard_Error, P2.Name.all);
559 Put_Line (Standard_Error, ")");
568 -- If we fall through that loop, then there was only one match
574 -- If we fall through outer loop, there was no match
577 Put (Standard_Error, "unrecognized ");
579 New_Line (Standard_Error);
585 -----------------------
586 -- OK_Alphanumerplus --
587 -----------------------
589 function OK_Alphanumerplus (S : String) return Boolean is
595 for J in S'Range loop
596 if not (Is_Alphanumeric (S (J)) or else
597 S (J) = '_
' or else S (J) = '$
')
605 end OK_Alphanumerplus;
611 function OK_Integer (S : String) return Boolean is
617 for J in S'Range loop
618 if not Is_Digit (S (J)) then
631 procedure Output_Version is
634 Put (Gnatvsn.Gnat_Version_String);
635 Put_Line (" Copyright 1996-2004 Free Software Foundation, Inc.");
642 procedure Place (C : Character) is
644 Buffer.Increment_Last;
645 Buffer.Table (Buffer.Last) := C;
648 procedure Place (S : String) is
650 for J in S'Range loop
659 procedure Place_Lower (S : String) is
661 for J in S'Range loop
662 Place (To_Lower (S (J)));
666 -------------------------
667 -- Place_Unix_Switches --
668 -------------------------
670 procedure Place_Unix_Switches (S : VMS_Data.String_Ptr) is
671 P1, P2, P3 : Natural;
673 Slen, Sln2 : Natural;
674 Wild_Card : Boolean := False;
678 while P1 <= S'Last loop
687 pragma Assert (S (P1) = '-' or else S (P1) = '`
');
689 while P2 < S'Last and then S (P2 + 1) /= ',' loop
693 -- Switch is now in S (P1 .. P2)
698 Wild_Card := S (P2) = '*';
706 while P3 <= Buffer.Last - Slen loop
707 if Buffer.Table (P3) = ' '
708 and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) =
712 P3 + Slen = Buffer.Last
714 Buffer.Table (P3 + Slen + 1) = ' ')
719 while P3 + Sln2 /= Buffer.Last
720 and then Buffer.Table (P3 + Sln2 + 1) /= ' '
726 Buffer.Table (P3 .. Buffer.Last - Sln2 - 1) :=
727 Buffer.Table (P3 + Sln2 + 1 .. Buffer.Last);
728 Buffer.Set_Last (Buffer.Last - Sln2 - 1);
740 pragma Assert (S (P2) /= '*');
747 Place (S (P1 .. P2));
752 end Place_Unix_Switches;
754 -----------------------------
755 -- Preprocess_Command_Data --
756 -----------------------------
758 procedure Preprocess_Command_Data is
760 for C in Real_Command_Type loop
762 Command : constant Item_Ptr := new Command_Item;
764 Last_Switch : Item_Ptr;
765 -- Last switch in list
768 -- Link new command item into list of commands
770 if Last_Command = null then
773 Last_Command.Next := Command;
776 Last_Command := Command;
778 -- Fill in fields of new command item
780 Command.Name := Command_List (C).Cname;
781 Command.Usage := Command_List (C).Usage;
782 Command.Command := C;
784 if Command_List (C).Unixsws = null then
785 Command.Unix_String := Command_List (C).Unixcmd;
788 Cmd : String (1 .. 5_000);
790 Sws : constant Argument_List_Access :=
791 Command_List (C).Unixsws;
794 Cmd (1 .. Command_List (C).Unixcmd'Length) :=
795 Command_List (C).Unixcmd.all;
796 Last := Command_List (C).Unixcmd'Length;
798 for J in Sws'Range loop
801 Cmd (Last + 1 .. Last + Sws (J)'Length) :=
803 Last := Last + Sws (J)'Length;
806 Command.Unix_String := new String'(Cmd
(1 .. Last
));
810 Command
.Params
:= Command_List
(C
).Params
;
811 Command
.Defext
:= Command_List
(C
).Defext
;
813 Validate_Command_Or_Option
(Command
.Name
);
815 -- Process the switch list
817 for S
in Command_List
(C
).Switches
'Range loop
819 SS
: constant VMS_Data
.String_Ptr
:=
820 Command_List
(C
).Switches
(S
);
821 P
: Natural := SS
'First;
822 Sw
: Item_Ptr
:= new Switch_Item
;
825 -- Pointer to last option
828 -- Link new switch item into list of switches
830 if Last_Switch
= null then
831 Command
.Switches
:= Sw
;
833 Last_Switch
.Next
:= Sw
;
838 -- Process switch string, first get name
840 while SS
(P
) /= ' ' and SS
(P
) /= '=' loop
844 Sw
.Name
:= new String'(SS (SS'First .. P - 1));
846 -- Direct translation case
849 Sw.Translation := T_Direct;
850 Sw.Unix_String := new String'(SS
(P
+ 1 .. SS
'Last));
851 Validate_Unix_Switch
(Sw
.Unix_String
);
853 if SS
(P
- 1) = '>' then
854 Sw
.Translation
:= T_Other
;
856 elsif SS
(P
+ 1) = '`' then
859 -- Create the inverted case (/NO ..)
861 elsif SS
(SS
'First + 1 .. SS
'First + 2) /= "NO" then
862 Sw
:= new Switch_Item
;
863 Last_Switch
.Next
:= Sw
;
867 new String'("/NO" & SS (SS'First + 1 .. P - 1));
868 Sw.Translation := T_Direct;
869 Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last));
870 Validate_Unix_Switch (Sw.Unix_String);
873 -- Directories translation case
875 elsif SS (P + 1) = '*' then
876 pragma Assert (SS (SS'Last) = '*');
877 Sw.Translation := T_Directories;
878 Sw.Unix_String := new String'(SS
(P
+ 2 .. SS
'Last - 1));
879 Validate_Unix_Switch
(Sw
.Unix_String
);
881 -- Directory translation case
883 elsif SS
(P
+ 1) = '%' then
884 pragma Assert
(SS
(SS
'Last) = '%');
885 Sw
.Translation
:= T_Directory
;
886 Sw
.Unix_String
:= new String'(SS (P + 2 .. SS'Last - 1));
887 Validate_Unix_Switch (Sw.Unix_String);
889 -- File translation case
891 elsif SS (P + 1) = '@
' then
892 pragma Assert (SS (SS'Last) = '@
');
893 Sw.Translation := T_File;
894 Sw.Unix_String := new String'(SS
(P
+ 2 .. SS
'Last - 1));
895 Validate_Unix_Switch
(Sw
.Unix_String
);
897 -- No space file translation case
899 elsif SS
(P
+ 1) = '<' then
900 pragma Assert
(SS
(SS
'Last) = '>');
901 Sw
.Translation
:= T_No_Space_File
;
902 Sw
.Unix_String
:= new String'(SS (P + 2 .. SS'Last - 1));
903 Validate_Unix_Switch (Sw.Unix_String);
905 -- Numeric translation case
907 elsif SS (P + 1) = '#
' then
908 pragma Assert (SS (SS'Last) = '#
');
909 Sw.Translation := T_Numeric;
910 Sw.Unix_String := new String'(SS
(P
+ 2 .. SS
'Last - 1));
911 Validate_Unix_Switch
(Sw
.Unix_String
);
913 -- Alphanumerplus translation case
915 elsif SS
(P
+ 1) = '|' then
916 pragma Assert
(SS
(SS
'Last) = '|');
917 Sw
.Translation
:= T_Alphanumplus
;
918 Sw
.Unix_String
:= new String'(SS (P + 2 .. SS'Last - 1));
919 Validate_Unix_Switch (Sw.Unix_String);
921 -- String translation case
923 elsif SS (P + 1) = '"' then
924 pragma Assert (SS (SS'Last) = '"');
925 Sw.Translation := T_String;
926 Sw.Unix_String := new String'(SS
(P
+ 2 .. SS
'Last - 1));
927 Validate_Unix_Switch
(Sw
.Unix_String
);
929 -- Commands translation case
931 elsif SS
(P
+ 1) = '?' then
932 Sw
.Translation
:= T_Commands
;
933 Sw
.Unix_String
:= new String'(SS (P + 2 .. SS'Last));
935 -- Options translation case
938 Sw.Translation := T_Options;
939 Sw.Unix_String := new String'("");
941 P
:= P
+ 1; -- bump past =
942 while P
<= SS
'Last loop
944 Opt
: constant Item_Ptr
:= new Option_Item
;
948 -- Link new option item into options list
950 if Last_Opt
= null then
953 Last_Opt
.Next
:= Opt
;
958 -- Fill in fields of new option item
961 while SS
(Q
) /= ' ' loop
965 Opt
.Name
:= new String'(SS (P .. Q - 1));
966 Validate_Command_Or_Option (Opt.Name);
971 while Q <= SS'Last and then SS (Q) /= ' ' loop
975 Opt.Unix_String := new String'(SS
(P
.. Q
- 1));
976 Validate_Unix_Switch
(Opt
.Unix_String
);
985 end Preprocess_Command_Data
;
987 ----------------------
988 -- Process_Argument --
989 ----------------------
991 procedure Process_Argument
(The_Command
: in out Command_Type
) is
992 Argv
: String_Access
;
997 Arg_Idx
: Integer) return Integer;
998 -- Begins looking at Arg_Idx + 1 and returns the index of the
999 -- last character before a slash or else the index of the last
1000 -- character in the string Argv.
1006 function Get_Arg_End
1008 Arg_Idx
: Integer) return Integer
1011 for J
in Arg_Idx
+ 1 .. Argv
'Last loop
1012 if Argv
(J
) = '/' then
1020 -- Start of processing for Process_Argument
1023 -- If an argument file is open, read the next non empty line
1025 if Is_Open
(Arg_File
) then
1027 Line
: String (1 .. 256);
1031 Get_Line
(Arg_File
, Line
, Last
);
1032 exit when Last
/= 0 or else End_Of_File
(Arg_File
);
1035 -- If the end of the argument file has been reached, close it
1037 if End_Of_File
(Arg_File
) then
1040 -- If the last line was empty, return after increasing Arg_Num
1041 -- to go to the next argument on the comment line.
1044 Arg_Num
:= Arg_Num
+ 1;
1049 Argv
:= new String'(Line (1 .. Last));
1052 if Argv (1) = '@
' then
1053 Put_Line (Standard_Error, "argument file cannot contain @cmd");
1059 -- No argument file is open, get the argument on the command line
1061 Argv := new String'(Argument
(Arg_Num
));
1062 Arg_Idx
:= Argv
'First;
1064 -- Check if this is the specification of an argument file
1066 if Argv
(Arg_Idx
) = '@' then
1067 -- The first argument on the command line cannot be an argument
1073 "Cannot specify argument line before command");
1077 -- Open the file, after conversion of the name to canonical form.
1078 -- Fail if file is not found.
1081 Canonical_File_Name
: String_Access
:=
1082 To_Canonical_File_Spec
(Argv
(Arg_Idx
+ 1 .. Argv
'Last));
1084 Open
(Arg_File
, In_File
, Canonical_File_Name
.all);
1085 Free
(Canonical_File_Name
);
1090 Put
(Standard_Error
, "Cannot open argument file """);
1091 Put
(Standard_Error
, Argv
(Arg_Idx
+ 1 .. Argv
'Last));
1092 Put_Line
(Standard_Error
, """");
1098 <<Tryagain_After_Coalesce
>>
1101 Next_Arg_Idx
: Integer;
1102 Arg
: String_Access
;
1105 Next_Arg_Idx
:= Get_Arg_End
(Argv
.all, Arg_Idx
);
1106 Arg
:= new String'(Argv (Arg_Idx .. Next_Arg_Idx));
1108 -- The first one must be a command name
1110 if Arg_Num = 1 and then Arg_Idx = Argv'First then
1111 Command := Matching_Name (Arg.all, Commands);
1113 if Command = null then
1117 The_Command := Command.Command;
1118 Output_File_Expected := False;
1120 -- Give usage information if only command given
1122 if Argument_Count = 1
1123 and then Next_Arg_Idx = Argv'Last
1128 ("List of available qualifiers and options");
1131 Put (Command.Usage.all);
1133 Put_Line (Command.Unix_String.all);
1136 Sw : Item_Ptr := Command.Switches;
1139 while Sw /= null loop
1143 case Sw.Translation is
1147 Put_Line (Sw.Unix_String.all &
1152 Put_Line (Sw.Unix_String.all);
1154 when T_Directories =>
1155 Put ("=(direc,direc,..direc)");
1157 Put (Sw.Unix_String.all);
1159 Put (Sw.Unix_String.all);
1160 Put_Line (" direc ...");
1165 Put (Sw.Unix_String.all);
1167 if Sw.Unix_String (Sw.Unix_String'Last)
1173 Put_Line ("directory ");
1175 when T_File | T_No_Space_File =>
1178 Put (Sw.Unix_String.all);
1180 if Sw.Translation = T_File
1181 and then Sw.Unix_String
1182 (Sw.Unix_String'Last) /= '='
1194 (Sw.Unix_String'First) = '`
'
1197 (Sw.Unix_String'First + 1
1198 .. Sw.Unix_String'Last));
1200 Put (Sw.Unix_String.all);
1205 when T_Alphanumplus =>
1210 (Sw.Unix_String'First) = '`
'
1213 (Sw.Unix_String'First + 1
1214 .. Sw.Unix_String'Last));
1216 Put (Sw.Unix_String.all);
1228 Put (Sw.Unix_String.all);
1231 (Sw.Unix_String'Last) /= '='
1240 Put (" (switches for ");
1242 (Sw.Unix_String'First + 7
1243 .. Sw.Unix_String'Last));
1247 (Sw.Unix_String'First
1248 .. Sw.Unix_String'First + 5));
1249 Put_Line (" switches");
1253 Opt : Item_Ptr := Sw.Options;
1256 Put_Line ("=(option,option..)");
1258 while Opt /= null loop
1262 if Opt = Sw.Options then
1267 Put_Line (Opt.Unix_String.all);
1281 -- Special handling for internal debugging switch /?
1283 elsif Arg.all = "/?" then
1284 Display_Command := True;
1285 Output_File_Expected := False;
1287 -- Copy -switch unchanged
1289 elsif Arg (Arg'First) = '-' then
1293 -- Set Output_File_Expected for the next argument
1295 Output_File_Expected :=
1296 Arg.all = "-o" and then The_Command = Link;
1298 -- Copy quoted switch with quotes stripped
1300 elsif Arg (Arg'First) = '"' then
1301 if Arg (Arg'Last) /= '"' then
1302 Put (Standard_Error, "misquoted argument: ");
1303 Put_Line (Standard_Error, Arg.all);
1304 Errors := Errors + 1;
1308 Place (Arg (Arg'First + 1 .. Arg'Last - 1));
1311 Output_File_Expected := False;
1313 -- Parameter Argument
1315 elsif Arg (Arg'First) /= '/'
1316 and then Make_Commands_Active = null
1318 Param_Count := Param_Count + 1;
1320 if Param_Count <= Command.Params'Length then
1322 case Command.Params (Param_Count) is
1324 when File | Optional_File =>
1326 Normal_File : constant String_Access :=
1327 To_Canonical_File_Spec
1332 Place_Lower (Normal_File.all);
1334 if Is_Extensionless (Normal_File.all)
1335 and then Command.Defext /= " "
1338 Place (Command.Defext);
1342 when Unlimited_Files =>
1344 Normal_File : constant String_Access :=
1345 To_Canonical_File_Spec
1348 File_Is_Wild : Boolean := False;
1349 File_List : String_Access_List_Access;
1352 for J in Arg'Range loop
1354 or else Arg (J) = '%'
1356 File_Is_Wild := True;
1360 if File_Is_Wild then
1361 File_List := To_Canonical_File_List
1364 for J in File_List.all'Range loop
1366 Place_Lower (File_List.all (J).all);
1371 Place_Lower (Normal_File.all);
1373 -- Add extension if not present, except after
1376 if Is_Extensionless (Normal_File.all)
1377 and then Command.Defext /= " "
1378 and then not Output_File_Expected
1381 Place (Command.Defext);
1385 Param_Count := Param_Count - 1;
1392 when Unlimited_As_Is =>
1395 Param_Count := Param_Count - 1;
1397 when Files_Or_Wildcard =>
1399 -- Remove spaces from a comma separated list
1400 -- of file names and adjust control variables
1403 while Arg_Num < Argument_Count and then
1404 (Argv (Argv'Last) = ',' xor
1405 Argument (Arg_Num + 1)
1406 (Argument (Arg_Num + 1)'First) = ',')
1409 (Argv
.all & Argument
(Arg_Num
+ 1));
1410 Arg_Num
:= Arg_Num
+ 1;
1411 Arg_Idx
:= Argv
'First;
1413 Get_Arg_End
(Argv
.all, Arg_Idx
);
1415 (Argv (Arg_Idx .. Next_Arg_Idx));
1418 -- Parse the comma separated list of VMS
1419 -- filenames and place them on the command
1420 -- line as space separated Unix style
1421 -- filenames. Lower case and add default
1422 -- extension as appropriate.
1425 Arg1_Idx : Integer := Arg'First;
1427 function Get_Arg1_End
1429 Arg_Idx : Integer) return Integer;
1430 -- Begins looking at Arg_Idx + 1 and
1431 -- returns the index of the last character
1432 -- before a comma or else the index of the
1433 -- last character in the string Arg.
1439 function Get_Arg1_End
1441 Arg_Idx : Integer) return Integer
1444 for J in Arg_Idx + 1 .. Arg'Last loop
1445 if Arg (J) = ',' then
1458 Get_Arg1_End (Arg.all, Arg1_Idx);
1462 Arg (Arg1_Idx .. Next_Arg1_Idx);
1465 constant String_Access :=
1466 To_Canonical_File_Spec (Arg1);
1470 Place_Lower (Normal_File.all);
1472 if Is_Extensionless (Normal_File.all)
1473 and then Command.Defext /= " "
1476 Place (Command.Defext);
1479 Arg1_Idx := Next_Arg1_Idx + 1;
1482 exit when Arg1_Idx > Arg'Last;
1484 -- Don't allow two or more commas in
1487 if Arg (Arg1_Idx) = ',' then
1488 Arg1_Idx := Arg1_Idx + 1;
1489 if Arg1_Idx > Arg'Last or else
1490 Arg (Arg1_Idx) = ','
1494 "Malformed Parameter: " &
1496 Put (Standard_Error, "usage: ");
1497 Put_Line (Standard_Error,
1508 -- Reset Output_File_Expected, in case it was True
1510 Output_File_Expected := False;
1512 -- Qualifier argument
1515 Output_File_Expected := False;
1517 -- This code is too heavily nested, should be
1518 -- separated out as separate subprogram ???
1524 Endp : Natural := 0; -- avoid warning!
1529 while SwP < Arg'Last
1530 and then Arg (SwP + 1) /= '='
1535 -- At this point, the switch name is in
1536 -- Arg (Arg'First..SwP) and if that is not the
1537 -- whole switch, then there is an equal sign at
1538 -- Arg (SwP + 1) and the rest of Arg is what comes
1539 -- after the equal sign.
1541 -- If make commands are active, see if we have
1542 -- another COMMANDS_TRANSLATION switch belonging
1545 if Make_Commands_Active /= null then
1548 (Arg (Arg'First .. SwP),
1553 and then Sw.Translation = T_Commands
1560 (Arg (Arg'First .. SwP),
1561 Make_Commands_Active.Switches,
1565 -- For case of GNAT MAKE or CHOP, if we cannot
1566 -- find the switch, then see if it is a
1567 -- recognized compiler switch instead, and if
1568 -- so process the compiler switch.
1570 elsif Command.Name.all = "MAKE"
1571 or else Command.Name.all = "CHOP" then
1574 (Arg (Arg'First .. SwP),
1581 (Arg (Arg'First .. SwP),
1583 ("COMPILE", Commands).Switches,
1587 -- For all other cases, just search the relevant
1593 (Arg (Arg'First .. SwP),
1599 case Sw.Translation is
1602 Place_Unix_Switches (Sw.Unix_String);
1604 and then Arg (SwP + 1) = '='
1606 Put (Standard_Error,
1607 "qualifier options ignored: ");
1608 Put_Line (Standard_Error, Arg.all);
1611 when T_Directories =>
1612 if SwP + 1 > Arg'Last then
1613 Put (Standard_Error,
1614 "missing directories for: ");
1615 Put_Line (Standard_Error, Arg.all);
1616 Errors := Errors + 1;
1618 elsif Arg (SwP + 2) /= '(' then
1622 elsif Arg (Arg'Last) /= ')' then
1624 -- Remove spaces from a comma separated
1625 -- list of file names and adjust
1626 -- control variables accordingly.
1628 if Arg_Num < Argument_Count and then
1629 (Argv (Argv'Last) = ',' xor
1630 Argument (Arg_Num + 1)
1631 (Argument (Arg_Num + 1)'First) = ',')
1634 new String'(Argv
.all
1637 Arg_Num
:= Arg_Num
+ 1;
1638 Arg_Idx
:= Argv
'First;
1640 Get_Arg_End
(Argv
.all, Arg_Idx
);
1642 (Argv (Arg_Idx .. Next_Arg_Idx));
1643 goto Tryagain_After_Coalesce;
1646 Put (Standard_Error,
1647 "incorrectly parenthesized " &
1648 "or malformed argument: ");
1649 Put_Line (Standard_Error, Arg.all);
1650 Errors := Errors + 1;
1654 Endp := Arg'Last - 1;
1657 while SwP <= Endp loop
1659 Dir_Is_Wild : Boolean := False;
1660 Dir_Maybe_Is_Wild : Boolean := False;
1662 Dir_List : String_Access_List_Access;
1668 and then Arg (P2 + 1) /= ','
1670 -- A wildcard directory spec on
1671 -- VMS will contain either * or
1674 if Arg (P2) = '*' then
1675 Dir_Is_Wild := True;
1677 elsif Arg (P2) = '%' then
1678 Dir_Is_Wild := True;
1680 elsif Dir_Maybe_Is_Wild
1681 and then Arg (P2) = '.'
1682 and then Arg (P2 + 1) = '.'
1684 Dir_Is_Wild := True;
1685 Dir_Maybe_Is_Wild := False;
1687 elsif Dir_Maybe_Is_Wild then
1688 Dir_Maybe_Is_Wild := False;
1690 elsif Arg (P2) = '.'
1691 and then Arg (P2 + 1) = '.'
1693 Dir_Maybe_Is_Wild := True;
1702 To_Canonical_File_List
1703 (Arg (SwP .. P2), True);
1705 for J in Dir_List.all'Range loop
1709 (Dir_List.all (J).all);
1716 (To_Canonical_Dir_Spec
1717 (Arg (SwP .. P2), False).all);
1725 if SwP + 1 > Arg'Last then
1726 Put (Standard_Error,
1727 "missing directory for: ");
1728 Put_Line (Standard_Error, Arg.all);
1729 Errors := Errors + 1;
1732 Place_Unix_Switches (Sw.Unix_String);
1734 -- Some switches end in "=". No space
1738 (Sw.Unix_String'Last) /= '='
1744 (To_Canonical_Dir_Spec
1745 (Arg (SwP + 2 .. Arg'Last),
1749 when T_File | T_No_Space_File =>
1750 if SwP + 1 > Arg'Last then
1751 Put (Standard_Error,
1752 "missing file for: ");
1753 Put_Line (Standard_Error, Arg.all);
1754 Errors := Errors + 1;
1757 Place_Unix_Switches (Sw.Unix_String);
1759 -- Some switches end in "=". No space
1762 if Sw.Translation = T_File
1763 and then Sw.Unix_String
1764 (Sw.Unix_String'Last) /= '='
1770 (To_Canonical_File_Spec
1771 (Arg (SwP + 2 .. Arg'Last)).all);
1775 if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then
1776 Place_Unix_Switches (Sw.Unix_String);
1777 Place (Arg (SwP + 2 .. Arg'Last));
1780 Put (Standard_Error, "argument for ");
1781 Put (Standard_Error, Sw.Name.all);
1783 (Standard_Error, " must be numeric");
1784 Errors := Errors + 1;
1787 when T_Alphanumplus =>
1788 if OK_Alphanumerplus
1789 (Arg (SwP + 2 .. Arg'Last))
1791 Place_Unix_Switches (Sw.Unix_String);
1792 Place (Arg (SwP + 2 .. Arg'Last));
1795 Put (Standard_Error, "argument for ");
1796 Put (Standard_Error, Sw.Name.all);
1797 Put_Line (Standard_Error,
1798 " must be alphanumeric");
1799 Errors := Errors + 1;
1804 -- A String value must be extended to the
1805 -- end of the Argv, otherwise strings like
1806 -- "foo/bar" get split at the slash.
1808 -- The begining and ending of the string
1809 -- are flagged with embedded nulls which
1810 -- are removed when building the Spawn
1811 -- call. Nulls are use because they won't
1812 -- show up in a /? output. Quotes aren't
1813 -- used because that would make it
1814 -- difficult to embed them.
1816 Place_Unix_Switches (Sw.Unix_String);
1818 if Next_Arg_Idx /= Argv'Last then
1819 Next_Arg_Idx := Argv'Last;
1821 (Argv
(Arg_Idx
.. Next_Arg_Idx
));
1824 while SwP
< Arg
'Last and then
1825 Arg
(SwP
+ 1) /= '=' loop
1831 Place
(Arg
(SwP
+ 2 .. Arg
'Last));
1836 -- Output -largs/-bargs/-cargs
1839 Place
(Sw
.Unix_String
1840 (Sw
.Unix_String
'First ..
1841 Sw
.Unix_String
'First + 5));
1844 (Sw
.Unix_String
'First + 7 ..
1845 Sw
.Unix_String
'Last) = "MAKE"
1847 Make_Commands_Active
:= null;
1850 -- Set source of new commands, also
1851 -- setting this non-null indicates that
1852 -- we are in the special commands mode
1853 -- for processing the -xargs case.
1855 Make_Commands_Active
:=
1858 (Sw
.Unix_String
'First + 7 ..
1859 Sw
.Unix_String
'Last),
1864 if SwP
+ 1 > Arg
'Last then
1866 (Sw
.Options
.Unix_String
);
1869 elsif Arg
(SwP
+ 2) /= '(' then
1873 elsif Arg
(Arg
'Last) /= ')' then
1874 Put
(Standard_Error
,
1875 "incorrectly parenthesized argument: ");
1876 Put_Line
(Standard_Error
, Arg
.all);
1877 Errors
:= Errors
+ 1;
1882 Endp
:= Arg
'Last - 1;
1885 while SwP
<= Endp
loop
1889 and then Arg
(P2
+ 1) /= ','
1894 -- Option name is in Arg (SwP .. P2)
1896 Opt
:= Matching_Name
(Arg
(SwP
.. P2
),
1909 (new String'(Sw.Unix_String.all &
1917 Arg_Idx := Next_Arg_Idx + 1;
1920 exit when Arg_Idx > Argv'Last;
1924 if not Is_Open (Arg_File) then
1925 Arg_Num := Arg_Num + 1;
1927 end Process_Argument;
1929 --------------------------------
1930 -- Validate_Command_Or_Option --
1931 --------------------------------
1933 procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is
1935 pragma Assert (N'Length > 0);
1937 for J in N'Range loop
1939 pragma Assert (N (J - 1) /= '_
');
1942 pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
1946 end Validate_Command_Or_Option;
1948 --------------------------
1949 -- Validate_Unix_Switch --
1950 --------------------------
1952 procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is
1954 if S (S'First) = '`
' then
1958 pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
1960 for J in S'First + 1 .. S'Last loop
1961 pragma Assert (S (J) /= ' ');
1964 pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
1968 end Validate_Unix_Switch;
1970 --------------------
1971 -- VMS_Conversion --
1972 --------------------
1974 procedure VMS_Conversion (The_Command : out Command_Type) is
1975 Result : Command_Type := Undefined;
1976 Result_Set : Boolean := False;
1980 -- First we must preprocess the string form of the command and options
1981 -- list into the internal form that we use.
1983 Preprocess_Command_Data;
1985 -- If no parameters, give complete list of commands
1987 if Argument_Count = 0 then
1990 Put_Line ("List of available commands");
1993 while Commands /= null loop
1994 Put (Commands.Usage.all);
1996 Put_Line (Commands.Unix_String.all);
1997 Commands := Commands.Next;
2005 -- Loop through arguments
2007 while Arg_Num <= Argument_Count loop
2008 Process_Argument (Result);
2010 if not Result_Set then
2011 The_Command := Result;
2016 -- Gross error checking that the number of parameters is correct.
2017 -- Not applicable to Unlimited_Files parameters.
2019 if (Param_Count = Command.Params'Length - 1
2020 and then Command.Params (Param_Count + 1) = Unlimited_Files)
2021 or else Param_Count <= Command.Params'Length
2026 Put_Line (Standard_Error,
2027 "Parameter count of "
2028 & Integer'Image (Param_Count)
2029 & " not equal to expected "
2030 & Integer'Image (Command.Params'Length));
2031 Put (Standard_Error, "usage: ");
2032 Put_Line (Standard_Error, Command.Usage.all);
2033 Errors := Errors + 1;
2039 -- Prepare arguments for a call to spawn, filtering out
2040 -- embedded nulls place there to delineate strings.
2044 Inside_Nul : Boolean := False;
2045 Arg : String (1 .. 1024);
2051 while P1 <= Buffer.Last and then Buffer.Table (P1) = ' ' loop
2056 Arg (Arg_Ctr) := Buffer.Table (P1);
2058 while P1 <= Buffer.Last loop
2060 if Buffer.Table (P1) = ASCII.NUL then
2062 Inside_Nul := False;
2068 if Buffer.Table (P1) = ' ' and then not Inside_Nul then
2070 Arg_Ctr := Arg_Ctr + 1;
2071 Arg (Arg_Ctr) := Buffer.Table (P1);
2074 Last_Switches.Increment_Last;
2077 while P2 < Buffer.Last
2078 and then (Buffer.Table (P2 + 1) /= ' ' or else
2082 Arg_Ctr := Arg_Ctr + 1;
2083 Arg (Arg_Ctr) := Buffer.Table (P2);
2084 if Buffer.Table (P2) = ASCII.NUL then
2085 Arg_Ctr := Arg_Ctr - 1;
2087 Inside_Nul := False;
2094 Last_Switches.Table (Last_Switches.Last) :=
2095 new String'(String (Arg
(1 .. Arg_Ctr
)));
2098 Arg
(Arg_Ctr
) := Buffer
.Table
(P1
);