diff --git a/sh/anguish.scm b/sh/anguish.scm index 14ef88c..bf56bad 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -52,7 +52,6 @@ (let ((ast- (transform ast))) (format (current-output-port) "parsed : ~s\n\n" ast) (format (current-output-port) "prepared : ~s\n\n" ast-) - ;(map (cut format (current-output-port) "prepared: ~s\n\n" <>) ast-) #t)) (#t (sh-exec ast))))))) @@ -88,7 +87,6 @@ copyleft. (add-history line)) (run ast)) (loop (readline (prompt))))))))) - (activate-readline) (clear-history) (read-history HOME) (with-readline-completion-function completion thunk) @@ -114,7 +112,7 @@ copyleft. (map foo o)) -;; TODO: add braces and pattern ending with / +;; TODO: add braces (define (glob pattern) ;; pattern -> list of path (define (glob? pattern) @@ -161,17 +159,17 @@ copyleft. (('if rest ...) ast) (_ #f))) +(define (background ast) + (match ast + (('pipeline fg rest ...) `(pipeline #f ,@rest)) + (_ ast))) + ;; transform ast -> list of expr ;; such that (map eval expr) -;; (define (background ast) -;; (match ast -;; (('pipeline fg rest ...) `(pipeline #f ,@rest)) -;; (_ ast))) - (define (transform ast) (match ast - ;(('script term "&") (background (transform term))) + (('script term "&") (list (background (transform term)))) (('script term) (list (transform term))) (('script terms ...) (transform terms)) ((('term command)) (list (transform command))) @@ -182,8 +180,8 @@ copyleft. (('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi")) `(if (equal? 0 (status:exit-val ,@(transform expression))) (begin ,@(transform consequent)) (begin ,@(transform alternative)))) (('for-clause "for" ((identifier "in" lst sep) do-group)) `(for-each (lambda (,(string->symbol identifier)) (begin ,@(expand identifier (transform do-group)))) (glob ,(transform lst)))) (('do-group "do" (command "done")) (transform command)) - (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline ,command)))) - (('pipeline command piped-commands) `(pipeline ,(transform command) ,@(transform piped-commands))) + (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,command)))) + (('pipeline command piped-commands) `(pipeline #t ,(transform command) ,@(transform piped-commands))) (('simple-command ('word s)) `(glob ,(transform s))) (('simple-command ('word s1) ('word s2)) `(append (glob ,(transform s1)) (glob ,(transform s2)))) (('simple-command ('word s1) (('word s2) ...)) `(append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2))))) @@ -202,7 +200,6 @@ copyleft. (define (sh-exec ast) (define (exec cmd) (local-eval cmd (the-environment))) - (let* (;(print (format (current-error-port) "parsed: ~s\n" ast)) (ast (transform ast)) ;(print (format (current-error-port) "transformed: ~s\n" ast)) diff --git a/sh/pipe.scm b/sh/pipe.scm index acc8b86..1e1a6c4 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -83,10 +83,10 @@ (setpgid pid pgid) pgid)) -(define (job-add-process job pid command) +(define (job-add-process fg? job pid command) (let ((pgid (add-to-process-group job pid))) (set-job-pgid! job pgid) - (tcsetpgrp (current-error-port) pgid) + (if fg? (tcsetpgrp (current-error-port) pgid)) (set-job-processes! job (cons (make-process pid command #f) (job-processes job))))) (define (job-control-init) @@ -112,63 +112,63 @@ (define (exec* command) ;; list of strings (apply execlp (cons (car command) command))) -(define (setup-process job) - (tcsetpgrp (current-error-port) (add-to-process-group job (getpid))) - (map (cut sigaction <> SIG_DFL) - (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) +(define (setup-process fg? job) + (when (isatty? (current-error-port)) + (when fg? (tcsetpgrp (current-error-port) (add-to-process-group job (getpid)))) + (map (cut sigaction <> SIG_DFL) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD))) (fdes->inport 0) (map fdes->outport '(1 2))) ;; reset stdin/stdout/stderr -(define (spawn-source job interactive? command) +(define (spawn-source fg? job command) (receive (r w) (pipe*) (let ((pid (primitive-fork))) (cond ((= 0 pid) (close r) - (setup-process job) + (setup-process fg? job) (move->fdes w 1) (exec* command)) (#t - (job-add-process job pid command) + (job-add-process fg? job pid command) (close w) r))))) -(define (spawn-filter job interactive? src command) +(define (spawn-filter fg? job src command) (receive (r w) (pipe*) (let ((pid (primitive-fork))) (cond ((= 0 pid) - (setup-process job) + (setup-process fg? job) (move->fdes src 0) (close r) (move->fdes w 1) (exec* command)) (#t - (job-add-process job pid command) + (job-add-process fg? job pid command) (close w) r))))) -(define (spawn-sink job interactive? src command) +(define (spawn-sink fg? job src command) (let ((pid (primitive-fork))) (cond ((= 0 pid) - (setup-process job) - (and src (move->fdes src 0)) + (setup-process fg? job) + (if src (move->fdes src 0)) (exec* command)) (#t - (job-add-process job pid command) + (job-add-process fg? job pid command) (and src (close src)))))) -(define (pipeline . commands) - (let* ((interactive? (isatty? (current-error-port))) - (index (+ 1 (length job-table))) +(define (pipeline fg? . commands) + (let* ((index (+ 1 (length job-table))) (job (make-job index #f '()))) (if (> (length commands) 1) - (let loop ((src (spawn-source job interactive? (car commands))) + (let loop ((src (spawn-source fg? job (car commands))) (commands (cdr commands))) (if (null? (cdr commands)) - (spawn-sink job interactive? src (car commands)) - (loop (spawn-filter job interactive? src (car commands)) + (spawn-sink fg? job src (car commands)) + (loop (spawn-filter fg? job src (car commands)) (cdr commands)))) - (spawn-sink job interactive? #f (car commands))) + (spawn-sink fg? job #f (car commands))) (set! job-table (cons job job-table)) - (wait job))) + (if fg? (wait job)))) (define (disjoin . predicates) (lambda (. arguments)