(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.
`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
;; 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.
"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.
(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)))
(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
;; 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)))
(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)
(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)
(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)