Implement count-pairs.

diff --git a/doc/ref-manual/lists.texi b/doc/ref-manual/lists.texi
index 6c21a463260ba0193a13b71452085b53539346cb..3e99b66eb57071f784f6fd8544e3b00bf073b2ce 100644 (file)
--- a/doc/ref-manual/lists.texi
+++ b/doc/ref-manual/lists.texi
@@ -539,20 +539,38 @@ a proper list.
 @end deffn
 
 @deffn {SRFI 1 procedure} length+ clist
-@var{Clist} must be a proper, dotted, or circular list.  If
-@var{clist} is a circular list, returns @code{#f}, otherwise returns
-the number of pairs comprising the list (which is the same as the
-length for a proper list).
+@var{Clist} must be a proper or circular list.  If @var{clist} is a
+circular list, returns @code{#f}, otherwise returns the number of
+pairs comprising the list (which is the same as the length for a
+proper list).
 
 @example
 @group
 (length+ (list 'a 'b 'c))               @result{} 3
-(length+ (cons* 'a 'b 'c))              @result{} 2
+(length+ (cons* 'a 'b 'c))              @error{}
 (length+ (circular-list 'a 'b 'c))      @result{} #f
 @end group
 @end example
 @end deffn
 
+@deffn procedure count-pairs object
+Counts the number of pairs in a list-like @var{object}.  If
+@var{object} is a proper list, returns the same value as
+@code{length}.  If @var{object} is a dotted list, returns the number
+of pairs including the last one.  If @var{object} is a circular list,
+counts the number of pairs up to and including the one with the
+backwards link.  If @var{object} is any other object, returns @code{0}
+as apropriate for an empty dotted list.
+
+@example
+@group
+(count-pairs (list 'a 'b 'c))           @result{} 3
+(count-pairs (cons* 'a 'b 'c))          @result{} 2
+(count-pairs (circular-list 'a 'b 'c))  @result{} 3
+@end group
+@end example
+@end deffn
+
 @deffn {standard procedure} null? object
 @cindex type predicate, for empty list
 @cindex empty list, predicate for

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index 5feb4d61686580d0e3c4976c9425d1d7f42ee87b..3b9b217214d280b01bfd682e8e509bb130dae632 100644 (file)
--- a/src/runtime/list.scm
+++ b/src/runtime/list.scm
@@ -256,6 +256,34 @@ USA.
        (and (null? l1)
             length))))
 
+(define (count-pairs x)
+
+  (define (loop x lag n)
+    (if (pair? x)
+       (let ((x (cdr x))
+             (n (fix:+ n 1)))
+         (if (pair? x)
+             (let ((x (cdr x))
+                   (lag (cdr lag))
+                   (n (fix:+ n 1)))
+               (if (eq? x lag)
+                   (count-pairs-in-cycle)
+                   (loop x lag n)))
+             n))
+       n))
+
+  ;; Deferred to avoid overhead on non-cyclical inputs.
+  (define (count-pairs-in-cycle)
+    (let ((ht (make-hash-table eq-comparator)))
+      (let loop ((x x) (n 0))
+       (if (hash-table-contains? ht x)
+           n
+           (begin
+             (hash-table-set! ht x #t)
+             (loop (cdr x) (fix:+ n 1)))))))
+
+  (loop x x 0))
+\f
 (define (length=? left right)
   (define (%length=? n list)
     (cond ((pair? list) (and (fix:positive? n)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 0931fc7d94627a95dbe1abbca99059d111ace547..afab7577470f33541d650819dadacb74a4860162 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3455,6 +3455,7 @@ USA.
          not-pair?                     ;(srfi 1)
          null-list?                    ;(srfi 1)
          null?                         ;(scheme base)
+         count-pairs
          pair?                         ;(scheme base)
          reduce                        ;(srfi 1)
          reduce-right                  ;(srfi 1)