diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-generic.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 174 |
1 files changed, 128 insertions, 46 deletions
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 619428d46bd..9e6102c7300 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))) @@ -245,6 +266,15 @@ BODY, if present, is used as the body of a default method. This macro can only be used within the lexical scope of a cl-generic method." (error "cl-generic-current-method-specializers used outside of a method")) +(defmacro cl-generic-define-context-rewriter (name args &rest body) + "Define a special kind of context named NAME. +Whenever a context specializer of the form (NAME . ARGS) appears, +the specializer used will be the one returned by BODY." + (declare (debug (&define name lambda-list def-body)) (indent defun)) + `(eval-and-compile + (put ',name 'cl-generic--context-rewriter + (lambda ,args ,@body)))) + (eval-and-compile ;Needed while compiling the cl-defmethod calls below! (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el. "Check which of the symbols VARS appear in SEXP." @@ -271,6 +301,11 @@ This macro can only be used within the lexical scope of a cl-generic method." ((let 'context mandatory) (unless (consp arg) (error "Invalid &context arg: %S" arg)) + (let* ((name (car arg)) + (rewriter + (and (symbolp name) + (get name 'cl-generic--context-rewriter)))) + (if rewriter (setq arg (apply rewriter (cdr arg))))) (push `((&context . ,(car arg)) . ,(cadr arg)) specializers) nil) (`(,name . ,type) @@ -418,8 +453,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 +662,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 +724,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." @@ -791,6 +835,8 @@ Can only be used from within the lexical body of a primary or around method." ;;; Add support for describe-function (defun cl--generic-search-method (met-name) + "For `find-function-regexp-alist'. Searches for a cl-defmethod. +MET-NAME is a cons (SYMBOL . SPECIALIZERS)." (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+" (regexp-quote (format "%s" (car met-name))) "\\_>"))) @@ -806,11 +852,15 @@ Can only be used from within the lexical body of a primary or around method." nil t) (re-search-forward base-re nil t)))) +;; WORKAROUND: This can't be a defconst due to bug#21237. +(defvar cl--generic-find-defgeneric-regexp "(\\(?:cl-\\)?defgeneric[ \t]+%s\\>") (with-eval-after-load 'find-func (defvar find-function-regexp-alist) (add-to-list 'find-function-regexp-alist - `(cl-defmethod . ,#'cl--generic-search-method))) + `(cl-defmethod . ,#'cl--generic-search-method)) + (add-to-list 'find-function-regexp-alist + `(cl-defgeneric . cl--generic-find-defgeneric-regexp))) (defun cl--generic-method-info (method) (let* ((specializers (cl--generic-method-specializers method)) @@ -858,11 +908,11 @@ Can only be used from within the lexical body of a primary or around method." (cl--generic-method-specializers method))) (file (find-lisp-object-file-name met-name 'cl-defmethod))) (when file - (insert (substitute-command-keys " in ‘")) + (insert (substitute-command-keys " in `")) (help-insert-xref-button (help-fns-short-filename file) 'help-function-def met-name file 'cl-defmethod) - (insert (substitute-command-keys "’.\n")))) + (insert (substitute-command-keys "'.\n")))) (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) (defun cl--generic-specializers-apply-to-type-p (specializers type) @@ -934,10 +984,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." @@ -955,10 +1004,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." @@ -970,7 +1018,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. @@ -986,8 +1034,9 @@ The value returned is a list of elements of the form `(and (vectorp ,name) (> (length ,name) 0) (let ((tag (aref ,name 0))) - (if (eq (symbol-function tag) :quick-object-witness-check) - tag)))) + (and (symbolp tag) + (eq (symbol-function tag) :quick-object-witness-check) + tag)))) (defun cl--generic-class-parents (class) (let ((parents ()) @@ -1000,16 +1049,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." @@ -1049,11 +1097,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." @@ -1062,13 +1110,47 @@ The value returned is a list of elements of the form (or (and (assq type cl--generic-typeof-types) (progn - (if (memq type '(vector array sequence)) - (message "`%S' also matches CL structs and EIEIO classes" type)) + ;; FIXME: While this wrinkle in the semantics can be occasionally + ;; problematic, this warning is more often annoying than helpful. + ;;(if (memq type '(vector array sequence)) + ;; (message "`%S' also matches CL structs and EIEIO classes" + ;; type)) (list cl--generic-typeof-generalizer))) (cl-call-next-method))) (cl--generic-prefill-dispatchers 0 integer) +;;; Dispatch on major mode. + +;; Two parts: +;; - first define a specializer (derived-mode <mode>) to match symbols +;; representing major modes, while obeying the major mode hierarchy. +;; - then define a context-rewriter so you can write +;; "&context (major-mode c-mode)" rather than +;; "&context (major-mode (derived-mode c-mode))". + +(defun cl--generic-derived-specializers (mode &rest _) + ;; FIXME: Handle (derived-mode <mode1> ... <modeN>) + (let ((specializers ())) + (while mode + (push `(derived-mode ,mode) specializers) + (setq mode (get mode 'derived-mode-parent))) + (nreverse specializers))) + +(cl-generic-define-generalizer cl--generic-derived-generalizer + 90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name)) + #'cl--generic-derived-specializers) + +(cl-defmethod cl-generic-generalizers ((_specializer (head derived-mode))) + "Support for the `(derived-mode MODE)' specializers." + (list cl--generic-derived-generalizer)) + +(cl-generic-define-context-rewriter major-mode (mode &rest modes) + `(major-mode ,(if (consp mode) + ;;E.g. could be (eql ...) + (progn (cl-assert (null modes)) mode) + `(derived-mode ,mode . ,modes)))) + ;; Local variables: ;; generated-autoload-file: "cl-loaddefs.el" ;; End: |