Make the spectacular new command language work. At least for values of

"work" that don't call for intensive testing.

scheme/comp-cmd.scm

@@ -0,0 +1,62 @@
+;; compile a command line to a scsh process form
+;;
+;; ,open signals command-line-lexer command-line-parser command-line-absyn
+
+(define (compile-redirection redir)
+  (list (redirection-op redir) (redirection-dest redir)))
+
+(define (compile-command cmd)
+  `(epf
+    (,(command-executable cmd) ,@(command-args cmd))
+    ,@(map compile-redirection 
+	   (command-redirections cmd))))
+
+(define (compile-command-chain chain)
+  (let ((semicolon (string->symbol ";")))
+    (let lp ((chain chain) (pf '()))
+      (if (null? chain)
+	  pf
+	  (let ((combinator (caar chain))
+		(command (compile-command (cdar chain)))
+		(next (lambda (pf) 
+			(lp (cdr chain) pf))))
+	    (cond
+	     ((eq? combinator 'none)
+	      (next command))
+	     ((eq? combinator '|)
+	      (if (and (not (null? pf)) 
+		       (eq? (car pf) combinator))
+		  (next (append pf (list command)))
+		  (next (list '| pf command))))
+	     ((eq? combinator '&&)
+	      (next
+	       `(begin
+		  (let ((status (run ,pf)))
+		    (if (zero? status)
+			(exit (status:exit-val (run ,command)))
+			(exit (status:exit-val status)))))))
+	     ((eq? combinator '||)
+	      (next
+	       `(begin
+		  (let ((status (run ,pf)))
+		    (if (zero? status)
+			(exit 0)
+			(exit (status:exit-val (run ,command))))))))
+	     ((eq? combinator semicolon)
+	      (next 
+	       `(begin (run ,pf) 
+		       (exit (status:exit-val (run ,command))))))
+	     (else
+	      (error "Unknown combinator" combinator))))))))
+
+(define (compile-command-line cmdln)
+  (let ((pf
+	 (compile-command-chain 
+	  (cons
+	   (cons 'none (command-line-first-cmd cmdln))
+	   (command-line-combinator/cmds cmdln)))))
+    (case (command-line-job-ctrl cmdln)
+      ((&)  `(run/bg ,pf))
+      ((&*) `(run/console ,pf))
+      (else `(run/fg ,pf)))))
+

scheme/job.scm

@@ -284,61 +284,104 @@
     (thunk)
     (set-tty-info/now port settings)))
 
+;; 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 ()
-    ((_ epf)
+    ((_ pf)
-     (call-with-values
+     (run/console* (cons 'run (quote pf))))))
-	 (lambda ()
+
-	   (fork-pty-session
+;; for use in command mode (used by command-line-compiler)
-	    (lambda ()
+(define (run/fg* s-expr)
-	      (exec-epf epf))))
+  (debug-message "run/fg* " s-expr)
-       (lambda (proc pty-in pty-out tty-name)
+  (save-tty-excursion
-	 (make-job-with-console
+   (current-input-port)
-	  (quote epf) proc
+   (lambda ()
-	  pty-in pty-out 
+     (def-prog-mode)
-	  (make-terminal-buffer 
+     (clear)
-	   (- (result-buffer-num-cols (result-buffer)) 1)
+     (endwin)
-	   (- (result-buffer-num-lines (result-buffer)) 1))))))))
+     (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)))))
+       (job-status (make-job-sans-console s-expr proc))
+       (set-tty-process-group (current-output-port) foreground-pgrp)
+       (display "Press any key to return to Commander S...")
+       (wait-for-key)
+       (release-lock paint-lock)))))
 
 (define-syntax run/fg
   (syntax-rules ()
     ((_ epf)
-     (save-tty-excursion
+     (run/fg* `(run ,(quote epf))))))
-      (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))
-		  (exec-epf epf)))))
-	  (job-status (make-job-sans-console (quote epf) proc))
-	  (set-tty-process-group (current-output-port) foreground-pgrp)
-	  (display "Press any key to return to Commander S...")
-	  (wait-for-key)
-	  (release-lock paint-lock)))))))
 
