diff options
author | Ludovic Courtès <ludo@gnu.org> | 2010-07-13 00:07:12 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2010-07-21 01:07:56 +0200 |
commit | 0b7f2eb8bf5002c91dec6267afb451ee6e3bf7c1 (patch) | |
tree | fd4a85fa48234271610f7da0f0f4c80d157b1fc7 /module/srfi | |
parent | 927bf5e8cc0af9515797ebab6d9ba162bef23c2a (diff) | |
download | guile-0b7f2eb8bf5002c91dec6267afb451ee6e3bf7c1.tar.gz |
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.
Diffstat (limited to 'module/srfi')
-rw-r--r-- | module/srfi/srfi-1.scm | 64 |
1 files changed, 62 insertions, 2 deletions
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index c32eb1c50..27aa39e6f 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) |