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

Fix the process status bug. Well, sort of. It's an evil hack, I think.

This commit is contained in:
eknauel 2005-08-11 15:03:15 +00:00
parent f26e89b895
commit 843ed0493b
2 changed files with 54 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
scheme/job.scm
View File

@ -27,13 +27,15 @@
(add-job! job)
job))
(define (make-job-sans-console name proc)
(let ((job (really-make-job
name #f proc (make-placeholder)
(define (make-job-sans-console name proc . args)
(let-optionals args
((fetch-status (lambda (x) x)))
(let ((job (really-make-job
name #f proc (make-placeholder)
(date) #f 'running)))
(spawn-job-status-surveillant job)
(add-job! job)
job))
(spawn-job-status-surveillant job fetch-status)
(add-job! job)
job)))
(define (job-with-console? v)
(and (job? v) (job-console v)))
@ -47,19 +49,20 @@
(define (job-status job)
(sync (job-status-rv job)))
(define (spawn-job-status-surveillant job)
(define (spawn-job-status-surveillant job fetch-status)
(spawn
(lambda ()
(let ((status (wait (job-proc job) wait/stopped-children)))
(let ((status (fetch-status (wait (job-proc job) wait/stopped-children))))
(debug-message "job-status-surveillant, wait returned with " status)
(cond
((status:exit-val status)
=> (lambda (i)
(debug-message "spawn-job-status-surveillant exit-val")
(debug-message "spawn-job-status-surveillant exit-val " i)
(set-job-run-status! job 'ready)
(set-job-end-time! job (date))))
((status:stop-sig status)
=> (lambda (signal)
(debug-message "spawn-job-status-surveillant stop-sig")
(debug-message "spawn-job-status-surveillant stop-sig " signal)
(cond
((= signal signal/ttin)
(set-job-run-status! job 'waiting-for-input))
@ -69,7 +72,7 @@
(set-job-run-status! job 'stopped)))))
((status:term-sig status)
=> (lambda (i)
(debug-message "spawn-job-status-surveillant term-sig")
(debug-message "spawn-job-status-surveillant term-sig " i)
(set-job-run-status! job 'stopped))))
(placeholder-set!
(really-job-status job) status)))))
@ -314,27 +317,45 @@
(save-tty-excursion
(current-input-port)
(lambda ()
(def-prog-mode)
(clear)
(endwin)
(restore-initial-tty-info! (current-input-port))
(drain-tty (current-output-port))
(obtain-lock paint-lock)
(let ((foreground-pgrp (tty-process-group (current-output-port)))
(proc
(fork
(lambda ()
(set-process-group (pid) (pid))
(set-tty-process-group (current-output-port) (pid))
(eval-s-expr s-expr)))))
(let ((job (make-job-sans-console s-expr proc)))
(job-status job)
(set-tty-process-group (current-output-port) foreground-pgrp)
(newline)
(display "Press any key to return to Commander S...")
(wait-for-key)
(release-lock paint-lock)
job)))))
(call-with-values
pipe
(lambda (rport wport)
(def-prog-mode)
(clear)
(endwin)
(restore-initial-tty-info! (current-input-port))
(drain-tty (current-output-port))
(obtain-lock paint-lock)
(let ((foreground-pgrp (tty-process-group (current-output-port)))
(proc
(fork
(lambda ()
(set-process-group (pid) (pid))
(set-tty-process-group (current-output-port) (pid))
(let ((status (eval-s-expr s-expr)))
;; I don't understand it. Send list, will work.
;; Send integer, READ will sit there and wait for ever.
;; Sigh.
(write (list status) wport)
(close-output-port wport)
;; We can't call EXIT with a scsh encoded status code,
;; because the value does not fit into a byte. Sigh.
;; Send value over pipe instead.
(exit 0))))))
(let* ((job (make-job-sans-console
s-expr proc
;; truely evil, I think.
(lambda (ignore)
(let ((v (car (read rport)))) ;; see above
(close-input-port rport)
v))))
(status (job-status job)))
(set-tty-process-group (current-output-port) foreground-pgrp)
(newline)
(display "Press any key to return to Commander S...")
(wait-for-key)
(release-lock paint-lock)
job)))))))
(define-syntax run/fg
(syntax-rules ()

1
scheme/nuit-packages.scm
View File

@ -559,6 +559,7 @@
srfi-6
signals
locks
let-opt
rendezvous
rendezvous-channels