mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-09-01 17:31:53 +00:00
5beb56fb53
Not sure why earlier tests did not catch it, but there are more places where we bump into problems because `eieio--class-precedence-list` now returns also non-EIEIO classes. * lisp/obsolete/eieio-compat.el (eieio--generic-static-object-generalizer): * lisp/emacs-lisp/eieio-core.el (eieio--generic-generalizer) (eieio--generic-subclass-specializers): Handle non-EIEIO parents. * test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el (eieio-test-method-order-list-7): Adjust test.
257 lines
11 KiB
EmacsLisp
257 lines
11 KiB
EmacsLisp
;;; eieio-compat.el --- Compatibility with Older EIEIO versions -*- lexical-binding:t -*-
|
|
|
|
;; Copyright (C) 1995-1996, 1998-2024 Free Software Foundation, Inc.
|
|
|
|
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
|
;; Keywords: OO, lisp
|
|
;; Package: eieio
|
|
;; Obsolete-since: 29.1
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Backward compatibility definition of old EIEIO functions in
|
|
;; terms of newer equivalent.
|
|
|
|
;; The main elements are the old EIEIO `defmethod' and `defgeneric' which are
|
|
;; now implemented on top of cl-generic. The differences we have to
|
|
;; accommodate are:
|
|
;; - EIEIO's :static methods (turned into a new `eieio--static' specializer).
|
|
;; - EIEIO's support for `call-next-method' and `next-method-p' instead of
|
|
;; `cl-next-method-p' and `cl-call-next-method' (simple matter of renaming).
|
|
;; - Different errors are signaled.
|
|
;; - EIEIO's defgeneric does not reset the function.
|
|
;; - EIEIO's no-next-method and no-applicable-method can't be aliases of
|
|
;; cl-generic's namesakes since they have different calling conventions,
|
|
;; which means that packages that (defmethod no-next-method ..) don't work.
|
|
;; - EIEIO's `call-next-method' and `next-method-p' had dynamic scope whereas
|
|
;; cl-generic's `cl-next-method-p' and `cl-call-next-method' are lexically
|
|
;; scoped.
|
|
|
|
;;; Code:
|
|
|
|
(require 'eieio-core)
|
|
(require 'cl-generic)
|
|
|
|
(put 'eieio--defalias 'byte-hunk-handler
|
|
#'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
|
|
;;;###autoload
|
|
(defun eieio--defalias (name body)
|
|
"Like `defalias', but with less side-effects.
|
|
More specifically, it has no side-effects at all when the new function
|
|
definition is the same (`eq') as the old one."
|
|
(cl-assert (not (symbolp body)))
|
|
(while (and (fboundp name) (symbolp (symbol-function name)))
|
|
;; Follow aliases, so methods applied to obsolete aliases still work.
|
|
(setq name (symbol-function name)))
|
|
(unless (and (fboundp name)
|
|
(eq (symbol-function name) body))
|
|
(defalias name body)))
|
|
|
|
;;;###autoload
|
|
(defmacro defgeneric (method args &optional doc-string)
|
|
"Create a generic function METHOD.
|
|
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. Uses `defmethod' to create methods, and calls
|
|
`defgeneric' for you. With this implementation the ARGS are
|
|
currently ignored. You can use `defgeneric' to apply specialized
|
|
top level documentation to a method."
|
|
(declare (doc-string 3) (obsolete cl-defgeneric "25.1")
|
|
(indent defun))
|
|
`(eieio--defalias ',method
|
|
(eieio--defgeneric-init-form
|
|
',method
|
|
,(if doc-string (help-add-fundoc-usage doc-string args)))))
|
|
|
|
;;;###autoload
|
|
(defmacro defmethod (method &rest args)
|
|
"Create a new METHOD through `defgeneric' with ARGS.
|
|
|
|
The optional second argument KEY is a specifier that
|
|
modifies how the method is called, including:
|
|
:before - Method will be called before the :primary
|
|
:primary - The default if not specified
|
|
:after - Method will be called after the :primary
|
|
:static - First arg could be an object or class
|
|
The next argument is the ARGLIST. The ARGLIST specifies the arguments
|
|
to the method as with `defun'. The first argument can have a type
|
|
specifier, such as:
|
|
((VARNAME CLASS) ARG2 ...)
|
|
where VARNAME is the name of the local variable for the method being
|
|
created. The CLASS is a class symbol for a class made with `defclass'.
|
|
A DOCSTRING comes after the ARGLIST, and is optional.
|
|
All the rest of the args are the BODY of the method. A method will
|
|
return the value of the last form in the BODY.
|
|
|
|
Summary:
|
|
|
|
(defmethod mymethod [:before | :primary | :after | :static]
|
|
((typearg class-name) arg2 &optional opt &rest rest)
|
|
\"doc-string\"
|
|
body)"
|
|
(declare (doc-string 3) (obsolete cl-defmethod "25.1")
|
|
(indent defun)
|
|
(debug
|
|
(&define ; this means we are defining something
|
|
[&name sexp] ;Allow (setf ...) additionally to symbols.
|
|
;; ^^ This is the methods symbol
|
|
[ &optional symbolp ] ; this is key :before etc
|
|
cl-generic-method-args ; arguments
|
|
[ &optional stringp ] ; documentation string
|
|
def-body ; part to be debugged
|
|
)))
|
|
(let* ((key (if (keywordp (car args)) (pop args)))
|
|
(params (car args))
|
|
(arg1 (car params))
|
|
(fargs (if (consp arg1)
|
|
(cons (car arg1) (cdr params))
|
|
params))
|
|
(class (if (consp arg1) (nth 1 arg1)))
|
|
(code `(lambda ,fargs ,@(cdr args))))
|
|
`(progn
|
|
;; Make sure there is a generic and the byte-compiler sees it.
|
|
(defgeneric ,method ,args)
|
|
(eieio--defmethod ',method ',key ',class #',code))))
|
|
|
|
(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))
|
|
(specializers ()))
|
|
(dolist (superclass superclasses)
|
|
(push superclass specializers)
|
|
(push `(eieio--static ,(cadr 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 &rest _)
|
|
(and (symbolp tag) (setq tag (cl--find-class tag))
|
|
(eieio--class-p tag)
|
|
(let ((superclasses (cl--class-allparents tag))
|
|
(specializers ()))
|
|
(dolist (superclass superclasses)
|
|
(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
|
|
eieio--generic-static-object-generalizer))
|
|
|
|
;;;###autoload
|
|
(defun eieio--defgeneric-init-form (method doc-string)
|
|
(if doc-string (put method 'function-documentation doc-string))
|
|
(if (memq method '(no-next-method no-applicable-method))
|
|
(symbol-function method)
|
|
(let ((generic (cl-generic-ensure-function method)))
|
|
(or (symbol-function (cl--generic-name generic))
|
|
(cl--generic-make-function generic)))))
|
|
|
|
;;;###autoload
|
|
(defun eieio--defmethod (method kind argclass code)
|
|
(setq kind (intern (downcase (symbol-name kind))))
|
|
(let* ((specializer (if (not (eq kind :static))
|
|
(or argclass t)
|
|
(setq kind nil)
|
|
`(eieio--static ,argclass)))
|
|
(uses-cnm (not (memq kind '(:before :after))))
|
|
(specializers `((arg ,specializer)))
|
|
(code
|
|
;; Backward compatibility for `no-next-method' and
|
|
;; `no-applicable-method', which have slightly different calling
|
|
;; convention than their cl-generic counterpart.
|
|
(pcase method
|
|
('no-next-method
|
|
(setq method 'cl-no-next-method)
|
|
(setq specializers `(generic method ,@specializers))
|
|
(lambda (_generic _method &rest args) (apply code args)))
|
|
('no-applicable-method
|
|
(setq method 'cl-no-applicable-method)
|
|
(setq specializers `(generic ,@specializers))
|
|
(lambda (generic arg &rest args)
|
|
(apply code arg (cl--generic-name generic) (cons arg args))))
|
|
(_ code))))
|
|
(cl-generic-define-method
|
|
method (unless (memq kind '(nil :primary)) (list kind))
|
|
specializers uses-cnm
|
|
(if uses-cnm
|
|
(let* ((docstring (documentation code 'raw))
|
|
(args (help-function-arglist code 'preserve-names))
|
|
(doc-only (if docstring
|
|
(let ((split (help-split-fundoc docstring nil)))
|
|
(if split (cdr split) docstring)))))
|
|
(lambda (cnm &rest args)
|
|
(:documentation
|
|
(help-add-fundoc-usage doc-only (cons 'cl-cnm args)))
|
|
(cl-letf (((symbol-function 'call-next-method) cnm)
|
|
((symbol-function 'next-method-p)
|
|
(lambda () (cl--generic-isnot-nnm-p cnm))))
|
|
(apply code args))))
|
|
code))
|
|
;; The old EIEIO code did not signal an error when there are methods
|
|
;; applicable but only of the before/after kind. So if we add a :before
|
|
;; or :after, make sure there's a matching dummy primary.
|
|
(when (and (memq kind '(:before :after))
|
|
;; FIXME: Use `cl-find-method'?
|
|
(not (cl-find-method method ()
|
|
(mapcar (lambda (arg)
|
|
(if (consp arg) (nth 1 arg) t))
|
|
specializers))))
|
|
(cl-generic-define-method method () specializers t
|
|
(lambda (cnm &rest args)
|
|
(if (cl--generic-isnot-nnm-p cnm)
|
|
(apply cnm args)))))
|
|
method))
|
|
|
|
;; Compatibility with code which tries to catch `no-method-definition' errors.
|
|
(push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions))
|
|
|
|
(defun generic-p (fname) (not (null (cl--generic fname))))
|
|
|
|
(defun no-next-method (&rest args)
|
|
(declare (obsolete cl-no-next-method "25.1"))
|
|
(apply #'cl-no-next-method 'unknown nil args))
|
|
|
|
(defun no-applicable-method (object method &rest args)
|
|
(declare (obsolete cl-no-applicable-method "25.1"))
|
|
(apply #'cl-no-applicable-method method object args))
|
|
|
|
(define-obsolete-function-alias 'call-next-method #'cl-call-next-method "25.1")
|
|
(defun next-method-p ()
|
|
(declare (obsolete cl-next-method-p "25.1"))
|
|
;; EIEIO's `next-method-p' just returned nil when called in an
|
|
;; invalid context.
|
|
(message "next-method-p called outside of a primary or around method")
|
|
nil)
|
|
|
|
;;;###autoload
|
|
(defun eieio-defclass (cname superclasses slots options)
|
|
(declare (obsolete eieio-defclass-internal "25.1"))
|
|
(eval `(defclass ,cname ,superclasses ,slots ,@options)))
|
|
|
|
(provide 'eieio-compat)
|
|
|
|
;;; eieio-compat.el ends here
|