Compile last version

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 2e22ba3..519d04e 100644 (file)
--- 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)
@@ -1986,7 +2020,7 @@
            make-array make-package make-symbol mapcar member minusp
            mod nil not nth nthcdr null numberp or package-name
            package-use-list packagep plusp prin1-to-string print
-           proclaim prog1 prog2 pron push quote remove remove-if
+           proclaim prog1 prog2 progn psetq push quote remove remove-if
            remove-if-not return return-from revappend reverse second
            set setq some string-upcase string string= stringp subseq
            symbol-function symbol-name symbol-package symbol-plist