From alendvai at common-lisp.net  Tue Mar  4 07:42:30 2014
From: alendvai at common-lisp.net (Attila Lendvai)
Date: Mon,  3 Mar 2014 23:42:30 -0800 (PST)
Subject: updated branch master: 048de2e Optimize DELETE-FROM-PLIST not to cons.
Message-ID: <20140304074230.E677035645E@mail.common-lisp.net>

The branch master has been updated:
       via  048de2e545042c94287797f9c029c88606591cf5 (commit)
       via  1bb1d834758891dddae65b64e9beb44d55821d9b (commit)
       via  3499b6e0a94e3c616af1cecce0613ce0122e01af (commit)
      from  b8bd1033fc56485a7e293815ffe0fc32c327f8a4 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 048de2e545042c94287797f9c029c88606591cf5
Author: Attila Lendvai <attila.lendvai at gmail.com>
Date:   Tue Mar 4 13:41:20 2014 +0600

    Optimize DELETE-FROM-PLIST not to cons.
    
    Patch by "James M. Lawrence" <llmjjmll at gmail.com>

commit 1bb1d834758891dddae65b64e9beb44d55821d9b
Author: Attila Lendvai <attila.lendvai at gmail.com>
Date:   Tue Mar 4 13:40:31 2014 +0600

    add/fix some tests

commit 3499b6e0a94e3c616af1cecce0613ce0122e01af
Author: James M. Lawrence <llmjjmll at gmail.com>
Date:   Tue Feb 26 20:54:57 2013 -0500

    fix test PARSE-ORDINARY-LAMBDA-LIST.1
    
    Signed-off-by: Attila Lendvai <attila.lendvai at gmail.com>

-----------------------------------------------------------------------

Summary of changes:
 lists.lisp |   16 ++++++++++++++--
 tests.lisp |   40 +++++++++++++++++++++++++++++++---------
 2 files changed, 45 insertions(+), 11 deletions(-)

diff --git a/lists.lisp b/lists.lisp
index 00b42fa..feaa726 100644
--- a/lists.lisp
+++ b/lists.lisp
@@ -278,8 +278,20 @@ not destructively modified. Keys are compared using EQ."
 (defun delete-from-plist (plist &rest keys)
   "Just like REMOVE-FROM-PLIST, but this version may destructively modify the
 provided plist."
-  ;; FIXME: should not cons
-  (apply 'remove-from-plist plist keys))
+  (declare (optimize speed))
+  (loop with head = plist
+        with tail = nil   ; a nil tail means an empty result so far
+        for (key . rest) on plist by #'cddr
+        do (assert rest () "Expected a proper plist, got ~S" plist)
+           (if (member key keys :test #'eq)
+               ;; skip over this pair
+               (symbol-macrolet ((next (cdr rest)))
+                 (if tail
+                     (setf (cdr tail) next)
+                     (setf head next)))
+               ;; keep this pair
+               (setf tail rest))
+        finally (return head)))
 
 (define-modify-macro remove-from-plistf (&rest keys) remove-from-plist
                      "Modify macro for REMOVE-FROM-PLIST.")
diff --git a/tests.lisp b/tests.lisp
index 9eb2454..eec655f 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -869,6 +869,27 @@
    nil
    t))
 
+(deftest delete-from-plist.1
+    (let ((orig '(a 1 b 2 c 3 d 4)))
+      (list (delete-from-plist (copy-list orig) 'a 'c)
+            (delete-from-plist (copy-list orig) 'b 'd)
+            (delete-from-plist (copy-list orig) 'b)
+            (delete-from-plist (copy-list orig) 'a)
+            (delete-from-plist (copy-list orig) 'd 42 "zot")
+            (delete-from-plist (copy-list orig) 'a 'b 'c 'd)
+            (delete-from-plist (copy-list orig) 'a 'b 'c 'd 'x)
+            (equal orig (delete-from-plist orig))
+            (eq orig (delete-from-plist orig))))
+  ((b 2 d 4)
+   (a 1 c 3)
+   (a 1 c 3 d 4)
+   (b 2 c 3 d 4)
+   (a 1 b 2 c 3)
+   nil
+   nil
+   t
+   t))
+
 (deftest mappend.1
     (mappend (compose 'list '*) '(1 2 3) '(1 2 3))
   (1 4 9))
@@ -924,7 +945,7 @@
             'done))
       (sb-ext:timeout ()
         'timed-out))
-  'done)
+  done)
 
 (deftest iota.1
     (iota 3)
@@ -1900,11 +1921,12 @@
   t)
 
 (deftest parse-ordinary-lambda-list.1
-  (multiple-value-bind (req opt rest keys allowp aux keyp)
-      (parse-ordinary-lambda-list '(a b c &optional d &key))
-    (and (equal '(a b c) req)
-         (equal '((d nil nil)) opt)
-         (equal '() keys)
-         (not allowp)
-         (not aux)
-         (eq t keyp))))
+    (multiple-value-bind (req opt rest keys allowp aux keyp)
+        (parse-ordinary-lambda-list '(a b c &optional d &key))
+      (and (equal '(a b c) req)
+           (equal '((d nil nil)) opt)
+           (equal '() keys)
+           (not allowp)
+           (not aux)
+           (eq t keyp)))
+  t)
-- 
Alexandria hooks/post-receive