[uim-commit] r2819 - in branches/r5rs/sigscheme: . test

[yamaken at freedesktop.org]

Author: yamaken
Date: 2006-01-06 15:17:49 -0800 (Fri, 06 Jan 2006)
New Revision: 2819

Modified:
   branches/r5rs/sigscheme/operations-srfi1.c
   branches/r5rs/sigscheme/test/test-srfi1.scm
Log:
* sigscheme/operations-srfi1.c
  - (scm_p_srfi1_lengthplus): Fix dotted list result


Modified: branches/r5rs/sigscheme/operations-srfi1.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi1.c	2006-01-06 23:02:33 UTC (rev 2818)
+++ branches/r5rs/sigscheme/operations-srfi1.c	2006-01-06 23:17:49 UTC (rev 2819)
@@ -601,6 +601,12 @@
     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;
 }
 

Modified: branches/r5rs/sigscheme/test/test-srfi1.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi1.scm	2006-01-06 23:02:33 UTC (rev 2818)
+++ branches/r5rs/sigscheme/test/test-srfi1.scm	2006-01-06 23:17:49 UTC (rev 2819)
@@ -31,6 +31,9 @@
 ;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 (load "./test/unittest.scm")
+
+(define tn test-name)
+
 (use srfi-1)
 (use srfi-8)
 
@@ -183,6 +186,31 @@
 
 ; 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 '(())))