Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / osint.adb < prev next >

Wrap

Text File | 1996-09-28 | 47KB | 1,439 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- O S I N T -- -- -- -- B o d y -- -- -- -- $Revision: 1.127 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- 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- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Output; use Output; with Switch; use Switch; with Opt; use Opt; with GNAT.OS_Lib; use GNAT.OS_Lib; with Sdefault; use Sdefault; with Table; with Tree_IO; use Tree_IO; with Unchecked_Conversion; package body Osint is ----------------------- -- Local Subprograms -- ----------------------- function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type; -- Convert OS format time to GNAT format time stamp procedure Create_File_And_Check (Fdesc : out File_Descriptor; Fmode : Mode); -- Create file whose name (NUL terminated) is in Name_Buffer (with the -- length in Name_Len), and place the resulting descriptor in Fdesc. -- Issue message and exit with fatal error if file cannot be created. -- The Fmode parameter is set to either Text or Binary (see description -- of GNAT.OS_Lib.Create_File). procedure Write_With_Check (A : Address; N : Integer); -- Writes N bytes from buffer starting at address A to file whose FD -- is stored in Output_FD, and whose file name is stored as a Name_Id -- in Output_File_Name. A check is made for disk full, and if this is -- detected, the file being written is deleted, and a fatal error is -- signalled. function Normalize_Directory_Name (Directory : String) return String_Ptr; -- Verify and normalize a directory name. If directory name is invalid, -- this will return an empty string. Otherwise it will insure a trailing -- slash and make other normalizations. function Src_Locate_File (Dir_Index : Natural; File_Name : String) return Name_Id; -- See if the file whose name is File_Name exists in the directory -- Src_Search_Directories indexed by Dir_Index. Returns the Name_Id -- of he full file name if file found, or No_Name if not found. function Lib_Locate_File (Dir_Index : Natural; File_Name : String) return Name_Id; -- Same as above for library files except that the Dir_Index is an -- index in Lib_Searc_Directories. function Find_Source_File (N : File_Name_Type) return Name_Id; -- Find a source file following the directory search order rules unless -- N is the name of the file just read with Next_Main_Source, in which -- case just look in the Primary_Directory. Returns Name_Id of the full -- file name if found, No_Name if file not found. ------------------------- -- Command Line Access -- ------------------------- -- Direct interface to command line parameters. (We don't want to use -- the predefined command line package because it defines functions -- returning string) function Arg_Count return Natural; pragma Import (C, Arg_Count, "arg_count"); -- Get number of arguments (note: optional globbing may be enabled) procedure Fill_Arg (A : System.Address; Arg_Num : Integer); pragma Import (C, Fill_Arg, "fill_arg"); -- Store one argument function Len_Arg (Arg_Num : Integer) return Integer; pragma Import (C, Len_Arg, "len_arg"); -- Get length of argument ------------------------------ -- Other Local Declarations -- ------------------------------ Argument_Count : constant Integer := Arg_Count - 1; -- Number of arguments (excluding program name) File_Names : array (Int range 1 .. Int (Argument_Count)) of String_Ptr; -- As arguments are scanned in Initialize, filenames are stored -- in this array. The string does not contain a terminating NUL. Number_File_Names : Int := 0; -- The total number of filenames found on command line and placed in -- File_Names. Current_File_Name_Index : Int := 0; -- The index in File_Names of the last file opened by Next_Main_Source -- or Next_Main_Lib_File. The value 0 indicates that no files have been -- opened yet. In_Binder : Boolean := False; In_Compiler : Boolean := False; In_Make : Boolean := False; -- Exactly one of these flags is set True to indicate which program -- is bound and executing with Osint, which is used by all these programs. Source_Time_Stamp : Time_Stamp_Type; -- Time stamp for current source file Output_FD : File_Descriptor; -- The file descriptor for the current library info, tree or binder output Output_File_Name : Name_Id; -- Name_Id for name of open file whose FD is in Output_FD, the name -- stored does not include the trailing NUL character. EOL : constant Character := Ascii.LF; -- End of line character Output_Filename : String_Ptr := null; -- The name after the -o option Save_Main_File_Name : File_Name_Type; -- Used to save a simple file name between calls to Next_Main_Source and -- Read_Source_File. If the file name argument to Read_Source_File is -- No_File, that indicates that the file whose name was returned by the -- last call to Next_Main_Source (and stored here) is to be read. Src_Save_Full_File_Name : Name_Id := No_Name; -- Set to full name of source file read by the most recent call to -- Read_Source_File (result returned by Full_Source_Name). Lib_Save_Full_File_Name : Name_Id := No_Name; -- Set to full name of library information file read by the -- most recent call to Read_Library_Info (result returned by -- Full_Library_Info_Name). Primary_Directory : Natural := 0; -- This is index in the tables created below for the first directory to -- search in for source or library information files. For the compiler -- (looking for sources) it is the directory containing the main unit. -- For the binder (looking for library information files) it is the -- current working directory. package Src_Search_Directories is new Table ( Table_Component_Type => String_Ptr, Table_Index_Type => Natural, Table_Low_Bound => Primary_Directory, Table_Initial => 12, Table_Increment => 100, Table_Name => "Osint.Src_Search_Directories"); -- Table of names of directories in which to search for source (Compiler) -- files. This table is filled in the order in which the directories are -- to be searched, and then used in that order. package Lib_Search_Directories is new Table ( Table_Component_Type => String_Ptr, Table_Index_Type => Natural, Table_Low_Bound => Primary_Directory, Table_Initial => 12, Table_Increment => 100, Table_Name => "Osint.Lib_Search_Directories"); -- Table of names of directories in which to search for library (Binder) -- files. This table is filled in the order in which the directories are -- to be searched and then used in that order. The reason for having two -- distinct tables is that we need them both in gnatmake. ------------------------- -- Close_Binder_Output -- ------------------------- procedure Close_Binder_Output is begin pragma Assert (In_Binder); Close (Output_FD); end Close_Binder_Output; ----------------------- -- Close_Stub_Output -- ----------------------- procedure Close_Stub_Output is begin pragma Assert (In_Compiler); Close (Output_FD); Restore_Output_FD; end Close_Stub_Output; ------------------------------- -- Close_Output_Library_Info -- ------------------------------- procedure Close_Output_Library_Info is begin pragma Assert (In_Compiler); Close (Output_FD); end Close_Output_Library_Info; ----------------------- -- Close_Xref_Output -- ----------------------- procedure Close_Xref_Output is begin pragma Assert (In_Compiler); Close (Output_FD); end Close_Xref_Output; -------------------------- -- Create_Binder_Output -- -------------------------- procedure Create_Binder_Output is File_Name : String_Ptr; Findex1 : Natural; Findex2 : Natural; Flength : Natural; begin pragma Assert (In_Binder); if (Output_Filename_Present) then if Output_Filename /= null then Name_Buffer (Output_Filename'Range) := Output_Filename.all; Name_Buffer (Output_Filename'Last + 1) := Ascii.NUL; Name_Len := Output_Filename'Last; else Write_Str ("Output filename missing after -o"); Write_Eol; Exit_Program (E_Fatal); end if; else File_Name := File_Names (Current_File_Name_Index); Findex1 := File_Name'First; -- The ali file might be specified by a full path name. However, -- the binder generated file should always be created in the -- current directory, so the path might need to be stripped away. -- In addition to the default directory_separator allow the '/' to -- act as separator since this is allowed in MS-DOS and OS2 ports. for J in reverse File_Name'Range loop if File_Name (J) = Directory_Separator or else File_Name (J) = '/' then Findex1 := J + 1; exit; end if; end loop; Findex2 := Findex1; while File_Name (Findex2) /= '.' loop Findex2 := Findex2 + 1; end loop; Name_Buffer (1 .. 2) := "b_"; Flength := Findex2 - Findex1; Name_Buffer (3 .. Flength + 2) := File_Name (Findex1 .. Findex2 - 1); Name_Buffer (Flength + 3) := '.'; Name_Buffer (Flength + 4) := 'c'; Name_Buffer (Flength + 5) := Ascii.NUL; Name_Len := Flength + 4; end if; Create_File_And_Check (Output_FD, Text); end Create_Binder_Output; --------------------------- -- Create_File_And_Check -- --------------------------- procedure Create_File_And_Check (Fdesc : out File_Descriptor; Fmode : Mode) is begin Output_File_Name := Name_Enter; Fdesc := Create_File (Name_Buffer'Address, Fmode); if Fdesc = Invalid_FD then Write_Str ("Cannot create: "); Write_Str (Name_Buffer); Write_Eol; Exit_Program (E_Fatal); end if; end Create_File_And_Check; -------------------------------- -- Create_Output_Library_Info -- -------------------------------- procedure Create_Output_Library_Info is -- ??? Needs to be coordinated with -o option Dot_Index : Natural; begin pragma Assert (In_Compiler); Get_Name_String (Save_Main_File_Name); Dot_Index := 0; for J in reverse 1 .. Name_Len loop if Name_Buffer (J) = '.' then Dot_Index := J; exit; end if; end loop; -- Should be impossible to not have an extension if Dot_Index = 0 then null; pragma Assert (False); end if; Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := "ali"; Name_Buffer (Dot_Index + 4) := Ascii.NUL; Name_Len := Dot_Index + 3; Create_File_And_Check (Output_FD, Text); end Create_Output_Library_Info; ----------------------- -- Create_Req_Output -- ----------------------- procedure Create_Req_Output is begin pragma Assert (In_Compiler); Create_File_And_Check (Output_FD, Text); end Create_Req_Output; ------------------------ -- Create_Stub_Output -- ------------------------ procedure Create_Stub_Output is FD : File_Descriptor; begin pragma Assert (In_Compiler); Create_File_And_Check (FD, Text); Set_Output_FD (FD); end Create_Stub_Output; ------------------------ -- Create_Xref_Output -- ------------------------ procedure Create_Xref_Output (Global_Xref_File : Boolean) is begin pragma Assert (In_Compiler); -- For now, always use X.ref, since cannot reference Lib ??? if not Global_Xref_File then Get_Name_String (Save_Main_File_Name); Name_Buffer (Name_Len - 2 .. Name_Len - 1) := "xr"; Name_Buffer (Name_Len + 1) := Ascii.NUL; else Name_Buffer (1 .. 5) := "X.ref"; Name_Buffer (6) := Ascii.NUL; Name_Len := 5; end if; Create_File_And_Check (Output_FD, Text); end Create_Xref_Output; ------------------------------- -- Current_Source_File_Stamp -- ------------------------------- function Current_Source_File_Stamp return Time_Stamp_Type is begin return Source_Time_Stamp; end Current_Source_File_Stamp; ------------------ -- Exit_Program -- ------------------ procedure Exit_Program (Exit_Code : Exit_Code_Type) is begin case Exit_Code is when E_Success => OS_Exit (0); when E_Warnings => OS_Exit (0); when E_Errors => OS_Exit (1); when E_Fatal => OS_Exit (2); when E_Abort => OS_Abort; end case; end Exit_Program; ---------------------- -- Find_Source_File -- ---------------------- function Find_Source_File (N : File_Name_Type) return Name_Id is Is_Main_Unit : constant Boolean := (N = Save_Main_File_Name); File_Located : Name_Id; begin -- The first place to look is in the directory of the main -- unit. If the file is the main unit and it is not found -- in the directory specified for it, it is an error. Get_Name_String (N); File_Located := Src_Locate_File (Primary_Directory, Name_Buffer (1 .. Name_Len)); if File_Located = No_Name then if Is_Main_Unit then -- An error. Main unit was not found in its specified directory Get_Name_String (N); Write_Str ("Cannot find: "); Write_Str (Name_Buffer (1 .. Name_Len)); Write_Eol; Exit_Program (E_Fatal); else -- This is not the main unit, so look for it in the other -- places on the search path. for Dir_Index in Primary_Directory + 1 .. Src_Search_Directories.Last loop File_Located := Src_Locate_File (Dir_Index, Name_Buffer (1 .. Name_Len)); exit when File_Located /= No_Name; end loop; end if; end if; return File_Located; end Find_Source_File; ---------------------------- -- Full_Library_Info_Name -- ---------------------------- function Full_Library_Info_Name return Name_Id is begin return Lib_Save_Full_File_Name; end Full_Library_Info_Name; --------------------------- -- Full_Object_File_Name -- --------------------------- function Full_Object_File_Name return Name_Id is J : Positive; ALI_Suffix : constant String_Ptr := new String'("ali"); Object_Suffix : String (1 .. 10); -- 10 should be sufficient till this code gets cleaned up ??? procedure Get_Object_Suffix (str : Address); pragma Import (C, Get_Object_Suffix, "Get_Object_Suffix"); -- The filename suffixes for ALI and object files -- ??? Should do with interfaces or something nicer begin Get_Name_String (Full_Library_Info_Name); Name_Len := Name_Len - ALI_Suffix'Length; Get_Object_Suffix (Object_Suffix'Address); J := Object_Suffix'First; while Object_Suffix (J) /= ASCII.Nul loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Object_Suffix (J); J := J + 1; end loop; return Name_Enter; end Full_Object_File_Name; ---------------------- -- Full_Source_Name -- ---------------------- function Full_Source_Name (N : File_Name_Type := No_File) return Name_Id is begin if N = No_File then return Src_Save_Full_File_Name; else return Find_Source_File (N); end if; end Full_Source_Name; ---------------- -- Initialize -- ---------------- procedure Initialize (P : Program_Type) is Already_Seen : Boolean := False; Search_Path_Value : String_Access; Next_Arg : Positive; function Get_Default_Identifier_Character_Set return Character; pragma Import (C, Get_Default_Identifier_Character_Set, "Get_Default_Identifier_Character_Set"); -- Function to determine the default identifier character set, -- which is system dependent. See Opt package spec for a list of -- the possible character codes and their interpretations. function Get_Maximum_File_Name_Length return Int; pragma Import (C, Get_Maximum_File_Name_Length, "Get_Maximum_File_Name_Length"); -- Function to get maximum file name length for system begin Program := P; case Program is when Binder => In_Binder := True; when Compiler => In_Compiler := True; when Make => In_Make := True; end case; Src_Search_Directories.Init; Lib_Search_Directories.Init; Gcc_Switches.Init; Binder_Switches.Init; Linker_Switches.Init; -- Needed only for gnatmake Identifier_Character_Set := Get_Default_Identifier_Character_Set; Maximum_File_Name_Length := Get_Maximum_File_Name_Length; -- Following should be removed by having above function return -- Integer'Last as indication of no maximum instead of -1 ??? if Maximum_File_Name_Length = -1 then Maximum_File_Name_Length := Int'Last; end if; Suppress_Options.Access_Checks := False; Suppress_Options.Accessibility_Checks := False; Suppress_Options.Discriminant_Checks := False; Suppress_Options.Division_Checks := False; Suppress_Options.Index_Checks := False; Suppress_Options.Length_Checks := False; Suppress_Options.Overflow_Checks := False; Suppress_Options.Range_Checks := False; Suppress_Options.Division_Checks := False; Suppress_Options.Length_Checks := False; Suppress_Options.Range_Checks := False; Suppress_Options.Storage_Checks := False; Suppress_Options.Tag_Checks := False; -- Set software overflow check flag. For now all targets require the -- use of software overflow checks. Later on, this will have to be -- specialized to the backend target. Also, if software overflow -- checking mode is set, then the default for suppressing overflow -- checks is True, since the software approach is expensive. Software_Overflow_Checking := True; Suppress_Options.Overflow_Checks := True; -- Similarly, the default is elaboration checks off Suppress_Options.Elaboration_Checks := True; -- Reserve the first slot in the search paths table. For the compiler -- this is the directory of the main source file and is filled in by -- each call to Next_Main_Source. For the binder, this is always empty -- so the current working directory is searched first. Src_Search_Directories.Set_Last (Primary_Directory); Src_Search_Directories.Table (Primary_Directory) := new String'(""); -- Overriden in Next_Main_Source if Next_Main_Source is ever called Lib_Search_Directories.Set_Last (Primary_Directory); Lib_Search_Directories.Table (Primary_Directory) := new String'(""); -- Loop through command line arguments, storing them for later access Scan_Args : declare In_Gcc_Args : Boolean := False; In_Binder_Args : Boolean := False; In_Linker_Args : Boolean := False; -- These three flags are used to indicate if we are scanning gcc, -- gnatbind, or gnatbl options within the gnatmake command line. Compiler_Opts : constant String_Ptr := new String'("-cargs"); Binder_Opts : constant String_Ptr := new String'("-bargs"); Linker_Opts : constant String_Ptr := new String'("-largs"); -- Needed in gnatmake to search for the gcc, gnatbind and gnatbl -- options put on the gnatmake command line begin Next_Arg := 1; loop exit when Next_Arg > Argument_Count; declare Next_Argv : String (1 .. Len_Arg (Next_Arg)); begin Fill_Arg (Next_Argv'Address, Next_Arg); if Next_Argv'Length /= 0 and then (Next_Argv (1) = Switch_Character or else Next_Argv (1) = '-') then -- If we are processing a switch of the form "-Idirname" -- add "dirname" to the source and library search paths. if Next_Argv'Length >= 2 and then Next_Argv (2) = 'I' then Src_Search_Directories.Increment_Last; Src_Search_Directories.Table (Src_Search_Directories.Last) := Normalize_Directory_Name (Next_Argv (3 .. Next_Argv'Length)); Lib_Search_Directories.Increment_Last; Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Normalize_Directory_Name (Next_Argv (3 .. Next_Argv'Length)); -- When executing "gnatmake", add the -I switch -- to both the compiler and binder switches. if Program = Make then Gcc_Switches.Increment_Last; Gcc_Switches.Table (Gcc_Switches.Last) := new String'(Next_Argv); Binder_Switches.Increment_Last; Binder_Switches.Table (Binder_Switches.Last) := new String'(Next_Argv); end if; -- Processing of gnatmake -[cbl]args arguments. elsif Program = Make and then Next_Argv = Compiler_Opts.all then In_Gcc_Args := True; In_Binder_Args := False; In_Linker_Args := False; elsif Program = Make and then Next_Argv = Binder_Opts.all then In_Gcc_Args := False; In_Binder_Args := True; In_Linker_Args := False; elsif Program = Make and then Next_Argv = Linker_Opts.all then In_Gcc_Args := False; In_Binder_Args := False; In_Linker_Args := True; elsif Program = Make and then In_Gcc_Args then Gcc_Switches.Increment_Last; Gcc_Switches.Table (Gcc_Switches.Last) := new String'(Next_Argv); elsif Program = Make and then In_Binder_Args then Binder_Switches.Increment_Last; Binder_Switches.Table (Binder_Switches.Last) := new String'(Next_Argv); elsif Program = Make and then In_Linker_Args then Linker_Switches.Increment_Last; Linker_Switches.Table (Linker_Switches.Last) := new String'(Next_Argv); -- All other options are single character and are handled -- by Scan_Switches. else Scan_Switches (Next_Argv); end if; -- Not a switch, so must be a filename (if non-empty) elsif Program = Make and then Next_Argv'Length /= 0 and then In_Gcc_Args then Gcc_Switches.Increment_Last; Gcc_Switches.Table (Gcc_Switches.Last) := new String'(Next_Argv); elsif Program = Make and then Next_Argv'Length /= 0 and then In_Binder_Args then Binder_Switches.Increment_Last; Binder_Switches.Table (Binder_Switches.Last) := new String'(Next_Argv); elsif Program = Make and then Next_Argv'Length /= 0 and then In_Linker_Args then Linker_Switches.Increment_Last; Linker_Switches.Table (Linker_Switches.Last) := new String'(Next_Argv); elsif Next_Argv'Length /= 0 then if Output_Filename_Present and not Already_Seen then Already_Seen := True; Output_Filename := new String'(Next_Argv); else Number_File_Names := Number_File_Names + 1; File_Names (Number_File_Names) := new String'(Next_Argv); end if; end if; end; Next_Arg := Next_Arg + 1; end loop; end Scan_Args; -- After the locations specified on the command line, the next places -- to look for files are the directories specified by the appropriate -- environment variable. Get this value, extract the directory names -- and store in the table. for Additional_Source_Dir in False .. True loop if Additional_Source_Dir then Search_Path_Value := Getenv ("ADA_INCLUDE_PATH"); else Search_Path_Value := Getenv ("ADA_OBJECTS_PATH"); end if; if Search_Path_Value'Length > 0 then declare Lower_Bound : Positive := 1; Upper_Bound : Positive; begin loop while Lower_Bound <= Search_Path_Value'Last and then Search_Path_Value.all (Lower_Bound) = Path_Separator loop Lower_Bound := Lower_Bound + 1; end loop; exit when Lower_Bound > Search_Path_Value'Last; Upper_Bound := Lower_Bound; while Upper_Bound <= Search_Path_Value'Last and then Search_Path_Value.all (Upper_Bound) /= Path_Separator loop Upper_Bound := Upper_Bound + 1; end loop; if Additional_Source_Dir then Src_Search_Directories.Increment_Last; Src_Search_Directories.Table (Src_Search_Directories.Last) := Normalize_Directory_Name (Search_Path_Value.all (Lower_Bound .. Upper_Bound - 1)); else Lib_Search_Directories.Increment_Last; Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Normalize_Directory_Name (Search_Path_Value.all (Lower_Bound .. Upper_Bound - 1)); end if; Lower_Bound := Upper_Bound + 1; end loop; end; end if; end loop; -- The last place to look are the defaults. Src_Search_Directories.Increment_Last; Lib_Search_Directories.Increment_Last; Src_Search_Directories.Table (Src_Search_Directories.Last) := Include_Dir_Default_Name; Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Object_Dir_Default_Name; end Initialize; ------------------- -- Lib_File_Name -- ------------------- function Lib_File_Name (Source_File : File_Name_Type) return File_Name_Type is Fptr : Natural; -- Pointer to location to set extension in place begin Get_Name_String (Source_File); Fptr := Name_Len + 1; for J in reverse 1 .. Name_Len loop if Name_Buffer (J) = '.' then Fptr := J; exit; end if; end loop; Name_Buffer (Fptr .. Fptr + 3) := ".ali"; Name_Buffer (Fptr + 4) := Ascii.NUL; Name_Len := Fptr + 3; return Name_Find; end Lib_File_Name; --------------------- -- Lib_Locate_File -- --------------------- function Lib_Locate_File (Dir_Index : Natural; File_Name : String) return Name_Id is Dir_Name_Length : Natural := Lib_Search_Directories.Table (Dir_Index)'Length; Full_Name : String (1 .. Dir_Name_Length + File_Name'Length); begin Full_Name (1 .. Dir_Name_Length) := Lib_Search_Directories.Table (Dir_Index).all; Full_Name (Dir_Name_Length + 1 .. Full_Name'Length) := File_Name; if not Is_Regular_File (Full_Name) then return No_Name; else Name_Len := Full_Name'Length; Name_Buffer (1 .. Name_Len) := Full_Name; return Name_Enter; end if; end Lib_Locate_File; -------------------- -- More_Lib_Files -- -------------------- function More_Lib_Files return Boolean is begin pragma Assert (In_Binder); return (Current_File_Name_Index < Number_File_Names); end More_Lib_Files; ----------------------- -- More_Source_Files -- ----------------------- function More_Source_Files return Boolean is begin pragma Assert (In_Compiler or else In_Make); return (Current_File_Name_Index < Number_File_Names); end More_Source_Files; ------------------------ -- Next_Main_Lib_File -- ------------------------ function Next_Main_Lib_File return File_Name_Type is File_Name : String_Ptr; Fptr : Natural; begin pragma Assert (In_Binder); Current_File_Name_Index := Current_File_Name_Index + 1; -- Fatal error if no more files (should call More_Lib_Files) pragma Assert (Current_File_Name_Index <= Number_File_Names); -- Otherwise return name of the file File_Name := File_Names (Current_File_Name_Index); Fptr := File_Name'First; for J in reverse File_Name'Range loop if File_Name (J) = Directory_Separator then Fptr := J + 1; exit; end if; end loop; Name_Len := File_Name'Last - Fptr + 1; Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last); return File_Name_Type (Name_Find); end Next_Main_Lib_File; ---------------------- -- Next_Main_Source -- ---------------------- function Next_Main_Source return File_Name_Type is File_Name : String_Ptr; Fptr : Natural; begin pragma Assert (In_Compiler or else In_Make); Current_File_Name_Index := Current_File_Name_Index + 1; -- Fatal error if no more files (should call More_Source_Files) pragma Assert (Current_File_Name_Index <= Number_File_Names); -- Otherwise return name of the file File_Name := File_Names (Current_File_Name_Index); Fptr := File_Name'First; for J in reverse File_Name'Range loop if File_Name (J) = Directory_Separator then if J = File_Name'Last then Write_Str ("File name missing"); Write_Eol; Exit_Program (E_Fatal); end if; Fptr := J + 1; exit; end if; end loop; -- Save name of directory in which main unit resides for use in -- locating other units Src_Search_Directories.Table (Primary_Directory) := new String'(File_Name (File_Name'First .. Fptr - 1)); Name_Len := File_Name'Last - Fptr + 1; Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last); Save_Main_File_Name := File_Name_Type (Name_Find); return Save_Main_File_Name; end Next_Main_Source; ------------------------------ -- Normalize_Directory_Name -- ------------------------------ function Normalize_Directory_Name (Directory : String) return String_Ptr is Result : String_Ptr; begin -- For now this just insures that the string is terminated with -- the directory separator character. Add more later? if Directory (Directory'Last) = Directory_Separator then Result := new String'(Directory); else Result := new String (1 .. Directory'Length + 1); Result (1 .. Directory'Length) := Directory; Result (Directory'Length + 1) := Directory_Separator; end if; return Result; end Normalize_Directory_Name; --------------------- -- Number_Of_Files -- --------------------- function Number_Of_Files return Int is begin return Number_File_Names; end Number_Of_Files; -------------------------- -- OS_Time_To_GNAT_Time -- -------------------------- function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is GNAT_Time : Time_Stamp_Type; Y : Year_Type; Mo : Month_Type; D : Day_Type; H : Hour_Type; Mn : Minute_Type; S : Second_Type; Z : constant := Character'Pos ('0'); begin GM_Split (T, Y, Mo, D, H, Mn, S); GNAT_Time (1) := Character'Val (Z + (Y / 10) mod 10); GNAT_Time (2) := Character'Val (Z + Y mod 10); GNAT_Time (3) := Character'Val (Z + Mo / 10); GNAT_Time (4) := Character'Val (Z + Mo mod 10); GNAT_Time (5) := Character'Val (Z + D / 10); GNAT_Time (6) := Character'Val (Z + D mod 10); GNAT_Time (7) := Character'Val (Z + H / 10); GNAT_Time (8) := Character'Val (Z + H mod 10); GNAT_Time (9) := Character'Val (Z + Mn / 10); GNAT_Time (10) := Character'Val (Z + Mn mod 10); GNAT_Time (11) := Character'Val (Z + S / 10); GNAT_Time (12) := Character'Val (Z + S mod 10); return GNAT_Time; end OS_Time_To_GNAT_Time; ----------------------- -- Read_Library_Info -- ----------------------- function Read_Library_Info (Lib_File : File_Name_Type; Fatal_Err : Boolean := False) return Text_Buffer_Ptr is Lib_FD : File_Descriptor; -- The file descriptor for the current library file. A negative value -- indicates failure to open the specified source file. Text : Text_Buffer_Ptr; -- Allocated text buffer. File_Located : Name_Id; begin if Lib_File = No_File then Name_Len := File_Names (Current_File_Name_Index)'Length; Name_Buffer (1 .. Name_Len) := File_Names (Current_File_Name_Index).all; File_Located := Lib_Locate_File (Primary_Directory, Name_Buffer (1 .. Name_Len)); else Get_Name_String (Lib_File); for Dir_Index in Lib_Search_Directories.First .. Lib_Search_Directories.Last loop File_Located := Lib_Locate_File (Dir_Index, Name_Buffer (1 .. Name_Len)); exit when File_Located /= No_Name; end loop; end if; Lib_Save_Full_File_Name := File_Located; if File_Located = No_Name then if Fatal_Err then Write_Str ("Cannot find: "); Write_Str (Name_Buffer (1 .. Name_Len)); Write_Eol; Exit_Program (E_Fatal); else return null; end if; end if; Get_Name_String (Lib_Save_Full_File_Name); Name_Buffer (Name_Len + 1) := Ascii.NUL; -- Open the library FD, note that we open in binary mode, because as -- documented in the spec, the caller is expected to handle either -- DOS or Unix mode files, and there is no point in wasting time on -- text translation when it is not required. Lib_FD := Open_Read (Name_Buffer'Address, Binary); if Lib_FD = Invalid_FD then if Fatal_Err then Write_Str ("Cannot open: "); Write_Str (Name_Buffer (1 .. Name_Len)); Write_Eol; Exit_Program (E_Fatal); else return null; end if; end if; -- Read data from the file declare Len : Integer := Integer (File_Length (Lib_FD)); -- Length of source file text. If it doesn't fit in an integer -- we're probably stuck anyway (>2 gigs of source seems a lot!) Lo : Text_Ptr := 0; -- Low bound for allocated text buffer Hi : Text_Ptr := Text_Ptr (Len); -- High bound for allocated text buffer. Note length is Len + 1 -- which allows for extra EOF character at the end of the buffer. begin -- Allocate text buffer. Note extra character at end for EOF Text := new Text_Buffer (Lo .. Hi); if Read (Lib_FD, Text (Lo)'Address, Len) < Len then null; -- ??? should do something here end if; Text (Hi) := EOF; end; -- Read is complete, close file and we are done Close (Lib_FD); return Text; end Read_Library_Info; ---------------------- -- Read_Source_File -- ---------------------- procedure Read_Source_File (N : File_Name_Type; Lo : in Source_Ptr; Hi : out Source_Ptr; Src : out Source_Buffer_Ptr) is Source_File_FD : File_Descriptor; -- The file descriptor for the current source file. A negative value -- indicates failure to open the specified source file. Len : Integer; -- Length of file. Assume no more than 2 gigabytes of source! begin Src_Save_Full_File_Name := Find_Source_File (N); if Src_Save_Full_File_Name = No_Name then Src := null; return; end if; Get_Name_String (Src_Save_Full_File_Name); Name_Buffer (Name_Len + 1) := Ascii.NUL; -- Open the source FD, note that we open in binary mode, because as -- documented in the spec, the caller is expected to handle either -- DOS or Unix mode files, and there is no point in wasting time on -- text translation when it is not required. Source_File_FD := Open_Read (Name_Buffer'Address, Binary); if Source_File_FD = Invalid_FD then Src := null; return; end if; -- Prepare to read data from the file Len := Integer (File_Length (Source_File_FD)); -- Set Hi so that length is one more than the physical length, -- allowing for the extra EOF character at the end of the buffer Hi := Lo + Source_Ptr (Len); -- Do the actual read operation declare subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); -- Physical buffer allocated type Actual_Source_Ptr is access Actual_Source_Buffer; -- This is the pointer type for the physical buffer allocated Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer; -- And this is the actual physical buffer begin -- Allocate source buffer, allowing extra character at end for EOF if Read (Source_File_FD, Actual_Ptr (Lo)'Address, Len) < Len then null; -- ??? should do something here end if; Actual_Ptr (Hi) := EOF; -- Now we need to work out the proper virtual origin pointer to -- return. This is exactly Actual_Ptr (0)'Address, but we have -- to be careful to suppress checks to compute this address. declare pragma Suppress (All_Checks); function To_Source_Buffer_Ptr is new Unchecked_Conversion (Address, Source_Buffer_Ptr); begin Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address); end; end; -- Read is complete, get time stamp and close file and we are done Source_Time_Stamp := OS_Time_To_GNAT_Time (File_Time_Stamp (Source_File_FD)); Close (Source_File_FD); end Read_Source_File; ----------------------- -- Source_File_Stamp -- ----------------------- function Source_File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is File_Located : Name_Id := Find_Source_File (Name); begin if File_Located = No_Name then return " "; else Get_Name_String (File_Located); Name_Buffer (Name_Len + 1) := Ascii.NUL; return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer)); end if; end Source_File_Stamp; --------------------- -- Src_Locate_File -- --------------------- function Src_Locate_File (Dir_Index : Natural; File_Name : String) return Name_Id is Dir_Name_Length : Natural := Src_Search_Directories.Table (Dir_Index)'Length; Full_Name : String (1 .. Dir_Name_Length + File_Name'Length); begin Full_Name (1 .. Dir_Name_Length) := Src_Search_Directories.Table (Dir_Index).all; Full_Name (Dir_Name_Length + 1 .. Full_Name'Length) := File_Name; if not Is_Regular_File (Full_Name) then return No_Name; else Name_Len := Full_Name'Length; Name_Buffer (1 .. Name_Len) := Full_Name; return Name_Enter; end if; end Src_Locate_File; ----------------------- -- Stub_Output_Start -- ----------------------- -- For now does nothing, should process -o switch ??? procedure Stub_Output_Start is begin null; end Stub_Output_Start; ---------------------- -- Stub_Output_Stop -- ---------------------- -- For now does nothing, should process -o switch ??? procedure Stub_Output_Stop is begin null; end Stub_Output_Stop; ----------------- -- Tree_Create -- ----------------- procedure Tree_Create is Dot_Index : Natural; begin pragma Assert (In_Compiler); Get_Name_String (Save_Main_File_Name); Dot_Index := 0; for J in reverse 1 .. Name_Len loop if Name_Buffer (J) = '.' then Dot_Index := J; exit; end if; end loop; -- Should be impossible to not have an extension if Dot_Index = 0 then null; pragma Assert (False); end if; -- Change *.ads to *.ats and *.adb to *.atb Name_Buffer (Dot_Index + 2) := 't'; Name_Buffer (Dot_Index + 4) := Ascii.NUL; Name_Len := Dot_Index + 3; Create_File_And_Check (Output_FD, Binary); Tree_Write_Initialize (Output_FD); end Tree_Create; ---------------- -- Tree_Close -- ---------------- procedure Tree_Close is begin pragma Assert (In_Compiler); Tree_Write_Terminate; Close (Output_FD); end Tree_Close; ----------------------- -- Write_Binder_Info -- ----------------------- procedure Write_Binder_Info (Info : String) is begin pragma Assert (In_Binder); Write_With_Check (Info'Address, Info'Length); Write_With_Check (EOL'Address, 1); end Write_Binder_Info; ------------------------ -- Write_Library_Info -- ------------------------ procedure Write_Library_Info (Info : String) is begin pragma Assert (In_Compiler); Write_With_Check (Info'Address, Info'Length); Write_With_Check (EOL'Address, 1); end Write_Library_Info; ------------------------ -- Write_Program_Name -- ------------------------ procedure Write_Program_Name is Command_Name : String (1 .. Len_Arg (0)); begin Fill_Arg (Command_Name'Address, 0); Write_Str (Command_Name); end Write_Program_Name; ---------------------- -- Write_With_Check -- ---------------------- procedure Write_With_Check (A : Address; N : Integer) is Ignore : Boolean; begin if N = Write (Output_FD, A, N) then return; else Write_Str ("error: disk full writing "); Write_Name_Decoded (Output_File_Name); Write_Eol; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Ascii.Nul; Delete_File (Name_Buffer'Address, Ignore); Exit_Program (E_Fatal); end if; end Write_With_Check; ----------------------- -- Write_Xref_Output -- ----------------------- procedure Write_Xref_Info (Info : String; Eol : Boolean := True) is begin pragma Assert (In_Compiler); Write_With_Check (Info'Address, Info'Length); if Eol then Write_With_Check (Osint.EOL'Address, 1); end if; end Write_Xref_Info; end Osint;