git.fiddlerwoaroof.com
Browse code

Debug destructuring-lambda

Bug made multiple args / multiple statements expand incorrectly

fiddlerwoaroof authored on 14/02/2016 23:42:48
Showing 1 changed files
fwoar.lisputils.lisp
History View file @ e534999
... ... 
@@ -19,7 +19,7 @@
19 19 
      (declare (ignorable anaphora:it))
20 20 
      ,@body))
21 21
22 
-(eval-when (:compile-toplevel :load-toplevel :execute)
22 
+(eval-when (:compile-toplevel :load-toplevel :execute)
23 23 
   (defun ensure-mapping (list)
24 24 
     "Take a list and make sure that it's parseable as a let-style binding.
25 25 
      Very handy for certain sorts of macros."
... ... 
@@ -29,19 +29,22 @@
29 29 
                                (t x))))
30 30 
       (mapcar symbols->mappings list)))
31 31
32 
-
33 
-    (defun rollup-list (list)
34 
-      (labels ((helper (list &optional accum)
32 
+
33 
+    (defun rollup-list (list &optional body)
34 
+      (labels ((helper (list &optional accum start)
35 35 
                  (tagbody
36 36 
                    start
37 37 
                    (cond
38 38 
                      ((endp list) (return-from rollup-list accum))
39 
-                     (t (setf accum  (cond
40 
-                                       ((null accum) (car list))
41 
-                                       (t `(,@(car list) ,accum)))
42 
-                              list (cdr list))
39 
+                     (t (psetf accum  (cond
40 
+                                        ((null accum) (car list))
41 
+                                        (start `(,@(car list) ,@accum))
42 
+                                        (t `(,@(car list) ,accum)))
43 
+                               list (cdr list)
44 
+                               start nil)
45 
+                        ;; NOTE: REMEMBER! This call to #'GO is the "tail call"
43 46 
                         (go start))))))
44 
-        (helper (reverse list)))))
47 
+        (helper (reverse list) body t))))
45 48
46 49 
 (defmacro destructuring-lambda ((&rest args) &body body)
47 50 
   "A lambda whose arguments can be lambda-lists to be destructured"
... ... 
@@ -50,15 +53,35 @@
50 53 
          (args (mapcar #'list args args-syms))
51 54 
          (destructuring-expressions
52 55 
            (rollup-list
53 
-             (append
54 56 
                (loop for (arg arg-sym) in args
55 57 
                      collect (if (consp arg)
56 58 
                                `(destructuring-bind ,arg ,arg-sym)
57 59 
                                `(let ((,arg ,arg-sym)))))
58 
-               body))))
60 
+               body)))
59 61 
     `(lambda ,args-syms
60 62 
        ,destructuring-expressions)))
61 63
64 
+
65 
+;;; CASES:::
66 
+#|
67 
+(fw.lu::destructuring-lambda ((slot slot-keyword . r))
68 
+                        (make-slot-spec slot slot-keyword))
69 
+
70 
+(fw.lu::destructuring-lambda ((slot slot-keyword . r))
71 
+                        (declare (ignore r))
72 
+                        (make-slot-spec slot slot-keyword))
73 
+
74 
+(fw.lu::destructuring-lambda ((slot slot-keyword . r) b c)
75 
+                        (make-slot-spec slot slot-keyword))
76 
+
77 
+(fw.lu::destructuring-lambda ((slot slot-keyword . r) b)
78 
+                        (make-slot-spec slot slot-keyword))
79 
+
80 
+(fw.lu::destructuring-lambda ((slot slot-keyword . r) b)
81 
+                        (declare (ignore r))
82 
+                        (make-slot-spec slot slot-keyword))
83 
+|#
84 
+
62 85 
 (defun alist-string-hash-table (alist)
63 86 
   "Make a hash table suitable for strings and other non-eql types
64 87 
    from an association list"