mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-03 18:41:25 -08:00
Code Issues Projects Releases Wiki Activity

* lisp/emacs-lisp/cl-generic.el: Try and fix bug#49866

Browse source 
(cl-generic-generalizers): Remember the specializers that match
a given value.
(cl--generic-eql-generalizer): Adjust accordingly.

* test/lisp/emacs-lisp/cl-generic-tests.el (cl-generic-test-01-eql):
Add corresponding test.
This commit is contained in:
Stefan Monnier 2021-08-09 19:03:01 -04:00
parent 0509f3921b
commit 75de09b9de
2 changed files with 21 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

29
lisp/emacs-lisp/cl-generic.el
View file

@ -1153,22 +1153,27 @@ These match if the argument is a cons cell whose car is `eql' to VAL."
(cl-generic-define-generalizer cl--generic-eql-generalizer (cl-generic-define-generalizer cl--generic-eql-generalizer
100 (lambda (name &rest _) `(gethash ,name cl--generic-eql-used)) 100 (lambda (name &rest _) `(gethash ,name cl--generic-eql-used))
(lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (list tag)))) (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (cdr tag))))
(cl-defmethod cl-generic-generalizers ((specializer (head eql))) (cl-defmethod cl-generic-generalizers ((specializer (head eql)))
"Support for (eql VAL) specializers. "Support for (eql VAL) specializers.
These match if the argument is `eql' to VAL." These match if the argument is `eql' to VAL."
(let ((form (cadr specializer))) (let* ((form (cadr specializer))
(puthash (if (or (not (symbolp form)) (macroexp-const-p form)) (val (if (or (not (symbolp form)) (macroexp-const-p form))
(eval form t) (eval form t)
;; FIXME: Compatibility with Emacs<28. For now emitting ;; FIXME: Compatibility with Emacs<28. For now emitting
;; a warning would be annoying for third party packages ;; a warning would be annoying for third party packages
;; which can't use the new form without breaking compatibility ;; which can't use the new form without breaking compatibility
;; with older Emacsen, but in the future we should emit ;; with older Emacsen, but in the future we should emit
;; a warning. ;; a warning.
;; (message "Quoting obsolete `eql' form: %S" specializer) ;; (message "Quoting obsolete `eql' form: %S" specializer)
form) form))
specializer cl--generic-eql-used)) (specializers (cdr (gethash val cl--generic-eql-used))))
;; The `specializers-function' needs to return all the (eql EXP) that
;; were used for the same VALue (bug#49866).
;; So we keep this info in `cl--generic-eql-used'.
(cl-pushnew specializer specializers :test #'equal)
(puthash val `(eql . ,specializers) cl--generic-eql-used))
(list cl--generic-eql-generalizer)) (list cl--generic-eql-generalizer))
(cl--generic-prefill-dispatchers 0 (eql nil)) (cl--generic-prefill-dispatchers 0 (eql nil))

5
test/lisp/emacs-lisp/cl-generic-tests.el
View file

@ -60,7 +60,10 @@
(defvar cl--generic-fooval 41) (defvar cl--generic-fooval 41)
(cl-defmethod cl--generic-1 ((_x (eql (+ cl--generic-fooval 1))) _y) (cl-defmethod cl--generic-1 ((_x (eql (+ cl--generic-fooval 1))) _y)
"forty-two") "forty-two")
(should (equal (cl--generic-1 42 nil) "forty-two"))) (cl-defmethod cl--generic-1 (_x (_y (eql 42)))
"FORTY-TWO")
(should (equal (cl--generic-1 42 nil) "forty-two"))
(should (equal (cl--generic-1 nil 42) "FORTY-TWO")))
(cl-defstruct cl-generic-struct-parent a b) (cl-defstruct cl-generic-struct-parent a b)
(cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c) (cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c)