awk macro: warn about invalid var use in rng forms.

The awk macro abruptly relocates rng forms out of their
apparent scope. Therefore, code like this is wrong:

  (awk ((let ((x t))
          (rng t x))
        (action)))

The rng form is transformed and relocated to a scope in which
the let is not visible. This is a problem worth warning about.

In the above case, there will also be a warning about the
variable x being unbound, which might alerts the programmer
to the problem. However, in cases where there is yet another
binding of x introduced via :let or outside of awk, that
warning wll not occur: the code motion will silently cause
x to refer to the wrong x:

  (awk (:let (x nil))
       ((let ((x t))
          (rng 1 x)) ;; refers to the (x nil) binding!!!
        (action)))

  (let ((x nil))
    (awk ((let ((x t))
            (rng 1 x)) ;; refers to the (x 4) binding!!!
          (action))))

Now there is a warning for this situation.

* share/txr/stdlib/awk.tl (sys:awk-compile-time): New slot,
outer-env.
(sys:awk-expander): Takes an env parameter, which is stored
into the new slot of the awk-compile-time structure.
(sys:awk-code-move-check): New function.
(sys:awk-mac-let): Use sys:expand-with-free-refs to expand
the rng forms, capturing the extra information which enables
the implementation of the warning. The rng variants are
refactored to pass the original form to the sys:rng
expander. This allows the diagnostic to display the original
rng form.
(awk): Parameter e renamed to outer-env, and passed to
sys:awk-expander.

1 files changed, 50 insertions, 30 deletions

diff --git a/share/txr/stdlib/awk.tl b/share/txr/stdlib/awk.tl
index 90f9e8b0..4808cb45 100644
--- a/share/txr/stdlib/awk.tl
+++ b/share/txr/stdlib/awk.tl
@@ -60,7 +60,8 @@
   (nranges 0)
   (rng-rec-temp (gensym))
   rng-expr-temps
-  rng-exprs)
+  rng-exprs
+  outer-env)
 
 (defmeth sys:awk-state rec-to-f (self)
   (cond
@@ -215,8 +216,8 @@
                                           (progn ,*body)))
           stream-var))))
 
