scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

+ Decigged syscalls, sleep 

+ Modified operations that work on file descriptors to allocate appropriate
  buffered ports.
This commit is contained in:
mainzelm 2001-09-07 16:05:31 +00:00
parent 572c01be18
commit 006c551429
8 changed files with 115 additions and 392 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
Makefile.in
View File

@ -118,7 +118,6 @@ SCSHOBJS = \
scsh/dirstuff1.o \ scsh/dirstuff1.o \
scsh/fdports1.o \ scsh/fdports1.o \
scsh/flock1.o \ scsh/flock1.o \
scsh/machine/stdio_dep.o \
scsh/machine/time_dep1.o \ scsh/machine/time_dep1.o \
scsh/signals1.o \ scsh/signals1.o \
scsh/machine/libansi.o \ scsh/machine/libansi.o \
@ -127,16 +126,17 @@ SCSHOBJS = \
scsh/rx/regexp1.o \ scsh/rx/regexp1.o \
scsh/select.o scsh/select1.o \ scsh/select.o scsh/select1.o \
scsh/sleep1.o \ scsh/sleep1.o \
scsh/syscalls.o scsh/syscalls1.o \ scsh/syscalls1.o \
scsh/syslog1.o \ scsh/syslog1.o \
scsh/time.o scsh/time1.o \ scsh/time1.o \
scsh/tty.o scsh/tty1.o \ scsh/tty1.o \
scsh/userinfo1.o \ scsh/userinfo1.o \
scsh/sighandlers1.o scsh/sighandlers1.o
SCSH_INITIALIZERS = s48_init_syslog s48_init_posix_regexp \ SCSH_INITIALIZERS = s48_init_syslog s48_init_posix_regexp \
s48_init_userinfo s48_init_sighandlers \ s48_init_userinfo s48_init_sighandlers \
s48_init_syscalls2 s48_init_network s48_init_flock s48_init_syscalls s48_init_network s48_init_flock \
s48_init_dirstuff s48_init_time s48_init_tty
UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o
@ -161,8 +161,7 @@ enough: $(VM) $(IMAGE) go $(LIBCIG) scsh $(LIBSCSH) $(LIBSCSHVM)
# Files generated by cig need their init functions called. # Files generated by cig need their init functions called.
CIGGEDINIT = s48_init_select \ CIGGEDINIT = s48_init_select
s48_init_syscalls s48_init_tty s48_init_time
# -------------------- # --------------------
# External code to include in the VM # External code to include in the VM
@ -229,15 +228,9 @@ scsh/flock1.o: scsh/flock1.h
scsh/fdports1.o scsh/fdports.o: scsh/fdports1.h scsh/fdports1.o scsh/fdports.o: scsh/fdports1.h
scsh/select1.o scsh/select.o: scsh/select1.h scsh/select1.o scsh/select.o: scsh/select1.h
scsh/syscalls1.o scsh/syscalls.o: scsh/syscalls1.h
scsh/time1.o scsh/time.o: scsh/time1.h
scsh/tty1.o scsh/tty.o: scsh/tty1.h
scsh/rx/regexp1.o: c/scheme48.h scsh/rx/regexp1.o: c/scheme48.h
scsh/syscalls.o: scsh/syscalls1.h scsh/dirstuff1.h scsh/fdports1.h \
scsh/select1.h scsh/userinfo1.h
scsh/sighandlers1.o: scsh/sighandlers1.h scsh/sighandlers1.o: scsh/sighandlers1.h
scsh/syslog1.o: c/scheme48.h scsh/syslog1.o: c/scheme48.h
@ -417,7 +410,7 @@ clean-cig:
-rm -f cig/*.o $(CIG) $(CIG).image $(LIBCIG) -rm -f cig/*.o $(CIG) $(CIG).image $(LIBCIG)
clean-scm2c: clean-scm2c:
rm -f scsh/select.c scsh/syscalls.c scsh/tty.c scsh/time.c rm -f scsh/select.c
distclean: clean distclean: clean
rm -f Makefile config.log config.status c/sysdep.h config.cache \ rm -f Makefile config.log config.status c/sysdep.h config.cache \
@ -786,9 +779,6 @@ SCHEME =scsh/awk.scm \
cig/libcig.c: cig/libcig.scm cig/libcig.c: cig/libcig.scm
scsh/jcontrol2.c: scsh/jcontrol2.scm scsh/jcontrol2.c: scsh/jcontrol2.scm
scsh/select.c: scsh/select.scm scsh/select.c: scsh/select.scm
scsh/syscalls.c: scsh/syscalls.scm
scsh/tty.c: scsh/tty.scm
scsh/time.c: scsh/time.scm
scsh/scsh: scsh/scsh-tramp.c scsh/scsh: scsh/scsh-tramp.c
$(CC) -o $@ $(CPPFLAGS) $(CFLAGS) \ $(CC) -o $@ $(CPPFLAGS) $(CFLAGS) \

26
scsh/newports.scm
View File

@ -395,9 +395,17 @@
p)) p))
(else (port-maker fd 1)))) (else (port-maker fd 1))))
(define (fdes->inport fd) (fdes->port fd make-input-fdport)) (define (fdes->inport fd)
(let ((port (fdes->port fd make-input-fdport)))
(if (not (input-port? port))
(error "fdes was already assigned to an outport" fd)
port)))
(define (fdes->outport fd) (fdes->port fd make-output-fdport)) (define (fdes->outport fd)
(let ((port (fdes->port fd make-output-fdport)))
(if (not (output-port? port))
(error "fdes was already assigned to an inport" fd)
port)))
(define (port->fdes port) (define (port->fdes port)
(check-arg open-fdport? port port->fdes) (check-arg open-fdport? port port->fdes)
@ -551,7 +559,9 @@
(%char-ready-fdes? input)) (%char-ready-fdes? input))
(define-r4rs-input (read-char) input s48-read-char (define-r4rs-input (read-char) input s48-read-char
(read-fdes-char input)) (let ((port (fdes->inport input)))
(set-port-buffering port bufpol/none)
(s48-read-char port)))
;structure refs changed to get reference from scheme -dalbertz ;structure refs changed to get reference from scheme -dalbertz
(define s48-display (structure-ref scheme display)) (define s48-display (structure-ref scheme display))
@ -567,7 +577,7 @@
(let ((stream (:optional maybe-i/o (current-output-port)))) (let ((stream (:optional maybe-i/o (current-output-port))))
(cond ((output-port? stream) (s48name arg ... stream)) (cond ((output-port? stream) (s48name arg ... stream))
((integer? stream) body ...) ((integer? stream) body ...)
(else (error "Not a port or file descriptor" stream)))))) (else (error "Not a outport or file descriptor" stream))))))
;;; This one depends upon S48's string ports. ;;; This one depends upon S48's string ports.
(define-r4rs-output (display object) output s48-display (define-r4rs-output (display object) output s48-display
@ -576,7 +586,9 @@
(write-string (string-output-port-output sp) output))) (write-string (string-output-port-output sp) output)))
(define-r4rs-output (newline) output s48-newline (define-r4rs-output (newline) output s48-newline
(write-fdes-char #\newline output)) (let ((port (fdes->outport output)))
(set-port-buffering port bufpol/none)
(s48-newline port)))
(define-r4rs-output (write object) output s48-write (define-r4rs-output (write object) output s48-write
(let ((sp (make-string-output-port))) (let ((sp (make-string-output-port)))
@ -584,7 +596,9 @@
(write-string (string-output-port-output sp) output))) (write-string (string-output-port-output sp) output)))
(define-r4rs-output (write-char char) output s48-write-char (define-r4rs-output (write-char char) output s48-write-char
(write-fdes-char char output)) (let ((port (fdes->outport output)))
(set-port-buffering port bufpol/none)
(s48-write-char char port)))
;;; S48's force-output doesn't default to forcing (current-output-port). ;;; S48's force-output doesn't default to forcing (current-output-port).
(define-r4rs-output (force-output) output s48-force-output (define-r4rs-output (force-output) output s48-force-output

81
scsh/rw.scm
View File

@ -12,27 +12,15 @@
;;; Best-effort/forward-progress reading ;;; Best-effort/forward-progress reading
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (generic-read-string!/partial s start end reader source)
(if (bogus-substring-spec? s start end)
(error "Bad substring indices" reader source s start end))
(if (= start end) 0 ; Vacuous request.
(let loop ()
(receive (err nread) (reader s start end source)
(cond ((not err) (and (not (zero? nread)) nread))
((= err errno/intr) (loop))
((or (= err errno/wouldblock) ; No forward-progess here.
(= err errno/again))
0)
(else (errno-error err reader s start start end source)))))))
(define (read-string!/partial s . args) (define (read-string!/partial s . args)
(let-optionals args ((fd/port (current-input-port)) (let-optionals args ((fd/port (current-input-port))
(start 0) (start 0)
(end (string-length s))) (end (string-length s)))
(cond ((integer? fd/port) (cond ((integer? fd/port)
(generic-read-string!/partial s start end (let ((port (fdes->inport fd/port)))
read-fdes-substring!/errno fd/port)) (set-port-buffering port bufpol/block (max (- end start) 0))
(read-string!/partial port start end)))
(else ; no differnce between fd/ports and s48 ports (else ; no differnce between fd/ports and s48 ports
(let* ((buffer (make-string (- end start))) (let* ((buffer (make-string (- end start)))
(needed (if (> (byte-vector-length (port-buffer fd/port)) 1) (needed (if (> (byte-vector-length (port-buffer fd/port)) 1)
@ -59,31 +47,14 @@
;;; ;;;
;;; Operation on ports is easy, since we can use read-block ;;; Operation on ports is easy, since we can use read-block
(define (generic-read-string! s start end reader source)
(if (bogus-substring-spec? s start end)
(error "Bad substring indices" reader source s start end))
(let loop ((i start))
(if (>= i end) (- i start)
(receive (err nread) (reader s i end source)
(cond (err (if (= err errno/intr) (loop i)
;; Give info on partially-read data in error packet.
(errno-error err reader
s start i end source)))
((zero? nread) ; EOF
(let ((result (- i start)))
(and (not (zero? result)) result)))
(else (loop (+ i nread))))))))
(define (read-string! s . args) (define (read-string! s . args)
(let-optionals args ((fd/port (current-input-port)) (let-optionals args ((fd/port (current-input-port))
(start 0) (start 0)
(end (string-length s))) (end (string-length s)))
(cond ((integer? fd/port) (cond ((integer? fd/port)
(generic-read-string! s start end (let ((port (fdes->inport fd/port)))
read-fdes-substring!/errno fd/port)) (set-port-buffering port bufpol/block (max (- end start) 0))
(read-string! port start end)))
(else ; no differnce between fd/port and s48 ports (else ; no differnce between fd/port and s48 ports
(let ((nbytes/eof (read-block s start (- end start) fd/port))) (let ((nbytes/eof (read-block s start (- end start) fd/port)))
@ -104,53 +75,31 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Non-blocking output to a buffered port is not defined. ;;; Non-blocking output to a buffered port is not defined.
(define (generic-write-string/partial s start end writer target)
(if (bogus-substring-spec? s start end)
(error "Bad substring indices" writer s start end target))
(if (= start end) 0 ; Vacuous request.
(let loop ()
(receive (err nwritten) (writer s start end target)
(cond ((not err) nwritten)
((= err errno/intr) (loop))
((or (= err errno/again) (= err errno/wouldblock)) 0)
(else (errno-error err writer
s start start end target)))))))
(define (write-string/partial s . args) (define (write-string/partial s . args)
(let-optionals args ((fd/port (current-output-port)) (let-optionals args ((fd/port (current-output-port))
(start 0) (start 0)
(end (string-length s))) (end (string-length s)))
(cond ((integer? fd/port) (cond ((integer? fd/port)
(generic-write-string/partial s start end (let ((port (fdes->outport fd/port)))
write-fdes-substring/errno fd/port)) (set-port-buffering port bufpol/block (max (- end start) 0))
(write-string/partial s port start end)))
(else (else
;; the only way to implement this, would be to use ;; the only way to implement this, would be to use
;; channel-maybe-write. But this is an VM-instruction which is not ;; channel-maybe-write. But this is an VM-instruction which is not
;; exported. Since we now have threads this shouldn;t matter. ;; exported. Since we now have threads this shouldn;t matter.
(error "write-string/parital is no longer supported on ports"))))) (error "write-string/parital is currently dereleased.
See the RELEASE file for details")))))
;;; Persistent writing ;;; Persistent writing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (generic-write-string s start end writer target)
(if (bogus-substring-spec? s start end)
(error "Bad substring indices" writer s start end target))
(let loop ((i start))
(if (< i end)
(receive (err nwritten) (writer s i end target)
(cond ((not err) (loop (+ i nwritten)))
((= err errno/intr) (loop i))
(else (errno-error err writer
s start i end target)))))))
(define (write-string s . args) (define (write-string s . args)
(let-optionals args ((fd/port (current-output-port)) (let-optionals args ((fd/port (current-output-port))
(start 0) (start 0)
(end (string-length s))) (end (string-length s)))
(cond ((integer? fd/port) (cond ((integer? fd/port)
(generic-write-string s start end (let ((port (fdes->outport fd/port)))
write-fdes-substring/errno fd/port)) (set-port-buffering port bufpol/block (max (- end start) 0))
(write-string s port start end)))
(else (write-block s start (- end start) fd/port))))) (else (write-block s start (- end start) fd/port)))))

4
scsh/sleep1.c
View File

@ -24,10 +24,10 @@
** and is pretty straightforward. ** and is pretty straightforward.
*/ */
s48_value sleep_until(time_t when) s48_value sleep_until(s48_value scm_when)
{ {
time_t now = time(0); time_t now = time(0);
int delta = when - now; int delta = s48_extract_integer(scm_when) - now;
if( delta > 0 ) { if( delta > 0 ) {
fd_set r, w, e; fd_set r, w, e;
struct timeval tv; struct timeval tv;

201
scsh/syscalls.c
View File

@ -1,201 +0,0 @@
/* This is an Scheme48/C interface file,
** automatically generated by a hacked version of cig 3.0.
step 4
*/
#include <stdio.h>
#include <stdlib.h> /* For malloc. */
#include "libcig.h"
#include <sys/signal.h>
#include <sys/types.h>
#include <sys/times.h>
#include <sys/time.h>
#include <fcntl.h> /* for O_RDWR */
#include <sys/stat.h>
#include <netdb.h>
#include <pwd.h>
#include <unistd.h>
/* Make sure foreign-function stubs interface to the C funs correctly: */
#include "dirstuff1.h"
#include "select1.h"
#include "syscalls1.h"
#include "userinfo1.h"
extern int errno;
#define errno_on_zero_or_false(x) ((x) ? S48_FALSE : s48_enter_fixnum(errno))
#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)
#define False_on_zero(x) ((x) ? s48_enter_fixnum(x) : S48_FALSE)
s48_value df_char_ready_fdes(s48_value g1)
{
extern s48_value char_ready_fdes(int );
s48_value ret1 = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
s48_value r1;
S48_GC_PROTECT_1(ret1);
r1 = char_ready_fdes(s48_extract_fixnum(g1));
ret1 = r1;
S48_GC_UNPROTECT();
return ret1;
}
s48_value df_read_fdes_char(s48_value g1)
{
extern s48_value read_fdes_char(int );
s48_value ret1 = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
s48_value r1;
S48_GC_PROTECT_1(ret1);
r1 = read_fdes_char(s48_extract_fixnum(g1));
ret1 = r1;
S48_GC_UNPROTECT();
return ret1;
}
s48_value df_write_fdes_char(s48_value g1, s48_value g2)
{
extern int write_fdes_char(char , int );
s48_value ret1 = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
int r1;
S48_GC_PROTECT_1(ret1);
r1 = write_fdes_char(s48_extract_char(g1), s48_extract_fixnum(g2));
ret1 = errno_or_false(r1);
S48_GC_UNPROTECT();
return ret1;
}
s48_value df_read_fdes_substring(s48_value g1, s48_value g2, s48_value g3, s48_value g4, s48_value mv_vec)
{
extern ssize_t read_fdes_substring(s48_value , size_t , size_t , int );
s48_value ret1 = S48_FALSE;
S48_DECLARE_GC_PROTECT(2);
ssize_t r1;
S48_GC_PROTECT_2(mv_vec,ret1);
r1 = read_fdes_substring(g1, s48_extract_fixnum(g2), s48_extract_fixnum(g3), s48_extract_fixnum(g4));
ret1 = errno_or_false(r1);
S48_VECTOR_SET(mv_vec,0,s48_enter_fixnum(r1));
S48_GC_UNPROTECT();
return ret1;
}
s48_value df_write_fdes_substring(s48_value g1, s48_value g2, s48_value g3, s48_value g4, s48_value mv_vec)
{
extern ssize_t write_fdes_substring(s48_value , size_t , size_t , int );
s48_value ret1 = S48_FALSE;
S48_DECLARE_GC_PROTECT(2);
ssize_t r1;
S48_GC_PROTECT_2(mv_vec,ret1);
r1 = write_fdes_substring(g1, s48_extract_fixnum(g2), s48_extract_fixnum(g3), s48_extract_fixnum(g4));
ret1 = errno_or_false(r1);
S48_VECTOR_SET(mv_vec,0,s48_enter_fixnum(r1));
S48_GC_UNPROTECT();
return ret1;
}
s48_value df_sleep_until(s48_value g1)
{
extern s48_value sleep_until(time_t );
s48_value ret1 = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
s48_value r1;
S48_GC_PROTECT_1(ret1);
r1 = sleep_until(s48_extract_integer(g1));
ret1 = r1;
S48_GC_UNPROTECT();
return ret1;
}
void s48_init_syscalls(void)
{
S48_EXPORT_FUNCTION(scheme_exec);
S48_EXPORT_FUNCTION(scsh_exit);
S48_EXPORT_FUNCTION(scsh__exit);
S48_EXPORT_FUNCTION(scsh_fork);
S48_EXPORT_FUNCTION(wait_pid);
S48_EXPORT_FUNCTION(scsh_chdir);
S48_EXPORT_FUNCTION(scheme_cwd);
S48_EXPORT_FUNCTION(scsh_getgid);
S48_EXPORT_FUNCTION(scsh_getegid);
S48_EXPORT_FUNCTION(scsh_setgid);
S48_EXPORT_FUNCTION(scsh_setegid);
S48_EXPORT_FUNCTION(get_groups);
S48_EXPORT_FUNCTION(scsh_getuid);
S48_EXPORT_FUNCTION(scsh_geteuid);
S48_EXPORT_FUNCTION(scsh_setuid);
S48_EXPORT_FUNCTION(scsh_seteuid);
S48_EXPORT_FUNCTION(scsh_getpid);
S48_EXPORT_FUNCTION(scsh_getppid);
S48_EXPORT_FUNCTION(scsh_getpgrp);
S48_EXPORT_FUNCTION(setpgid);
S48_EXPORT_FUNCTION(scsh_setsid);
S48_EXPORT_FUNCTION(scsh_umask);
S48_EXPORT_FUNCTION(process_times);
S48_EXPORT_FUNCTION(cpu_clock_ticks_per_sec);
S48_EXPORT_FUNCTION(scsh_chmod);
S48_EXPORT_FUNCTION(scsh_fchmod);
S48_EXPORT_FUNCTION(scsh_chown);
S48_EXPORT_FUNCTION(scsh_fchown);
S48_EXPORT_FUNCTION(scsh_access);
S48_EXPORT_FUNCTION(scsh_link);
S48_EXPORT_FUNCTION(scsh_mkfifo);
S48_EXPORT_FUNCTION(scsh_mkdir);
S48_EXPORT_FUNCTION(scsh_readlink);
S48_EXPORT_FUNCTION(scsh_rename);
S48_EXPORT_FUNCTION(scsh_rmdir);
S48_EXPORT_FUNCTION(scm_utime);
S48_EXPORT_FUNCTION(scm_utime_now);
S48_EXPORT_FUNCTION(scheme_stat);
S48_EXPORT_FUNCTION(scheme_fstat);
S48_EXPORT_FUNCTION(scsh_symlink);
S48_EXPORT_FUNCTION(scsh_truncate);
S48_EXPORT_FUNCTION(scsh_ftruncate);
S48_EXPORT_FUNCTION(scsh_unlink);
S48_EXPORT_FUNCTION(scsh_fsync);
S48_EXPORT_FUNCTION(scsh_sync);
S48_EXPORT_FUNCTION(scsh_close);
S48_EXPORT_FUNCTION(scsh_dup);
S48_EXPORT_FUNCTION(scsh_dup2);
S48_EXPORT_FUNCTION(scsh_lseek);
S48_EXPORT_FUNCTION(df_char_ready_fdes);
S48_EXPORT_FUNCTION(scsh_open);
S48_EXPORT_FUNCTION(scheme_pipe);
S48_EXPORT_FUNCTION(df_read_fdes_char);
S48_EXPORT_FUNCTION(df_write_fdes_char);
S48_EXPORT_FUNCTION(df_read_fdes_substring);
S48_EXPORT_FUNCTION(df_write_fdes_substring);
S48_EXPORT_FUNCTION(scsh_kill);
S48_EXPORT_FUNCTION(open_dir);
S48_EXPORT_FUNCTION(scm_envvec);
S48_EXPORT_FUNCTION(create_env);
S48_EXPORT_FUNCTION(align_env);
S48_EXPORT_FUNCTION(free_envvec);
S48_EXPORT_FUNCTION(set_cloexec);
S48_EXPORT_FUNCTION(fcntl_read);
S48_EXPORT_FUNCTION(fcntl_write);
S48_EXPORT_FUNCTION(df_sleep_until);
S48_EXPORT_FUNCTION(scm_gethostname);
S48_EXPORT_FUNCTION(errno_msg);
S48_EXPORT_FUNCTION(scm_crypt);
}

67
scsh/syscalls.scm
View File

@ -5,33 +5,6 @@
;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme? ;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme?
(foreign-init-name "syscalls")
(foreign-source
"#include <sys/signal.h>"
"#include <sys/types.h>"
"#include <sys/times.h>"
"#include <sys/time.h>"
"#include <fcntl.h> /* for O_RDWR */" ; ???
"#include <sys/stat.h>"
"#include <netdb.h>"
"#include <pwd.h>"
"#include <unistd.h>"
""
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
"#include \"dirstuff1.h\""
; "#include \"fdports1.h\"" JMG
"#include \"select1.h\""
"#include \"syscalls1.h\""
"#include \"userinfo1.h\""
""
"extern int errno;"
""
"#define errno_on_zero_or_false(x) ((x) ? S48_FALSE : s48_enter_fixnum(errno))"
"#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)"
"#define False_on_zero(x) ((x) ? s48_enter_fixnum(x) : S48_FALSE)" ; Not a function.
"" "")
;;; Macro for converting syscalls that return error codes to ones that ;;; Macro for converting syscalls that return error codes to ones that
;;; raise exceptions on errors. ;;; raise exceptions on errors.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -294,7 +267,6 @@
(define-stubless-foreign %rename-file/eintr (old-name new-name) "scsh_rename") (define-stubless-foreign %rename-file/eintr (old-name new-name) "scsh_rename")
(define-retrying-syscall %rename-file %rename-file/eintr) (define-retrying-syscall %rename-file %rename-file/eintr)
(define-stubless-foreign delete-directory/eintr (path) "scsh_rmdir") (define-stubless-foreign delete-directory/eintr (path) "scsh_rmdir")
(define-retrying-syscall delete-directory delete-directory/eintr) (define-retrying-syscall delete-directory delete-directory/eintr)
@ -464,41 +436,6 @@
(values r w))) (values r w)))
(pipe-fdes))) (pipe-fdes)))
(define-foreign %read-fdes-char
(read_fdes_char (fixnum fd))
desc) ; Char or errno or #f (eof).
(define (read-fdes-char fd)
(let ((c (%read-fdes-char fd)))
(if (integer? c) (errno-error c read-fdes-char fd) c)))
(define-foreign write-fdes-char/errno (write_fdes_char (char char) (fixnum fd))
(to-scheme fixnum errno_or_false))
(define-errno-syscall (write-fdes-char char fd) write-fdes-char/errno)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Read and write
(define-foreign read-fdes-substring!/errno
(read_fdes_substring (string-desc buf)
(size_t start)
(size_t end)
(fixnum fd))
(multi-rep (to-scheme ssize_t errno_or_false)
ssize_t))
(define-foreign write-fdes-substring/errno
(write_fdes_substring (string-desc buf)
(size_t start)
(size_t end)
(fixnum fd))
(multi-rep (to-scheme ssize_t errno_or_false)
ssize_t))
;;; Signals (rather incomplete) ;;; Signals (rather incomplete)
;;; --------------------------- ;;; ---------------------------
@ -791,9 +728,7 @@
(let lp () (let lp ()
(or (%sleep-until when) (lp))))) (or (%sleep-until when) (lp)))))
;;; JMG: I don't know whether time_t or long is correct... (define-stubless-foreign %sleep-until (secs) "sleep_until")
(define-foreign %sleep-until (sleep_until (time_t secs))
desc)
(define-stubless-foreign %gethostname/eintr () "scm_gethostname") (define-stubless-foreign %gethostname/eintr () "scm_gethostname")
(define-retrying-syscall %gethostname %gethostname/eintr) (define-retrying-syscall %gethostname %gethostname/eintr)

