;; The main entry points are: `cl-defgeneric' and `cl-defmethod'.
;; Missing elements:
-;; - We don't support next-method-p, make-method, call-method,
-;; define-method-combination.
+;; - We don't support make-method, call-method, define-method-combination.
;; - Method and generic function objects: CLOS defines methods as objects
;; (same for generic functions), whereas we don't offer such an abstraction.
;; - `no-next-method' should receive the "calling method" object, but since we
"Create a generic function NAME.
DOC-STRING is the base documentation for this class. A generic
function has no body, as its purpose is to decide which method body
-is appropriate to use. Specific methods are defined with `defmethod'.
+is appropriate to use. Specific methods are defined with `cl-defmethod'.
With this implementation the ARGS are currently ignored.
OPTIONS-AND-METHODS is currently only used to specify the docstring,
via (:documentation DOCSTRING)."
(let* ((doc-string (and doc-string (stringp (car body))
(pop body)))
(cnm (make-symbol "cl--cnm"))
+ (nmp (make-symbol "cl--nmp"))
(nbody (macroexpand-all
- `(cl-flet ((cl-call-next-method ,cnm))
+ `(cl-flet ((cl-call-next-method ,cnm)
+ (cl-next-method-p ,nmp))
,@body)
macroenv))
;; FIXME: Rather than `grep' after the fact, the
;; is used.
;; FIXME: Also, optimize the case where call-next-method is
;; only called with explicit arguments.
- (uses-cnm (cl--generic-fgrep (list cnm) nbody)))
+ (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
(cons (not (not uses-cnm))
`#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
,@(if doc-string (list doc-string))
- ,nbody))))
+ ,(if (not (memq nmp uses-cnm))
+ nbody
+ `(let ((,nmp (lambda ()
+ (cl--generic-isnot-nnm-p ,cnm))))
+ ,nbody))))))
(f (error "Unexpected macroexpansion result: %S" f))))))))
which case this method will be invoked when the argument is `eql' to VAL.
\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
- (declare (doc-string 3) (indent 2))
+ (declare (doc-string 3) (indent 2)
+ (debug
+ (&define ; this means we are defining something
+ [&or name ("setf" :name setf name)]
+ ;; ^^ This is the methods symbol
+ [ &optional keywordp ] ; this is key :before etc
+ list ; arguments
+ [ &optional stringp ] ; documentation string
+ def-body))) ; part to be debugged
(let ((qualifiers nil))
(while (keywordp args)
(push args qualifiers)
cl--generic-combined-method-memoization)
(cond
((null mets-by-qual) (lambda (&rest args)
- (cl-no-applicable-method generic-name args)))
+ (apply #'cl-no-applicable-method
+ generic-name args)))
(t
(let* ((fun (lambda (&rest args)
;; FIXME: CLOS passes as second arg the "calling method".
(apply af args)))))))
(cl--generic-nest fun (alist-get :around mets-by-qual))))))))
+(defconst cl--generic-nnm-sample
+ (cl--generic-build-combined-method nil '(((specializer . :qualifier)))))
+(defconst cl--generic-cnm-sample
+ (funcall (cl--generic-build-combined-method
+ nil `(((specializer . :primary) 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")))
+
(defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags)
(let ((types (apply #'append (mapcar cl-generic-tag-types-function tags)))
(methods '()))
(cl-defgeneric cl-no-next-method (generic method &rest args)
"Function called when `cl-call-next-method' finds no next method.")
-(cl-defmethod cl-no-next-method ((generic t) method &rest args)
+(cl-defmethod cl-no-next-method (generic method &rest args)
(signal 'cl-no-next-method `(,generic ,method ,@args)))
(cl-defgeneric cl-no-applicable-method (generic &rest args)
"Function called when a method call finds no applicable method.")
-(cl-defmethod cl-no-applicable-method ((generic t) &rest args)
+(cl-defmethod cl-no-applicable-method (generic &rest args)
(signal 'cl-no-applicable-method `(,generic ,@args)))
(defun cl-call-next-method (&rest _args)
Can only be used from within the lexical body of a primary or around method."
(error "cl-call-next-method only allowed inside primary and around methods"))
+(defun cl-next-method-p ()
+ "Return non-nil if there is a next method.
+Can only be used from within the lexical body of a primary or around method."
+ (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1"))
+ (error "cl-next-method-p only allowed inside primary and around methods"))
+
;;; Add support for describe-function
(defun cl--generic-search-method (met-name)