From: David Vázquez <davazp@gmail.com>
Date: Wed, 30 Jan 2013 23:13:12 +0000 (+0000)
Subject: Preliminary DO and DO* iteration macros
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=81db23f4ad7e7f6c632c25285e3bfe5b4b168e46;p=jscl.git

Preliminary DO and DO* iteration macros
---

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 8574222..7b46a86 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -301,6 +301,34 @@
       `(let ,(mapcar #'cdr assignments)
 	 (setq ,@(!reduce #'append (mapcar #'butlast assignments) '())))))
 
+  (defmacro do (varlist endlist &body body)
+    `(block nil        
+       (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+	 (while t
+	   (when ,(car endlist)
+	     (return (progn ,(cdr endlist))))
+	   (tagbody ,@body)
+	   (psetq
+	    ,@(apply #'append
+		     (mapcar (lambda (v)
+			       (and (consp (cdr v))
+				    (list (first v) (third v))))
+			     varlist)))))))
+
+  (defmacro do* (varlist endlist &body body)
+    `(block nil        
+       (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+	 (while t
+	   (when ,(car endlist)
+	     (return (progn ,(cdr endlist))))
+	   (tagbody ,@body)
+	   (setq
+	    ,@(apply #'append
+		     (mapcar (lambda (v)
+			       (and (consp (cdr v))
+				    (list (first v) (third v))))
+			     varlist)))))))
+  
   (defun list-length (list)
     (let ((l 0))
       (while (not (null list))
@@ -2118,12 +2146,12 @@
             boundp butlast caar cadddr caddr cadr car car case catch cdar cdddr
             cddr cdr cdr char char-code char= code-char cond cons consp copy-list
             decf declaim defparameter defun defmacro defvar digit-char-p
-            disassemble documentation dolist dotimes ecase eq eql equal error eval
-            every export fdefinition find-package find-symbol first fourth fset
-            funcall function functionp gensym get-universal-time go identity if
-            in-package incf integerp integerp intern keywordp lambda last length
-            let let* list-all-packages list listp make-array make-package
-            make-symbol mapcar member minusp mod multiple-value-bind
+            disassemble do do* documentation dolist dotimes ecase eq eql equal
+	    error eval every export fdefinition find-package find-symbol first
+	    fourth fset funcall function functionp gensym get-universal-time go
+	    identity if in-package incf integerp integerp intern keywordp lambda
+	    last length let let* list-all-packages list listp make-array
+	    make-package make-symbol mapcar member minusp mod multiple-value-bind
             multiple-value-call multiple-value-list multiple-value-prog1 nil not
             nth nthcdr null numberp or package-name package-use-list packagep
             plusp prin1-to-string print proclaim prog1 prog2 progn psetq push