mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

srfi-1 list-copy: move from C to Scheme

Browse source 
* 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.
This commit is contained in:
Rob Browning 2024-07-20 14:56:27 -05:00
parent 6bd70136d9
commit aa44035ee8
4 changed files with 26 additions and 35 deletions
Download patch file Download diff file Expand all files Collapse all files

33
libguile/srfi-1.c
View file

@ -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"

1
libguile/srfi-1.h
View file

@ -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);

18
module/srfi/srfi-1.scm
View file

@ -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)

9
test-suite/tests/srfi-1.test
View file

@ -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