(car+cdr, fold, last, list-index,

list-tabulate, not-pair, xcons): Rewrite in C.

diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index a746732..aa56a62 100644 (file)
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -167,6 +167,17 @@ SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_DEFINE (scm_srfi1_car_plus_cdr, "car+cdr", 1, 0, 0,
+            (SCM pair),
+           "Return two values, the @sc{car} and the @sc{cdr} of @var{pair}.")
+#define FUNC_NAME s_scm_srfi1_car_plus_cdr
+{
+  SCM_VALIDATE_CONS (SCM_ARG1, pair);
+  return scm_values (scm_list_2 (SCM_CAR (pair), SCM_CDR (pair)));
+}
+#undef FUNC_NAME
+
+
 SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0,
             (SCM lstlst),
            "Construct a list by appending all lists in @var{lstlst}.\n"
@@ -848,6 +859,132 @@ SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_DEFINE (scm_srfi1_fold, "fold", 3, 0, 1,
+            (SCM proc, SCM init, SCM list1, SCM rest),
+           "Apply @var{proc} to the elements of @var{lst1} @dots{}\n"
+           "@var{lstN} to build a result, and return that result.\n"
+           "\n"
+           "Each @var{proc} call is @code{(@var{proc} @var{elem1} @dots{}\n"
+           "@var{elemN} @var{previous})}, where @var{elem1} is from\n"
+           "@var{lst1}, through @var{elemN} from @var{lstN}.\n"
+           "@var{previous} is the return from the previous call to\n"
+           "@var{proc}, or the given @var{init} for the first call.  If any\n"
+           "list is empty, just @var{init} is returned.\n"
+           "\n"
+           "@code{fold} works through the list elements from first to last.\n"
+           "The following shows a list reversal and the calls it makes,\n"
+           "\n"
+           "@example\n"
+           "(fold cons '() '(1 2 3))\n"
+           "\n"
+           "(cons 1 '())\n"
+           "(cons 2 '(1))\n"
+           "(cons 3 '(2 1)\n"
+           "@result{} (3 2 1)\n"
+           "@end example\n"
+           "\n"
+           "If @var{lst1} through @var{lstN} have different lengths,\n"
+           "@code{fold} stops when the end of the shortest is reached.\n"
+           "Ie.@: elements past the length of the shortest are ignored in\n"
+           "the other @var{lst}s.  At least one @var{lst} must be\n"
+           "non-circular.\n"
+           "\n"
+           "The way @code{fold} builds a result from iterating is quite\n"
+           "general, it can do more than other iterations like say\n"
+           "@code{map} or @code{filter}.  The following for example removes\n"
+           "adjacent duplicate elements from a list,\n"
+           "\n"
+           "@example\n"
+           "(define (delete-adjacent-duplicates lst)\n"
+           "  (fold-right (lambda (elem ret)\n"
+           "                (if (equal? elem (first ret))\n"
+           "                    ret\n"
+           "                    (cons elem ret)))\n"
+           "              (list (last lst))\n"
+           "              lst))\n"
+           "(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))\n"
+           "@result{} (1 2 3 4 5)\n"
+           "@end example\n"
+           "\n"
+           "Clearly the same sort of thing can be done with a\n"
+           "@code{for-each} and a variable in which to build the result,\n"
+           "but a self-contained @var{proc} can be re-used in multiple\n"
+           "contexts, where a @code{for-each} would have to be written out\n"
+           "each time.")
+#define FUNC_NAME s_scm_srfi1_fold
+{
+  SCM lst;
+  int argnum;
+  SCM_VALIDATE_REST_ARGUMENT (rest);
+
+  if (scm_is_null (rest))
+    {
+      /* one list */
+      scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
+      SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+      for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
+        init = proc_tramp (proc, SCM_CAR (list1), init);
+
+      /* check below that list1 is a proper list, and done */
+      lst = list1;
+      argnum = 2;
+    }
+  else
+    {
+      /* two or more lists */
+      SCM  vec, args, a;
+      size_t  len, i;
+
+      /* vec is the list arguments */
+      vec = scm_vector (scm_cons (list1, rest));
+      len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+      /* args is the argument list to pass to proc, same length as vec,
+         re-used for each call */
+      args = scm_make_list (SCM_I_MAKINUM (len+1), SCM_UNDEFINED);
+
+      for (;;)
+        {
+          /* first elem of each list in vec into args, and step those
+             vec entries onto their next element */
+          for (i = 0, a = args, argnum = 2;
+               i < len;
+               i++, a = SCM_CDR (a), argnum++)
+            {
+              lst = SCM_SIMPLE_VECTOR_REF (vec, i);  /* list argument */
+              if (! scm_is_pair (lst))
+                goto check_lst_and_done;
+              SCM_SETCAR (a, SCM_CAR (lst));  /* arg for proc */
+              SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst));  /* rest of lst */
+            }
+          SCM_SETCAR (a, init);
+
+          init = scm_apply (proc, args, SCM_EOL);
+        }
+    }
+
+ check_lst_and_done:
+  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
+  return init;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_last, "last", 1, 0, 0,
+            (SCM lst),
+           "Like @code{cons}, but with interchanged arguments.  Useful\n"
+           "mostly when passed to higher-order procedures.")
+#define FUNC_NAME s_scm_srfi1_last
+{
+  SCM pair = scm_last_pair (lst);
+  /* scm_last_pair returns SCM_EOL for an empty list */
+  SCM_VALIDATE_CONS (SCM_ARG1, pair);
+  return SCM_CAR (pair);
+}
+#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"
@@ -860,6 +997,109 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_DEFINE (scm_srfi1_list_index, "list-index", 2, 0, 1,
+            (SCM pred, SCM list1, SCM rest),
+           "Return the index of the first set of elements, one from each of\n"
+           "@var{lst1}@dots{}@var{lstN}, which satisfies @var{pred}.\n"
+           "\n"
+           "@var{pred} is called as @code{(@var{pred} elem1 @dots{}\n"
+           "elemN)}.  Searching stops when the end of the shortest\n"
+           "@var{lst} is reached.  The return index starts from 0 for the\n"
+           "first set of elements.  If no set of elements pass then the\n"
+           "return is @code{#f}.\n"
+           "\n"
+           "@example\n"
+           "(list-index odd? '(2 4 6 9))      @result{} 3\n"
+           "(list-index = '(1 2 3) '(3 1 2))  @result{} #f\n"
+           "@end example")
+#define FUNC_NAME s_scm_srfi1_list_index
+{
+  long  n = 0;
+  SCM   lst;
+  int   argnum;
+  SCM_VALIDATE_REST_ARGUMENT (rest);
+
+  if (scm_is_null (rest))
+    {
+      /* one list */
+      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
+      SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+      for ( ; scm_is_pair (list1); n++, list1 = SCM_CDR (list1))
+        if (scm_is_true (pred_tramp (pred, SCM_CAR (list1))))
+          return SCM_I_MAKINUM (n);
+
+      /* not found, check below that list1 is a proper list */
+    end_list1:
+      lst = list1;
+      argnum = 2;
+    }
+  else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
+    {
+      /* two lists */
+      SCM list2 = SCM_CAR (rest);
+      scm_t_trampoline_2 pred_tramp = scm_trampoline_2 (pred);
+      SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+      for ( ; ; n++)
+        {
+          if (! scm_is_pair (list1))
+            goto end_list1;
+          if (! scm_is_pair (list2))
+            {
+              lst = list2;
+              argnum = 3;
+              break;
+            }
+          if (scm_is_true (pred_tramp (pred,
+                                       SCM_CAR (list1), SCM_CAR (list2))))
+            return SCM_I_MAKINUM (n);
+
+          list1 = SCM_CDR (list1);
+          list2 = SCM_CDR (list2);
+        }
+    }
+  else
+    {
+      /* three or more lists */
+      SCM     vec, args, a;
+      size_t  len, i;
+
+      /* vec is the list arguments */
+      vec = scm_vector (scm_cons (list1, rest));
+      len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+      /* args is the argument list to pass to pred, same length as vec,
+         re-used for each call */
+      args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
+
+      for ( ; ; n++)
+        {
+          /* first elem of each list in vec into args, and step those
+             vec entries onto their next element */
+          for (i = 0, a = args, argnum = 2;
+               i < len;
+               i++, a = SCM_CDR (a), argnum++)
+            {
+              lst = SCM_SIMPLE_VECTOR_REF (vec, i);  /* list argument */
+              if (! scm_is_pair (lst))
+                goto not_found_check_lst;
+              SCM_SETCAR (a, SCM_CAR (lst));  /* arg for pred */
+              SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst));  /* rest of lst */
+            }
+
+          if (scm_is_true (scm_apply (pred, args, SCM_EOL)))
+            return SCM_I_MAKINUM (n);
+        }
+    }
+
+ not_found_check_lst:
+  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
+  return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
 /* This routine differs from the core list-copy in allowing improper lists.
    Maybe the core could allow them similarly.  */
 
