summaryrefslogtreecommitdiff
path: root/module/srfi
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2010-07-13 00:07:12 +0200
committerLudovic Courtès <ludo@gnu.org>2010-07-21 01:07:56 +0200
commit0b7f2eb8bf5002c91dec6267afb451ee6e3bf7c1 (patch)
treefd4a85fa48234271610f7da0f0f4c80d157b1fc7 /module/srfi
parent927bf5e8cc0af9515797ebab6d9ba162bef23c2a (diff)
downloadguile-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.scm64
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)