From b496bba407a6d57beced6a6598b9032095993d85 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter@more-magic.net>
Date: Sun, 30 Sep 2012 19:46:42 +0100
Subject: First stab at basic scsh interface.  Currently can fork off
 subprocesses and run processess synchronously

---
 scsh-process.scm | 87 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 87 insertions(+)
 create mode 100644 scsh-process.scm

(limited to '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
-- 
cgit v1.2.3