Add length=? procedure.

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index 7af702cc81a1e2dcd47a67a3b0c0cf816731c77a..8f0aa1c6c31813ce14c42b54886178327bffd5ab 100644 (file)
--- a/src/runtime/list.scm
+++ b/src/runtime/list.scm
@@ -240,6 +240,34 @@ USA.
 (define (length list)
   (guarantee-list->length list 'LENGTH))
 
+(define (length=? left right)
+  (define (%length=? n list)
+    (cond ((pair? list) (and (fix:positive? n)
+                            (%length=? (fix:- n 1) (cdr list))))
+         ((null? list) (fix:zero? n))
+         (else (error:not-list list 'length=?))))
+
+  (define (%same-length left right)
+    (cond ((pair? left) (cond ((pair? right) (%same-length (cdr left) (cdr right)))
+                             ((null? right) #f)
+                             (else (error:not-list right 'length=?))))
+         ((null? left) (cond ((pair? right) #f)
+                             ((null? right) #t)
+                             (else (error:not-list right 'length=?))))
+         (else (error:not-list left 'length=?))))
+
+  ;; Take arguments in either order to make this easy to use.
+  (cond ((pair? left) (cond ((pair? right) (%same-length (cdr left) (cdr right)))
+                           ((index-fixnum? right) (%length=? right left))
+                           ((null? right) #F)
+                           (else (error:wrong-type-argument right "index fixnum or list" 'length=?))))
+       ((index-fixnum? left) (%length=? left right))
+       ((null? left) (cond ((pair? right) #f)
+                           ((index-fixnum? right) (fix:zero? right))
+                           ((null right) #t)
+                           (else (error:wrong-type-argument right "index fixnum or list" 'length=?))))
+       (else (error:wrong-type-argument left "index fixnum or list" 'length=?))))
+
 (define (not-pair? x)
   (not (pair? x)))
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 11ec4db507b2ec9f3bc5541b0298821b43114bbd..ea4a2571755e19d22c92f214983ecc9f6893c75c 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2359,6 +2359,7 @@ USA.
          last                          ;SRFI-1
          last-pair
          length
+         length=?
          list
          list->weak-list
          list-copy