commit 9539272d26f2954a253ed1365a6704ed197a79be Author: David Kastrup Date: Mon Jun 2 15:05:55 2014 +0200 Let length+ return the length of dotted lists rather than #f * libguile/srfi-1.c (scm_srfi1_length_plus): Previously, length+ returned #f for dotted lists. This leaves the user with no efficient means for determining the length of dotted lists. While the Scheme standard does not prescribe a behavior here, the reference implementation at indeed returns the spine length (number of successive pairs in the cdr-chain) of dotted lists rather than #f, providing a good endorsement of this behavior. As one consequence, the multi-list implementations for map, fold, and for-each will happen to accept dotted lists as the shortest list. Previously, this caused an error late during processing. diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index aaa3efe..0db6388 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -614,8 +614,32 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0, "circular.") #define FUNC_NAME s_scm_srfi1_length_plus { - long len = scm_ilength (lst); - return (len >= 0 ? SCM_I_MAKINUM (len) : SCM_BOOL_F); + /* This uses the "tortoise and hare" algorithm to detect "infinitely + long" lists (i.e. lists with cycles in their cdrs), and returns #f + if it does find one. + + Dotted lists are treated just like regular lists, returning the + length of the spine. This is in conformance with the reference + implementation though not explicitly defined in the standard. */ + long i = 0; + SCM tortoise = lst; + SCM hare = lst; + + do { + if (!scm_is_pair (hare)) return scm_from_long (i); + hare = SCM_CDR(hare); + i++; + if (!scm_is_pair (hare)) return scm_from_long (i); + hare = SCM_CDR(hare); + i++; + /* For every two steps the hare takes, the tortoise takes one. */ + tortoise = SCM_CDR(tortoise); + } + while (!scm_is_eq (hare, tortoise)); + + /* If the tortoise ever catches the hare, then the list must contain + a cycle. */ + return SCM_BOOL_F; } #undef FUNC_NAME diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index 0806e73..bc72048 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -474,7 +474,7 @@ that result. See the manual for details." (or len1 len2)))) (unless len (scm-error 'wrong-type-arg "fold" - "Args do not contain a proper (finite) list: ~S" + "Args do not contain a finite list: ~S" (list (list list1 list2)) #f)) (let fold2 ((knil knil) (list1 list1) (list2 list2) (len len)) (if (zero? len) @@ -601,7 +601,7 @@ has just one element then that's the return value." (or len1 len2)))) (unless len (scm-error 'wrong-type-arg "map" - "Args do not contain a proper (finite) list: ~S" + "Args do not contain a finite list: ~S" (list (list l1 l2)) #f)) (let map2 ((l1 l1) (l2 l2) (len len)) (if (zero? len) @@ -620,7 +620,7 @@ has just one element then that's the return value." rest))) (if (not len) (scm-error 'wrong-type-arg "map" - "Args do not contain a proper (finite) list: ~S" + "Args do not contain a finite list: ~S" (list (cons l1 rest)) #f)) (let mapn ((l1 l1) (rest rest) (len len)) (if (zero? len) @@ -649,7 +649,7 @@ has just one element then that's the return value." (or len1 len2)))) (unless len (scm-error 'wrong-type-arg "for-each" - "Args do not contain a proper (finite) list: ~S" + "Args do not contain a finite list: ~S" (list (list l1 l2)) #f)) (let for-each2 ((l1 l1) (l2 l2) (len len)) (unless (zero? len) @@ -667,7 +667,7 @@ has just one element then that's the return value." rest))) (if (not len) (scm-error 'wrong-type-arg "for-each" - "Args do not contain a proper (finite) list: ~S" + "Args do not contain a finite list: ~S" (list (cons l1 rest)) #f)) (let for-eachn ((l1 l1) (rest rest) (len len)) (if (> len 0) diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index d40f8e1..9364ea2 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -1187,19 +1187,21 @@ (pass-if-exception "proc arg count 4" exception:wrong-num-args (fold (lambda (x y z prev) x) 1 '(1 2 3) '(1 2 3))) - (pass-if-exception "improper first 1" exception:wrong-type-arg - (fold + 1 1 '(1 2 3))) - (pass-if-exception "improper first 2" exception:wrong-type-arg - (fold + 1 '(1 . 2) '(1 2 3))) - (pass-if-exception "improper first 3" exception:wrong-type-arg - (fold + 1 '(1 2 . 3) '(1 2 3))) - - (pass-if-exception "improper second 1" exception:wrong-type-arg - (fold + 1 '(1 2 3) 1)) - (pass-if-exception "improper second 2" exception:wrong-type-arg - (fold + 1 '(1 2 3) '(1 . 2))) - (pass-if-exception "improper second 3" exception:wrong-type-arg - (fold + 1 '(1 2 3) '(1 2 . 3))) + ;; For multiple list arguments, dotted lists are permitted by this + ;; implementation and a non-list is a zero-length dotted list + (pass-if "improper first 1" + (= 1 (fold + 1 1 '(1 2 3)))) + (pass-if "improper first 2" + (= 3 (fold + 1 '(1 . 2) '(1 2 3)))) + (pass-if "improper first 3" + (= 7 (fold + 1 '(1 2 . 3) '(1 2 3)))) + + (pass-if "improper second 1" + (= 1 (fold + 1 '(1 2 3) 1))) + (pass-if "improper second 2" + (= 3 (fold + 1 '(1 2 3) '(1 . 2)))) + (pass-if "improper second 3" + (= 7 (fold + 1 '(1 2 3) '(1 2 . 3)))) (pass-if (= 6 (fold + 1 '(2) '(3)))) (pass-if (= 15 (fold + 1 '(2 3) '(4 5))))