From 2a61bd0096db23123734db439051c859e42b9606 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 18 Jan 2015 12:24:43 -0500 Subject: [PATCH] EIEIO&cl-generic: Add obsolescence warnings and fix corner case * lisp/emacs-lisp/cl-generic.el (cl-generic-define-method): Correctly handle introduction of a new dispatch argument. (cl--generic-cache-miss): Handle dispatch on an argument which was not considered as dispatchable for this method. (cl-defmethod): Warn when adding a method to an obsolete generic function. (cl--generic-lambda): Make sure it works if cl-lib is not yet loaded. * lisp/emacs-lisp/eieio-generic.el (eieio--defgeneric-init-form): Use autoloadp. * lisp/emacs-lisp/eieio.el (defclass): Add obsolescence warning for the `newname' argument. * test/automated/cl-generic-tests.el (cl-generic-test-10-weird): New test. Rename other tests to preserve ordering. --- etc/NEWS | 2 ++ lisp/ChangeLog | 20 ++++++++++++++++--- lisp/emacs-lisp/cl-generic.el | 27 +++++++++++++++++--------- lisp/emacs-lisp/eieio-generic.el | 2 +- lisp/emacs-lisp/eieio.el | 11 +++++++++++ test/ChangeLog | 5 +++++ test/automated/cl-generic-tests.el | 31 ++++++++++++++++++++---------- 7 files changed, 75 insertions(+), 23 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index be283bbc1c3..4551c9c6b79 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -203,6 +203,8 @@ the old behavior -- *shell* buffer displays in current window -- use ** EIEIO *** The `:protection' slot option is not obeyed any more. +*** The `newname' argument to constructors is optional&deprecated. +If you need your objects to be named, do it by inheriting from `eieio-named'. *** The -list-p and -child-p functions are declared obsolete. *** The variables are declared obsolete. *** The variables are declared obsolete. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b7a1fb943a3..c731551f913 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,6 +1,20 @@ +2015-01-18 Stefan Monnier + + * emacs-lisp/eieio.el (defclass): Add obsolescence warning for the + `newname' argument. + + * emacs-lisp/cl-generic.el (cl-generic-define-method): Correctly handle + introduction of a new dispatch argument. + (cl--generic-cache-miss): Handle dispatch on an argument which was not + considered as dispatchable for this method. + (cl-defmethod): Warn when adding a method to an obsolete generic function. + (cl--generic-lambda): Make sure it works if cl-lib is not yet loaded. + + * emacs-lisp/eieio-generic.el (eieio--defgeneric-init-form): Use autoloadp. + 2015-01-18 Artur Malabarba - * emacs-lisp/package.el (package--append-to-alist): Renamed from + * emacs-lisp/package.el (package--append-to-alist): Rename from `package--add-to-alist' Updated docstring due to new name. @@ -862,8 +876,8 @@ 2014-12-27 Eli Zaretskii * language/misc-lang.el (composition-function-table): Add Syriac - characters and also ZWJ/ZWNJ. See - http://lists.gnu.org/archive/html/help-gnu-emacs/2014-12/msg00248.html + characters and also ZWJ/ZWNJ. + See http://lists.gnu.org/archive/html/help-gnu-emacs/2014-12/msg00248.html for the details. 2014-12-27 Fabián Ezequiel Gallina diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 819e2e92888..544f1fa140f 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -212,13 +212,13 @@ This macro can only be used within the lexical scope of a cl-generic method." (macroenv (cons `(cl-generic-current-method-specializers . ,(lambda () specializers)) macroexpand-all-environment))) + (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. (if (not with-cnm) (cons nil (macroexpand-all fun macroenv)) ;; First macroexpand away the cl-function stuff (e.g. &key and ;; destructuring args, `declare' and whatnot). (pcase (macroexpand fun macroenv) (`#'(lambda ,args . ,body) - (require 'cl-lib) ;Needed to expand `cl-flet'. (let* ((doc-string (and doc-string (stringp (car body)) (pop body))) (cnm (make-symbol "cl--cnm")) @@ -287,6 +287,13 @@ which case this method will be invoked when the argument is `eql' to VAL. (cadr name)))) (setq name setter) code)) + ,(and (get name 'byte-obsolete-info) + (or (not (fboundp 'byte-compile-warning-enabled-p)) + (byte-compile-warning-enabled-p 'obsolete)) + (let* ((obsolete (get name 'byte-obsolete-info))) + (macroexp--warn-and-return + (macroexp--obsolete-warning name obsolete "generic function") + nil))) (cl-generic-define-method ',name ',qualifiers ',args ,uses-cnm ,fun))))) @@ -308,13 +315,14 @@ which case this method will be invoked when the argument is `eql' to VAL. (dolist (specializer specializers) (let* ((tagcode (funcall cl-generic-tagcode-function specializer 'arg)) (x (assq i dispatches))) - (if (not x) - (setf (cl--generic-dispatches generic) - (setq dispatches (cons (list i tagcode) dispatches))) - (unless (member tagcode (cdr x)) - (setf (cdr x) - (nreverse (sort (cons tagcode (cdr x)) - #'car-less-than-car))))) + (unless x + (setq x (list i (funcall cl-generic-tagcode-function t 'arg))) + (setf (cl--generic-dispatches generic) + (setq dispatches (cons x dispatches)))) + (unless (member tagcode (cdr x)) + (setf (cdr x) + (nreverse (sort (cons tagcode (cdr x)) + #'car-less-than-car)))) (setq i (1+ i)))) (if me (setcdr me (cons uses-cnm function)) (setf (cl--generic-method-table generic) @@ -478,7 +486,8 @@ for all those different tags in the method-cache.") (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags))) (methods '())) (dolist (method-desc (cl--generic-method-table generic)) - (let ((m (member (nth dispatch-arg (caar method-desc)) types))) + (let* ((specializer (or (nth dispatch-arg (caar method-desc)) t)) + (m (member specializer types))) (when m (push (cons (length m) method-desc) methods)))) ;; Sort the methods, most specific first. diff --git a/lisp/emacs-lisp/eieio-generic.el b/lisp/emacs-lisp/eieio-generic.el index 27a58493905..74ecefe7863 100644 --- a/lisp/emacs-lisp/eieio-generic.el +++ b/lisp/emacs-lisp/eieio-generic.el @@ -110,7 +110,7 @@ Methods with only primary implementations are executed in an optimized way." (cond ((or (not (fboundp method)) - (eq 'autoload (car-safe (symbol-function method)))) + (autoloadp (symbol-function method))) ;; Make sure the method tables are installed. (eieio--mt-install method) ;; Construct the actual body of this function. diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index c5597b83170..0c85d90151a 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -276,6 +276,17 @@ and reference them using the function `class-option'." `(defun ,name (&rest slots) ,(format "Create a new object with name NAME of class type %S." name) + (declare (compiler-macro + (lambda (whole) + (if (not (stringp (car slots))) + whole + (macroexp--warn-and-return + (format "Obsolete name arg %S to constructor %S" + (car slots) (car whole)) + ;; Keep the name arg, for backward compatibility, + ;; but hide it so we don't trigger indefinitely. + `(,(car whole) (identity ,(car slots)) + ,@(cdr slots))))))) (apply #'eieio-constructor ',name slots)))))) diff --git a/test/ChangeLog b/test/ChangeLog index 15baf866f37..e81bfa7d185 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,8 @@ +2015-01-18 Stefan Monnier + + * automated/cl-generic-tests.el (cl-generic-test-10-weird): New test. + Rename other tests to preserve ordering. + 2015-01-18 Leo Liu * automated/seq-tests.el (test-seq-subseq): Add more tests. diff --git a/test/automated/cl-generic-tests.el b/test/automated/cl-generic-tests.el index 46397fb7f51..1c01d9b164b 100644 --- a/test/automated/cl-generic-tests.el +++ b/test/automated/cl-generic-tests.el @@ -29,12 +29,12 @@ (cl-defgeneric cl--generic-1 (x y)) (cl-defgeneric (setf cl--generic-1) (v y z) "My generic doc.") -(ert-deftest cl-generic-test-0 () +(ert-deftest cl-generic-test-00 () (cl-defgeneric cl--generic-1 (x y)) (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) (should (equal (cl--generic-1 'a 'b) '(a . b)))) -(ert-deftest cl-generic-test-1-eql () +(ert-deftest cl-generic-test-01-eql () (cl-defgeneric cl--generic-1 (x y)) (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) @@ -53,7 +53,7 @@ (cl-defstruct (cl-generic-struct-child11 (:include cl-generic-struct-child1)) d) (cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent)) e) -(ert-deftest cl-generic-test-2-struct () +(ert-deftest cl-generic-test-02-struct () (cl-defgeneric cl--generic-1 (x y) "My doc.") (cl-defmethod cl--generic-1 ((x t) y) "Doc 1." (cons x y)) (cl-defmethod cl--generic-1 ((_x cl-generic-struct-parent) y) @@ -73,7 +73,7 @@ (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil) '("child11" "around""child1" "parent" a)))) -(ert-deftest cl-generic-test-3-setf () +(ert-deftest cl-generic-test-03-setf () (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z)) (cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z)) (should (equal (setf (cl--generic-1 'a 'b) 'v) '(v a b))) @@ -85,7 +85,7 @@ '(v a b))) (should (equal x '(3 2 1))))) -(ert-deftest cl-generic-test-4-overlapping-tagcodes () +(ert-deftest cl-generic-test-04-overlapping-tagcodes () (cl-defgeneric cl--generic-1 (x y) "My doc.") (cl-defmethod cl--generic-1 ((y t) z) (list y z)) (cl-defmethod cl--generic-1 ((_y (eql 4)) _z) @@ -98,7 +98,7 @@ (should (equal (cl--generic-1 1 'b) '("integer" "number" 1 b))) (should (equal (cl--generic-1 4 'b) '("four" "integer" "number" 4 b)))) -(ert-deftest cl-generic-test-5-alias () +(ert-deftest cl-generic-test-05-alias () (cl-defgeneric cl--generic-1 (x y) "My doc.") (defalias 'cl--generic-2 #'cl--generic-1) (cl-defmethod cl--generic-1 ((y t) z) (list y z)) @@ -106,7 +106,7 @@ (cons "four" (cl-call-next-method))) (should (equal (cl--generic-1 4 'b) '("four" 4 b)))) -(ert-deftest cl-generic-test-6-multiple-dispatch () +(ert-deftest cl-generic-test-06-multiple-dispatch () (cl-defgeneric cl--generic-1 (x y) "My doc.") (cl-defmethod cl--generic-1 (x y) (list x y)) (cl-defmethod cl--generic-1 (_x (_y integer)) @@ -117,7 +117,7 @@ (cons "x&y-int" (cl-call-next-method))) (should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2)))) -(ert-deftest cl-generic-test-7-apo () +(ert-deftest cl-generic-test-07-apo () (cl-defgeneric cl--generic-1 (x y) (:documentation "My doc.") (:argument-precedence-order y x)) (cl-defmethod cl--generic-1 (x y) (list x y)) @@ -129,7 +129,7 @@ (cons "x&y-int" (cl-call-next-method))) (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2)))) -(ert-deftest cl-generic-test-8-after/before () +(ert-deftest cl-generic-test-08-after/before () (let ((log ())) (cl-defgeneric cl--generic-1 (x y)) (cl-defmethod cl--generic-1 ((_x t) y) (cons y log)) @@ -144,7 +144,7 @@ (defun cl--generic-test-advice (&rest args) (cons "advice" (apply args))) -(ert-deftest cl-generic-test-9-advice () +(ert-deftest cl-generic-test-09-advice () (cl-defgeneric cl--generic-1 (x y) "My doc.") (cl-defmethod cl--generic-1 (x y) (list x y)) (advice-add 'cl--generic-1 :around #'cl--generic-test-advice) @@ -155,5 +155,16 @@ (advice-remove 'cl--generic-1 #'cl--generic-test-advice) (should (equal (cl--generic-1 4 5) '("integer" 4 5)))) +(ert-deftest cl-generic-test-10-weird () + (cl-defgeneric cl--generic-1 (x &rest r) "My doc.") + (cl-defmethod cl--generic-1 (x &rest r) (cons x r)) + ;; This kind of definition is not valid according to CLHS, but it does show + ;; up in EIEIO's tests for no-next-method, so we should either + ;; detect it and signal an error or do something meaningful with it. + (cl-defmethod cl--generic-1 (x (y integer) &rest r) + `("integer" ,y ,x ,@r)) + (should (equal (cl--generic-1 'a 'b) '(a b))) + (should (equal (cl--generic-1 1 2) '("integer" 2 1)))) + (provide 'cl-generic-tests) ;;; cl-generic-tests.el ends here -- 2.39.5