diff options
author | Andy Wingo <wingo@pobox.com> | 2022-12-01 12:56:51 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2022-12-01 12:56:51 +0100 |
commit | d184d093466a536281dfc2bcb9eb727f6facdeb4 (patch) | |
tree | 1cad4f9592870a020289771b5fb60cd5f12a2301 | |
parent | c7fa78fc751eb336bcfafbb5ac59c460ee2c5d7a (diff) | |
download | guile-d184d093466a536281dfc2bcb9eb727f6facdeb4.tar.gz |
Fix order-of-side-effects bug in (eq? x y z) expansion
* module/language/tree-il/primitives.scm (bind-lexicals): New helper.
(expand-eq, expand-chained-comparisons): Ensure all arguments are
eagerly evaluated. Previously an intermediate #f result would shortcut
the evaluation.
* test-suite/tests/compiler.test ("size effects in multi-arg eq / <"):
Add test.
-rw-r--r-- | module/language/tree-il/primitives.scm | 46 | ||||
-rw-r--r-- | test-suite/tests/compiler.test | 11 |
2 files changed, 45 insertions, 12 deletions
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 7f3746b4f..135a1f56f 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -1,6 +1,6 @@ ;;; open-coding primitive procedures -;; Copyright (C) 2009-2015, 2017-2021 Free Software Foundation, Inc. +;; Copyright (C) 2009-2015, 2017-2022 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 @@ -568,17 +568,32 @@ (define-primitive-expander f64vector-set! (vec i x) (bytevector-ieee-double-native-set! vec (* i 8) x)) +(define (bind-lexicals src exps k) + (match exps + (() (k '())) + ((exp . exps) + (with-lexicals src (exp) + (bind-lexicals src exps (lambda (exps) (k (cons exp exps)))))))) + (define (expand-eq prim) (case-lambda ((src) (make-const src #t)) ((src a) (make-const src #t)) ((src a b) #f) - ((src a b . rest) - (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))) + ((src . args) + (bind-lexicals + src args + (lambda (args) + (match args + ((a . args) + (let lp ((args args)) + (match args + ((b) + (make-primcall src prim (list a b))) + ((b . args) + (make-conditional src (make-primcall src prim (list a b)) + (lp args) + (make-const src #f)))))))))))) (define-primitive-expander! 'eq? (expand-eq 'eq?)) (define-primitive-expander! 'eqv? (expand-eq 'eqv?)) @@ -594,11 +609,18 @@ (make-primcall src prim (list a (make-const src 0))) (make-const src #t))) ((src a b) #f) - ((src a b . rest) - (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)))) + ((src . args) + (bind-lexicals + src args + (lambda (args) + (let lp ((args args)) + (match args + ((a b) + (make-primcall src prim (list a b))) + ((a b . args) + (make-conditional src (make-primcall src prim (list a b)) + (lp (cons b args)) + (make-const src #f)))))))) (else #f))) (for-each (lambda (prim) diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index 67d8d9ed9..a018e0c41 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -401,6 +401,17 @@ (pass-if-equal "foo bar" 'qux (test-proc 'foo 'bar)) (pass-if-equal "foo two" 'foo (test-proc 'foo 'two))) +(with-test-prefix "size effects in multi-arg eq / <" + (pass-if-equal "eq?" 42 + (compile '(catch 'foo + (lambda () (= 0 1 (throw 'foo))) + (lambda (k) 42)))) + + (pass-if-equal "<" 42 + (compile '(catch 'foo + (lambda () (< 0 -1 (throw 'foo))) + (lambda (k) 42))))) + (with-test-prefix "read-and-compile tree-il" (let ((code "\ |