# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1460640751 0
# Node ID d16b5b36039846f8623a081bdcddfd86bd847577
# Parent  fdb771cc2b8cf2ee987aee2c19a9ffc0b5291a0e
Fix up `push-if-new` with setf/places macromancy

diff -r fdb771cc2b8c -r d16b5b360398 package.lisp
--- a/package.lisp	Wed Apr 13 17:38:57 2016 +0000
+++ b/package.lisp	Thu Apr 14 13:32:31 2016 +0000
@@ -7,7 +7,6 @@
         #:defstar
         #:bones.quickutils)
   (:export
-    #:vector-push-extend-all
     #:push-if-new))
 
 (defpackage #:bones.wam
diff -r fdb771cc2b8c -r d16b5b360398 src/make-quickutils.lisp
--- a/src/make-quickutils.lisp	Wed Apr 13 17:38:57 2016 +0000
+++ b/src/make-quickutils.lisp	Thu Apr 14 13:32:31 2016 +0000
@@ -12,6 +12,7 @@
                :tree-member-p
                :tree-collect
                :with-gensyms
+               :zip
                :map-tree
                )
   :package "BONES.QUICKUTILS")
diff -r fdb771cc2b8c -r d16b5b360398 src/quickutils.lisp
--- a/src/quickutils.lisp	Wed Apr 13 17:38:57 2016 +0000
+++ b/src/quickutils.lisp	Thu Apr 14 13:32:31 2016 +0000
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :MAP-TREE) :ensure-package T :package "BONES.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :ZIP :MAP-TREE) :ensure-package T :package "BONES.QUICKUTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "BONES.QUICKUTILS")
@@ -18,7 +18,8 @@
                                          :CURRY :STRING-DESIGNATOR
                                          :WITH-GENSYMS :EXTRACT-FUNCTION-NAME
                                          :SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE
-                                         :TREE-MEMBER-P :TREE-COLLECT :MAP-TREE))))
+                                         :TREE-MEMBER-P :TREE-COLLECT
+                                         :TRANSPOSE :ZIP :MAP-TREE))))
 
   (defun %reevaluate-constant (name value test)
     (if (not (boundp name))
@@ -254,6 +255,17 @@
                     :append (tree-collect predicate item)))))
   
 
+  (defun transpose (lists)
+    "Analog to matrix transpose for a list of lists given by `lists`."
+    (apply #'mapcar #'list lists))
+  
+
+  (defun zip (&rest lists)
+    "Take a tuple of lists and turn them into a list of
+tuples. Equivalent to `unzip`."
+    (transpose lists))
+  
+
   (defun map-tree (function tree)
     "Map `function` to each of the leave of `tree`."
     (check-type tree cons)
@@ -269,6 +281,6 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (export '(define-constant set-equal curry switch eswitch cswitch
             ensure-boolean while until tree-member-p tree-collect with-gensyms
-            with-unique-names map-tree)))
+            with-unique-names zip map-tree)))
 
 ;;;; END OF quickutils.lisp ;;;;
diff -r fdb771cc2b8c -r d16b5b360398 src/utils.lisp
--- a/src/utils.lisp	Wed Apr 13 17:38:57 2016 +0000
+++ b/src/utils.lisp	Thu Apr 14 13:32:31 2016 +0000
@@ -1,9 +1,19 @@
 (in-package #:bones.utils)
 
-;; TODO: learn setf expanders and do this right.
-(defmacro push-if-new (thing list-place)
-  `(not (eql ,list-place (pushnew ,thing ,list-place))))
+(defmacro push-if-new (thing place
+                             &environment env
+                             &key key (test 'eql))
+  "Push `thing` into the list at `place` if it's not already there.
+
+  Returns whether `thing` was actually pushed.  This function is basically
+  `pushnew` except for the return value.
 
-(defun vector-push-extend-all (vector &rest things)
-  (loop :for thing :in things :do
-        (vector-push-extend thing vector)))
+  "
+  (multiple-value-bind (temps exprs stores store-expr access-expr)
+      (get-setf-expansion place env)
+    (declare (ignore stores store-expr))
+    (with-gensyms (current result)
+      `(let* (,@(zip temps exprs)
+              (,current ,access-expr)
+              (,result (pushnew ,thing ,place :key ,key :test ,test)))
+        (not (eql ,current ,result))))))