diff options
Diffstat (limited to 'module/rnrs/arithmetic/fixnums.scm')
-rw-r--r-- | module/rnrs/arithmetic/fixnums.scm | 99 |
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) |