From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andreas Rottmann Newsgroups: gmane.lisp.guile.devel Subject: [PATCH 2/3] Several optimizations for R6RS fixnum arithmetic Date: Sat, 2 Apr 2011 19:42:27 +0200 Message-ID: <1301766148-20242-3-git-send-email-a.rottmann@gmx.at> References: <87wrjglvsq.fsf@gmx.at> <1301766148-20242-1-git-send-email-a.rottmann@gmx.at> NNTP-Posting-Host: lo.gmane.org X-Trace: dough.gmane.org 1301766225 21347 80.91.229.12 (2 Apr 2011 17:43:45 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sat, 2 Apr 2011 17:43:45 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sat Apr 02 19:43:40 2011 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1Q64rL-0007p4-6q for guile-devel@m.gmane.org; Sat, 02 Apr 2011 19:43:39 +0200 Original-Received: from localhost ([127.0.0.1]:50228 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1Q64rK-0006Jh-Ep for guile-devel@m.gmane.org; Sat, 02 Apr 2011 13:43:38 -0400 Original-Received: from [140.186.70.92] (port=32772 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1Q64rE-0006Hl-3d for guile-devel@gnu.org; Sat, 02 Apr 2011 13:43:33 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1Q64r9-0004LM-24 for guile-devel@gnu.org; Sat, 02 Apr 2011 13:43:31 -0400 Original-Received: from mailout-de.gmx.net ([213.165.64.23]:56469) by eggs.gnu.org with smtp (Exim 4.71) (envelope-from ) id 1Q64r8-0004KB-K9 for guile-devel@gnu.org; Sat, 02 Apr 2011 13:43:26 -0400 Original-Received: (qmail invoked by alias); 02 Apr 2011 17:43:25 -0000 Original-Received: from 83-215-154-5.hage.dyn.salzburg-online.at (EHLO nathot.lan) [83.215.154.5] by mail.gmx.net (mp029) with SMTP; 02 Apr 2011 19:43:25 +0200 X-Authenticated: #3102804 X-Provags-ID: V01U2FsdGVkX1+Ax01PAP+AK0C4fbxYH1hRpEKER/Z0Ncq7UL33+r o88b1ZdQanS4lt Original-Received: from localhost (localhost.localdomain [127.0.0.1]) by nathot.lan (Postfix) with ESMTP id 7A23C3A691; Sat, 2 Apr 2011 19:43:24 +0200 (CEST) Original-Received: from nathot.lan ([127.0.0.1]) by localhost (nathot.lan [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id Win5OPxlO0dn; Sat, 2 Apr 2011 19:43:19 +0200 (CEST) Original-Received: from delenn.lan (delenn.lan [192.168.3.11]) by nathot.lan (Postfix) with ESMTP id 38B543A696; Sat, 2 Apr 2011 19:43:19 +0200 (CEST) Original-Received: by delenn.lan (Postfix, from userid 1000) id 22D1C2C00C1; Sat, 2 Apr 2011 19:43:19 +0200 (CEST) X-Mailer: git-send-email 1.7.4.1 In-Reply-To: <1301766148-20242-1-git-send-email-a.rottmann@gmx.at> X-Y-GMX-Trusted: 0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 2) X-Received-From: 213.165.64.23 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:12146 Archived-At: * 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. --- module/rnrs/arithmetic/fixnums.scm | 86 +++++++++++++++++------------------- 1 files changed, 41 insertions(+), 45 deletions(-) diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm index befbe9d..03511ed 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,45 @@ (>= 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 (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 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 +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) -- 1.7.4.1