Use continuation-graft in import-os-error-syscall.
This commit is contained in:
parent
b30eed8d54
commit
925ca7b349
|
@ -15,10 +15,22 @@
|
||||||
;;; You can't throw an error within a handler
|
;;; You can't throw an error within a handler
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define-record err
|
;;; Move this to somewhere else as soon as Marc published his SRFI
|
||||||
errno
|
(define (continuation-capture receiver)
|
||||||
msg
|
(call-with-current-continuation
|
||||||
stuff)
|
(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
|
(define-syntax import-os-error-syscall
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
|
@ -27,9 +39,8 @@
|
||||||
(import-lambda-definition syscall/eintr (%arg ...) c-name)
|
(import-lambda-definition syscall/eintr (%arg ...) c-name)
|
||||||
(define (syscall %arg ...)
|
(define (syscall %arg ...)
|
||||||
(let ((arg %arg) ...)
|
(let ((arg %arg) ...)
|
||||||
(let ((res
|
(continuation-capture
|
||||||
(call-with-current-continuation
|
(lambda (cont)
|
||||||
(lambda (k)
|
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(with-handler
|
(with-handler
|
||||||
(lambda (condition more)
|
(lambda (condition more)
|
||||||
|
@ -38,17 +49,17 @@
|
||||||
(let ((stuff (exception-arguments condition)))
|
(let ((stuff (exception-arguments condition)))
|
||||||
(if (= (cadr stuff) errno/intr)
|
(if (= (cadr stuff) errno/intr)
|
||||||
(loop)
|
(loop)
|
||||||
(k (make-err (cadr stuff) ; errno
|
(continuation-graft
|
||||||
|
cont
|
||||||
|
(lambda ()
|
||||||
|
(apply errno-error
|
||||||
|
(cadr stuff) ; errno
|
||||||
(caddr stuff) ;msg
|
(caddr stuff) ;msg
|
||||||
(cdddr stuff) ;packet
|
syscall
|
||||||
)))) ; (msg syscall . packet)
|
(cdddr stuff)))))) ;packet
|
||||||
(more)))
|
(more)))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(syscall/eintr %arg ...)))))))) ;BOGUS
|
(syscall/eintr %arg ...))))))))))))
|
||||||
(if (err? res)
|
|
||||||
(apply errno-error (err:errno res) (err:msg res) syscall
|
|
||||||
(err:stuff res))
|
|
||||||
res))))))))
|
|
||||||
|
|
||||||
;;; Process
|
;;; Process
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
Loading…
Reference in New Issue