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)))
(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))

48
sh/pipe.scm
View File

@ -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)