Fixed the CHAIN macro to correctly chain plain slot values.

[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 5c65ad6..2ef7d82 100644 (file)
--- a/src/lib/ps-macro-lib.lisp
+++ b/src/lib/ps-macro-lib.lisp
@@ -81,6 +81,16 @@
       `(@ (slot-value ,obj ,(if (symbolp (car props)) `',(car props) (car props))) ,@(cdr props))
       obj))
 
+(defpsmacro chain (&rest method-calls)
+  (labels ((do-chain (method-calls)
+             (if (cdr 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))))
+
+
 (defpsmacro concatenate (result-type &rest sequences)
   (assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.")
   (cons '+ sequences))
@@ -127,23 +137,44 @@
 
 (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?)
+  (cond ((null bindings)
+         body)
+        ((atom bindings)
+         ;; dotted destructuring list
+         `(let ((,bindings (when (> (length ,arr) ,n)
+                             ((@ ,arr slice) ,n))))
+            ,body))
+        (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))))