From 58147d67806e1f54c447d7eabac35b1a5086c3a6 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Tue, 28 Jan 2014 17:44:22 -0500
Subject: [PATCH] Compile numerical comparisons with more than 2 arguments to
 VM code.

* module/language/tree-il/primitives.scm (chained-comparison-expander):
  New procedure.
  (*primitive-expand-table*): Add primitive expanders for '<', '>',
  '<=', '>=', and '='.
---
 module/language/tree-il/primitives.scm | 23 +++++++++++++++++++++++
 1 file changed, 23 insertions(+)

diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index f140eeca2..9901876a7 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -491,6 +491,29 @@
 (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* ((prim (make-primitive-ref src prim-name))
+            (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-application src prim (list a b*))
+                                   (make-application src prim (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
   (case-lambda