scratch/oclosure f11349ed20 03/25: * lisp/emacs-lisp/cl-generic.el: Use OClosure for `cl-next-method-p`

[Stefan Monnier]

branch: scratch/oclosure
commit f11349ed20c05fbe97db219eecfae0059d7ee4c0
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * 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`.
---
 lisp/emacs-lisp/cl-generic.el | 46 ++++++++++---------------------------------
 lisp/emacs-lisp/oclosure.el   | 16 +++++++--------
 2 files changed, 17 insertions(+), 45 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 152a7a2afa..ecd384d8b0 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 524b71a5a4..debb26bc8a 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)