From f9190b5ce9aa34980c184c87d536c1e37c0f7ef9 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 28 Oct 2016 06:31:36 -0700
Subject: 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.
---
 share/txr/stdlib/awk.tl |  44 +++++++++++++-
 txr.1                   | 154 ++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 196 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))))))))
diff --git a/txr.1 b/txr.1
index e3cf995b..f9f57363 100644
--- a/txr.1
+++ b/txr.1
@@ -40579,6 +40579,160 @@ is
   (awk ((fconv - : iz)))
 .cble
 
+.coNP Macros @, -> @, ->> @, <- @ !> and @ <!
+.synb
+.mets (-> < path << form *)
+.mets (->> < path << form *)
+.mets (<- < path << form *)
+.mets (!> < command << form *)
+.mets (<! < command << form *)
+.syne
+.desc
+These awk macros provide convenient redirection of output and input to and from
+files and commands.
+
+When at least one
+.meta form
+argument is present, the functions
+.codn -> ,
+.code ->>
+and
+.code !>
+evaluate each
+.meta form
+in a dynamic environment in which the
+.code *stdout*
+variable is bound to a file output stream, for the first two
+functions, or output command pipe in the case of the last one.
+
+Similarly, when at least
+.meta form
+argument is present, the remaining functions
+.code <-
+and
+.code <!
+evaluate each
+.meta form
+in a dynamic environment in which
+.code *stdin*
+is bound to to a file input stream or input command pipe, respectively.
+
+The
+.meta path
+and
+.meta command
+arguments are treated as forms, and evaluated.
+They should evaluate to strings.
+
+The first evaluation of one of these macros for a given
+.meta path
+or
+.meta command
+being used in a particular direction (input or output) and type (file or
+command) creates a stream.  That stream is then associated with the given
+.meta path
+or
+.meta command
+string, together with the direction and type. Upon a subsequent evaluation
+of one of these macros for the same
+.meta path
+or
+.meta command
+string, direction and type, a new stream is not opened; rather, the
+previously associated stream is used.
+
+The
+.code ->
+macro indicates that the file named
+.meta path
+is to be opened for writing and overwritten, or created if it doesn't exist.
+The
+.code ->>
+macro indicates that the file named by
+.meta path
+is to be opened in append mode, created if necessary.
+The
+.code <-
+macro indicates that the file given by
+.meta path
+is to be opened for reading.
+
+The
+.code !>
+macro indicates that
+.meta command
+is to be opened as an output command pipe. The
+.code <!
+macro indicates that
+.meta command
+is to be opened as an input command pipe.
+
+If any of these macros is invoked without any
+.meta form
+arguments, then it yields the stream object associated with
+.meta path
+or
+.meta command
+argument, direction and type. If the association doesn't exist,
+the stream is first created.
+
+If
+.meta form
+arguments are present, then the value of the last one is yielded
+as a value, except in the case when the last form yields the
+.code :close
+keyword symbol.
+
+If the last
+.meta form
+yields the
+.code :close
+keyword symbol, the the association between the
+.meta path
+or
+.metn command ,
+direction and type and the stream is removed, and the stream
+is closed. In this case, the result value of the macro isn't the
+.code :close
+symbol, but rather the return value of the
+.meta close-stream
+call that is implicitly applied to the stream.
+
+Even if there is only one
+.meta form
+which yields
+.codn :close ,
+the stream is created, if it doesn't exist prior to the macro
+invocation.
+
+In each invocation of these macros, after every
+.meta form
+is evaluated, the stream is implicitly flushed, if it is an output stream.
+
+The association between the
+.meta pipe
+or
+.meta command
+strings, direction and type is scoped to the inner-most enclosing
+.code awk
+macro. An inner
+.code awk
+macro cannot refer to the associations established in an outer
+.code awk
+macro. An outer
+.code awk
+macro can, of course, obtain an association's stream object and communicate
+that stream to the nested macro where it can be used.
+
+When the
+.meta awk
+surrounding macro terminates, all of the streams opened by these
+redirection macros are closed, without breaking those associations.
+If lexical closures are captured inside the macro, and then invoked after the
+macro has terminated, and inside those closures the redirection macros are
+used, those macro instances will with closed stream objects, and so
+attempts to perform I/O will fail.
+
 .coNP Examples of @ awk Macro Usage
 The following examples are
 .code awk
-- 
cgit v1.2.3