From 37ab2245f27d83f0faa3c0d9277088433bc4efaf Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 13 May 2015 18:39:49 -0400 Subject: [PATCH] * lisp/loadup.el ("emacs-lisp/cl-generic"): Preload * src/lisp.mk (lisp): Add emacs-lisp/cl-generic.elc. * lisp/emacs-lisp/cl-generic.el (cl-generic-define-method): Avoid defalias for closures which are not immutable. (cl--generic-prefill-dispatchers): New macro. Use it to prefill the dispatchers table with various entries. * lisp/emacs-lisp/ert.el (emacs-lisp-mode-hook): * lisp/emacs-lisp/seq.el (emacs-lisp-mode-hook): Use add-hook. --- lisp/emacs-lisp/cl-generic.el | 50 ++++++++++++++++++++++++++++++++----------- lisp/emacs-lisp/ert.el | 4 ++-- lisp/emacs-lisp/seq.el | 2 +- lisp/loadup.el | 1 + src/lisp.mk | 1 + 5 files changed, 43 insertions(+), 15 deletions(-) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index f6595d3035b..a2716ef87ee 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -438,7 +438,16 @@ 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. - (defalias (cl--generic-name generic) gfun)))) + (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)))) (defmacro cl--generic-with-memoization (place &rest code) (declare (indent 1) (debug t)) @@ -696,6 +705,25 @@ methods.") (if (eq specializer t) (list cl--generic-t-generalizer) (error "Unknown specializer %S" specializer))) +(defmacro cl--generic-prefill-dispatchers (arg-or-context specializer) + (unless (integerp arg-or-context) + (setq arg-or-context `(&context . ,arg-or-context))) + (unless (fboundp 'cl--generic-get-dispatcher) + (require 'cl-generic)) + (let ((fun (cl--generic-get-dispatcher + `(,arg-or-context ,@(cl-generic-generalizers specializer) + ,cl--generic-t-generalizer)))) + ;; Recompute dispatch at run-time, since the generalizers may be slightly + ;; different (e.g. byte-compiled rather than interpreted). + ;; FIXME: There is a risk that the run-time generalizer is not equivalent + ;; to the compile-time one, in which case `fun' may not be correct + ;; any more! + `(let ((dispatch `(,',arg-or-context + ,@(cl-generic-generalizers ',specializer) + ,cl--generic-t-generalizer))) + ;; (message "Prefilling for %S with \n%S" dispatch ',fun) + (puthash dispatch ',fun cl--generic-dispatchers)))) + (cl-defmethod cl-generic-combine-methods (generic methods) "Standard support for :after, :before, :around, and `:extra NAME' qualifiers." (cl--generic-standard-method-combination generic methods)) @@ -869,17 +897,6 @@ Can only be used from within the lexical body of a primary or around method." 80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used)) (lambda (tag) (if (eq (car-safe tag) 'head) (list tag))))) -;; Pre-fill the cl--generic-dispatchers table. -;; We have two copies of `(0 ...)' but we can't share them via `let' because -;; they're not used at the same time (one is compile-time, one is run-time). -(puthash `(0 ,cl--generic-head-generalizer ,cl--generic-t-generalizer) - (eval-when-compile - (unless (fboundp 'cl--generic-get-dispatcher) - (require 'cl-generic)) - (cl--generic-get-dispatcher - `(0 ,cl--generic-head-generalizer ,cl--generic-t-generalizer))) - cl--generic-dispatchers) - (cl-defmethod cl-generic-generalizers :extra "head" (specializer) "Support for the `(head VAL)' specializers." ;; We have to implement `head' here using the :extra qualifier, @@ -890,6 +907,8 @@ Can only be used from within the lexical body of a primary or around method." (gethash (cadr specializer) cl--generic-head-used) specializer) (list cl--generic-head-generalizer))) +(cl--generic-prefill-dispatchers 0 (head eql)) + ;;; Support for (eql ) specializers. (defvar cl--generic-eql-used (make-hash-table :test #'eql)) @@ -904,6 +923,9 @@ Can only be used from within the lexical body of a primary or around method." (puthash (cadr specializer) specializer cl--generic-eql-used) (list cl--generic-eql-generalizer)) +(cl--generic-prefill-dispatchers 0 (eql nil)) +(cl--generic-prefill-dispatchers window-system (eql nil)) + ;;; Support for cl-defstructs specializers. (defun cl--generic-struct-tag (name) @@ -960,6 +982,8 @@ Can only be used from within the lexical body of a primary or around method." (list cl--generic-struct-generalizer)))) (cl-call-next-method))) +(cl--generic-prefill-dispatchers 0 cl--generic-generalizer) + ;;; Dispatch on "system types". (defconst cl--generic-typeof-types @@ -998,6 +1022,8 @@ Can only be used from within the lexical body of a primary or around method." (list cl--generic-typeof-generalizer))) (cl-call-next-method))) +(cl--generic-prefill-dispatchers 0 integer) + ;; Local variables: ;; generated-autoload-file: "cl-loaddefs.el" ;; End: diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 8dc8261365f..b678e122c11 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -2537,7 +2537,7 @@ To be used in the ERT results buffer." (add-to-list 'minor-mode-alist '(ert--current-run-stats (:eval (ert--tests-running-mode-line-indicator)))) -(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) +(add-hook 'emacs-lisp-mode-hook #'ert--activate-font-lock-keywords) (defun ert--unload-function () "Unload function to undo the side-effects of loading ert.el." @@ -2548,7 +2548,7 @@ To be used in the ERT results buffer." nil) (defvar ert-unload-hook '()) -(add-hook 'ert-unload-hook 'ert--unload-function) +(add-hook 'ert-unload-hook #'ert--unload-function) (provide 'ert) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 5553de658b2..0aa0f095969 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -442,7 +442,7 @@ If no element is found, return nil." (unless (fboundp 'elisp--font-lock-flush-elisp-buffers) ;; In Emacsā‰„25, (via elisp--font-lock-flush-elisp-buffers and a few others) ;; we automatically highlight macros. - (add-to-list 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords)) + (add-hook 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords)) (provide 'seq) ;;; seq.el ends here diff --git a/lisp/loadup.el b/lisp/loadup.el index 0746f95c1b9..828b19e85e3 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -193,6 +193,7 @@ (load "language/cham") (load "indent") +(load "emacs-lisp/cl-generic") (load "frame") (load "startup") (load "term/tty-colors") diff --git a/src/lisp.mk b/src/lisp.mk index ee2a07c0fd7..8eb86b7429e 100644 --- a/src/lisp.mk +++ b/src/lisp.mk @@ -113,6 +113,7 @@ lisp = \ $(lispsource)/language/cham.elc \ $(lispsource)/indent.elc \ $(lispsource)/window.elc \ + $(lispsource)/emacs-lisp/cl-generic.elc \ $(lispsource)/frame.elc \ $(lispsource)/term/tty-colors.elc \ $(lispsource)/font-core.elc \ -- 2.11.4.GIT