First stab at basic scsh interface. Currently can fork off subprocesses and run processess synchronously

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