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
; operation.
(define (vm-channel-abort channel)
(cond ((and (false? *pending-input-channels-head*)
(false? *pending-output-channels-head*))
(set-channel-os-status! channel false) ; no longer pending
(enter-fixnum (channel-abort
(extract-fixnum (channel-os-index channel)))))
((vm-eq? channel *pending-input-channels-head*)
(dequeue-input-channel!)
(channel-os-status channel))
((vm-eq? channel *pending-output-channels-head*)
(dequeue-output-channel!)
(channel-os-status channel))
(else
(let loop ((ch (channel-next *pending-input-channels-head*))
(prev *pending-input-channels-head*))
(cond ((false? ch)
(let loop ((ch (channel-next *pending-output-channels-head*))
(prev *pending-output-channels-head*))
(cond ((false? ch)
(set-channel-os-status! channel false) ; no longer pending
(enter-fixnum (channel-abort
(extract-fixnum (channel-os-index channel)))))
((vm-eq? ch channel)
(if (vm-eq? ch *pending-output-channels-tail*)
(set! *pending-output-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)))))
((vm-eq? ch channel)
(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)))))))
(let* ((input? (or (= input-status (channel-status channel))
(= special-input-status (channel-status channel))))
(head (if input?
*pending-input-channels-head*
*pending-output-channels-head*)))
(cond ((false? head)
(set-channel-os-status! channel false) ; no longer pending
(enter-fixnum (channel-abort
(extract-fixnum (channel-os-index channel)))))
((vm-eq? channel head)
(if input?
(dequeue-input-channel!)
(dequeue-output-channel!))
(channel-os-status channel))
(else
(let loop ((ch (channel-next head)) (prev head))
(cond ((false? ch)
(set-channel-os-status! channel false) ; no longer pending
(enter-fixnum (channel-abort
(extract-fixnum (channel-os-index channel)))))
((vm-eq? ch channel)
(if input?
(if (vm-eq? ch *pending-input-channels-tail*)
(set! *pending-input-channels-tail* prev))
(if (vm-eq? ch *pending-output-channels-tail*)
(set! *pending-output-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)
(set! *pending-input-channels-head*