99
scsh/syscalls1.c
View File

@ -35,7 +35,6 @@
#include <crypt.h> #include <crypt.h>
#endif #endif
#include "cstuff.h" #include "cstuff.h"
#include "machine/stdio_dep.h"
/* Make sure our exports match up w/the implementation: */ /* Make sure our exports match up w/the implementation: */
#include "syscalls1.h" #include "syscalls1.h"
@ -407,36 +406,6 @@ s48_value scsh_mkdir(s48_value sch_path, s48_value sch_mode)
return S48_UNSPECIFIC; return S48_UNSPECIFIC;
} }
/* Reading and writing
*******************************************************************************
*/
/* Return a char, #f (EOF), or errno. */
s48_value read_fdes_char(int fd)
{
int i; char c;
if( (i=read(fd, &c, 1)) < 0 ) return s48_enter_fixnum(errno);
if(i==0) return S48_FALSE;
return s48_enter_char(c);
}
int write_fdes_char(char c, int fd) {return write(fd, &c, 1);}
ssize_t read_fdes_substring(s48_value buf, size_t start, size_t end, int fd)
{
return read(fd, StrByte(buf,start), end-start);
}
ssize_t write_fdes_substring(s48_value buf, size_t start, size_t end, int fd)
{
return write(fd, StrByte(buf,start), end-start);
}
/* S_ISSOCK(mode) and S_ISLNK(mode) are not POSIX. You lose on a NeXT. Ugh. */ /* S_ISSOCK(mode) and S_ISLNK(mode) are not POSIX. You lose on a NeXT. Ugh. */
#ifndef S_ISSOCK #ifndef S_ISSOCK
#define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK) #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
@ -611,7 +580,7 @@ s48_value char_ready_fdes(s48_value sch_fd)
fd_set readfds; fd_set readfds;
struct timeval timeout; struct timeval timeout;
int result; int result;
int fd = s48_extract_fixnum sch_fd; int fd = s48_extract_fixnum (sch_fd);
FD_ZERO(&readfds); FD_ZERO(&readfds);
FD_SET(fd, &readfds); FD_SET(fd, &readfds);
@ -935,7 +904,71 @@ s48_value scm_crypt(s48_value key, s48_value salt)
return s48_enter_string (ret); return s48_enter_string (ret);
} }
void s48_init_syscalls2(){ void s48_init_syscalls (){
S48_EXPORT_FUNCTION(scheme_exec);
S48_EXPORT_FUNCTION(scsh_exit);
S48_EXPORT_FUNCTION(scsh__exit);
S48_EXPORT_FUNCTION(scsh_fork);
S48_EXPORT_FUNCTION(wait_pid);
S48_EXPORT_FUNCTION(scsh_chdir);
S48_EXPORT_FUNCTION(scheme_cwd);
S48_EXPORT_FUNCTION(scsh_getgid);
S48_EXPORT_FUNCTION(scsh_getegid);
S48_EXPORT_FUNCTION(scsh_setgid);
S48_EXPORT_FUNCTION(scsh_setegid);
S48_EXPORT_FUNCTION(get_groups);
S48_EXPORT_FUNCTION(scsh_getuid);
S48_EXPORT_FUNCTION(scsh_geteuid);
S48_EXPORT_FUNCTION(scsh_setuid);
S48_EXPORT_FUNCTION(scsh_seteuid);
S48_EXPORT_FUNCTION(scsh_getpid);
S48_EXPORT_FUNCTION(scsh_getppid);
S48_EXPORT_FUNCTION(scsh_getpgrp);
S48_EXPORT_FUNCTION(setpgid);
S48_EXPORT_FUNCTION(scsh_setsid);
S48_EXPORT_FUNCTION(scsh_umask);
S48_EXPORT_FUNCTION(process_times);
S48_EXPORT_FUNCTION(cpu_clock_ticks_per_sec);
S48_EXPORT_FUNCTION(scsh_chmod);
S48_EXPORT_FUNCTION(scsh_fchmod);
S48_EXPORT_FUNCTION(scsh_chown);
S48_EXPORT_FUNCTION(scsh_fchown);
S48_EXPORT_FUNCTION(scsh_access);
S48_EXPORT_FUNCTION(scsh_link);
S48_EXPORT_FUNCTION(scsh_mkfifo);
S48_EXPORT_FUNCTION(scsh_mkdir);
S48_EXPORT_FUNCTION(scsh_readlink);
S48_EXPORT_FUNCTION(scsh_rename);
S48_EXPORT_FUNCTION(scsh_rmdir);
S48_EXPORT_FUNCTION(scm_utime);
S48_EXPORT_FUNCTION(scm_utime_now);
S48_EXPORT_FUNCTION(scheme_stat);
S48_EXPORT_FUNCTION(scheme_fstat);
S48_EXPORT_FUNCTION(scsh_symlink);
S48_EXPORT_FUNCTION(scsh_truncate);
S48_EXPORT_FUNCTION(scsh_ftruncate);
S48_EXPORT_FUNCTION(scsh_unlink);
S48_EXPORT_FUNCTION(scsh_fsync);
S48_EXPORT_FUNCTION(scsh_sync);
S48_EXPORT_FUNCTION(scsh_close);
S48_EXPORT_FUNCTION(scsh_dup);
S48_EXPORT_FUNCTION(scsh_dup2);
S48_EXPORT_FUNCTION(scsh_lseek);
S48_EXPORT_FUNCTION(char_ready_fdes);
S48_EXPORT_FUNCTION(scsh_open);
S48_EXPORT_FUNCTION(scheme_pipe);
S48_EXPORT_FUNCTION(scsh_kill);
S48_EXPORT_FUNCTION(scm_envvec);
S48_EXPORT_FUNCTION(create_env);
S48_EXPORT_FUNCTION(align_env);
S48_EXPORT_FUNCTION(free_envvec);
S48_EXPORT_FUNCTION(set_cloexec);
S48_EXPORT_FUNCTION(fcntl_read);
S48_EXPORT_FUNCTION(fcntl_write);
S48_EXPORT_FUNCTION(sleep_until);
S48_EXPORT_FUNCTION(scm_gethostname);
S48_EXPORT_FUNCTION(errno_msg);
S48_EXPORT_FUNCTION(scm_crypt);
S48_GC_PROTECT_GLOBAL(envvec_record_type_binding); S48_GC_PROTECT_GLOBAL(envvec_record_type_binding);
S48_GC_PROTECT_GLOBAL(add_envvec_finalizerB_binding); S48_GC_PROTECT_GLOBAL(add_envvec_finalizerB_binding);
S48_GC_PROTECT_GLOBAL(current_env); S48_GC_PROTECT_GLOBAL(current_env);

3
scsh/syscalls1.h
View File

@ -73,6 +73,8 @@ s48_value scsh_mkfifo(s48_value sch_path, s48_value sch_mode);
s48_value scsh_mkdir(s48_value sch_path, s48_value sch_mode); s48_value scsh_mkdir(s48_value sch_path, s48_value sch_mode);
s48_value char_ready_fdes(s48_value sch_fd);
s48_value read_fdes_char(int fd); s48_value read_fdes_char(int fd);
int write_fdes_char(char c, int fd); int write_fdes_char(char c, int fd);
@ -143,3 +145,4 @@ s48_value scm_syslog (s48_value _facility, s48_value _level, s48_value _message)
s48_value scm_closelog(); s48_value scm_closelog();
s48_value sleep_until();