[Guile-commits] 01/02: Add with-lexicals helper; fix bug in (equal? #t (foo) #t)

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 498428fbef63d9159d84f18f719e02927341aa9a
Author: Andy Wingo <address@hidden>
AuthorDate: Wed May 13 14:22:37 2020 +0200

    Add with-lexicals helper; fix bug in (equal? #t (foo) #t)
    
    * module/language/tree-il.scm (with-lexicals): New public helper.
    * .dir-locals.el (with-lexicals): Add indentation rule.
    * module/language/tree-il/compile-bytecode.scm (canonicalize): Use
      with-lexicals.
    * module/language/tree-il/compile-cps.scm (canonicalize): Use
      with-lexicals from tree-il.
    * module/language/tree-il/primitives.scm (chained-comparison-expander):
      Remove duplicate expander definitions for <, <=, and so on.
    * module/language/tree-il/primitives.scm (maybe-simplify-to-eq): Avoid
      inadvertent code duplication by using with-lexicals.
      (expand-chained-comparisons): Likewise.
      (call-with-prompt): Simplify to use with-lexicals.
---
 .dir-locals.el                               |  1 +
 module/language/tree-il.scm                  | 17 ++++++-
 module/language/tree-il/compile-bytecode.scm | 10 ++--
 module/language/tree-il/compile-cps.scm      | 21 ++------
 module/language/tree-il/primitives.scm       | 74 ++++++++++------------------
 5 files changed, 50 insertions(+), 73 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index c987955..3c6519f 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -19,6 +19,7 @@
      (eval . (put 'with-fresh-name-state-from-dfg 'scheme-indent-function 1))
      (eval . (put 'with-cps            'scheme-indent-function 1))
      (eval . (put 'with-cps-constants  'scheme-indent-function 1))
+     (eval . (put 'with-lexicals       'scheme-indent-function 2))
      (eval . (put 'build-cps-term      'scheme-indent-function 0))
      (eval . (put 'build-cps-exp       'scheme-indent-function 0))
      (eval . (put 'build-cps-cont      'scheme-indent-function 0))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 77d6f23..974fce2 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,4 +1,4 @@
-;;;;   Copyright (C) 2009-2014, 2017-2019 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2009-2014, 2017-2020 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -60,6 +60,7 @@
             make-tree-il-folder
             post-order
             pre-order
+            with-lexicals
 
             tree-il=?
             tree-il-hash))
