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) (add-job! job)
job)) job))
(define (make-job-sans-console name proc) (define (make-job-sans-console name proc . args)
(let ((job (really-make-job (let-optionals args
name #f proc (make-placeholder) ((fetch-status (lambda (x) x)))
(let ((job (really-make-job
name #f proc (make-placeholder)
(date) #f 'running))) (date) #f 'running)))
(spawn-job-status-surveillant job) (spawn-job-status-surveillant job fetch-status)
(add-job! job) (add-job! job)
job)) job)))
(define (job-with-console? v) (define (job-with-console? v)
(and (job? v) (job-console v))) (and (job? v) (job-console v)))
@ -47,19 +49,20 @@
(define (job-status job) (define (job-status job)
(sync (job-status-rv job))) (sync (job-status-rv job)))
(define (spawn-job-status-surveillant job) (define (spawn-job-status-surveillant job fetch-status)
(spawn (spawn
(lambda () (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 (cond
((status:exit-val status) ((status:exit-val status)
=> (lambda (i) => (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-run-status! job 'ready)
(set-job-end-time! job (date)))) (set-job-end-time! job (date))))
((status:stop-sig status) ((status:stop-sig status)
=> (lambda (signal) => (lambda (signal)
(debug-message "spawn-job-status-surveillant stop-sig") (debug-message "spawn-job-status-surveillant stop-sig " signal)
(cond (cond
((= signal signal/ttin) ((= signal signal/ttin)
(set-job-run-status! job 'waiting-for-input)) (set-job-run-status! job 'waiting-for-input))
@ -69,7 +72,7 @@
(set-job-run-status! job 'stopped))))) (set-job-run-status! job 'stopped)))))
((status:term-sig status) ((status:term-sig status)
=> (lambda (i) => (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)))) (set-job-run-status! job 'stopped))))
(placeholder-set! (placeholder-set!
(really-job-status job) status))))) (really-job-status job) status)))))
@ -314,27 +317,45 @@
(save-tty-excursion (save-tty-excursion
(current-input-port) (current-input-port)
(lambda () (lambda ()
(def-prog-mode) (call-with-values
(clear) pipe
(endwin) (lambda (rport wport)
(restore-initial-tty-info! (current-input-port)) (def-prog-mode)
(drain-tty (current-output-port)) (clear)
(obtain-lock paint-lock) (endwin)
(let ((foreground-pgrp (tty-process-group (current-output-port))) (restore-initial-tty-info! (current-input-port))
(proc (drain-tty (current-output-port))
(fork (obtain-lock paint-lock)
(lambda () (let ((foreground-pgrp (tty-process-group (current-output-port)))
(set-process-group (pid) (pid)) (proc
(set-tty-process-group (current-output-port) (pid)) (fork
(eval-s-expr s-expr))))) (lambda ()
(let ((job (make-job-sans-console s-expr proc))) (set-process-group (pid) (pid))
(job-status job) (set-tty-process-group (current-output-port) (pid))
(set-tty-process-group (current-output-port) foreground-pgrp) (let ((status (eval-s-expr s-expr)))
(newline) ;; I don't understand it. Send list, will work.
(display "Press any key to return to Commander S...") ;; Send integer, READ will sit there and wait for ever.
(wait-for-key) ;; Sigh.
(release-lock paint-lock) (write (list status) wport)
job))))) (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 (define-syntax run/fg
(syntax-rules () (syntax-rules ()

1
scheme/nuit-packages.scm
View File

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