From: Stefan Monnier Date: Mon, 13 Dec 2021 16:33:49 +0000 (-0500) Subject: * lisp/emacs-lisp/cl-generic.el: Use FCR for `cl-next-method-p` X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=a3640a88f0159f1f5dbe868b0449982fb90cbb2b;p=emacs.git * lisp/emacs-lisp/cl-generic.el: Use FCR for `cl-next-method-p` * lisp/emacs-lisp/fcr.el (fcr--define): Avoid `cl-lib` at run-time. (fcr--type-sym): Delete variable. Use an interned symbol instead, so the closures stand a chance of being printable readably. (fcr--fix-type, fcr--copy, fcr-get, fcr-type): Adjust accordingly. * lisp/emacs-lisp/cl-generic.el (cl--generic-nnm): New FCR 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 `fcr-type`. --- diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index ad2bdc0cde2..fa7f736fe49 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))) +(fcr-defstruct 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))) + (fcr-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 (fcr-type cnm) 'cl--generic-nnm))) ;;; Define some pre-defined generic functions, used internally. diff --git a/lisp/emacs-lisp/fcr.el b/lisp/emacs-lisp/fcr.el index 51fc2402ac7..112fdbdf574 100644 --- a/lisp/emacs-lisp/fcr.el +++ b/lisp/emacs-lisp/fcr.el @@ -179,11 +179,11 @@ (defun fcr--define (class pred) (let* ((name (cl--class-name class)) - (predname (intern (format "fcr--%s-p" name)))) + (predname (intern (format "fcr--%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 fcr-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 fcr--type-sym (make-symbol ":type")) - (defun fcr--fix-type (fcr) (if (byte-code-function-p fcr) fcr @@ -239,7 +237,7 @@ ;; marker so we can distinguish this entry from actual variables. (cl-assert (eq 'closure (car-safe fcr))) (let ((typename (documentation fcr 'raw))) - (push (cons fcr--type-sym (intern typename)) + (push (cons :type (intern typename)) (cadr fcr)) fcr))) @@ -247,7 +245,7 @@ (if (byte-code-function-p fcr) (apply #'make-closure fcr args) (cl-assert (eq 'closure (car-safe fcr))) - (cl-assert (eq fcr--type-sym (caar (cadr fcr)))) + (cl-assert (eq :type (caar (cadr fcr)))) (let ((env (cadr fcr))) `(closure (,(car env) @@ -263,7 +261,7 @@ (let ((csts (aref fcr 2))) (aref csts index)) (cl-assert (eq 'closure (car-safe fcr))) - (cl-assert (eq fcr--type-sym (caar (cadr fcr)))) + (cl-assert (eq :type (caar (cadr fcr)))) (cdr (nth (1+ index) (cadr fcr))))) (defun fcr-type (fcr) @@ -272,7 +270,7 @@ (let ((type (and (> (length fcr) 4) (aref fcr 4)))) (if (symbolp type) type)) (and (eq 'closure (car-safe fcr)) - (eq fcr--type-sym (caar (cadr fcr))) + (eq :type (caar (cadr fcr))) (cdar (cadr fcr))))) (provide 'fcr)