Fixed a bug in PS LOOP: the :INITIALLY and :FINALLY clauses should execute whether...

[clinton/parenscript.git] / src / lib / ps-macro-lib.lisp

diff --git a/src/lib/ps-macro-lib.lisp b/src/lib/ps-macro-lib.lisp
index 1013939..56b88dc 100644 (file)
--- a/src/lib/ps-macro-lib.lisp
+++ b/src/lib/ps-macro-lib.lisp
@@ -84,7 +84,9 @@
 (defpsmacro chain (&rest method-calls)
   (labels ((do-chain (method-calls)
              (if (cdr method-calls)
-                 `((@ ,(do-chain (cdr method-calls)) ,(caar method-calls)) ,@(cdar method-calls))
+                 (if (listp (car method-calls))
+                     `((@ ,(do-chain (cdr method-calls)) ,(caar method-calls)) ,@(cdar method-calls))
+                     `(@ ,(do-chain (cdr method-calls)) ,(car method-calls)))
                  (car method-calls))))
     (do-chain (reverse method-calls))))
 
@@ -135,23 +137,52 @@
 
 (defpsmacro append (arr1 &rest arrs)
   (if arrs
-      `((@ ,arr1 :concat) ,@arrs)
+      `((@ ,arr1 concat) ,@arrs)
       arr1))
 
 (defpsmacro apply (fn &rest args)
   (let ((arglist (if (> (length args) 1)
                      `(append (list ,@(butlast args)) ,(car (last args)))
                      (first args))))
-    `((@ ,fn :apply) this ,arglist)))
-
-(defpsmacro destructuring-bind (vars expr &body body)
-  ;; a simple implementation that for now only supports flat lists,
-  ;; but does allow NIL bindings to indicate ignore (a la LOOP)
+    `((@ ,fn apply) this ,arglist)))
+
+(defun destructuring-wrap (arr n bindings body &key setf?)
+  (flet ((bind-rest (sym)
+           `(let ((,sym (when (> (length ,arr) ,n)
+                          ((@ ,arr slice) ,n))))
+              ,body)))
+    (cond ((null bindings)
+           body)
+          ((atom bindings) ;; dotted destructuring list
+           (bind-rest bindings))
+          ((eq (car bindings) '&rest)
+           (if (and (= (length bindings) 2)
+                    (atom (second bindings)))
+               (bind-rest (second bindings))
+               (error "~a is invalid in destructuring list." bindings)))
+          ((eq (car bindings) '&optional)
+           (destructuring-wrap arr n (cdr bindings) body :setf? setf?))
+          (t (let ((var (car bindings))
+                   (inner-body (destructuring-wrap arr (1+ n) (cdr bindings) body :setf? setf?)))
+               (cond ((null var) inner-body)
+                     ((atom var) (if setf?
+                                     `(progn (setf ,var (aref ,arr ,n))
+                                             ,inner-body)
+                                     `(let ((,var (aref ,arr ,n)))
+                                        ,inner-body)))
+                     (t `(,(if setf? 'dset 'destructuring-bind)
+                           ,var (aref ,arr ,n)
+                           ,inner-body))))))))
+
+(defpsmacro dset (bindings expr &body body)
+  (let ((arr (if (complex-js-expr? expr) (ps-gensym) expr)))
+    `(progn
+       ,@(unless (eq arr expr) `((setf ,arr ,expr)))
+       ,(destructuring-wrap arr 0 bindings (cons 'progn body) :setf? t))))
+
+(defpsmacro destructuring-bind (bindings expr &body body)
   (let* ((arr (if (complex-js-expr? expr) (ps-gensym) expr))
-         (n -1)
-         (bindings
-          (append (unless (equal arr expr) `((,arr ,expr)))
-                  (mapcan (lambda (var)
-                            (incf n)
-                            (when var `((,var (aref ,arr ,n))))) vars))))
-    `(let* ,bindings ,@body)))
+         (bound (destructuring-wrap arr 0 bindings (cons 'progn body))))
+    (if (eq arr expr)
+        bound
+        `(let ((,arr ,expr)) ,bound))))