Geek Gadgets 1

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

/ Geek Gadgets 1 / ADE-1.bin / ade-bin / lib / gcc-lib / m68k-amigaos / 2.7.2.1 / adainclude / g-os_lib.adb < prev next >

Wrap

Text File | 1995-10-17 | 11.6 KB | 422 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T . O S _ L I B -- -- -- -- B o d y -- -- -- -- $Revision: 1.27 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- The GNAT library is free software; you can redistribute it and/or modify -- -- it under terms of the GNU Library General Public License as published by -- -- the Free Software Foundation; either version 2, or (at your option) any -- -- later version. The GNAT library is distributed in the hope that it will -- -- be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -- -- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- Library General Public License for more details. You should have -- -- received a copy of the GNU Library General Public License along with -- -- the GNAT library; see the file COPYING.LIB. If not, write to the Free -- -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Unchecked_Conversion; with System; use System; with System.Storage_Elements; use System.Storage_Elements; package body GNAT.OS_Lib is ----------------------- -- Local Subprograms -- ----------------------- function C_String_Length (S : Address) return Integer; -- Returns the length of a C string. Does check for null address -- (returns 0). --------------------- -- C_String_Length -- --------------------- function C_String_Length (S : Address) return Integer is function Strlen (S : Address) return Integer; pragma Import (C, Strlen, "strlen"); begin if S = Null_Address then return 0; else return Strlen (S); end if; end C_String_Length; ---------------------- -- Create_Temp_File -- ---------------------- procedure Create_Temp_File (FD : out File_Descriptor; Name : out Temp_File_Name) is function Get_Temp_Name (T : Address) return Address; pragma Import (C, Get_Temp_Name, "mktemp"); Result : Address; begin Name := "GNAT-XXXXXX" & Ascii.NUL; -- Check for NULL pointer returned by C if Get_Temp_Name (Name'Address) = To_Address (0) then FD := -1; else FD := Create_New_File (Name'Address, Binary); end if; end Create_Temp_File; ----------------- -- Delete_File -- ----------------- procedure Delete_File (Name : Address; Success : out Boolean) is R : Integer; function unlink (A : Address) return Integer; pragma Import (C, unlink, "unlink"); begin R := unlink (Name); Success := (R = 0); end Delete_File; ---------------------- -- File_Time_Stamp -- ---------------------- function File_Time_Stamp (FD : File_Descriptor) return OS_Time is function File_Time (FD : File_Descriptor) return OS_Time; pragma Import (C, File_Time, "file_time_fd"); begin return File_Time (FD); end File_Time_Stamp; ---------------------- -- File_Time_Stamp -- ---------------------- function File_Time_Stamp (Name : String) return OS_Time is function File_Time (Name : Address) return OS_Time; pragma Import (C, File_Time, "file_time_name"); F_Name : String (1 .. Name'Last + 1); begin F_Name (Name'Range) := Name; F_Name (F_Name'Last) := Ascii.NUL; return File_Time (F_Name'Address); end File_Time_Stamp; ------------ -- Getenv -- ------------ function Getenv (Name : String) return String_Access is procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); pragma Import (C, Get_Env_Value_Ptr, "get_env_value_ptr"); procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); pragma Import (C, Strncpy, "strncpy"); Env_Value_Ptr : Address; Env_Value_Length : Integer; F_Name : String (1 .. Name'Last + 1); Result : String_Access; begin F_Name (Name'Range) := Name; F_Name (F_Name'Last) := Ascii.NUL; Get_Env_Value_Ptr (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); Result := new String (1 .. Env_Value_Length); if Env_Value_Length > 0 then Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length); end if; return Result; end Getenv; ------------ -- GM_Day -- ------------ function GM_Day (Date : OS_Time) return Day_Type is Y : Year_Type; Mo : Month_Type; D : Day_Type; H : Hour_Type; Mn : Minute_Type; S : Second_Type; begin GM_Split (Date, Y, Mo, D, H, Mn, S); return D; end GM_Day; ------------- -- GM_Hour -- ------------- function GM_Hour (Date : OS_Time) return Hour_Type is Y : Year_Type; Mo : Month_Type; D : Day_Type; H : Hour_Type; Mn : Minute_Type; S : Second_Type; begin GM_Split (Date, Y, Mo, D, H, Mn, S); return H; end GM_Hour; --------------- -- GM_Minute -- --------------- function GM_Minute (Date : OS_Time) return Minute_Type is Y : Year_Type; Mo : Month_Type; D : Day_Type; H : Hour_Type; Mn : Minute_Type; S : Second_Type; begin GM_Split (Date, Y, Mo, D, H, Mn, S); return Mn; end GM_Minute; -------------- -- GM_Month -- -------------- function GM_Month (Date : OS_Time) return Month_Type is Y : Year_Type; Mo : Month_Type; D : Day_Type; H : Hour_Type; Mn : Minute_Type; S : Second_Type; begin GM_Split (Date, Y, Mo, D, H, Mn, S); return Mo; end GM_Month; --------------- -- GM_Second -- --------------- function GM_Second (Date : OS_Time) return Second_Type is Y : Year_Type; Mo : Month_Type; D : Day_Type; H : Hour_Type; Mn : Minute_Type; S : Second_Type; begin GM_Split (Date, Y, Mo, D, H, Mn, S); return S; end GM_Second; -------------- -- GM_Split -- -------------- procedure GM_Split (Date : OS_Time; Year : out Year_Type; Month : out Month_Type; Day : out Day_Type; Hour : out Hour_Type; Minute : out Minute_Type; Second : out Second_Type) is procedure To_GM_Time (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address); pragma Import (C, To_GM_Time, "to_gm_time"); T : OS_Time := Date; Y : Integer; Mo : Integer; D : Integer; H : Integer; Mn : Integer; S : Integer; begin To_GM_Time (T'Address, Y'Address, Mo'Address, D'Address, H'Address, Mn'Address, S'Address); Year := Y + 1900; Month := Mo + 1; Day := D; Hour := H; Minute := Mn; Second := S; end GM_Split; ------------- -- GM_Year -- ------------- function GM_Year (Date : OS_Time) return Year_Type is Y : Year_Type; Mo : Month_Type; D : Day_Type; H : Hour_Type; Mn : Minute_Type; S : Second_Type; begin GM_Split (Date, Y, Mo, D, H, Mn, S); return Y; end GM_Year; ------------------ -- Is_Directory -- ------------------ function Is_Directory (Name : String) return Boolean is function Is_Directory (Name : Address) return Integer; pragma Import (C, Is_Directory, "is_directory"); F_Name : String (1 .. Name'Last + 1); begin F_Name (Name'Range) := Name; F_Name (F_Name'Last) := Ascii.NUL; return Is_Directory (F_Name'Address) /= 0; end Is_Directory; --------------------- -- Is_Regular_File -- --------------------- function Is_Regular_File (Name : String) return Boolean is function Is_Regular_File (Name : Address) return Integer; pragma Import (C, Is_Regular_File, "is_regular_file"); F_Name : String (1 .. Name'Last + 1); begin F_Name (Name'Range) := Name; F_Name (F_Name'Last) := Ascii.NUL; return Is_Regular_File (F_Name'Address) /= 0; end Is_Regular_File; ------------------------- -- Locate_Regular_File -- ------------------------- function Locate_Regular_File (File_Name : String; Path : String) return String_Access is function Locate_Exec (Exec_Name, Path_Val : Address) return Address; pragma Import (C, Locate_Exec, "locate_exec"); -- "historical reasons" for the name of the C function. ??? Exec_Name : String (1 .. File_Name'Length + 1); Path_Val : String (1 .. Path'Length); Path_Addr : Address; Path_Len : Integer; Return_Val : String_Access; begin Exec_Name (1 .. File_Name'Length) := File_Name; Exec_Name (Exec_Name'Last) := Ascii.NUL; Path_Val (1 .. Path'Length) := Path; Path_Val (Path_Val'Last) := Ascii.NUL; Path_Addr := Locate_Exec (Exec_Name'Address, Path_Val'Address); Path_Len := C_String_Length (Path_Addr); if Path_Len = 0 then return null; else Return_Val := new String (1 .. Path_Len); declare subtype Path_String is String (1 .. Path_Len); type Path_String_Access is access Path_String; function Address_To_Access is new Unchecked_Conversion (Source => Address, Target => Path_String_Access); Path_Access : Path_String_Access := Address_To_Access (Path_Addr); begin for J in 1 .. Path_Len loop Return_Val (J) := Path_Access (J); end loop; return Return_Val; end; end if; end Locate_Regular_File; ----------- -- Spawn -- ----------- procedure Spawn (Program_Name : String; Args : Argument_List; Success : out Boolean) is Arg_List : array (1 .. Args'Length + 2) of Address; Arg : String_Access; function Portable_Spawn (Args : Address) return Integer; pragma Import (C, Portable_Spawn, "portable_spawn"); begin Arg := new String (1 .. Program_Name'Length + 1); Arg (1 .. Program_Name'Length) := Program_Name; Arg (Arg'Last) := Ascii.NUL; Arg_List (1) := Arg.all'Address; for J in 1 .. Args'Length loop Arg := new String (1 .. Args (J + Args'First - 1)'Length + 1); Arg (1 .. Arg'Last - 1) := Args (J + Args'First - 1).all; Arg (Arg'Last) := Ascii.NUL; Arg_List (J + 1) := Arg.all'Address; end loop; Arg_List (Arg_List'Last) := Null_Address; if Portable_Spawn (Arg_List'Address) = 0 then Success := True; else Success := False; end if; end Spawn; end GNAT.OS_Lib;