mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Start rewriting SRFI-1 in Scheme.

Browse source 
This partially reverts commit e556f8c3c6
(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.
This commit is contained in:
Ludovic Courtès 2010-07-13 00:07:12 +02:00
parent 927bf5e8cc
commit 0b7f2eb8bf
8 changed files with 224 additions and 271 deletions
Download patch file Download diff file Expand all files Collapse all files

1
benchmark-suite/Makefile.am
View file

@ -5,6 +5,7 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/if.bm \ benchmarks/if.bm \
benchmarks/logand.bm \ benchmarks/logand.bm \
benchmarks/read.bm \ benchmarks/read.bm \
benchmarks/srfi-1.bm \
benchmarks/srfi-13.bm \ benchmarks/srfi-13.bm \
benchmarks/structs.bm \ benchmarks/structs.bm \
benchmarks/subr.bm \ benchmarks/subr.bm \

38
benchmark-suite/benchmarks/srfi-1.bm Normal file
View file

@ -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)))

64
module/srfi/srfi-1.scm
View file

@ -1,6 +1,6 @@
;;; srfi-1.scm --- List Library ;;; 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 ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -225,6 +225,11 @@
;;; Constructors ;;; 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. ;; internal helper, similar to (scsh utilities) check-arg.
(define (check-arg-type pred arg caller) (define (check-arg-type pred arg caller)
(if (pred arg) (if (pred arg)
@ -235,7 +240,15 @@
;; the srfi spec doesn't seem to forbid inexact integers. ;; the srfi spec doesn't seem to forbid inexact integers.
(define (non-negative-integer? x) (and (integer? x) (>= x 0))) (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) (define (circular-list elt1 . elts)
(set! elts (cons elt1 elts)) (set! elts (cons elt1 elts))
@ -294,6 +307,13 @@
(else (else
(error "not a proper list in null-list?")))) (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 (list= elt= . rest)
(define (lists-equal a b) (define (lists-equal a b)
(let lp ((a a) (b b)) (let lp ((a a) (b b))
@ -317,9 +337,17 @@
(define third caddr) (define third caddr)
(define fourth cadddr) (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 take list-head)
(define drop list-tail) (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 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
(define (zip clist1 . rest) (define (zip clist1 . rest)
@ -343,6 +371,21 @@
;;; Fold, unfold & map ;;; 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) (define (fold-right kons knil clist1 . rest)
(if (null? rest) (if (null? rest)
(let f ((list1 clist1)) (let f ((list1 clist1))
@ -463,6 +506,23 @@
(else (else
(and (pred (car ls)) (lp (cdr ls))))))) (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 ;;; Association lists
(define alist-cons acons) (define alist-cons acons)

320
srfi/srfi-1.c
View file

@ -27,13 +27,34 @@
#include "srfi-1.h" #include "srfi-1.h"
/* The intent of this file is to gradually replace those Scheme /* The intent of this file was to gradually replace those Scheme
* procedures in srfi-1.scm which extends core primitive procedures, * procedures in srfi-1.scm that extend core primitive procedures,
* so that using srfi-1 won't have performance penalties. * 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 static long
srfi1_ilength (SCM sx) srfi1_ilength (SCM sx)
{ {
@ -253,16 +274,12 @@ SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_srfi1_car_plus_cdr, "car+cdr", 1, 0, 0, SCM
(SCM pair), scm_srfi1_car_plus_cdr (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_VALIDATE_CONS (SCM_ARG1, pair); CACHE_VAR (car_plus_cdr, "car+cdr");
return scm_values (scm_list_2 (SCM_CAR (pair), SCM_CDR (pair))); return scm_call_1 (car_plus_cdr, pair);
} }
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0, SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0,
(SCM lstlst), (SCM lstlst),
@ -935,131 +952,19 @@ SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM
SCM_DEFINE (scm_srfi1_fold, "fold", 3, 0, 1, scm_srfi1_fold (SCM proc, SCM init, SCM list1, SCM rest)
(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 lst; CACHE_VAR (fold, "fold");
int argnum; return scm_apply_3 (fold, proc, init, list1, rest);
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;
} }
#undef FUNC_NAME
SCM
SCM_DEFINE (scm_srfi1_last, "last", 1, 0, 0, scm_srfi1_last (SCM lst)
(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 pair = scm_last_pair (lst); CACHE_VAR (last, "last");
/* scm_last_pair returns SCM_EOL for an empty list */ return scm_call_1 (last, lst);
SCM_VALIDATE_CONS (SCM_ARG1, pair);
return SCM_CAR (pair);
} }
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0, SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
(SCM lst), (SCM lst),
@ -1073,106 +978,12 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_srfi1_list_index, "list-index", 2, 0, 1, SCM
(SCM pred, SCM list1, SCM rest), scm_srfi1_list_index (SCM pred, SCM list1, SCM rest)
"Return the index of the first set of elements, one from each of\n"
"@var{lst1}@dots{}@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
{ {
long n = 0; CACHE_VAR (list_index, "list-index");
SCM lst; return scm_apply_2 (list_index, pred, list1, rest);
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;
} }
#undef FUNC_NAME
/* This routine differs from the core list-copy in allowing improper lists. /* This routine differs from the core list-copy in allowing improper lists.
Maybe the core could allow them similarly. */ 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 #undef FUNC_NAME
SCM
SCM_DEFINE (scm_srfi1_list_tabulate, "list-tabulate", 2, 0, 0, scm_srfi1_list_tabulate (SCM n, SCM proc)
(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
{ {
long i, nn; CACHE_VAR (list_tabulate, "list-tabulate");
SCM ret = SCM_EOL; return scm_call_2 (list_tabulate, n, proc);
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;
} }
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1, SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1,
(SCM equal, SCM lst, SCM rest), (SCM equal, SCM lst, SCM rest),
@ -1609,21 +1407,12 @@ SCM_DEFINE (scm_srfi1_ninth, "ninth", 1, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM
SCM_DEFINE (scm_srfi1_not_pair_p, "not-pair?", 1, 0, 0, scm_srfi1_not_pair_p (SCM obj)
(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
{ {
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_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
(SCM pred, SCM list), (SCM pred, SCM list),
@ -2153,17 +1942,14 @@ SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_srfi1_xcons, "xcons", 2, 0, 0, SCM
(SCM d, SCM a), scm_srfi1_xcons (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
{ {
return scm_cons (a, d); CACHE_VAR (xcons, "xcons");
return scm_call_2 (xcons, d, a);
} }
#undef FUNC_NAME
void void
scm_init_srfi_1 (void) scm_init_srfi_1 (void)
{ {

1
test-suite/standalone/.gitignore vendored
View file

@ -12,3 +12,4 @@
/test-scm-take-locale-symbol /test-scm-take-locale-symbol
/test-scm-take-u8vector /test-scm-take-u8vector
/test-loose-ends /test-loose-ends
/test-srfi-1

7
test-suite/standalone/Makefile.am
View file

@ -163,6 +163,13 @@ libtest_extensions_la_LIBADD = ${top_builddir}/libguile/libguile-@GUILE_EFFECTIV
check_SCRIPTS += test-extensions check_SCRIPTS += test-extensions
TESTS += 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/libguile-srfi-srfi-1-v-@LIBGUILE_SRFI_SRFI_1_MAJOR@.la
check_PROGRAMS += test-srfi-1
TESTS += test-srfi-1
if BUILD_PTHREAD_SUPPORT if BUILD_PTHREAD_SUPPORT

60
test-suite/standalone/test-srfi-1.c Normal file
View file

@ -0,0 +1,60 @@
/* 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
* 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, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
/* Exercise the compatibility layer of `libguile-srfi-srfi-1'. */
#ifndef HAVE_CONFIG_H
# include <config.h>
#endif
#include <libguile.h>
#include <srfi/srfi-1.h>
#include <stdlib.h>
static void *
tests (void *data)
{
SCM times, lst, result;
scm_init_srfi_1 ();
times = SCM_VARIABLE_REF (scm_c_lookup ("*"));
lst = scm_list_3 (scm_from_int (1), scm_from_int (2), scm_from_int (3));
/* (fold * 1 '(1 2 3) '(1 2 3)) */
result = scm_srfi1_fold (times, scm_from_int (1), lst, scm_list_1 (lst));
if (scm_to_int (result) == 36)
* (int *) data = EXIT_SUCCESS;
else
* (int *) data = EXIT_FAILURE;
return data;
}
int
main (int argc, char *argv[])
{
int ret;
scm_with_guile (tests, &ret);
return ret;
}

4
test-suite/tests/srfi-1.test
View file

@ -1,6 +1,6 @@
;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -1563,7 +1563,7 @@
(with-test-prefix "list-tabulate" (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)) (list-tabulate -1 identity))
(pass-if "0" (pass-if "0"
(equal? '() (list-tabulate 0 identity))) (equal? '() (list-tabulate 0 identity)))