File : posix.adb
------------------------------------------------------------------------------
-- --
-- FLORIST (FSU Implementation of POSIX.5) COMPONENTS --
-- --
-- P O S I X --
-- --
-- B o d y --
-- --
-- --
-- Copyright (c) 1996-1999 Florida State University (FSU), --
-- All Rights Reserved. --
-- --
-- This file is a component of FLORIST, an implementation of an Ada API --
-- for the POSIX OS services, for use with the GNAT Ada compiler and --
-- the FSU Gnu Ada Runtime Library (GNARL). The interface is intended --
-- to be close to that specified in IEEE STD 1003.5: 1990 and IEEE STD --
-- 1003.5b: 1996. --
-- --
-- FLORIST is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the --
-- Free Software Foundation; either version 2, or (at your option) any --
-- later version. FLORIST 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 --
-- General Public License for more details. You should have received a --
-- copy of the GNU General Public License distributed with GNARL; see --
-- file COPYING. If not, write to the Free Software Foundation, 59 --
-- Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
------------------------------------------------------------------------------
-- [$Revision: 1.3 $]
with POSIX.C,
POSIX.Implementation,
Unchecked_Conversion,
Unchecked_Deallocation;
pragma Elaborate (POSIX.C);
pragma Elaborate (POSIX.Implementation);
package body POSIX is
use POSIX.C;
use POSIX.Implementation;
type String_List is new POSIX.Implementation.String_List;
-----------------------------
-- Unchecked Conversions --
-----------------------------
type String_Ptr is access all String;
type Wide_String_Ptr is access all Wide_String;
type Stream_Element_Array_Ptr is
access all Ada.Streams.Stream_Element_Array;
function sptr_to_psptr is new Unchecked_Conversion
(String_Ptr, POSIX_String_Ptr);
function psptr_to_sptr is new Unchecked_Conversion
(POSIX_String_Ptr, String_Ptr);
function smelmptr_to_psptr is new Unchecked_Conversion
(Stream_Element_Array_Ptr, POSIX_String_Ptr);
function psptr_to_smelmptr is new Unchecked_Conversion
(POSIX_String_Ptr, Stream_Element_Array_Ptr);
-----------------------
-- To_POSIX_String --
-----------------------
function To_POSIX_String (Str : String)
return POSIX_String is
begin
return sptr_to_psptr (Str'Unrestricted_Access).all;
end To_POSIX_String;
-----------------
-- To_String --
-----------------
function To_String (Str : POSIX_String)
return string is
begin
return psptr_to_sptr (Str'Unrestricted_Access).all;
end To_String;
----------------------
-- To_Wide_String --
----------------------
function To_Wide_String (Str : POSIX_String)
return Wide_String is
Result : Wide_String (Str'Range);
begin
for I in Str'Range loop
Result (I) :=
Wide_Character'Val (POSIX_Character'Pos (Str (I)));
end loop;
return Result;
end To_Wide_String;
-- We cannot use direct unchecked conversion here,
-- since the sizes of the characters are different.
-- However, we rely that the integer codes for the
-- first 256 wide characters are the same as those
-- of the ordinary characters. [See ARM A.1 (36)]
-----------------------
-- To_POSIX_String --
-----------------------
function To_POSIX_String (Str : Wide_String)
return POSIX_String is
Result : POSIX_String (Str'Range);
begin
for I in Str'Range loop
Result (I) := POSIX_Character'Val
(Wide_Character'Pos (Str (I)) rem 256);
end loop;
return Result;
end To_POSIX_String;
-------------------------------
-- To_Stream_Element_Array --
-------------------------------
function To_Stream_Element_Array (Buffer : POSIX_String)
return Ada.Streams.Stream_Element_Array is
begin
return psptr_to_smelmptr (Buffer'Unrestricted_Access).all;
end To_Stream_Element_Array;
-- This is only going to work if the sizes of
-- Stream_Element and Character are the same.
Assert_1 : constant := Boolean'Pos (Boolean'Pred
(Ada.Streams.Stream_Element'Size = Character'Size));
-----------------------
-- To_POSIX_String --
-----------------------
function To_POSIX_String
(Buffer : Ada.Streams.Stream_Element_Array) return POSIX_String is
begin
return smelmptr_to_psptr (Buffer'Unrestricted_Access).all;
end To_POSIX_String;
-------------------
-- Is_Filename --
-------------------
function Is_Filename (Str : POSIX_String) return Boolean is
begin
if To_String (Str)'Length = 0 then return False; end if;
for I in Str'Range loop
if Str (I) = '/' or Str (I) = NUL or Str (I) = ' ' then
return false;
end if;
end loop;
return True;
end Is_Filename;
-- These two functions (Is_Pathname and Is_Filename) seem
-- not to be unimplementable in a portable way, since they are
-- supposed to "check all constraints set on filename and
-- pathname by the implementation that can be checked without
-- accessing the file system directly.
-------------------
-- Is_Pathname --
-------------------
function Is_Pathname (Str : POSIX_String) return Boolean is
begin
if To_String (Str)'Length = 0 then return False; end if;
for I in Str'Range loop
if Str (I) = NUL or Str (I) = ' ' then
return false;
end if;
end loop;
return True;
end Is_Pathname;
----------------------------
-- Is_Portable_filename --
----------------------------
function Is_Portable_Filename (Str : POSIX_String)
return Boolean is
begin
if To_String (Str)'Length = 0 then return False; end if;
for I in Str'Range loop
case Str (I) is
when 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '.' | '_' =>
null;
when '-' =>
if I = Str'First then return False; end if;
when others =>
return False;
end case;
end loop;
return True;
end Is_Portable_Filename;
----------------------------
-- Is_Portable_Pathname --
----------------------------
function Is_Portable_Pathname (Str : POSIX_String)
return Boolean is
Start : Positive;
P : Positive;
begin
if To_String (Str)'Length = 0 then return false; end if;
Start := Str'First;
P := Str'First;
loop
if P > Str'Last or else Str (P) = '/' then
if Start < P and then not
Is_Portable_Filename (Str (Start .. P - 1)) then
return false;
end if;
if P > Str'Last then return true; end if;
Start := P + 1;
end if;
P := P + 1;
end loop;
end Is_Portable_Pathname;
------------------
-- Make_Empty --
------------------
procedure Free is
new Unchecked_Deallocation (POSIX_String, POSIX_String_Ptr);
procedure Free is
new Unchecked_Deallocation (String_List, POSIX_String_List);
procedure Make_Empty (List : in out POSIX_String_List) is
begin
if List = null then return; end if;
for I in 1 .. List.Length loop
if List.List (I) = null then exit; end if;
Free (List.List (I));
end loop;
Free (List);
end Make_Empty;
--------------
-- Append --
--------------
procedure Append
(List : in out POSIX_String_List;
In_Str : in POSIX_String) is
Tmp : POSIX_String_List;
Len : constant Integer := In_Str'Length;
begin
if List = null then
List := new String_List (Min_String_List_Length);
-- rely that pointers all initialized to null
end if;
for I in 1 .. List.Length loop
if List.List (I) = null then
if I = List.Length then
Tmp := new String_List (2 * List.Length);
Tmp.List (List.List'Range) := List.List;
Tmp.Char (List.List'Range) := List.Char;
Free (List); List := Tmp;
end if;
List.List (I) := new POSIX_String (1 .. Len + 1);
List.List (I)(1 .. Len) := In_Str;
List.List (I)(Len + 1) := NUL;
List.Char (I) := List.List (I)(1)'Unchecked_Access;
return;
end if;
end loop;
end Append;
----------------------
-- For_Every_Item --
----------------------
-- generic
-- with procedure Action
-- (Item: POSIX_String; Quit: in out Boolean);
procedure For_Every_Item (List : in POSIX_String_List) is
Quit : Boolean := False;
begin
if List = null then return; end if;
for I in 1 .. List.Length loop
exit when List.List (I) = null;
declare
L : constant Integer := List.List (I)'Length;
begin
Action (List.List (I)(1 .. L - 1), Quit);
end;
exit when Quit;
end loop;
end For_Every_Item;
--------------
-- Length --
--------------
function Length (List : POSIX_String_List)
return Natural is
begin
if List = null then return 0; end if;
for I in 1 .. List.Length loop
if List.List (I) = null then return Natural (I - 1);
end if;
end loop;
raise Program_Error;
return 0;
end Length;
-------------
-- Value --
-------------
function Value
(List : POSIX_String_List;
Index : Positive)
return POSIX_String is
I : constant Positive := Index;
begin
if List = null or else
not (I in 1 .. List.Length) or else
List.List (I) = null then raise Constraint_Error;
end if;
declare
L : constant Integer := List.List (I).all'Length;
begin
return List.List (I)(1 .. L - 1);
end;
end Value;
-----------------
-- Empty_set --
-----------------
function Empty_Set return Option_Set is
begin
return (Option => 0);
end Empty_Set;
-----------
-- "+" --
-----------
function "+" (L, R : Option_Set) return Option_Set is
begin
return (Option => Bits (unsigned (L.Option) or unsigned (R.Option)));
end "+";
-----------
-- "-" --
-----------
function "-" (L, R : Option_Set) return Option_Set is
begin
return (Option =>
Bits (unsigned (L.Option) and not (unsigned (R.Option))));
end "-";
---------
-- < --
---------
function "<" (Left, Right : Option_Set) return Boolean is
begin
return (Left <= Right) and (Left /= Right);
end "<";
---------
-- <= --
---------
function "<=" (Left, Right : Option_Set) return Boolean is
begin
return (((not Bits (unsigned (Right.Option)))) and
Bits (unsigned (Left.Option))) = 0;
end "<=";
---------
-- > --
---------
function ">" (Left, Right : Option_Set) return Boolean is
begin
return Right < Left;
end ">";
----------
-- >= --
----------
function ">=" (Left, Right : Option_Set) return Boolean is
begin
return Right <= Left;
end ">=";
----------------------
-- Get_Error_Code --
----------------------
function Get_Error_Code return Error_Code is
begin
return POSIX.Implementation.Get_Ada_Error_Code;
end Get_Error_Code;
----------------------
-- Set_Error_Code --
----------------------
procedure Set_Error_Code (Error : in Error_Code) is
begin
POSIX.Implementation.Set_Ada_Error_Code (Error);
end Set_Error_Code;
----------------------
-- Is_POSIX_Error --
----------------------
function Is_POSIX_Error (Error : Error_Code) return Boolean is
use Bogus_Error_Codes;
begin
for I in Error_Array'Range loop
if Error = Error_Array (I) then
return True;
end if;
end loop;
return False;
end Is_POSIX_Error;
-------------
-- Image --
-------------
function Image (Error : Error_Code) return String is
use Bogus_Error_Codes;
begin
for I in Error_Array'Range loop
if Error = Error_Array (I) then
return Error_Name_Enum'Image (I);
end if;
end loop;
declare
Tmp : constant String := Error_Code'Image (Error);
begin
if Tmp (Tmp'First) /= ' ' then return Tmp; end if;
return Tmp (Tmp'First + 1 .. Tmp'Last);
end;
end Image;
function uname (name : access struct_utsname)
return int;
pragma Import (C, uname, uname_LINKNAME);
-------------------
-- System_Name --
-------------------
function System_Name return POSIX_String is
Name : aliased struct_utsname;
begin
Check (uname (Name'Unchecked_Access));
return Form_POSIX_String (Name.sysname (1)'Unchecked_Access);
end System_Name;
-----------------
-- Node_Name --
-----------------
function Node_Name return POSIX_String is
Name : aliased struct_utsname;
begin
Check (uname (Name'Unchecked_Access));
return Form_POSIX_String (Name.nodename (1)'Unchecked_Access);
end Node_Name;
---------------
-- Release --
---------------
function Release return POSIX_String is
Name : aliased struct_utsname;
begin
Check (uname (Name'Unchecked_Access));
return Form_POSIX_String (Name.release (1)'Unchecked_Access);
end Release;
---------------
-- Version --
---------------
function Version return POSIX_String is
Name : aliased struct_utsname;
begin
Check (uname (Name'Unchecked_Access));
return Form_POSIX_String (Name.version (1)'Unchecked_Access);
end Version;
---------------
-- Machine --
---------------
function Machine return POSIX_String is
Name : aliased struct_utsname;
begin
Check (uname (Name'Unchecked_Access));
return Form_POSIX_String (Name.machine (1)'Unchecked_Access);
end Machine;
-----------------------------------------
-- Timespec Composition/Decomposition --
-----------------------------------------
procedure Split
(D : in Duration;
S : out Duration;
NS : out Duration);
pragma Inline (Split);
-- Decompose D into seconds (S) and nanoseconds (NS) parts,
-- with the nanosecond part in the range 0.0 .. 0.999999999.
procedure Split
(D : in Duration;
S : out Duration;
NS : out Duration) is
begin
S := POSIX.Implementation.To_Duration
(To_D_Int (D / NS_per_S) * NS_per_S);
NS := D - S;
if NS < 0.0 then
S := S - 1.0;
NS := NS + 1.0;
end if;
end Split;
-------------
-- Split --
-------------
procedure Split
(Time : in Timespec;
S : out Seconds;
NS : out Nanoseconds) is
SD, NSD : Duration;
begin
Split (Time.Val, S => SD, NS => NSD);
S := Seconds (SD); NS := Nanoseconds (NSD * NS_per_S);
end Split;
-------------------
-- To_Timespec --
-------------------
function To_Timespec
(S : Seconds;
NS : Nanoseconds) return Timespec is
begin
return Timespec'
(Val => Duration (S) + Duration (NS) / NS_per_S);
end To_Timespec;
-------------------
-- Get_Seconds --
-------------------
function Get_Seconds (Time : Timespec) return Seconds is
SD, NSD : Duration;
begin
Split (Time.Val, S => SD, NS => NSD);
return Seconds (SD);
end Get_Seconds;
-----------------------
-- Get_Nanoseconds --
-----------------------
function Get_Nanoseconds (Time : Timespec) return Nanoseconds is
SD, NSD : Duration;
begin
Split (Time.Val, S => SD, NS => NSD);
return Nanoseconds (NSD * NS_per_S);
end Get_Nanoseconds;
-----------------------
-- Set_Nanoseconds --
-----------------------
procedure Set_Nanoseconds
(Time : in out Timespec;
NS : in Nanoseconds) is
SD, NSD : Duration;
begin
Split (Time.Val, S => SD, NS => NSD);
Time.Val := SD + Duration (NS) / NS_per_S;
end Set_Nanoseconds;
-------------------
-- Set_Seconds --
-------------------
procedure Set_Seconds
(Time : in out Timespec;
S : in Seconds) is
SD, NSD : Duration;
begin
Split (Time.Val, S => SD, NS => NSD);
Time.Val := Duration (S) + NSD;
end Set_Seconds;
-----------
-- "+" --
-----------
function "+" (Left, Right : Timespec) return Timespec is
begin
return Timespec' (Val => Left.Val + Right.Val);
end "+";
-----------
-- "+" --
-----------
function "+" (Left : Timespec; Right : Nanoseconds)
return Timespec is
begin
return Timespec'
(Val => Left.Val + Duration (Right) / NS_per_S);
end "+";
-----------
-- "-" --
-----------
function "-" (Right : Timespec) return Timespec is
begin
return Timespec' (Val => -Right.Val);
end "-";
-----------
-- "-" --
-----------
function "-" (Left, Right : Timespec) return Timespec is
begin
return Timespec' (Val => Left.Val - Right.Val);
end "-";
-----------
-- "-" --
-----------
function "-" (Left : Timespec; Right : Nanoseconds)
return Timespec is
begin
return Timespec' (Val => Left.Val - Duration (Right) / NS_per_S);
end "-";
-----------
-- "*" --
-----------
function "*" (Left : Timespec; Right : Integer)
return Timespec is
begin
return Timespec' (Val => Left.Val * Duration (Right));
end "*";
-----------
-- "*" --
-----------
function "*" (Left : Integer; Right : Timespec)
return Timespec is
begin
return Timespec' (Val => Left * Right.Val);
end "*";
-----------
-- "/" --
-----------
function "/" (Left : Timespec; Right : Integer)
return Timespec is
begin
return Timespec' (Val => Left.Val / Right);
end "/";
-----------
-- "/" --
-----------
function "/" (Left, Right : Timespec) return Integer is
begin
return Integer (Left.Val / Right.Val);
end "/";
-----------
-- "<" --
-----------
function "<" (Left, Right : Timespec) return Boolean is
begin
return Left.Val < Right.Val;
end "<";
-----------
-- "<=" --
-----------
function "<=" (Left, Right : Timespec) return Boolean is
begin
return Left.Val < Right.Val or else Right.Val = Left.Val;
end "<=";
-----------
-- ">" --
-----------
function ">" (Left, Right : Timespec) return Boolean is
begin
return Right <= Left;
end ">";
------------
-- ">=" --
------------
function ">=" (Left, Right : Timespec) return Boolean is
begin
return Right < Left;
end ">=";
-------------------
-- To_Timespec --
-------------------
function To_Timespec (D : Duration) return Timespec is
begin
return Timespec' (Val => D);
end To_Timespec;
-------------------
-- To_Duration --
-------------------
function To_Duration (Time : Timespec) return Duration is
begin
return Time.Val;
end To_Duration;
------------------------------
-- Host_To_Network_Byte_Order
------------------------------
function c_htonl (host_32 : Interfaces.Unsigned_32)
return Interfaces.Unsigned_32;
pragma Import (C, c_htonl, "c_htonl");
function Host_To_Network_Byte_Order (Host_32 : Interfaces.Unsigned_32)
return Interfaces.Unsigned_32 is
begin
return c_htonl (Host_32);
end Host_To_Network_Byte_Order;
function c_htons (host_16 : Interfaces.Unsigned_16)
return Interfaces.Unsigned_16;
pragma Import (C, c_htons, "c_htons");
function Host_To_Network_Byte_Order (Host_16 : Interfaces.Unsigned_16)
return Interfaces.Unsigned_16 is
begin
return c_htons (Host_16);
end Host_To_Network_Byte_Order;
------------------------------
-- Host_To_Network_Byte_Order
------------------------------
function c_ntohl (host_32 : Interfaces.Unsigned_32)
return Interfaces.Unsigned_32;
pragma Import (C, c_ntohl, "c_htonl");
function Network_To_Host_Byte_Order (Host_32 : Interfaces.Unsigned_32)
return Interfaces.Unsigned_32 is
begin
return c_ntohl (Host_32);
end Network_To_Host_Byte_Order;
function c_ntohs (host_16 : Interfaces.Unsigned_16)
return Interfaces.Unsigned_16;
pragma Import (C, c_ntohs, "c_htons");
function Network_To_Host_Byte_Order (Host_16 : Interfaces.Unsigned_16)
return Interfaces.Unsigned_16 is
begin
return c_ntohs (Host_16);
end Network_To_Host_Byte_Order;
begin
pragma Assert (Duration'Small = 1.0/NS_per_S);
-- We rely that Duration is an exact count of nanoseconds.
null;
end POSIX;