From 09d682f419016ad906f8448fd2c245e411b5358c Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 8 Sep 2016 22:44:46 -0700
Subject: awk macro: revise rng eval strategy.
awk ranges must evaluate out-of-band after the
record is read, before the patterns and actions
are evaluated.
* share/txr/stdlib/awk.tl (sys:awk-compile-time): New slots,
rng-expr-temps and rng-exprs.
(sys:awk-let): Stash the code for evaluating a range into
the compile-time info into the rng-exprs list, and associate
it with a gensym in the parallel rng-expr-temps list.
Then emit that gensym as the expansion for the rng form.
(awk): Process the pattern code in two steps. First, expand
it, to get it to drop the rng-exprs into the awk compile-time
info structure. Then when generating the final lambda,
wrap an let* around the generated code which
binds the rng-temps with the rng-exprs. This resolves the
gensym references that replaced the ranges. let* is is used
and its bindings are reversed into discovery order because
this supports nested rng syntax. Given (rng x (rng y z)), the
(rng y z) is expanded first, and so its code and temp gensym
are pushed onto their respective lists firsts. The outer
rng's code will thus contain a temp referring to the
code of the inner one.
---
share/txr/stdlib/awk.tl | 67 +++++++++++++++++++++++++++++++------------------
1 file changed, 43 insertions(+), 24 deletions(-)
diff --git a/share/txr/stdlib/awk.tl b/share/txr/stdlib/awk.tl
index d7aa6891..a2d03361 100644
--- a/share/txr/stdlib/awk.tl
+++ b/share/txr/stdlib/awk.tl
@@ -41,7 +41,9 @@
(set self.output (open-file self.output "w")))))
(defstruct sys:awk-compile-time ()
- (nranges 0))
+ (nranges 0)
+ rng-expr-temps
+ rng-exprs)
(defmeth sys:awk-state rec-to-f (self)
(cond
@@ -137,31 +139,48 @@
(macrolet ((next () '(return-from :awk-rec))
(next-file () '(return-from :awk-file))
(prn (. args) ^(qref ,',aws-sym (prn ,*args)))
- (rng (from-expr to-expr)
- (let ((ix (pinc (qref ,awc nranges))))
- ^(symacrolet ((flag (vecref (qref ,',aws-sym rng-vec) ,ix)))
- (cond
- (,from-expr (set flag t))
- (,to-expr (zap flag) t)
- (flag))))))
+ (rng (from-expr to-expr :env e)
+ (let ((ix (pinc (qref ,awc nranges)))
+ (rng-temp (gensym))
+ (from-expr-ex (sys:expand from-expr e))
+ (to-expr-ex (sys:expand to-expr e)))
+ (push rng-temp (qref ,awc rng-expr-temps))
+ (push ^(symacrolet ((flag (vecref (qref ,',aws-sym rng-vec) ,ix)))
+ (cond
+ (,from-expr-ex (set flag t))
+ (,to-expr-ex (zap flag) t)
+ (flag)))
+ (qref ,awc rng-exprs))
+ rng-temp)))
,*body)))
-(defmacro awk (. clauses)
+(defmacro awk (:env e . clauses)
(tree-bind (awc inputs output name lets b-actions e-actions p-actions)
(sys:awk-expander clauses)
(with-gensyms (aws-sym awk-fun awk-retval)
- ^(let* (,*lets ,awk-retval)
- (let ((,awk-fun (lambda (,aws-sym)
- (sys:awk-let ,awc ,aws-sym
- ,*(mapcar (aret ^(when ,@1 ,*@rest)) p-actions))))
- (,aws-sym (new sys:awk-state
- ,*(if inputs ^(inputs (list ,*inputs)))
- ,*(if output ^(output ,output))
- rng-n (macro-time (qref ,awc nranges)))))
- (sys:awk-let ,awc ,aws-sym
- ,*b-actions)
- (block ,name
- (unwind-protect
- (qref ,aws-sym (loop ,awk-fun))
- (set ,awk-retval (progn ,*e-actions)))
- ,awk-retval))))))
+ (let* ((p-actions-xform-unex (mapcar (aret ^(when ,@1 ,*@rest))
+ p-actions))
+ (p-actions-xform (sys:expand
+ ^(sys:awk-let ,awc ,aws-sym
+ ,*p-actions-xform-unex)
+ e)))
+ ^(let* (,*lets ,awk-retval)
+ (let* ((,aws-sym (new sys:awk-state
+ ,*(if inputs ^(inputs (list ,*inputs)))
+ ,*(if output ^(output ,output))
+ rng-n (macro-time (qref ,awc nranges))))
+ (,awk-fun (lambda (,aws-sym)
+ (sys:awk-let ,awc ,aws-sym
+ ,(if awc.rng-exprs
+ ^(let* ,(nreverse
+ (zip awc.rng-expr-temps
+ awc.rng-exprs))
+ ,p-actions-xform)
+ p-actions-xform)))))
+ (sys:awk-let ,awc ,aws-sym
+ ,*b-actions)
+ (block ,name
+ (unwind-protect
+ (qref ,aws-sym (loop ,awk-fun))
+ (set ,awk-retval (progn ,*e-actions)))
+ ,awk-retval)))))))
--
cgit v1.2.3