From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: ludo@gnu.org (Ludovic =?iso-8859-1?Q?Court=E8s?=) Newsgroups: gmane.lisp.guile.devel Subject: SRFI-1 in Scheme Date: Tue, 13 Jul 2010 00:57:07 +0200 Message-ID: <8739vocnr0.fsf@gnu.org> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/signed; boundary="==-=-="; micalg=pgp-sha1; protocol="application/pgp-signature" X-Trace: dough.gmane.org 1278975463 28215 80.91.229.12 (12 Jul 2010 22:57:43 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Mon, 12 Jul 2010 22:57:43 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Jul 13 00:57:40 2010 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 1OYRwP-0001az-PM for guile-devel@m.gmane.org; Tue, 13 Jul 2010 00:57:38 +0200 Original-Received: from localhost ([127.0.0.1]:52437 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1OYRwP-0007zN-5l for guile-devel@m.gmane.org; Mon, 12 Jul 2010 18:57:37 -0400 Original-Received: from [140.186.70.92] (port=52215 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1OYRwJ-0007zH-VT for guile-devel@gnu.org; Mon, 12 Jul 2010 18:57:34 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.69) (envelope-from ) id 1OYRwH-0007XU-AC for guile-devel@gnu.org; Mon, 12 Jul 2010 18:57:31 -0400 Original-Received: from lo.gmane.org ([80.91.229.12]:46518) by eggs.gnu.org with esmtp (Exim 4.69) (envelope-from ) id 1OYRwG-0007XL-Lz for guile-devel@gnu.org; Mon, 12 Jul 2010 18:57:29 -0400 Original-Received: from list by lo.gmane.org with local (Exim 4.69) (envelope-from ) id 1OYRwC-0001WE-6a for guile-devel@gnu.org; Tue, 13 Jul 2010 00:57:24 +0200 Original-Received: from acces.bordeaux.inria.fr ([193.50.110.5]) by main.gmane.org with esmtp (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Tue, 13 Jul 2010 00:57:24 +0200 Original-Received: from ludo by acces.bordeaux.inria.fr with local (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Tue, 13 Jul 2010 00:57:24 +0200 X-Injected-Via-Gmane: http://gmane.org/ Original-Lines: 719 Original-X-Complaints-To: usenet@dough.gmane.org X-Gmane-NNTP-Posting-Host: acces.bordeaux.inria.fr X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 25 Messidor an 218 de la =?iso-8859-1?Q?R=E9volution?= X-PGP-Key-ID: 0xEA52ECF4 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 83C4 F8E5 10A3 3B4C 5BEA D15D 77DD 95E2 EA52 ECF4 X-OS: x86_64-unknown-linux-gnu User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/23.2 (gnu/linux) Cancel-Lock: sha1:Z4I7p2+u+8dFCTYYXVVpmhqUt0M= X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 3) 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:10652 Archived-At: --==-=-= Content-Type: multipart/mixed; boundary="=-=-=" --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Hello! The attached patch is a first stab at re-implementing SRFI-1 in Scheme. Here=E2=80=99s a quick benchmark of =E2=80=98fold=E2=80=99, for large and s= mall lists: - in C ("srfi-1.bm: fold: fold" 30 user 5.55 benchmark 5.54999599456787 bench/= interp 5.54999599456787 gc 0.0) ("srfi-1.bm: fold: fold" 2000000 user 4.41 benchmark 4.14297119140625 b= ench/interp 4.14297119140625 gc 0.0) - in Scheme (debug engine) ("srfi-1.bm: fold: fold" 30 user 6.04 benchmark 6.03999599456787 bench/= interp 6.03999599456787 gc 0.0) ("srfi-1.bm: fold: fold" 2000000 user 5.14 benchmark 4.87297119140625 b= ench/interp 4.87297119140625 gc 0.0) - in Scheme (regular engine) ("srfi-1.bm: fold: fold" 30 user 5.46 benchmark 5.45999656677246 bench/= interp 5.45999656677246 gc 0.0) ("srfi-1.bm: fold: fold" 2000000 user 4.64 benchmark 4.4111181640625 be= nch/interp 4.4111181640625 gc 0.0) IOW, with the debug engine (currently the default) and for large lists =E2=80=98fold=E2=80=99 in Scheme is ~9% slower than in C; for small lists i= t=E2=80=99s ~17% slower. With the regular engine, Scheme is ~2% faster for large lists and still ~5% slower for small lists. I=E2=80=99m tempted to put this in and then make the regular engine the def= ault unless =E2=80=98--debug=E2=80=99 is specified. What do you think? Thanks, Ludo=E2=80=99. --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-Start-rewriting-SRFI-1-in-Scheme.patch Content-Transfer-Encoding: quoted-printable Content-Description: the patch From=20927b96b48d4870c768da093741af6e6bcd438cad Mon Sep 17 00:00:00 2001 From: =3D?UTF-8?q?Ludovic=3D20Court=3DC3=3DA8s?=3D Date: Tue, 13 Jul 2010 00:07:12 +0200 Subject: [PATCH] Start rewriting SRFI-1 in Scheme. This partially reverts commit e556f8c3c6b74ee6596e8dcbe829109d7745da2c (Fri May 6 2005). * module/srfi/srfi-1.scm (xcons, list-tabulate, not-pair?, car+cdr, last, fold, list-index): New procedures. * srfi/srfi-1.c (srfi1_module): New variable. (CACHE_VAR): New macro. (scm_srfi1_car_plus_cdr, scm_srfi1_fold, scm_srfi1_last, scm_srfi1_list_index, scm_srfi1_list_tabulate, scm_srfi1_not_pair_p, scm_srfi1_xcons): Rewrite as proxies of the corresponding Scheme procedure. * test-suite/tests/srfi-1.test ("list-tabulate")["-1"]: Change exception type to `exception:wrong-type-arg'. * benchmark-suite/benchmarks/srfi-1.bm: New file. * benchmark-suite/Makefile.am (SCM_BENCHMARKS): Add `benchmarks/srfi-1.bm'. =2D-- benchmark-suite/Makefile.am | 1 + benchmark-suite/benchmarks/srfi-1.bm | 38 ++++ module/srfi/srfi-1.scm | 64 +++++++- srfi/srfi-1.c | 318 ++++++------------------------= ---- test-suite/tests/srfi-1.test | 4 +- 5 files changed, 154 insertions(+), 271 deletions(-) create mode 100644 benchmark-suite/benchmarks/srfi-1.bm diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am index d99e457..b58219a 100644 =2D-- a/benchmark-suite/Makefile.am +++ b/benchmark-suite/Makefile.am @@ -5,6 +5,7 @@ SCM_BENCHMARKS =3D benchmarks/0-reference.bm \ benchmarks/if.bm \ benchmarks/logand.bm \ benchmarks/read.bm \ + benchmarks/srfi-1.bm \ benchmarks/srfi-13.bm \ benchmarks/structs.bm \ benchmarks/subr.bm \ diff --git a/benchmark-suite/benchmarks/srfi-1.bm b/benchmark-suite/benchma= rks/srfi-1.bm new file mode 100644 index 0000000..2888934 =2D-- /dev/null +++ b/benchmark-suite/benchmarks/srfi-1.bm @@ -0,0 +1,38 @@ +;;; -*- mode: scheme; coding: utf-8; -*- +;;; SRFI-1. +;;; +;;; Copyright 2010 Free Software Foundation, Inc. +;;; +;;; This program 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, or +;;; (at your option) any later version. +;;; +;;; This program 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 software; see the file COPYING.LESSER. If +;;; not, write to the Free Software Foundation, Inc., 51 Franklin +;;; Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (benchmarks srfi-1) + #:use-module (srfi srfi-1) + #:use-module (benchmark-suite lib)) + +(define %big-list + (iota 1000000)) + +(define %small-list + (iota 10)) + + +(with-benchmark-prefix "fold" + + (benchmark "fold" 30 + (fold (lambda (x y) y) #f %big-list)) + + (benchmark "fold" 2000000 + (fold (lambda (x y) y) #f %small-list))) diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index c32eb1c..27aa39e 100644 =2D-- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -1,6 +1,6 @@ ;;; srfi-1.scm --- List Library =20 =2D;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009 Free Software= Foundation, Inc. +;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010 Free Soft= ware Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -225,6 +225,11 @@ =20 ;;; Constructors =20 +(define (xcons d a) + "Like `cons', but with interchanged arguments. Useful mostly when passe= d to +higher-order procedures." + (cons a d)) + ;; internal helper, similar to (scsh utilities) check-arg. (define (check-arg-type pred arg caller) (if (pred arg) @@ -235,7 +240,15 @@ ;; the srfi spec doesn't seem to forbid inexact integers. (define (non-negative-integer? x) (and (integer? x) (>=3D x 0))) =20 =2D +(define (list-tabulate n init-proc) + "Return an N-element list, where each list element is produced by applyi= ng the +procedure INIT-PROC to the corresponding list index. The order in which +INIT-PROC is applied to the indices is not specified." + (check-arg-type non-negative-integer? n "list-tabulate") + (let lp ((n n) (acc '())) + (if (<=3D n 0) + acc + (lp (- n 1) (cons (init-proc (- n 1)) acc))))) =20 (define (circular-list elt1 . elts) (set! elts (cons elt1 elts)) @@ -294,6 +307,13 @@ (else (error "not a proper list in null-list?")))) =20 +(define (not-pair? x) + "Return #t if X is not a pair, #f otherwise. + +This is shorthand notation `(not (pair? X))' and is supposed to be used for +end-of-list checking in contexts where dotted lists are allowed." + (not (pair? x))) + (define (list=3D elt=3D . rest) (define (lists-equal a b) (let lp ((a a) (b b)) @@ -317,9 +337,17 @@ (define third caddr) (define fourth cadddr) =20 +(define (car+cdr x) + "Return two values, the `car' and the `cdr' of PAIR." + (values (car x) (cdr x))) + (define take list-head) (define drop list-tail) =20 +(define (last pair) + "Return the last element of the non-empty, finite list PAIR." + (car (last-pair pair))) + ;;; Miscelleneous: length, append, concatenate, reverse, zip & count =20 (define (zip clist1 . rest) @@ -343,6 +371,21 @@ =20 ;;; Fold, unfold & map =20 +(define (fold kons knil list1 . rest) + "Apply PROC to the elements of LIST1 ... LISTN to build a result, and re= turn +that result. See the manual for details." + (if (null? rest) + (let f ((knil knil) (list1 list1)) + (if (null? list1) + knil + (f (kons (car list1) knil) (cdr list1)))) + (let f ((knil knil) (lists (cons list1 rest))) + (if (any null? lists) + knil + (let ((cars (map1 car lists)) + (cdrs (map1 cdr lists))) + (f (apply kons (append! cars (list knil))) cdrs)))))) + (define (fold-right kons knil clist1 . rest) (if (null? rest) (let f ((list1 clist1)) @@ -463,6 +506,23 @@ (else (and (pred (car ls)) (lp (cdr ls))))))) =20 +(define (list-index pred clist1 . rest) + "Return the index of the first set of elements, one from each of +CLIST1 ... CLISTN, that satisfies PRED." + (if (null? rest) + (let lp ((l clist1) (i 0)) + (if (null? l) + #f + (if (pred (car l)) + i + (lp (cdr l) (+ i 1))))) + (let lp ((lists (cons clist1 rest)) (i 0)) + (cond ((any1 null? lists) + #f) + ((apply pred (map1 car lists)) i) + (else + (lp (map1 cdr lists) (+ i 1))))))) + ;;; Association lists =20 (define alist-cons acons) diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index 537c2b3..71cfcf9 100644 =2D-- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -27,13 +27,32 @@ =20 #include "srfi-1.h" =20 =2D/* The intent of this file is to gradually replace those Scheme =2D * procedures in srfi-1.scm which extends core primitive procedures, +/* The intent of this file was to gradually replace those Scheme + * procedures in srfi-1.scm that extend core primitive procedures, * so that using srfi-1 won't have performance penalties. * =2D * Please feel free to contribute any new replacements! + * However, we now prefer to write these procedures in Scheme, let the com= piler + * optimize them, and have the VM execute them efficiently. */ =20 + +/* The `(srfi srfi-1)' module. */ +static SCM srfi1_module =3D SCM_BOOL_F; + +/* Cache variable NAME in C variable VAR. */ +#define CACHE_VAR(var, name) \ + static SCM var =3D SCM_BOOL_F; \ + if (scm_is_false (var)) \ + { \ + if (SCM_UNLIKELY (scm_is_false (srfi1_module))) \ + srfi1_module =3D scm_c_resolve_module ("srfi srfi-1"); \ + \ + var =3D scm_module_variable (srfi1_module, \ + scm_from_locale_symbol (name)); \ + if (scm_is_false (var)) \ + abort (); \ + } + static long srfi1_ilength (SCM sx) { @@ -253,16 +272,12 @@ SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0, #undef FUNC_NAME =20 =20 =2DSCM_DEFINE (scm_srfi1_car_plus_cdr, "car+cdr", 1, 0, 0, =2D (SCM pair), =2D "Return two values, the @sc{car} and the @sc{cdr} of @var{pair}.") =2D#define FUNC_NAME s_scm_srfi1_car_plus_cdr +SCM +scm_srfi1_car_plus_cdr (SCM pair) { =2D SCM_VALIDATE_CONS (SCM_ARG1, pair); =2D return scm_values (scm_list_2 (SCM_CAR (pair), SCM_CDR (pair))); + CACHE_VAR (car_plus_cdr, "car+cdr"); + return scm_call_1 (car_plus_cdr, pair); } =2D#undef FUNC_NAME =2D =20 SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0, (SCM lstlst), @@ -935,131 +950,19 @@ SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, = 0, } #undef FUNC_NAME =20 =2D =2DSCM_DEFINE (scm_srfi1_fold, "fold", 3, 0, 1, =2D (SCM proc, SCM init, SCM list1, SCM rest), =2D "Apply @var{proc} to the elements of @var{lst1} @dots{}\n" =2D "@var{lstN} to build a result, and return that result.\n" =2D "\n" =2D "Each @var{proc} call is @code{(@var{proc} @var{elem1} @dots{}\n" =2D "@var{elemN} @var{previous})}, where @var{elem1} is from\n" =2D "@var{lst1}, through @var{elemN} from @var{lstN}.\n" =2D "@var{previous} is the return from the previous call to\n" =2D "@var{proc}, or the given @var{init} for the first call. If any\n" =2D "list is empty, just @var{init} is returned.\n" =2D "\n" =2D "@code{fold} works through the list elements from first to last.\n" =2D "The following shows a list reversal and the calls it makes,\n" =2D "\n" =2D "@example\n" =2D "(fold cons '() '(1 2 3))\n" =2D "\n" =2D "(cons 1 '())\n" =2D "(cons 2 '(1))\n" =2D "(cons 3 '(2 1)\n" =2D "@result{} (3 2 1)\n" =2D "@end example\n" =2D "\n" =2D "If @var{lst1} through @var{lstN} have different lengths,\n" =2D "@code{fold} stops when the end of the shortest is reached.\n" =2D "Ie.@: elements past the length of the shortest are ignored in\n" =2D "the other @var{lst}s. At least one @var{lst} must be\n" =2D "non-circular.\n" =2D "\n" =2D "The way @code{fold} builds a result from iterating is quite\n" =2D "general, it can do more than other iterations like say\n" =2D "@code{map} or @code{filter}. The following for example removes\n" =2D "adjacent duplicate elements from a list,\n" =2D "\n" =2D "@example\n" =2D "(define (delete-adjacent-duplicates lst)\n" =2D " (fold-right (lambda (elem ret)\n" =2D " (if (equal? elem (first ret))\n" =2D " ret\n" =2D " (cons elem ret)))\n" =2D " (list (last lst))\n" =2D " lst))\n" =2D "(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))\n" =2D "@result{} (1 2 3 4 5)\n" =2D "@end example\n" =2D "\n" =2D "Clearly the same sort of thing can be done with a\n" =2D "@code{for-each} and a variable in which to build the result,\n" =2D "but a self-contained @var{proc} can be re-used in multiple\n" =2D "contexts, where a @code{for-each} would have to be written out\n" =2D "each time.") =2D#define FUNC_NAME s_scm_srfi1_fold +SCM +scm_srfi1_fold (SCM proc, SCM init, SCM list1, SCM rest) { =2D SCM lst; =2D int argnum; =2D SCM_VALIDATE_REST_ARGUMENT (rest); =2D =2D if (scm_is_null (rest)) =2D { =2D /* one list */ =2D SCM_VALIDATE_PROC (SCM_ARG1, proc); =2D =2D for ( ; scm_is_pair (list1); list1 =3D SCM_CDR (list1)) =2D init =3D scm_call_2 (proc, SCM_CAR (list1), init); =2D =2D /* check below that list1 is a proper list, and done */ =2D lst =3D list1; =2D argnum =3D 2; =2D } =2D else =2D { =2D /* two or more lists */ =2D SCM vec, args, a; =2D size_t len, i; =2D =2D /* vec is the list arguments */ =2D vec =3D scm_vector (scm_cons (list1, rest)); =2D len =3D SCM_SIMPLE_VECTOR_LENGTH (vec); =2D =2D /* args is the argument list to pass to proc, same length as vec, =2D re-used for each call */ =2D args =3D scm_make_list (SCM_I_MAKINUM (len+1), SCM_UNDEFINED); =2D =2D for (;;) =2D { =2D /* first elem of each list in vec into args, and step those =2D vec entries onto their next element */ =2D for (i =3D 0, a =3D args, argnum =3D 2; =2D i < len; =2D i++, a =3D SCM_CDR (a), argnum++) =2D { =2D lst =3D SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument = */ =2D if (! scm_is_pair (lst)) =2D goto check_lst_and_done; =2D SCM_SETCAR (a, SCM_CAR (lst)); /* arg for proc */ =2D SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of= lst */ =2D } =2D SCM_SETCAR (a, init); =2D =2D init =3D scm_apply (proc, args, SCM_EOL); =2D } =2D } =2D =2D check_lst_and_done: =2D SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "lis= t"); =2D return init; + CACHE_VAR (fold, "fold"); + return scm_apply_3 (fold, proc, init, list1, rest); } =2D#undef FUNC_NAME =2D =20 =2DSCM_DEFINE (scm_srfi1_last, "last", 1, 0, 0, =2D (SCM lst), =2D "Like @code{cons}, but with interchanged arguments. Useful\n" =2D "mostly when passed to higher-order procedures.") =2D#define FUNC_NAME s_scm_srfi1_last +SCM +scm_srfi1_last (SCM lst) { =2D SCM pair =3D scm_last_pair (lst); =2D /* scm_last_pair returns SCM_EOL for an empty list */ =2D SCM_VALIDATE_CONS (SCM_ARG1, pair); =2D return SCM_CAR (pair); + CACHE_VAR (last, "last"); + return scm_call_1 (last, lst); } =2D#undef FUNC_NAME =2D =20 SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0, (SCM lst), @@ -1073,106 +976,12 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0,= 0, #undef FUNC_NAME =20 =20 =2DSCM_DEFINE (scm_srfi1_list_index, "list-index", 2, 0, 1, =2D (SCM pred, SCM list1, SCM rest), =2D "Return the index of the first set of elements, one from each of\n" =2D "@var{lst1}@dots{}@var{lstN}, which satisfies @var{pred}.\n" =2D "\n" =2D "@var{pred} is called as @code{(@var{pred} elem1 @dots{}\n" =2D "elemN)}. Searching stops when the end of the shortest\n" =2D "@var{lst} is reached. The return index starts from 0 for the\n" =2D "first set of elements. If no set of elements pass then the\n" =2D "return is @code{#f}.\n" =2D "\n" =2D "@example\n" =2D "(list-index odd? '(2 4 6 9)) @result{} 3\n" =2D "(list-index =3D '(1 2 3) '(3 1 2)) @result{} #f\n" =2D "@end example") =2D#define FUNC_NAME s_scm_srfi1_list_index +SCM +scm_srfi1_list_index (SCM pred, SCM list1, SCM rest) { =2D long n =3D 0; =2D SCM lst; =2D int argnum; =2D SCM_VALIDATE_REST_ARGUMENT (rest); =2D =2D if (scm_is_null (rest)) =2D { =2D /* one list */ =2D SCM_VALIDATE_PROC (SCM_ARG1, pred); =2D =2D for ( ; scm_is_pair (list1); n++, list1 =3D SCM_CDR (list1)) =2D if (scm_is_true (scm_call_1 (pred, SCM_CAR (list1)))) =2D return SCM_I_MAKINUM (n); =2D =2D /* not found, check below that list1 is a proper list */ =2D end_list1: =2D lst =3D list1; =2D argnum =3D 2; =2D } =2D else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest))) =2D { =2D /* two lists */ =2D SCM list2 =3D SCM_CAR (rest); =2D SCM_VALIDATE_PROC (SCM_ARG1, pred); =2D =2D for ( ; ; n++) =2D { =2D if (! scm_is_pair (list1)) =2D goto end_list1; =2D if (! scm_is_pair (list2)) =2D { =2D lst =3D list2; =2D argnum =3D 3; =2D break; =2D } =2D if (scm_is_true (scm_call_2 (pred, =2D SCM_CAR (list1), SCM_CAR (list2))= )) =2D return SCM_I_MAKINUM (n); =2D =2D list1 =3D SCM_CDR (list1); =2D list2 =3D SCM_CDR (list2); =2D } =2D } =2D else =2D { =2D /* three or more lists */ =2D SCM vec, args, a; =2D size_t len, i; =2D =2D /* vec is the list arguments */ =2D vec =3D scm_vector (scm_cons (list1, rest)); =2D len =3D SCM_SIMPLE_VECTOR_LENGTH (vec); =2D =2D /* args is the argument list to pass to pred, same length as vec, =2D re-used for each call */ =2D args =3D scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED); =2D =2D for ( ; ; n++) =2D { =2D /* first elem of each list in vec into args, and step those =2D vec entries onto their next element */ =2D for (i =3D 0, a =3D args, argnum =3D 2; =2D i < len; =2D i++, a =3D SCM_CDR (a), argnum++) =2D { =2D lst =3D SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument = */ =2D if (! scm_is_pair (lst)) =2D goto not_found_check_lst; =2D SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */ =2D SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of= lst */ =2D } =2D =2D if (scm_is_true (scm_apply (pred, args, SCM_EOL))) =2D return SCM_I_MAKINUM (n); =2D } =2D } =2D =2D not_found_check_lst: =2D SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "lis= t"); =2D return SCM_BOOL_F; + CACHE_VAR (list_index, "list-index"); + return scm_apply_2 (list_index, pred, list1, rest); } =2D#undef FUNC_NAME =2D =20 /* This routine differs from the core list-copy in allowing improper lists. Maybe the core could allow them similarly. */ @@ -1206,25 +1015,12 @@ SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0,= 0, } #undef FUNC_NAME =20 =2D =2DSCM_DEFINE (scm_srfi1_list_tabulate, "list-tabulate", 2, 0, 0, =2D (SCM n, SCM proc), =2D "Return an @var{n}-element list, where each list element is\n" =2D "produced by applying the procedure @var{init-proc} to the\n" =2D "corresponding list index. The order in which @var{init-proc}\n" =2D "is applied to the indices is not specified.") =2D#define FUNC_NAME s_scm_srfi1_list_tabulate +SCM +scm_srfi1_list_tabulate (SCM n, SCM proc) { =2D long i, nn; =2D SCM ret =3D SCM_EOL; =2D nn =3D scm_to_signed_integer (n, 0, LONG_MAX); =2D SCM_VALIDATE_PROC (SCM_ARG2, proc); =2D for (i =3D nn-1; i >=3D 0; i--) =2D ret =3D scm_cons (scm_call_1 (proc, scm_from_long (i)), ret); =2D return ret; + CACHE_VAR (list_tabulate, "list-tabulate"); + return scm_call_2 (list_tabulate, n, proc); } =2D#undef FUNC_NAME =2D =20 SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1, (SCM equal, SCM lst, SCM rest), @@ -1609,21 +1405,12 @@ SCM_DEFINE (scm_srfi1_ninth, "ninth", 1, 0, 0, } #undef FUNC_NAME =20 =2D =2DSCM_DEFINE (scm_srfi1_not_pair_p, "not-pair?", 1, 0, 0, =2D (SCM obj), =2D "Return @code{#t} is @var{obj} is not a pair, @code{#f}\n" =2D "otherwise.\n" =2D "\n" =2D "This is shorthand notation @code{(not (pair? @var{obj}))} and\n" =2D "is supposed to be used for end-of-list checking in contexts\n" =2D "where dotted lists are allowed.") =2D#define FUNC_NAME s_scm_srfi1_not_pair_p +SCM +scm_srfi1_not_pair_p (SCM obj) { =2D return scm_from_bool (! scm_is_pair (obj)); + CACHE_VAR (not_pair_p, "not-pair?"); + return scm_call_1 (not_pair_p, obj); } =2D#undef FUNC_NAME =2D =20 SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0, (SCM pred, SCM list), @@ -2153,17 +1940,14 @@ SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0, #undef FUNC_NAME =20 =20 =2DSCM_DEFINE (scm_srfi1_xcons, "xcons", 2, 0, 0, =2D (SCM d, SCM a), =2D "Like @code{cons}, but with interchanged arguments. Useful\n" =2D "mostly when passed to higher-order procedures.") =2D#define FUNC_NAME s_scm_srfi1_xcons +SCM +scm_srfi1_xcons (SCM d, SCM a) { =2D return scm_cons (a, d); + CACHE_VAR (xcons, "xcons"); + return scm_call_2 (xcons, d, a); } =2D#undef FUNC_NAME =2D =20 + void scm_init_srfi_1 (void) { diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index ecff82f..909f58c 100644 =2D-- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -1,6 +1,6 @@ ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -= *- ;;;; =2D;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009 Free Software Foundati= on, Inc. +;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 2010 Free Software Foun= dation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -1563,7 +1563,7 @@ =20 (with-test-prefix "list-tabulate" =20 =2D (pass-if-exception "-1" exception:out-of-range + (pass-if-exception "-1" exception:wrong-type-arg (list-tabulate -1 identity)) (pass-if "0" (equal? '() (list-tabulate 0 identity))) =2D-=20 1.7.0 --=-=-=-- --==-=-= Content-Type: application/pgp-signature -----BEGIN PGP SIGNATURE----- Version: GnuPG v2.0.12 (GNU/Linux) iEYEARECAAYFAkw7nccACgkQd92V4upS7PQ7OACfSAMx/Hw6xbLlekW7bY+YV1sd L9sAn3S/ioi7Jz11aJpc2o/+egyBP2EX =9Fuk -----END PGP SIGNATURE----- --==-=-=--