commander-s/scheme/job.scm

(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")
	      (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")
	      (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")
	      (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 signal (job-proc job)))
  
(define (stop-job job)
  (signal-process-group 
   (proc:pid (job-proc job)) signal/stop))

(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/foreground-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))))

;; 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/foreground-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/foreground-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))
				     ((= signal signal/tstp)
				      (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 () 
	   (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 ()
    ((_ pf)
     (run/console* `(run (quote pf))))))

;; 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 () 
	       (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)))))

(define-syntax run/fg
  (syntax-rules ()
    ((_ epf)
     (run/fg* `(run ,(quote 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))
	    (eval-s-expr s-expr)))))
    (let ((job (make-job-sans-console (quote epf) proc)))
      (release-lock paint-lock)
      job)))

;; for use in Scheme mode
(define-syntax run/bg
  (syntax-rules ()
    ((_ pf)
     (run/bg* `(run ,(quote pf))))))

(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)
  (eval s-expr (evaluation-environment)))

;;; EOF