Author: yamakenz
Date: Sun Jul 1 03:58:06 2007
New Revision: 4643
Added:
sigscheme-trunk/test/test-srfi1-another.scm
Modified:
sigscheme-trunk/QALog
sigscheme-trunk/src/list.c
sigscheme-trunk/src/module-srfi1.c
sigscheme-trunk/src/sigscheme.h
sigscheme-trunk/test/test-srfi1.scm
Log:
* src/sigscheme.h
- (scm_p_srfi1_proper_listp, scm_p_srfi1_drop): Removed
* src/module-srfi1.c
- (scm_initialize_srfi1):
* Add alias proper-list? -> list?
* Add alias drop -> list-tail
- (scm_p_srfi1_proper_listp): Removed and replaced with list?
- (scm_p_srfi1_drop): Removed and replaced with list-tail. This change fix
the invalid returning of dotted tail on negative index such as (drop 1 -1)
==> 1
- (scm_p_srfi1_last_pair): Optimize
- (scm_p_srfi1_lengthplus): Change the behavior on dotted list as same as the
reference implementation
- (scm_p_srfi1_find_tail): Allow dotted list as same as the reference
implementation
* src/list.c
- (scm_p_list_tail): Add a comment about SRFI-1 drop
* test/test-srfi1-another.scm
- New file
- Add various tests for SRFI-1 procedures implemented in module-srfi1.c
* test/test-srfi1.scm
- Remove obsoleted length+ tests
* QALog
- Update
Modified: sigscheme-trunk/QALog
==============================================================================
--- sigscheme-trunk/QALog (original)
+++ sigscheme-trunk/QALog Sun Jul 1 03:58:06 2007
@@ -265,7 +265,7 @@
yyyy yyy r5rs qquote.c
r5rs macro.c
r5rs promise.c
- srfi module-srfi1.c
+yyyy yyy srfi module-srfi1.c
yyyy yyy srfi module-srfi2.c
yyyy yyy srfi module-srfi6.c
yyyy yyy srfi module-srfi8.c
@@ -915,14 +915,14 @@
file: module-srfi1.c
category: srfi
-spec by eyes:
-spec by tests:
-general review:
-64-bit by eyes:
-64-bit by tests:
-coding style:
-normal case tests:
-corner case tests:
+spec by eyes: [EMAIL PROTECTED]
+spec by tests: [EMAIL PROTECTED]
+general review: [EMAIL PROTECTED]
+64-bit by eyes: [EMAIL PROTECTED]
+64-bit by tests:
+coding style: [EMAIL PROTECTED]
+normal case tests: [EMAIL PROTECTED]
+corner case tests: [EMAIL PROTECTED]
file: module-srfi2.c
category: srfi
@@ -1081,6 +1081,11 @@
Log
---
+2007-07-01 YamaKen <yamaken AT bp.iij4u.or.jp>
+ * module-srfi1.c
+ - QA done @r4643 with test-srfi1-another.scm, test-srfi1.scm and
+ stone-srfi1.scm
+
2007-06-30 YamaKen <yamaken AT bp.iij4u.or.jp>
* env.c
- QA done again @r4613 with test-misc.scm
Modified: sigscheme-trunk/src/list.c
==============================================================================
--- sigscheme-trunk/src/list.c (original)
+++ sigscheme-trunk/src/list.c Sun Jul 1 03:58:06 2007
@@ -374,6 +374,11 @@
return lst;
}
+/* Since this procedure is also used as SRFI-1 'drop', following specification
+ * must also be satisfied.
+ *
+ * SRFI-1: drop returns all but the first i elements of list x.
+ * x may be any value -- a proper, circular, or dotted list. */
SCM_EXPORT ScmObj
scm_p_list_tail(ScmObj lst, ScmObj k)
{
Modified: sigscheme-trunk/src/module-srfi1.c
==============================================================================
--- sigscheme-trunk/src/module-srfi1.c (original)
+++ sigscheme-trunk/src/module-srfi1.c Sun Jul 1 03:58:06 2007
@@ -87,22 +87,18 @@
scm_define_alias("for-each", "r5rs:for-each");
#endif
- /* overwrite Scheme procedures with efficient C implementations */
+ /* Overwrite Scheme procedures with efficient C implementations. */
scm_register_funcs(scm_functable_srfi1);
+
+ scm_define_alias("proper-list?", "list?");
+ /* SigScheme's list-tail satisfies the specification of drop. */
+ scm_define_alias("drop", "list-tail");
}
/*===========================================================================
Predicates
===========================================================================*/
SCM_EXPORT ScmObj
-scm_p_srfi1_proper_listp(ScmObj obj)
-{
- DECLARE_FUNCTION("proper-list?", procedure_fixed_1);
-
- return MAKE_BOOL(PROPER_LISTP(obj));
-}
-
-SCM_EXPORT ScmObj
scm_p_srfi1_circular_listp(ScmObj obj)
{
DECLARE_FUNCTION("circular-list?", procedure_fixed_1);
@@ -121,39 +117,17 @@
/*===========================================================================
Selectors
===========================================================================*/
-/* SRFI1: drop returns all but the first i elements of list x.
- * x may be any value -- a proper, circular, or dotted list. */
-SCM_EXPORT ScmObj
-scm_p_srfi1_drop(ScmObj lst, ScmObj scm_idx)
-{
- ScmObj ret;
- scm_int_t idx, i;
- DECLARE_FUNCTION("drop", procedure_fixed_2);
-
- ENSURE_INT(scm_idx);
-
- idx = SCM_INT_VALUE(scm_idx);
- ret = lst;
- for (i = 0; i < idx; i++) {
- if (!CONSP(ret))
- ERR_OBJ("illegal index is specified for", lst);
-
- ret = CDR(ret);
- }
-
- return ret;
-}
-
/* SRFI-1: last-pair returns the last pair in the non-empty, finite list
* pair. */
SCM_EXPORT ScmObj
scm_p_srfi1_last_pair(ScmObj lst)
{
+ ScmObj next;
DECLARE_FUNCTION("last-pair", procedure_fixed_1);
ENSURE_CONS(lst);
- for (; CONSP(CDR(lst)); lst = CDR(lst))
+ for (; next = CDR(lst), CONSP(next); lst = next)
;
return lst;
@@ -169,22 +143,28 @@
DECLARE_FUNCTION("length+", procedure_fixed_1);
len = scm_length(lst);
- /* although SRFI-1 does not specify the behavior for dotted list
- * explicitly, the description indicates that dotted list is treated as
- * same as R5RS 'length' procedure. So produce an error here. */
- if (SCM_LISTLEN_DOTTEDP(len))
- ERR_OBJ("proper or circular list required but got", lst);
-
- return (SCM_LISTLEN_PROPERP(len)) ? MAKE_INT(len) : SCM_FALSE;
+ /* Although the behavior on dotted list is not defined in SRFI-1 itself,
+ * the reference implementation returns its length. So SigScheme followed
+ * it. */
+ if (SCM_LISTLEN_PROPERP(len))
+ return MAKE_INT(len);
+ else if (SCM_LISTLEN_DOTTEDP(len))
+ return MAKE_INT(SCM_LISTLEN_DOTTED(len));
+ else /* if (SCM_LISTLEN_CIRCULARP(len)) */
+ return SCM_FALSE;
}
/*===========================================================================
Searching
===========================================================================*/
+/* Although the behavior on null list is not explicitly defined in SRFI-1
+ * itself, the reference implementation returns #f So SigScheme followed it.
+ * Although the behavior on dotted list is not defined in SRFI-1 itself, the
+ * reference implementation returns the last pair. So SigScheme followed it. */
SCM_EXPORT ScmObj
scm_p_srfi1_find_tail(ScmObj pred, ScmObj lst)
{
- ScmObj tail, elm, found, term;
+ ScmObj tail, elm, found;
DECLARE_FUNCTION("find-tail", procedure_fixed_2);
ENSURE_PROCEDURE(pred);
@@ -195,8 +175,7 @@
if (TRUEP(found))
return tail;
}
- term = CONSP(tail) ? CDR(tail) : tail;
- CHECK_PROPER_LIST_TERMINATION(term, lst);
+ CHECK_PROPER_LIST_TERMINATION(tail, lst);
return SCM_FALSE;
}
Modified: sigscheme-trunk/src/sigscheme.h
==============================================================================
--- sigscheme-trunk/src/sigscheme.h (original)
+++ sigscheme-trunk/src/sigscheme.h Sun Jul 1 03:58:06 2007
@@ -1673,10 +1673,8 @@
/* module-srfi1.c */
#if SCM_USE_SRFI1
-SCM_EXPORT ScmObj scm_p_srfi1_proper_listp(ScmObj obj);
SCM_EXPORT ScmObj scm_p_srfi1_circular_listp(ScmObj obj);
SCM_EXPORT ScmObj scm_p_srfi1_dotted_listp(ScmObj obj);
-SCM_EXPORT ScmObj scm_p_srfi1_drop(ScmObj lst, ScmObj scm_idx);
SCM_EXPORT ScmObj scm_p_srfi1_last_pair(ScmObj lst);
SCM_EXPORT ScmObj scm_p_srfi1_lengthplus(ScmObj lst);
SCM_EXPORT ScmObj scm_p_srfi1_find_tail(ScmObj pred, ScmObj lst);
Added: sigscheme-trunk/test/test-srfi1-another.scm
==============================================================================
--- (empty file)
+++ sigscheme-trunk/test/test-srfi1-another.scm Sun Jul 1 03:58:06 2007
@@ -0,0 +1,629 @@
+#! /usr/bin/env sscm -C UTF-8
+
+;; Filename : test-srfi1-another.scm
+;; About : unit test for SRFI-1 (another version)
+;;
+;; Copyright (c) 2007 SigScheme Project <uim AT freedesktop.org>
+;;
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;; 3. Neither the name of authors nor the names of its contributors
+;; may be used to endorse or promote products derived from this software
+;; without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
+;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(load "./test/unittest.scm")
+
+(use srfi-1)
+
+(if (not (provided? "srfi-1"))
+ (test-skip "SRFI-1 is not enabled"))
+
+(define tn test-name)
+
+;;(define drop list-tail)
+
+;; To prevent being affected from possible bug of the C implementation of
+;; list-tail, tests in this file use this R5RS definition of list-tail.
+(define my-list-tail
+ (lambda (x k)
+ (if (zero? k)
+ x
+ (my-list-tail (cdr x) (- k 1)))))
+
+;; unique objects
+(define elm0 (list #t))
+(define elm1 (list #t))
+(define elm2 (list #t))
+(define elm3 (list #t))
+(define elm4 (list #t))
+(define elm5 (list #t))
+(define elm6 (list #t))
+(define elm7 (list #t))
+(define elm8 (list #t))
+(define elm9 (list #t))
+;; sublists
+(define cdr9 (cons elm9 '()))
+(define cdr8 (cons elm8 cdr9))
+(define cdr7 (cons elm7 cdr8))
+(define cdr6 (cons elm6 cdr7))
+(define cdr5 (cons elm5 cdr6))
+(define cdr4 (cons elm4 cdr5))
+(define cdr3 (cons elm3 cdr4))
+(define cdr2 (cons elm2 cdr3))
+(define cdr1 (cons elm1 cdr2))
+(define cdr0 (cons elm0 cdr1))
+(define lst cdr0)
+;; circular lists
+(define clst1 (list 1))
+(set-cdr! clst1 clst1)
+(define clst2 (list 1 2))
+(set-cdr! (my-list-tail clst2 1) clst2)
+(define clst3 (list 1 2 3))
+(set-cdr! (my-list-tail clst3 2) clst3)
+(define clst4 (list 1 2 3 4))
+(set-cdr! (my-list-tail clst4 3) clst4)
+
+
+;;
+;; Constructors
+;;
+
+
+;;
+;; Predicates
+;;
+
+;; proper-list?
+(tn "proper-list? proper list")
+(assert-eq? (tn) #t (proper-list? '()))
+(assert-eq? (tn) #t (proper-list? '(1)))
+(assert-eq? (tn) #t (proper-list? '(1 2)))
+(assert-eq? (tn) #t (proper-list? '(1 2 3)))
+(assert-eq? (tn) #t (proper-list? '(1 2 3 4)))
+(tn "proper-list? dotted list")
+(assert-eq? (tn) #f (proper-list? 1))
+(assert-eq? (tn) #f (proper-list? '(1 . 2)))
+(assert-eq? (tn) #f (proper-list? '(1 2 . 3)))
+(assert-eq? (tn) #f (proper-list? '(1 2 3 . 4)))
+(assert-eq? (tn) #f (proper-list? '(1 2 3 4 . 5)))
+(tn "proper-list? circular list")
+(assert-eq? (tn) #f (proper-list? clst1))
+(assert-eq? (tn) #f (proper-list? clst2))
+(assert-eq? (tn) #f (proper-list? clst3))
+(assert-eq? (tn) #f (proper-list? clst4))
+(tn "proper-list? all kind of Scheme objects")
+(if (and sigscheme?
+ (provided? "siod-bugs"))
+ (assert-eq? (tn) #t (proper-list? #f))
+ (assert-eq? (tn) #f (proper-list? #f)))
+(assert-eq? (tn) #f (proper-list? #t))
+(assert-eq? (tn) #t (proper-list? '()))
+(if sigscheme?
+ (begin
+ (assert-eq? (tn) #f (proper-list? (eof)))
+ (assert-eq? (tn) #f (proper-list? (undef)))))
+(assert-eq? (tn) #f (proper-list? 0))
+(assert-eq? (tn) #f (proper-list? 1))
+(assert-eq? (tn) #f (proper-list? 3))
+(assert-eq? (tn) #f (proper-list? -1))
+(assert-eq? (tn) #f (proper-list? -3))
+(assert-eq? (tn) #f (proper-list? 'symbol))
+(assert-eq? (tn) #f (proper-list? 'SYMBOL))
+(assert-eq? (tn) #f (proper-list? #\a))
+(assert-eq? (tn) #f (proper-list? #\ ))
+(assert-eq? (tn) #f (proper-list? ""))
+(assert-eq? (tn) #f (proper-list? " "))
+(assert-eq? (tn) #f (proper-list? "a"))
+(assert-eq? (tn) #f (proper-list? "A"))
+(assert-eq? (tn) #f (proper-list? "aBc12!"))
+(assert-eq? (tn) #f (proper-list? " "))
+(assert-eq? (tn) #f (proper-list? " 0 12!"))
+(assert-eq? (tn) #f (proper-list? +))
+(assert-eq? (tn) #f (proper-list? (lambda () #t)))
+
+;; syntactic keywords should not be appeared as operand
+(if sigscheme?
+ (begin
+ ;; pure syntactic keyword
+ (assert-error (tn) (lambda () (proper-list? else)))
+ ;; expression keyword
+ (assert-error (tn) (lambda () (proper-list? do)))))
+
+(call-with-current-continuation
+ (lambda (k)
+ (assert-eq? (tn) #f (proper-list? k))))
+(assert-eq? (tn) #f (proper-list? (current-output-port)))
+(assert-eq? (tn) #f (proper-list? '(#t . #t)))
+(assert-eq? (tn) #f (proper-list? (cons #t #t)))
+(assert-eq? (tn) #t (proper-list? '(0 1 2)))
+(assert-eq? (tn) #t (proper-list? (list 0 1 2)))
+(assert-eq? (tn) #f (proper-list? '#()))
+(assert-eq? (tn) #f (proper-list? (vector)))
+(assert-eq? (tn) #f (proper-list? '#(0 1 2)))
+(assert-eq? (tn) #f (proper-list? (vector 0 1 2)))
+
+;; circular-list?
+(tn "circular-list? proper list")
+(assert-eq? (tn) #f (circular-list? '()))
+(assert-eq? (tn) #f (circular-list? '(1)))
+(assert-eq? (tn) #f (circular-list? '(1 2)))
+(assert-eq? (tn) #f (circular-list? '(1 2 3)))
+(assert-eq? (tn) #f (circular-list? '(1 2 3 4)))
+(tn "circular-list? dotted list")
+(assert-eq? (tn) #f (circular-list? 1))
+(assert-eq? (tn) #f (circular-list? '(1 . 2)))
+(assert-eq? (tn) #f (circular-list? '(1 2 . 3)))
+(assert-eq? (tn) #f (circular-list? '(1 2 3 . 4)))
+(assert-eq? (tn) #f (circular-list? '(1 2 3 4 . 5)))
+(tn "circular-list? circular list")
+(assert-eq? (tn) #t (circular-list? clst1))
+(assert-eq? (tn) #t (circular-list? clst2))
+(assert-eq? (tn) #t (circular-list? clst3))
+(assert-eq? (tn) #t (circular-list? clst4))
+(tn "circular-list? all kind of Scheme objects")
+(if (and sigscheme?
+ (provided? "siod-bugs"))
+ (assert-eq? (tn) #f (circular-list? #f))
+ (assert-eq? (tn) #f (circular-list? #f)))
+(assert-eq? (tn) #f (circular-list? #t))
+(assert-eq? (tn) #f (circular-list? '()))
+(if sigscheme?
+ (begin
+ (assert-eq? (tn) #f (circular-list? (eof)))
+ (assert-eq? (tn) #f (circular-list? (undef)))))
+(assert-eq? (tn) #f (circular-list? 0))
+(assert-eq? (tn) #f (circular-list? 1))
+(assert-eq? (tn) #f (circular-list? 3))
+(assert-eq? (tn) #f (circular-list? -1))
+(assert-eq? (tn) #f (circular-list? -3))
+(assert-eq? (tn) #f (circular-list? 'symbol))
+(assert-eq? (tn) #f (circular-list? 'SYMBOL))
+(assert-eq? (tn) #f (circular-list? #\a))
+(assert-eq? (tn) #f (circular-list? #\ ))
+(assert-eq? (tn) #f (circular-list? ""))
+(assert-eq? (tn) #f (circular-list? " "))
+(assert-eq? (tn) #f (circular-list? "a"))
+(assert-eq? (tn) #f (circular-list? "A"))
+(assert-eq? (tn) #f (circular-list? "aBc12!"))
+(assert-eq? (tn) #f (circular-list? " "))
+(assert-eq? (tn) #f (circular-list? " 0 12!"))
+(assert-eq? (tn) #f (circular-list? +))
+(assert-eq? (tn) #f (circular-list? (lambda () #t)))
+
+;; syntactic keywords should not be appeared as operand
+(if sigscheme?
+ (begin
+ ;; pure syntactic keyword
+ (assert-error (tn) (lambda () (circular-list? else)))
+ ;; expression keyword
+ (assert-error (tn) (lambda () (circular-list? do)))))
+
+(call-with-current-continuation
+ (lambda (k)
+ (assert-eq? (tn) #f (circular-list? k))))
+(assert-eq? (tn) #f (circular-list? (current-output-port)))
+(assert-eq? (tn) #f (circular-list? '(#t . #t)))
+(assert-eq? (tn) #f (circular-list? (cons #t #t)))
+(assert-eq? (tn) #f (circular-list? '(0 1 2)))
+(assert-eq? (tn) #f (circular-list? (list 0 1 2)))
+(assert-eq? (tn) #f (circular-list? '#()))
+(assert-eq? (tn) #f (circular-list? (vector)))
+(assert-eq? (tn) #f (circular-list? '#(0 1 2)))
+(assert-eq? (tn) #f (circular-list? (vector 0 1 2)))
+
+;; dotted-list?
+(tn "dotted-list? proper list")
+(assert-eq? (tn) #f (dotted-list? '()))
+(assert-eq? (tn) #f (dotted-list? '(1)))
+(assert-eq? (tn) #f (dotted-list? '(1 2)))
+(assert-eq? (tn) #f (dotted-list? '(1 2 3)))
+(assert-eq? (tn) #f (dotted-list? '(1 2 3 4)))
+(tn "dotted-list? dotted list")
+(assert-eq? (tn) #t (dotted-list? 1))
+(assert-eq? (tn) #t (dotted-list? '(1 . 2)))
+(assert-eq? (tn) #t (dotted-list? '(1 2 . 3)))
+(assert-eq? (tn) #t (dotted-list? '(1 2 3 . 4)))
+(assert-eq? (tn) #t (dotted-list? '(1 2 3 4 . 5)))
+(tn "dotted-list? circular list")
+(assert-eq? (tn) #f (dotted-list? clst1))
+(assert-eq? (tn) #f (dotted-list? clst2))
+(assert-eq? (tn) #f (dotted-list? clst3))
+(assert-eq? (tn) #f (dotted-list? clst4))
+(tn "dotted-list? all kind of Scheme objects")
+(if (and sigscheme?
+ (provided? "siod-bugs"))
+ (assert-eq? (tn) #f (dotted-list? #f))
+ (assert-eq? (tn) #t (dotted-list? #f)))
+(assert-eq? (tn) #t (dotted-list? #t))
+(assert-eq? (tn) #f (dotted-list? '()))
+(if sigscheme?
+ (begin
+ (assert-eq? (tn) #t (dotted-list? (eof)))
+ (assert-eq? (tn) #t (dotted-list? (undef)))))
+(assert-eq? (tn) #t (dotted-list? 0))
+(assert-eq? (tn) #t (dotted-list? 1))
+(assert-eq? (tn) #t (dotted-list? 3))
+(assert-eq? (tn) #t (dotted-list? -1))
+(assert-eq? (tn) #t (dotted-list? -3))
+(assert-eq? (tn) #t (dotted-list? 'symbol))
+(assert-eq? (tn) #t (dotted-list? 'SYMBOL))
+(assert-eq? (tn) #t (dotted-list? #\a))
+(assert-eq? (tn) #t (dotted-list? #\ ))
+(assert-eq? (tn) #t (dotted-list? ""))
+(assert-eq? (tn) #t (dotted-list? " "))
+(assert-eq? (tn) #t (dotted-list? "a"))
+(assert-eq? (tn) #t (dotted-list? "A"))
+(assert-eq? (tn) #t (dotted-list? "aBc12!"))
+(assert-eq? (tn) #t (dotted-list? " "))
+(assert-eq? (tn) #t (dotted-list? " 0 12!"))
+(assert-eq? (tn) #t (dotted-list? +))
+(assert-eq? (tn) #t (dotted-list? (lambda () #t)))
+
+;; syntactic keywords should not be appeared as operand
+(if sigscheme?
+ (begin
+ ;; pure syntactic keyword
+ (assert-error (tn) (lambda () (dotted-list? else)))
+ ;; expression keyword
+ (assert-error (tn) (lambda () (dotted-list? do)))))
+
+(call-with-current-continuation
+ (lambda (k)
+ (assert-eq? (tn) #t (dotted-list? k))))
+(assert-eq? (tn) #t (dotted-list? (current-output-port)))
+(assert-eq? (tn) #t (dotted-list? '(#t . #t)))
+(assert-eq? (tn) #t (dotted-list? (cons #t #t)))
+(assert-eq? (tn) #f (dotted-list? '(0 1 2)))
+(assert-eq? (tn) #f (dotted-list? (list 0 1 2)))
+(assert-eq? (tn) #t (dotted-list? '#()))
+(assert-eq? (tn) #t (dotted-list? (vector)))
+(assert-eq? (tn) #t (dotted-list? '#(0 1 2)))
+(assert-eq? (tn) #t (dotted-list? (vector 0 1 2)))
+
+
+;;
+;; Selectors
+;;
+
+;; drop
+;;
+;; SRFI-1: drop returns all but the first i elements of list x.
+;; x may be any value -- a proper, circular, or dotted list.
+(tn "drop proper list invalid forms")
+(assert-error (tn) (lambda () (drop '() -1)))
+(assert-error (tn) (lambda () (drop '(1 2) -1)))
+(tn "drop proper list index 0")
+(assert-equal? (tn) '() (drop '() 0))
+(assert-equal? (tn) '(1) (drop '(1) 0))
+(assert-equal? (tn) '(1 2) (drop '(1 2) 0))
+(assert-equal? (tn) '(1 2 3) (drop '(1 2 3) 0))
+(assert-equal? (tn) '(1 2 3 4) (drop '(1 2 3 4) 0))
+(assert-eq? (tn) cdr0 (drop lst 0))
+(assert-eq? (tn) cdr9 (drop cdr9 0))
+(tn "drop proper list index 1")
+(assert-error (tn) (lambda () (drop '() 1)))
+(assert-equal? (tn) '() (drop '(1) 1))
+(assert-equal? (tn) '(2) (drop '(1 2) 1))
+(assert-equal? (tn) '(2 3) (drop '(1 2 3) 1))
+(assert-equal? (tn) '(2 3 4) (drop '(1 2 3 4) 1))
+(assert-eq? (tn) cdr1 (drop lst 1))
+(assert-eq? (tn) cdr9 (drop cdr8 1))
+(assert-eq? (tn) '() (drop cdr9 1))
+(tn "drop proper list index 2")
+(assert-error (tn) (lambda () (drop '() 2)))
+(assert-error (tn) (lambda () (drop '(1) 2)))
+(assert-equal? (tn) '() (drop '(1 2) 2))
+(assert-equal? (tn) '(3) (drop '(1 2 3) 2))
+(assert-equal? (tn) '(3 4) (drop '(1 2 3 4) 2))
+(assert-eq? (tn) cdr2 (drop lst 2))
+(assert-eq? (tn) cdr9 (drop cdr7 2))
+(assert-eq? (tn) '() (drop cdr8 2))
+(assert-error (tn) (lambda () (drop cdr9 2)))
+(tn "drop proper list index 3")
+(assert-error (tn) (lambda () (drop '() 3)))
+(assert-error (tn) (lambda () (drop '(1) 3)))
+(assert-error (tn) (lambda () (drop '(1 2) 3)))
+(assert-equal? (tn) '() (drop '(1 2 3) 3))
+(assert-equal? (tn) '(4) (drop '(1 2 3 4) 3))
+(assert-eq? (tn) cdr3 (drop lst 3))
+(assert-eq? (tn) cdr9 (drop cdr6 3))
+(assert-eq? (tn) '() (drop cdr7 3))
+(assert-error (tn) (lambda () (drop cdr8 3)))
+(assert-error (tn) (lambda () (drop cdr9 3)))
+(tn "drop proper list index 4")
+(assert-error (tn) (lambda () (drop '() 4)))
+(assert-error (tn) (lambda () (drop '(1) 4)))
+(assert-error (tn) (lambda () (drop '(1 2) 4)))
+(assert-error (tn) (lambda () (drop '(1 2 3) 4)))
+(assert-equal? (tn) '() (drop '(1 2 3 4) 4))
+(assert-eq? (tn) cdr4 (drop lst 4))
+(assert-eq? (tn) cdr9 (drop cdr5 4))
+(assert-eq? (tn) '() (drop cdr6 4))
+(assert-error (tn) (lambda () (drop cdr7 4)))
+(assert-error (tn) (lambda () (drop cdr8 4)))
+(assert-error (tn) (lambda () (drop cdr9 4)))
+(tn "drop proper list index 5")
+(assert-error (tn) (lambda () (drop '() 5)))
+(assert-error (tn) (lambda () (drop '(1) 5)))
+(assert-error (tn) (lambda () (drop '(1 2) 5)))
+(assert-error (tn) (lambda () (drop '(1 2 3) 5)))
+(assert-error (tn) (lambda () (drop '(1 2 3 4) 5)))
+(assert-eq? (tn) cdr5 (drop lst 5))
+(assert-eq? (tn) cdr9 (drop cdr4 5))
+(assert-eq? (tn) '() (drop cdr5 5))
+(assert-error (tn) (lambda () (drop cdr6 5)))
+(assert-error (tn) (lambda () (drop cdr7 5)))
+(assert-error (tn) (lambda () (drop cdr8 5)))
+(assert-error (tn) (lambda () (drop cdr9 5)))
+(tn "drop proper list other indices")
+(assert-eq? (tn) cdr6 (drop lst 6))
+(assert-eq? (tn) cdr7 (drop lst 7))
+(assert-eq? (tn) cdr8 (drop lst 8))
+(assert-eq? (tn) cdr9 (drop lst 9))
+(assert-eq? (tn) '() (drop lst 10))
+(assert-error (tn) (lambda () (drop lst 11)))
+
+(tn "drop dotted list invalid forms")
+(assert-error (tn) (lambda () (drop 1 -1)))
+(assert-error (tn) (lambda () (drop '(1 . 2) -1)))
+(tn "drop dotted list index 0")
+(assert-equal? (tn) 1 (drop 1 0))
+(assert-equal? (tn) '(1 . 2) (drop '(1 . 2) 0))
+(assert-equal? (tn) '(1 2 . 3) (drop '(1 2 . 3) 0))
+(assert-equal? (tn) '(1 2 3 . 4) (drop '(1 2 3 . 4) 0))
+(assert-equal? (tn) '(1 2 3 4 . 5) (drop '(1 2 3 4 . 5) 0))
+(tn "drop dotted list index 1")
+(assert-error (tn) (lambda () (drop 1 1)))
+(assert-equal? (tn) 2 (drop '(1 . 2) 1))
+(assert-equal? (tn) '(2 . 3) (drop '(1 2 . 3) 1))
+(assert-equal? (tn) '(2 3 . 4) (drop '(1 2 3 . 4) 1))
+(assert-equal? (tn) '(2 3 4 . 5) (drop '(1 2 3 4 . 5) 1))
+(tn "drop dotted list index 2")
+(assert-error (tn) (lambda () (drop 1 2)))
+(assert-error (tn) (lambda () (drop '(1 . 2) 2)))
+(assert-equal? (tn) 3 (drop '(1 2 . 3) 2))
+(assert-equal? (tn) '(3 . 4) (drop '(1 2 3 . 4) 2))
+(assert-equal? (tn) '(3 4 . 5) (drop '(1 2 3 4 . 5) 2))
+(tn "drop dotted list index 3")
+(assert-error (tn) (lambda () (drop 1 3)))
+(assert-error (tn) (lambda () (drop '(1 . 2) 3)))
+(assert-error (tn) (lambda () (drop '(1 2 . 3) 3)))
+(assert-equal? (tn) 4 (drop '(1 2 3 . 4) 3))
+(assert-equal? (tn) '(4 . 5) (drop '(1 2 3 4 . 5) 3))
+(tn "drop dotted list index 4")
+(assert-error (tn) (lambda () (drop 1 4)))
+(assert-error (tn) (lambda () (drop '(1 . 2) 4)))
+(assert-error (tn) (lambda () (drop '(1 2 . 3) 4)))
+(assert-error (tn) (lambda () (drop '(1 2 3 . 4) 4)))
+(assert-equal? (tn) 5 (drop '(1 2 3 4 . 5) 4))
+(tn "drop dotted list index 5")
+(assert-error (tn) (lambda () (drop 1 5)))
+(assert-error (tn) (lambda () (drop '(1 . 2) 5)))
+(assert-error (tn) (lambda () (drop '(1 2 . 3) 5)))
+(assert-error (tn) (lambda () (drop '(1 2 3 . 4) 5)))
+(assert-error (tn) (lambda () (drop '(1 2 3 4 . 5) 5)))
+
+(tn "drop circular list invalid forms")
+;; SigScheme's implementation does not detect negative index on circular list
+;; since it is an user error. It goes an infinite loop.
+;;(assert-error (tn) (lambda () (drop clst1 -1)))
+;;(assert-error (tn) (lambda () (drop clst2 -1)))
+(tn "drop circular list index 0")
+(assert-eq? (tn) clst1 (drop clst1 0))
+(assert-eq? (tn) clst2 (drop clst2 0))
+(assert-eq? (tn) clst3 (drop clst3 0))
+(assert-eq? (tn) clst4 (drop clst4 0))
+(tn "drop circular list index 1")
+(assert-eq? (tn) clst1 (drop clst1 1))
+(assert-eq? (tn) (my-list-tail clst2 1) (drop clst2 1))
+(assert-eq? (tn) (my-list-tail clst3 1) (drop clst3 1))
+(assert-eq? (tn) (my-list-tail clst4 1) (drop clst4 1))
+(tn "drop circular list index 2")
+(assert-eq? (tn) clst1 (drop clst1 2))
+(assert-eq? (tn) clst2 (drop clst2 2))
+(assert-eq? (tn) (my-list-tail clst3 2) (drop clst3 2))
+(assert-eq? (tn) (my-list-tail clst4 2) (drop clst4 2))
+(tn "drop circular list index 3")
+(assert-eq? (tn) clst1 (drop clst1 3))
+(assert-eq? (tn) (my-list-tail clst2 1) (drop clst2 3))
+(assert-eq? (tn) clst3 (drop clst3 3))
+(assert-eq? (tn) (my-list-tail clst4 3) (drop clst4 3))
+(tn "drop circular list index 4")
+(assert-eq? (tn) clst1 (drop clst1 4))
+(assert-eq? (tn) clst2 (drop clst2 4))
+(assert-eq? (tn) (my-list-tail clst3 1) (drop clst3 4))
+(assert-eq? (tn) clst4 (drop clst4 4))
+(tn "drop circular list index 5")
+(assert-eq? (tn) clst1 (drop clst1 5))
+(assert-eq? (tn) (my-list-tail clst2 1) (drop clst2 5))
+(assert-eq? (tn) (my-list-tail clst3 2) (drop clst3 5))
+(assert-eq? (tn) (my-list-tail clst4 1) (drop clst4 5))
+(tn "drop circular list index 6")
+(assert-eq? (tn) clst1 (drop clst1 6))
+(assert-eq? (tn) clst2 (drop clst2 6))
+(assert-eq? (tn) clst3 (drop clst3 6))
+(assert-eq? (tn) (my-list-tail clst4 2) (drop clst4 6))
+
+(tn "drop SRFI-1 examples")
+(assert-equal? (tn) '(c d e) (drop '(a b c d e) 2))
+(assert-equal? (tn) '(3 . d) (drop '(1 2 3 . d) 2))
+(assert-equal? (tn) 'd (drop '(1 2 3 . d) 3))
+
+;; last-pair
+;;
+;; SRFI-1: last-pair returns the last pair in the non-empty, finite list pair.
+(tn "last-pair invalid forms")
+(assert-error (tn) (lambda () (last-pair '())))
+(assert-error (tn) (lambda () (last-pair 1)))
+(tn "last-pair")
+(assert-eq? (tn) cdr9 (last-pair lst))
+(assert-eq? (tn) cdr9 (last-pair cdr7))
+(assert-eq? (tn) cdr9 (last-pair cdr8))
+(assert-eq? (tn) cdr9 (last-pair cdr9))
+(assert-equal? (tn) '(1 . 2) (last-pair '(1 . 2)))
+(assert-equal? (tn) '(2 . 3) (last-pair '(1 2 . 3)))
+(assert-equal? (tn) '(3 . 4) (last-pair '(1 2 3 . 4)))
+
+
+;;
+;; Miscellaneous: length, append, concatenate, reverse, zip & count
+;;
+
+;; length+
+(tn "length+ proper list")
+(assert-equal? (tn) 0 (length+ '()))
+(assert-equal? (tn) 1 (length+ '(1)))
+(assert-equal? (tn) 2 (length+ '(1 2)))
+(assert-equal? (tn) 3 (length+ '(1 2 3)))
+(assert-equal? (tn) 4 (length+ '(1 2 3 4)))
+(tn "length+ dotted list")
+;; Although the behavior on dotted list is not defined in SRFI-1 itself, the
+;; reference implementation returns its length. So SigScheme followed it.
+(if sigscheme?
+ (begin
+ (assert-equal? (tn) 0 (length+ 1))
+ (assert-equal? (tn) 1 (length+ '(1 . 2)))
+ (assert-equal? (tn) 2 (length+ '(1 2 . 3)))
+ (assert-equal? (tn) 3 (length+ '(1 2 3 . 4)))
+ (assert-equal? (tn) 4 (length+ '(1 2 3 4 . 5)))))
+(tn "length+ circular list")
+(assert-eq? (tn) #f (length+ clst1))
+(assert-eq? (tn) #f (length+ clst2))
+(assert-eq? (tn) #f (length+ clst3))
+(assert-eq? (tn) #f (length+ clst4))
+
+
+;;
+;; Fold, unfold & map
+;;
+
+
+;;
+;; Filtering & partitioning
+;;
+
+
+;;
+;; Searching
+;;
+
+;; find-tail
+(tn "find-tail invalid forms")
+(assert-error (tn) (lambda () (find-tail even? '#(1 2))))
+(assert-error (tn) (lambda () (find-tail 1 '(1 2))))
+(tn "find-tail proper list")
+;; Although the behavior on null list is not explicitly defined in SRFI-1
+;; itself, the reference implementation returns #f So SigScheme followed it.
+(assert-false (tn) (find-tail even? '()))
+(assert-false (tn) (find-tail (lambda (x) #f) lst))
+(assert-eq? (tn) lst (find-tail (lambda (x) (eq? x elm0)) lst))
+(assert-eq? (tn) cdr1 (find-tail (lambda (x) (eq? x elm1)) lst))
+(assert-eq? (tn) cdr2 (find-tail (lambda (x) (eq? x elm2)) lst))
+(assert-eq? (tn) cdr8 (find-tail (lambda (x) (eq? x elm8)) lst))
+(assert-eq? (tn) cdr9 (find-tail (lambda (x) (eq? x elm9)) lst))
+(tn "find-tail dotted list")
+(assert-error (tn) (lambda () (find-tail even? 1)))
+;; Although the behavior on dotted list is not defined in SRFI-1 itself, the
+;; reference implementation returns the last pair. So SigScheme followed it.
+(assert-equal? (tn) '(1 . 2) (find-tail (lambda (x) (= x 1)) '(1 . 2)))
+(assert-equal? (tn) '(2 . 3) (find-tail (lambda (x) (= x 2)) '(1 2 . 3)))
+(assert-equal? (tn) '(3 . 4) (find-tail (lambda (x) (= x 3)) '(1 2 3 . 4)))
+(assert-error (tn) (lambda () (find-tail even? '(1 . 2))))
+(assert-equal? (tn) '(2 . 3) (find-tail even? '(1 2 . 3)))
+(assert-equal? (tn) '(2 3 . 4) (find-tail even? '(1 2 3 . 4)))
+(assert-equal? (tn) '(1 . 2) (find-tail odd? '(1 . 2)))
+(assert-equal? (tn) '(1 2 . 3) (find-tail odd? '(1 2 . 3)))
+(assert-equal? (tn) '(1 2 3 . 4) (find-tail odd? '(1 2 3 . 4)))
+(tn "find-tail circular list")
+;; SRFI-1: In the circular-list case, this procedure "rotates" the list.
+(assert-eq? (tn) clst4 (find-tail (lambda (x) (= x 1)) clst4))
+(assert-eq? (tn) (my-list-tail clst4 1) (find-tail (lambda (x) (= x 2))
+ clst4))
+(assert-eq? (tn) (my-list-tail clst4 2) (find-tail (lambda (x) (= x 3))
+ clst4))
+(assert-eq? (tn) (my-list-tail clst4 3) (find-tail (lambda (x) (= x 4))
+ clst4))
+(assert-eq? (tn)
+ clst4
+ (let ((cnt 2))
+ (find-tail (lambda (x)
+ (if (= x 1)
+ (set! cnt (- cnt 1)))
+ (and (zero? cnt)
+ (= x 1)))
+ clst4)))
+(assert-eq? (tn)
+ (my-list-tail clst4 1)
+ (let ((cnt 2))
+ (find-tail (lambda (x)
+ (if (= x 1)
+ (set! cnt (- cnt 1)))
+ (and (zero? cnt)
+ (= x 2)))
+ clst4)))
+(assert-eq? (tn)
+ (my-list-tail clst4 2)
+ (let ((cnt 2))
+ (find-tail (lambda (x)
+ (if (= x 1)
+ (set! cnt (- cnt 1)))
+ (and (zero? cnt)
+ (= x 3)))
+ clst4)))
+(assert-eq? (tn)
+ clst4
+ (let ((cnt 3))
+ (find-tail (lambda (x)
+ (if (= x 1)
+ (set! cnt (- cnt 1)))
+ (and (zero? cnt)
+ (= x 1)))
+ clst4)))
+(assert-eq? (tn)
+ clst4
+ (let ((cnt 4))
+ (find-tail (lambda (x)
+ (if (= x 1)
+ (set! cnt (- cnt 1)))
+ (and (zero? cnt)
+ (= x 1)))
+ clst4)))
+
+
+;;
+;; Deleting
+;;
+
+
+;;
+;; Association lists
+;;
+
+
+;;
+;; Set operations on lists
+;;
+
+
+(total-report)
Modified: sigscheme-trunk/test/test-srfi1.scm
==============================================================================
--- sigscheme-trunk/test/test-srfi1.scm (original)
+++ sigscheme-trunk/test/test-srfi1.scm Sun Jul 1 03:58:06 2007
@@ -192,31 +192,6 @@
; length+
(assert-false "length+ test 1" (length+ circular-lst))
-(tn "length+ proper list")
-(assert-equal? (tn) 0 (length+ '()))
-(assert-equal? (tn) 1 (length+ '(1)))
-(assert-equal? (tn) 2 (length+ '(1 2)))
-(assert-equal? (tn) 3 (length+ '(1 2 3)))
-(assert-equal? (tn) 4 (length+ '(1 2 3 4)))
-(tn "length+ improper list")
-(assert-error (tn) (lambda () (length+ 1)))
-(assert-error (tn) (lambda () (length+ '(1 . 2))))
-(assert-error (tn) (lambda () (length+ '(1 2 . 3))))
-(assert-error (tn) (lambda () (length+ '(1 2 3 . 4))))
-(assert-error (tn) (lambda () (length+ '(1 2 3 4 . 5))))
-(tn "length+ circular list")
-(define lst1 '(1))
-(set-cdr! lst1 lst1)
-(define lst2 '(1 2))
-(set-cdr! (list-tail lst2 1) lst2)
-(define lst3 '(1 2 3))
-(set-cdr! (list-tail lst3 2) lst3)
-(define lst4 '(1 2 3 4))
-(set-cdr! (list-tail lst4 3) lst4)
-(assert-false (tn) (length+ lst1))
-(assert-false (tn) (length+ lst2))
-(assert-false (tn) (length+ lst3))
-(assert-false (tn) (length+ lst4))
; concatenate
(assert-equal? "concatenate test 1" '() (concatenate '(())))
