From 26fd4eae69871cb45835bea5c0ce35657415cf15 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 26 Jan 2004 15:47:48 +0100 Subject: [PATCH] [multiple changes] 2004-01-26 Ed Schonberg * exp_ch3.adb (Build_Slice_Assignment): New TSS procedure for one-dimensional array an slice assignments, when component type is controlled. * exp_ch5.adb (Expand_Assign_Array): If array is one-dimensional, component type is controlled, and control_actions are in effect, use TSS procedure rather than generating inline code. * exp_tss.ads (TSS_Slice_Assign): New TSS procedure for one-dimensional arrays with controlled components. 2004-01-26 Vincent Celier * gnatcmd.adb (GNATCmd): Add specification of argument file on the command line for the non VMS case. * gnatlink.adb (Process_Binder_File): When building object file, if GNU linker is used, put all object paths between quotes, to prevent ld error when there are unusual characters (such as '!') in the paths. * Makefile.generic: When there are sources in Ada and the main is in C/C++, invoke gnatmake with -B, instead of -z. * vms_conv.adb (Preprocess_Command_Data): New procedure, extracted from VMS_Conversion. (Process_Argument): New procedure, extracted from VMS_Conversion. Add specification of argument file on the command line. 2004-01-26 Bernard Banner * Makefile.in: Enable GMEM_LIB and SYMLIB for x86_64 2004-01-26 Ed Schonberg * snames.adb: Update copyright notice. Add info on slice assignment for controlled arrays. From-SVN: r76634 --- gcc/ada/ChangeLog | 39 ++ gcc/ada/Makefile.generic | 17 +- gcc/ada/Makefile.in | 4 +- gcc/ada/exp_ch3.adb | 293 +++++++++ gcc/ada/exp_ch5.adb | 122 +++- gcc/ada/exp_tss.ads | 4 +- gcc/ada/gnatcmd.adb | 64 +- gcc/ada/gnatlink.adb | 24 +- gcc/ada/snames.adb | 3 +- gcc/ada/vms_conv.adb | 1595 ++++++++++++++++++++++++---------------------- 10 files changed, 1382 insertions(+), 783 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ba407a2..3e2838d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,42 @@ +2004-01-26 Ed Schonberg + + * exp_ch3.adb (Build_Slice_Assignment): New TSS procedure for + one-dimensional array an slice assignments, when component type is + controlled. + + * exp_ch5.adb (Expand_Assign_Array): If array is one-dimensional, + component type is controlled, and control_actions are in effect, use + TSS procedure rather than generating inline code. + + * exp_tss.ads (TSS_Slice_Assign): New TSS procedure for one-dimensional + arrays with controlled components. + +2004-01-26 Vincent Celier + + * gnatcmd.adb (GNATCmd): Add specification of argument file on the + command line for the non VMS case. + + * gnatlink.adb (Process_Binder_File): When building object file, if + GNU linker is used, put all object paths between quotes, to prevent ld + error when there are unusual characters (such as '!') in the paths. + + * Makefile.generic: When there are sources in Ada and the main is in + C/C++, invoke gnatmake with -B, instead of -z. + + * vms_conv.adb (Preprocess_Command_Data): New procedure, extracted + from VMS_Conversion. + (Process_Argument): New procedure, extracted from VMS_Conversion. Add + specification of argument file on the command line. + +2004-01-26 Bernard Banner + + * Makefile.in: Enable GMEM_LIB and SYMLIB for x86_64 + +2004-01-26 Ed Schonberg + + * snames.adb: Update copyright notice. + Add info on slice assignment for controlled arrays. + 2004-01-23 Robert Dewar * exp_aggr.adb: Minor reformatting diff --git a/gcc/ada/Makefile.generic b/gcc/ada/Makefile.generic index cb27f4f..6be6231 100644 --- a/gcc/ada/Makefile.generic +++ b/gcc/ada/Makefile.generic @@ -337,21 +337,16 @@ internal-build: $(LINKER) archive-objects force else # C/C++ main -# The trick here is to force gnatmake to bind/link, even if there is no -# Ada main program. To achieve this effect, we use the -z switch, which is -# close enough to our needs, and the usual -n gnatbind switch and --LINK= -# gnatlink switch. link: $(LINKER) archive-objects force - $(GNATMAKE) $(EXEC_RULE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) \ - -bargs -n -largs $(LARGS) $(LDFLAGS) + $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) \ + -largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS) internal-build: $(LINKER) archive-objects force - @echo $(GNATMAKE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS) - @$(GNATMAKE) $(EXEC_RULE) -z \ - -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \ - -bargs -n \ - -largs $(LARGS) $(LDFLAGS) + @echo $(GNATMAKE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS) + @$(GNATMAKE) $(EXEC_RULE) \ + -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \ + -largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS) endif else diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 7252bc0..f9abc3a 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -1287,11 +1287,13 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) system.ads<5nsystem.ads TOOLS_TARGET_PAIRS=mlib-tgt.adb<5lml-tgt.adb - MISCLIB= + SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL) THREADSLIB=-lpthread GNATLIB_SHARED=gnatlib-shared-dual + GMEM_LIB = gmemlib PREFIX_OBJS=$(PREFIX_REAL_OBJS) LIBRARY_VERSION := $(LIB_VERSION) + endif # The runtime library for gnat comprises two directories. One contains the diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 42d1586..111e14b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -114,6 +114,12 @@ package body Exp_Ch3 is -- Build record initialization procedure. N is the type declaration -- node, and Pe is the corresponding entity for the record type. + procedure Build_Slice_Assignment (Typ : Entity_Id); + -- Build assignment procedure for one-dimensional arrays of controlled + -- types. Other array and slice assignments are expanded in-line, but + -- the code expansion for controlled components (when control actions + -- are active) can lead to very large blocks that GCC3 handles poorly. + procedure Build_Variant_Record_Equality (Typ : Entity_Id); -- Create An Equality function for the non-tagged variant record 'Typ' -- and attach it to the TSS list @@ -2474,6 +2480,287 @@ package body Exp_Ch3 is end if; end Build_Record_Init_Proc; + ---------------------------- + -- Build_Slice_Assignment -- + ---------------------------- + + -- Generates the following subprogram: + -- procedure Assign + -- (Source, Target : Array_Type, + -- Left_Lo, Left_Hi, Right_Lo, Right_Hi : Index; + -- Rev : Boolean) + -- is + -- Li1 : Index; + -- Ri1 : Index; + -- begin + -- if Rev then + -- Li1 := Left_Hi; + -- Ri1 := Right_Hi; + -- else + -- Li1 := Left_Lo; + -- Ri1 := Right_Lo; + -- end if; + -- + -- loop + -- Target (Li1) := Source (Ri1); + -- if Rev then + -- exit when Li2 = Left_Lo; + -- Li2 := Index'pred (Li2); + -- Ri2 := Index'pred (Ri2); + -- else + -- exit when Li2 = Left_Hi; + -- Li2 := Index'succ (Li2); + -- Ri2 := Index'succ (Ri2); + -- end if; + -- end loop; + -- end Assign; + + procedure Build_Slice_Assignment (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); + + -- Build formal parameters of procedure + + Larray : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars => New_Internal_Name ('A')); + Rarray : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars => New_Internal_Name ('R')); + Left_Lo : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars => New_Internal_Name ('L')); + Left_Hi : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars => New_Internal_Name ('L')); + Right_Lo : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars => New_Internal_Name ('R')); + Right_Hi : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars => New_Internal_Name ('R')); + Rev : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars => New_Internal_Name ('D')); + Proc_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Typ, TSS_Slice_Assign)); + + Lnn : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + Rnn : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + -- subscripts for left and right sides + + Decls : List_Id; + Loops : Node_Id; + Stats : List_Id; + + begin + + -- Build declarations for indices. + + Decls := New_List; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Lnn, + Object_Definition => + New_Occurrence_Of (Index, Loc))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => + New_Occurrence_Of (Index, Loc))); + + Stats := New_List; + + -- Build initializations for indices. + + declare + F_Init : constant List_Id := New_List; + B_Init : constant List_Id := New_List; + + begin + Append_To (F_Init, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Lnn, Loc), + Expression => New_Occurrence_Of (Left_Lo, Loc))); + + Append_To (F_Init, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn, Loc), + Expression => New_Occurrence_Of (Right_Lo, Loc))); + + Append_To (B_Init, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Lnn, Loc), + Expression => New_Occurrence_Of (Left_Hi, Loc))); + + Append_To (B_Init, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn, Loc), + Expression => New_Occurrence_Of (Right_Hi, Loc))); + + Append_To (Stats, + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Rev, Loc), + Then_Statements => B_Init, + Else_Statements => F_Init)); + end; + + -- Now construct the assignment statement + + Loops := + Make_Loop_Statement (Loc, + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Larray, Loc), + Expressions => New_List (New_Occurrence_Of (Lnn, Loc))), + Expression => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Rarray, Loc), + Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), + End_Label => Empty); + + -- Build the increment/decrement statements. + + declare + F_Ass : constant List_Id := New_List; + B_Ass : constant List_Id := New_List; + + begin + Append_To (F_Ass, + Make_Exit_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Lnn, Loc), + Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); + + Append_To (B_Ass, + Make_Exit_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Lnn, Loc), + Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); + + Append_To (F_Ass, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Lnn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List ( + New_Occurrence_Of (Lnn, Loc))))); + + Append_To (F_Ass, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List ( + New_Occurrence_Of (Rnn, Loc))))); + + Append_To (B_Ass, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Lnn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index, Loc), + Attribute_Name => Name_Pred, + Expressions => New_List ( + New_Occurrence_Of (Lnn, Loc))))); + + Append_To (B_Ass, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Rnn, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index, Loc), + Attribute_Name => Name_Pred, + Expressions => New_List ( + New_Occurrence_Of (Rnn, Loc))))); + + Append_To (Statements (Loops), + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Rev, Loc), + Then_Statements => B_Ass, + Else_Statements => F_Ass)); + end; + + Append_To (Stats, Loops); + + declare + Spec : Node_Id; + Formals : List_Id := New_List; + + begin + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Larray, + Out_Present => True, + Parameter_Type => + New_Reference_To (Base_Type (Typ), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Rarray, + Parameter_Type => + New_Reference_To (Base_Type (Typ), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Left_Lo, + Parameter_Type => + New_Reference_To (Index, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Left_Hi, + Parameter_Type => + New_Reference_To (Index, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Right_Lo, + Parameter_Type => + New_Reference_To (Index, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Right_Hi, + Parameter_Type => + New_Reference_To (Index, Loc))); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Rev, + Parameter_Type => + New_Reference_To (Standard_Boolean, Loc))); + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Name, + Parameter_Specifications => Formals); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stats))); + end; + + Set_TSS (Typ, Proc_Name); + Set_Is_Pure (Proc_Name); + end Build_Slice_Assignment; + ------------------------------------ -- Build_Variant_Record_Equality -- ------------------------------------ @@ -3483,6 +3770,12 @@ package body Exp_Ch3 is if Typ = Base and then Has_Controlled_Component (Base) then Build_Controlling_Procs (Base); + + if not Is_Limited_Type (Component_Type (Typ)) + and then Number_Dimensions (Typ) = 1 + then + Build_Slice_Assignment (Typ); + end if; end if; -- For packed case, there is a default initialization, except diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 7c08b2a..ac0a7f7 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,6 +32,7 @@ with Exp_Ch7; use Exp_Ch7; with Exp_Ch11; use Exp_Ch11; with Exp_Dbug; use Exp_Dbug; with Exp_Pakd; use Exp_Pakd; +with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Hostparm; use Hostparm; with Nlists; use Nlists; @@ -160,6 +161,10 @@ package body Exp_Ch5 is -- This switch is set to True if the array move must be done using -- an explicit front end generated loop. + procedure Apply_Dereference (Arg : in out Node_Id); + -- If the argument is an access to an array, and the assignment is + -- converted into a procedure call, apply explicit dereference. + function Has_Address_Clause (Exp : Node_Id) return Boolean; -- Test if Exp is a reference to an array whose declaration has -- an address clause, or it is a slice of such an array. @@ -185,6 +190,20 @@ package body Exp_Ch5 is -- generate a front end loop, which is not so terrible. -- It would really be better if backend handled this ??? + ----------------------- + -- Apply_Dereference -- + ----------------------- + + procedure Apply_Dereference (Arg : in out Node_Id) is + Typ : constant Entity_Id := Etype (Arg); + begin + if Is_Access_Type (Typ) then + Rewrite (Arg, Make_Explicit_Dereference (Loc, + Prefix => Relocate_Node (Arg))); + Analyze_And_Resolve (Arg, Designated_Type (Typ)); + end if; + end Apply_Dereference; + ------------------------ -- Has_Address_Clause -- ------------------------ @@ -704,10 +723,47 @@ package body Exp_Ch5 is -- Cases where either Forwards_OK or Backwards_OK is true if Forwards_OK (N) or else Backwards_OK (N) then - Rewrite (N, - Expand_Assign_Array_Loop - (N, Larray, Rarray, L_Type, R_Type, Ndim, - Rev => not Forwards_OK (N))); + if Controlled_Type (Component_Type (L_Type)) + and then Base_Type (L_Type) = Base_Type (R_Type) + and then Ndim = 1 + and then not No_Ctrl_Actions (N) + then + declare + Proc : constant Entity_Id := + TSS (Base_Type (L_Type), TSS_Slice_Assign); + Actuals : List_Id; + + begin + Apply_Dereference (Larray); + Apply_Dereference (Rarray); + Actuals := New_List ( + Duplicate_Subexpr (Larray, Name_Req => True), + Duplicate_Subexpr (Rarray, Name_Req => True), + Duplicate_Subexpr (Left_Lo, Name_Req => True), + Duplicate_Subexpr (Left_Hi, Name_Req => True), + Duplicate_Subexpr (Right_Lo, Name_Req => True), + Duplicate_Subexpr (Right_Hi, Name_Req => True)); + + if Forwards_OK (N) then + Append_To (Actuals, + New_Occurrence_Of (Standard_False, Loc)); + else + Append_To (Actuals, + New_Occurrence_Of (Standard_True, Loc)); + end if; + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => Actuals)); + end; + + else + Rewrite (N, + Expand_Assign_Array_Loop + (N, Larray, Rarray, L_Type, R_Type, Ndim, + Rev => not Forwards_OK (N))); + end if; -- Case of both are false with No_Implicit_Conditionals @@ -806,19 +862,53 @@ package body Exp_Ch5 is Right_Opnd => Cright_Lo); end if; - Rewrite (N, - Make_Implicit_If_Statement (N, - Condition => Condition, + if Controlled_Type (Component_Type (L_Type)) + and then Base_Type (L_Type) = Base_Type (R_Type) + and then Ndim = 1 + and then not No_Ctrl_Actions (N) + then - Then_Statements => New_List ( - Expand_Assign_Array_Loop - (N, Larray, Rarray, L_Type, R_Type, Ndim, - Rev => False)), + -- Call TSS procedure for array assignment, passing the + -- the explicit bounds of right- and left-hand side. - Else_Statements => New_List ( - Expand_Assign_Array_Loop - (N, Larray, Rarray, L_Type, R_Type, Ndim, - Rev => True)))); + declare + Proc : constant Node_Id := + TSS (Base_Type (L_Type), TSS_Slice_Assign); + Actuals : List_Id; + + begin + Apply_Dereference (Larray); + Apply_Dereference (Rarray); + Actuals := New_List ( + Duplicate_Subexpr (Larray, Name_Req => True), + Duplicate_Subexpr (Rarray, Name_Req => True), + Duplicate_Subexpr (Left_Lo, Name_Req => True), + Duplicate_Subexpr (Left_Hi, Name_Req => True), + Duplicate_Subexpr (Right_Lo, Name_Req => True), + Duplicate_Subexpr (Right_Hi, Name_Req => True)); + Append_To (Actuals, Condition); + + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc, Loc), + Parameter_Associations => Actuals)); + end; + + else + Rewrite (N, + Make_Implicit_If_Statement (N, + Condition => Condition, + + Then_Statements => New_List ( + Expand_Assign_Array_Loop + (N, Larray, Rarray, L_Type, R_Type, Ndim, + Rev => False)), + + Else_Statements => New_List ( + Expand_Assign_Array_Loop + (N, Larray, Rarray, L_Type, R_Type, Ndim, + Rev => True)))); + end if; end if; Analyze (N, Suppress => All_Checks); diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads index c36b821..a85fff0 100644 --- a/gcc/ada/exp_tss.ads +++ b/gcc/ada/exp_tss.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -81,6 +81,7 @@ package Exp_Tss is TSS_RAS_Access : constant TNT := "RA"; -- RAs type access TSS_RAS_Dereference : constant TNT := "RD"; -- RAs type deference TSS_Rep_To_Pos : constant TNT := "RP"; -- Rep to Pos conversion + TSS_Slice_Assign : constant TNT := "SA"; -- Slice assignment TSS_Stream_Input : constant TNT := "SI"; -- Stream Input attribute TSS_Stream_Output : constant TNT := "SO"; -- Stream Output attribute TSS_Stream_Read : constant TNT := "SR"; -- Stream Read attribute @@ -95,6 +96,7 @@ package Exp_Tss is TSS_RAS_Access, TSS_RAS_Dereference, TSS_Rep_To_Pos, + TSS_Slice_Assign, TSS_Stream_Input, TSS_Stream_Output, TSS_Stream_Read, diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index f1896d9..1e04140 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -493,10 +493,66 @@ begin end; end; + -- Get the arguments from the command line and from the eventual + -- argument file(s) specified on the command line. + for Arg in Command_Arg + 1 .. Argument_Count loop - Last_Switches.Increment_Last; - Last_Switches.Table (Last_Switches.Last) := - new String'(Argument (Arg)); + declare + The_Arg : constant String := Argument (Arg); + begin + -- Check if an argument file is specified + + if The_Arg (The_Arg'First) = '@' then + declare + Arg_File : Ada.Text_IO.File_Type; + Line : String (1 .. 256); + Last : Natural; + + begin + -- Open the file. Fail if the file cannot be found. + + begin + Open + (Arg_File, In_File, + The_Arg (The_Arg'First + 1 .. The_Arg'Last)); + + exception + when others => + Put + (Standard_Error, "Cannot open argument file """); + Put + (Standard_Error, + The_Arg (The_Arg'First + 1 .. The_Arg'Last)); + + Put_Line (Standard_Error, """"); + raise Error_Exit; + end; + + -- Read line by line and put the content of each + -- non empty line in the Last_Switches table. + + while not End_Of_File (Arg_File) loop + Get_Line (Arg_File, Line, Last); + + if Last /= 0 then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(Line (1 .. Last)); + end if; + end loop; + + Close (Arg_File); + end; + + else + -- It is not an argument file; just put the argument in + -- the Last_Switches table. + + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(The_Arg); + end if; + end; end loop; end if; end if; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 08ad0d8..afd3258 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -673,6 +673,11 @@ procedure Gnatlink is -- Predicate indicating whether this target uses the GNU linker. In -- this case we must output a GNU linker compatible response file. + Opening : aliased constant String := """"; + Closing : aliased constant String := '"' & ASCII.LF; + -- Needed to quote object paths in object list files when GNU linker + -- is used. + procedure Get_Next_Line; -- Read the next line from the binder file without the line -- terminator. @@ -883,6 +888,8 @@ procedure Gnatlink is -- If target is using the GNU linker we must add a special header -- and footer in the response file. -- The syntax is : INPUT (object1.o object2.o ... ) + -- Because the GNU linker does not like name with characters such + -- as '!', we must put the object paths between double quotes. if Using_GNU_Linker then declare @@ -895,9 +902,22 @@ procedure Gnatlink is end if; for J in Objs_Begin .. Objs_End loop + -- Opening quote for GNU linker + if Using_GNU_Linker then + Status := Write (Tname_FD, Opening'Address, 1); + end if; + Status := Write (Tname_FD, Linker_Objects.Table (J).all'Address, - Linker_Objects.Table (J).all'Length); - Status := Write (Tname_FD, ASCII.LF'Address, 1); + Linker_Objects.Table (J).all'Length); + + -- Closing quote for GNU linker + + if Using_GNU_Linker then + Status := Write (Tname_FD, Closing'Address, 2); + + else + Status := Write (Tname_FD, ASCII.LF'Address, 1); + end if; Response_File_Objects.Increment_Last; Response_File_Objects.Table (Response_File_Objects.Last) := diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 85294fe..a922c9d 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -690,6 +690,7 @@ package body Snames is -- xxxRA RAs type access routine for type xxx (Exp_TSS) -- xxxRD RAs type dereference routine for type xxx (Exp_TSS) -- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS) + -- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS) -- xxxSI stream input attribute subprogram for type xxx (Exp_TSS) -- xxxSO stream output attribute subprogram for type xxx (Exp_TSS) -- xxxSR stream read attribute subprogram for type xxx (Exp_TSS) diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb index 459d3a1..c632e73 100644 --- a/gcc/ada/vms_conv.adb +++ b/gcc/ada/vms_conv.adb @@ -40,6 +40,9 @@ package body VMS_Conv is Arg_Num : Natural; -- Argument number + Arg_File : Ada.Text_IO.File_Type; + -- A file where arguments are read from + Commands : Item_Ptr; -- Pointer to head of list of command items, one for each command, with -- the end of the list marked by a null pointer. @@ -119,6 +122,14 @@ package body VMS_Conv is -- updating Ptr appropriatelly. Note that in the case of use of ! the -- result may be to remove a previously placed switch. + procedure Preprocess_Command_Data; + -- Preprocess the string form of the command and options list into the + -- internal form. + + procedure Process_Argument (The_Command : in out Command_Type); + -- Process one argument from the command line, or one line from + -- from a command line file. For the first call, set The_Command. + procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr); -- Check that N is a valid command or option name, i.e. that it is of the -- form of an Ada identifier with upper case letters and underscores. @@ -736,61 +747,12 @@ package body VMS_Conv is end loop; end Place_Unix_Switches; - -------------------------------- - -- Validate_Command_Or_Option -- - -------------------------------- - - procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is - begin - pragma Assert (N'Length > 0); - - for J in N'Range loop - if N (J) = '_' then - pragma Assert (N (J - 1) /= '_'); - null; - else - pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J))); - null; - end if; - end loop; - end Validate_Command_Or_Option; - - -------------------------- - -- Validate_Unix_Switch -- - -------------------------- + ----------------------------- + -- Preprocess_Command_Data -- + ----------------------------- - procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is + procedure Preprocess_Command_Data is begin - if S (S'First) = '`' then - return; - end if; - - pragma Assert (S (S'First) = '-' or else S (S'First) = '!'); - - for J in S'First + 1 .. S'Last loop - pragma Assert (S (J) /= ' '); - - if S (J) = '!' then - pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-'); - null; - end if; - end loop; - end Validate_Unix_Switch; - - -------------------- - -- VMS_Conversion -- - -------------------- - - -- This function is *far* too long and *far* too heavily nested, it - -- needs procedural abstraction ??? - - procedure VMS_Conversion (The_Command : out Command_Type) is - begin - Buffer.Init; - - -- First we must preprocess the string form of the command and options - -- list into the internal form that we use. - for C in Real_Command_Type loop declare Command : constant Item_Ptr := new Command_Item; @@ -1016,288 +978,475 @@ package body VMS_Conv is end loop; end; end loop; + end Preprocess_Command_Data; - -- If no parameters, give complete list of commands - - if Argument_Count = 0 then - Output_Version; - New_Line; - Put_Line ("List of available commands"); - New_Line; + ---------------------- + -- Process_Argument -- + ---------------------- - while Commands /= null loop - Put (Commands.Usage.all); - Set_Col (53); - Put_Line (Commands.Unix_String.all); - Commands := Commands.Next; + procedure Process_Argument (The_Command : in out Command_Type) is + Argv : String_Access; + Arg_Idx : Integer; + + function Get_Arg_End + (Argv : String; + Arg_Idx : Integer) return Integer; + -- Begins looking at Arg_Idx + 1 and returns the index of the + -- last character before a slash or else the index of the last + -- character in the string Argv. + + ----------------- + -- Get_Arg_End -- + ----------------- + + function Get_Arg_End + (Argv : String; + Arg_Idx : Integer) return Integer + is + begin + for J in Arg_Idx + 1 .. Argv'Last loop + if Argv (J) = '/' then + return J - 1; + end if; end loop; - raise Normal_Exit; - end if; + return Argv'Last; + end Get_Arg_End; - Arg_Num := 1; + -- Start of processing for Process_Argument - -- Loop through arguments + begin + -- If an argument file is open, read the next non empty line - while Arg_Num <= Argument_Count loop + if Is_Open (Arg_File) then + declare + Line : String (1 .. 256); + Last : Natural; + begin + loop + Get_Line (Arg_File, Line, Last); + exit when Last /= 0 or else End_Of_File (Arg_File); + end loop; - Process_Argument : declare - Argv : String_Access; - Arg_Idx : Integer; - - function Get_Arg_End - (Argv : String; - Arg_Idx : Integer) return Integer; - -- Begins looking at Arg_Idx + 1 and returns the index of the - -- last character before a slash or else the index of the last - -- character in the string Argv. - - ----------------- - -- Get_Arg_End -- - ----------------- - - function Get_Arg_End - (Argv : String; - Arg_Idx : Integer) return Integer - is - begin - for J in Arg_Idx + 1 .. Argv'Last loop - if Argv (J) = '/' then - return J - 1; - end if; - end loop; + -- If the end of the argument file has been reached, close it - return Argv'Last; - end Get_Arg_End; + if End_Of_File (Arg_File) then + Close (Arg_File); - -- Start of processing for Process_Argument + -- If the last line was empty, return after increasing Arg_Num + -- to go to the next argument on the comment line. - begin - Argv := new String'(Argument (Arg_Num)); - Arg_Idx := Argv'First; + if Last = 0 then + Arg_Num := Arg_Num + 1; + return; + end if; + end if; - <> - loop - declare - Next_Arg_Idx : Integer; - Arg : String_Access; + Argv := new String'(Line (1 .. Last)); + Arg_Idx := 1; - begin - Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); - Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); + if Argv (1) = '@' then + Put_Line (Standard_Error, "argument file cannot contain @cmd"); + raise Error_Exit; + end if; + end; - -- The first one must be a command name + else + -- No argument file is open, get the argument on the command line - if Arg_Num = 1 and then Arg_Idx = Argv'First then - Command := Matching_Name (Arg.all, Commands); + Argv := new String'(Argument (Arg_Num)); + Arg_Idx := Argv'First; - if Command = null then - raise Error_Exit; - end if; + -- Check if this is the specification of an argument file - The_Command := Command.Command; + if Argv (Arg_Idx) = '@' then + -- The first argument on the command line cannot be an argument + -- file. - -- Give usage information if only command given + if Arg_Num = 1 then + Put_Line + (Standard_Error, + "Cannot specify argument line before command"); + raise Error_Exit; + end if; - if Argument_Count = 1 - and then Next_Arg_Idx = Argv'Last - then - Output_Version; - New_Line; - Put_Line - ("List of available qualifiers and options"); - New_Line; + -- Open the file, after conversion of the name to canonical form. + -- Fail if file is not found. - Put (Command.Usage.all); - Set_Col (53); - Put_Line (Command.Unix_String.all); + declare + Canonical_File_Name : String_Access := + To_Canonical_File_Spec (Argv (Arg_Idx + 1 .. Argv'Last)); + begin + Open (Arg_File, In_File, Canonical_File_Name.all); + Free (Canonical_File_Name); + return; + + exception + when others => + Put (Standard_Error, "Cannot open argument file """); + Put (Standard_Error, Argv (Arg_Idx + 1 .. Argv'Last)); + Put_Line (Standard_Error, """"); + raise Error_Exit; + end; + end if; + end if; - declare - Sw : Item_Ptr := Command.Switches; + <> + loop + declare + Next_Arg_Idx : Integer; + Arg : String_Access; - begin - while Sw /= null loop - Put (" "); - Put (Sw.Name.all); + begin + Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); - case Sw.Translation is + -- The first one must be a command name - when T_Other => - Set_Col (53); - Put_Line (Sw.Unix_String.all & - "/"); + if Arg_Num = 1 and then Arg_Idx = Argv'First then + Command := Matching_Name (Arg.all, Commands); - when T_Direct => - Set_Col (53); - Put_Line (Sw.Unix_String.all); + if Command = null then + raise Error_Exit; + end if; - when T_Directories => - Put ("=(direc,direc,..direc)"); - Set_Col (53); - Put (Sw.Unix_String.all); - Put (" direc "); - Put (Sw.Unix_String.all); - Put_Line (" direc ..."); + The_Command := Command.Command; - when T_Directory => - Put ("=directory"); - Set_Col (53); - Put (Sw.Unix_String.all); + -- Give usage information if only command given - if Sw.Unix_String (Sw.Unix_String'Last) - /= '=' - then - Put (' '); - end if; + if Argument_Count = 1 + and then Next_Arg_Idx = Argv'Last + then + Output_Version; + New_Line; + Put_Line + ("List of available qualifiers and options"); + New_Line; + + Put (Command.Usage.all); + Set_Col (53); + Put_Line (Command.Unix_String.all); + + declare + Sw : Item_Ptr := Command.Switches; + + begin + while Sw /= null loop + Put (" "); + Put (Sw.Name.all); + + case Sw.Translation is + + when T_Other => + Set_Col (53); + Put_Line (Sw.Unix_String.all & + "/"); + + when T_Direct => + Set_Col (53); + Put_Line (Sw.Unix_String.all); + + when T_Directories => + Put ("=(direc,direc,..direc)"); + Set_Col (53); + Put (Sw.Unix_String.all); + Put (" direc "); + Put (Sw.Unix_String.all); + Put_Line (" direc ..."); + + when T_Directory => + Put ("=directory"); + Set_Col (53); + Put (Sw.Unix_String.all); + + if Sw.Unix_String (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; + + Put_Line ("directory "); + + when T_File | T_No_Space_File => + Put ("=file"); + Set_Col (53); + Put (Sw.Unix_String.all); + + if Sw.Translation = T_File + and then Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Put (' '); + end if; + + Put_Line ("file "); + + when T_Numeric => + Put ("=nnn"); + Set_Col (53); + + if Sw.Unix_String + (Sw.Unix_String'First) = '`' + then + Put (Sw.Unix_String + (Sw.Unix_String'First + 1 + .. Sw.Unix_String'Last)); + else + Put (Sw.Unix_String.all); + end if; + + Put_Line ("nnn"); + + when T_Alphanumplus => + Put ("=xyz"); + Set_Col (53); + + if Sw.Unix_String + (Sw.Unix_String'First) = '`' + then + Put (Sw.Unix_String + (Sw.Unix_String'First + 1 + .. Sw.Unix_String'Last)); + else + Put (Sw.Unix_String.all); + end if; + + Put_Line ("xyz"); + + when T_String => + Put ("="); + Put ('"'); + Put (""); + Put ('"'); + Set_Col (53); + + Put (Sw.Unix_String.all); + + if Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Put (' '); + end if; + + Put (""); + New_Line; + + when T_Commands => + Put (" (switches for "); + Put (Sw.Unix_String + (Sw.Unix_String'First + 7 + .. Sw.Unix_String'Last)); + Put (')'); + Set_Col (53); + Put (Sw.Unix_String + (Sw.Unix_String'First + .. Sw.Unix_String'First + 5)); + Put_Line (" switches"); + + when T_Options => + declare + Opt : Item_Ptr := Sw.Options; - Put_Line ("directory "); + begin + Put_Line ("=(option,option..)"); - when T_File | T_No_Space_File => - Put ("=file"); - Set_Col (53); - Put (Sw.Unix_String.all); + while Opt /= null loop + Put (" "); + Put (Opt.Name.all); - if Sw.Translation = T_File - and then Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Put (' '); + if Opt = Sw.Options then + Put (" (D)"); end if; - Put_Line ("file "); - - when T_Numeric => - Put ("=nnn"); Set_Col (53); + Put_Line (Opt.Unix_String.all); + Opt := Opt.Next; + end loop; + end; - if Sw.Unix_String - (Sw.Unix_String'First) = '`' - then - Put (Sw.Unix_String - (Sw.Unix_String'First + 1 - .. Sw.Unix_String'Last)); - else - Put (Sw.Unix_String.all); - end if; + end case; - Put_Line ("nnn"); + Sw := Sw.Next; + end loop; + end; - when T_Alphanumplus => - Put ("=xyz"); - Set_Col (53); + raise Normal_Exit; + end if; - if Sw.Unix_String - (Sw.Unix_String'First) = '`' - then - Put (Sw.Unix_String - (Sw.Unix_String'First + 1 - .. Sw.Unix_String'Last)); - else - Put (Sw.Unix_String.all); - end if; + -- Special handling for internal debugging switch /? - Put_Line ("xyz"); + elsif Arg.all = "/?" then + Display_Command := True; - when T_String => - Put ("="); - Put ('"'); - Put (""); - Put ('"'); - Set_Col (53); + -- Copy -switch unchanged - Put (Sw.Unix_String.all); + elsif Arg (Arg'First) = '-' then + Place (' '); + Place (Arg.all); - if Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Put (' '); - end if; + -- Copy quoted switch with quotes stripped - Put (""); - New_Line; + elsif Arg (Arg'First) = '"' then + if Arg (Arg'Last) /= '"' then + Put (Standard_Error, "misquoted argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; - when T_Commands => - Put (" (switches for "); - Put (Sw.Unix_String - (Sw.Unix_String'First + 7 - .. Sw.Unix_String'Last)); - Put (')'); - Set_Col (53); - Put (Sw.Unix_String - (Sw.Unix_String'First - .. Sw.Unix_String'First + 5)); - Put_Line (" switches"); + else + Place (' '); + Place (Arg (Arg'First + 1 .. Arg'Last - 1)); + end if; - when T_Options => - declare - Opt : Item_Ptr := Sw.Options; + -- Parameter Argument - begin - Put_Line ("=(option,option..)"); + elsif Arg (Arg'First) /= '/' + and then Make_Commands_Active = null + then + Param_Count := Param_Count + 1; - while Opt /= null loop - Put (" "); - Put (Opt.Name.all); + if Param_Count <= Command.Params'Length then - if Opt = Sw.Options then - Put (" (D)"); - end if; + case Command.Params (Param_Count) is - Set_Col (53); - Put_Line (Opt.Unix_String.all); - Opt := Opt.Next; - end loop; - end; + when File | Optional_File => + declare + Normal_File : constant String_Access := + To_Canonical_File_Spec + (Arg.all); - end case; + begin + Place (' '); + Place_Lower (Normal_File.all); - Sw := Sw.Next; - end loop; + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; end; - raise Normal_Exit; - end if; + when Unlimited_Files => + declare + Normal_File : constant String_Access := + To_Canonical_File_Spec + (Arg.all); - -- Special handling for internal debugging switch /? + File_Is_Wild : Boolean := False; + File_List : String_Access_List_Access; - elsif Arg.all = "/?" then - Display_Command := True; + begin + for J in Arg'Range loop + if Arg (J) = '*' + or else Arg (J) = '%' + then + File_Is_Wild := True; + end if; + end loop; - -- Copy -switch unchanged + if File_Is_Wild then + File_List := To_Canonical_File_List + (Arg.all, False); - elsif Arg (Arg'First) = '-' then - Place (' '); - Place (Arg.all); + for J in File_List.all'Range loop + Place (' '); + Place_Lower (File_List.all (J).all); + end loop; - -- Copy quoted switch with quotes stripped + else + Place (' '); + Place_Lower (Normal_File.all); + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; + end if; - elsif Arg (Arg'First) = '"' then - if Arg (Arg'Last) /= '"' then - Put (Standard_Error, "misquoted argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + Param_Count := Param_Count - 1; + end; - else + when Other_As_Is => Place (' '); - Place (Arg (Arg'First + 1 .. Arg'Last - 1)); - end if; + Place (Arg.all); - -- Parameter Argument + when Unlimited_As_Is => + Place (' '); + Place (Arg.all); + Param_Count := Param_Count - 1; + + when Files_Or_Wildcard => + + -- Remove spaces from a comma separated list + -- of file names and adjust control variables + -- accordingly. + + while Arg_Num < Argument_Count and then + (Argv (Argv'Last) = ',' xor + Argument (Arg_Num + 1) + (Argument (Arg_Num + 1)'First) = ',') + loop + Argv := new String' + (Argv.all & Argument (Arg_Num + 1)); + Arg_Num := Arg_Num + 1; + Arg_Idx := Argv'First; + Next_Arg_Idx := + Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + end loop; - elsif Arg (Arg'First) /= '/' - and then Make_Commands_Active = null - then - Param_Count := Param_Count + 1; + -- Parse the comma separated list of VMS + -- filenames and place them on the command + -- line as space separated Unix style + -- filenames. Lower case and add default + -- extension as appropriate. - if Param_Count <= Command.Params'Length then + declare + Arg1_Idx : Integer := Arg'First; + + function Get_Arg1_End + (Arg : String; + Arg_Idx : Integer) return Integer; + -- Begins looking at Arg_Idx + 1 and + -- returns the index of the last character + -- before a comma or else the index of the + -- last character in the string Arg. + + ------------------ + -- Get_Arg1_End -- + ------------------ + + function Get_Arg1_End + (Arg : String; + Arg_Idx : Integer) return Integer + is + begin + for J in Arg_Idx + 1 .. Arg'Last loop + if Arg (J) = ',' then + return J - 1; + end if; + end loop; - case Command.Params (Param_Count) is + return Arg'Last; + end Get_Arg1_End; - when File | Optional_File => + begin + loop declare - Normal_File : constant String_Access := - To_Canonical_File_Spec - (Arg.all); + Next_Arg1_Idx : + constant Integer := + Get_Arg1_End (Arg.all, Arg1_Idx); + + Arg1 : + constant String := + Arg (Arg1_Idx .. Next_Arg1_Idx); + + Normal_File : + constant String_Access := + To_Canonical_File_Spec (Arg1); begin Place (' '); @@ -1309,584 +1458,536 @@ package body VMS_Conv is Place ('.'); Place (Command.Defext); end if; + + Arg1_Idx := Next_Arg1_Idx + 1; end; - when Unlimited_Files => - declare - Normal_File : constant String_Access := - To_Canonical_File_Spec - (Arg.all); + exit when Arg1_Idx > Arg'Last; - File_Is_Wild : Boolean := False; - File_List : String_Access_List_Access; + -- Don't allow two or more commas in + -- a row - begin - for J in Arg'Range loop - if Arg (J) = '*' - or else Arg (J) = '%' - then - File_Is_Wild := True; - end if; - end loop; + if Arg (Arg1_Idx) = ',' then + Arg1_Idx := Arg1_Idx + 1; + if Arg1_Idx > Arg'Last or else + Arg (Arg1_Idx) = ',' + then + Put_Line + (Standard_Error, + "Malformed Parameter: " & + Arg.all); + Put (Standard_Error, "usage: "); + Put_Line (Standard_Error, + Command.Usage.all); + raise Error_Exit; + end if; + end if; - if File_Is_Wild then - File_List := To_Canonical_File_List - (Arg.all, False); + end loop; + end; + end case; + end if; - for J in File_List.all'Range loop - Place (' '); - Place_Lower (File_List.all (J).all); - end loop; + -- Qualifier argument - else - Place (' '); - Place_Lower (Normal_File.all); + else + -- This code is too heavily nested, should be + -- separated out as separate subprogram ??? - if Is_Extensionless (Normal_File.all) - and then Command.Defext /= " " - then - Place ('.'); - Place (Command.Defext); - end if; - end if; + declare + Sw : Item_Ptr; + SwP : Natural; + P2 : Natural; + Endp : Natural := 0; -- avoid warning! + Opt : Item_Ptr; - Param_Count := Param_Count - 1; - end; + begin + SwP := Arg'First; + while SwP < Arg'Last + and then Arg (SwP + 1) /= '=' + loop + SwP := SwP + 1; + end loop; - when Other_As_Is => - Place (' '); - Place (Arg.all); + -- At this point, the switch name is in + -- Arg (Arg'First..SwP) and if that is not the + -- whole switch, then there is an equal sign at + -- Arg (SwP + 1) and the rest of Arg is what comes + -- after the equal sign. + + -- If make commands are active, see if we have + -- another COMMANDS_TRANSLATION switch belonging + -- to gnatmake. + + if Make_Commands_Active /= null then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => True); + + if Sw /= null + and then Sw.Translation = T_Commands + then + null; - when Unlimited_As_Is => - Place (' '); - Place (Arg.all); - Param_Count := Param_Count - 1; + else + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Make_Commands_Active.Switches, + Quiet => False); + end if; + + -- For case of GNAT MAKE or CHOP, if we cannot + -- find the switch, then see if it is a + -- recognized compiler switch instead, and if + -- so process the compiler switch. + + elsif Command.Name.all = "MAKE" + or else Command.Name.all = "CHOP" then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => True); + + if Sw = null then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Matching_Name + ("COMPILE", Commands).Switches, + Quiet => False); + end if; + + -- For all other cases, just search the relevant + -- command. + + else + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => False); + end if; + + if Sw /= null then + case Sw.Translation is + + when T_Direct => + Place_Unix_Switches (Sw.Unix_String); + if SwP < Arg'Last + and then Arg (SwP + 1) = '=' + then + Put (Standard_Error, + "qualifier options ignored: "); + Put_Line (Standard_Error, Arg.all); + end if; + + when T_Directories => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directories for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; - when Files_Or_Wildcard => + elsif Arg (Arg'Last) /= ')' then - -- Remove spaces from a comma separated list - -- of file names and adjust control variables - -- accordingly. + -- Remove spaces from a comma separated + -- list of file names and adjust + -- control variables accordingly. - while Arg_Num < Argument_Count and then + if Arg_Num < Argument_Count and then (Argv (Argv'Last) = ',' xor Argument (Arg_Num + 1) (Argument (Arg_Num + 1)'First) = ',') - loop - Argv := new String' - (Argv.all & Argument (Arg_Num + 1)); + then + Argv := + new String'(Argv.all + & Argument + (Arg_Num + 1)); Arg_Num := Arg_Num + 1; Arg_Idx := Argv'First; Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); Arg := new String' (Argv (Arg_Idx .. Next_Arg_Idx)); - end loop; + goto Tryagain_After_Coalesce; + end if; + + Put (Standard_Error, + "incorrectly parenthesized " & + "or malformed argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; - -- Parse the comma separated list of VMS - -- filenames and place them on the command - -- line as space separated Unix style - -- filenames. Lower case and add default - -- extension as appropriate. + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; + while SwP <= Endp loop declare - Arg1_Idx : Integer := Arg'First; - - function Get_Arg1_End - (Arg : String; - Arg_Idx : Integer) return Integer; - -- Begins looking at Arg_Idx + 1 and - -- returns the index of the last character - -- before a comma or else the index of the - -- last character in the string Arg. - - ------------------ - -- Get_Arg1_End -- - ------------------ - - function Get_Arg1_End - (Arg : String; - Arg_Idx : Integer) return Integer - is - begin - for J in Arg_Idx + 1 .. Arg'Last loop - if Arg (J) = ',' then - return J - 1; - end if; - end loop; + Dir_Is_Wild : Boolean := False; + Dir_Maybe_Is_Wild : Boolean := False; - return Arg'Last; - end Get_Arg1_End; + Dir_List : String_Access_List_Access; begin + P2 := SwP; + + while P2 < Endp + and then Arg (P2 + 1) /= ',' loop - declare - Next_Arg1_Idx : - constant Integer := - Get_Arg1_End (Arg.all, Arg1_Idx); - - Arg1 : - constant String := - Arg (Arg1_Idx .. Next_Arg1_Idx); - - Normal_File : - constant String_Access := - To_Canonical_File_Spec (Arg1); - - begin - Place (' '); - Place_Lower (Normal_File.all); - - if Is_Extensionless (Normal_File.all) - and then Command.Defext /= " " - then - Place ('.'); - Place (Command.Defext); - end if; - - Arg1_Idx := Next_Arg1_Idx + 1; - end; - - exit when Arg1_Idx > Arg'Last; - - -- Don't allow two or more commas in - -- a row - - if Arg (Arg1_Idx) = ',' then - Arg1_Idx := Arg1_Idx + 1; - if Arg1_Idx > Arg'Last or else - Arg (Arg1_Idx) = ',' - then - Put_Line - (Standard_Error, - "Malformed Parameter: " & - Arg.all); - Put (Standard_Error, "usage: "); - Put_Line (Standard_Error, - Command.Usage.all); - raise Error_Exit; - end if; + -- A wildcard directory spec on + -- VMS will contain either * or + -- % or ... + + if Arg (P2) = '*' then + Dir_Is_Wild := True; + + elsif Arg (P2) = '%' then + Dir_Is_Wild := True; + + elsif Dir_Maybe_Is_Wild + and then Arg (P2) = '.' + and then Arg (P2 + 1) = '.' + then + Dir_Is_Wild := True; + Dir_Maybe_Is_Wild := False; + + elsif Dir_Maybe_Is_Wild then + Dir_Maybe_Is_Wild := False; + + elsif Arg (P2) = '.' + and then Arg (P2 + 1) = '.' + then + Dir_Maybe_Is_Wild := True; + end if; + P2 := P2 + 1; end loop; + + if Dir_Is_Wild then + Dir_List := + To_Canonical_File_List + (Arg (SwP .. P2), True); + + for J in Dir_List.all'Range loop + Place_Unix_Switches + (Sw.Unix_String); + Place_Lower + (Dir_List.all (J).all); + end loop; + + else + Place_Unix_Switches + (Sw.Unix_String); + Place_Lower + (To_Canonical_Dir_Spec + (Arg (SwP .. P2), False).all); + end if; + + SwP := P2 + 2; end; - end case; - end if; + end loop; - -- Qualifier argument + when T_Directory => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directory for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; - else - -- This code is too heavily nested, should be - -- separated out as separate subprogram ??? - - declare - Sw : Item_Ptr; - SwP : Natural; - P2 : Natural; - Endp : Natural := 0; -- avoid warning! - Opt : Item_Ptr; - - begin - SwP := Arg'First; - while SwP < Arg'Last - and then Arg (SwP + 1) /= '=' - loop - SwP := SwP + 1; - end loop; + else + Place_Unix_Switches (Sw.Unix_String); - -- At this point, the switch name is in - -- Arg (Arg'First..SwP) and if that is not the - -- whole switch, then there is an equal sign at - -- Arg (SwP + 1) and the rest of Arg is what comes - -- after the equal sign. + -- Some switches end in "=". No space + -- here - -- If make commands are active, see if we have - -- another COMMANDS_TRANSLATION switch belonging - -- to gnatmake. + if Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Place (' '); + end if; - if Make_Commands_Active /= null then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => True); + Place_Lower + (To_Canonical_Dir_Spec + (Arg (SwP + 2 .. Arg'Last), + False).all); + end if; - if Sw /= null - and then Sw.Translation = T_Commands - then - null; + when T_File | T_No_Space_File => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing file for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; else - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Make_Commands_Active.Switches, - Quiet => False); - end if; + Place_Unix_Switches (Sw.Unix_String); - -- For case of GNAT MAKE or CHOP, if we cannot - -- find the switch, then see if it is a - -- recognized compiler switch instead, and if - -- so process the compiler switch. + -- Some switches end in "=". No space + -- here. - elsif Command.Name.all = "MAKE" - or else Command.Name.all = "CHOP" then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => True); + if Sw.Translation = T_File + and then Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Place (' '); + end if; - if Sw = null then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Matching_Name - ("COMPILE", Commands).Switches, - Quiet => False); + Place_Lower + (To_Canonical_File_Spec + (Arg (SwP + 2 .. Arg'Last)).all); end if; - -- For all other cases, just search the relevant - -- command. - - else - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => False); - end if; + when T_Numeric => + if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); - if Sw /= null then - case Sw.Translation is + else + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line + (Standard_Error, " must be numeric"); + Errors := Errors + 1; + end if; - when T_Direct => - Place_Unix_Switches (Sw.Unix_String); - if SwP < Arg'Last - and then Arg (SwP + 1) = '=' - then - Put (Standard_Error, - "qualifier options ignored: "); - Put_Line (Standard_Error, Arg.all); - end if; + when T_Alphanumplus => + if OK_Alphanumerplus + (Arg (SwP + 2 .. Arg'Last)) + then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); - when T_Directories => - if SwP + 1 > Arg'Last then - Put (Standard_Error, - "missing directories for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + else + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line (Standard_Error, + " must be alphanumeric"); + Errors := Errors + 1; + end if; - elsif Arg (SwP + 2) /= '(' then - SwP := SwP + 2; - Endp := Arg'Last; + when T_String => - elsif Arg (Arg'Last) /= ')' then + -- A String value must be extended to the + -- end of the Argv, otherwise strings like + -- "foo/bar" get split at the slash. - -- Remove spaces from a comma separated - -- list of file names and adjust - -- control variables accordingly. + -- The begining and ending of the string + -- are flagged with embedded nulls which + -- are removed when building the Spawn + -- call. Nulls are use because they won't + -- show up in a /? output. Quotes aren't + -- used because that would make it + -- difficult to embed them. - if Arg_Num < Argument_Count and then - (Argv (Argv'Last) = ',' xor - Argument (Arg_Num + 1) - (Argument (Arg_Num + 1)'First) = ',') - then - Argv := - new String'(Argv.all - & Argument - (Arg_Num + 1)); - Arg_Num := Arg_Num + 1; - Arg_Idx := Argv'First; - Next_Arg_Idx := - Get_Arg_End (Argv.all, Arg_Idx); - Arg := new String' - (Argv (Arg_Idx .. Next_Arg_Idx)); - goto Tryagain_After_Coalesce; - end if; + Place_Unix_Switches (Sw.Unix_String); - Put (Standard_Error, - "incorrectly parenthesized " & - "or malformed argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + if Next_Arg_Idx /= Argv'Last then + Next_Arg_Idx := Argv'Last; + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); - else - SwP := SwP + 3; - Endp := Arg'Last - 1; - end if; + SwP := Arg'First; + while SwP < Arg'Last and then + Arg (SwP + 1) /= '=' loop + SwP := SwP + 1; + end loop; + end if; - while SwP <= Endp loop - declare - Dir_Is_Wild : Boolean := False; - Dir_Maybe_Is_Wild : Boolean := False; - - Dir_List : String_Access_List_Access; - - begin - P2 := SwP; - - while P2 < Endp - and then Arg (P2 + 1) /= ',' - loop - -- A wildcard directory spec on - -- VMS will contain either * or - -- % or ... - - if Arg (P2) = '*' then - Dir_Is_Wild := True; - - elsif Arg (P2) = '%' then - Dir_Is_Wild := True; - - elsif Dir_Maybe_Is_Wild - and then Arg (P2) = '.' - and then Arg (P2 + 1) = '.' - then - Dir_Is_Wild := True; - Dir_Maybe_Is_Wild := False; - - elsif Dir_Maybe_Is_Wild then - Dir_Maybe_Is_Wild := False; - - elsif Arg (P2) = '.' - and then Arg (P2 + 1) = '.' - then - Dir_Maybe_Is_Wild := True; - - end if; - - P2 := P2 + 1; - end loop; - - if Dir_Is_Wild then - Dir_List := - To_Canonical_File_List - (Arg (SwP .. P2), True); - - for J in Dir_List.all'Range loop - Place_Unix_Switches - (Sw.Unix_String); - Place_Lower - (Dir_List.all (J).all); - end loop; - - else - Place_Unix_Switches - (Sw.Unix_String); - Place_Lower - (To_Canonical_Dir_Spec - (Arg (SwP .. P2), False).all); - end if; - - SwP := P2 + 2; - end; - end loop; + Place (ASCII.NUL); + Place (Arg (SwP + 2 .. Arg'Last)); + Place (ASCII.NUL); - when T_Directory => - if SwP + 1 > Arg'Last then - Put (Standard_Error, - "missing directory for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + when T_Commands => - else - Place_Unix_Switches (Sw.Unix_String); + -- Output -largs/-bargs/-cargs - -- Some switches end in "=". No space - -- here + Place (' '); + Place (Sw.Unix_String + (Sw.Unix_String'First .. + Sw.Unix_String'First + 5)); - if Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Place (' '); - end if; + if Sw.Unix_String + (Sw.Unix_String'First + 7 .. + Sw.Unix_String'Last) = "MAKE" + then + Make_Commands_Active := null; - Place_Lower - (To_Canonical_Dir_Spec - (Arg (SwP + 2 .. Arg'Last), - False).all); - end if; + else + -- Set source of new commands, also + -- setting this non-null indicates that + -- we are in the special commands mode + -- for processing the -xargs case. - when T_File | T_No_Space_File => - if SwP + 1 > Arg'Last then - Put (Standard_Error, - "missing file for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; + Make_Commands_Active := + Matching_Name + (Sw.Unix_String + (Sw.Unix_String'First + 7 .. + Sw.Unix_String'Last), + Commands); + end if; - else - Place_Unix_Switches (Sw.Unix_String); + when T_Options => + if SwP + 1 > Arg'Last then + Place_Unix_Switches + (Sw.Options.Unix_String); + SwP := Endp + 1; - -- Some switches end in "=". No space - -- here. + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; - if Sw.Translation = T_File - and then Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Place (' '); - end if; + elsif Arg (Arg'Last) /= ')' then + Put (Standard_Error, + "incorrectly parenthesized argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + SwP := Endp + 1; - Place_Lower - (To_Canonical_File_Spec - (Arg (SwP + 2 .. Arg'Last)).all); - end if; + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; - when T_Numeric => - if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then - Place_Unix_Switches (Sw.Unix_String); - Place (Arg (SwP + 2 .. Arg'Last)); + while SwP <= Endp loop + P2 := SwP; - else - Put (Standard_Error, "argument for "); - Put (Standard_Error, Sw.Name.all); - Put_Line - (Standard_Error, " must be numeric"); - Errors := Errors + 1; - end if; + while P2 < Endp + and then Arg (P2 + 1) /= ',' + loop + P2 := P2 + 1; + end loop; - when T_Alphanumplus => - if OK_Alphanumerplus - (Arg (SwP + 2 .. Arg'Last)) - then - Place_Unix_Switches (Sw.Unix_String); - Place (Arg (SwP + 2 .. Arg'Last)); + -- Option name is in Arg (SwP .. P2) - else - Put (Standard_Error, "argument for "); - Put (Standard_Error, Sw.Name.all); - Put_Line (Standard_Error, - " must be alphanumeric"); - Errors := Errors + 1; - end if; + Opt := Matching_Name (Arg (SwP .. P2), + Sw.Options); - when T_String => + if Opt /= null then + Place_Unix_Switches + (Opt.Unix_String); + end if; - -- A String value must be extended to the - -- end of the Argv, otherwise strings like - -- "foo/bar" get split at the slash. + SwP := P2 + 2; + end loop; - -- The begining and ending of the string - -- are flagged with embedded nulls which - -- are removed when building the Spawn - -- call. Nulls are use because they won't - -- show up in a /? output. Quotes aren't - -- used because that would make it - -- difficult to embed them. + when T_Other => + Place_Unix_Switches + (new String'(Sw.Unix_String.all & + Arg.all)); - Place_Unix_Switches (Sw.Unix_String); + end case; + end if; + end; + end if; - if Next_Arg_Idx /= Argv'Last then - Next_Arg_Idx := Argv'Last; - Arg := new String' - (Argv (Arg_Idx .. Next_Arg_Idx)); + Arg_Idx := Next_Arg_Idx + 1; + end; - SwP := Arg'First; - while SwP < Arg'Last and then - Arg (SwP + 1) /= '=' loop - SwP := SwP + 1; - end loop; - end if; + exit when Arg_Idx > Argv'Last; - Place (ASCII.NUL); - Place (Arg (SwP + 2 .. Arg'Last)); - Place (ASCII.NUL); + end loop; - when T_Commands => + if not Is_Open (Arg_File) then + Arg_Num := Arg_Num + 1; + end if; + end Process_Argument; - -- Output -largs/-bargs/-cargs + -------------------------------- + -- Validate_Command_Or_Option -- + -------------------------------- - Place (' '); - Place (Sw.Unix_String - (Sw.Unix_String'First .. - Sw.Unix_String'First + 5)); + procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is + begin + pragma Assert (N'Length > 0); - if Sw.Unix_String - (Sw.Unix_String'First + 7 .. - Sw.Unix_String'Last) = "MAKE" - then - Make_Commands_Active := null; + for J in N'Range loop + if N (J) = '_' then + pragma Assert (N (J - 1) /= '_'); + null; + else + pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J))); + null; + end if; + end loop; + end Validate_Command_Or_Option; - else - -- Set source of new commands, also - -- setting this non-null indicates that - -- we are in the special commands mode - -- for processing the -xargs case. - - Make_Commands_Active := - Matching_Name - (Sw.Unix_String - (Sw.Unix_String'First + 7 .. - Sw.Unix_String'Last), - Commands); - end if; + -------------------------- + -- Validate_Unix_Switch -- + -------------------------- - when T_Options => - if SwP + 1 > Arg'Last then - Place_Unix_Switches - (Sw.Options.Unix_String); - SwP := Endp + 1; + procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is + begin + if S (S'First) = '`' then + return; + end if; - elsif Arg (SwP + 2) /= '(' then - SwP := SwP + 2; - Endp := Arg'Last; + pragma Assert (S (S'First) = '-' or else S (S'First) = '!'); - elsif Arg (Arg'Last) /= ')' then - Put - (Standard_Error, - "incorrectly parenthesized " & - "argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; - SwP := Endp + 1; + for J in S'First + 1 .. S'Last loop + pragma Assert (S (J) /= ' '); - else - SwP := SwP + 3; - Endp := Arg'Last - 1; - end if; + if S (J) = '!' then + pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-'); + null; + end if; + end loop; + end Validate_Unix_Switch; - while SwP <= Endp loop - P2 := SwP; + -------------------- + -- VMS_Conversion -- + -------------------- - while P2 < Endp - and then Arg (P2 + 1) /= ',' - loop - P2 := P2 + 1; - end loop; + procedure VMS_Conversion (The_Command : out Command_Type) is + Result : Command_Type := Undefined; + Result_Set : Boolean := False; + begin + Buffer.Init; - -- Option name is in Arg (SwP .. P2) + -- First we must preprocess the string form of the command and options + -- list into the internal form that we use. - Opt := Matching_Name (Arg (SwP .. P2), - Sw.Options); + Preprocess_Command_Data; - if Opt /= null then - Place_Unix_Switches - (Opt.Unix_String); - end if; + -- If no parameters, give complete list of commands - SwP := P2 + 2; - end loop; + if Argument_Count = 0 then + Output_Version; + New_Line; + Put_Line ("List of available commands"); + New_Line; - when T_Other => - Place_Unix_Switches - (new String'(Sw.Unix_String.all & - Arg.all)); + while Commands /= null loop + Put (Commands.Usage.all); + Set_Col (53); + Put_Line (Commands.Unix_String.all); + Commands := Commands.Next; + end loop; - end case; - end if; - end; - end if; + raise Normal_Exit; + end if; - Arg_Idx := Next_Arg_Idx + 1; - end; + Arg_Num := 1; - exit when Arg_Idx > Argv'Last; + -- Loop through arguments - end loop; - end Process_Argument; + while Arg_Num <= Argument_Count loop + Process_Argument (Result); - Arg_Num := Arg_Num + 1; + if not Result_Set then + The_Command := Result; + Result_Set := True; + end if; end loop; -- Gross error checking that the number of parameters is correct. -- 2.7.4