andrius
/
gash
mirror of https://git.savannah.gnu.org/git/gash.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

background via "&"

This commit is contained in:
Rutger van Beusekom 2016-11-01 11:25:36 +01:00
parent 1b31587c9b
commit 1837431f0c
2 changed files with 33 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
sh/anguish.scm
View File

@ -52,7 +52,6 @@
(let ((ast- (transform ast))) (let ((ast- (transform ast)))
(format (current-output-port) "parsed : ~s\n\n" ast) (format (current-output-port) "parsed : ~s\n\n" ast)
(format (current-output-port) "prepared : ~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))
(#t (#t
(sh-exec ast))))))) (sh-exec ast)))))))
@ -88,7 +87,6 @@ copyleft.
(add-history line)) (add-history line))
(run ast)) (run ast))
(loop (readline (prompt))))))))) (loop (readline (prompt)))))))))
(activate-readline)
(clear-history) (clear-history)
(read-history HOME) (read-history HOME)
(with-readline-completion-function completion thunk) (with-readline-completion-function completion thunk)
@ -114,7 +112,7 @@ copyleft.
(map foo o)) (map foo o))
;; TODO: add braces and pattern ending with / ;; TODO: add braces
(define (glob pattern) ;; pattern -> list of path (define (glob pattern) ;; pattern -> list of path
(define (glob? pattern) (define (glob? pattern)
@ -161,17 +159,17 @@ copyleft.
(('if rest ...) ast) (('if rest ...) ast)
(_ #f))) (_ #f)))
(define (background ast)
(match ast
(('pipeline fg rest ...) `(pipeline #f ,@rest))
(_ ast)))
;; transform ast -> list of expr ;; transform ast -> list of expr
;; such that (map eval expr) ;; such that (map eval expr)
;; (define (background ast)
;; (match ast
;; (('pipeline fg rest ...) `(pipeline #f ,@rest))
;; (_ ast)))
(define (transform ast) (define (transform ast)
(match ast (match ast
;(('script term "&") (background (transform term))) (('script term "&") (list (background (transform term))))
(('script term) (list (transform term))) (('script term) (list (transform term)))
(('script terms ...) (transform terms)) (('script terms ...) (transform terms))
((('term command)) (list (transform command))) ((('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)))) (('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)))) (('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)) (('do-group "do" (command "done")) (transform command))
(('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline ,command)))) (('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,command))))
(('pipeline command piped-commands) `(pipeline ,(transform command) ,@(transform piped-commands))) (('pipeline command piped-commands) `(pipeline #t ,(transform command) ,@(transform piped-commands)))
(('simple-command ('word s)) `(glob ,(transform s))) (('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)) (glob ,(transform s2))))
(('simple-command ('word s1) (('word s2) ...)) `(append (glob ,(transform s1)) (append-map glob (list ,@(map 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 (sh-exec ast)
(define (exec cmd) (define (exec cmd)
(local-eval cmd (the-environment))) (local-eval cmd (the-environment)))
(let* (;(print (format (current-error-port) "parsed: ~s\n" ast)) (let* (;(print (format (current-error-port) "parsed: ~s\n" ast))
(ast (transform ast)) (ast (transform ast))
;(print (format (current-error-port) "transformed: ~s\n" ast)) ;(print (format (current-error-port) "transformed: ~s\n" ast))

48
sh/pipe.scm
View File

@ -83,10 +83,10 @@
(setpgid pid pgid) (setpgid pid pgid)
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))) (let ((pgid (add-to-process-group job pid)))
(set-job-pgid! job pgid) (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))))) (set-job-processes! job (cons (make-process pid command #f) (job-processes job)))))
(define (job-control-init) (define (job-control-init)
@ -112,63 +112,63 @@
(define (exec* command) ;; list of strings (define (exec* command) ;; list of strings
(apply execlp (cons (car command) command))) (apply execlp (cons (car command) command)))
(define (setup-process job) (define (setup-process fg? job)
(tcsetpgrp (current-error-port) (add-to-process-group job (getpid))) (when (isatty? (current-error-port))
(map (cut sigaction <> SIG_DFL) (when fg? (tcsetpgrp (current-error-port) (add-to-process-group job (getpid))))
(list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) (map (cut sigaction <> SIG_DFL)
(list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)))
(fdes->inport 0) (map fdes->outport '(1 2))) ;; reset stdin/stdout/stderr (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*) (receive (r w) (pipe*)
(let ((pid (primitive-fork))) (let ((pid (primitive-fork)))
(cond ((= 0 pid) (close r) (cond ((= 0 pid) (close r)
(setup-process job) (setup-process fg? job)
(move->fdes w 1) (move->fdes w 1)
(exec* command)) (exec* command))
(#t (#t
(job-add-process job pid command) (job-add-process fg? job pid command)
(close w) (close w)
r))))) r)))))
(define (spawn-filter job interactive? src command) (define (spawn-filter fg? job src command)
(receive (r w) (pipe*) (receive (r w) (pipe*)
(let ((pid (primitive-fork))) (let ((pid (primitive-fork)))
(cond ((= 0 pid) (cond ((= 0 pid)
(setup-process job) (setup-process fg? job)
(move->fdes src 0) (move->fdes src 0)
(close r) (close r)
(move->fdes w 1) (move->fdes w 1)
(exec* command)) (exec* command))
(#t (#t
(job-add-process job pid command) (job-add-process fg? job pid command)
(close w) (close w)
r))))) r)))))
(define (spawn-sink job interactive? src command) (define (spawn-sink fg? job src command)
(let ((pid (primitive-fork))) (let ((pid (primitive-fork)))
(cond ((= 0 pid) (cond ((= 0 pid)
(setup-process job) (setup-process fg? job)
(and src (move->fdes src 0)) (if src (move->fdes src 0))
(exec* command)) (exec* command))
(#t (#t
(job-add-process job pid command) (job-add-process fg? job pid command)
(and src (close src)))))) (and src (close src))))))
(define (pipeline . commands) (define (pipeline fg? . commands)
(let* ((interactive? (isatty? (current-error-port))) (let* ((index (+ 1 (length job-table)))
(index (+ 1 (length job-table)))
(job (make-job index #f '()))) (job (make-job index #f '())))
(if (> (length commands) 1) (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))) (commands (cdr commands)))
(if (null? (cdr commands)) (if (null? (cdr commands))
(spawn-sink job interactive? src (car commands)) (spawn-sink fg? job src (car commands))
(loop (spawn-filter job interactive? src (car commands)) (loop (spawn-filter fg? job src (car commands))
(cdr commands)))) (cdr commands))))
(spawn-sink job interactive? #f (car commands))) (spawn-sink fg? job #f (car commands)))
(set! job-table (cons job job-table)) (set! job-table (cons job job-table))
(wait job))) (if fg? (wait job))))
(define (disjoin . predicates) (define (disjoin . predicates)
(lambda (. arguments) (lambda (. arguments)