mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +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/logand.bm \
benchmarks/read.bm \
benchmarks/srfi-1.bm \
benchmarks/srfi-13.bm \
benchmarks/structs.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
;; 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)

320
srfi/srfi-1.c
View file

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

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

@ -12,3 +12,4 @@
/test-scm-take-locale-symbol
/test-scm-take-u8vector
/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
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

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 -*-
;;;;
;;;; 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)))