-(defun sys:awk-expander (clauses)
-  (let ((awc (new sys:awk-compile-time)))
+(defun sys:awk-expander (outer-env clauses)
+  (let ((awc (new sys:awk-compile-time outer-env outer-env)))
     (each ((cl clauses))
       (tree-case cl
         ((pattern . actions) (caseql pattern
@@ -267,6 +268,13 @@
          awc.cond-actions (nreverse awc.cond-actions))
     awc))
 
+(defun sys:awk-code-move-check (awc aws-sym form suspicious-vars)
+  (when suspicious-vars
+    (compile-warning form "~!form ~s\n\
+                           is moved out of the apparent scope\n\
+                           and thus cannot refer to variables ~s"
+                     form suspicious-vars)))
+
 (defmacro sys:awk-mac-let (awc aws-sym . body)
   ^(symacrolet ((rec (rslot ,aws-sym 'rec 'rec-to-f))
                 (orec (rslot ,aws-sym 'orig-rec 'rec-to-f))
@@ -286,41 +294,53 @@
                 (ors (qref ,aws-sym ors)))
      (macrolet ((next () '(return-from :awk-rec))
                 (next-file () '(return-from :awk-file))
-                (sys:rng (style from-expr to-expr :env e)
-                  (let ((ix (pinc (qref ,awc nranges)))
+                (sys:rng (form from-expr to-expr :env e)
+                  (let ((style (car form))
+                        (ix (pinc (qref ,awc nranges)))
                         (rng-temp (gensym))
                         (from-expr-ex (sys:expand from-expr e))
                         (to-expr-ex (sys:expand to-expr e))
                         (flag-old (gensym))
                         (flag-new (gensym)))
-                    (push rng-temp (qref ,awc rng-expr-temps))
-                    (push ^(placelet ((flag (vecref (qref ,',aws-sym rng-vec) ,ix)))
-                             (let* ((,flag-old flag) ,flag-new)
-                               (when (or ,flag-old ,from-expr-ex)
-                                 (set ,flag-new t))
-                               (when (and ,flag-new ,to-expr-ex)
-                                 (set ,flag-new nil))
-                               ,*(caseq style
-                                   (rng ^((or (set flag ,flag-new) ,flag-old)))
-                                   (-rng- ^((and (set flag ,flag-new) ,flag-old)))
-                                   (rng- ^((set flag ,flag-new)))
-                                   (-rng ^((set flag ,flag-new) ,flag-old)))))
-                          (qref ,awc rng-exprs))
-                    rng-temp))
-                (rng (from-expr to-expr)
-                  ^(sys:rng rng
+                    (tree-bind ((from-expr-ex fe-fv fe-ff fe-ev fe-ef)
+                                (to-expr-ex te-fv te-ff te-ev te-ef))
+                               (list
+                                 (sys:expand-with-free-refs from-expr e
+                                                            ,awc.outer-env)
+                                 (sys:expand-with-free-refs to-expr e
+                                                            ,awc.outer-env))
+                      (sys:awk-code-move-check ,awc ',aws-sym form
+                                               (set-diff fe-ev fe-fv))
+                      (sys:awk-code-move-check ,awc ',aws-sym form
+                                               (set-diff te-ev te-fv))
+                      (push rng-temp (qref ,awc rng-expr-temps))
+                      (push ^(placelet ((flag (vecref (qref ,',aws-sym rng-vec) ,ix)))
+                               (let* ((,flag-old flag) ,flag-new)
+                                 (when (or ,flag-old ,from-expr-ex)
+                                   (set ,flag-new t))
+                                 (when (and ,flag-new ,to-expr-ex)
+                                   (set ,flag-new nil))
+                                 ,*(caseq style
+                                     (rng ^((or (set flag ,flag-new) ,flag-old)))
+                                     (-rng- ^((and (set flag ,flag-new) ,flag-old)))
+                                     (rng- ^((set flag ,flag-new)))
+                                     (-rng ^((set flag ,flag-new) ,flag-old)))))
+                            (qref ,awc rng-exprs))
+                      rng-temp)))
+                (rng (:form form from-expr to-expr)
+                  ^(sys:rng ,form
                             (sys:awk-test ,from-expr ,(qref ,awc rng-rec-temp))
                             (sys:awk-test ,to-expr ,(qref ,awc rng-rec-temp))))
-                (-rng (from-expr to-expr)
-                  ^(sys:rng -rng
+                (-rng (:form form from-expr to-expr)
+                  ^(sys:rng ,form
                             (sys:awk-test ,from-expr ,(qref ,awc rng-rec-temp))
                             (sys:awk-test ,to-expr ,(qref ,awc rng-rec-temp))))
-                (rng- (from-expr to-expr)
-                  ^(sys:rng rng-
+                (rng- (:form form from-expr to-expr)
+                  ^(sys:rng ,form
                             (sys:awk-test ,from-expr ,(qref ,awc rng-rec-temp))
                             (sys:awk-test ,to-expr ,(qref ,awc rng-rec-temp))))
-                (-rng- (from-expr to-expr)
-                  ^(sys:rng -rng-
+                (-rng- (:form form from-expr to-expr)
+                  ^(sys:rng ,form
                             (sys:awk-test ,from-expr ,(qref ,awc rng-rec-temp))
                             (sys:awk-test ,to-expr ,(qref ,awc rng-rec-temp))))
                 (ff (. opip-args)
@@ -351,8 +371,8 @@
 (defun sys:awk-fun-shadowing-env (up-env)
   (make-env nil '((prn . sys:special)) up-env))
 
-(defmacro awk (:env e . clauses)
-  (let ((awc (sys:awk-expander clauses)))
+(defmacro awk (:env outer-env . clauses)
+  (let ((awc (sys:awk-expander outer-env clauses)))
     (with-gensyms (aws-sym awk-begf-fun awk-fun awk-endf-fun awk-retval)
       (let* ((p-actions-xform-unex (mapcar (aret ^(when (sys:awk-test ,@1 rec)
                                                     ,*@rest))
@@ -360,7 +380,7 @@
              (p-actions-xform (sys:expand
                                 ^(sys:awk-mac-let ,awc ,aws-sym
                                    ,*p-actions-xform-unex)
-                                (sys:awk-fun-shadowing-env e))))
+                                (sys:awk-fun-shadowing-env outer-env))))
         ^(block ,(or awc.name 'awk)
            (let* (,*awc.lets ,awk-retval
                   (,aws-sym (new sys:awk-state