summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2014-02-07 15:07:14 +0100
committerAndy Wingo <wingo@pobox.com>2014-02-07 15:12:35 +0100
commit04f59ec2e7ab73caacbbfa2c5905fe4f240c47c5 (patch)
tree4367241d85f4b347d2f873bb8bc7d4503cf177fa
parent08224c56fa735612fa6b33533c927c9c3eaf8d3d (diff)
parent58147d67806e1f54c447d7eabac35b1a5086c3a6 (diff)
downloadguile-04f59ec2e7ab73caacbbfa2c5905fe4f240c47c5.tar.gz
Merge commit '58147d67806e1f54c447d7eabac35b1a5086c3a6'
-rw-r--r--module/language/tree-il/primitives.scm22
1 files changed, 22 insertions, 0 deletions
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 71437b2b6..2ea56427e 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -525,6 +525,28 @@
(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)
+ (hashq-set! *primitive-expand-table* prim-name
+ (chained-comparison-expander prim-name)))
+ '(< > <= >= =))
+
;; Appropriate for use with either 'eqv?' or 'equal?'.
(define (maybe-simplify-to-eq prim)
(case-lambda