diff --git a/scsh/syscalls.scm b/scsh/syscalls.scm index 4913ca7..2e36586 100644 --- a/scsh/syscalls.scm +++ b/scsh/syscalls.scm @@ -15,10 +15,22 @@ ;;; You can't throw an error within a handler ;;; -(define-record err - errno - msg - stuff) +;;; Move this to somewhere else as soon as Marc published his SRFI +(define (continuation-capture receiver) + (call-with-current-continuation + (lambda (k) + (receiver (lambda (thunk) + (call-with-values + thunk + k)))))) + +(define (continuation-graft cont thunk) + (cont thunk)) + +(define (continuation-return cont . returned-values) + (continuation-graft + cont + (lambda () (apply values returned-values)))) (define-syntax import-os-error-syscall (syntax-rules () @@ -27,28 +39,27 @@ (import-lambda-definition syscall/eintr (%arg ...) c-name) (define (syscall %arg ...) (let ((arg %arg) ...) - (let ((res - (call-with-current-continuation - (lambda (k) - (let loop () - (with-handler - (lambda (condition more) - (if (and (exception? condition) (eq? (exception-reason condition) - 'os-error)) - (let ((stuff (exception-arguments condition))) - (if (= (cadr stuff) errno/intr) - (loop) - (k (make-err (cadr stuff) ; errno - (caddr stuff) ;msg - (cdddr stuff) ;packet - )))) ; (msg syscall . packet) - (more))) - (lambda () - (syscall/eintr %arg ...)))))))) ;BOGUS - (if (err? res) - (apply errno-error (err:errno res) (err:msg res) syscall - (err:stuff res)) - res)))))))) + (continuation-capture + (lambda (cont) + (let loop () + (with-handler + (lambda (condition more) + (if (and (exception? condition) (eq? (exception-reason condition) + 'os-error)) + (let ((stuff (exception-arguments condition))) + (if (= (cadr stuff) errno/intr) + (loop) + (continuation-graft + cont + (lambda () + (apply errno-error + (cadr stuff) ; errno + (caddr stuff) ;msg + syscall + (cdddr stuff)))))) ;packet + (more))) + (lambda () + (syscall/eintr %arg ...)))))))))))) ;;; Process ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;