@@ -568,6 +569,20 @@ This is an implementation of `foldts' as described by Andy 
Wingo in
 (define (pre-order f x)
   (pre-post-order f (lambda (x) x) x))
 
+(define-syntax-rule (with-lexical src id . body)
+  (let ((k (lambda (id) . body)))
+    (match id
+      (($ <lexical-ref>) (k id))
+      (_
+       (let ((tmp (gensym "v ")))
+         (make-let src (list 'id) (list tmp) (list id)
+                   (k (make-lexical-ref src 'id tmp))))))))
+(define-syntax with-lexicals
+  (syntax-rules ()
+    ((with-lexicals src () . body) (let () . body))
+    ((with-lexicals src (id . ids) . body)
+     (with-lexical src id (with-lexicals src ids . body)))))
+
 ;; FIXME: We should have a better primitive than this.
 (define (struct-nfields x)
   (/ (string-length (symbol->string (struct-layout x))) 2))
diff --git a/module/language/tree-il/compile-bytecode.scm 
b/module/language/tree-il/compile-bytecode.scm
index 96f5eb8..b8d432f 100644
--- a/module/language/tree-il/compile-bytecode.scm
+++ b/module/language/tree-il/compile-bytecode.scm
@@ -432,12 +432,10 @@
 
        ;; struct-set! needs to return its value.
        (($ <primcall> src 'struct-set! (x idx v))
-        (let ((sym (gensym "v ")))
-          (make-let src (list 'v) (list sym) (list v)
-                    (let ((v (make-lexical-ref src 'v sym)))
-                      (make-seq src
-                                (make-primcall src 'struct-set! (list x idx v))
-                                v)))))
+        (with-lexicals src (v)
+          (make-seq src
+                    (make-primcall src 'struct-set! (list x idx v))
+                    v)))
 
        ;; Transform "ash" to lsh / rsh.
        (($ <primcall> src 'ash (x ($ <const> src (? exact-integer? y))))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 703e9fd..bd2bd77 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -2303,19 +2303,6 @@ integer."
 (define *comp-module* (make-fluid))
 
 (define (canonicalize exp)
-  (define-syntax-rule (with-lexical src id . body)
-    (let ((k (lambda (id) . body)))
-      (match id
-        (($ <lexical-ref>) (k id))
-        (_
-         (let ((v (gensym "v ")))
-           (make-let src (list 'v) (list v) (list id)
-                     (k (make-lexical-ref src 'v v))))))))
-  (define-syntax with-lexicals
-    (syntax-rules ()
-      ((with-lexicals src () . body) (let () . body))
-      ((with-lexicals src (id . ids) . body)
-       (with-lexical src id (with-lexicals src ids . body)))))
   (define (reduce-conditional exp)
     (match exp
       (($ <conditional> src
@@ -2348,10 +2335,9 @@ integer."
           (evaluate-args-eagerly-if-needed
            src inits (lambda (inits) (k (cons init inits)))))
          (_
-          (with-lexical
-           src init
-           (evaluate-args-eagerly-if-needed
-            src inits (lambda (inits) (k (cons init inits))))))))))
+          (with-lexicals src (init)
+            (evaluate-args-eagerly-if-needed
+             src inits (lambda (inits) (k (cons init inits))))))))))
   (post-order
    (lambda (exp)
      (match exp
@@ -2521,5 +2507,4 @@ integer."
 ;;; Local Variables:
 ;;; eval: (put 'convert-arg 'scheme-indent-function 2)
 ;;; eval: (put 'convert-args 'scheme-indent-function 2)
-;;; eval: (put 'with-lexicals 'scheme-indent-function 2)
 ;;; End:
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index b1fa344..f97da97 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -560,28 +560,6 @@
 (define-primitive-expander f64vector-set! (vec i x)
   (bytevector-ieee-double-native-set! vec (* i 8) x))
 
-(define (chained-comparison-expander prim-name)
-  (case-lambda
-    ((src) (make-const src #t))
-    ((src a) #f)
-    ((src a b) #f)
-    ((src a b . rest)
-     (let* ((b-sym (gensym "b"))
-            (b* (make-lexical-ref src 'b b-sym)))
-       (make-let src
-                 '(b)
-                 (list b-sym)
-                 (list b)
-                 (make-conditional src
-                                   (make-primcall src prim-name (list a b*))
-                                   (make-primcall src prim-name (cons b* rest))
-                                   (make-const src #f)))))))
-
-(for-each (lambda (prim-name)
-            (define-primitive-expander! prim-name
-              (chained-comparison-expander prim-name)))
-          '(< > <= >= =))
-
 (define (character-comparison-expander char< <)
   (lambda (src . args)
     (expand-primcall
@@ -619,9 +597,10 @@
                    (make-primcall src 'eq? (list a b))))))
      (or (maybe-simplify a b) (maybe-simplify b a)))
     ((src a b . rest)
-     (make-conditional src (make-primcall src prim (list a b))
-                       (make-primcall src prim (cons b rest))
-                       (make-const src #f)))
+     (with-lexicals src (b)
+       (make-conditional src (make-primcall src prim (list a b))
+                         (make-primcall src prim (cons b rest))
+                         (make-const src #f))))
     (else #f)))
 
 (define-primitive-expander! 'eqv?   (maybe-simplify-to-eq 'eqv?))
@@ -638,9 +617,10 @@
                (make-const src #t)))
     ((src a b) #f)
     ((src a b . rest)
-     (make-conditional src (make-primcall src prim (list a b))
-                       (make-primcall src prim (cons b rest))
-                       (make-const src #f)))
+     (with-lexicals src (b)
+       (make-conditional src (make-primcall src prim (list a b))
+                         (make-primcall src prim (cons b rest))
+                         (make-const src #f))))
     (else #f)))
 
 (for-each (lambda (prim)
@@ -662,26 +642,24 @@
            (make-primcall src 'name (list . args)))
          (define-syntax-rule (const val)
            (make-const src val))
-         (make-let
-          src (list 'handler) (list h) (list handler)
-          (let ((handler (make-lexical-ref src 'handler h)))
-            (make-conditional
-             src
-             (primcall procedure? handler)
-             (make-prompt
-              src #f tag thunk
-              (make-lambda
-               src '()
-               (make-lambda-case
-                src '() #f 'args #f '() (list args)
-                (primcall apply handler (make-lexical-ref #f 'args args))
-                #f)))
-             (primcall throw
-                       (const 'wrong-type-arg)
-                       (const "call-with-prompt")
-                       (const "Wrong type (expecting procedure): ~S")
-                       (primcall list handler)
-                       (primcall list handler)))))))))
+         (with-lexicals src (handler)
+           (make-conditional
+            src
+            (primcall procedure? handler)
+            (make-prompt
+             src #f tag thunk
+             (make-lambda
+              src '()
+              (make-lambda-case
+               src '() #f 'args #f '() (list args)
+               (primcall apply handler (make-lexical-ref #f 'args args))
+               #f)))
+            (primcall throw
+                      (const 'wrong-type-arg)
+                      (const "call-with-prompt")
+                      (const "Wrong type (expecting procedure): ~S")
+                      (primcall list handler)
+                      (primcall list handler))))))))
    (else #f)))
 
 (define-primitive-expander! 'abort-to-prompt*