399 lines
11 KiB
Scheme
399 lines
11 KiB
Scheme
(define-record-type job :job
|
|
(really-make-job name console
|
|
proc status
|
|
start-time end-time run-status)
|
|
job?
|
|
(name job-name)
|
|
(console job-console)
|
|
(proc job-proc)
|
|
(status really-job-status set-job-status!)
|
|
(start-time job-start-time)
|
|
(end-time job-end-time set-job-end-time!)
|
|
(run-status job-run-status set-job-run-status!))
|
|
|
|
(define-record-discloser :job
|
|
(lambda (r)
|
|
`(job ,(job-name r) ,(job-run-status r))))
|
|
|
|
(define (make-job-with-console name proc pty-in pty-out terminal-buffer)
|
|
(let ((job (really-make-job
|
|
name
|
|
(make-console pty-in pty-out
|
|
(app-window-curses-win (result-window))
|
|
terminal-buffer)
|
|
proc (make-placeholder)
|
|
(date) #f 'running)))
|
|
(spawn-job-status-surveillant job)
|
|
(add-job! job)
|
|
job))
|
|
|
|
(define (make-job-sans-console name proc)
|
|
(let ((job (really-make-job
|
|
name #f proc (make-placeholder)
|
|
(date) #f 'running)))
|
|
(spawn-job-status-surveillant job)
|
|
(add-job! job)
|
|
job))
|
|
|
|
(define (job-with-console? v)
|
|
(and (job? v) (job-console v)))
|
|
|
|
(define (job-sans-console? v)
|
|
(not (job-with-console? v)))
|
|
|
|
(define (job-status-rv job)
|
|
(placeholder-value-rv (really-job-status job)))
|
|
|
|
(define (job-status job)
|
|
(sync (job-status-rv job)))
|
|
|
|
(define (spawn-job-status-surveillant job)
|
|
(spawn
|
|
(lambda ()
|
|
(let ((status (wait (job-proc job) wait/stopped-children)))
|
|
(cond
|
|
((status:exit-val status)
|
|
=> (lambda (i)
|
|
(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 " signal)
|
|
(cond
|
|
((= signal signal/ttin)
|
|
(set-job-run-status! job 'waiting-for-input))
|
|
((= signal signal/ttou)
|
|
(set-job-run-status! job 'new-output))
|
|
(else
|
|
(set-job-run-status! job 'stopped)))))
|
|
((status:term-sig status)
|
|
=> (lambda (i)
|
|
(debug-message "spawn-job-status-surveillant term-sig " i)
|
|
(set-job-run-status! job 'stopped))))
|
|
(placeholder-set!
|
|
(really-job-status job) status)))))
|
|
|
|
(define (job-running? job)
|
|
(eq? (job-run-status job) 'running))
|
|
|
|
(define (job-ready? job)
|
|
(eq? (job-run-status job) 'ready))
|
|
|
|
(define (job-waiting-for-input? job)
|
|
(eq? (job-run-status job) 'waiting-for-input))
|
|
|
|
(define (job-has-new-output? job)
|
|
(eq? (job-run-status job) 'new-output))
|
|
|
|
(define (job-stopped? job)
|
|
(eq? (job-run-status job) 'stopped))
|
|
|
|
(define (signal-job signal job)
|
|
(signal-process-group (job-proc job) signal))
|
|
|
|
(define (stop-job job)
|
|
(signal-job signal/stop job))
|
|
|
|
(define (continue-job job)
|
|
(set-job-status! job (make-placeholder))
|
|
(set-job-run-status! job 'running)
|
|
(signal-process-group
|
|
(proc:pid (job-proc job)) signal/cont)
|
|
(spawn-job-status-surveillant job)
|
|
(send notify-continue-channel job))
|
|
|
|
(define (pause-job-output job)
|
|
(pause-console-output (job-console job)))
|
|
|
|
(define (resume-job-output job)
|
|
(resume-console-output (job-console job)))
|
|
|
|
(define (continue-job-in-foreground job)
|
|
(if (job-sans-console? job)
|
|
(begin
|
|
(drain-tty (current-output-port))
|
|
(def-prog-mode)
|
|
(endwin)
|
|
(newline)
|
|
(drain-tty (current-output-port))
|
|
(obtain-lock paint-lock)
|
|
(set-tty-process-group
|
|
(current-output-port) (proc:pid (job-proc job)))
|
|
(continue-job job)
|
|
(job-status job)
|
|
(set-tty-process-group (current-output-port) (pid))
|
|
(display "Press any key to return to Commander S...")
|
|
(wait-for-key)
|
|
(release-lock paint-lock))))
|
|
|
|
(define (continue-job-in-background job)
|
|
(continue-job job))
|
|
|
|
;; channels for communicating with the joblist surveillant
|
|
|
|
(define add-job-channel
|
|
(make-channel))
|
|
|
|
(define get-job-list-channel
|
|
(make-channel))
|
|
|
|
(define clear-ready-jobs-channel
|
|
(make-channel))
|
|
|
|
(define notify-continue-channel
|
|
(make-channel))
|
|
|
|
(define (add-job! job)
|
|
(send add-job-channel job))
|
|
|
|
(define (running-jobs)
|
|
(let ((answer-channel (make-channel)))
|
|
(send get-job-list-channel (cons 'running answer-channel))
|
|
(receive answer-channel)))
|
|
|
|
(define (ready-jobs)
|
|
(let ((answer-channel (make-channel)))
|
|
(send get-job-list-channel (cons 'ready answer-channel))
|
|
(receive answer-channel)))
|
|
|
|
(define (stopped-jobs)
|
|
(let ((answer-channel (make-channel)))
|
|
(send get-job-list-channel (cons 'stopped answer-channel))
|
|
(receive answer-channel)))
|
|
|
|
(define (clear-ready-jobs!)
|
|
(send clear-ready-jobs-channel 'ignored))
|
|
|
|
(define (jobs-with-new-output)
|
|
(let ((answer-channel (make-channel)))
|
|
(send get-job-list-channel (cons 'new-output answer-channel))
|
|
(receive answer-channel)))
|
|
|
|
(define (jobs-waiting-for-input)
|
|
(let ((answer-channel (make-channel)))
|
|
(send get-job-list-channel (cons 'waiting-for-input answer-channel))
|
|
(receive answer-channel)))
|
|
|
|
(define (spawn-joblist-surveillant)
|
|
(let ((statistics-channel (make-channel)))
|
|
(spawn
|
|
(lambda ()
|
|
(let lp ((running '())
|
|
(ready '())
|
|
(stopped '())
|
|
(new-output '())
|
|
(waiting-for-input '())
|
|
(notify? #f))
|
|
(debug-message "spawn-joblist-surveillant "
|
|
running " " ready " " stopped " "
|
|
new-output " " waiting-for-input " " notify?)
|
|
(cond
|
|
(notify?
|
|
(send statistics-channel
|
|
(list (cons 'running (length running))
|
|
(cons 'ready (length ready))
|
|
(cons 'stopped (length stopped))
|
|
(cons 'new-output (length new-output))
|
|
(cons 'waiting-for-input (length waiting-for-input))))
|
|
(lp running ready stopped new-output waiting-for-input #f))
|
|
(else
|
|
(apply
|
|
select
|
|
(append
|
|
(list
|
|
(wrap (receive-rv add-job-channel)
|
|
(lambda (new-job)
|
|
(lp (cons new-job running)
|
|
ready stopped new-output waiting-for-input #t)))
|
|
|
|
(wrap (receive-rv notify-continue-channel)
|
|
(lambda (job)
|
|
(lp (cons job running)
|
|
ready
|
|
(delete job stopped)
|
|
(delete job new-output)
|
|
(delete job waiting-for-input) #t)))
|
|
|
|
(wrap (receive-rv clear-ready-jobs-channel)
|
|
(lambda (ignore)
|
|
(lp running '() stopped new-output waiting-for-input #t)))
|
|
|
|
(wrap (receive-rv get-job-list-channel)
|
|
(lambda (state.channel)
|
|
(send (cdr state.channel)
|
|
(case (car state.channel)
|
|
((running) running)
|
|
((ready) ready)
|
|
((stopped) stopped)
|
|
((new-output) new-output)
|
|
((waiting-for-input) waiting-for-input)
|
|
(else
|
|
(error "joblist-surveillant" state.channel))))
|
|
(lp running ready stopped new-output waiting-for-input #f))))
|
|
|
|
(map (lambda (job)
|
|
(wrap (job-status-rv job)
|
|
(lambda (status)
|
|
(cond
|
|
((status:exit-val status)
|
|
=> (lambda (ignore)
|
|
(lp (delete job running)
|
|
(cons job ready) stopped
|
|
new-output waiting-for-input #t)))
|
|
((status:stop-sig status)
|
|
=> (lambda (signal)
|
|
(cond
|
|
((= signal signal/ttin)
|
|
(lp (delete job running)
|
|
ready stopped new-output
|
|
(cons job waiting-for-input) #t))
|
|
((= signal signal/ttou)
|
|
(lp (delete job running)
|
|
ready stopped
|
|
(cons job new-output)
|
|
waiting-for-input #t))
|
|
((or (= signal signal/tstp)
|
|
(= signal signal/stop))
|
|
;; TODO catch any other signal here
|
|
(stop-job job)
|
|
(lp (delete job running)
|
|
ready (cons job stopped)
|
|
new-output waiting-for-input #t))
|
|
(else
|
|
(error "Unhandled signal" signal)))))
|
|
((status:term-sig status)
|
|
=> (lambda (signal)
|
|
(lp (delete job running)
|
|
ready (cons job stopped)
|
|
new-output waiting-for-input #t)))))))
|
|
running))))))))
|
|
statistics-channel))
|
|
|
|
(define (initial-job-statistics)
|
|
(list (cons 'running 0)
|
|
(cons 'ready 0)
|
|
(cons 'new-output 0)
|
|
(cons 'waiting-for-input 0)))
|
|
|
|
;; #### unfinished
|
|
(define (install-terminal/stop-handler)
|
|
(set-interrupt-handler
|
|
interrupt/tstp
|
|
(lambda args
|
|
(display args))))
|
|
|
|
(define (save-tty-excursion port thunk)
|
|
(let ((settings (tty-info port)))
|
|
(let ((val (thunk)))
|
|
(set-tty-info/now port settings)
|
|
val)))
|
|
|
|
;; run a job by running the program form
|
|
|
|
|
|
;; for use in command mode (used by command-line-compiler)
|
|
(define (run/console* s-expr)
|
|
(call-with-values
|
|
(lambda ()
|
|
(fork-pty-session
|
|
(lambda ()
|
|
(handle-signal-default signal/ttou)
|
|
(eval-s-expr s-expr))))
|
|
(lambda (proc pty-in pty-out tty-name)
|
|
(make-job-with-console
|
|
s-expr proc pty-in pty-out
|
|
(make-terminal-buffer
|
|
(- (result-buffer-num-cols (result-buffer)) 1)
|
|
(- (result-buffer-num-lines (result-buffer)) 1))))))
|
|
|
|
;; for use in Scheme mode
|
|
(define-syntax run/console
|
|
(syntax-rules ()
|
|
((_ epf)
|
|
(run/console* '(exec-epf epf)))))
|
|
|
|
;; for use in command mode (used by command-line-compiler)
|
|
(define (run/fg* s-expr)
|
|
(debug-message "run/fg* " s-expr)
|
|
(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 ()
|
|
(let ((child-pid (pid)))
|
|
(set-process-group child-pid)
|
|
(set-tty-process-group (current-output-port) child-pid)
|
|
(handle-signal-default signal/ttou)
|
|
(eval-s-expr s-expr))))))
|
|
(let* ((job (make-job-sans-console s-expr proc))
|
|
(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 ()
|
|
((_ epf)
|
|
(run/fg* '(exec-epf epf)))))
|
|
|
|
;; for use in command mode (used by command-line-compiler)
|
|
(define (run/bg* s-expr)
|
|
(obtain-lock paint-lock)
|
|
(drain-tty (current-output-port))
|
|
(set-tty-process-group (current-output-port) (pid))
|
|
(let ((proc
|
|
(fork
|
|
(lambda ()
|
|
(set-process-group (pid) (pid))
|
|
(handle-signal-default signal/ttou)
|
|
(eval-s-expr s-expr)))))
|
|
(let ((job (make-job-sans-console s-expr proc)))
|
|
(release-lock paint-lock)
|
|
job)))
|
|
|
|
;; for use in Scheme mode
|
|
(define-syntax run/bg
|
|
(syntax-rules ()
|
|
((_ epf)
|
|
(run/bg* '(exec-epf epf)))))
|
|
|
|
(define (init-evaluation-environment package)
|
|
(let ((structure (reify-structure package)))
|
|
(load-structure structure)
|
|
(rt-structure->environment structure)))
|
|
|
|
(define *evaluation-environment*
|
|
(delay (init-evaluation-environment 'nuit-eval)))
|
|
|
|
(define (evaluation-environment) (force *evaluation-environment*))
|
|
|
|
(define (read-sexp-from-string string)
|
|
(let ((string-port (open-input-string string)))
|
|
(read string-port)))
|
|
|
|
(define (eval-string str)
|
|
(eval (read-sexp-from-string str)
|
|
(evaluation-environment)))
|
|
; (with-fatal-and-capturing-error-handler
|
|
; (lambda (condition raw-continuation continuation decline)
|
|
; raw-continuation)
|
|
; (lambda ()
|
|
; (eval (read-sexp-from-string exp) env))))))
|
|
|
|
(define (eval-s-expr s-expr)
|
|
(debug-message "eval-s-expr " s-expr " " (pid))
|
|
(eval s-expr (evaluation-environment)))
|
|
|
|
;;; EOF |