suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

'status waits for port-managing threads

Browse Source 
svn: r2526
This commit is contained in:
Matthew Flatt 2006-03-28 14:15:52 +00:00
parent d6bb606ab5
commit c5492262fc
1 changed files with 37 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
collects/mzlib/process.ss
View File

@ -98,33 +98,43 @@
(sync subp si)
(semaphore-wait it-ready)
(break-thread si))))
(list (aport so)
(aport si)
(subprocess-pid subp)
(aport se)
(letrec ((control
(lambda (m)
(case m
((status) (let ((s (subprocess-status subp)))
(cond ((not (integer? s)) s)
((zero? s) 'done-ok)
(else 'done-error))))
((exit-code) (let ((s (subprocess-status subp)))
(and (integer? s) s)))
((wait)
(subprocess-wait subp)
(let ([twait (lambda (t)
(when (thread? t)
(thread-wait t)))])
(twait so)
(twait si)
(twait se)))
((interrupt) (subprocess-kill subp #f))
((kill) (subprocess-kill subp #t))
(else
(raise-type-error 'control-process
"'status, 'exit-code, 'wait, 'interrupt, or 'kill" m))))))
control)))))
(let ([threads-still-going?
(lambda ()
(ormap (lambda (s)
(and (thread? s)
(thread-running? s)))
(list so si se)))])
(list (aport so)
(aport si)
(subprocess-pid subp)
(aport se)
(letrec ((control
(lambda (m)
(case m
((status) (let ((s (subprocess-status subp)))
(cond ((or (not (integer? s))
(threads-still-going?))
'running)
((zero? s) 'done-ok)
(else 'done-error))))
((exit-code) (if (threads-still-going?)
#f
(let ((s (subprocess-status subp)))
(and (integer? s) s))))
((wait)
(subprocess-wait subp)
(let ([twait (lambda (t)
(when (thread? t)
(thread-wait t)))])
(twait so)
(twait si)
(twait se)))
((interrupt) (subprocess-kill subp #f))
((kill) (subprocess-kill subp #t))
(else
(raise-type-error 'control-process
"'status, 'exit-code, 'wait, 'interrupt, or 'kill" m))))))
control))))))
(define (process/ports out in err str)
(apply process*/ports out in err (shell-path/args "process/ports" str)))