X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/6afef3f6ca2f3009c722b84e249903b7f807b044..05d76dba6604f78e4b2b7b9f8b30c916cad7d32a:/lisp/emacs-lisp/cl-generic.el diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index c012a30a41..0144daf379 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1,6 +1,6 @@ ;;; cl-generic.el --- CLOS-style generic functions for Elisp -*- lexical-binding: t; -*- -;; Copyright (C) 2015 Free Software Foundation, Inc. +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ;; Author: Stefan Monnier ;; Version: 1.0 @@ -80,11 +80,9 @@ ;; 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 -;; variable, you name it). ;;; Code: @@ -101,14 +99,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 +161,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 @@ -174,9 +193,9 @@ OPTIONS-AND-METHODS currently understands: - (declare DECLARATIONS) - (:argument-precedence-order &rest ARGS) - (:method [QUALIFIERS...] ARGS &rest BODY) -BODY, if present, is used as the body of a default method. +DEFAULT-BODY, if present, is used as the body of a default method. -\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest BODY)" +\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)" (declare (indent 2) (doc-string 3)) (let* ((doc (if (stringp (car-safe options-and-methods)) (pop options-and-methods))) @@ -220,7 +239,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 +264,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 +299,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) @@ -325,10 +358,10 @@ This macro can only be used within the lexical scope of a cl-generic method." (defmacro cl-defmethod (name args &rest body) "Define a new method for generic function NAME. I.e. it defines the implementation of NAME to use for invocations where the -value of the dispatch argument matches the specified TYPE. -The dispatch argument has to be one of the mandatory arguments, and -all methods of NAME have to use the same argument for dispatch. -The dispatch argument and TYPE are specified in ARGS where the corresponding +values of the dispatch arguments match the specified TYPEs. +The dispatch arguments have to be among the mandatory arguments, and +all methods of NAME have to use the same set of arguments for dispatch. +Each dispatch argument and TYPE are specified in ARGS where the corresponding formal argument appears as (VAR TYPE) rather than just VAR. The optional second argument QUALIFIER is a specifier that @@ -338,8 +371,14 @@ modifies how the method is combined with other methods, including: :around - Method will be called around everything else The absence of QUALIFIER means this is a \"primary\" method. -Other than a type, TYPE can also be of the form `(eql VAL)' in -which case this method will be invoked when the argument is `eql' to VAL. +TYPE can be one of the basic types (see the full list and their +hierarchy in `cl--generic-typeof-types'), CL struct type, or an +EIEIO class. + +Other than that, TYPE can also be of the form `(eql VAL)' in +which case this method will be invoked when the argument is `eql' +to VAL, or `(head VAL)', in which case the argument is required +to be a cons with VAL as its head. \(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" (declare (doc-string 3) (indent 2) @@ -371,7 +410,8 @@ which case this method will be invoked when the argument is `eql' to VAL. ;; function, so warnings like "not known to be defined" are fair game. ;; But in practice, it's common to use `cl-defmethod' ;; without a previous `cl-defgeneric'. - (declare-function ,name "") + ;; The ",'" is a no-op that pacifies check-declare. + (,'declare-function ,name "") (cl-generic-define-method ',name ',(nreverse qualifiers) ',args ,uses-cnm ,fun))))) @@ -418,8 +458,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 +667,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 +729,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." @@ -753,10 +802,10 @@ methods.") ;;; Define some pre-defined generic functions, used internally. -(define-error 'cl-no-method "No method for %S") -(define-error 'cl-no-next-method "No next method for %S" 'cl-no-method) -(define-error 'cl-no-primary-method "No primary method for %S" 'cl-no-method) -(define-error 'cl-no-applicable-method "No applicable method for %S" +(define-error 'cl-no-method "No method") +(define-error 'cl-no-next-method "No next method" 'cl-no-method) +(define-error 'cl-no-primary-method "No primary method" 'cl-no-method) +(define-error 'cl-no-applicable-method "No applicable method" 'cl-no-method) (cl-defgeneric cl-no-next-method (generic method &rest args) @@ -889,7 +938,7 @@ MET-NAME is a cons (SYMBOL . SPECIALIZERS)." (setq applies t))) applies)) -(defun cl--generic-all-functions (&optional type) +(defun cl-generic-all-functions (&optional type) "Return a list of all generic functions. Optional TYPE argument returns only those functions that contain methods for TYPE." @@ -940,10 +989,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 +1009,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." @@ -973,10 +1020,14 @@ The value returned is a list of elements of the form (cl--generic-prefill-dispatchers 0 (eql nil)) (cl--generic-prefill-dispatchers window-system (eql nil)) +(cl--generic-prefill-dispatchers (terminal-parameter nil 'xterm--get-selection) + (eql nil)) +(cl--generic-prefill-dispatchers (terminal-parameter nil 'xterm--set-selection) + (eql nil)) ;;; 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 +1058,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 +1106,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." @@ -1069,13 +1119,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 ) 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 ... ) + (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: