Implement appending to files

2 files changed, 21 insertions, 8 deletions

diff --git a/scsh-process.scm b/scsh-process.scm
index 6102c4d..57a773e 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -214,19 +214,22 @@
 (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))
+    ((_ (> ?file-name)) (setup-redirection (> 1 ?file-name)))
+    ((_ (>> ?file-name)) (setup-redirection (>> 1 ?file-name)))
     ((_ (> ?fd ?file-name))
      (duplicate-fileno (file-open (maybe-symbol->string `?file-name)
                                   (fx+ open/wronly open/creat))
                        `?fd))
+    ((_ (>> ?fd ?file-name))
+     (duplicate-fileno (file-open (maybe-symbol->string `?file-name)
+                                  (fx+ open/wronly (fx+ open/append open/creat)))
+                       `?fd))
+    ((_ (< ?fd ?file-name))
+     (duplicate-fileno (file-open (maybe-symbol->string `?file-name)
+                                  open/rdonly)
+                       `?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)
diff --git a/tests/run.scm b/tests/run.scm
index 4e3bb8a..df73ac3 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -38,7 +38,17 @@
     (let ((tmpfile (run/file (echo "blah"))))
       (test "Simple run/file"
             "blah\n"
-            (with-input-from-file tmpfile read-all))))
+            (with-input-from-file tmpfile read-all))
+
+      (test "Appending to a file"
+            '("blah" "foo")
+            (begin (run (echo foo) (>> ,tmpfile))
+                   (read-lines tmpfile)))
+      
+      (test "Redirecting from object"
+            '("blah" "foo" "testing, 1 2 3")
+            (run/strings (cat tmpfile -) (<< "testing, 1 2 3")))
+      (delete-file* tmpfile)))
 
   (test-group "Subprocesses"
     (let ((outfile "outfile"))