summaryrefslogtreecommitdiff
path: root/module/rnrs/arithmetic/fixnums.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/rnrs/arithmetic/fixnums.scm')
-rw-r--r--module/rnrs/arithmetic/fixnums.scm99
1 files changed, 47 insertions, 52 deletions
diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm
index befbe9d35..0ce245811 100644
--- a/module/rnrs/arithmetic/fixnums.scm
+++ b/module/rnrs/arithmetic/fixnums.scm
@@ -76,6 +76,7 @@
fxreverse-bit-field)
(import (only (guile) ash
cons*
+ define-inlinable
inexact->exact
logand
logbit?
@@ -84,9 +85,11 @@
lognot
logxor
most-positive-fixnum
- most-negative-fixnum)
+ most-negative-fixnum
+ object-address)
(ice-9 optargs)
(rnrs base (6))
+ (rnrs control (6))
(rnrs arithmetic bitwise (6))
(rnrs conditions (6))
(rnrs exceptions (6))
@@ -98,57 +101,49 @@
(define (greatest-fixnum) most-positive-fixnum)
(define (least-fixnum) most-negative-fixnum)
-
- (define (fixnum? obj)
- (and (integer? obj)
- (exact? obj)
- (>= obj most-negative-fixnum)
- (<= obj most-positive-fixnum)))
- (define (assert-fixnum . args)
+ (define-inlinable (fixnum? obj)
+ (not (= 0 (logand 2 (object-address obj)))))
+
+ (define-syntax assert-fixnum
+ (syntax-rules ()
+ ((_ arg ...)
+ (or (and (fixnum? arg) ...)
+ (raise (make-assertion-violation))))))
+
+ (define (assert-fixnums args)
(or (for-all fixnum? args) (raise (make-assertion-violation))))
- (define (fx=? fx1 fx2 . rst)
- (let ((args (cons* fx1 fx2 rst)))
- (apply assert-fixnum args)
- (apply = args)))
-
- (define (fx>? fx1 fx2 . rst)
- (let ((args (cons* fx1 fx2 rst)))
- (apply assert-fixnum args)
- (apply > args)))
-
- (define (fx<? fx1 fx2 . rst)
- (let ((args (cons* fx1 fx2 rst)))
- (apply assert-fixnum rst)
- (apply < args)))
-
- (define (fx>=? fx1 fx2 . rst)
- (let ((args (cons* fx1 fx2 rst)))
- (apply assert-fixnum rst)
- (apply >= args)))
-
- (define (fx<=? fx1 fx2 . rst)
- (let ((args (cons* fx1 fx2 rst)))
- (apply assert-fixnum rst)
- (apply <= args)))
-
- (define (fxzero? fx) (assert-fixnum fx) (zero? fx))
- (define (fxpositive? fx) (assert-fixnum fx) (positive? fx))
- (define (fxnegative? fx) (assert-fixnum fx) (negative? fx))
- (define (fxodd? fx) (assert-fixnum fx) (odd? fx))
- (define (fxeven? fx) (assert-fixnum fx) (even? fx))
-
- (define (fxmax fx1 fx2 . rst)
- (let ((args (cons* fx1 fx2 rst)))
- (apply assert-fixnum args)
- (apply max args)))
-
- (define (fxmin fx1 fx2 . rst)
- (let ((args (cons* fx1 fx2 rst)))
- (apply assert-fixnum args)
- (apply min args)))
-
+ (define-syntax define-fxop*
+ (syntax-rules ()
+ ((_ name op)
+ (define name
+ (case-lambda
+ ((x y)
+ (assert-fixnum x y)
+ (op x y))
+ (args
+ (assert-fixnums args)
+ (apply op args)))))))
+
+ ;; All these predicates don't check their arguments for fixnum-ness,
+ ;; as this doesn't seem to be strictly required by R6RS.
+
+ (define fx=? =)
+ (define fx>? >)
+ (define fx<? <)
+ (define fx>=? >=)
+ (define fx<=? <=)
+
+ (define fxzero? zero?)
+ (define fxpositive? positive?)
+ (define fxnegative? negative?)
+ (define fxodd? odd?)
+ (define fxeven? even?)
+
+ (define-fxop* fxmax max)
+ (define-fxop* fxmin min)
+
(define (fx+ fx1 fx2)
(assert-fixnum fx1 fx2)
(let ((r (+ fx1 fx2)))
@@ -219,9 +214,9 @@
(values s0 s1)))
(define (fxnot fx) (assert-fixnum fx) (lognot fx))
- (define (fxand . args) (apply assert-fixnum args) (apply logand args))
- (define (fxior . args) (apply assert-fixnum args) (apply logior args))
- (define (fxxor . args) (apply assert-fixnum args) (apply logxor args))
+ (define-fxop* fxand logand)
+ (define-fxop* fxior logior)
+ (define-fxop* fxxor logxor)
(define (fxif fx1 fx2 fx3)
(assert-fixnum fx1 fx2 fx3)