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

Replace hacked-up VM-CHANNEL-ABORT by a version that's simpler and 

closer to the original.
This commit is contained in:
sperber 2002-09-19 07:07:40 +00:00
parent 9950aa7205
commit d14e638e10
1 changed files with 32 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
scheme/vm/vmio.scm
View File

@ -288,46 +288,39 @@
; if it has. If not, call the OS and have it abort the channel's current ; if it has. If not, call the OS and have it abort the channel's current
; operation. ; operation.
(define (vm-channel-abort channel) (define (vm-channel-abort channel)
(cond ((and (false? *pending-input-channels-head*) (let* ((input? (or (= input-status (channel-status channel))
(false? *pending-output-channels-head*)) (= special-input-status (channel-status channel))))
(set-channel-os-status! channel false) ; no longer pending (head (if input?
(enter-fixnum (channel-abort *pending-input-channels-head*
(extract-fixnum (channel-os-index channel))))) *pending-output-channels-head*)))
((vm-eq? channel *pending-input-channels-head*) (cond ((false? head)
(dequeue-input-channel!) (set-channel-os-status! channel false) ; no longer pending
(channel-os-status channel)) (enter-fixnum (channel-abort
((vm-eq? channel *pending-output-channels-head*) (extract-fixnum (channel-os-index channel)))))
(dequeue-output-channel!) ((vm-eq? channel head)
(channel-os-status channel)) (if input?
(else (dequeue-input-channel!)
(let loop ((ch (channel-next *pending-input-channels-head*)) (dequeue-output-channel!))
(prev *pending-input-channels-head*)) (channel-os-status channel))
(cond ((false? ch) (else
(let loop ((ch (channel-next *pending-output-channels-head*)) (let loop ((ch (channel-next head)) (prev head))
(prev *pending-output-channels-head*)) (cond ((false? ch)
(cond ((false? ch) (set-channel-os-status! channel false) ; no longer pending
(set-channel-os-status! channel false) ; no longer pending (enter-fixnum (channel-abort
(enter-fixnum (channel-abort (extract-fixnum (channel-os-index channel)))))
(extract-fixnum (channel-os-index channel))))) ((vm-eq? ch channel)
((vm-eq? ch channel) (if input?
(if (vm-eq? ch *pending-output-channels-tail*) (if (vm-eq? ch *pending-input-channels-tail*)
(set! *pending-output-channels-tail* prev)) (set! *pending-input-channels-tail* prev))
(set-channel-next! prev (channel-next ch)) (if (vm-eq? ch *pending-output-channels-tail*)
(set-channel-next! ch false) (set! *pending-output-channels-tail* prev)))
(channel-os-status ch)) (set-channel-next! prev (channel-next ch))
(else (set-channel-next! ch false)
(loop (channel-next ch) ch))))) (channel-os-status ch))
(else
((vm-eq? ch channel) (loop (channel-next ch) ch))))))))
(if (vm-eq? ch *pending-input-channels-tail*)
(set! *pending-input-channels-tail* prev))
(set-channel-next! prev (channel-next ch))
(set-channel-next! ch false)
(channel-os-status ch))
(else
(loop (channel-next ch) ch)))))))
(define (trace-io trace-value) (define (trace-io trace-value)
(set! *pending-input-channels-head* (set! *pending-input-channels-head*