From fee393aaddfe51f9a3fdedf05e270065bf5aa8a1 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 19 Oct 2016 00:53:14 +0200 Subject: [PATCH] cleanup --- sh/anguish.scm | 2 +- sh/pipe.scm | 107 +++++-------------------------------------------- 2 files changed, 11 insertions(+), 98 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 4a4641f..0d5789c 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -145,7 +145,7 @@ copyleft. (define (builtin ast) - (format (current-error-port) "builtin: ~s\n" ast) + ;;(format (current-error-port) "builtin: ~s\n" ast) (match ast (('append ('glob "cd") arg) `(apply chdir ,arg)) (('for-each rest ...) ast) diff --git a/sh/pipe.scm b/sh/pipe.scm index ec15b89..b19dd9a 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -19,12 +19,11 @@ (newline)) (define-record-type - (make-process pid command status state) + (make-process pid command status) process? (pid process-pid) (command process-command) - (status process-status set-process-status!) - (state process-state set-process-state!)) ;; '(running stopped completed terminated) + (status process-status set-process-status!)) (define-record-type (make-job id pgid processes) @@ -36,12 +35,10 @@ (define job-table '()) ;; list of (define (status->state status) - (cond ((status:exit-val status) - 'completed) - ((status:term-sig status) - 'terminated) - ((status:stop-sig status) - 'stopped))) + (cond ((status:exit-val status) 'completed) + ((status:term-sig status) 'terminated) + ((status:stop-sig status) 'stopped) + (#t 'running))) (define (job-status job) (process-status (car (job-processes job)))) @@ -49,16 +46,10 @@ (define (job-update job pid status) (unless (= 0 pid) (let ((proc (find (compose (cute eqv? pid <>) process-pid) (job-processes job)))) - (set-process-status! proc status) - (set-process-state! proc (status->state status))))) + (set-process-status! proc status)))) (define (job-running? job) - (find (compose (cute eq? 'running <>) process-state) (job-processes job))) - -;; (define (job-at index) -;; (let ((len (length job-table))) -;; (if (or (> index len) (< index 0)) #f -;; (list-ref job-table (- len index))))) + (find (compose not process-status) (job-processes job))) (define (add-to-process-group job pid) (let* ((pgid (job-pgid job)) @@ -70,7 +61,7 @@ (let ((pgid (add-to-process-group job pid))) (set-job-pgid! job pgid) (tcsetpgrp (current-error-port) pgid) - (set-job-processes! job (cons (make-process pid command #f 'running) (job-processes job))))) + (set-job-processes! job (cons (make-process pid command #f) (job-processes job))))) (define (job-control-init) (let* ((interactive? (isatty? (current-error-port))) @@ -156,86 +147,8 @@ (job-update job pid status) (if (job-running? job) (loop)))) (tcsetpgrp (current-error-port) (getpid)) - (pretty-print job-table) + ;;(pretty-print job-table) (job-status job))) ;;(pipeline (list "ls" "/") ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; (define (job-launch command fg?) ;; todo: integrate into pipeline -;; (let* ((interactive? (isatty? (current-error-port))) -;; (foo (stdout "ISATTY: " interactive?)) -;; (pgid (getpid)) -;; (pid (primitive-fork))) -;; (if (= 0 pid) -;; (when interactive? ;; the child i.e. command -;; (setpgid (getpid) (getpid)) ;; put job in own process group -;; (if fg? (tcsetpgrp (current-error-port) (getpid))) ;; put job in foreground - -;; (map (cut sigaction <> SIG_DFL) -;; (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) - -;; (fdes->inport 0) -;; (map fdes->outport '(1 2)) - -;; (exec* command) -;; (exit 1)) -;; (when interactive? ;; the parent i.e. shell -;; (setpgid pid pid) ;; put job in own process group -;; (tcsetpgrp (current-error-port) pid) ;; put job in foreground -;; (when fg? -;; (waitpid pid WUNTRACED) -;; (tcsetpgrp (current-error-port) (getpid))))))) ;; put shell in foreground - -;; (define (mark-job-status pid status) -;; (if (not (= 0 pid)) -;; (cond ((status:stop-sig status) -;; (set-job-stopped! pid job-table)) -;; ((status:term-sig status) -;; (set-job-terminated! pid job-table)) -;; ((status:exit-val status) -;; (set-job-completed! pid job-table))))) - -;; (define (job-wait job) -;; (let loop () -;; (let* ((status (job-status job)) -;; (pid-status (waitpid WAIT_ANY WUNTRACED)) -;; (pid (car pid-status)) -;; (status (cdr pid-status))) -;; (mark-job-status pid status) -;; (if (eq? status (job-status job)) (loop))))) - -;; (define (set-job-stopped! job-table pid) -;; (set-job-status! (assoc-ref job-table pid) 'stopped)) - -;; (define (set-job-terminated! job-table pid) ;; signal -;; (set-job-status! (assoc-ref job-table pid) 'terminated)) - -;; (define (set-job-completed! job-table pid) ;; exit value -;; (set-job-status! (assoc-ref job-table pid) 'completed)) - -;; (define (notify-job-status job-table) ;; call when prompting, from SIGCHLD handler or -;; (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) -;; (pid (car pid-status)) -;; (status (cdr pid-status))) -;; (mark-job-status pid status))) - -;; (define (job-by-id job-table id) -;; (if (< job-id (length job-table)) -;; (list-ref job-table job-id) -;; #f)) - -;; (define (background job-id) -;; (let ((job (job-by-id job-table job-id))) -;; (if (and job (eq? 'stopped (job-status job))) -;; (kill (- (job-pgid job)) SIGCONT)))) - -;; (define (foreground job-id) -;; (let ((job (job-by-id job-table job-id))) -;; (tcsetpgrp (current-error-port) (job-pgid job)) -;; (if (and job (eq? 'stopped (job-status job))) -;; (kill (- (job-pgid job)) SIGCONT)) -;; (job-wait job) -;; (tcsetpgrp (current-error-port) (getpid))))