[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv27759

Modified Files:
	lists.lisp 
Log Message:
Add maplist. Tweak copy-list.


--- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2008/03/18 16:24:49	1.24
+++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2008/03/20 22:21:31	1.25
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.24 2008/03/18 16:24:49 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.25 2008/03/20 22:21:31 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -200,10 +200,12 @@
 (defun copy-list (list)
   (if (null list)
       nil
-    (let ((new-list (cons (pop list) list)))
-      (do ((new-tail new-list (cdr new-tail)))
-	  ((atom list) new-list)
-	(setf (cdr new-tail) (cons (pop list) list))))))
+    (let* ((new-list (cons (pop list) nil))
+	   (new-tail new-list))
+      (do () ((atom list) new-list)
+	(setf new-tail
+	      (setf (cdr new-tail)
+		    (cons (pop list) nil)))))))
 
 (defun list (&rest objects)
   (numargs-case
@@ -390,6 +392,33 @@
 		(setf (car p) x)))))
 	first-list))))
 
+(defun maplist (function first-list &rest more-lists)
+  (numargs-case
+   (2 (function first-list)
+      (do ((result nil)
+	   (p first-list (cdr p)))
+	  ((endp p)
+	   (nreverse result))
+	(push (funcall function p)
+	      result)))
+   (3 (function first-list second-list)
+      (do ((result nil)
+	   (p1 first-list (cdr p1))
+	   (p2 second-list (cdr p2)))
+	  ((or (endp p1) (endp p2))
+	   (nreverse result))
+	(push (funcall function p1 p2)
+	      result)))
+   (t (function first-list &rest more-lists)
+      (declare (dynamic-extent more-lists))
+      (do ((result nil))
+	  ((or (endp first-list)
+	       (some #'endp more-lists))
+	   (nreverse result))
+	(push (apply function first-list more-lists)
+	      result)
+	(setf first-list (cdr first-list)
+	      more-lists (map-into more-lists #'cdr more-lists))))))
 
 (defun nbutlast (list &optional (n 1))
   (let ((start-right (nthcdr n list)))