From df777314f1fcc8cce837e8c86c56d60425fe875c Mon Sep 17 00:00:00 2001 From: Jose Ruiz Date: Fri, 6 Apr 2007 11:22:40 +0200 Subject: [PATCH] gnatcmd.adb (B_Start): Add prefix of binder generated file. 2007-04-06 Jose Ruiz Vincent Celier * gnatcmd.adb (B_Start): Add prefix of binder generated file. (Stack_String): Add this String that contains the name of the Stack package in the project file. (Packages_To_Check_By_Stack): Add this list that contains the packages to be checked by gnatstack, which are the naming and the stack packages. (Check_Files): If no .ci files were specified for gnatstack we add all the .ci files belonging to the projects, including binder generated files. (Non_VMS_Usage): Document that gnatstack accept project file switches. (GNATCmd): Update the B_Start variable if we are in a VMS environment. Add gnatstack to the list of commands that use project file related switches, and get the single attribute Switches from the stack package in a project file when calling gnatstack. Parse the -U flag for processing files belonging to all projects in the project tree. Remove all processing for command Setup * prj-attr.adb: Add new package Stack with single attribute Switches * vms_conv.ads (Command_Type): Add command Stack. Move to body declarations that are only used in the body: types Item_Id, Translation_Type, Item_Ptr, Item and its subtypes. * vms_conv.adb: (Initialize): Add data for new command Stack. Add declarations moved from the spec: types Item_Id, Translation_Type, Item_Ptr, Item and its subtypes. (Cargs_Buffer): New table (Cargs): New Boolean global variable (Process_Buffer): New procedure to create arguments (Place): Put character in table Buffer or Cargs_Buffer depending on the value of Cargs. (Process_Argument): Set Cargs when processing qualifiers for GNAT COMPILE (VMS_Conversion): Call Process_Buffer for table Buffer and, if it is not empty, for table Cargs_Buffer. (Initialize): Remove component Setup in Command_List From-SVN: r123575 --- gcc/ada/gnatcmd.adb | 526 ++++++++++++++++++++++--------------------- gcc/ada/prj-attr.adb | 5 + gcc/ada/vms_conv.adb | 316 ++++++++++++++++++++------ gcc/ada/vms_conv.ads | 132 +---------- 4 files changed, 516 insertions(+), 463 deletions(-) diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 8eb1563b352..d503a0c334f 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -29,6 +29,7 @@ with GNAT.Directory_Operations; use GNAT.Directory_Operations; with Csets; with MLib.Tgt; use MLib.Tgt; with MLib.Utl; +with MLib.Fil; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; @@ -60,6 +61,9 @@ procedure GNATCmd is Current_Verbosity : Prj.Verbosity := Prj.Default; Tool_Package_Name : Name_Id := No_Name; + B_Start : String_Ptr := new String'("b~"); + -- Prefix of binder generated file, changed to b__ for VMS + Old_Project_File_Used : Boolean := False; -- This flag indicates a switch -p (for gnatxref and gnatfind) for -- an old fashioned project file. -p cannot be used in conjonction @@ -120,6 +124,7 @@ procedure GNATCmd is Linker_String : constant String_Access := new String'("linker"); Gnatls_String : constant String_Access := new String'("gnatls"); Pretty_String : constant String_Access := new String'("pretty_printer"); + Stack_String : constant String_Access := new String'("stack"); Gnatstub_String : constant String_Access := new String'("gnatstub"); Metric_String : constant String_Access := new String'("metrics"); Xref_String : constant String_Access := new String'("cross_reference"); @@ -145,6 +150,9 @@ procedure GNATCmd is Packages_To_Check_By_Pretty : constant String_List_Access := new String_List'((Naming_String, Pretty_String, Compiler_String)); + Packages_To_Check_By_Stack : constant String_List_Access := + new String_List'((Naming_String, Stack_String)); + Packages_To_Check_By_Gnatstub : constant String_List_Access := new String_List'((Naming_String, Gnatstub_String, Compiler_String)); @@ -174,54 +182,52 @@ procedure GNATCmd is -- The path of the working directory All_Projects : Boolean := False; - -- Flag used for GNAT PRETTY and GNAT METRIC to indicate that - -- the underlying tool (gnatcheck, gnatpp or gnatmetric) should be invoked - -- for all sources of all projects. + -- Flag used for GNAT CHECK, GNAT PRETTY, GNAT METRIC, and GNAT STACK to + -- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric) + -- should be invoked for all sources of all projects. ----------------------- -- Local Subprograms -- ----------------------- procedure Add_To_Carg_Switches (Switch : String_Access); - -- Add a switch to the Carg_Switches table. If it is the first one, - -- put the switch "-cargs" at the beginning of the table. + -- Add a switch to the Carg_Switches table. If it is the first one, put the + -- switch "-cargs" at the beginning of the table. procedure Add_To_Rules_Switches (Switch : String_Access); - -- Add a switch to the Rules_Switches table. If it is the first one, - -- put the switch "-crules" at the beginning of the table. + -- Add a switch to the Rules_Switches table. If it is the first one, put + -- the switch "-crules" at the beginning of the table. procedure Check_Files; - -- For GNAT LIST, GNAT PRETTY and GNAT METRIC, check if a project - -- file is specified, without any file arguments. If it is the case, - -- invoke the GNAT tool with the proper list of files, derived from + -- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a + -- project file is specified, without any file arguments. If it is the + -- case, invoke the GNAT tool with the proper list of files, derived from -- the sources of the project. function Check_Project (Project : Project_Id; Root_Project : Project_Id) return Boolean; - -- Returns True if Project = Root_Project. - -- For GNAT METRIC, also returns True if Project is extended by - -- Root_Project. + -- Returns True if Project = Root_Project or if we want to consider all + -- sources of all projects. For GNAT METRIC, also returns True if Project + -- is extended by Root_Project. procedure Check_Relative_Executable (Name : in out String_Access); - -- Check if an executable is specified as a relative path. - -- If it is, and the path contains directory information, fail. - -- Otherwise, prepend the exec directory. - -- This procedure is only used for GNAT LINK when a project file - -- is specified. + -- Check if an executable is specified as a relative path. If it is, and + -- the path contains directory information, fail. Otherwise, prepend the + -- exec directory. This procedure is only used for GNAT LINK when a project + -- file is specified. function Configuration_Pragmas_File return Name_Id; -- Return an argument, if there is a configuration pragmas file to be - -- specified for Project, otherwise return No_Name. - -- Used for gnatstub (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim - -- (GNAT ELIM), and gnatmetric (GNAT METRIC). + -- specified for Project, otherwise return No_Name. Used for gnatstub (GNAT + -- STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric (GNAT + -- METRIC). procedure Delete_Temp_Config_Files; -- Delete all temporary config files function Index (Char : Character; Str : String) return Natural; - -- Returns the first occurrence of Char in Str. - -- Returns 0 if Char is not in Str. + -- Returns first occurrence of Char in Str, returns 0 if Char not in Str procedure Non_VMS_Usage; -- Display usage for platforms other than VMS @@ -232,20 +238,20 @@ procedure GNATCmd is procedure Set_Library_For (Project : Project_Id; There_Are_Libraries : in out Boolean); - -- If Project is a library project, add the correct - -- -L and -l switches to the linker invocation. + -- If Project is a library project, add the correct -L and -l switches to + -- the linker invocation. procedure Set_Libraries is new For_Every_Project_Imported (Boolean, Set_Library_For); - -- Add the -L and -l switches to the linker for all - -- of the library projects. + -- Add the -L and -l switches to the linker for all of the library + -- projects. procedure Test_If_Relative_Path (Switch : in out String_Access; Parent : String); - -- Test if Switch is a relative search path switch. - -- If it is and it includes directory information, prepend the path with - -- Parent.This subprogram is only called when using project files. + -- Test if Switch is a relative search path switch. If it is and it + -- includes directory information, prepend the path with Parent. This + -- subprogram is only called when using project files. -------------------------- -- Add_To_Carg_Switches -- @@ -300,27 +306,89 @@ procedure GNATCmd is end if; end loop; - -- If all arguments were switches, add the path names of - -- all the sources of the main project. + -- If all arguments were switches, add the path names of all the sources + -- of the main project. if Add_Sources then declare Current_Last : constant Integer := Last_Switches.Last; begin + -- Gnatstack needs to add the the .ci file for the binder + -- generated files corresponding to all of the library projects + -- and main units belonging to the application. + + if The_Command = Stack then + for Proj in Project_Table.First .. + Project_Table.Last (Project_Tree.Projects) + loop + if Check_Project (Proj, Project) then + declare + Data : Project_Data renames + Project_Tree.Projects.Table (Proj); + Main : String_List_Id := Data.Mains; + File : String_Access; + + begin + -- Include binder generated files for main programs + + while Main /= Nil_String loop + File := + new String' + (Get_Name_String (Data.Object_Directory) & + Directory_Separator & + B_Start.all & + MLib.Fil.Ext_To + (Get_Name_String + (Project_Tree.String_Elements.Table + (Main).Value), + "ci")); + + if Is_Regular_File (File.all) then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := File; + end if; + + Main := + Project_Tree.String_Elements.Table (Main).Next; + end loop; + + if Data.Library then + + -- Include the .ci file for the binder generated + -- files that contains the initialization and + -- finalization of the library. + + File := + new String' + (Get_Name_String (Data.Object_Directory) & + Directory_Separator & + B_Start.all & + Get_Name_String (Data.Library_Name) & + ".ci"); + + if Is_Regular_File (File.all) then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := File; + end if; + end if; + end; + end if; + end loop; + end if; + for Unit in Unit_Table.First .. Unit_Table.Last (Project_Tree.Units) loop Unit_Data := Project_Tree.Units.Table (Unit); - -- For gnatls, we only need to put the library units, - -- body or spec, but not the subunits. + -- For gnatls, we only need to put the library units, body or + -- spec, but not the subunits. if The_Command = List then if Unit_Data.File_Names (Body_Part).Name /= No_Name then - -- There is a body; check if it is for this - -- project. + -- There is a body, check if it is for this project if Unit_Data.File_Names (Body_Part).Project = Project @@ -330,9 +398,9 @@ procedure GNATCmd is if Unit_Data.File_Names (Specification).Name = No_Name then - -- We have a body with no spec: we need - -- to check if this is a subunit, because - -- gnatls will complain about subunits. + -- We have a body with no spec: we need to check if + -- this is a subunit, because gnatls will complain + -- about subunits. declare Src_Ind : Source_File_Index; @@ -359,11 +427,11 @@ procedure GNATCmd is end if; end if; - elsif Unit_Data.File_Names (Specification).Name /= - No_Name + elsif + Unit_Data.File_Names (Specification).Name /= No_Name then - -- We have a spec with no body; check if it is - -- for this project. + -- We have a spec with no body; check if it is for this + -- project. if Unit_Data.File_Names (Specification).Project = Project @@ -377,14 +445,97 @@ procedure GNATCmd is end if; end if; + -- For gnatstack, we put the .ci files corresponding to the + -- different units, including the binder generated files. We + -- only need to do that for the library units, body or spec, + -- but not the subunits. + + elsif The_Command = Stack then + if + Unit_Data.File_Names (Body_Part).Name /= No_Name + then + -- There is a body. Check if .ci files for this project + -- must be added. + + if + Check_Project + (Unit_Data.File_Names (Body_Part).Project, Project) + then + Subunit := False; + + if + Unit_Data.File_Names (Specification).Name = No_Name + then + -- We have a body with no spec: we need to check + -- if this is a subunit, because .ci files are not + -- generated for subunits. + + declare + Src_Ind : Source_File_Index; + + begin + Src_Ind := Sinput.P.Load_Project_File + (Get_Name_String + (Unit_Data.File_Names (Body_Part).Path)); + + Subunit := + Sinput.P.Source_File_Is_Subunit (Src_Ind); + end; + end if; + + if not Subunit then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String' + (Get_Name_String + (Project_Tree.Projects.Table + (Unit_Data.File_Names + (Body_Part).Project). + Object_Directory) & + Directory_Separator & + MLib.Fil.Ext_To + (Get_Name_String + (Unit_Data.File_Names + (Body_Part).Display_Name), + "ci")); + end if; + end if; + + elsif + Unit_Data.File_Names (Specification).Name /= No_Name + then + -- We have a spec with no body. Check if it is for this + -- project. + + if + Check_Project + (Unit_Data.File_Names (Specification).Project, + Project) + then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String' + (Get_Name_String + (Project_Tree.Projects.Table + (Unit_Data.File_Names + (Specification).Project). + Object_Directory) & + Dir_Separator & + MLib.Fil.Ext_To + (Get_Name_String + (Unit_Data.File_Names + (Specification).Name), + "ci")); + end if; + end if; + else -- For gnatcheck, gnatpp and gnatmetric, put all sources -- of the project, or of all projects if -U was specified. for Kind in Spec_Or_Body loop - -- Put only sources that belong to the main - -- project. + -- Put only sources that belong to the main project if Check_Project (Unit_Data.File_Names (Kind).Project, Project) @@ -400,9 +551,9 @@ procedure GNATCmd is end if; end loop; - -- If the list of files is too long, create a temporary - -- text file that lists these files, and pass this temp - -- file to gnatcheck, gnatpp or gnatmetric using switch -files=. + -- If the list of files is too long, create a temporary text file + -- that lists these files, and pass this temp file to gnatcheck, + -- gnatpp or gnatmetric using switch -files=. if Last_Switches.Last - Current_Last > Max_Files_On_The_Command_Line @@ -421,8 +572,7 @@ procedure GNATCmd is Last_Switches.Last loop Len := Last_Switches.Table (Index)'Length; - Buffer (1 .. Len) := - Last_Switches.Table (Index).all; + Buffer (1 .. Len) := Last_Switches.Table (Index).all; Len := Len + 1; Buffer (Len) := ASCII.LF; Buffer (Len + 1) := ASCII.NUL; @@ -440,13 +590,12 @@ procedure GNATCmd is OK := False; end if; - -- If there were any problem creating the temp - -- file, then pass the list of files. + -- If there were any problem creating the temp file, then + -- pass the list of files. if OK then - -- Replace the list of files with - -- "-files=". + -- Replace list of files with -files= Last_Switches.Set_Last (Current_Last + 1); Last_Switches.Table (Last_Switches.Last) := @@ -476,10 +625,10 @@ procedure GNATCmd is elsif The_Command = Metric then declare - Data : Project_Data := - Project_Tree.Projects.Table (Root_Project); + Data : Project_Data; begin + Data := Project_Tree.Projects.Table (Root_Project); while Data.Extends /= No_Project loop if Project = Data.Extends then return True; @@ -601,14 +750,14 @@ procedure GNATCmd is ------------------ procedure Process_Link is - Look_For_Executable : Boolean := True; - There_Are_Libraries : Boolean := False; - Path_Option : constant String_Access := - MLib.Linker_Library_Path_Option; - Prj : Project_Id := Project; - Arg : String_Access; - Last : Natural := 0; - Skip_Executable : Boolean := False; + Look_For_Executable : Boolean := True; + There_Are_Libraries : Boolean := False; + Path_Option : constant String_Access := + MLib.Linker_Library_Path_Option; + Prj : Project_Id := Project; + Arg : String_Access; + Last : Natural := 0; + Skip_Executable : Boolean := False; begin -- Add the default search directories, to be able to find @@ -640,9 +789,9 @@ procedure GNATCmd is Last_Switches.Table (Last_Switches.Last) := new String'("-lgnat"); - -- If Path_Option is not null, create the switch - -- ("-Wl,-rpath," or equivalent) with all the library dirs - -- plus the standard GNAT library dir. + -- If Path_Option is not null, create the switch ("-Wl,-rpath," or + -- equivalent) with all the library dirs plus the standard GNAT + -- library dir. if Path_Option /= null then declare @@ -656,16 +805,15 @@ procedure GNATCmd is for Index in Library_Paths.First .. Library_Paths.Last loop - -- Add the length of the library dir plus one - -- for the directory separator. + -- Add the length of the library dir plus one for the + -- directory separator. Length := Length + Library_Paths.Table (Index)'Length + 1; end loop; - -- Finally, add the length of the standard GNAT - -- library dir. + -- Finally, add the length of the standard GNAT library dir Length := Length + MLib.Utl.Lib_Directory'Length; Option := new String (1 .. Length); @@ -704,11 +852,10 @@ procedure GNATCmd is end if; end if; - -- Check if the first ALI file specified can be found, either - -- in the object directory of the main project or in an object - -- directory of a project file extended by the main project. - -- If the ALI file can be found, replace its name with its - -- absolute path. + -- Check if the first ALI file specified can be found, either in the + -- object directory of the main project or in an object directory of a + -- project file extended by the main project. If the ALI file can be + -- found, replace its name with its absolute path. Skip_Executable := False; @@ -753,8 +900,8 @@ procedure GNATCmd is Last := ALI_File'Last; end if; - -- If file name includes directory information, - -- stop if ALI file exists. + -- If file name includes directory information, stop if ALI + -- file exists. if Is_Absolute_Path (ALI_File (1 .. Last)) then Test_Existence := True; @@ -804,8 +951,7 @@ procedure GNATCmd is end if; end; - -- Go to the project being extended, - -- if any. + -- Go to the project being extended, if any Prj := Project_Tree.Projects.Table (Prj).Extends; @@ -817,8 +963,8 @@ procedure GNATCmd is end if; end loop Switch_Loop; - -- If a relative path output file has been specified, we add - -- the exec directory. + -- If a relative path output file has been specified, we add the exec + -- directory. for J in reverse 1 .. Last_Switches.Last - 1 loop if Last_Switches.Table (J).all = "-o" then @@ -840,10 +986,9 @@ procedure GNATCmd is end loop; end if; - -- If no executable is specified, then find the name - -- of the first ALI file on the command line and issue - -- a -o switch with the absolute path of the executable - -- in the exec directory. + -- If no executable is specified, then find the name of the first ALI + -- file on the command line and issue a -o switch with the absolute path + -- of the executable in the exec directory. if Look_For_Executable then for J in 1 .. Last_Switches.Last loop @@ -1030,8 +1175,8 @@ procedure GNATCmd is end loop; New_Line; - Put_Line ("Commands find, list, metric, pretty, stub and xref accept " & - "project file switches -vPx, -Pprj and -Xnam=val"); + Put_Line ("Commands find, list, metric, pretty, stack, stub and xref " & + "accept project file switches -vPx, -Pprj and -Xnam=val"); New_Line; end Non_VMS_Usage; @@ -1061,10 +1206,9 @@ begin VMS_Conv.Initialize; - -- Add the directory where the GNAT driver is invoked in front of the - -- path, if the GNAT driver is invoked with directory information. - -- Only do this if the platform is not VMS, where the notion of path - -- does not really exist. + -- Add the directory where the GNAT driver is invoked in front of the path, + -- if the GNAT driver is invoked with directory information. Do not do this + -- for VMS, where the notion of path does not really exist. if not OpenVMS then declare @@ -1101,6 +1245,8 @@ begin then VMS_Conversion (The_Command); + B_Start := new String'("b__"); + -- If not on VMS, scan the command line directly else @@ -1193,8 +1339,8 @@ begin raise Error_Exit; end; - -- Read line by line and put the content of each - -- non empty line in the Last_Switches table. + -- 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); @@ -1229,149 +1375,6 @@ begin Exec_Path : String_Access; begin - -- First deal with built-in command(s) - - if The_Command = Setup then - Process_Setup : - declare - Arg_Num : Positive := 1; - Argv : String_Access; - - begin - while Arg_Num <= Last_Switches.Last loop - Argv := Last_Switches.Table (Arg_Num); - - if Argv (Argv'First) /= '-' then - Fail ("invalid parameter """, Argv.all, """"); - - else - if Argv'Length = 1 then - Fail - ("switch character cannot be followed by a blank"); - end if; - - -- -vPx Specify verbosity while parsing project files - - if Argv'Length = 4 - and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" - then - case Argv (Argv'Last) is - when '0' => - Current_Verbosity := Prj.Default; - when '1' => - Current_Verbosity := Prj.Medium; - when '2' => - Current_Verbosity := Prj.High; - when others => - Fail ("Invalid switch: ", Argv.all); - end case; - - -- -Pproject_file Specify project file to be used - - elsif Argv (Argv'First + 1) = 'P' then - - -- Only one -P switch can be used - - if Project_File /= null then - Fail - (Argv.all, - ": second project file forbidden (first is """, - Project_File.all & """)"); - - elsif Argv'Length = 2 then - - -- There is space between -P and the project file - -- name. -P cannot be the last option. - - if Arg_Num = Last_Switches.Last then - Fail ("project file name missing after -P"); - - else - Arg_Num := Arg_Num + 1; - Argv := Last_Switches.Table (Arg_Num); - - -- After -P, there must be a project file name, - -- not another switch. - - if Argv (Argv'First) = '-' then - Fail ("project file name missing after -P"); - - else - Project_File := new String'(Argv.all); - end if; - end if; - - else - -- No space between -P and project file name - - Project_File := - new String'(Argv (Argv'First + 2 .. Argv'Last)); - end if; - - -- -Xexternal=value Specify an external reference to be - -- used in project files - - elsif Argv'Length >= 5 - and then Argv (Argv'First + 1) = 'X' - then - declare - Equal_Pos : constant Natural := - Index ('=', Argv (Argv'First + 2 .. Argv'Last)); - begin - if Equal_Pos >= Argv'First + 3 and then - Equal_Pos /= Argv'Last then - Add - (External_Name => - Argv (Argv'First + 2 .. Equal_Pos - 1), - Value => Argv (Equal_Pos + 1 .. Argv'Last)); - else - Fail - (Argv.all, - " is not a valid external assignment."); - end if; - end; - - elsif Argv.all = "-v" then - Verbose_Mode := True; - - elsif Argv.all = "-q" then - Quiet_Output := True; - - else - Fail ("invalid parameter """, Argv.all, """"); - end if; - end if; - - Arg_Num := Arg_Num + 1; - end loop; - - if Project_File = null then - Fail ("no project file specified"); - end if; - - Setup_Projects := True; - - Prj.Pars.Set_Verbosity (To => Current_Verbosity); - - -- Missing directories are created during processing of the - -- project tree. - - Prj.Pars.Parse - (Project => Project, - In_Tree => Project_Tree, - Project_File_Name => Project_File.all, - Packages_To_Check => All_Packages); - - if Project = Prj.No_Project then - Fail ("""", Project_File.all, """ processing failed"); - end if; - - -- Processing is done - - return; - end Process_Setup; - end if; - -- Locate the executable for the command Exec_Path := Locate_Exec_On_Path (Program); @@ -1391,8 +1394,8 @@ begin end loop; end if; - -- For BIND, CHECK, FIND, LINK, LIST, PRETTY ad XREF, look for project - -- file related switches. + -- For BIND, CHECK, ELIM, FIND, LINK, LIST, PRETTY, STACK, STUB, + -- METRIC ad XREF, look for project file related switches. if The_Command = Bind or else The_Command = Check @@ -1402,6 +1405,7 @@ begin or else The_Command = List or else The_Command = Xref or else The_Command = Pretty + or else The_Command = Stack or else The_Command = Stub or else The_Command = Metric then @@ -1430,6 +1434,9 @@ begin when Pretty => Tool_Package_Name := Name_Pretty_Printer; Packages_To_Check := Packages_To_Check_By_Pretty; + when Stack => + Tool_Package_Name := Name_Stack; + Packages_To_Check := Packages_To_Check_By_Stack; when Stub => Tool_Package_Name := Name_Gnatstub; Packages_To_Check := Packages_To_Check_By_Gnatstub; @@ -1440,8 +1447,8 @@ begin null; end case; - -- Check that the switches are consistent. - -- Detect project file related switches. + -- Check that the switches are consistent. Detect project file + -- related switches. Inspect_Switches : declare @@ -1562,7 +1569,9 @@ begin then declare Equal_Pos : constant Natural := - Index ('=', Argv (Argv'First + 2 .. Argv'Last)); + Index + ('=', + Argv (Argv'First + 2 .. Argv'Last)); begin if Equal_Pos >= Argv'First + 3 and then Equal_Pos /= Argv'Last then @@ -1581,7 +1590,8 @@ begin elsif (The_Command = Check or else The_Command = Pretty or else - The_Command = Metric) + The_Command = Metric or else + The_Command = Stack) and then Argv'Length = 2 and then Argv (2) = 'U' then @@ -1640,10 +1650,10 @@ begin if Pkg /= No_Package then Element := Project_Tree.Packages.Table (Pkg); - -- Packages Gnatls has a single attribute Switches, that is - -- not an associative array. + -- Packages Gnatls and Gnatstack have a single attribute + -- Switches, that is not an associative array. - if The_Command = List then + if The_Command = List or else The_Command = Stack then The_Switches := Prj.Util.Value_Of (Variable_Name => Snames.Name_Switches, @@ -1651,14 +1661,14 @@ begin In_Tree => Project_Tree); -- Packages Binder (for gnatbind), Cross_Reference (for - -- gnatxref), Linker (for gnatlink) Finder (for gnatfind), - -- Pretty_Printer (for gnatpp) Eliminate (for gnatelim), - -- Check (for gnatcheck) and Metric (for gnatmetric) have - -- an attributed Switches, an associative array, indexed - -- by the name of the file. + -- gnatxref), Linker (for gnatlink), Finder (for gnatfind), + -- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check + -- (for gnatcheck), and Metric (for gnatmetric) have an + -- attributed Switches, an associative array, indexed by the + -- name of the file. - -- They also have an attribute Default_Switches, indexed - -- by the name of the programming language. + -- They also have an attribute Default_Switches, indexed by the + -- name of the programming language. else if The_Switches.Kind = Prj.Undefined then @@ -1790,7 +1800,6 @@ begin declare Switch : constant String := Get_Name_String (The_Switches.Value); - begin if Switch'Length > 0 then Add_To_Carg_Switches (new String'(Switch)); @@ -2031,14 +2040,15 @@ begin end; end if; - -- For gnat check, gnat pretty, gnat metric ands gnat list, - -- if no file has been put on the command line, call tool with all - -- the sources of the main project. + -- For gnat check, gnat pretty, gnat metric, gnat list, and gnat + -- stack, if no file has been put on the command line, call tool + -- with all the sources of the main project. if The_Command = Check or else The_Command = Pretty or else The_Command = Metric or else - The_Command = List + The_Command = List or else + The_Command = Stack then Check_Files; end if; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index f73751c8c26..5b109001800 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -191,6 +191,11 @@ package body Prj.Attr is "SVvcs_file_check#" & "SVvcs_log_check#" & + -- package Stack + + "Pstack#" & + "LVswitches#" & + -- package Language_Processing "Planguage_processing#" & diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb index c5e53d7e113..250ed6206c8 100644 --- a/gcc/ada/vms_conv.adb +++ b/gcc/ada/vms_conv.adb @@ -36,6 +36,134 @@ with Ada.Text_IO; use Ada.Text_IO; package body VMS_Conv is + ------------------------- + -- Internal Structures -- + ------------------------- + + -- The switches and commands are defined by strings in the previous + -- section so that they are easy to modify, but internally, they are + -- kept in a more conveniently accessible form described in this + -- section. + + -- Commands, command qualifers and options have a similar common format + -- so that searching for matching names can be done in a common manner. + + type Item_Id is (Id_Command, Id_Switch, Id_Option); + + type Translation_Type is + ( + T_Direct, + -- A qualifier with no options. + -- Example: GNAT MAKE /VERBOSE + + T_Directories, + -- A qualifier followed by a list of directories + -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR]) + + T_Directory, + -- A qualifier followed by one directory + -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB] + + T_File, + -- A qualifier followed by a filename + -- Example: GNAT LINK /EXECUTABLE=FOO.EXE + + T_No_Space_File, + -- A qualifier followed by a filename + -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR + + T_Numeric, + -- A qualifier followed by a numeric value. + -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39 + + T_String, + -- A qualifier followed by a quoted string. Only used by + -- /IDENTIFICATION qualifier. + -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version" + + T_Options, + -- A qualifier followed by a list of options. + -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS) + + T_Commands, + -- A qualifier followed by a list. Only used for + -- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS + -- (gnatmake -cargs -bargs -largs ) + -- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ + + T_Other, + -- A qualifier passed directly to the linker. Only used + -- for LINK and SHARED if no other match is found. + -- Example: GNAT LINK FOO.ALI /SYSSHR + + T_Alphanumplus + -- A qualifier followed by a legal linker symbol prefix. Only used + -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz). + -- Example: GNAT BIND /BUILD_LIBRARY=foobar + ); + + type Item (Id : Item_Id); + type Item_Ptr is access all Item; + + type Item (Id : Item_Id) is record + Name : String_Ptr; + -- Name of the command, switch (with slash) or option + + Next : Item_Ptr; + -- Pointer to next item on list, always has the same Id value + + Command : Command_Type := Undefined; + + Unix_String : String_Ptr := null; + -- Corresponding Unix string. For a command, this is the unix command + -- name and possible default switches. For a switch or option it is + -- the unix switch string. + + case Id is + + when Id_Command => + + Switches : Item_Ptr; + -- Pointer to list of switch items for the command, linked + -- through the Next fields with null terminating the list. + + Usage : String_Ptr; + -- Usage information, used only for errors and the default + -- list of commands output. + + Params : Parameter_Ref; + -- Array of parameters + + Defext : String (1 .. 3); + -- Default extension. If non-blank, then this extension is + -- supplied by default as the extension for any file parameter + -- which does not have an extension already. + + when Id_Switch => + + Translation : Translation_Type; + -- Type of switch translation. For all cases, except Options, + -- this is the only field needed, since the Unix translation + -- is found in Unix_String. + + Options : Item_Ptr; + -- For the Options case, this field is set to point to a list + -- of options item (for this case Unix_String is null in the + -- main switch item). The end of the list is marked by null. + + when Id_Option => + + null; + -- No special fields needed, since Name and Unix_String are + -- sufficient to completely described an option. + + end case; + end record; + + subtype Command_Item is Item (Id_Command); + subtype Switch_Item is Item (Id_Switch); + subtype Option_Item is Item (Id_Option); + Keep_Temps_Option : constant Item_Ptr := new Item' (Id => Id_Option, @@ -80,6 +208,19 @@ package body VMS_Conv is Table_Initial => 4096, Table_Increment => 100, Table_Name => "Buffer"); + -- Table to store the command to be used + + package Cargs_Buffer is new Table.Table + (Table_Component_Type => Character, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 4096, + Table_Increment => 100, + Table_Name => "Cargs_Buffer"); + -- Table to store the compiler switches for GNAT COMPILE + + Cargs : Boolean := False; + -- When True, commands should go to Cargs_Buffer instead of Buffer table function Init_Object_Dirs return Argument_List; -- Get the list of the object directories @@ -145,6 +286,10 @@ package body VMS_Conv is -- Process one argument from the command line, or one line from -- from a command line file. For the first call, set The_Command. + procedure Process_Buffer (S : String); + -- Process the characters in the Buffer table or the Cargs_Buffer table + -- to convert these into arguments. + 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. @@ -360,16 +505,6 @@ package body VMS_Conv is Params => new Parameter_Array'(1 => Unlimited_Files), Defext => " "), - Setup => - (Cname => new S'("SETUP"), - Usage => new S'("GNAT SETUP /qualifiers"), - VMS_Only => False, - Unixcmd => new S'(""), - Unixsws => null, - Switches => Setup_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => " "), - Shared => (Cname => new S'("SHARED"), Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt" @@ -382,6 +517,16 @@ package body VMS_Conv is Params => new Parameter_Array'(1 => Unlimited_Files), Defext => " "), + Stack => + (Cname => new S'("STACK"), + Usage => new S'("GNAT STACK /qualifiers ci_files"), + VMS_Only => False, + Unixcmd => new S'("gnatstack"), + Unixsws => null, + Switches => Stack_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => "ci" & ASCII.NUL), + Stub => (Cname => new S'("STUB"), Usage => new S'("GNAT STUB file [directory]/qualifiers"), @@ -673,8 +818,11 @@ package body VMS_Conv is procedure Place (C : Character) is begin - Buffer.Increment_Last; - Buffer.Table (Buffer.Last) := C; + if Cargs then + Cargs_Buffer.Append (C); + else + Buffer.Append (C); + end if; end Place; procedure Place (S : String) is @@ -1052,6 +1200,8 @@ package body VMS_Conv is -- Start of processing for Process_Argument begin + Cargs := False; + -- If an argument file is open, read the next non empty line if Is_Open (Arg_File) then @@ -1554,6 +1704,8 @@ package body VMS_Conv is else Output_File_Expected := False; + Cargs := Command.Name.all = "COMPILE"; + -- This code is too heavily nested, should be -- separated out as separate subprogram ??? @@ -1966,6 +2118,73 @@ package body VMS_Conv is end if; end Process_Argument; + -------------------- + -- Process_Buffer -- + -------------------- + + procedure Process_Buffer (S : String) is + P1, P2 : Natural; + Inside_Nul : Boolean := False; + Arg : String (1 .. 1024); + Arg_Ctr : Natural; + + begin + P1 := 1; + while P1 <= S'Last and then S (P1) = ' ' loop + P1 := P1 + 1; + end loop; + + Arg_Ctr := 1; + Arg (Arg_Ctr) := S (P1); + + while P1 <= S'Last loop + if S (P1) = ASCII.NUL then + if Inside_Nul then + Inside_Nul := False; + else + Inside_Nul := True; + end if; + end if; + + if S (P1) = ' ' and then not Inside_Nul then + P1 := P1 + 1; + Arg_Ctr := Arg_Ctr + 1; + Arg (Arg_Ctr) := S (P1); + + else + Last_Switches.Increment_Last; + P2 := P1; + + while P2 < S'Last + and then (S (P2 + 1) /= ' ' or else + Inside_Nul) + loop + P2 := P2 + 1; + Arg_Ctr := Arg_Ctr + 1; + Arg (Arg_Ctr) := S (P2); + if S (P2) = ASCII.NUL then + Arg_Ctr := Arg_Ctr - 1; + + if Inside_Nul then + Inside_Nul := False; + else + Inside_Nul := True; + end if; + end if; + end loop; + + Last_Switches.Table (Last_Switches.Last) := + new String'(String (Arg (1 .. Arg_Ctr))); + P1 := P2 + 2; + + exit when P1 > S'Last; + + Arg_Ctr := 1; + Arg (Arg_Ctr) := S (P1); + end if; + end loop; + end Process_Buffer; + -------------------------------- -- Validate_Command_Or_Option -- -------------------------------- @@ -2012,8 +2231,9 @@ package body VMS_Conv is -------------------- procedure VMS_Conversion (The_Command : out Command_Type) is - Result : Command_Type := Undefined; - Result_Set : Boolean := False; + Result : Command_Type := Undefined; + Result_Set : Boolean := False; + begin Buffer.Init; @@ -2040,10 +2260,9 @@ package body VMS_Conv is raise Normal_Exit; end if; - Arg_Num := 1; - -- Loop through arguments + Arg_Num := 1; while Arg_Num <= Argument_Count loop Process_Argument (Result); @@ -2079,66 +2298,13 @@ package body VMS_Conv is -- Prepare arguments for a call to spawn, filtering out -- embedded nulls place there to delineate strings. - declare - P1, P2 : Natural; - Inside_Nul : Boolean := False; - Arg : String (1 .. 1024); - Arg_Ctr : Natural; + Process_Buffer (String (Buffer.Table (1 .. Buffer.Last))); - begin - P1 := 1; - - while P1 <= Buffer.Last and then Buffer.Table (P1) = ' ' loop - P1 := P1 + 1; - end loop; - - Arg_Ctr := 1; - Arg (Arg_Ctr) := Buffer.Table (P1); - - while P1 <= Buffer.Last loop - - if Buffer.Table (P1) = ASCII.NUL then - if Inside_Nul then - Inside_Nul := False; - else - Inside_Nul := True; - end if; - end if; - - if Buffer.Table (P1) = ' ' and then not Inside_Nul then - P1 := P1 + 1; - Arg_Ctr := Arg_Ctr + 1; - Arg (Arg_Ctr) := Buffer.Table (P1); - - else - Last_Switches.Increment_Last; - P2 := P1; - - while P2 < Buffer.Last - and then (Buffer.Table (P2 + 1) /= ' ' or else - Inside_Nul) - loop - P2 := P2 + 1; - Arg_Ctr := Arg_Ctr + 1; - Arg (Arg_Ctr) := Buffer.Table (P2); - if Buffer.Table (P2) = ASCII.NUL then - Arg_Ctr := Arg_Ctr - 1; - if Inside_Nul then - Inside_Nul := False; - else - Inside_Nul := True; - end if; - end if; - end loop; - - Last_Switches.Table (Last_Switches.Last) := - new String'(String (Arg (1 .. Arg_Ctr))); - P1 := P2 + 2; - Arg_Ctr := 1; - Arg (Arg_Ctr) := Buffer.Table (P1); - end if; - end loop; - end; + if Cargs_Buffer.Last > 1 then + Last_Switches.Append (new String'("-cargs")); + Process_Buffer + (String (Cargs_Buffer.Table (1 .. Cargs_Buffer.Last))); + end if; end if; end VMS_Conversion; diff --git a/gcc/ada/vms_conv.ads b/gcc/ada/vms_conv.ads index 7f58c28e9df..98496df730e 100644 --- a/gcc/ada/vms_conv.ads +++ b/gcc/ada/vms_conv.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2003-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2006, 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- -- @@ -109,8 +109,8 @@ package VMS_Conv is Name, Preprocess, Pretty, - Setup, Shared, + Stack, Stub, Xref, Undefined); @@ -158,134 +158,6 @@ package VMS_Conv is -- an extension already. end record; - ------------------------- - -- Internal Structures -- - ------------------------- - - -- The switches and commands are defined by strings in the previous - -- section so that they are easy to modify, but internally, they are - -- kept in a more conveniently accessible form described in this - -- section. - - -- Commands, command qualifers and options have a similar common format - -- so that searching for matching names can be done in a common manner. - - type Item_Id is (Id_Command, Id_Switch, Id_Option); - - type Translation_Type is - ( - T_Direct, - -- A qualifier with no options. - -- Example: GNAT MAKE /VERBOSE - - T_Directories, - -- A qualifier followed by a list of directories - -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR]) - - T_Directory, - -- A qualifier followed by one directory - -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB] - - T_File, - -- A qualifier followed by a filename - -- Example: GNAT LINK /EXECUTABLE=FOO.EXE - - T_No_Space_File, - -- A qualifier followed by a filename - -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR - - T_Numeric, - -- A qualifier followed by a numeric value. - -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39 - - T_String, - -- A qualifier followed by a quoted string. Only used by - -- /IDENTIFICATION qualifier. - -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version" - - T_Options, - -- A qualifier followed by a list of options. - -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS) - - T_Commands, - -- A qualifier followed by a list. Only used for - -- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS - -- (gnatmake -cargs -bargs -largs ) - -- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ - - T_Other, - -- A qualifier passed directly to the linker. Only used - -- for LINK and SHARED if no other match is found. - -- Example: GNAT LINK FOO.ALI /SYSSHR - - T_Alphanumplus - -- A qualifier followed by a legal linker symbol prefix. Only used - -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz). - -- Example: GNAT BIND /BUILD_LIBRARY=foobar - ); - - type Item (Id : Item_Id); - type Item_Ptr is access all Item; - - type Item (Id : Item_Id) is record - Name : String_Ptr; - -- Name of the command, switch (with slash) or option - - Next : Item_Ptr; - -- Pointer to next item on list, always has the same Id value - - Command : Command_Type := Undefined; - - Unix_String : String_Ptr := null; - -- Corresponding Unix string. For a command, this is the unix command - -- name and possible default switches. For a switch or option it is - -- the unix switch string. - - case Id is - - when Id_Command => - - Switches : Item_Ptr; - -- Pointer to list of switch items for the command, linked - -- through the Next fields with null terminating the list. - - Usage : String_Ptr; - -- Usage information, used only for errors and the default - -- list of commands output. - - Params : Parameter_Ref; - -- Array of parameters - - Defext : String (1 .. 3); - -- Default extension. If non-blank, then this extension is - -- supplied by default as the extension for any file parameter - -- which does not have an extension already. - - when Id_Switch => - - Translation : Translation_Type; - -- Type of switch translation. For all cases, except Options, - -- this is the only field needed, since the Unix translation - -- is found in Unix_String. - - Options : Item_Ptr; - -- For the Options case, this field is set to point to a list - -- of options item (for this case Unix_String is null in the - -- main switch item). The end of the list is marked by null. - - when Id_Option => - - null; - -- No special fields needed, since Name and Unix_String are - -- sufficient to completely described an option. - - end case; - end record; - - subtype Command_Item is Item (Id_Command); - subtype Switch_Item is Item (Id_Switch); - subtype Option_Item is Item (Id_Option); - ------------------- -- Switch Tables -- -------------------