diff options
| -rw-r--r-- | lib-src/emacsclient.c | 8 | ||||
| -rw-r--r-- | lisp/ChangeLog.16 | 3 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 43 | ||||
| -rw-r--r-- | test/automated/cl-generic-tests.el | 40 |
4 files changed, 66 insertions, 28 deletions
diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c index 806275f5b1d..357ebc736ab 100644 --- a/lib-src/emacsclient.c +++ b/lib-src/emacsclient.c @@ -107,13 +107,13 @@ char *w32_getenv (char *); /* Name used to invoke this program. */ const char *progname; -/* The second argument to main. */ +/* The second argument to main. */ char **main_argv; /* Nonzero means don't wait for a response from Emacs. --no-wait. */ int nowait = 0; -/* Nonzero means don't print messages for successful operations. --quiet. */ +/* Nonzero means don't print messages for successful operations. --quiet. */ int quiet = 0; /* Nonzero means args are expressions to be evaluated. --eval. */ @@ -131,7 +131,7 @@ const char *alt_display = NULL; /* The parent window ID, if we are opening a frame via XEmbed. */ char *parent_id = NULL; -/* Nonzero means open a new Emacs frame on the current terminal. */ +/* Nonzero means open a new Emacs frame on the current terminal. */ int tty = 0; /* If non-NULL, the name of an editor to fallback to if the server @@ -148,7 +148,7 @@ const char *server_file = NULL; int emacs_pid = 0; /* If non-NULL, a string that should form a frame parameter alist to - be used for the new frame */ + be used for the new frame. */ const char *frame_parameters = NULL; static _Noreturn void print_help_and_exit (void); diff --git a/lisp/ChangeLog.16 b/lisp/ChangeLog.16 index 457c1511af8..bc5267aadba 100644 --- a/lisp/ChangeLog.16 +++ b/lisp/ChangeLog.16 @@ -5030,8 +5030,7 @@ * mouse.el (mouse-yank-primarY): Look for frame-type w32, not system-type windows-nt. - * server.el (server-create-window-system-frame): Look for window - type. + * server.el (server-create-window-system-frame): Look for window type. (server-proces-filter): Only force a window system when windows-nt _and_ w32. Explain why. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 13585bcaf18..b3c127f48f7 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -237,14 +237,19 @@ BODY, if present, is used as the body of a default method. (`(,spec-args . ,_) (cl--generic-split-args args)) (mandatory (mapcar #'car spec-args)) (apo (assq :argument-precedence-order options))) - (setf (cl--generic-dispatches generic) nil) + (unless (fboundp name) + ;; If the generic function was fmakunbound, throw away previous methods. + (setf (cl--generic-dispatches generic) nil) + (setf (cl--generic-method-table generic) nil)) (when apo (dolist (arg (cdr apo)) (let ((pos (memq arg mandatory))) (unless pos (error "%S is not a mandatory argument" arg)) - (push (list (- (length mandatory) (length pos))) - (cl--generic-dispatches generic))))) - (setf (cl--generic-method-table generic) nil) + (let* ((argno (- (length mandatory) (length pos))) + (dispatches (cl--generic-dispatches generic)) + (dispatch (or (assq argno dispatches) (list argno)))) + (setf (cl--generic-dispatches generic) + (cons dispatch (delq dispatch dispatches))))))) (setf (cl--generic-options generic) options) (cl--generic-make-function generic))) @@ -438,16 +443,14 @@ which case this method will be invoked when the argument is `eql' to VAL. ;; the generic function. current-load-list) ;; For aliases, cl--generic-name gives us the actual name. - (funcall - (if purify-flag - ;; BEWARE! Don't purify this function definition, since that leads - ;; to memory corruption if the hash-tables it holds are modified - ;; (the GC doesn't trace those pointers). - #'fset - ;; But do use `defalias' in the normal case, so that it interacts - ;; properly with nadvice, e.g. for tracing/debug-on-entry. - #'defalias) - (cl--generic-name generic) gfun)))) + (let ((purify-flag + ;; BEWARE! Don't purify this function definition, since that leads + ;; to memory corruption if the hash-tables it holds are modified + ;; (the GC doesn't trace those pointers). + nil)) + ;; But do use `defalias', so that it interacts properly with nadvice, + ;; e.g. for tracing/debug-on-entry. + (defalias (cl--generic-name generic) gfun))))) (defmacro cl--generic-with-memoization (place &rest code) (declare (indent 1) (debug t)) @@ -705,6 +708,11 @@ methods.") (if (eq specializer t) (list cl--generic-t-generalizer) (error "Unknown specializer %S" specializer))) +(eval-when-compile + ;; This macro is brittle and only really important in order to be + ;; able to preload cl-generic without also preloading the byte-compiler, + ;; So we use `eval-when-compile' so as not keep it available longer than + ;; strictly needed. (defmacro cl--generic-prefill-dispatchers (arg-or-context specializer) (unless (integerp arg-or-context) (setq arg-or-context `(&context . ,arg-or-context))) @@ -722,7 +730,7 @@ methods.") ,@(cl-generic-generalizers ',specializer) ,cl--generic-t-generalizer))) ;; (message "Prefilling for %S with \n%S" dispatch ',fun) - (puthash dispatch ',fun cl--generic-dispatchers)))) + (puthash dispatch ',fun cl--generic-dispatchers))))) (cl-defmethod cl-generic-combine-methods (generic methods) "Standard support for :after, :before, :around, and `:extra NAME' qualifiers." @@ -796,8 +804,6 @@ Can only be used from within the lexical body of a primary or around method." specializers qualifiers (cl--generic-method-table (cl--generic generic))))) -(defalias 'cl-method-qualifiers 'cl--generic-method-qualifiers) - ;;; Add support for describe-function (defun cl--generic-search-method (met-name) @@ -850,6 +856,9 @@ Can only be used from within the lexical body of a primary or around method." (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) (defun cl--generic-describe (function) + ;; Supposedly this is called from help-fns, so help-fns should be loaded at + ;; this point. + (declare-function help-fns-short-filename "help-fns" (filename)) (let ((generic (if (symbolp function) (cl--generic function)))) (when generic (require 'help-mode) ;Needed for `help-function-def' button! diff --git a/test/automated/cl-generic-tests.el b/test/automated/cl-generic-tests.el index a6035d1cba2..2703b44dee5 100644 --- a/test/automated/cl-generic-tests.el +++ b/test/automated/cl-generic-tests.el @@ -26,15 +26,18 @@ (eval-when-compile (require 'ert)) ;Don't indirectly require cl-lib at run-time. (require 'cl-generic) +(fmakunbound 'cl--generic-1) (cl-defgeneric cl--generic-1 (x y)) (cl-defgeneric (setf cl--generic-1) (v y z) "My generic doc.") (ert-deftest cl-generic-test-00 () + (fmakunbound 'cl--generic-1) (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-01-eql () + (fmakunbound 'cl--generic-1) (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) @@ -54,6 +57,7 @@ (cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent)) e) (ert-deftest cl-generic-test-02-struct () + (fmakunbound 'cl--generic-1) (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) @@ -91,6 +95,7 @@ (should (equal x '(3 2 1))))) (ert-deftest cl-generic-test-04-overlapping-tagcodes () + (fmakunbound 'cl--generic-1) (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) @@ -104,6 +109,7 @@ (should (equal (cl--generic-1 4 'b) '("four" "integer" "number" 4 b)))) (ert-deftest cl-generic-test-05-alias () + (fmakunbound 'cl--generic-1) (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)) @@ -112,6 +118,7 @@ (should (equal (cl--generic-1 4 'b) '("four" 4 b)))) (ert-deftest cl-generic-test-06-multiple-dispatch () + (fmakunbound 'cl--generic-1) (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)) @@ -123,6 +130,7 @@ (should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2)))) (ert-deftest cl-generic-test-07-apo () + (fmakunbound 'cl--generic-1) (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)) @@ -136,6 +144,7 @@ (ert-deftest cl-generic-test-08-after/before () (let ((log ())) + (fmakunbound 'cl--generic-1) (cl-defgeneric cl--generic-1 (x y)) (cl-defmethod cl--generic-1 ((_x t) y) (cons y log)) (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) @@ -150,6 +159,7 @@ (defun cl--generic-test-advice (&rest args) (cons "advice" (apply args))) (ert-deftest cl-generic-test-09-advice () + (fmakunbound 'cl--generic-1) (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) @@ -161,6 +171,7 @@ (should (equal (cl--generic-1 4 5) '("integer" 4 5)))) (ert-deftest cl-generic-test-10-weird () + (fmakunbound 'cl--generic-1) (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 @@ -172,6 +183,7 @@ (should (equal (cl--generic-1 1 2) '("integer" 2 1)))) (ert-deftest cl-generic-test-11-next-method-p () + (fmakunbound 'cl--generic-1) (cl-defgeneric cl--generic-1 (x y)) (cl-defmethod cl--generic-1 ((x t) y) (list x y (cl-next-method-p))) @@ -179,15 +191,33 @@ (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method))) (should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil)))) -(ert-deftest sm-generic-test-12-context () +(ert-deftest cl-generic-test-12-context () + (fmakunbound 'cl--generic-1) (cl-defgeneric cl--generic-1 ()) - (cl-defmethod cl--generic-1 (&context (overwrite-mode (eql t))) 'is-t) - (cl-defmethod cl--generic-1 (&context (overwrite-mode (eql nil))) 'is-nil) - (cl-defmethod cl--generic-1 () 'other) + (cl-defmethod cl--generic-1 (&context (overwrite-mode (eql t))) + (list 'is-t (cl-call-next-method))) + (cl-defmethod cl--generic-1 (&context (overwrite-mode (eql nil))) + (list 'is-nil (cl-call-next-method))) + (cl-defmethod cl--generic-1 () 'any) (should (equal (list (let ((overwrite-mode t)) (cl--generic-1)) (let ((overwrite-mode nil)) (cl--generic-1)) (let ((overwrite-mode 1)) (cl--generic-1))) - '(is-t is-nil other)))) + '((is-t any) (is-nil any) any)))) + +(ert-deftest cl-generic-test-13-head () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) + (cl-defmethod cl--generic-1 ((_x (head 4)) _y) + (cons "quatre" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (head 5)) _y) + (cons "cinq" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (head 6)) y) + (cons "six" (cl-call-next-method 'a y))) + (should (equal (cl--generic-1 'a nil) '(a))) + (should (equal (cl--generic-1 '(4) nil) '("quatre" (4)))) + (should (equal (cl--generic-1 '(5) nil) '("cinq" (5)))) + (should (equal (cl--generic-1 '(6) nil) '("six" a)))) (provide 'cl-generic-tests) ;;; cl-generic-tests.el ends here |