[uim-commit] r2813 - in branches/r5rs/sigscheme: . test
yamaken at freedesktop.org
yamaken at freedesktop.org
Fri Jan 6 09:13:32 PST 2006
Author: yamaken
Date: 2006-01-06 09:13:27 -0800 (Fri, 06 Jan 2006)
New Revision: 2813
Modified:
branches/r5rs/sigscheme/operations-srfi1.c
branches/r5rs/sigscheme/sigscheme.h
branches/r5rs/sigscheme/test/test-srfi1.scm
Log:
* sigscheme/sigscheme.h
- (scm_p_srfi1_proper_listp, scm_p_srfi1_circular_listp,
scm_p_srfi1_dotted_listp, scm_p_srfi1_not_pairp): Fix arg name
appropriately
* sigscheme/operations-srfi1.c
- (scm_p_srfi1_null_listp): Check circular and dotted list properly
- (scm_p_srfi1_proper_listp, scm_p_srfi1_lengthplus): Simplify with
new list predicate
- (scm_p_srfi1_circular_listp, scm_p_srfi1_dotted_listp):
* Ditto
* Remove the code derived from the Shiro Kawai's one copied with
no license, copyright and original author information
- (scm_p_srfi1_not_pairp): Simplify
- (scm_p_srfi1_circular_list): Remove unneeded check already done by
map_eval()
* sigscheme/test/test-srfi1.scm
- Fix dotted list test for null-list?. Although Gauche returns #f,
it is an error against SRFI-1 specification. Don't rely on a
behavior of another implementation as the correct
specification. Read original spec first.
Modified: branches/r5rs/sigscheme/operations-srfi1.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi1.c 2006-01-06 16:27:14 UTC (rev 2812)
+++ branches/r5rs/sigscheme/operations-srfi1.c 2006-01-06 17:13:27 UTC (rev 2813)
@@ -197,9 +197,6 @@
{
DECLARE_FUNCTION("circular-list", procedure_variadic_0);
- if (FALSEP(scm_p_listp(args)))
- ERR_OBJ("list required but got", args);
-
SET_CDR(scm_p_srfi1_last_pair(args), args);
return args;
}
@@ -245,76 +242,47 @@
SRFI1 : The procedures : Predicates
==============================================================================*/
ScmObj
-scm_p_srfi1_proper_listp(ScmObj lst)
+scm_p_srfi1_proper_listp(ScmObj obj)
{
DECLARE_FUNCTION("proper-list?", procedure_fixed_1);
- return scm_p_listp(lst);
+
+ return MAKE_BOOL(PROPER_LISTP(obj));
}
ScmObj
scm_p_srfi1_circular_listp(ScmObj obj)
{
- ScmObj slow = obj;
- int len = 0;
DECLARE_FUNCTION("circular-list?", procedure_fixed_1);
- for (;;) {
- if (NULLP(obj)) break;
- if (!CONSP(obj)) return SCM_FALSE;
- if (len != 0 && obj == slow) return SCM_TRUE; /* circular */
-
- obj = CDR(obj);
- len++;
- if (NULLP(obj)) break;
- if (!CONSP(obj)) return SCM_FALSE;
- if (obj == slow) return SCM_TRUE; /* circular */
-
- obj = CDR(obj);
- slow = CDR(slow);
- len++;
- }
-
- return SCM_FALSE;
+ return MAKE_BOOL(CIRCULAR_LISTP(obj));
}
ScmObj
scm_p_srfi1_dotted_listp(ScmObj obj)
{
- ScmObj slow = obj;
- int len = 0;
DECLARE_FUNCTION("dotted-list?", procedure_fixed_1);
- for (;;) {
- if (NULLP(obj)) break;
- if (!CONSP(obj)) return SCM_TRUE;
- if (len != 0 && obj == slow) return SCM_FALSE; /* circular */
-
- obj = CDR(obj);
- len++;
- if (NULLP(obj)) break;
- if (!CONSP(obj)) return SCM_TRUE;
- if (obj == slow) return SCM_FALSE; /* circular */
-
- obj = CDR(obj);
- slow = CDR(slow);
- len++;
- }
-
- return SCM_FALSE;
+ return MAKE_BOOL(DOTTED_LISTP(obj));
}
ScmObj
-scm_p_srfi1_not_pairp(ScmObj pair)
+scm_p_srfi1_not_pairp(ScmObj obj)
{
DECLARE_FUNCTION("not-pair?", procedure_fixed_1);
- return CONSP(pair) ? SCM_FALSE : SCM_TRUE;
+
+ return MAKE_BOOL(!CONSP(obj));
}
ScmObj
scm_p_srfi1_null_listp(ScmObj lst)
{
+ int len;
DECLARE_FUNCTION("null-list?", procedure_fixed_1);
- /* TODO : check circular list */
+
+ len = scm_length(lst);
+ if (!SCM_LISTLEN_PROPERP(len) && !SCM_LISTLEN_CIRCULARP(len))
+ ERR_OBJ("proper or circular list required but got", lst);
+
return MAKE_BOOL(NULLP(lst));
}
@@ -629,13 +597,11 @@
ScmObj
scm_p_srfi1_lengthplus(ScmObj lst)
{
+ int len;
DECLARE_FUNCTION("length+", procedure_fixed_1);
- /* FIXME!: remove expensive circular_listp */
- if (NFALSEP(scm_p_srfi1_circular_listp(lst)))
- return SCM_FALSE;
-
- return scm_p_length(lst);
+ len = scm_length(lst);
+ return (SCM_LISTLEN_PROPERP(len)) ? MAKE_INT(len) : SCM_FALSE;
}
ScmObj
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2006-01-06 16:27:14 UTC (rev 2812)
+++ branches/r5rs/sigscheme/sigscheme.h 2006-01-06 17:13:27 UTC (rev 2813)
@@ -1032,10 +1032,10 @@
ScmObj scm_p_srfi1_list_copy(ScmObj lst);
ScmObj scm_p_srfi1_circular_list(ScmObj args);
ScmObj scm_p_srfi1_iota(ScmObj scm_count, ScmObj args);
-ScmObj scm_p_srfi1_proper_listp(ScmObj lst);
-ScmObj scm_p_srfi1_circular_listp(ScmObj lst);
-ScmObj scm_p_srfi1_dotted_listp(ScmObj lst);
-ScmObj scm_p_srfi1_not_pairp(ScmObj pair);
+ScmObj scm_p_srfi1_proper_listp(ScmObj obj);
+ScmObj scm_p_srfi1_circular_listp(ScmObj obj);
+ScmObj scm_p_srfi1_dotted_listp(ScmObj obj);
+ScmObj scm_p_srfi1_not_pairp(ScmObj obj);
ScmObj scm_p_srfi1_null_listp(ScmObj lst);
ScmObj scm_p_srfi1_listequal(ScmObj eqproc, ScmObj args);
ScmObj scm_p_srfi1_first(ScmObj lst);
Modified: branches/r5rs/sigscheme/test/test-srfi1.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi1.scm 2006-01-06 16:27:14 UTC (rev 2812)
+++ branches/r5rs/sigscheme/test/test-srfi1.scm 2006-01-06 17:13:27 UTC (rev 2813)
@@ -1,3 +1,35 @@
+;; FileName : test-srfi1.scm
+;; About : unit test for SRFI1
+;;
+;; Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
+;;
+;; 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)
(use srfi-8)
@@ -69,7 +101,7 @@
; null-list?
(assert-false "null-list? test 1" (null-list? proper-lst))
(assert-false "null-list? test 2" (null-list? circular-lst))
-(assert-false "null-list? test 3" (null-list? dotted-lst))
+(assert-error "null-list? test 3" (lambda () (null-list? dotted-lst)))
(assert-true "null-list? test 4" (null-list? null-lst))
(define num-lst (iota 10 1))
More information about the uim-commit
mailing list