@@ -893,6 +1133,29 @@ SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_DEFINE (scm_srfi1_list_tabulate, "list-tabulate", 2, 0, 0,
+            (SCM n, SCM proc),
+           "Return an @var{n}-element list, where each list element is\n"
+           "produced by applying the procedure @var{init-proc} to the\n"
+           "corresponding list index.  The order in which @var{init-proc}\n"
+           "is applied to the indices is not specified.")
+#define FUNC_NAME s_scm_srfi1_list_tabulate
+{
+  long i, nn;
+  scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
+  SCM ret = SCM_EOL;
+
+  SCM_VALIDATE_INUM_MIN_COPY (SCM_ARG1, n, 0, nn);
+  SCM_ASSERT (proc_tramp, proc, SCM_ARG2, FUNC_NAME);
+
+  for (i = nn-1; i >= 0; i--)
+    ret = scm_cons (proc_tramp (proc, SCM_I_MAKINUM (i)), ret);
+
+  return ret;
+}
+#undef FUNC_NAME
+
+
 SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1,
             (SCM equal, SCM lst, SCM rest),
            "Add to @var{list} any of the given @var{elem}s not already in\n"
@@ -1219,6 +1482,21 @@ SCM_DEFINE (scm_srfi1_ninth, "ninth", 1, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_DEFINE (scm_srfi1_not_pair_p, "not-pair?", 1, 0, 0,
+            (SCM obj),
+           "Return @code{#t} is @var{obj} is not a pair, @code{#f}\n"
+           "otherwise.\n"
+           "\n"
+           "This is shorthand notation @code{(not (pair?  @var{obj}))} and\n"
+           "is supposed to be used for end-of-list checking in contexts\n"
+           "where dotted lists are allowed.")
+#define FUNC_NAME s_scm_srfi1_not_pair_p
+{
+  return scm_from_bool (! scm_is_pair (obj));
+}
+#undef FUNC_NAME
+
+
 SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
            (SCM pred, SCM list),
            "Partition the elements of @var{list} with predicate @var{pred}.\n"
@@ -1760,6 +2038,17 @@ SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_DEFINE (scm_srfi1_xcons, "xcons", 2, 0, 0,
+            (SCM d, SCM a),
+           "Like @code{cons}, but with interchanged arguments.  Useful\n"
+           "mostly when passed to higher-order procedures.")
+#define FUNC_NAME s_scm_srfi1_xcons
+{
+  return scm_cons (a, d);
+}
+#undef FUNC_NAME
+
+
 void
 scm_init_srfi_1 (void)
 {

diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h
index 3f8f81e..0a20c6b 100644 (file)
--- a/srfi/srfi-1.h
+++ b/srfi/srfi-1.h
@@ -35,6 +35,7 @@
 SCM_SRFI1_API SCM scm_srfi1_alist_copy (SCM alist);
 SCM_SRFI1_API SCM scm_srfi1_break (SCM pred, SCM lst);
 SCM_SRFI1_API SCM scm_srfi1_break_x (SCM pred, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_car_plus_cdr (SCM pair);
 SCM_SRFI1_API SCM scm_srfi1_concatenate (SCM lstlst);
 SCM_SRFI1_API SCM scm_srfi1_concatenate_x (SCM lstlst);
 SCM_SRFI1_API SCM scm_srfi1_count (SCM pred, SCM list1, SCM rest);
@@ -50,14 +51,19 @@ SCM_SRFI1_API SCM scm_srfi1_fifth (SCM lst);
 SCM_SRFI1_API SCM scm_srfi1_filter_map (SCM proc, SCM list1, SCM rest);
 SCM_SRFI1_API SCM scm_srfi1_find (SCM pred, SCM lst);
 SCM_SRFI1_API SCM scm_srfi1_find_tail (SCM pred, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_fold (SCM proc, SCM init, SCM list1, SCM rest);
+SCM_SRFI1_API SCM scm_srfi1_last (SCM lst);
 SCM_SRFI1_API SCM scm_srfi1_length_plus (SCM lst);
 SCM_SRFI1_API SCM scm_srfi1_lset_adjoin (SCM equal, SCM lst, SCM rest);
 SCM_SRFI1_API SCM scm_srfi1_list_copy (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_list_index (SCM pred, SCM list1, SCM rest);
+SCM_SRFI1_API SCM scm_srfi1_list_tabulate (SCM n, SCM proc);
 SCM_SRFI1_API SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args);
 SCM_SRFI1_API SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args);
 SCM_SRFI1_API SCM scm_srfi1_member (SCM obj, SCM ls, SCM pred);
 SCM_SRFI1_API SCM scm_srfi1_ninth (SCM lst);
 SCM_SRFI1_API SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred);
+SCM_SRFI1_API SCM scm_srfi1_not_pair_p (SCM obj);
 SCM_SRFI1_API SCM scm_srfi1_partition (SCM pred, SCM list);
 SCM_SRFI1_API SCM scm_srfi1_partition_x (SCM pred, SCM list);
 SCM_SRFI1_API SCM scm_srfi1_reduce (SCM proc, SCM def, SCM lst);
@@ -75,6 +81,7 @@ SCM_SRFI1_API SCM scm_srfi1_take_right (SCM lst, SCM n);
 SCM_SRFI1_API SCM scm_srfi1_take_while (SCM pred, SCM lst);
 SCM_SRFI1_API SCM scm_srfi1_take_while_x (SCM pred, SCM lst);
 SCM_SRFI1_API SCM scm_srfi1_tenth (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_xcons (SCM d, SCM a);
 
 SCM_SRFI1_API void scm_init_srfi_1 (void);
 

diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm
index 36da13b..7fd1b67 100644 (file)
--- a/srfi/srfi-1.scm
+++ b/srfi/srfi-1.scm
@@ -225,9 +225,6 @@
 
 ;;; Constructors
 
-(define (xcons d a)
-  (cons a d))
-
 ;; internal helper, similar to (scsh utilities) check-arg.
 (define (check-arg-type pred arg caller)
   (if (pred arg)
@@ -238,12 +235,7 @@
 ;; the srfi spec doesn't seem to forbid inexact integers.
 (define (non-negative-integer? x) (and (integer? x) (>= x 0)))
 
-(define (list-tabulate n init-proc)
-  (check-arg-type non-negative-integer? n "list-tabulate")
-  (let lp ((n n) (acc '()))
-    (if (<= n 0)
-      acc
-      (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
+
 
 (define (circular-list elt1 . elts)
   (set! elts (cons elt1 elts))
@@ -304,9 +296,6 @@
     (else
      (error "not a proper list in null-list?"))))
 
-(define (not-pair? x)
-  (not (pair? x)))
-
 (define (list= elt= . rest)
   (define (lists-equal a b)
     (let lp ((a a) (b b))
@@ -330,14 +319,9 @@
 (define third caddr)
 (define fourth cadddr)
 
-(define (car+cdr x) (values (car x) (cdr x)))
-
 (define take list-head)
 (define drop list-tail)
 
-(define (last pair)
-  (car (last-pair pair)))
-
 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 
 (define (append-reverse rev-head tail)
@@ -370,19 +354,6 @@
 
 ;;; Fold, unfold & map
 
-(define (fold kons knil list1 . rest)
-  (if (null? rest)
-      (let f ((knil knil) (list1 list1))
-       (if (null? list1)
-           knil
-           (f (kons (car list1) knil) (cdr list1))))
-      (let f ((knil knil) (lists (cons list1 rest)))
-       (if (any null? lists)
-           knil
-           (let ((cars (map1 car lists))
-                 (cdrs (map1 cdr lists)))
-             (f (apply kons (append! cars (list knil))) cdrs))))))
-
 (define (fold-right kons knil clist1 . rest)
   (if (null? rest)
     (let f ((list1 clist1))
@@ -516,21 +487,6 @@
          (else
           (and (pred (car ls)) (lp (cdr ls)))))))
 
-(define (list-index pred clist1 . rest)
-  (if (null? rest)
-    (let lp ((l clist1) (i 0))
-      (if (null? l)
-       #f
-       (if (pred (car l))
-         i
-         (lp (cdr l) (+ i 1)))))
-    (let lp ((lists (cons clist1 rest)) (i 0))
-      (cond ((any1 null? lists)
-            #f)
-           ((apply pred (map1 car lists)) i)
-           (else
-            (lp (map1 cdr lists) (+ i 1)))))))
-
 ;;; Association lists
 
 (define alist-cons acons)