diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-generic.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 122 |
1 files changed, 76 insertions, 46 deletions
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 3bbddfc45a1..8dee9a38ab0 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -98,19 +98,20 @@ They should be sorted from most specific to least specific.") (:constructor cl--generic-make (name &optional dispatches method-table)) (:predicate nil)) - (name nil :read-only t) ;Pointer back to the symbol. + (name nil :type symbol :read-only t) ;Pointer back to the symbol. ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP) ;; where the EXPs are expressions (to be `or'd together) to compute the tag ;; on which to dispatch and PRIORITY is the priority of each expression to ;; decide in which order to sort them. ;; The most important dispatch is last in the list (and the least is first). - dispatches + (dispatches nil :type (list-of (cons natnum (list-of tagcode)))) ;; `method-table' is a list of ;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where ;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method' ;; (and hence expects an extra argument holding the next-method). - method-table) + (method-table nil :type (list-of (cons (cons (list-of type) keyword) + (cons boolean function))))) (defmacro cl--generic (name) `(get ,name 'cl--generic)) @@ -134,15 +135,16 @@ They should be sorted from most specific to least specific.") generic)) (defun cl--generic-setf-rewrite (name) - (let ((setter (intern (format "cl-generic-setter--%s" name)))) - (cons setter - `(eval-and-compile - (unless (eq ',setter (get ',name 'cl-generic-setter)) - ;; (when (get ',name 'gv-expander) - ;; (error "gv-expander conflicts with (setf %S)" ',name)) - (setf (get ',name 'cl-generic-setter) ',setter) - (gv-define-setter ,name (val &rest args) - (cons ',setter (cons val args)))))))) + (let* ((setter (intern (format "cl-generic-setter--%s" name))) + (exp `(unless (eq ',setter (get ',name 'cl-generic-setter)) + ;; (when (get ',name 'gv-expander) + ;; (error "gv-expander conflicts with (setf %S)" ',name)) + (setf (get ',name 'cl-generic-setter) ',setter) + (gv-define-setter ,name (val &rest args) + (cons ',setter (cons val args)))))) + ;; Make sure `setf' can be used right away, e.g. in the body of the method. + (eval exp t) + (cons setter exp))) ;;;###autoload (defmacro cl-defgeneric (name args &rest options-and-methods) @@ -151,8 +153,9 @@ DOC-STRING is the base documentation for this class. A generic function has no body, as its purpose is to decide which method body is appropriate to use. Specific methods are defined with `cl-defmethod'. With this implementation the ARGS are currently ignored. -OPTIONS-AND-METHODS is currently only used to specify the docstring, -via (:documentation DOCSTRING)." +OPTIONS-AND-METHODS currently understands: +- (:documentation DOCSTRING) +- (declare DECLARATIONS)" (declare (indent 2) (doc-string 3)) (let* ((docprop (assq :documentation options-and-methods)) (doc (cond ((stringp (car-safe options-and-methods)) @@ -161,13 +164,26 @@ via (:documentation DOCSTRING)." (prog1 (cadr docprop) (setq options-and-methods - (delq docprop options-and-methods))))))) + (delq docprop options-and-methods)))))) + (declarations (assq 'declare options-and-methods))) + (when declarations + (setq options-and-methods + (delq declarations options-and-methods))) `(progn ,(when (eq 'setf (car-safe name)) (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite (cadr name)))) (setq name setter) code)) + ,@(mapcar (lambda (declaration) + (let ((f (cdr (assq (car declaration) + defun-declarations-alist)))) + (cond + (f (apply (car f) name args (cdr declaration))) + (t (message "Warning: Unknown defun property `%S' in %S" + (car declaration) name) + nil)))) + (cdr declarations)) (defalias ',name (cl-generic-define ',name ',args ',options-and-methods) ,(help-add-fundoc-usage doc args))))) @@ -292,18 +308,19 @@ which case this method will be invoked when the argument is `eql' to VAL. list ; arguments [ &optional stringp ] ; documentation string def-body))) ; part to be debugged - (let ((qualifiers nil)) + (let ((qualifiers nil) + (setfizer (if (eq 'setf (car-safe name)) + ;; Call it before we call cl--generic-lambda. + (cl--generic-setf-rewrite (cadr name))))) (while (keywordp args) (push args qualifiers) (setq args (pop body))) (pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after)))) (`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm))) `(progn - ,(when (eq 'setf (car-safe name)) - (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite - (cadr name)))) - (setq name setter) - code)) + ,(when setfizer + (setq name (car setfizer)) + (cdr setfizer)) ,(and (get name 'byte-obsolete-info) (or (not (fboundp 'byte-compile-warning-enabled-p)) (byte-compile-warning-enabled-p 'obsolete)) @@ -311,6 +328,11 @@ which case this method will be invoked when the argument is `eql' to VAL. (macroexp--warn-and-return (macroexp--obsolete-warning name obsolete "generic function") nil))) + ;; You could argue that `defmethod' modifies rather than defines the + ;; 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 "") (cl-generic-define-method ',name ',qualifiers ',args ,uses-cnm ,fun))))) @@ -344,14 +366,14 @@ which case this method will be invoked when the argument is `eql' to VAL. (if me (setcdr me (cons uses-cnm function)) (setf (cl--generic-method-table generic) (cons `(,key ,uses-cnm . ,function) mt))) - ;; For aliases, cl--generic-name gives us the actual name. + (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) + current-load-list :test #'equal) (let ((gfun (cl--generic-make-function generic)) ;; Prevent `defalias' from recording this as the definition site of ;; the generic function. current-load-list) - (defalias (cl--generic-name generic) gfun)) - (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) - current-load-list :test #'equal))) + ;; For aliases, cl--generic-name gives us the actual name. + (defalias (cl--generic-name generic) gfun)))) (defmacro cl--generic-with-memoization (place &rest code) (declare (indent 1) (debug t)) @@ -448,8 +470,12 @@ for all those different tags in the method-cache.") ;; We don't currently have "method objects" like CLOS ;; does so we can't really do it the CLOS way. ;; The closest would be to pass the lambda corresponding - ;; to the method, but the caller wouldn't be able to do - ;; much with it anyway. So we pass nil for now. + ;; to the method, or maybe the ((SPECIALIZERS + ;; . QUALIFIER) USE-CNM . FUNCTION) entry from the method + ;; table, but the caller wouldn't be able to do much with + ;; it anyway. So we pass nil for now. + ;; FIXME: signal `no-primary-method' if there's + ;; no primary. (apply #'cl-no-next-method generic-name nil args))) ;; We use `cdr' to drop the `uses-cnm' annotations. (before @@ -566,6 +592,24 @@ Can only be used from within the lexical body of a primary or around method." (add-to-list 'find-function-regexp-alist `(cl-defmethod . ,#'cl--generic-search-method))) +(defun cl--generic-method-info (method) + (pcase-let ((`((,specializers . ,qualifier) ,uses-cnm . ,function) method)) + (let* ((args (help-function-arglist function 'names)) + (docstring (documentation function)) + (doconly (if docstring + (let ((split (help-split-fundoc docstring nil))) + (if split (cdr split) docstring)))) + (combined-args ())) + (if uses-cnm (setq args (cdr args))) + (dolist (specializer specializers) + (let ((arg (if (eq '&rest (car args)) + (intern (format "arg%d" (length combined-args))) + (pop args)))) + (push (if (eq specializer t) arg (list arg specializer)) + combined-args))) + (setq combined-args (append (nreverse combined-args) args)) + (list qualifier combined-args doconly)))) + (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) (defun cl--generic-describe (function) (let ((generic (if (symbolp function) (cl--generic function)))) @@ -575,25 +619,11 @@ Can only be used from within the lexical body of a primary or around method." (insert "\n\nThis is a generic function.\n\n") (insert (propertize "Implementations:\n\n" 'face 'bold)) ;; Loop over fanciful generics - (pcase-dolist (`((,specializers . ,qualifier) ,uses-cnm . ,method) - (cl--generic-method-table generic)) - (let* ((args (help-function-arglist method 'names)) - (docstring (documentation method)) - (doconly (if docstring - (let ((split (help-split-fundoc docstring nil))) - (if split (cdr split) docstring)))) - (combined-args ())) - (if uses-cnm (setq args (cdr args))) - (dolist (specializer specializers) - (let ((arg (if (eq '&rest (car args)) - (intern (format "arg%d" (length combined-args))) - (pop args)))) - (push (if (eq specializer t) arg (list arg specializer)) - combined-args))) - (setq combined-args (append (nreverse combined-args) args)) + (dolist (method (cl--generic-method-table generic)) + (let* ((info (cl--generic-method-info method))) ;; FIXME: Add hyperlinks for the types as well. - (insert (format "%S %S" qualifier combined-args)) - (let* ((met-name (cons function specializers)) + (insert (format "%S %S" (nth 0 info) (nth 1 info))) + (let* ((met-name (cons function (caar method))) (file (find-lisp-object-file-name met-name 'cl-defmethod))) (when file (insert " in `") @@ -601,7 +631,7 @@ Can only be used from within the lexical body of a primary or around method." 'help-function-def met-name file 'cl-defmethod) (insert "'.\n"))) - (insert "\n" (or doconly "Undocumented") "\n\n"))))))) + (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) ;;; Support for (eql <val>) specializers. |