Merge commit '58147d67806e1f54c447d7eabac35b1a5086c3a6'

[bpt/guile.git] / module / language / tree-il / primitives.scm

diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 84c07a0..2ea5642 100644 (file)
--- 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, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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
@@ -45,7 +45,7 @@
     values
     eq? eqv? equal?
     memq memv
-    = < > <= >= zero?
+    = < > <= >= zero? positive? negative?
     + * - / 1- 1+ quotient remainder modulo
     ash logand logior logxor lognot
     not
@@ -161,7 +161,7 @@
 (define *effect-free-primitives*
   `(values
     eq? eqv? equal?
-    = < > <= >= zero?
+    = < > <= >= zero? positive? negative?
     ash logand logior logxor lognot
     + * - / 1- 1+ quotient remainder modulo
     not
@@ -374,6 +374,12 @@
 (define-primitive-expander zero? (x)
   (= x 0))
 
+(define-primitive-expander positive? (x)
+  (> x 0))
+
+(define-primitive-expander negative? (x)
+  (< x 0))
+
 ;; FIXME: All the code that uses `const?' is redundant with `peval'.
 
 (define-primitive-expander +
@@ -519,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