From: David Vázquez <davazp@gmail.com>
Date: Sun, 20 Jan 2013 17:49:41 +0000 (+0000)
Subject: Merge branch 'psetq' into gh-pages
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5036873a22b60a9f0ff618ead7379c44c84d23c5;hp=a1533bed60c97b6a1a3b2840f191ebe3d36b61c4;p=jscl.git

Merge branch 'psetq' into gh-pages
---

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 2e22ba3..b2db1eb 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -277,6 +277,25 @@
   (defun reverse (list)
     (revappend list '()))
 
+  (defmacro psetq (&rest pairs)
+    (let (;; For each pair, we store here a list of the form
+	  ;; (VARIABLE GENSYM VALUE).
+	  (assignments '()))
+      (while t
+	(cond
+	  ((null pairs) (return))
+	  ((null (cdr pairs))
+	   (error "Odd paris in PSETQ"))
+	  (t
+	   (let ((variable (car pairs))
+		 (value (cadr pairs)))
+	     (push `(,variable ,(gensym) ,value)  assignments)
+	     (setq pairs (cddr pairs))))))
+      (setq assignments (reverse assignments))
+      ;; 
+      `(let ,(mapcar #'cdr assignments)
+	 (setq ,@(!reduce #'append (mapcar #'butlast assignments) '())))))
+
   (defun list-length (list)
     (let ((l 0))
       (while (not (null list))
@@ -1173,12 +1192,27 @@
         (ls-compile-block body t)) *newline*
        "})"))))
 
-(define-compilation setq (var val)
+
+(defun setq-pair (var val)
   (let ((b (lookup-in-lexenv var *environment* 'variable)))
     (if (eq (binding-type b) 'lexical-variable)
         (concat (binding-value b) " = " (ls-compile val))
         (ls-compile `(set ',var ,val)))))
 
+(define-compilation setq (&rest pairs)
+  (let ((result ""))
+    (while t
+      (cond
+	((null pairs) (return))
+	((null (cdr pairs))
+	 (error "Odd paris in SETQ"))
+	(t
+	 (concatf result
+	   (concat (setq-pair (car pairs) (cadr pairs))
+		   (if (null (cddr pairs)) "" ", ")))
+	 (setq pairs (cddr pairs)))))
+    (concat "(" result ")")))
+
 ;;; FFI Variable accessors
 (define-compilation js-vref (var)
   var)