BinIO bugfix, mlton-posix.h update...
ANOQ of the Sun
anoq@hardcoreprocessing.com
Mon, 15 Nov 1999 12:31:35 -0800
This message is in MIME format. Since your mail reader does not understand
this format, some or all of this message may not be legible.
------_=_NextPart_000_01BF2FA9.161782A2
Content-Type: text/plain;
charset="windows-1252"
Hello!
BinIO works now... I found a bug. One of the lines was:
val empty = ""
It should of course be:
val empty = Word8Vector.tabulate (0, fn _ => 0w0)
I have attached a new bin-io.sml
Also I have added the #defines to mlton-posix.h
and attached it and put it on the webpage.
It now works on Windows - at least the functions
I have used:
openIn, closeIn, openOut, closeOut,
flushOut, inputN, output
Cheers
--
http://www.HardcoreProcessing.com
------_=_NextPart_000_01BF2FA9.161782A2
Content-Type: application/x-unknown-content-type-sml_auto_file;
name="bin-io.sml"
Content-Transfer-Encoding: quoted-printable
Content-Disposition: attachment;
filename="bin-io.sml"
(* Copyright (C) 1997-1999 NEC Research Institute.
* Please see the file LICENSE for license information.
*)
structure BinIO: BIN_IO =3D
struct
structure FS =3D Posix.FileSys
structure PIO =3D Posix.IO
=20
structure Array =3D Word8Array
structure Vector =3D Word8Vector
=20
type vector =3D Vector.vector
type elem =3D Vector.elem
val bufSize =3D 4096
(*---------------------------------------------------*)
(* outstream *)
(*---------------------------------------------------*)
datatype buf =3D
Buf of {size: int ref,
array: Array.array}
fun isFull(Buf{size, ...}) =3D !size =3D bufSize
(* write out to fd size bytes of buf starting at index i *)
fun flushGen(fd: FS.file_desc,
buf: 'a,
i: int,
size: int,
write: FS.file_desc * {buf: 'a,
i: int,
sz: int option} -> int): unit =3D
let
val max =3D i + size
fun loop i =3D
if i =3D max
then ()
else
loop(i + write(fd, {buf =3D buf,
i =3D i,
sz =3D SOME(max - i)}))
in loop i
end
fun flush(fd, Buf{size, array}) =3D
(flushGen(fd, array, 0, !size, PIO.writeArr)
; size :=3D 0)
=20
datatype bufStyle =3D
Unbuffered
| Line of buf
| Buffered of buf
=20
datatype outstream' =3D
Out of {fd: FS.file_desc,
closed: bool ref,
bufStyle: bufStyle}
type outstream =3D outstream' ref
val mkOutstream =3D ref
val getOutstream =3D !
val setOutstream =3D op :=3D
=20
fun flushOut(ref(Out{fd, bufStyle, closed, ...})): unit =3D
(case (!closed, bufStyle) of
(true, _) =3D> ()
| (_, Unbuffered) =3D> ()
| (_, Line b) =3D> flush(fd, b)
| (_, Buffered b) =3D> flush(fd, b))
handle exn =3D> raise IO.Io{name =3D "<unimplemented>",
function =3D "flushOut",
cause =3D exn}
val openOuts: outstream list ref =3D ref []
fun closeOut(out as ref(Out{fd, closed, ...})): unit =3D
if !closed then ()
else (flushOut out;
closed :=3D true;
PIO.close fd;
openOuts :=3D List.filter (fn out' =3D> not(out =3D out')) =
(!openOuts))
val newOut =3D
((* These side-effect is here so that the dead code elimination won't
* get rid of it as long as newOut is used
*)
AtSaveWorld.addNewCleaner(fn () =3D> List.app flushOut (!openOuts));
AtExit.addNewCleaner
(fn () =3D>
List.app
(fn out as ref(Out{fd,...}) =3D>
(flushOut out;
if fd =3D FS.stdout orelse fd =3D FS.stderr
then ()
else closeOut out))
(!openOuts));
(* end stupidity *)
fn fd =3D>
let
val bufStyle =3D
if fd =3D FS.stderr
then Unbuffered
else (if Posix.ProcEnv.isatty fd then Line else Buffered)
(Buf{size =3D ref 0,
array =3D Array.array(bufSize, 0w0)})
val out =3D ref(Out{fd =3D fd,
closed =3D ref false,
bufStyle =3D bufStyle})
in openOuts :=3D out :: !openOuts;
out
end)
local
val readWrite =3D
let open FS.S
in flags[irusr, iwusr, irgrp, iwgrp, iroth, iwoth]
end
in
fun openOut path =3D
(newOut(FS.creat(path, readWrite)))
handle exn =3D> raise IO.Io{name =3D "<unimplemented>",
function =3D "openOut",
cause =3D exn}
=20
fun openAppend path =3D
(newOut(FS.createf(path, FS.O_WRONLY, FS.O.append, readWrite)))
handle exn =3D> raise IO.Io{name =3D "<unimplemented>",
function =3D "openAppend",
cause =3D exn}
end
=20
fun output(out as ref(Out{fd, closed, bufStyle, ...}), v): unit =
=3D
let
in if !closed
then raise IO.Io{name =3D "<unimplemented>",
function =3D "output1",
cause =3D IO.ClosedStream}
else
let
val vecSize =3D Vector.length v
fun store(b as Buf{size, array}) =3D
let
val curSize =3D !size
val newSize =3D vecSize + curSize
in
if newSize > bufSize
then
let
(* flush the current buffer + a prefix of the
* vector, if the current buffer is empty
*)
val veci =3D
if curSize =3D 0
then 0
else
let val fill =3D bufSize - curSize
in Array.copyVec{src =3D v,
si =3D 0,
len =3D SOME fill,
dst =3D array,
di =3D curSize} ;
size :=3D bufSize ;
flush(fd, b) ;
fill
end
(* flush out as much of the vector as needed
* so that <=3D bufSize remains
*)
fun loop i =3D
let val remaining =3D vecSize - i
in if remaining <=3D bufSize
then
(Array.copyVec{src =3D v,
si =3D i,
len =3D SOME remaining,
dst =3D array,
di =3D 0} ;
size :=3D remaining)
else
(flushGen(fd, v, i, bufSize, PIO.writeVec);
loop(i + bufSize))
end
in loop veci
end
else (Array.copyVec{src =3D v, si =3D 0, len =3D NONE,
dst =3D array, di =3D curSize} ;
size :=3D newSize)
end
in case bufStyle of
Unbuffered =3D> flushGen(fd, v, 0, vecSize, PIO.writeVec)
| Line b =3D> (store b)
| Buffered b =3D> store b
end handle exn =3D> raise IO.Io{name =3D "<unimplemented>",
function =3D "output1",
cause =3D exn}
end
=20
fun output1(out, c: elem): unit =3D output(out, str c)
=20
(*---------------------------------------------------*)
(* instream *)
(*---------------------------------------------------*)
datatype instream =3D
In of {fd: FS.file_desc,
closed: bool ref,
eof: bool ref,
first: int ref, (* index of first character *)
last: int ref, (* one past the index of the last char *)
buf: Array.array}
fun newIn fd =3D In{fd =3D fd,
eof =3D ref false,
closed =3D ref false,
first =3D ref 0,
last =3D ref 0,
buf =3D Array.array(bufSize, 0w0)}
fun openIn path =3D
newIn(FS.openf(path, FS.O_RDONLY, FS.O.flags[]))
handle exn =3D> raise IO.Io{name =3D "<unimplemented>",
function =3D "openIn",
cause =3D exn}
fun updateIn(In{fd, closed, eof, first, last, buf, ...}): unit =
=3D
if !closed
then raise IO.Io{name =3D "<unimplemented>",
function =3D "<unknown>",
cause =3D IO.ClosedStream}
else if !eof
then ()
else=20
if !first =3D !last
then (* need to read *)
let
val bytesRead =3D
PIO.readArr(fd, {buf =3D buf, i =3D 0, sz =3D NONE})
in if bytesRead =3D 0
then eof :=3D true
else (first :=3D 0; last :=3D bytesRead)
end
else ()
val empty =3D Word8Vector.tabulate (0, fn _ =3D> 0w0)
=20
fun input(ins as In{eof, buf, first, last, ...}): vector =3D
(updateIn ins
; if !eof
then (eof :=3D false; empty)
else
(
(Array.extract(buf, !first, SOME(!last - !first)))
before first :=3D !last))
handle exn =3D> raise IO.Io{name =3D "<unimplemented>",
function =3D "input",
cause =3D exn}
fun lookahead(ins as In{eof, buf, first, ...}): elem option =3D
(if !eof
then NONE
else (updateIn ins
; if !eof
then NONE
else SOME((Array.sub(buf, !first)))))
handle exn =3D> raise IO.Io{name =3D "<unimplemented>",
function =3D "lookahead",
cause =3D exn}
fun input1(ins as In{buf, first, ...}): elem option =3D
(case lookahead ins of
NONE =3D> NONE
| res as SOME _ =3D> (first :=3D 1 + !first;
res))
handle exn =3D> raise IO.Io{name =3D "<unimplemented>",
function =3D "input1",
cause =3D exn}
fun inputN(ins as In{fd, eof, first, last, buf, ...},
bytesToRead: int): vector =3D
(if Int.geu(bytesToRead, Array.maxLen)
then raise Size
else
if !eof
then (eof :=3D false; empty)
else
let val size =3D !last - !first
in if size >=3D bytesToRead
then (
(Array.extract(buf, !first, SOME bytesToRead))
before first :=3D bytesToRead + !first)
else
let val dst =3D Array.array(bytesToRead, 0w0)
val _ =3D
(Array.copy{src =3D buf, si =3D !first, len =3D SOME size,
dst =3D dst, di =3D 0} ;
first :=3D !last)
fun loop(bytesRead: int): int =3D
if bytesRead =3D bytesToRead
then bytesRead
else let
val bytesRead' =3D
PIO.readArr
(fd, {buf =3D dst, i =3D bytesRead,
sz =3D SOME(bytesToRead - bytesRead)})
in if bytesRead' =3D 0
then (eof :=3D true ;
bytesRead)
else loop(bytesRead + bytesRead')
end
val bytesRead =3D loop size
in if bytesRead =3D bytesToRead
then
(Primitive.Vector.fromArray dst)
else (
(Array.extract(dst, 0, SOME bytesRead)))
end
end)
handle exn =3D> raise IO.Io{name =3D "<unimplemented>",
function =3D "inputN",
cause =3D exn}
fun inputAll(ins as In{fd, eof, first, last, buf, ...}) =3D
if !eof
then (eof :=3D false; empty)
else
(let val vs =3D [Array.extract(buf, !first, SOME(!last - !first))]
fun loop vs =3D
let val v =3D PIO.readVec(fd, bufSize)
in if Vector.length v =3D 0
then (Vector.concat(rev vs))
else loop(v :: vs)
end
in loop vs
end)
handle exn =3D> raise IO.Io{name =3D "<unimplemented>",
function =3D "inputN",
cause =3D exn}
(* not entirely correct - really needs to do non blocking =
lookahead *)
fun canInput(ins as In{eof, first, last, ...}, n) =3D
(updateIn ins
; if !eof
then SOME 0
else SOME(Int.min(n, !last - !first)))
fun closeIn(In{fd, closed, ...}) =3D
(PIO.close fd; closed :=3D true)
=20
fun endOfStream(ins as In{eof, ...}) =3D
!eof orelse (updateIn ins; !eof)
(* This is all just a hack so that I can emulate scanStream *)
structure StreamIO =3D
struct
type outstream =3D outstream'
datatype state =3D
Uneval of instream
| Eval of (char * lazy) option
withtype lazy =3D state ref
type instream =3D lazy
(*
fun make ins =3D ref(Uneval ins)
fun input1' r =3D
case !r of
Eval v =3D> v
| Uneval ins =3D> let val v =3D (case input1 ins of
NONE =3D> NONE
| SOME c =3D> SOME(c, make ins))
in r :=3D Eval v; v
end
val input1 =3D input1'*)
end
(*
fun scanStream f ins =3D
case f StreamIO.input1 (StreamIO.make ins) of
NONE =3D> NONE
| SOME(v, _) =3D> SOME v *)
end
(*
structure TextIOGlobal: TEXT_IO_GLOBAL =3D TextIO
open TextIO
*)
------_=_NextPart_000_01BF2FA9.161782A2
Content-Type: application/x-unknown-content-type-ProjectBuilder.h;
name="mlton-posix.h"
Content-Transfer-Encoding: quoted-printable
Content-Disposition: attachment;
filename="mlton-posix.h"
/* Copyright (C) 1997-1999 NEC Research Institute.
* Please see the file LICENSE for license information.
*/
#ifndef _MLTON_POSIX_H
#define _MLTON_POSIX_H
#if defined(_WIN32)
// Of course Windows does not provide the Unix-style file permissions
#define S_IRGRP 0
#define S_IWGRP 0
#define S_IROTH 0
#define S_IWOTH 0
#endif
#include "mlton-lib.h"
#define MLTON_errno() errno
#define MLTON_clearErrno() errno =3D 0
#if defined(_WIN32)
extern char **environ;
#else
extern char **environ;
#endif
void MLTON_init_posix();
/* ------------------------------------------------- */
/* Error */
/* ------------------------------------------------- */
#define MLTON_strerror(n) ((cpointer)(strerror(n)))
#ifndef ECANCELED
#define ECANCELED 0
#endif
#ifndef ENOTSUP
#define ENOTSUP 0
#endif
/* ------------------------------------------------- */
/* FileSys */
/* ------------------------------------------------- */
#define MLTON_opendir(p) ((cpointer)(opendir((char*)(p))))
#define MLTON_readdir(d) ((cpointer)(readdir((DIR*)(d))))
#define MLTON_rewinddir(p) ((void)(rewinddir((DIR*)(p))))
#define MLTON_closedir(p) ((int)(closedir((DIR*)(p))))
#define MLTON_dirent_name(d) ((cpointer)(((struct =
dirent*)(d))->d_name))
#define MLTON_fstat(f,s) ((int)(fstat((f), (struct stat*)(s))))
#define MLTON_lstat(f,s) ((int)(lstat((char*)(f), (struct stat*)(s))))
#define MLTON_stat(f,s) ((int)(stat((char*)(f), (struct stat*)(s))))
extern struct stat MLTON_stat;
#define MLTON_stat_dev(p) ((uint)(((struct stat*)(p))->st_dev))
#define MLTON_stat_ino(p) ((int)(((struct stat*)(p))->st_ino))
#define MLTON_stat_mode(p) ((uint)(((struct stat*)(p))->st_mode))
#define MLTON_stat_nlink(p) ((int)(((struct stat*)(p))->st_nlink))
#define MLTON_stat_uid(p) ((uint)(((struct stat*)(p))->st_uid))
#define MLTON_stat_gid(p) ((uint)(((struct stat*)(p))->st_gid))
#define MLTON_stat_rdev(p) ((uint)(((struct stat*)(p))->st_rdev))
#define MLTON_stat_size(p) ((int)(((struct stat*)(p))->st_size))
#define MLTON_stat_atime(p) ((int)(((struct stat*)(p))->st_atime))
#define MLTON_stat_mtime(p) ((int)(((struct stat*)(p))->st_mtime))
#define MLTON_stat_ctime(p) ((int)(((struct stat*)(p))->st_ctime))
#define MLTON_utime(s,u) ((int)(utime((char*)(s), (struct =
utimbuf*)(u))))
extern struct utimbuf MLTON_utimbuf;
#define MLTON_set_utimbuf_actime(p,x) (((struct utimbuf*)(p))->actime) =
=3D (x)
#define MLTON_set_utimbuf_modtime(p,x) (((struct =
utimbuf*)(p))->modtime) =3D (x)
#define MLTON_access(f,w) ((int)(access((char*)(f), (w))))
#define MLTON_chdir(p) ((int)(chdir((char*)(p))))
#define MLTON_chmod(p,m) ((int)(chmod((char*)(p), (m))))
#define MLTON_getcwd(buf,n) ((cpointer)(getcwd((buf),(n))))
#define MLTON_link(p1,p2) ((int)(link((char*)(p1), (char*)(p2))))
#define MLTON_mkdir(p,w) ((int)(mkdir((char*)(p), (w))))
#define MLTON_mkfifo(p,w) ((int)(mkfifo((char*)(p), (w))))
#define MLTON_open(p,w,m) ((int)(open((char*)(p), (w), (m))))
#define MLTON_pathconf(p,n) ((int)(pathconf((char*)(p), (n))))
#define MLTON_readlink(p,b,n) ((int)(readlink((char*)(p), (b), (n))))
#define MLTON_rename(p1,p2) ((int)(rename((char*)(p1), (char*)(p2))))
#define MLTON_rmdir(p) ((int)(rmdir((char*)(p))))
#define MLTON_symlink(p1,p2) ((int)(symlink((char*)(p1), (char*)(p2))))
#define MLTON_unlink(p) ((int)(unlink((char*)(p))))
/* ------------------------------------------------- */
/* IO */
/* ------------------------------------------------- */
#define MLTON_read(fd, b, i, s) ((int)(read((fd), (void*)((char*)(b) + =
(i)), (s))))
#define MLTON_write(fd, b, i, s) ((int)(write((fd), (void*)((char*)(b) =
+ (i)), (s))))
#define MLTON_pipe(p) ((int)(pipe((int*)(p))))
#if defined(_WIN32)
#else
extern struct flock MLTON_flock;
#define MLTON_flock_type(p) ((int)(((struct flock*)(p))->l_type))
#define MLTON_flock_whence(p) ((int)(((struct flock*)(p))->l_whence))
#define MLTON_flock_start(p) ((int)(((struct flock*)(p))->l_start))
#define MLTON_flock_len(p) ((int)(((struct flock*)(p))->l_len))
#define MLTON_flock_pid(p) ((int)(((struct flock*)(p))->l_pid))
#define MLTON_set_flock_type(p,x) (((struct flock*)(p))->l_type) =3D =
(x)
#define MLTON_set_flock_whence(p,x) (((struct flock*)(p))->l_whence) =
=3D (x)
#define MLTON_set_flock_start(p,x) (((struct flock*)(p))->l_start) =3D =
(x)
#define MLTON_set_flock_len(p,x) (((struct flock*)(p))->l_len) =3D (x)
#define MLTON_set_flock_pid(p,x) (((struct flock*)(p))->l_pid) =3D (x)
#endif
/* ------------------------------------------------- */
/* ProcEnv */
/* ------------------------------------------------- */
extern pointer MLTON_environ;
#if defined(_WIN32)
#else
#define MLTON_times(t) ((int)(times((struct tms*)(t))))
extern struct tms MLTON_tms;
#define MLTON_tms_utime(p) ((int)(((struct tms*)(p))->tms_utime))
#define MLTON_tms_stime(p) ((int)(((struct tms*)(p))->tms_stime))
#define MLTON_tms_cutime(p) ((int)(((struct tms*)(p))->tms_cutime))
#define MLTON_tms_cstime(p) ((int)(((struct tms*)(p))->tms_cstime))
extern struct utsname MLTON_utsname;
#define MLTON_uname(u) uname((struct utsname*)(u))
#define MLTON_uname_sysname(p) ((cpointer)(((struct =
utsname*)(p))->sysname))
#define MLTON_uname_nodename(p) ((cpointer)(((struct =
utsname*)(p))->nodename))
#define MLTON_uname_release(p) ((cpointer)(((struct =
utsname*)(p))->release))
#define MLTON_uname_version(p) ((cpointer)(((struct =
utsname*)(p))->version))
#define MLTON_uname_machine(p) ((cpointer)(((struct =
utsname*)(p))->machine))
#endif
#define MLTON_numgroups 100
int MLTON_getgroups(pointer groups);
#define MLTON_getlogin() ((cpointer)(getlogin()))
#define MLTON_ctermid() ((cpointer)ctermid((string)NULL))
#define MLTON_getenv(s) ((cpointer)getenv((string)(s)))
#define MLTON_ttyname(fd) ((cpointer)ttyname(fd))
/* ------------------------------------------------- */
/* Process */
/* ------------------------------------------------- */
#define MLTON_waitpid(pid, status, options) ((int)(waitpid((pid), =
(int*)(status), (options))))
int MLTON_exec(pointer path, pointer args);
int MLTON_exece(pointer path, pointer args, pointer env);
int MLTON_execp(pointer file, pointer args);
/* ------------------------------------------------- */
/* SysDB */
/* ------------------------------------------------- */
#define MLTON_getpwnam(p) ((cpointer)(getpwnam((char*)(p))))
#define MLTON_getpwuid(u) ((cpointer)(getpwuid((uid_t)(u))))
#define MLTON_passwd_name(p) ((cpointer)(((struct =
passwd*)(p))->pw_name))
#define MLTON_passwd_uid(p) ((uint)(((struct passwd*)(p))->pw_uid))
#define MLTON_passwd_gid(p) ((uint)(((struct passwd*)(p))->pw_gid))
#define MLTON_passwd_dir(p) ((cpointer)(((struct passwd*)(p))->pw_dir))
#define MLTON_passwd_shell(p) ((cpointer)(((struct =
passwd*)(p))->pw_shell))
#define MLTON_getgrgid(g) ((cpointer)(getgrgid((gid_t)(g))))
#define MLTON_getgrnam(s) ((cpointer)(getgrnam((char*)(s))))
#define MLTON_group_name(p) ((cpointer)(((struct group*)(p))->gr_name))
#define MLTON_group_gid(p) ((uint)(((struct group*)(p))->gr_gid))
#define MLTON_group_mem(p) ((cpointer)(((struct group*)(p))->gr_mem))
/* ------------------------------------------------- */
/* TTY */
/* ------------------------------------------------- */
#if defined(_WIN32)
#else
extern struct termios MLTON_termios;
#define MLTON_termios_iflag(t) ((uint)(((struct =
termios*)(t))->c_iflag))
#define MLTON_termios_oflag(t) ((uint)(((struct =
termios*)(t))->c_oflag))
#define MLTON_termios_cflag(t) ((uint)(((struct =
termios*)(t))->c_cflag))
#define MLTON_termios_lflag(t) ((uint)(((struct =
termios*)(t))->c_lflag))
#define MLTON_termios_cc(t) ((cpointer)(((struct termios*)(t))->c_cc))
#define MLTON_set_termios_iflag(t,x) (((struct termios*)(t))->c_iflag) =
=3D (x)
#define MLTON_set_termios_oflag(t,x) (((struct termios*)(t))->c_oflag) =
=3D (x)
#define MLTON_set_termios_cflag(t,x) (((struct termios*)(t))->c_cflag) =
=3D (x)
#define MLTON_set_termios_lflag(t,x) (((struct termios*)(t))->c_lflag) =
=3D (x)
#define MLTON_tcgetattr(f,t) ((int)(tcgetattr((f), (struct =
termios*)(t))))
#define MLTON_tcsetattr(f,a,t) ((int)(tcsetattr((f), (a), (struct =
termios*)(t))))
#define MLTON_cfgetospeed(t) ((int)(cfgetospeed((struct termios*)(t))))
#define MLTON_cfsetospeed(t,s) ((int)(cfsetospeed((struct termios*)(t), =
(s))))
#define MLTON_cfgetispeed(t) ((int)(cfgetispeed((struct termios*)(t))))
#define MLTON_cfsetispeed(t,s) ((int)(cfsetispeed((struct termios*)(t), =
(s))))
#endif
/* ------------------------------------------------- */
/* Signals */
/* ------------------------------------------------- */
#define MLTON_sigemptyset(s) ((int)(sigemptyset((sigset_t*)(s))))
#define MLTON_sigfillset(s) ((int)(sigfillset((sigset_t*)(s))))
#define MLTON_sigaddset(a,b) ((int)(sigaddset((sigset_t*)(a),(b))))
#define MLTON_sigdelset(a,b) ((int)(sigdelset((sigset_t*)(a),(b))))
#define MLTON_sigismember(a,b) ((int)(sigismember((sigset_t*)(a),(b))))
#define MLTON_sigpending(s) ((int)(sigpending((sigset_t*)(s))))
#define MLTON_sigprocmask(a,b) =
((int)(sigprocmask((a),(sigset_t*)(b),(sigset_t*)NULL)))
#define MLTON_sigsuspend(a) ((int)(sigsuspend((sigset_t*)(a))))
#endif /* #ifndef _MLTON_POSIX_H */
------_=_NextPart_000_01BF2FA9.161782A2--