[patch] hobbitized scm_append_x, take 2

[karlheg@inetarena.com (Karl M. Hegbloom)]

 [ Should I be sending these here, or is there a `guile-patches' list
   for this sort of monkey business? ]

 The previous try was flawed.  I had neglected to test the case where
 there are empties embedded in the arglist, like:

(apply append!
       (map (lambda (elt)
              (if (pred? elt) elt '()))
         ls))

 In addition, it would segv when (append!) is run. (with the empty
 arglist.)

 I believe this time I have it right, and that the argument checking
 is correct as well.  It acts just like `nconc' in CMU-CL, tested with 
 the similar sample arguments, and like the original guile `append!'.

;; Test expression:
(let ((ls1 '(a b c d))
      (ls2 '(e f g h))
      (ls3 '(i j k l)))
  (newline)
  (display (append! ls1 ls2 ls3))
  ;;(display (append! ls1 '() ls2 ls3)) ; <-- strips emptys
  ;;(display (append! ls1 ls2 ls3 'x))  ; <-- dotted cdr
  ;;(display (append! ls1 ls2 'x ls3))  ; <-- wta
  ;;(display (append! 'x)) ; <-- returns a valid cdr
  ;;(display (append!) ; <-- ()
  (newline)
  (display ls1)
  (newline))

1998-09-08  Karl M. Hegbloom  <karlheg@bittersweet.inetarena.com>

	* list.c (scm_append_x): tail recursive version from scm compiled
	by hobbit then hand optimized.

Index: list.c
===================================================================
RCS file: /usr/local/cvsroot/debian/guile-core/libguile/list.c,v
retrieving revision 1.1.1.1
diff -u -u -r1.1.1.1 list.c
--- libguile/list.c	1998/08/26 17:14:05	1.1.1.1
+++ libguile/list.c	1998/09/09 16:08:21
@@ -165,6 +165,7 @@
 
 SCM_PROC (s_append, "append", 0, 0, 1, scm_append);
 SCM
+
 scm_append(args)
      SCM args;
 {
@@ -193,8 +194,105 @@
   }
 }
 
+#define HOBBITIZED_APPEND_X 1
 
-SCM_PROC (s_append_x, "append!", 0, 0, 1, scm_append_x);
+SCM_PROC(s_append_x, "append!", 0, 0, 1, scm_append_x);
+#ifdef HOBBITIZED_APPEND_X
+/*
+ *  The following `append!' function, taken from `rscheme' and slightly
+ *  modified, was first compiled with ghobbit, and then hand-optimized to
+ *  its present state.
+ *
+ * (define (append! . args)
+ *   (and (null? args)
+ *        (set! args '(())))
+ *   ;; (assert-ta (all-but-last (lambda (elt)
+ *   ;;                            (or (null? elt)
+ *   ;;                                (list? elt)))
+ *   ;;                          args))
+ *   (let ((target (car args))
+ *         (tails  (cdr args)))
+ *     (let tloop ((target target)
+ *                 (tails tails))
+ *       (if (null? target)
+ *           (if (pair? tails)
+ *               (tloop (car tails) (cdr tails))
+ *               '())
+ *           (let loop ((tails tails)
+ *                      (p target))
+ *             (if (null? tails)
+ *                 target
+ *                 (let ((new-tail (car tails)))
+ *                   (if (null? new-tail)
+ *                       (loop (cdr tails) p)
+ *                       (begin
+ *                         (set-cdr! (last-pair p) new-tail)
+ *                         (loop (cdr tails) new-tail))))))))))
+ *
+ * ;;; Test cases show that it works like Common Lisp's `nconc'
+ * ;;;
+ * ;;;(let ((ls1 '(a b c d))
+ * ;;;      (ls2 '(e f g h))
+ * ;;;      (ls3 '(i j k l)))
+ * ;;;  (newline)
+ * ;;;  (display (append! ls1 ls2 ls3))
+ * ;;;  ;;(display (append! ls1 '() ls2 ls3)) ; <-- strips emptys
+ * ;;;  ;;(display (append! ls1 ls2 ls3 'x))  ; <-- dotted cdr
+ * ;;;  ;;(display (append! ls1 ls2 'x ls3))  ; <-- wta
+ * ;;;  ;;(display (append! 'x)) ; <-- returns a valid cdr
+ * ;;;  (newline)
+ * ;;;  (display ls1))
+ */
+SCM
+scm_append_x(args)
+     SCM args;
+{
+  SCM target, tails;
+  SCM p;
+  long count;
+  if (SCM_NULLP (args)) args = scm_listofnull;
+  target = SCM_CAR (args);
+  tails  = SCM_CDR (args);
+  for (count = scm_ilength (args) - 1, p = args;
+       count > 0;
+       p = SCM_CDR (p), count--)
+    {
+      SCM car = SCM_CAR (p);
+      SCM_ASSERT (SCM_NULLP (car) ||
+		  (SCM_NIMP (car) && SCM_CONSP (car)),
+		  car, SCM_ARGn, s_append_x);
+    }
+ tloop:
+  if (SCM_NULLP (target)) {
+    if (SCM_NIMP (tails) && SCM_CONSP (tails)) {
+      target = SCM_CAR (tails);
+      tails  = SCM_CDR (tails);
+      goto tloop;
+    }
+    else return SCM_EOL;
+  }
+  else {
+    SCM new_tail;
+    p = target;
+  loop:
+    if (SCM_NULLP (tails))
+      return target;
+    else {
+      new_tail = SCM_CAR (tails);
+      if (SCM_NULLP (new_tail)) {
+	tails = SCM_CDR (tails);
+	goto loop;
+      }
+      else {
+	SCM_SETCDR (scm_last_pair (p), new_tail);
+	tails = SCM_CDR (tails);
+	p = new_tail;
+	goto loop;
+      }
+    }
+  }
+}
+#else
 SCM
 scm_append_x(args)
      SCM args;
@@ -210,7 +308,7 @@
   SCM_SETCDR (scm_last_pair (arg), scm_append_x (args));
   return arg;
 }
-
+#endif /* HOBBITIZED_APPEND_X */
 
 SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair);
 SCM


guile> (append! '(a b c . x) 'a '(d e f))

Backtrace:
0* [append! (a b c . x) a ...]

ERROR: In procedure append! in expression (append! (quote #) (quote a) ...):
ERROR: Wrong type argument: a
ABORT: (wrong-type-arg)
guile> (append! '(a b c . x) '(d e f) 'a)
(a b c d e f . a)
guile> (append! '(a b c ) '() '(d e f))
(a b c d e f)
guile> (append! '(a b c ) '() '(d e f) '())
(a b c d e f)
guile> (append! '() '(a b c ) '() '(d e f))
(a b c d e f)
guile> (append! '(a b c ))
(a b c)
guile> (append! 'a)
a
guile> (append!)
()
guile> 
Process scheme finished