+;; 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 ()
-    ((_ epf)
+    ((_ pf)
-     (begin
+     (run/bg* (cons 'run (quote pf))))))
-       (obtain-lock paint-lock)
+
-       (drain-tty (current-output-port))
+(define (init-evaluation-environment package)
-       (set-tty-process-group (current-output-port) (pid))
+  (let ((structure (reify-structure package)))
-       (let ((proc
+    (load-structure structure)
- 	      (fork
+    (rt-structure->environment structure)))
- 	       (lambda ()
+
-		 (set-process-group (pid) (pid))
+(define *evaluation-environment* 
- 		 (exec-epf epf)))))
+  (delay (init-evaluation-environment 'nuit-eval)))
- 	 (let ((job (make-job-sans-console (quote epf) proc)))
+
-	   (release-lock paint-lock)
+(define (evaluation-environment) (force *evaluation-environment*))
- 	   job))))))
+
+(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

scheme/nuit-engine.scm

@@ -203,7 +203,7 @@
 (define (eval-command-in-scheme-mode command-line)
   (let ((viewer
 	 (find/init-plugin-for-result
-	  (eval-expression command-line))))
+	  (eval-string command-line))))
     (let* ((tokens (split-command-line command-line))
 	   (command (car tokens))
 	   (args (cdr tokens))
@@ -588,24 +588,6 @@
 			(+ (buffer-pos-line (command-buffer)) 1))
   (set-buffer-pos-col! (command-buffer) 2))
 
-(define (init-evaluation-environment package)
-  (let ((structure (reify-structure package)))
-    (load-structure structure)
-    (rt-structure->environment structure)))
-
-(define (read-sexp-from-string string)
-  (let ((string-port (open-input-string string)))
-    (read string-port)))
-
-(define eval-expression
-  (let ((env (init-evaluation-environment 'nuit-eval)))
-    (lambda (exp)
-      (eval (read-sexp-from-string exp) env))))
-;       (with-fatal-and-capturing-error-handler
-;        (lambda (condition raw-continuation continuation decline)
-; 	 raw-continuation)
-;        (lambda ()
-; 	 (eval (read-sexp-from-string exp) env))))))
 
 (define (determine-plugin-by-type result)
   (find (lambda (r)

scheme/nuit-packages.scm

@@ -233,8 +233,13 @@
 	srfi-37
 	sorting
 
+	command-line-lexer
+	command-line-parser
+	command-line-absyn
+	command-line-compiler
 	joblist
 	jobs
+	run-jobs-internals
 	layout
         fs-object
 	pps
@@ -376,8 +381,9 @@
    srfi-1
 
    terminal-buffer
-   jobs
    run-jobs
+   run-jobs-internals
+   jobs
    focus-table
    fs-object
    pps)
@@ -525,6 +531,14 @@
    (run/fg :syntax)
    (run/bg :syntax)))
 
+(define-interface run-jobs-internals-interface
+  (export
+   eval-string
+   eval-s-expr
+   run/console*
+   run/fg*
+   run/bg*))
+
 (define-interface joblist-interface
   (export running-jobs
 	  ready-jobs
@@ -535,18 +549,21 @@
 
 (define-structures ((jobs	job-interface)
 		    (run-jobs   run-jobs-interface)
+		    (run-jobs-internals run-jobs-internals-interface)
 		    (joblist	joblist-interface))
   (open (modify scheme-with-scsh 
 		(hide receive select))
 	define-record-types
 	threads
 	srfi-1
+	srfi-6
 	signals
 	locks
 
 	rendezvous
 	rendezvous-channels
 	rendezvous-placeholders
+	rt-modules
 
 	initial-tty
 	ncurses
@@ -619,6 +636,21 @@
 	handle)
   (files cmdline))
 
+;;; command line compiler
+
+(define-interface command-line-compiler-interface
+  (export compile-command-line))
+
+(define-structure command-line-compiler 
+    command-line-compiler-interface
+  (open scheme
+	signals
+
+	command-line-lexer
+	command-line-parser
+	command-line-absyn)
+  (files comp-cmd))
+   
 ;;; nuit 
 
 (define-interface nuit-interface
@@ -640,7 +672,6 @@
 	srfi-13
 	debugging
 	inspect-exception
-	rt-modules
 	tty-debug
 	threads
 	rendezvous
@@ -668,6 +699,8 @@
 	completion-sets
 	select-list
 	jobs
+	run-jobs
+	run-jobs-internals
 	joblist
 	;; the following modules are plugins
 	joblist-viewer

scheme/std-command.scm

@@ -1,6 +1,8 @@
 (define (standard-command-plugin-completer command args)
   #f)
 
+;; helper functions for globbing
+
 (define (contains-glob-enumerator? arg)
   (if-match
    (regexp-search 
@@ -28,28 +30,73 @@
 	(error "no files match this glob expression" arg (cwd))
 	files)))
 
-(define (expand-command-argument arg)
+;; expand command list:
-  (let ((expanded (expand-file-name arg)))
+;; - substiute environment vars in strings with their values
-    (cond 
+;; - globbing
-     ((contains-glob-expression? arg)
-      (glob-argument expanded))
-     (else (list expanded)))))
 
-(define (expand-argument-list args)
+(define (env-var-name str)
-  (fold-right
+  (cond
-   (lambda (arg expanded)
+   ((regexp-search 
-     (append (expand-command-argument arg) expanded))
+     (rx (: #\$ (? #\{) (submatch (+ (- ascii #\}))) (? #\}))) str)
-   '() args))
+    => (lambda (matches)
+	 (match:substring matches 1)))
+   (else #f)))
 
+(define (lookup-env-var var)
+  (cond
+   ((assoc var (env->alist))
+    => cdr)
+   (else
+    (error "Undefined environment variable" var))))
+
+(define (substitute-env-vars str)
+  (cond
+   ((env-var-name str)
+    => lookup-env-var)
+   (else str)))
+
+(define (expand-string str)
+  (substitute-env-vars str))
+
+(define (expand-redirection redirection)
+  (make-redirection
+   (redirection-op redirection)
+   (expand-string (redirection-dest redirection))))
+
+(define (expand-command command)
+  (let ((expanded (map expand-string (command-args command))))
+    (make-command
+     (expand-string (command-executable command))
+     (fold-right 
+      (lambda (arg args)
+	(if (contains-glob-expression? arg)
+	    (append (glob-argument arg) args)
+	    (cons arg args)))
+      '() expanded)
+   (map expand-redirection (command-redirections command)))))
+
+(define (expand-command-line command-line)
+  (make-command-line
+   (expand-command (command-line-first-cmd command-line))
+   (map (lambda (combinator.command)
+	  (cons (car combinator.command)
+		(expand-command (cdr combinator.command))))
+	(command-line-combinator/cmds command-line))
+   (command-line-job-ctrl command-line)))
+
+;; #####
+;; it's a dumb idea to keep command and args separate, merge
+;; this stuff
 (define (standard-command-plugin-evaluater command args)
-  (def-prog-mode)
+  (let* ((parsed
-  (endwin)
+	  (parse-command-line
-  (newline)
+	   (lex-command-line
-  (let ((status (run (,command ,@(expand-argument-list args)))))
+	    (string-append command " "
-    (newline)
+			   (string-join args)))))
-    (display "Press any key to return to scsh-nuit...")
+	 (expanded (expand-command-line parsed))
-    (wait-for-key)
+	 (s-expr (compile-command-line expanded)))
-    status))
+    (debug-message "Compiled command " s-expr)
+    (eval-s-expr s-expr)))
 
 (define standard-command-plugin
   (make-command-plugin #f