;; TODO:
;;
-;; - A generic "filter" generalizer (e.g. could be used to cleanly adds methods
+;; - A generic "filter" generalizer (e.g. could be used to cleanly add methods
;; to cl-generic-combine-methods with a specializer that says it applies only
;; when some particular qualifier is used).
;; - A way to dispatch on the context (e.g. the major-mode, some global
(cl-defstruct (cl--generic-generalizer
(:constructor nil)
(:constructor cl-generic-make-generalizer
- (priority tagcode-function specializers-function)))
+ (name priority tagcode-function specializers-function)))
+ (name nil :type string)
(priority nil :type integer)
tagcode-function
specializers-function)
-(defconst cl--generic-t-generalizer
- (cl-generic-make-generalizer
- 0 (lambda (_name) nil) (lambda (_tag) '(t))))
+
+(defmacro cl-generic-define-generalizer
+ (name priority tagcode-function specializers-function)
+ "Define a new kind of generalizer.
+NAME is the name of the variable that will hold it.
+PRIORITY defines which generalizer takes precedence.
+ The catch-all generalizer has priority 0.
+ Then `eql' generalizer has priority 100.
+TAGCODE-FUNCTION takes as first argument a varname and should return
+ a chunk of code that computes the tag of the value held in that variable.
+ Further arguments are reserved for future use.
+SPECIALIZERS-FUNCTION takes as first argument a tag value TAG
+ and should return a list of specializers that match TAG.
+ Further arguments are reserved for future use."
+ (declare (indent 1) (debug (symbolp body)))
+ `(defconst ,name
+ (cl-generic-make-generalizer
+ ',name ,priority ,tagcode-function ,specializers-function)))
+
+(cl-generic-define-generalizer cl--generic-t-generalizer
+ 0 (lambda (_name &rest _) nil) (lambda (_tag &rest _) '(t)))
(cl-defstruct (cl--generic-method
(:constructor nil)
(defmacro cl--generic (name)
`(get ,name 'cl--generic))
-(defun cl-generic-ensure-function (name)
+(defun cl-generic-ensure-function (name &optional noerror)
(let (generic
(origname name))
(while (and (null (setq generic (cl--generic name)))
(fboundp name)
+ (null noerror)
(symbolp (symbol-function name)))
(setq name (symbol-function name)))
(unless (or (not (fboundp name))
(autoloadp (symbol-function name))
- (and (functionp name) generic))
+ (and (functionp name) generic)
+ noerror)
(error "%s is already defined as something else than a generic function"
origname))
(if generic
;;;###autoload
(defun cl-generic-define (name args options)
- (pcase-let* ((generic (cl-generic-ensure-function name))
+ (pcase-let* ((generic (cl-generic-ensure-function name 'noerror))
(`(,spec-args . ,_) (cl--generic-split-args args))
(mandatory (mapcar #'car spec-args))
(apo (assq :argument-precedence-order options)))
(setq i (1+ i))))
;; 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)))
+ ;; See also the related FIXME in cl--generic-build-combined-method.
+ (setf (cl--generic-method-table generic)
+ (if (null me)
+ (cons method mt)
+ ;; Keep the ordering; important for methods with :extra qualifiers.
+ (mapcar (lambda (x) (if (eq x (car me)) method x)) 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
(setq fun (cl-generic-call-method generic method fun)))
fun)))))
+(defun cl--generic-arg-specializer (method dispatch-arg)
+ (or (if (integerp dispatch-arg)
+ (nth dispatch-arg
+ (cl--generic-method-specializers method))
+ (cdr (assoc dispatch-arg
+ (cl--generic-method-specializers method))))
+ t))
+
(defun cl--generic-cache-miss (generic
dispatch-arg dispatches-left methods-left types)
(let ((methods '()))
(dolist (method methods-left)
- (let* ((specializer (or (if (integerp dispatch-arg)
- (nth dispatch-arg
- (cl--generic-method-specializers method))
- (cdr (assoc dispatch-arg
- (cl--generic-method-specializers method))))
- t))
+ (let* ((specializer (cl--generic-arg-specializer method dispatch-arg))
(m (member specializer types)))
(when m
(push (cons (length m) method) methods))))
The function can use `cl-generic-call-method' to create functions that call those
methods.")
-;; Temporary definition to let the next defmethod succeed.
-(fset 'cl-generic-generalizers
- (lambda (_specializer) (list cl--generic-t-generalizer)))
-(fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination)
+(unless (ignore-errors (cl-generic-generalizers t))
+ ;; Temporary definition to let the next defmethod succeed.
+ (fset 'cl-generic-generalizers
+ (lambda (specializer)
+ (if (eq t specializer) (list cl--generic-t-generalizer))))
+ (fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination))
(cl-defmethod cl-generic-generalizers (specializer)
"Support for the catch-all t specializer."
(defvar cl--generic-head-used (make-hash-table :test #'eql))
-(defconst cl--generic-head-generalizer
- (cl-generic-make-generalizer
- 80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used))
- (lambda (tag) (if (eq (car-safe tag) 'head) (list tag)))))
+(cl-generic-define-generalizer cl--generic-head-generalizer
+ 80 (lambda (name &rest _) `(gethash (car-safe ,name) cl--generic-head-used))
+ (lambda (tag &rest _) (if (eq (car-safe tag) 'head) (list tag))))
(cl-defmethod cl-generic-generalizers :extra "head" (specializer)
"Support for the `(head VAL)' specializers."
(defvar cl--generic-eql-used (make-hash-table :test #'eql))
-(defconst cl--generic-eql-generalizer
- (cl-generic-make-generalizer
- 100 (lambda (name) `(gethash ,name cl--generic-eql-used))
- (lambda (tag) (if (eq (car-safe tag) 'eql) (list tag)))))
+(cl-generic-define-generalizer cl--generic-eql-generalizer
+ 100 (lambda (name &rest _) `(gethash ,name cl--generic-eql-used))
+ (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (list tag))))
(cl-defmethod cl-generic-generalizers ((specializer (head eql)))
"Support for the `(eql VAL)' specializers."
;;; Support for cl-defstructs specializers.
-(defun cl--generic-struct-tag (name)
+(defun cl--generic-struct-tag (name &rest _)
;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
;; but that would suffer from some problems:
;; - the vector may have size 0.
(cl--class-parents class)))))
(nreverse parents)))
-(defun cl--generic-struct-specializers (tag)
+(defun cl--generic-struct-specializers (tag &rest _)
(and (symbolp tag) (boundp tag)
(let ((class (symbol-value tag)))
(when (cl-typep class 'cl-structure-class)
(cl--generic-class-parents class)))))
-(defconst cl--generic-struct-generalizer
- (cl-generic-make-generalizer
- 50 #'cl--generic-struct-tag
- #'cl--generic-struct-specializers))
+(cl-generic-define-generalizer cl--generic-struct-generalizer
+ 50 #'cl--generic-struct-tag
+ #'cl--generic-struct-specializers)
(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
"Support for dispatch on cl-struct types."
(sequence)
(number)))
-(defconst cl--generic-typeof-generalizer
- (cl-generic-make-generalizer
- ;; FIXME: We could also change `type-of' to return `null' for nil.
- 10 (lambda (name) `(if ,name (type-of ,name) 'null))
- (lambda (tag) (and (symbolp tag) (assq tag cl--generic-typeof-types)))))
+(cl-generic-define-generalizer cl--generic-typeof-generalizer
+ ;; FIXME: We could also change `type-of' to return `null' for nil.
+ 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null))
+ (lambda (tag &rest _)
+ (and (symbolp tag) (assq tag cl--generic-typeof-types))))
(cl-defmethod cl-generic-generalizers :extra "typeof" (type)
"Support for dispatch on builtin types."
(defgeneric ,method ,args)
(eieio--defmethod ',method ',key ',class #',code))))
-(defun eieio--generic-static-symbol-specializers (tag)
+(defun eieio--generic-static-symbol-specializers (tag &rest _)
(cl-assert (or (null tag) (eieio--class-p tag)))
(when (eieio--class-p tag)
(let ((superclasses (eieio--generic-subclass-specializers tag))
(push `(eieio--static ,(cadr superclass)) specializers))
(nreverse specializers))))
-(defconst eieio--generic-static-symbol-generalizer
- (cl-generic-make-generalizer
- ;; Give it a slightly higher priority than `subclass' so that the
- ;; interleaved list comes before subclass's non-interleaved list.
- 61 (lambda (name) `(and (symbolp ,name) (cl--find-class ,name)))
- #'eieio--generic-static-symbol-specializers))
-(defconst eieio--generic-static-object-generalizer
- (cl-generic-make-generalizer
- ;; Give it a slightly higher priority than `class' so that the
- ;; interleaved list comes before the class's non-interleaved list.
- 51 #'cl--generic-struct-tag
- (lambda (tag)
- (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag))
- (eieio--class-p tag)
- (let ((superclasses (eieio--class-precedence-list tag))
- (specializers ()))
- (dolist (superclass superclasses)
- (setq superclass (eieio--class-name superclass))
- (push superclass specializers)
- (push `(eieio--static ,superclass) specializers))
- (nreverse specializers))))))
+(cl-generic-define-generalizer eieio--generic-static-symbol-generalizer
+ ;; Give it a slightly higher priority than `subclass' so that the
+ ;; interleaved list comes before subclass's non-interleaved list.
+ 61 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name)))
+ #'eieio--generic-static-symbol-specializers)
+(cl-generic-define-generalizer eieio--generic-static-object-generalizer
+ ;; Give it a slightly higher priority than `class' so that the
+ ;; interleaved list comes before the class's non-interleaved list.
+ 51 #'cl--generic-struct-tag
+ (lambda (tag _targets)
+ (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag))
+ (eieio--class-p tag)
+ (let ((superclasses (eieio--class-precedence-list tag))
+ (specializers ()))
+ (dolist (superclass superclasses)
+ (setq superclass (eieio--class-name superclass))
+ (push superclass specializers)
+ (push `(eieio--static ,superclass) specializers))
+ (nreverse specializers)))))
(cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static)))
(list eieio--generic-static-symbol-generalizer
;;;; General support to dispatch based on the type of the argument.
-(defconst eieio--generic-generalizer
- (cl-generic-make-generalizer
- ;; Use the exact same tagcode as for cl-struct, so that methods
- ;; that dispatch on both kinds of objects get to share this
- ;; part of the dispatch code.
- 50 #'cl--generic-struct-tag
- (lambda (tag)
- (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))
- (mapcar #'eieio--class-name
- (eieio--class-precedence-list (symbol-value tag)))))))
+(cl-generic-define-generalizer eieio--generic-generalizer
+ ;; Use the exact same tagcode as for cl-struct, so that methods
+ ;; that dispatch on both kinds of objects get to share this
+ ;; part of the dispatch code.
+ 50 #'cl--generic-struct-tag
+ (lambda (tag &rest _)
+ (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))
+ (mapcar #'eieio--class-name
+ (eieio--class-precedence-list (symbol-value tag))))))
(cl-defmethod cl-generic-generalizers :extra "class" (specializer)
;; CLHS says:
;; would not make much sense (e.g. to which argument should it apply?).
;; Instead, we add a new "subclass" specializer.
-(defun eieio--generic-subclass-specializers (tag)
+(defun eieio--generic-subclass-specializers (tag &rest _)
(when (eieio--class-p tag)
(mapcar (lambda (class)
`(subclass ,(eieio--class-name class)))
(eieio--class-precedence-list tag))))
-(defconst eieio--generic-subclass-generalizer
- (cl-generic-make-generalizer
- 60 (lambda (name) `(and (symbolp ,name) (cl--find-class ,name)))
- #'eieio--generic-subclass-specializers))
+(cl-generic-define-generalizer eieio--generic-subclass-generalizer
+ 60 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name)))
+ #'eieio--generic-subclass-specializers)
(cl-defmethod cl-generic-generalizers ((_specializer (head subclass)))
(list eieio--generic-subclass-generalizer))
\f
-;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "ea8c7f24ed47c6b71ac37cbdae1c9931")
+;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "bd51800d7de6429a2c9a6a600ba2dc52")
;;; Generated autoloads from eieio-compat.el
(autoload 'eieio--defalias "eieio-compat" "\
projects / emacs.git / commitdiff