[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)