diff --git a/scheme/comp-cmd.scm b/scheme/comp-cmd.scm new file mode 100644 index 0000000..bf4d47d --- /dev/null +++ b/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))))) + diff --git a/scheme/job.scm b/scheme/job.scm index 86fe4c8..efbc946 100644 --- a/scheme/job.scm +++ b/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) - (call-with-values - (lambda () - (fork-pty-session - (lambda () - (exec-epf epf)))) - (lambda (proc pty-in pty-out tty-name) - (make-job-with-console - (quote epf) proc - pty-in pty-out - (make-terminal-buffer - (- (result-buffer-num-cols (result-buffer)) 1) - (- (result-buffer-num-lines (result-buffer)) 1)))))))) + ((_ pf) + (run/console* (cons '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))))) + (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 - (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))))))) + (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 () - ((_ epf) - (begin - (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)) - (exec-epf epf))))) - (let ((job (make-job-sans-console (quote epf) proc))) - (release-lock paint-lock) - job)))))) + ((_ pf) + (run/bg* (cons '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 \ No newline at end of file diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm index 077639f..9d8cd75 100644 --- a/scheme/nuit-engine.scm +++ b/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) diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index 6918702..acef519 100644 --- a/scheme/nuit-packages.scm +++ b/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 @@ -618,6 +635,21 @@ signals 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 @@ -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 diff --git a/scheme/std-command.scm b/scheme/std-command.scm index ae6e51c..acb98d3 100644 --- a/scheme/std-command.scm +++ b/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) - (let ((expanded (expand-file-name arg))) - (cond - ((contains-glob-expression? arg) - (glob-argument expanded)) - (else (list expanded))))) +;; expand command list: +;; - substiute environment vars in strings with their values +;; - globbing -(define (expand-argument-list args) - (fold-right - (lambda (arg expanded) - (append (expand-command-argument arg) expanded)) - '() args)) +(define (env-var-name str) + (cond + ((regexp-search + (rx (: #\$ (? #\{) (submatch (+ (- ascii #\}))) (? #\}))) str) + => (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) - (endwin) - (newline) - (let ((status (run (,command ,@(expand-argument-list args))))) - (newline) - (display "Press any key to return to scsh-nuit...") - (wait-for-key) - status)) + (let* ((parsed + (parse-command-line + (lex-command-line + (string-append command " " + (string-join args))))) + (expanded (expand-command-line parsed)) + (s-expr (compile-command-line expanded))) + (debug-message "Compiled command " s-expr) + (eval-s-expr s-expr))) (define standard-command-plugin (make-command-plugin #f