summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--scsh-process.meta10
-rw-r--r--scsh-process.scm87
-rw-r--r--scsh-process.setup2
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