;;; 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
values
eq? eqv? equal?
memq memv
- = < > <= >= zero?
+ = < > <= >= zero? positive? negative?
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor lognot
not
(define *effect-free-primitives*
`(values
eq? eqv? equal?
- = < > <= >= zero?
+ = < > <= >= zero? positive? negative?
ash logand logior logxor lognot
+ * - / 1- 1+ quotient remainder modulo
not
(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 +
(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