diff options
| -rw-r--r-- | scsh-process.meta | 10 | ||||
| -rw-r--r-- | scsh-process.scm | 87 | ||||
| -rw-r--r-- | scsh-process.setup | 2 |
3 files changed, 99 insertions, 0 deletions
diff --git a/scsh-process.meta b/scsh-process.meta new file mode 100644 index 0000000..f38b7dc --- /dev/null +++ b/scsh-process.meta @@ -0,0 +1,10 @@ +;;; scsh-process.meta -*- Scheme -*- + +((synopsis "") + (author "Peter Bex") + (category os) + (license "BSD") + (doc-from-wiki) + ;(depends) + ;(test-depends test) + (files "scsh-process.meta" "scsh-process.setup" "scsh-process.scm")) diff --git a/scsh-process.scm b/scsh-process.scm new file mode 100644 index 0000000..ca747e2 --- /dev/null +++ b/scsh-process.scm @@ -0,0 +1,87 @@ +;; +;; SCSH process form notation +;; +;; See http://www.scsh.net/docu/html/man-Z-H-3.html#node_chap_2 +;; +;; Some minor changes due to Chicken- and R7RS-incompatible identifiers: +;; | was changed to pipe, |+ was changed to pipe+ +;; +;; || wasn't changed, but it's really the zero-length symbol +;; + +(module scsh-process + ((& maybe-symbol->string) (run maybe-symbol->string) (exec-epf maybe-symbol->string) + exec-path) + +(import chicken scheme data-structures) + +(use posix) + +(define-syntax & + (syntax-rules () + ((_ ?epf ...) + (process-fork (lambda () + (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)) + (exec-epf ?epf ...))))))) + +(define-syntax run + (syntax-rules () + ((_ ?epf ...) + ;; We reorder the values as they make more sense this way for SCSH compat: + ;; scsh returns just the exit code, and conveniently we allow MV in single + ;; value continuations, which makes it compatible. + (receive (pid normal-exit? exit-status) + (process-wait (& ?epf ...)) + (values exit-status normal-exit? pid))))) + +(define (maybe-symbol->string s) + (if (symbol? s) (symbol->string s) s)) + +;; Perhaps this should really be a procedure? +(define-syntax setup-redirection + (syntax-rules (< > << >> = - stdports) + ((_ (< ?file-name)) (setup-redirection (< 0 ?file-name))) + ((_ (> ?file-name)) (setup-redirection (> 1 ?file-name))) + ((_ (<< ?object)) (setup-redirection (<< 0 ?object))) + ((_ (>> ?object)) (setup-redirection (>> 1 ?object))) + ((_ (< ?fd ?file-name)) + (duplicate-fileno (file-open (maybe-symbol->string `?file-name) + open/rdonly) + `?fd)) + ((_ (> ?fd ?file-name)) + (duplicate-fileno (file-open (maybe-symbol->string `?file-name) + (fx+ open/wronly open/creat)) + `?fd)) + ((_ (<< ?fd ?object)) (error "<< currently not implemented")) + ((_ (>> ?fd ?object)) (error ">> currently not implemented")) + ((_ (- ?fd/port)) + (let ((o `?fd/port)) + (cond + ((fixnum? ?fd/port) (file-close o)) + ((output-port? ?fd/port) (close-output-port o)) + ((input-port? ?fd/port) (close-input-port o)) + (else (error "Can only close i/o-ports and file descriptor numbers" o))))) + ((_ stdports) + (begin (setup-redirection (= 0 (current-input-port))) + (setup-redirection (= 1 (current-output-port))) + (setup-redirection (= 2 (current-error-port))))) + ((_ ?arg0 ...) + (syntax-error "Invalid redirection pattern: " `?arg0 ...)))) + +;; The most "core" syntax form +(define-syntax exec-epf + (syntax-rules () + ((_ (?prog ?arg0 ...) ?redir0 ...) + (begin + (setup-redirection ?redir0) ... + (exec-path `?prog `?arg0 ...))))) + +;; TODO: Perhaps expose environment, and mess around with the path so that +;; execve can be used in a sensible way? Scsh has its own PATH, so we could +;; use something similar to that, but it's more work. +(define (exec-path prog . args) + (process-execute (maybe-symbol->string prog) (map maybe-symbol->string args))) +)
\ No newline at end of file diff --git a/scsh-process.setup b/scsh-process.setup new file mode 100644 index 0000000..50c62e1 --- /dev/null +++ b/scsh-process.setup @@ -0,0 +1,2 @@ +;; -*- Scheme -*- +(standard-extension scsh-process 0.1)
\ No newline at end of file |