* 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 macro for defining n-ary procedures special-casing the binary case via case-lambda. All applicable procedures redefined using this macro. * benchmark-suite/benchmarks/r6rs-arithmetic.bm: New file containing some benchmarks for R6RS fixnum operations. --- benchmark-suite/benchmarks/r6rs-arithmetic.bm | 35 +++++++++++++ module/rnrs/arithmetic/fixnums.scm | 69 +++++++++++-------------- 2 files changed, 66 insertions(+), 38 deletions(-) create mode 100644 benchmark-suite/benchmarks/r6rs-arithmetic.bm diff --git a/benchmark-suite/benchmarks/r6rs-arithmetic.bm b/benchmark-suite/benchmarks/r6rs-arithmetic.bm new file mode 100644 index 0000000..4c9b8e6 --- /dev/null +++ b/benchmark-suite/benchmarks/r6rs-arithmetic.bm @@ -0,0 +1,35 @@ +;;; -*- mode: scheme; coding: utf-8; -*- +;;; R6RS-specific arithmetic benchmarks +;;; +;;; Copyright (C) 2011 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 +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (benchmarks r6rs-arithmetic) + #:use-module (benchmark-suite lib) + #:use-module (rnrs arithmetic fixnums)) + + +(with-benchmark-prefix "fixnum" + + (benchmark "fixnum? [yes]" 1e7 + (fixnum? 10000)) + + (let ((n (+ most-positive-fixnum 100))) + (benchmark "fixnum? [no]" 1e7 + (fixnum? n))) + + (benchmark "fxxor [2]" 1e7 + (fxxor 3 8))) diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm index befbe9d..8c35dc6 100644 --- a/module/rnrs/arithmetic/fixnums.scm +++ b/module/rnrs/arithmetic/fixnums.scm @@ -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,50 +106,42 @@ (>= 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 (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-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-fxop* fx=? =) + (define-fxop* fx>? >) + (define-fxop* fx<? <) + (define-fxop* fx>=? >=) + (define-fxop* fx<=? <=) + (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-fxop* fxmax max) + (define-fxop* fxmin min) - (define (fxmin fx1 fx2 . rst) - (let ((args (cons* fx1 fx2 rst))) - (apply assert-fixnum args) - (apply min args))) - (define (fx+ fx1 fx2) (assert-fixnum fx1 fx2) (let ((r (+ fx1 fx2))) @@ -219,9 +212,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) -- 1.7.4.1
