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 3/3] Add `fixnum?' VM primitive Date: Sat, 2 Apr 2011 19:42:28 +0200 Message-ID: <1301766148-20242-4-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 1301766238 21412 80.91.229.12 (2 Apr 2011 17:43:58 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sat, 2 Apr 2011 17:43:58 +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:54 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 1Q64rY-0000Ed-L6 for guile-devel@m.gmane.org; Sat, 02 Apr 2011 19:43:53 +0200 Original-Received: from localhost ([127.0.0.1]:50409 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1Q64rX-0006Qz-QT for guile-devel@m.gmane.org; Sat, 02 Apr 2011 13:43:51 -0400 Original-Received: from [140.186.70.92] (port=33052 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1Q64rL-0006LW-8k for guile-devel@gnu.org; Sat, 02 Apr 2011 13:43:46 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1Q64rI-0004UJ-Dd for guile-devel@gnu.org; Sat, 02 Apr 2011 13:43:38 -0400 Original-Received: from mailout-de.gmx.net ([213.165.64.23]:47297) by eggs.gnu.org with smtp (Exim 4.71) (envelope-from ) id 1Q64rI-0004TW-0c for guile-devel@gnu.org; Sat, 02 Apr 2011 13:43:36 -0400 Original-Received: (qmail invoked by alias); 02 Apr 2011 17:43:31 -0000 Original-Received: from 83-215-154-5.hage.dyn.salzburg-online.at (EHLO nathot.lan) [83.215.154.5] by mail.gmx.net (mp069) with SMTP; 02 Apr 2011 19:43:31 +0200 X-Authenticated: #3102804 X-Provags-ID: V01U2FsdGVkX19zAq15PmtzLj0xPp7H/Jn4OALSOHZ7z63kXl8vnG C8FdUB4uYry/Ak Original-Received: from localhost (localhost.localdomain [127.0.0.1]) by nathot.lan (Postfix) with ESMTP id 3FACC3A691; Sat, 2 Apr 2011 19:43:31 +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 Qcstegr9k9jY; Sat, 2 Apr 2011 19:43:22 +0200 (CEST) Original-Received: from delenn.lan (delenn.lan [192.168.3.11]) by nathot.lan (Postfix) with ESMTP id AE6E53A69B; Sat, 2 Apr 2011 19:43:20 +0200 (CEST) Original-Received: by delenn.lan (Postfix, from userid 1000) id 98B152C00C1; Sat, 2 Apr 2011 19:43:20 +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: Genre and OS details not recognized. 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:12147 Archived-At: This primitive can be used to significantly speed up the operations in `(rnrs arithmetic fixnums)'. * libguile/r6rs-arithmetic.c: New file containing `fixnum?' procedure implementation as a new extension. * libguile/r6rs-arithmetic.h: New file with prototypes for the above. * libguile/Makefile.am: Add above files in relevant places. * libguile/init.c (scm_i_init_guile): Register R6RS arithmetic extension. * libguile/vm-i-scheme.c (fixnump): New VM primitive. * module/language/tree-il/compile-glil.scm (*primcall-ops*): Add `fixnum?'. * module/language/tree-il/primitives.scm (*interesting-primitive-names*, *effect-free-primitives*) (*effect+exception-free-primitives*): Add `fixnum?'. --- libguile/Makefile.am | 4 ++ libguile/init.c | 2 + libguile/numbers.c | 1 - libguile/numbers.h | 1 + libguile/r6rs-arithmetic.c | 48 ++++++++++++++++++++++++++++++ libguile/r6rs-arithmetic.h | 30 ++++++++++++++++++ libguile/vm-i-scheme.c | 8 ++++- module/language/tree-il/compile-glil.scm | 1 + module/language/tree-il/primitives.scm | 9 +++-- module/rnrs/arithmetic/fixnums.scm | 11 +++---- 10 files changed, 103 insertions(+), 12 deletions(-) create mode 100644 libguile/r6rs-arithmetic.c create mode 100644 libguile/r6rs-arithmetic.h diff --git a/libguile/Makefile.am b/libguile/Makefile.am index ac27eb8..01a384d 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -179,6 +179,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ procs.c \ programs.c \ promises.c \ + r6rs-arithmetic.c \ r6rs-ports.c \ random.c \ rdelim.c \ @@ -275,6 +276,7 @@ DOT_X_FILES = \ procprop.x \ procs.x \ promises.x \ + r6rs-arithmetic.x \ r6rs-ports.x \ random.x \ rdelim.x \ @@ -375,6 +377,7 @@ DOT_DOC_FILES = \ procprop.doc \ procs.doc \ promises.doc \ + r6rs-arithmetic.doc \ r6rs-ports.doc \ random.doc \ rdelim.doc \ @@ -569,6 +572,7 @@ modinclude_HEADERS = \ programs.h \ promises.h \ pthread-threads.h \ + r6rs-arithmetic.h \ r6rs-ports.h \ random.h \ rdelim.h \ diff --git a/libguile/init.c b/libguile/init.c index 8b3b8cd..2c23b1e 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -100,6 +100,7 @@ #include "libguile/programs.h" #include "libguile/promises.h" #include "libguile/array-map.h" +#include "libguile/r6rs-arithmetic.h" #include "libguile/random.h" #include "libguile/rdelim.h" #include "libguile/read.h" @@ -403,6 +404,7 @@ scm_i_init_guile (void *base) scm_bootstrap_programs (); scm_bootstrap_vm (); scm_register_r6rs_ports (); + scm_register_r6rs_arithmetic (); scm_register_foreign (); scm_register_srfi_1 (); scm_register_srfi_60 (); diff --git a/libguile/numbers.c b/libguile/numbers.c index 427e772..0a10030 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -6122,7 +6122,6 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0, } #undef FUNC_NAME - SCM scm_i_num_eq_p (SCM, SCM, SCM); SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1, (SCM x, SCM y, SCM rest), diff --git a/libguile/numbers.h b/libguile/numbers.h index ab96981..fb97785 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -240,6 +240,7 @@ SCM_API SCM scm_complex_p (SCM x); SCM_API SCM scm_real_p (SCM x); SCM_API SCM scm_rational_p (SCM z); SCM_API SCM scm_integer_p (SCM x); +SCM_API SCM scm_fixnum_p (SCM x); SCM_API SCM scm_inexact_p (SCM x); SCM_API SCM scm_num_eq_p (SCM x, SCM y); SCM_API SCM scm_less_p (SCM x, SCM y); diff --git a/libguile/r6rs-arithmetic.c b/libguile/r6rs-arithmetic.c new file mode 100644 index 0000000..b00f1f4 --- /dev/null +++ b/libguile/r6rs-arithmetic.c @@ -0,0 +1,48 @@ +/* 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 + * . + */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include "libguile/_scm.h" +#include "libguile/numbers.h" +#include "libguile/r6rs-arithmetic.h" + +SCM_DEFINE (scm_fixnum_p, "fixnum?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is a fixnum, @code{#f} otherwise.") +#define FUNC_NAME s_scm_fixnum_p +{ + return scm_from_bool (SCM_I_INUMP (x)); +} +#undef FUNC_NAME + +void +scm_register_r6rs_arithmetic (void) +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_r6rs_arithmetic", + (scm_t_extension_init_func) scm_init_r6rs_arithmetic, + NULL); +} + +void +scm_init_r6rs_arithmetic (void) +{ +#include "libguile/r6rs-arithmetic.x" +} diff --git a/libguile/r6rs-arithmetic.h b/libguile/r6rs-arithmetic.h new file mode 100644 index 0000000..833426a --- /dev/null +++ b/libguile/r6rs-arithmetic.h @@ -0,0 +1,30 @@ +#ifndef SCM_R6RS_ARITHMETIC_H +#define SCM_R6RS_ARITHMETIC_H + +/* 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 + * . + */ + + + +#include "libguile/__scm.h" + +/* R6RS Fixnum Arithmetic */ + +SCM_API void scm_init_r6rs_arithmetic (void); +SCM_INTERNAL void scm_register_r6rs_arithmetic (void); + +#endif /* SCM_R6RS_ARITHMETIC_H */ diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 9e249bc..21255c6 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 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 @@ -111,6 +111,12 @@ VM_DEFINE_FUNCTION (139, vectorp, "vector?", 1) RETURN (scm_from_bool (SCM_I_IS_VECTOR (x))); } +VM_DEFINE_FUNCTION (210, fixnump, "fixnum?", 1) +{ + ARGS1 (x); + RETURN (scm_from_bool (SCM_I_INUMP (x))); +} + /* * Basic data diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index f193e9d..b4d860f 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -108,6 +108,7 @@ ((list? . 1) . list?) ((symbol? . 1) . symbol?) ((vector? . 1) . vector?) + ((fixnum? . 1) . fixnum?) (list . list) (vector . vector) ((class-of . 1) . class-of) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 316a462..24e6021 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -1,6 +1,6 @@ ;;; open-coding primitive procedures -;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 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 @@ -21,6 +21,7 @@ (define-module (language tree-il primitives) #:use-module (system base pmatch) #:use-module (rnrs bytevectors) + #:use-module (rnrs arithmetic fixnums) #:use-module (system base syntax) #:use-module (language tree-il) #:use-module (srfi srfi-4) @@ -43,7 +44,7 @@ + * - / 1- 1+ quotient remainder modulo ash logand logior logxor not - pair? null? list? symbol? vector? acons cons cons* + fixnum? pair? null? list? symbol? vector? acons cons cons* list vector @@ -112,7 +113,7 @@ = < > <= >= zero? + * - / 1- 1+ quotient remainder modulo not - pair? null? list? symbol? vector? acons cons cons* + pair? null? list? symbol? vector? fixnum? acons cons cons* list vector car cdr caar cadr cdar cddr @@ -137,7 +138,7 @@ '(values eq? eqv? equal? not - pair? null? list? symbol? vector? acons cons cons* + pair? null? list? symbol? vector? fixnum? acons cons cons* list vector struct?)) diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm index 03511ed..b519920 100644 --- a/module/rnrs/arithmetic/fixnums.scm +++ b/module/rnrs/arithmetic/fixnums.scm @@ -76,7 +76,9 @@ fxreverse-bit-field) (import (only (guile) ash cons* + effective-version inexact->exact + load-extension logand logbit? logcount @@ -93,18 +95,15 @@ (rnrs exceptions (6)) (rnrs lists (6))) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_r6rs_arithmetic") + (define fixnum-width (let ((w (inexact->exact (round (/ (log (+ most-positive-fixnum 1)) (log 2)))))) (lambda () w))) (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-syntax assert-fixnum (syntax-rules () -- 1.7.4.1