(`(,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)))
(> (cl--generic-generalizer-priority x)
(cl--generic-generalizer-priority y)))))))
(setq i (1+ i))))
- (if me (setcar me method)
- (setf (cl--generic-method-table generic) (cons method mt)))
+ ;; We used to (setcar me method), but that can cause false positives in
+ ;; the hash-consing table of the method-builder (bug#20644).
+ ;; See the related FIXME in cl--generic-build-combined-method.
+ (setf (cl--generic-method-table generic) (cons method (delq (car me) mt)))
(cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
current-load-list :test #'equal)
;; FIXME: Try to avoid re-constructing a new function if the old one
;; the generic function.
current-load-list)
;; For aliases, cl--generic-name gives us the actual name.
- (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))
(progn
(while (and dispatches
(let ((x (nth 1 (car dispatches))))
- ;; No need to dispatch for `t' specializers.
+ ;; No need to dispatch for t specializers.
(or (null x) (equal x cl--generic-t-generalizer))))
(setq dispatches (cdr dispatches)))
(pop dispatches))))
#'cl--generic-standard-method-combination)
(cl-defmethod cl-generic-generalizers (specializer)
- "Support for the catch-all `t' specializer."
+ "Support for the catch-all t specializer."
(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)))
+ (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))
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)
(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!
(cl--generic-method-specializers method)))
(file (find-lisp-object-file-name met-name 'cl-defmethod)))
(when file
- (insert " in `")
+ (insert (substitute-command-keys " in ‘"))
(help-insert-xref-button (help-fns-short-filename file)
'help-function-def met-name file
'cl-defmethod)
- (insert "'.\n")))
+ (insert (substitute-command-keys "’.\n"))))
(insert "\n" (or (nth 2 info) "Undocumented") "\n\n")))))))
;;; Support for (head <val>) specializers.
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,
(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))
(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)
(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
(list cl--generic-typeof-generalizer)))
(cl-call-next-method)))
+(cl--generic-prefill-dispatchers 0 integer)
+
;; Local variables:
;; generated-autoload-file: "cl-loaddefs.el"
;; End: