diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index 6d5a1ab90..e2a9c9319 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -1183,57 +1183,6 @@ SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_split_at, "split-at", 2, 0, 0, - (SCM lst, SCM n), - "Return two values (multiple values), being a list of the\n" - "elements before index @var{n} in @var{lst}, and a list of those\n" - "after.") -#define FUNC_NAME s_scm_srfi1_split_at -{ - size_t nn; - /* pre is a list of elements before the i split point, loc is the CDRLOC - of the last cell, ie. where to store to append to it */ - SCM pre = SCM_EOL; - SCM *loc = ⪯ - - for (nn = scm_to_size_t (n); nn != 0; nn--) - { - SCM_VALIDATE_CONS (SCM_ARG1, lst); - - *loc = scm_cons (SCM_CAR (lst), SCM_EOL); - loc = SCM_CDRLOC (*loc); - lst = SCM_CDR(lst); - } - return scm_values (scm_list_2 (pre, lst)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_srfi1_split_at_x, "split-at!", 2, 0, 0, - (SCM lst, SCM n), - "Return two values (multiple values), being a list of the\n" - "elements before index @var{n} in @var{lst}, and a list of those\n" - "after. @var{lst} is modified to form those values.") -#define FUNC_NAME s_scm_srfi1_split_at -{ - size_t nn; - SCM upto = lst; - SCM *loc = &lst; - - for (nn = scm_to_size_t (n); nn != 0; nn--) - { - SCM_VALIDATE_CONS (SCM_ARG1, upto); - - loc = SCM_CDRLOC (upto); - upto = SCM_CDR (upto); - } - - *loc = SCM_EOL; - return scm_values (scm_list_2 (lst, upto)); -} -#undef FUNC_NAME - SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0, (SCM lst, SCM n), "Return the a list containing the @var{n} last elements of\n" diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h index 87aa98981..593d9bb02 100644 --- a/libguile/srfi-1.h +++ b/libguile/srfi-1.h @@ -47,8 +47,6 @@ 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); SCM_INTERNAL SCM scm_srfi1_remove_x (SCM pred, SCM list); -SCM_INTERNAL SCM scm_srfi1_split_at (SCM lst, SCM n); -SCM_INTERNAL SCM scm_srfi1_split_at_x (SCM lst, SCM n); SCM_INTERNAL SCM scm_srfi1_take_right (SCM lst, SCM n); SCM_INTERNAL void scm_register_srfi_1 (void); diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index 5bcc3611c..8ddf2714b 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -238,6 +238,10 @@ higher-order procedures." (scm-error 'wrong-type-arg caller "Wrong type argument: ~S" (list arg) '()))) +(define (out-of-range proc arg) + (scm-error 'out-of-range proc + "Value out of range: ~A" (list arg) (list arg))) + ;; the srfi spec doesn't seem to forbid inexact integers. (define (non-negative-integer? x) (and (integer? x) (>= x 0))) @@ -375,6 +379,30 @@ end-of-list checking in contexts where dotted lists are allowed." (loop (cdr prev) (cdr tail))))))) +(define (split-at lst i) + "Return two values, a list of the elements before index I in LST, and +a list of those after." + (if (< i 0) + (out-of-range 'split-at i) + (let lp ((l lst) (n i) (acc '())) + (if (<= n 0) + (values (reverse! acc) l) + (lp (cdr l) (- n 1) (cons (car l) acc)))))) + +(define (split-at! lst i) + "Linear-update variant of `split-at'." + (cond ((< i 0) + (out-of-range 'split-at! i)) + ((= i 0) + (values '() lst)) + (else + (let lp ((l lst) (n (- i 1))) + (if (<= n 0) + (let ((tmp (cdr l))) + (set-cdr! l '()) + (values lst tmp)) + (lp (cdr l) (- n 1))))))) + (define (last pair) "Return the last element of the non-empty, finite list PAIR." (car (last-pair pair)))