New awk capability: file/pipe I/O redirection.

* share/txr/stdlib/awk.tl (sys:awk-state): New slot, streams.
Holds hash table of open streams. New :fini finalizer
which closes all streams.
(sys:awk-state ensure-stream, sys:awk-state close-or-flush):
New methods.
(sys:awk-redir): New macro.
(sys:awk-let): Bind new local macros ->, ->>, <-, !> and !<.
(awk): Call finalizers on awk state to get all streams
to close.

* txr.1: Document new awk macros.

1 files changed, 42 insertions, 2 deletions

diff --git a/share/txr/stdlib/awk.tl b/share/txr/stdlib/awk.tl
index 84688768..760c92ac 100644
--- a/share/txr/stdlib/awk.tl
+++ b/share/txr/stdlib/awk.tl
@@ -39,6 +39,10 @@
   rec orig-rec fields nf
   rng-vec (rng-n 0)
   par-mode par-mode-fs par-mode-prev-fs
+  (streams (hash :equal-based))
+  (:fini (self)
+    (dohash (k v self.streams)
+      (close-stream v)))
   (:postinit (self)
     (if (plusp self.rng-n)
       (set self.rng-vec (vector self.rng-n)))
@@ -151,11 +155,36 @@
     (t (put-string self.rec)
        (put-string self.ors))))
 
+(defmeth sys:awk-state ensure-stream (self kind path mode)
+  (hash-update-1 self.streams
+                 ^(,kind ,path)
+                 (do or @1 (caseq kind
+                             (:inf (open-file path "r"))
+                             (:outf (open-file path "w"))
+                             (:inp (open-command path "r"))
+                             (:outp (open-command path "w"))))
+                 nil))
+
+(defmeth sys:awk-state close-or-flush (self stream kind path val)
+  (cond
+    ((eq val :close) (whenlet ((s (del [self.streams ^(,kind ,path)])))
+                       (close-stream s)))
+    ((memq kind '(:outf outp)) (flush-stream stream) val)
+    (val)))
+
 (defun sys:awk-test (val rec)
   (caseq (typeof val)
     ((regex fun) (call val rec))
     (t val)))
 
+(defmacro sys:awk-redir (aws-sym stream-var kind mode path body)
+  (with-gensyms (res-sym)
+    ^(let ((,stream-var (qref ,aws-sym (ensure-stream ,kind ,path, mode))))
+       ,(if body
+          ^(qref ,aws-sym (close-or-flush ,stream-var ,kind ,path
+                                          (progn ,*body)))
+          stream-var))))
+
 (defun sys:awk-expander (clauses)
   (let ((awc (new sys:awk-compile-time)))
     (each ((cl clauses))
@@ -253,7 +282,17 @@
                   ^(symacrolet ((f (rslot ,',aws-sym 'fields 'f-to-rec)))
                      (set f (mapcar (opip ,*opip-args) f))))
                 (fconv (. conv-args)
-                  ^(set f (sys:conv (,*conv-args) f))))
+                  ^(set f (sys:conv (,*conv-args) f)))
+                (-> (path . body)
+                  ^(sys:awk-redir ,',aws-sym *stdout* :outf "w" ,path ,body))
+                (->> (path . body)
+                  ^(sys:awk-redir ,',aws-sym *stdout* :apf "a" ,path ,body))
+                (<- (path . body)
+                  ^(sys:awk-redir ,',aws-sym *stdin* :inf "r" ,path ,body))
+                (!> (path . body)
+                  ^(sys:awk-redir ,',aws-sym *stdout* :outp "w" ,path ,body))
+                (<! (path . body)
+                  ^(sys:awk-redir ,',aws-sym *stdin* :inp "w" ,path ,body)))
        ,*body)))
 
 (defmacro awk (:env e . clauses)
@@ -298,5 +337,6 @@
                                              awk-begf-fun)
                                           ,(if awc.end-file-actions
                                              awk-endf-fun))))
-                     (set ,awk-retval (progn ,*awc.end-actions)))
+                     (set ,awk-retval (progn ,*awc.end-actions))
+                     (call-finalizers ,aws-sym))
                    ,awk-retval))))))))