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 length+: move from C to Scheme

Browse source 
* 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+.
This commit is contained in:
Rob Browning 2024-07-17 19:44:06 -05:00
parent 3cb6309f62
commit 372a52e6aa
4 changed files with 34 additions and 52 deletions
Download patch file Download diff file Expand all files Collapse all files

43
libguile/srfi-1.c
View file

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

1
libguile/srfi-1.h
View file

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

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

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

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

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