1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 14:50:19 +02:00

Several optimizations for R6RS fixnum arithmetic

* module/rnrs/arithmetic/fixnums.scm (assert-fixnum): Is now a
  macro.
  (assert-fixnums): New procedure checking a the elements of a list
  for fixnum-ness.  All callers applying `assert-fixnum' to a list
  now changed to use this procedure.

* module/rnrs/arithmetic/fixnums.scm (define-fxop*): New for defining
  n-ary inlinable special-casing the binary case using `case-lambda'.
  All applicable procedures redefined using this macro.

* module/rnrs/arithmetic/fixnums.scm: Alias all predicates to
  their non-fixnum counterparts.
This commit is contained in:
Andreas Rottmann 2011-04-02 19:42:27 +02:00 committed by Andy Wingo
parent b7715701b4
commit 78d1be4aef

View file

@ -87,6 +87,7 @@
most-negative-fixnum)
(ice-9 optargs)
(rnrs base (6))
(rnrs control (6))
(rnrs arithmetic bitwise (6))
(rnrs conditions (6))
(rnrs exceptions (6))
@ -105,49 +106,44 @@
(>= obj most-negative-fixnum)
(<= obj most-positive-fixnum)))
(define (assert-fixnum . args)
(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-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)))))))
(define (fx>? fx1 fx2 . rst)
(let ((args (cons* fx1 fx2 rst)))
(apply assert-fixnum args)
(apply > 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<? fx1 fx2 . rst)
(let ((args (cons* fx1 fx2 rst)))
(apply assert-fixnum rst)
(apply < args)))
(define fx=? =)
(define fx>? >)
(define fx<? <)
(define fx>=? >=)
(define fx<=? <=)
(define (fx>=? fx1 fx2 . rst)
(let ((args (cons* fx1 fx2 rst)))
(apply assert-fixnum rst)
(apply >= args)))
(define fxzero? zero?)
(define fxpositive? positive?)
(define fxnegative? negative?)
(define fxodd? odd?)
(define fxeven? even?)
(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-fxop* fxmax max)
(define-fxop* fxmin min)
(define (fx+ fx1 fx2)
(assert-fixnum fx1 fx2)
@ -219,9 +215,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)