diff options
| author | Peter Bex <peter@more-magic.net> | 2012-09-30 20:34:16 +0100 | 
|---|---|---|
| committer | Peter Bex <peter@more-magic.net> | 2012-09-30 20:34:16 +0100 | 
| commit | 5b84da15a22d21fcf023cef5e88dc384f77168af (patch) | |
| tree | 5cfc0e7cd80b0a82dbff1c55c69b53816a95f6c3 | |
| parent | b496bba407a6d57beced6a6598b9032095993d85 (diff) | |
| download | scsh-process-5b84da15a22d21fcf023cef5e88dc384f77168af.tar.gz | |
Implement scheme begin forms, filedescriptor dup()ing and use print-error-message to print the error message, then exit
| -rw-r--r-- | scsh-process.scm | 16 | 
1 files changed, 14 insertions, 2 deletions
| diff --git a/scsh-process.scm b/scsh-process.scm index ca747e2..74727ce 100644 --- a/scsh-process.scm +++ b/scsh-process.scm @@ -24,7 +24,8 @@                       (handle-exceptions exn                         ;; TODO: Figure out how SCSH does this.  It shows the error                         ;; on stderr in the REPL, but then still quits it. -                       (begin ((##sys#error-handler) exn) (exit 1)) +                       ;; If we just invoke current-handler, it'll get a second REPL +                       (begin (print-error-message exn) (exit 1))                         (exec-epf ?epf ...)))))))  (define-syntax run @@ -57,6 +58,12 @@                         `?fd))      ((_ (<< ?fd ?object)) (error "<< currently not implemented"))      ((_ (>> ?fd ?object)) (error ">> currently not implemented")) +    ((_ (= ?fd-from ?fd/port-to)) +     (let* ((fd/port-to ?fd/port-to)    ; Evaluate once +            (fd-to (if (port? fd/port-to) +                       (port->fileno fd/port-to) +                       fd/port-to))) +       (duplicate-fileno ?fd-from fd-to)))      ((_ (- ?fd/port))       (let ((o `?fd/port))         (cond @@ -73,7 +80,12 @@  ;; The most "core" syntax form  (define-syntax exec-epf -  (syntax-rules () +  (syntax-rules (begin) +    ((_ (begin ?expr0 ...)) +     (begin (setup-redirection (= 0 (current-input-port))) +            (setup-redirection (= 1 (current-output-port))) +            (setup-redirection (= 2 (current-error-port))) +            ?expr0 ...))      ((_ (?prog ?arg0 ...) ?redir0 ...)       (begin         (setup-redirection ?redir0) ... | 
