[Guile-commits] 01/17: srfi-1 list-copy: move from C to Scheme

[Rob Browning]

rlb pushed a commit to branch main
in repository guile.

commit aa44035ee883fd675a0e58343ad2172701f364b5
Author: Rob Browning <rlb@defaultvalue.org>
AuthorDate: Sat Jul 20 14:56:27 2024 -0500

    srfi-1 list-copy: move from C to Scheme
    
    * libguile/srfi-1.c (scm_srfi1_list_copy): delete.
    * libguile/srfi-1.h (scm_srfi1_list_copy): delete.
    * module/srfi/srfi-1.scm: add list-copy.
    * test-suite/tests/srfi-1.test: ensure copied spine is independent.
---
 libguile/srfi-1.c            | 33 ---------------------------------
 libguile/srfi-1.h            |  1 -
 module/srfi/srfi-1.scm       | 18 ++++++++++++++++++
 test-suite/tests/srfi-1.test |  9 ++++++++-
 4 files changed, 26 insertions(+), 35 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index b18ba41c7..bb7930cc0 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -618,39 +618,6 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-
-/* This routine differs from the core list-copy in allowing improper lists.
-   Maybe the core could allow them similarly.  */
-
-SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0, 
-            (SCM lst),
-           "Return a copy of the given list @var{lst}.\n"
-           "\n"
-           "@var{lst} can be a proper or improper list.  And if @var{lst}\n"
-           "is not a pair then it's treated as the final tail of an\n"
-           "improper list and simply returned.")
-#define FUNC_NAME s_scm_srfi1_list_copy
-{
-  SCM newlst;
-  SCM * fill_here;
-  SCM from_here;
-
-  newlst = lst;
-  fill_here = &newlst;
-  from_here = lst;
-
-  while (scm_is_pair (from_here))
-    {
-      SCM c;
-      c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
-      *fill_here = c;
-      fill_here = SCM_CDRLOC (c);
-      from_here = SCM_CDR (from_here);
-    }
-  return newlst;
-}
-#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 9dafb9c0d..20cb478b4 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -35,7 +35,6 @@ 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_list_copy (SCM lst);
 SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_remove (SCM pred, SCM list);
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 57f9058b6..89090af89 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -262,6 +262,24 @@ INIT-PROC is applied to the indices is not specified."
         acc
         (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
 
+(define (list-copy lst)
+  "Return a copy of the given list @var{lst}.
+@var{lst} can be a proper or improper list.  And if @var{lst} is not a
+pair then it's treated as the final tail of an improper list and simply
+returned."
+  ;; This routine differs from the core list-copy in allowing improper
+  ;; lists.  Maybe the core could allow them too.
+  (if (not (pair? lst))
+      lst
+      (let ((result (cons (car lst) (cdr lst))))
+        (let lp ((tail result))
+          (let ((next (cdr tail)))
+            (if (pair? next)
+                (begin
+                  (set-cdr! tail (cons (car next) (cdr next)))
+                  (lp next))
+                result))))))
+
 (define (circular-list elt1 . elts)
   (set! elts (cons elt1 elts))
   (set-cdr! (last-pair elts) elts)
diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index dc3e47f50..d3166e5a2 100644
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -1449,7 +1449,14 @@
   (pass-if (equal? '(1 . 2)       (list-copy '(1 . 2))))
   (pass-if (equal? '(1 2 . 3)     (list-copy '(1 2 . 3))))
   (pass-if (equal? '(1 2 3 . 4)   (list-copy '(1 2 3 . 4))))
-  (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
+  (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5))))
+
+  (let ((src (list 1 2 3 4 5)))
+    (define (find-pair? p lst)
+      (let lp ((lst lst))
+        (and (pair? lst) (or (eq? p lst) (lp (cdr lst))))))
+    (pair-for-each (lambda (p) (pass-if (not (find-pair? p src))))
+                   (list-copy src))))
 
 ;;
 ;; list-index