## posix-io-64.pkg
# Package for POSIX 1003.1 primitive I/O operations
# Using 64-bit positions.
stipulate
package host_unt = host_unt_guts
package int = int_guts
package file_position = file_position_guts
package ci = mythryl_callable_c_library_interface; # mythryl_callable_c_library_interface is from src/lib/std/src/unsafe/mythryl-callable-c-library-interface.pkg #
fun cfun fun_name
=
ci::find_c_function { lib_name => "posix_io", fun_name };
#
# If this code is revived, it should be changed from using
# find_c_function to using find_c_function' -- for a model
# see src/lib/std/src/psx/posix-io.pkg # -- 2012-04-24 CrT
herein
package posix_io {
#
# inline_t is from src/lib/core/init/built-in.pkg splitpos = inline_t::Int2::extern
joinpos = inline_t::Int2::intern
package fs = posix_file
package om: api
enum open_mode = O_RDONLY | O_WRONLY | O_RDWR
end = FS
use OM
type word = host_unt::word
type s_int = host_int::int
my ++ = host_unt::bitwise_or
my & = host_unt::bitwise_and
infix ++ &
my osval: String -> Sy_Int = cfun "osval"; # osval def in src/c/lib/posix-io/osval.c
#
w_osval = host_unt::from_int o osval
fun fail (fct, msg)
=
raise exception DIE ("POSIX_IO." + fct + ": " + msg)
type File_Descriptor = fs::File_Descriptor
type pid = posix_process::pid
my pipe' : Void -> (Sy_Int, Sy_Int) = cfun "pipe"; # pipe def in src/c/lib/posix-io/pipe.c
#
fun pipe ()
=
{ my (ifd, ofd) = pipe' ()
#
{ infd => fs::fd ifd,
outfd => fs::fd ofd
};
};
my dup' : s_int -> s_int = cfun "dup"; # dup def in src/c/lib/posix-io/dup.c
#
fun dup fd
=
fs::fd (dup' (fs::intOf fd));
my dup2' : (Sy_Int, Sy_Int) -> Void = cfun "dup2"; # dup2 def in src/c/lib/posix-io/dup2.c
#
fun dup2 { old, new }
=
dup2'(fs::intOf old, fs::intOf new);
my close' : s_int -> Void = cfun "close";
fun close fd = close' (fs::intOf fd)
my read' : (Int, Int) -> vector_of_one_byte_unts::Vector = cfun "read"; # read def in src/c/lib/posix-io/read.c
my readbuf' : (Int, rw_vector_of_one_byte_unts::Rw_Vector, Int, Int) -> Int = cfun "readbuf"; # readbuf def in src/c/lib/posix-io/readbuf.c
fun readArr (fd, asl) = let
my (buf, i, len) = rw_vector_slice_of_one_byte_unts::base asl
in
readbuf' (fs::intOf fd, buf, len, i)
end
fun readVec (fd, count) =
if count < 0 then raise exception SIZE else read'(fs::intOf fd, count)
my writevec' : (Int, vector_of_one_byte_unts::Vector, Int, Int) -> Int = cfun "writebuf"; # writebuf def in src/c/lib/posix-io/writebuf.c
my writearr' : (Int, rw_vector_of_one_byte_unts::Rw_Vector, Int, Int) -> Int = cfun "writebuf"; # writebuf def in src/c/lib/posix-io/writebuf.c
fun writeArr (fd, asl) = let
my (buf, i, len) = rw_vector_slice_of_one_byte_unts::base asl
in
writearr' (fs::intOf fd, buf, len, i)
end
fun writeVec (fd, vsl) = let
my (buf, i, len) = vector_slice_of_one_byte_unts::base vsl
in
writevec' (fs::intOf fd, buf, len, i)
end
enum whence = SEEK_SET | SEEK_CUR | SEEK_END
seek_set = osval "SEEK_SET"
seek_cur = osval "SEEK_CUR"
seek_end = osval "SEEK_END"
fun whToWord SEEK_SET = seek_set
| whToWord SEEK_CUR = seek_cur
| whToWord SEEK_END = seek_end
fun whFromWord wh =
if wh == seek_set then SEEK_SET
else if wh == seek_cur then SEEK_CUR
else if wh == seek_end then SEEK_END
else fail ("whFromWord", "unknown whence "$(int::to_string wh))
package fd {
local package bf = bit_flags_g ()
in
use BF
end
cloexec = fromWord (w_osval "cloexec")
}
package o {
local package bf = bit_flags_g ()
in
use BF
end
append = fromWord (w_osval "append")
dsync = fromWord (w_osval "dsync")
nonblock = fromWord (w_osval "nonblock")
rsync = fromWord (w_osval "rsync")
sync = fromWord (w_osval "sync")
}
my fcntl_d: (Sy_Int, Sy_Int) -> Sy_Int = cfun "fcntl_d"; # fcntl_d def in src/c/lib/posix-io/fcntl_d.c
my fcntl_gfd: Sy_int -> Sy_Unt = cfun "fcntl_gfd"; # fcntl_gfd def in src/c/lib/posix-io/fcntl_gfd.c
my fcntl_sfd: (Sy_Int, Sy_Unt) -> Void = cfun "fcntl_sfd"; # fcntl_sfd def in src/c/lib/posix-io/fcntl_sfd.c
my fcntl_gfl: Sy_Int -> (Sy_Unt, Sy_Unt) = cfun "fcntl_gfl"; # fcntl_gfl def in src/c/lib/posix-io/fcntl_gfl.c
my fcntl_sfl: (Sy_Int, Sy_Unt) -> Void = cfun "fcntl_sfl"; # fcntl_sfl def in src/c/lib/posix-io/fcntl_sfl.c
#
fun dupfd { old, base } = fs::fd (fcntl_d (fs::intOf old, fs::intOf base))
fun getfd fd = fd::fromWord (fcntl_gfd (fs::intOf fd))
fun setfd (fd, fl) = fcntl_sfd (fs::intOf fd, fd::toWord fl)
fun getfl fd = let
my (status, omode) = fcntl_gfl (fs::intOf fd)
in
(o::fromWord status, fs::omodeFromWord omode)
end
fun setfl (fd, status) = fcntl_sfl (fs::intOf fd, o::toWord status)
enum lock_type = F_RDLCK | F_WRLCK | F_UNLCK
package FLock {
enum flock = FLOCK of {
ltype: lock_type,
whence: whence,
start: file_position::Int,
len: file_position::Int,
pid: Null_Or( pid )
}
fun flock fv = FLOCK fv
fun ltype (FLOCK fv) = fv.ltype
fun whence (FLOCK fv) = fv.whence
fun start (FLOCK fv) = fv.start
fun len (FLOCK fv) = fv.len
fun pid (FLOCK fv) = fv.pid
}
type flock_rep = s_int *
s_int *
one_word_unt::word * one_word_unt::word *
one_word_unt::word * one_word_unt::word *
s_int
my fcntl_l: (Sy_Int, Sy_Int, Flock_Rep) -> flock_rep = cfun "fcntl_l_64"; # fcntl_l_64 def in src/c/lib/posix-io/fcntl_l_64.c
f_getlk = osval "F_GETLK"
f_setlk = osval "F_SETLK"
f_setlkw = osval "F_SETLKW"
f_rdlck = osval "F_RDLCK"
f_wrlck = osval "F_WRLCK"
f_unlck = osval "F_UNLCK"
fun flockToRep (FLock::FLOCK { ltype, whence, start, len, ... } ) = let
fun ltypeOf F_RDLCK = f_rdlck
| ltypeOf F_WRLCK = f_wrlck
| ltypeOf F_UNLCK = f_unlck
my (shi, slo) = splitpos start
my (lhi, llo) = splitpos len
in
(ltypeOf ltype, whToWord whence, shi, slo, lhi, llo, 0)
end
fun flockFromRep (usepid, (ltype, whence, shi, slo, lhi, llo, pid)) = let
fun ltypeOf ltype =
if ltype == f_rdlck then F_RDLCK
else if ltype == f_wrlck then F_WRLCK
else if ltype == f_unlck then F_UNLCK
else fail ("flockFromRep", "unknown lock type "$(int::to_string ltype))
in
FLock::FLOCK {
ltype = ltypeOf ltype,
whence = whFromWord whence,
start = joinpos (shi, slo),
len = joinpos (lhi, llo),
pid = if usepid then THE (posix_process::PID pid) else NULL
}
end
fun getlk (fd, flock) =
flockFromRep (TRUE, fcntl_l (fs::intOf fd, f_getlk, flockToRep flock))
fun setlk (fd, flock) =
flockFromRep (FALSE, fcntl_l (fs::intOf fd, f_setlk, flockToRep flock))
fun setlkw (fd, flock) =
flockFromRep (FALSE, fcntl_l (fs::intOf fd, f_setlkw, flockToRep flock))
my lseek'
:
(Sy_Int, one_word_unt::Unt, one_word_unt::Unt, Sy_Int) -> (one_word_unt::Unt, one_word_unt::Unt)
=
cfun "lseek_64" # lseek_64 def in src/c/lib/posix-io/lseek_64.c
fun lseek (fd, offset, whence)
=
let my (ohi, olo) = splitpos offset
in joinpos (lseek'(fs::intOf fd, ohi, olo, whToWord whence))
end
my fsync' : Sy_Int -> Void = cfun "fsync"; # fsync def in src/c/lib/posix-io/fsync.c
#
fun fsync fd
=
fsync' (fs::intOf fd)
# Making readers and writers...
# (code lifted from winix-data-file-io-driver-for-posix--premicrothread.pkg
# and winix-text-file-io-driver-for-posix--premicrothread.pkg)
fun announce s x y = (
# print "Posix: "; print (s: String); print "\n";
x y)
bufferSzB = 4096
fun isRegFile fd = fs::st::isReg (fs::fstat fd)
fun posFns (closed, fd) =
if isRegFile fd then
let pos = REF (file_position::from_int 0)
fun getPos () = *pos
fun setPos p =
(if *closed then raise exception io::CLOSED_IO_STREAM
pos := announce "lseek" lseek (fd, p, SEEK_SET))
fun endPos () =
(if *closed then raise exception io::CLOSED_IO_STREAM
fs::st::size (announce "fstat" fs::fstat fd))
fun verifyPos () =
let curPos = lseek (fd, file_position::from_int 0, SEEK_CUR)
in
pos := curPos; curPos
end
in
ignore (verifyPos ());
{ pos = pos,
getPos = THE getPos,
setPos = THE setPos,
endPos = THE endPos,
verifyPos = THE verifyPos }
end
else { pos = REF (file_position::from_int 0),
getPos = NULL, setPos = NULL, endPos = NULL, verifyPos = NULL }
fun mkReader { mkRD, cvtVec, cvtArrSlice } { fd, name, initablekMode } =
let closed = REF FALSE
my { pos, getPos, setPos, endPos, verifyPos } = posFns (closed, fd)
blocking = REF initablekMode
fun blockingOn () = (setfl (fd, o::flags[]); blocking := TRUE)
fun blockingOff () = (setfl (fd, o::nonblock); blocking := FALSE)
fun incPos k = pos := position.+(*pos, file_position::from_int k)
fun r_readVec n =
let v = announce "read" readVec (fd, n)
in
incPos (vector_of_one_byte_unts::length v);
cvtVec v
end
fun r_readArr arg =
let k = announce "readBuf" readArr (fd, cvtArrSlice arg)
in
incPos k; k
end
fun blockWrap f x =
(if *closed then raise exception io::CLOSED_IO_STREAM
if *blocking then () else blockingOn();
f x)
fun noBlockWrap f x =
(if *closed then raise exception io::CLOSED_IO_STREAM
if *blocking then blockingOff()
(/* try */ THE (f x)
except (e as assembly::RUNTIME_EXCEPTION(_, THE cause)) =>
if cause == posix_error::again then NULL
else raise exception e
/* end try */))
fun r_close () =
if *closed then ()
else (closed:=TRUE; announce "close" close fd)
isReg = isRegFile fd
fun avail () =
if *closed then THE 0
else if isReg then
THE (file_position::toInt (fs::st::size (fs::fstat fd) - *pos))
else NULL
in
mkRD { name = name,
chunkSize = bufferSzB,
readVec = THE (blockWrap r_readVec),
readArr = THE (blockWrap r_readArr),
readVecNB = THE (noBlockWrap r_readVec),
readArrNB = THE (noBlockWrap r_readArr),
block = NULL,
can_readx = NULL,
avail = avail,
getPos = getPos,
setPos = setPos,
endPos = endPos,
verifyPos = verifyPos,
close = r_close,
ioDesc = THE (fs::fdToIOD fd) }
end
fun mkWriter { mkWR, cvtVecSlice, cvtArrSlice }
{ fd, name, initablekMode, appendMode, chunkSize } =
let closed = REF FALSE
my { pos, getPos, setPos, endPos, verifyPos } = posFns (closed, fd)
fun incPos k = (pos := position.+(*pos, file_position::from_int k); k)
blocking = REF initablekMode
appendFS = o::flags (if appendMode then [o::append] else NIL)
fun updateStatus() =
let flgs = if *blocking then appendFS
else o::flags[o::nonblock, appendFS]
in
announce "setfl" setfl (fd, flgs)
end
fun ensureOpen () = if *closed then raise exception io::CLOSED_IO_STREAM else ()
fun ensureBlock (x) =
if *blocking == x then () else (blocking := x; updateStatus())
fun writeVec' (fd, s) = writeVec (fd, cvtVecSlice s)
fun writeArr' (fd, s) = writeArr (fd, cvtArrSlice s)
fun putV x = incPos (announce "writeVec" writeVec' x)
fun putA x = incPos (announce "writeArr" writeArr' x)
fun write (put, block) arg =
(ensureOpen();
ensureBlock block;
put (fd, arg))
fun handleBlock writer arg =
THE (writer arg)
except (e as assembly::RUNTIME_EXCEPTION(_, THE cause)) =>
if cause == posix_error::again then NULL else raise exception e
fun w_close () =
if *closed then ()
else (closed:=TRUE; announce "close" close fd)
in
mkWR { name = name,
chunkSize = chunkSize,
writeVec = THE (write (putV, TRUE)),
writeArr = THE (write (putA, TRUE)),
writeVecNB = THE (handleBlock (write (putV, FALSE))),
writeArrNB = THE (handleBlock (write (putA, FALSE))),
block = NULL,
canOutput = NULL,
getPos = getPos,
setPos = setPos,
endPos = endPos,
verifyPos = verifyPos,
ioDesc = THE (fs::fdToIOD fd),
close = w_close }
end
local
fun c2w_vs cvs = let
my (cv, s, l) = vector_slice_of_chars::base cvs
wv = byte::string_to_bytes cv
in
vector_slice_of_one_byte_unts::slice (wv, s, THE l)
end
# hack!!! This only works because rw_vector_of_chars::Rw_Vector and
# rw_vector_of_one_byte_unts::Rw_Vector are really the same internally.
my c2w_a
:
rw_vector_of_chars::Rw_Vector -> rw_vector_of_one_byte_unts::Rw_Vector
=
inline_t::cast
fun c2w_as cas = let
my (ca, s, l) = rw_vector_slice_of_chars::base cas
wa = c2w_a ca
in
rw_vector_slice_of_one_byte_unts::slice (wa, s, THE l)
end
in
mkBinReader = mkReader { mkRD = winix_base_data_file_io_driver_for_posix__premicrothread::RD,
cvtVec = \\ v => v,
cvtArrSlice = \\ s => s }
mkTextReader = mkReader { mkRD = winix_base_text_file_io_driver_for_posix__premicrothread::RD,
cvtVec = byte::bytes_to_string,
cvtArrSlice = c2w_as }
mkBinWriter = mkWriter { mkWR = winix_base_data_file_io_driver_for_posix__premicrothread::WR,
cvtVecSlice = \\ s => s,
cvtArrSlice = \\ s => s }
mkTextWriter = mkWriter { mkWR = winix_base_text_file_io_driver_for_posix__premicrothread::WR,
cvtVecSlice = c2w_vs,
cvtArrSlice = c2w_as }
end # local
}; # package posix_io
end