First version of the job control

scheme/go

@@ -1,5 +1,5 @@
 #!/bin/sh
-args="-lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit"
+args="-lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lel cml/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit"
 echo "Starting scsh with options: $args" 
 exec scsh $args 
 #-c "(nuit)"

scheme/gogo

@@ -1,3 +1,3 @@
 #!/bin/sh
-args="-lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit"
+args="-lel pps/load.scm -lel module-system/load.scm -lel interaction/load.scm -lel cml/load.scm -lm debug-packages.scm -lel scsh-ncurses-0.2/load.scm -lm nuit-packages.scm -o nuit"
 exec scsh $args -c "(nuit)"

scheme/job.scm

@@ -0,0 +1,141 @@
+(define-record-type job :job
+  (make-job name pty-in pty-out proc status)
+  job?
+  (name job-name)
+  (pty-in job-pty-in)
+  (pty-out job-pty-out)
+  (proc job-proc)
+  (status really-job-status))
+
+(define (make-job name pty-in pty-out proc)
+  (let ((job (make-job name pty-in pty-out proc
+		       (make-placeholder))))
+    (spawn-job-status-surveillant job)
+    (add-job! job)
+    job))
+
+(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)
+  (let ((channel (make-channel)))
+    (spawn
+     (lambda ()
+       (placeholder-set! 
+	(really-job-status job) (wait (job-proc)))))))
+
+(define (signal-job signal job)
+  (signal-process-group signal (job-proc job)))
+  
+(define (stop-job job)
+  (signal-job signal/stop job))
+
+(define (continue-job job)
+  (signal-process-group signal/cont job))
+
+;; channels for communicating with the joblist surveillant
+
+(define add-job-channel
+  (make-channel))
+
+(define get-job-list-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 (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 '())
+		(new-output '())
+		(waiting-for-input '())
+		(notify? #f))
+	 (cond
+	  (notify?
+	   (send statistics-channel
+		 (list (cons 'running (length running))
+		       (cons 'ready (length ready))
+		       (cons 'new-output (length new-output))
+		       (cons 'waiting-for-input (length waiting-for-input))))
+	   (lp running ready 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 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)
+			      ((new-output) new-output)
+			      ((waiting-for-input) waiting-for-input)
+			      (else
+			       (error "joblist-surveillant" state.channel))))
+		      (lp running ready new-output waiting-for-input #f))))
+
+	     (map (lambda (job)
+		    (wrap (job-status-rv job)
+			  (lambda (ignore)
+			    (lp (delete job running)
+				(cons job ready)
+				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-syntax run-as-background-job
+  (syntax-rules ()
+    ((_ epf)
+     (call-with-values
+	 (lambda ()
+	   (fork-pty-session
+	    (lambda ()
+	      (exec-epf epf))))
+       (lambda (proc pty-in pty-out tty-name)
+	 (make-job (quote epf) pty-in pty-out proc))))))

scheme/nuit-engine.scm

@@ -305,11 +305,20 @@
   (init-windows!)
   (init-executables-completion-set!)
 
+  ;; init joblist
+  (let ((statistics-channel (spawn-joblist-surveillant)))
+    (spawn
+     (lambda ()
+       (let lp ((stats (cml-receive statistics-channel)))
+	 (debug-message "statistics update " stats)
+ 	 (paint-command-frame-window)
+ 	 (paint-job-status-list stats)
+ 	 (paint-command-window-contents)
+ 	 (refresh-command-window)
+	 (lp (cml-receive statistics-channel))))))
+
   (set-process-group (pid) (pid))
   (set-tty-process-group (current-input-port) (pid))
-  (set-interrupt-handler interrupt/tstp
-			 (lambda a
-			   (debug-message "SIGTSTP")))
 
   '(set-interrupt-handler interrupt/keyboard 
 			  (lambda a 
@@ -536,8 +545,36 @@
   (box (app-window-curses-win command-frame-window)
        (ascii->char 0) (ascii->char 0))
   (paint-command-buffer-mode-indicator)
+  (paint-job-status-list)
   (wrefresh (app-window-curses-win command-frame-window)))
 
+(define paint-job-status-list
+  (let ((latest-statistics (initial-job-statistics)))
+    (lambda args
+      (let-optionals args
+	  ((statistics latest-statistics))
+	(let* ((stat-item (lambda (text number)
+			    (string-append text (number->string number))))
+	       (stat
+		(string-join
+		 (map 
+		  (lambda (status.count)
+		    (case (car status.count)
+		      ((running) (stat-item "run:" (cdr status.count)))
+		      ((ready) (stat-item "ready:" (cdr status.count)))
+		      ((new-output) (stat-item "out:" (cdr status.count)))
+		      ((waiting-for-input) (stat-item "in:" (cdr status.count)))))
+		  statistics)))
+	       (line (string-append "[ " stat " ]")))
+	  (set! latest-statistics statistics)
+	  (mvwaddstr
+	   (app-window-curses-win command-frame-window)
+	   (- (app-window-height command-frame-window) 1)
+	   (- (- (app-window-width command-frame-window)
+		 (string-length line))
+	      2)
+	   line))))))
+
 (define (paint-command-window-contents)
   (set-buffer-num-lines! command-buffer
  			 (- (app-window-height command-window) 2))

scheme/nuit-packages.scm

@@ -329,13 +329,46 @@
 	thread-fluids)
   (files complete))
 
+;;; jobs and joblist
+
+(define-interface job-interface
+  (export make-job
+	  job-status
+	  job-status-rv
+	  signal-job
+	  stop-job
+	  continue-job
+	  (run-as-background-job :syntax)))
+
+(define-interface joblist-interface
+  (export running-jobs
+	  ready-jobs
+	  jobs-with-new-output
+	  jobs-waiting-for-input
+	  spawn-joblist-surveillant
+	  initial-job-statistics))
+
+(define-structures ((jobs	job-interface)
+		    (joblist	joblist-interface))
+  (open (modify scheme-with-scsh 
+		(hide receive select))
+	define-record-types
+	threads
+	srfi-1
+	signals
+
+	rendezvous
+	rendezvous-channels
+	rendezvous-placeholders)
+  (files job))
+
 ;;; nuit 
 
 (define-interface nuit-interface
   (export nuit))
 
 (define-structure nuit nuit-interface    
-  (open scheme-with-scsh
+  (open (modify scheme-with-scsh (hide receive))
 	external-calls
 	define-record-types
 	conditions
@@ -352,6 +385,13 @@
 	inspect-exception
 	rt-modules
 	tty-debug
+	threads
+	rendezvous
+	(modify	rendezvous-channels
+		(rename
+		 (send cml-send)
+		 (receive cml-receive)))
+	let-opt
 
 	focus-table
 	nuit-eval/focus-table
@@ -365,6 +405,8 @@
         handle-fatal-error
 	completion-sets
 	select-list
+	jobs
+	joblist
 	;; the following modules are plugins
 	dirlist-view-plugin
         user-group-info-plugin