emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

scratch/fcr a3640a8 2/2: * lisp/emacs-lisp/cl-generic.el: Use FCR for `c


From: Stefan Monnier
Subject: scratch/fcr a3640a8 2/2: * lisp/emacs-lisp/cl-generic.el: Use FCR for `cl-next-method-p`
Date: Mon, 13 Dec 2021 11:34:00 -0500 (EST)

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

    * 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`.
---
 lisp/emacs-lisp/cl-generic.el | 46 ++++++++++---------------------------------
 lisp/emacs-lisp/fcr.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 ad2bdc0..fa7f736 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 51fc240..112fdbd 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)



reply via email to

[Prev in Thread] Current Thread [Next in Thread]