* 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.
This commit is contained in:
Stefan Monnier 2015-05-13 18:39:49 -04:00
parent 8d69f38a94
commit 37ab2245f2
5 changed files with 43 additions and 15 deletions

View file

@ -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 <val>) 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:

View file

@ -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)

View file

@ -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

View file

@ -193,6 +193,7 @@
(load "language/cham")
(load "indent")
(load "emacs-lisp/cl-generic")
(load "frame")
(load "startup")
(load "term/tty-colors")

View file

@ -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 \