From aa1c4ae271733cf7dc64918b570bab4034488fa1 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 29 Oct 2015 10:33:36 -0400 Subject: [PATCH] * lisp/emacs-lisp/cl-generic.el: Accomodate future changes (cl--generic-generalizer): Add `name' field. (cl-generic-make-generalizer): Add corresponding `name' argument. (cl-generic-define-generalizer): New macro. (cl--generic-head-generalizer, cl--generic-eql-generalizer) (cl--generic-struct-generalizer, cl--generic-typeof-generalizer) (cl--generic-t-generalizer): Use it. (cl-generic-ensure-function): Add `noerror' argument. (cl-generic-define): Use it so we don't follow aliases. (cl-generic-define-method): Preserve pre-existing ordering of methods. (cl--generic-arg-specializer): New function. (cl--generic-cache-miss): Use it. (cl-generic-generalizers): Only fset a temporary definition during bootstrap. (cl--generic-struct-tag, cl--generic-struct-specializers): Allow extra arguments. * lisp/emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-generalizer) (eieio--generic-static-object-generalizer): Use cl-generic-define-generalizer. (eieio--generic-static-symbol-specializers): Allow extra arguments. * lisp/emacs-lisp/eieio-core.el (eieio--generic-generalizer) (eieio--generic-subclass-generalizer): Use cl-generic-define-generalizer. (eieio--generic-subclass-specializers): Allow extra arguments. --- lisp/emacs-lisp/cl-generic.el | 105 ++++++++++++++++++++------------ lisp/emacs-lisp/eieio-compat.el | 42 ++++++------- lisp/emacs-lisp/eieio-core.el | 30 +++++---- 3 files changed, 100 insertions(+), 77 deletions(-) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index dd01ebe9dd8..0d7ef5b2e61 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -80,7 +80,7 @@ ;; 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 @@ -101,14 +101,33 @@ (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) @@ -144,16 +163,18 @@ (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 @@ -220,7 +241,7 @@ BODY, if present, is used as the body of a default method. ;;;###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))) @@ -418,8 +439,12 @@ which case this method will be invoked when the argument is `eql' to VAL. (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 @@ -623,16 +648,19 @@ FUN is the function that should be called when METHOD calls (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)))) @@ -682,10 +710,12 @@ The METHODS list is sorted from most specific first to most generic last. 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." @@ -940,10 +970,9 @@ The value returned is a list of elements of the form (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." @@ -961,10 +990,9 @@ The value returned is a list of elements of the form (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." @@ -976,7 +1004,7 @@ The value returned is a list of elements of the form ;;; 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. @@ -1007,16 +1035,15 @@ The value returned is a list of elements of the form (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." @@ -1056,11 +1083,11 @@ The value returned is a list of elements of the form (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." diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 386ff2f7449..638c475ef2b 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -124,7 +124,7 @@ Summary: (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)) @@ -134,27 +134,25 @@ Summary: (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 diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index e3f7b11bb64..7011a30656b 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -1059,16 +1059,15 @@ method invocation orders of the involved classes." ;;;; 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: @@ -1088,22 +1087,21 @@ method invocation orders of the involved classes." ;; 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)) -;;;### (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" "\ -- 2.39.2