bug#25681: [PATCH] Simplify cl-get using `plist-member'

[npostavs]

Severity: wishlist
Tags: patch

I noticed cl-get and friends had on overly complicated
implemententation.

>From 760926c3b3bc36a8ac6854402e33d768c9e33fb1 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Fri, 5 Aug 2016 19:59:52 -0400
Subject: [PATCH] Simplify cl-get using `plist-member'

* lisp/emacs-lisp/cl-extra.el (cl-get, cl-getf, cl--set-getf): Use
`plist-member' instead of explicit loop.
* test/lisp/emacs-lisp/cl-extra-tests.el: New tests.
---
 lisp/emacs-lisp/cl-extra.el            | 28 +++++++------------------
 test/lisp/emacs-lisp/cl-extra-tests.el | 38 ++++++++++++++++++++++++++++++++++
 2 files changed, 46 insertions(+), 20 deletions(-)
 create mode 100644 test/lisp/emacs-lisp/cl-extra-tests.el

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 644c35d7b3..edd14b816f 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -593,13 +593,7 @@ cl-get
 \n(fn SYMBOL PROPNAME &optional DEFAULT)"
   (declare (compiler-macro cl--compiler-macro-get)
            (gv-setter (lambda (store) (ignore def) `(put ,sym ,tag ,store))))
-  (or (get sym tag)
-      (and def
-           ;; Make sure `def' is really absent as opposed to set to nil.
-          (let ((plist (symbol-plist sym)))
-            (while (and plist (not (eq (car plist) tag)))
-              (setq plist (cdr (cdr plist))))
-            (if plist (car (cdr plist)) def)))))
+  (cl-getf (symbol-plist sym) tag def))
 (autoload 'cl--compiler-macro-get "cl-macs")
 
 ;;;###autoload
@@ -618,26 +612,20 @@ cl-getf
                                  ,(funcall setter
                                            `(cl--set-getf ,getter ,k ,val))
                                  ,val)))))))))
-  (setplist '--cl-getf-symbol-- plist)
-  (or (get '--cl-getf-symbol-- tag)
-      ;; Originally we called cl-get here,
-      ;; but that fails, because cl-get has a compiler macro
-      ;; definition that uses getf!
-      (when def
-        ;; Make sure `def' is really absent as opposed to set to nil.
-       (while (and plist (not (eq (car plist) tag)))
-         (setq plist (cdr (cdr plist))))
-       (if plist (car (cdr plist)) def))))
+  (let ((val-tail (cdr-safe (plist-member plist tag))))
+    (if val-tail (car val-tail) def)))
 
 ;;;###autoload
 (defun cl--set-getf (plist tag val)
-  (let ((p plist))
-    (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p))))
-    (if p (progn (setcar (cdr p) val) plist) (cl-list* tag val plist))))
+  (let ((val-tail (cdr-safe (plist-member plist tag))))
+    (if val-tail (progn (setcar val-tail val) plist)
+      (cl-list* tag val plist))))
 
 ;;;###autoload
 (defun cl--do-remf (plist tag)
   (let ((p (cdr plist)))
+    ;; Can't use `plist-member' here because it goes to the cons-cell
+    ;; of TAG and we need the one before.
     (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
     (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
 
diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el 
b/test/lisp/emacs-lisp/cl-extra-tests.el
new file mode 100644
index 0000000000..3e2388acc6
--- /dev/null
+++ b/test/lisp/emacs-lisp/cl-extra-tests.el
@@ -0,0 +1,38 @@
+;;; cl-extra-tests.el --- tests for emacs-lisp/cl-extra.el  -*- 
lexical-binding:t -*-
+
+;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see `http://www.gnu.org/licenses/'.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'ert)
+
+(ert-deftest cl-get ()
+  (put 'cl-get-test 'x 1)
+  (put 'cl-get-test 'y nil)
+  (should (eq (cl-get 'cl-get-test 'x) 1))
+  (should (eq (cl-get 'cl-get-test 'y :none) nil))
+  (should (eq (cl-get 'cl-get-test 'z :none) :none)))
+
+(ert-deftest cl-getf ()
+  (let ((plist '(x 1 y nil)))
+    (should (eq (cl-getf plist 'x) 1))
+    (should (eq (cl-getf plist 'y :none) nil))
+    (should (eq (cl-getf plist 'z :none) :none))))
+
+;;; cl-extra-tests.el ends here
-- 
2.11.1