[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-208-g0
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-208-g0b7f2eb |
|
Date: |
Tue, 20 Jul 2010 23:09:05 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=0b7f2eb8bf5002c91dec6267afb451ee6e3bf7c1
The branch, master has been updated
via 0b7f2eb8bf5002c91dec6267afb451ee6e3bf7c1 (commit)
via 927bf5e8cc0af9515797ebab6d9ba162bef23c2a (commit)
from 442eaa681b0c2db4254d4903f8a0996b4ffc83d0 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 0b7f2eb8bf5002c91dec6267afb451ee6e3bf7c1
Author: Ludovic Courtès <address@hidden>
Date: Tue Jul 13 00:07:12 2010 +0200
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'.
* test-suite/standalone/Makefile.am (test_srfi_1_SOURCES,
test_srfi_1_CFLAGS, test_srfi_1_LDADD): New variables.
(check_PROGRAMS): Add `test-srfi-1'.
(TESTS): Ditto.
* test-suite/standalone/test-srfi-1.c: New file.
commit 927bf5e8cc0af9515797ebab6d9ba162bef23c2a
Author: Ludovic Courtès <address@hidden>
Date: Tue Jul 20 10:27:38 2010 +0200
Add `vhash-fold*' in `(ice-9 vlist)'.
* module/ice-9/vlist.scm (%vhash-fold*): New inline procedure.
(vhash-fold*, vhash-foldq*, vhash-foldv*): New procedures.
* test-suite/tests/vlist.test ("vhash")["vhash-fold*", "vhash-fold*
tail", "vhash-fold* interleaved", "vhash-foldq* degenerate"]: New
tests.
* doc/ref/api-compound.texi (VHashes): Add `vhash-fold*' & co.
-----------------------------------------------------------------------
Summary of changes:
benchmark-suite/Makefile.am | 1 +
benchmark-suite/benchmarks/srfi-1.bm | 38 +++
doc/ref/api-compound.texi | 26 ++
module/ice-9/vlist.scm | 61 ++++-
module/srfi/srfi-1.scm | 64 ++++-
srfi/srfi-1.c | 320 ++++----------------
test-suite/standalone/.gitignore | 1 +
test-suite/standalone/Makefile.am | 7 +
.../{test-scm-take-u8vector.c => test-srfi-1.c} | 45 ++--
test-suite/tests/srfi-1.test | 4 +-
test-suite/tests/vlist.test | 43 +++-
11 files changed, 307 insertions(+), 303 deletions(-)
create mode 100644 benchmark-suite/benchmarks/srfi-1.bm
copy test-suite/standalone/{test-scm-take-u8vector.c => test-srfi-1.c} (55%)
diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am
index d99e457..b58219a 100644
--- a/benchmark-suite/Makefile.am
+++ b/benchmark-suite/Makefile.am
@@ -5,6 +5,7 @@ SCM_BENCHMARKS = 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/benchmarks/srfi-1.bm
new file mode 100644
index 0000000..2888934
--- /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/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 93d930f..bc8cb7f 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -3300,6 +3300,32 @@ Fold over the key/pair elements of @var{vhash}. For
each pair call @var{proc}
as @code{(@var{proc} key value result)}.
@end deffn
address@hidden {Scheme Procedure} vhash-fold* proc init key vhash [equal?
[hash]]
address@hidden {Scheme Procedure} vhash-foldq* proc init key vhash
address@hidden {Scheme Procedure} vhash-foldv* proc init key vhash
+Fold over all the values associated with @var{key} in @var{vhash}, with each
+call to @var{proc} having the form @code{(proc value result)}, where
address@hidden is the result of the previous call to @var{proc} and @var{init}
the
+value of @var{result} for the first call to @var{proc}.
+
+Keys in @var{vhash} are hashed using @var{hash} are compared using
@var{equal?}.
+The second form uses @code{eq?} as the equality predicate and @code{hashq} as
+the hash function; the third one uses @code{eqv?} and @code{hashv}.
+
+Example:
+
address@hidden
+(define vh
+ (alist->vhash '((a . 1) (a . 2) (z . 0) (a . 3))))
+
+(vhash-fold* cons '() 'a vh)
address@hidden (3 2 1)
+
+(vhash-fold* cons '() 'z vh)
address@hidden (0)
address@hidden example
address@hidden deffn
+
@deffn {Scheme Procedure} alist->vhash alist [hash-proc]
Return the vhash corresponding to @var{alist}, an association list, using
@var{hash-proc} to compute key hashes. When omitted, @var{hash-proc} defaults
diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index 0c92976..d72e6c1 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -31,7 +31,9 @@
vhash? vhash-cons vhash-consq vhash-consv
vhash-assoc vhash-assq vhash-assv
- vhash-delete vhash-fold alist->vhash))
+ vhash-delete vhash-fold
+ vhash-fold* vhash-foldq* vhash-foldv*
+ alist->vhash))
;;; Author: Ludovic Courtès <address@hidden>
;;;
@@ -408,9 +410,62 @@ with @var{value}. Use @var{hash} to compute @var{key}'s
hash."
(define vhash-consq (cut vhash-cons <> <> <> hashq))
(define vhash-consv (cut vhash-cons <> <> <> hashv))
-;; This hack to make sure `vhash-assq' gets to use the `eq?' instruction
instead
-;; of calling the `eq?' subr.
+(define-inline (%vhash-fold* proc init key vhash equal? hash)
+ ;; Fold over all the values associated with KEY in VHASH.
+ (define khash
+ (let ((size (block-size (vlist-base vhash))))
+ (and (> size 0) (hash key size))))
+
+ (let loop ((base (vlist-base vhash))
+ (khash khash)
+ (offset (and khash
+ (block-hash-table-ref (vlist-base vhash)
+ khash)))
+ (max-offset (vlist-offset vhash))
+ (result init))
+
+ (let ((answer (and offset (block-ref base offset))))
+ (cond ((and (pair? answer)
+ (<= offset max-offset)
+ (let ((answer-key (caar answer)))
+ (equal? key answer-key)))
+ (let ((result (proc (cdar answer) result))
+ (next-offset (cdr answer)))
+ (loop base khash next-offset max-offset result)))
+ ((and (pair? answer) (cdr answer))
+ =>
+ (lambda (next-offset)
+ (loop base khash next-offset max-offset result)))
+ (else
+ (let ((next-base (block-base base)))
+ (if (and next-base (> (block-size next-base) 0))
+ (let* ((khash (hash key (block-size next-base)))
+ (offset (block-hash-table-ref next-base khash)))
+ (loop next-base khash offset (block-offset base)
+ result))
+ result)))))))
+
+(define* (vhash-fold* proc init key vhash
+ #:optional (equal? equal?) (hash hash))
+ "Fold over all the values associated with @var{key} in @var{vhash}, with each
+call to @var{proc} having the form @code{(proc value result)}, where
address@hidden is the result of the previous call to @var{proc} and @var{init}
the
+value of @var{result} for the first call to @var{proc}."
+ (%vhash-fold* proc init key vhash equal? hash))
+
+(define (vhash-foldq* proc init key vhash)
+ "Same as @code{vhash-fold*}, but using @code{hashq} and @code{eq?}."
+ (%vhash-fold* proc init key vhash eq? hashq))
+
+(define (vhash-foldv* proc init key vhash)
+ "Same as @code{vhash-fold*}, but using @code{hashv} and @code{eqv?}."
+ (%vhash-fold* proc init key vhash eqv? hashv))
+
(define-inline (%vhash-assoc key vhash equal? hash)
+ ;; A specialization of `vhash-fold*' that stops when the first value
+ ;; associated with KEY is found or when the end-of-list is reached. Inline
to
+ ;; make sure `vhash-assq' gets to use the `eq?' instruction instead of
calling
+ ;; the `eq?' subr.
(define khash
(let ((size (block-size (vlist-base vhash))))
(and (> size 0) (hash key size))))
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index c32eb1c..27aa39e 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -1,6 +1,6 @@
;;; srfi-1.scm --- List Library
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009 Free Software
Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010 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
@@ -225,6 +225,11 @@
;;; Constructors
+(define (xcons d a)
+ "Like `cons', but with interchanged arguments. Useful mostly when passed 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) (>= x 0)))
-
+(define (list-tabulate n init-proc)
+ "Return an N-element list, where each list element is produced by applying
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 (<= n 0)
+ acc
+ (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
(define (circular-list elt1 . elts)
(set! elts (cons elt1 elts))
@@ -294,6 +307,13 @@
(else
(error "not a proper list in null-list?"))))
+(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= elt= . rest)
(define (lists-equal a b)
(let lp ((a a) (b b))
@@ -317,9 +337,17 @@
(define third caddr)
(define fourth cadddr)
+(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)
+(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
(define (zip clist1 . rest)
@@ -343,6 +371,21 @@
;;; Fold, unfold & map
+(define (fold kons knil list1 . rest)
+ "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
+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)))))))
+(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
(define alist-cons acons)
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 537c2b3..44db0e3 100644
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -27,13 +27,34 @@
#include "srfi-1.h"
-/* The intent of this file is to gradually replace those Scheme
- * 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.
*
- * Please feel free to contribute any new replacements!
+ * However, we now prefer to write these procedures in Scheme, let the compiler
+ * optimize them, and have the VM execute them efficiently.
*/
+
+/* The `(srfi srfi-1)' module. */
+static SCM srfi1_module = SCM_BOOL_F;
+
+/* Cache variable NAME in C variable VAR. */
+#define CACHE_VAR(var, name) \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ { \
+ if (SCM_UNLIKELY (scm_is_false (srfi1_module))) \
+ srfi1_module = scm_c_resolve_module ("srfi srfi-1"); \
+ \
+ var = scm_module_variable (srfi1_module, \
+ scm_from_locale_symbol (name)); \
+ if (SCM_UNLIKELY (scm_is_false (var))) \
+ abort (); \
+ \
+ var = SCM_VARIABLE_REF (var); \
+ }
+
static long
srfi1_ilength (SCM sx)
{
@@ -253,16 +274,12 @@ SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_srfi1_car_plus_cdr, "car+cdr", 1, 0, 0,
- (SCM pair),
- "Return two values, the @sc{car} and the @sc{cdr} of @var{pair}.")
-#define FUNC_NAME s_scm_srfi1_car_plus_cdr
+SCM
+scm_srfi1_car_plus_cdr (SCM pair)
{
- SCM_VALIDATE_CONS (SCM_ARG1, pair);
- 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);
}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0,
(SCM lstlst),
@@ -935,131 +952,19 @@ SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0,
}
#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_fold, "fold", 3, 0, 1,
- (SCM proc, SCM init, SCM list1, SCM rest),
- "Apply @var{proc} to the elements of @var{lst1} @dots{}\n"
- "@var{lstN} to build a result, and return that result.\n"
- "\n"
- "Each @var{proc} call is @code{(@var{proc} @var{elem1} @dots{}\n"
- "@var{elemN} @var{previous})}, where @var{elem1} is from\n"
- "@var{lst1}, through @var{elemN} from @var{lstN}.\n"
- "@var{previous} is the return from the previous call to\n"
- "@var{proc}, or the given @var{init} for the first call. If any\n"
- "list is empty, just @var{init} is returned.\n"
- "\n"
- "@code{fold} works through the list elements from first to last.\n"
- "The following shows a list reversal and the calls it makes,\n"
- "\n"
- "@example\n"
- "(fold cons '() '(1 2 3))\n"
- "\n"
- "(cons 1 '())\n"
- "(cons 2 '(1))\n"
- "(cons 3 '(2 1)\n"
- "@result{} (3 2 1)\n"
- "@end example\n"
- "\n"
- "If @var{lst1} through @var{lstN} have different lengths,\n"
- "@code{fold} stops when the end of the shortest is reached.\n"
- "Ie.@: elements past the length of the shortest are ignored in\n"
- "the other @var{lst}s. At least one @var{lst} must be\n"
- "non-circular.\n"
- "\n"
- "The way @code{fold} builds a result from iterating is quite\n"
- "general, it can do more than other iterations like say\n"
- "@code{map} or @code{filter}. The following for example removes\n"
- "adjacent duplicate elements from a list,\n"
- "\n"
- "@example\n"
- "(define (delete-adjacent-duplicates lst)\n"
- " (fold-right (lambda (elem ret)\n"
- " (if (equal? elem (first ret))\n"
- " ret\n"
- " (cons elem ret)))\n"
- " (list (last lst))\n"
- " lst))\n"
- "(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))\n"
- "@result{} (1 2 3 4 5)\n"
- "@end example\n"
- "\n"
- "Clearly the same sort of thing can be done with a\n"
- "@code{for-each} and a variable in which to build the result,\n"
- "but a self-contained @var{proc} can be re-used in multiple\n"
- "contexts, where a @code{for-each} would have to be written out\n"
- "each time.")
-#define FUNC_NAME s_scm_srfi1_fold
+SCM
+scm_srfi1_fold (SCM proc, SCM init, SCM list1, SCM rest)
{
- SCM lst;
- int argnum;
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- if (scm_is_null (rest))
- {
- /* one list */
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
-
- for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
- init = scm_call_2 (proc, SCM_CAR (list1), init);
-
- /* check below that list1 is a proper list, and done */
- lst = list1;
- argnum = 2;
- }
- else
- {
- /* two or more lists */
- SCM vec, args, a;
- size_t len, i;
-
- /* vec is the list arguments */
- vec = scm_vector (scm_cons (list1, rest));
- len = SCM_SIMPLE_VECTOR_LENGTH (vec);
-
- /* args is the argument list to pass to proc, same length as vec,
- re-used for each call */
- args = scm_make_list (SCM_I_MAKINUM (len+1), SCM_UNDEFINED);
-
- for (;;)
- {
- /* first elem of each list in vec into args, and step those
- vec entries onto their next element */
- for (i = 0, a = args, argnum = 2;
- i < len;
- i++, a = SCM_CDR (a), argnum++)
- {
- lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
- if (! scm_is_pair (lst))
- goto check_lst_and_done;
- SCM_SETCAR (a, SCM_CAR (lst)); /* arg for proc */
- SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
- }
- SCM_SETCAR (a, init);
-
- init = scm_apply (proc, args, SCM_EOL);
- }
- }
-
- check_lst_and_done:
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
- return init;
+ CACHE_VAR (fold, "fold");
+ return scm_apply_3 (fold, proc, init, list1, rest);
}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_last, "last", 1, 0, 0,
- (SCM lst),
- "Like @code{cons}, but with interchanged arguments. Useful\n"
- "mostly when passed to higher-order procedures.")
-#define FUNC_NAME s_scm_srfi1_last
+SCM
+scm_srfi1_last (SCM lst)
{
- SCM pair = scm_last_pair (lst);
- /* scm_last_pair returns SCM_EOL for an empty list */
- SCM_VALIDATE_CONS (SCM_ARG1, pair);
- return SCM_CAR (pair);
+ CACHE_VAR (last, "last");
+ return scm_call_1 (last, lst);
}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
(SCM lst),
@@ -1073,106 +978,12 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_srfi1_list_index, "list-index", 2, 0, 1,
- (SCM pred, SCM list1, SCM rest),
- "Return the index of the first set of elements, one from each of\n"
- "@address@hidden@var{lstN}, which satisfies @var{pred}.\n"
- "\n"
- "@var{pred} is called as @code{(@var{pred} elem1 @dots{}\n"
- "elemN)}. Searching stops when the end of the shortest\n"
- "@var{lst} is reached. The return index starts from 0 for the\n"
- "first set of elements. If no set of elements pass then the\n"
- "return is @code{#f}.\n"
- "\n"
- "@example\n"
- "(list-index odd? '(2 4 6 9)) @result{} 3\n"
- "(list-index = '(1 2 3) '(3 1 2)) @result{} #f\n"
- "@end example")
-#define FUNC_NAME s_scm_srfi1_list_index
+SCM
+scm_srfi1_list_index (SCM pred, SCM list1, SCM rest)
{
- long n = 0;
- SCM lst;
- int argnum;
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- if (scm_is_null (rest))
- {
- /* one list */
- SCM_VALIDATE_PROC (SCM_ARG1, pred);
-
- for ( ; scm_is_pair (list1); n++, list1 = SCM_CDR (list1))
- if (scm_is_true (scm_call_1 (pred, SCM_CAR (list1))))
- return SCM_I_MAKINUM (n);
-
- /* not found, check below that list1 is a proper list */
- end_list1:
- lst = list1;
- argnum = 2;
- }
- else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
- {
- /* two lists */
- SCM list2 = SCM_CAR (rest);
- SCM_VALIDATE_PROC (SCM_ARG1, pred);
-
- for ( ; ; n++)
- {
- if (! scm_is_pair (list1))
- goto end_list1;
- if (! scm_is_pair (list2))
- {
- lst = list2;
- argnum = 3;
- break;
- }
- if (scm_is_true (scm_call_2 (pred,
- SCM_CAR (list1), SCM_CAR (list2))))
- return SCM_I_MAKINUM (n);
-
- list1 = SCM_CDR (list1);
- list2 = SCM_CDR (list2);
- }
- }
- else
- {
- /* three or more lists */
- SCM vec, args, a;
- size_t len, i;
-
- /* vec is the list arguments */
- vec = scm_vector (scm_cons (list1, rest));
- len = SCM_SIMPLE_VECTOR_LENGTH (vec);
-
- /* args is the argument list to pass to pred, same length as vec,
- re-used for each call */
- args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
-
- for ( ; ; n++)
- {
- /* first elem of each list in vec into args, and step those
- vec entries onto their next element */
- for (i = 0, a = args, argnum = 2;
- i < len;
- i++, a = SCM_CDR (a), argnum++)
- {
- lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
- if (! scm_is_pair (lst))
- goto not_found_check_lst;
- SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */
- SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
- }
-
- if (scm_is_true (scm_apply (pred, args, SCM_EOL)))
- return SCM_I_MAKINUM (n);
- }
- }
-
- not_found_check_lst:
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
- return SCM_BOOL_F;
+ CACHE_VAR (list_index, "list-index");
+ return scm_apply_2 (list_index, pred, list1, rest);
}
-#undef FUNC_NAME
-
/* This routine differs from the core list-copy in allowing improper lists.
Maybe the core could allow them similarly. */
@@ -1206,25 +1017,12 @@ SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
}
#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_list_tabulate, "list-tabulate", 2, 0, 0,
- (SCM n, SCM proc),
- "Return an @var{n}-element list, where each list element is\n"
- "produced by applying the procedure @var{init-proc} to the\n"
- "corresponding list index. The order in which @var{init-proc}\n"
- "is applied to the indices is not specified.")
-#define FUNC_NAME s_scm_srfi1_list_tabulate
+SCM
+scm_srfi1_list_tabulate (SCM n, SCM proc)
{
- long i, nn;
- SCM ret = SCM_EOL;
- nn = scm_to_signed_integer (n, 0, LONG_MAX);
- SCM_VALIDATE_PROC (SCM_ARG2, proc);
- for (i = nn-1; i >= 0; i--)
- ret = scm_cons (scm_call_1 (proc, scm_from_long (i)), ret);
- return ret;
+ CACHE_VAR (list_tabulate, "list-tabulate");
+ return scm_call_2 (list_tabulate, n, proc);
}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1,
(SCM equal, SCM lst, SCM rest),
@@ -1609,21 +1407,12 @@ SCM_DEFINE (scm_srfi1_ninth, "ninth", 1, 0, 0,
}
#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_not_pair_p, "not-pair?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} is @var{obj} is not a pair, @code{#f}\n"
- "otherwise.\n"
- "\n"
- "This is shorthand notation @code{(not (pair? @var{obj}))} and\n"
- "is supposed to be used for end-of-list checking in contexts\n"
- "where dotted lists are allowed.")
-#define FUNC_NAME s_scm_srfi1_not_pair_p
+SCM
+scm_srfi1_not_pair_p (SCM obj)
{
- return scm_from_bool (! scm_is_pair (obj));
+ CACHE_VAR (not_pair_p, "not-pair?");
+ return scm_call_1 (not_pair_p, obj);
}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
(SCM pred, SCM list),
@@ -2153,17 +1942,14 @@ SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_srfi1_xcons, "xcons", 2, 0, 0,
- (SCM d, SCM a),
- "Like @code{cons}, but with interchanged arguments. Useful\n"
- "mostly when passed to higher-order procedures.")
-#define FUNC_NAME s_scm_srfi1_xcons
+SCM
+scm_srfi1_xcons (SCM d, SCM a)
{
- return scm_cons (a, d);
+ CACHE_VAR (xcons, "xcons");
+ return scm_call_2 (xcons, d, a);
}
-#undef FUNC_NAME
-
+
void
scm_init_srfi_1 (void)
{
diff --git a/test-suite/standalone/.gitignore b/test-suite/standalone/.gitignore
index 94b4307..794146e 100644
--- a/test-suite/standalone/.gitignore
+++ b/test-suite/standalone/.gitignore
@@ -12,3 +12,4 @@
/test-scm-take-locale-symbol
/test-scm-take-u8vector
/test-loose-ends
+/test-srfi-1
diff --git a/test-suite/standalone/Makefile.am
b/test-suite/standalone/Makefile.am
index 4582c9e..a748c1e 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -163,6 +163,13 @@ libtest_extensions_la_LIBADD =
${top_builddir}/libguile/address@hidden
check_SCRIPTS += test-extensions
TESTS += test-extensions
+# test-srfi-1
+test_srfi_1_SOURCES = test-srfi-1.c
+test_srfi_1_CFLAGS = ${test_cflags}
+test_srfi_1_LDADD = \
+ ${top_builddir}/srfi/address@hidden@.la
+check_PROGRAMS += test-srfi-1
+TESTS += test-srfi-1
if BUILD_PTHREAD_SUPPORT
diff --git a/test-suite/standalone/test-scm-take-u8vector.c
b/test-suite/standalone/test-srfi-1.c
similarity index 55%
copy from test-suite/standalone/test-scm-take-u8vector.c
copy to test-suite/standalone/test-srfi-1.c
index fff3af4..215008d 100644
--- a/test-suite/standalone/test-scm-take-u8vector.c
+++ b/test-suite/standalone/test-srfi-1.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2010 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
@@ -16,50 +16,45 @@
* 02110-1301 USA
*/
-/* Make sure `scm_take_u8vector ()' returns a u8vector that actually uses the
- provided storage. */
+/* Exercise the compatibility layer of `libguile-srfi-srfi-1'. */
-
-#ifdef HAVE_CONFIG_H
+#ifndef HAVE_CONFIG_H
# include <config.h>
#endif
#include <libguile.h>
+#include <srfi/srfi-1.h>
#include <stdlib.h>
-
static void *
-do_test (void *result)
+tests (void *data)
{
-#define LEN 123
- SCM u8v;
- scm_t_uint8 *data;
- scm_t_array_handle handle;
+ SCM times, lst, result;
- data = scm_malloc (LEN);
- u8v = scm_take_u8vector (data, LEN);
+ scm_init_srfi_1 ();
- scm_array_get_handle (u8v, &handle);
+ times = SCM_VARIABLE_REF (scm_c_lookup ("*"));
+ lst = scm_list_3 (scm_from_int (1), scm_from_int (2), scm_from_int (3));
- if (scm_array_handle_u8_writable_elements (&handle) == data
- && scm_array_handle_u8_elements (&handle) == data)
- * (int *) result = EXIT_SUCCESS;
- else
- * (int *) result = EXIT_FAILURE;
+ /* (fold * 1 '(1 2 3) '(1 2 3)) */
+ result = scm_srfi1_fold (times, scm_from_int (1), lst, scm_list_1 (lst));
- scm_array_handle_release (&handle);
+ if (scm_to_int (result) == 36)
+ * (int *) data = EXIT_SUCCESS;
+ else
+ * (int *) data = EXIT_FAILURE;
- return NULL;
-#undef LEN
+ return data;
}
+
int
main (int argc, char *argv[])
{
- int result;
+ int ret;
- scm_with_guile (do_test, &result);
+ scm_with_guile (tests, &ret);
- return result;
+ return ret;
}
diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index ecff82f..909f58c 100644
--- 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 -*-
;;;;
-;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009 Free Software Foundation,
Inc.
+;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 2010 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
@@ -1563,7 +1563,7 @@
(with-test-prefix "list-tabulate"
- (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)))
diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test
index 47e386e..f3e0989 100644
--- a/test-suite/tests/vlist.test
+++ b/test-suite/tests/vlist.test
@@ -19,9 +19,10 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-vlist)
- :use-module (test-suite lib)
- :use-module (ice-9 vlist)
- :use-module (srfi srfi-1))
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 vlist)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26))
;;;
@@ -300,4 +301,38 @@
(equal? (assq k alist)
(vhash-assoc k vh eq?))))
#t
- keys)))))
+ keys))))
+
+ (pass-if "vhash-fold*"
+ (let* ((keys (make-list 10 'a))
+ (values (iota 10))
+ (vh (fold vhash-cons vlist-null keys values)))
+ (equal? (vhash-fold* cons '() 'a vh)
+ values)))
+
+ (pass-if "vhash-fold* tail"
+ (let* ((keys (make-list 100 'a))
+ (values (iota 100))
+ (vh (fold vhash-cons vlist-null keys values)))
+ (equal? (vhash-fold* cons '() 'a (vlist-drop vh 42))
+ (take values (- 100 42)))))
+
+ (pass-if "vhash-fold* interleaved"
+ (let* ((keys '(a b a b a b a b a b c d e a b))
+ (values '(1 0 2 0 3 0 4 0 5 0 0 0 0 6 0))
+ (vh (fold vhash-cons vlist-null keys values)))
+ (equal? (vhash-fold* cons '() 'a vh)
+ (filter (cut > <> 0) values))))
+
+ (pass-if "vhash-foldq* degenerate"
+ (let* ((keys '(a b a b a a a b a b a a a z))
+ (values '(1 0 2 0 3 4 5 0 6 0 7 8 9 0))
+ (vh (fold (lambda (k v vh)
+ ;; Degenerate case where VH2 contains only
+ ;; 1-element blocks.
+ (let* ((vh1 (vhash-consq 'x 'x vh))
+ (vh2 (vlist-tail vh1)))
+ (vhash-consq k v vh2)))
+ vlist-null keys values)))
+ (equal? (vhash-foldq* cons '() 'a vh)
+ (filter (cut > <> 0) values)))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-11-208-g0b7f2eb,
Ludovic Courtès <=