From: Stefan Monnier Date: Mon, 13 Dec 2021 16:33:49 +0000 (-0500) Subject: * lisp/emacs-lisp/cl-generic.el: Use OClosure for `cl-next-method-p` X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=f11349ed20c05fbe97db219eecfae0059d7ee4c0;p=emacs.git * lisp/emacs-lisp/cl-generic.el: Use OClosure for `cl-next-method-p` * lisp/emacs-lisp/oclosure.el (oclosure--define): Avoid `cl-lib` at run-time. (oclosure--type-sym): Delete variable. Use an interned symbol instead, so the closures stand a chance of being printable readably. (oclosure--fix-type, oclosure--copy, oclosure-get, oclosure-type): Adjust accordingly. * lisp/emacs-lisp/cl-generic.el (cl--generic-nnm): New OClosure type. (cl--generic-no-next-method-function): Delete function. (cl-generic-call-method): Use it for the default no-next-method case. (cl--generic-nnm-sample, cl--generic-cnm-sample): Delete vars. (cl--generic-isnot-nnm-p): Use `oclosure-type`. --- diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 152a7a2afa0..ecd384d8b0f 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -713,9 +713,8 @@ for all those different tags in the method-cache.") (list (cl--generic-name generic))) f)))) -(defun cl--generic-no-next-method-function (generic method) - (lambda (&rest args) - (apply #'cl-no-next-method generic method args))) +(oclosure-define cl--generic-nnm + "Special type for `call-next-method's that just call `no-next-method'.") (defun cl-generic-call-method (generic method &optional fun) "Return a function that calls METHOD. @@ -723,9 +722,7 @@ FUN is the function that should be called when METHOD calls `call-next-method'." (if (not (cl--generic-method-uses-cnm method)) (cl--generic-method-function method) - (let ((met-fun (cl--generic-method-function method)) - (next (or fun (cl--generic-no-next-method-function - generic method)))) + (let ((met-fun (cl--generic-method-function method))) (lambda (&rest args) (apply met-fun ;; FIXME: This sucks: passing just `next' would @@ -733,8 +730,12 @@ FUN is the function that should be called when METHOD calls ;; quasi-η, but we need this to implement the ;; "if call-next-method is called with no ;; arguments, then use the previous arguments". - (lambda (&rest cnm-args) - (apply next (or cnm-args args))) + (if fun + (lambda (&rest cnm-args) + (apply fun (or cnm-args args))) + (oclosure-make cl--generic-nnm () (&rest cnm-args) + (apply #'cl-no-next-method generic method + (or cnm-args args)))) args))))) ;; Standard CLOS name. @@ -892,36 +893,9 @@ those methods.") "Standard support for :after, :before, :around, and `:extra NAME' qualifiers." (cl--generic-standard-method-combination generic methods)) -(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t)) -(defconst cl--generic-cnm-sample - (funcall (cl--generic-build-combined-method - nil (list (cl--generic-make-method () () t #'identity))))) - (defun cl--generic-isnot-nnm-p (cnm) "Return non-nil if CNM is the function that calls `cl-no-next-method'." - ;; ¡Big Gross Ugly Hack! - ;; `next-method-p' just sucks, we should let it die. But EIEIO did support - ;; it, and some packages use it, so we need to support it. - (catch 'found - (cl-assert (function-equal cnm cl--generic-cnm-sample)) - (if (byte-code-function-p cnm) - (let ((cnm-constants (aref cnm 2)) - (sample-constants (aref cl--generic-cnm-sample 2))) - (dotimes (i (length sample-constants)) - (when (function-equal (aref sample-constants i) - cl--generic-nnm-sample) - (throw 'found - (not (function-equal (aref cnm-constants i) - cl--generic-nnm-sample)))))) - (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample))) - (let ((cnm-env (cadr cnm))) - (dolist (vb (cadr cl--generic-cnm-sample)) - (when (function-equal (cdr vb) cl--generic-nnm-sample) - (throw 'found - (not (function-equal (cdar cnm-env) - cl--generic-nnm-sample)))) - (setq cnm-env (cdr cnm-env))))) - (error "Haven't found no-next-method-sample in cnm-sample"))) + (not (eq (oclosure-type cnm) 'cl--generic-nnm))) ;;; Define some pre-defined generic functions, used internally. diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 524b71a5a47..debb26bc8ad 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -179,11 +179,11 @@ (defun oclosure--define (class pred) (let* ((name (cl--class-name class)) - (predname (intern (format "oclosure--%s-p" name)))) + (predname (intern (format "oclosure--%s-p" name))) + (type `(satisfies ,predname))) (setf (cl--find-class name) class) (defalias predname pred) - ;; Yuck! - (eval `(cl-deftype ,name () '(satisfies ,predname)) t))) + (put name 'cl-deftype-handler (lambda () type)))) (defmacro oclosure-make (type fields args &rest body) (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body))) @@ -226,8 +226,6 @@ (if t nil ,@(mapcar #'car fields)) ,@body)))))) -(defvar oclosure--type-sym (make-symbol ":type")) - (defun oclosure--fix-type (oclosure) (if (byte-code-function-p oclosure) oclosure @@ -239,7 +237,7 @@ ;; marker so we can distinguish this entry from actual variables. (cl-assert (eq 'closure (car-safe oclosure))) (let ((typename (documentation oclosure 'raw))) - (push (cons oclosure--type-sym (intern typename)) + (push (cons :type (intern typename)) (cadr oclosure)) oclosure))) @@ -247,7 +245,7 @@ (if (byte-code-function-p oclosure) (apply #'make-closure oclosure args) (cl-assert (eq 'closure (car-safe oclosure))) - (cl-assert (eq oclosure--type-sym (caar (cadr oclosure)))) + (cl-assert (eq :type (caar (cadr oclosure)))) (let ((env (cadr oclosure))) `(closure (,(car env) @@ -263,7 +261,7 @@ (let ((csts (aref oclosure 2))) (aref csts index)) (cl-assert (eq 'closure (car-safe oclosure))) - (cl-assert (eq oclosure--type-sym (caar (cadr oclosure)))) + (cl-assert (eq :type (caar (cadr oclosure)))) (cdr (nth (1+ index) (cadr oclosure))))) (defun oclosure-type (oclosure) @@ -272,7 +270,7 @@ (let ((type (and (> (length oclosure) 4) (aref oclosure 4)))) (if (symbolp type) type)) (and (eq 'closure (car-safe oclosure)) - (eq oclosure--type-sym (caar (cadr oclosure))) + (eq :type (caar (cadr oclosure))) (cdar (cadr oclosure))))) (provide 'oclosure)