[Guile-commits] 08/17: srfi-1 length+: move from C to Scheme

[Rob Browning]

rlb pushed a commit to branch main
in repository guile.

commit 372a52e6aa22ac255d8607c9e4f4f43864218440
Author: Rob Browning <rlb@defaultvalue.org>
AuthorDate: Wed Jul 17 19:44:06 2024 -0500

    srfi-1 length+: move from C to Scheme
    
    * libguile/srfi-1.c (scm_srfi1_length_plus): delete.
    * libguile/srfi-1.h (scm_srfi1_length_plus): delete.
    * module/srfi/srfi-1.scm: add length+.
---
 libguile/srfi-1.c            | 43 -------------------------------------------
 libguile/srfi-1.h            |  1 -
 module/srfi/srfi-1.scm       | 24 ++++++++++++++++++++++++
 test-suite/tests/srfi-1.test | 18 ++++++++++--------
 4 files changed, 34 insertions(+), 52 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 7a8f72e15..798f4e7bb 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -371,49 +371,6 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, 
"delete-duplicates!", 1, 1, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
-            (SCM lst),
-           "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
-           "circular.")
-#define FUNC_NAME s_scm_srfi1_length_plus
-{
-  size_t i = 0;
-  SCM tortoise = lst;
-  SCM hare = lst;
-
-  do
-    {
-      if (!scm_is_pair (hare))
-        {
-          if (SCM_NULL_OR_NIL_P (hare))
-            return scm_from_size_t (i);
-          else
-            scm_wrong_type_arg_msg (FUNC_NAME, 1, lst,
-                                    "proper or circular list");
-        }
-      hare = SCM_CDR (hare);
-      i++;
-      if (!scm_is_pair (hare))
-        {
-          if (SCM_NULL_OR_NIL_P (hare))
-            return scm_from_size_t (i);
-          else
-            scm_wrong_type_arg_msg (FUNC_NAME, 1, lst,
-                                    "proper or circular list");
-        }
-      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
-
 SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
             (SCM equal, SCM lst, SCM rest),
            "Return @var{lst} with any elements in the lists in @var{rest}\n"
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index f23d4b035..329988745 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -27,7 +27,6 @@
 SCM_INTERNAL SCM scm_srfi1_count (SCM pred, SCM list1, SCM rest);
 SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
-SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst);
 SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest);
 SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index f44b32909..31623cdc6 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -445,6 +445,30 @@ a list of those after."
 
 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 
+(define (length+ lst)
+  "Return the length of @var{lst}, or @code{#f} if @var{lst} is circular."
+  (let lp ((tortoise lst)
+           (hare lst)
+           (i 0))
+    (if (not-pair? hare)
+        (if (null? hare)
+            i
+            (scm-error 'wrong-type-arg "length+"
+                       "Argument not a proper or circular list: ~s"
+                       (list lst) (list lst)))
+        (let ((hare (cdr hare)))
+          (if (not-pair? hare)
+              (if (null? hare)
+                  (1+ i)
+                  (scm-error 'wrong-type-arg "length+"
+                             "Argument not a proper or circular list: ~s"
+                             (list lst) (list lst)))
+              (let ((tortoise (cdr tortoise))
+                    (hare (cdr hare)))
+                (if (eq? hare tortoise)
+                    #f
+                    (lp tortoise hare (+ i 2)))))))))
+
 (define (concatenate lists)
   "Construct a list by appending all lists in @var{lists}.
 
diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index 04a35ed6d..a1ced0fb5 100644
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -21,6 +21,8 @@
   #:use-module (ice-9 copy-tree)
   #:use-module (srfi srfi-1))
 
+(define list+-bad-arg-exception
+  '(wrong-type-arg . "^Argument not a proper or circular list"))
 
 (define (ref-delete x lst . proc)
   "Reference implemenation of srfi-1 `delete'."
@@ -1188,18 +1190,18 @@
     (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
+    (pass-if-exception "improper first 1" list+-bad-arg-exception
       (fold + 1 1 '(1 2 3)))
-    (pass-if-exception "improper first 2" exception:wrong-type-arg
+    (pass-if-exception "improper first 2" list+-bad-arg-exception
       (fold + 1 '(1 . 2) '(1 2 3)))
-    (pass-if-exception "improper first 3" exception:wrong-type-arg
+    (pass-if-exception "improper first 3" list+-bad-arg-exception
       (fold + 1 '(1 2 . 3) '(1 2 3)))
 
-    (pass-if-exception "improper second 1" exception:wrong-type-arg
+    (pass-if-exception "improper second 1" list+-bad-arg-exception
       (fold + 1 '(1 2 3) 1))
-    (pass-if-exception "improper second 2" exception:wrong-type-arg
+    (pass-if-exception "improper second 2" list+-bad-arg-exception
       (fold + 1 '(1 2 3) '(1 . 2)))
-    (pass-if-exception "improper second 3" exception:wrong-type-arg
+    (pass-if-exception "improper second 3" list+-bad-arg-exception
       (fold + 1 '(1 2 3) '(1 2 . 3)))
 
     (pass-if (= 6 (fold + 1 '(2) '(3))))
@@ -1330,9 +1332,9 @@
     (length+))
   (pass-if-exception "too many args" exception:wrong-num-args
     (length+ 123 456))
-  (pass-if-exception "not a pair" exception:wrong-type-arg
+  (pass-if-exception "not a pair" list+-bad-arg-exception
     (length+ 'x))
-  (pass-if-exception "improper list" exception:wrong-type-arg
+  (pass-if-exception "improper list" list+-bad-arg-exception
     (length+ '(x y . z)))
   (pass-if (= 0 (length+ '())))
   (pass-if (= 1 (length+ '(x))))