Commit 909126de authored by Stefan Monnier's avatar Stefan Monnier

* lisp/emacs-lisp/cl-generic.el: Add support for cl-next-method-p.

(cl-defmethod): Add edebug spec.
(cl--generic-build-combined-method): Fix call to
cl-no-applicable-method.
(cl--generic-nnm-sample, cl--generic-cnm-sample): New constant.
(cl--generic-isnot-nnm-p): New function.
(cl--generic-lambda): Use it to add support for cl-next-method-p.
(cl-no-next-method, cl-no-applicable-method): Simplify arg list.
(cl-next-method-p): New function.
parent 3065125d
2015-01-18 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/cl-macs.el (cl-defstruct): Minor optimization when include
or print is nil.
(cl-struct-type-p): New function.
* emacs-lisp/cl-generic.el: Add support for cl-next-method-p.
(cl-defmethod): Add edebug spec.
(cl--generic-build-combined-method): Fix call to
cl-no-applicable-method.
(cl--generic-nnm-sample, cl--generic-cnm-sample): New constant.
(cl--generic-isnot-nnm-p): New function.
(cl--generic-lambda): Use it to add support for cl-next-method-p.
(cl-no-next-method, cl-no-applicable-method): Simplify arg list.
(cl-next-method-p): New function.
2015-01-17 Ulrich Müller <ulm@gentoo.org>
* version.el (emacs-repository-get-version): Update docstring.
......@@ -14,8 +30,8 @@
in place of the file name while working on non-file buffers, just
like hack-dir-local-variables already does. (Bug#19140)
* textmodes/enriched.el (enriched-encode): Use
inhibit-point-motion-hooks in addition to inhibit-read-only.
* textmodes/enriched.el (enriched-encode):
Use inhibit-point-motion-hooks in addition to inhibit-read-only.
(Bug#18246)
* desktop.el (desktop-read): Do not call desktop-clear when no
......
......@@ -26,8 +26,7 @@
;; 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
......@@ -133,7 +132,7 @@ They should be sorted from most specific to least specific.")
"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)."
......@@ -223,8 +222,10 @@ This macro can only be used within the lexical scope of a cl-generic method."
(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
......@@ -232,11 +233,15 @@ This macro can only be used within the lexical scope of a cl-generic method."
;; 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))))))))
......@@ -261,7 +266,15 @@ Other than a type, TYPE can also be of the form `(eql VAL)' in
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)
......@@ -402,7 +415,8 @@ for all those different tags in the method-cache.")
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".
......@@ -428,6 +442,38 @@ for all those different tags in the method-cache.")
(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 '()))
......@@ -452,12 +498,12 @@ for all those different tags in the method-cache.")
(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)
......@@ -465,6 +511,12 @@ for all those different tags in the method-cache.")
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)
......
......@@ -36,12 +36,12 @@
;; Retrieved from:
;; http://192.220.96.201/dylan/linearization-oopsla96.html
;; There is funny stuff going on with typep and deftype. This
;; is the only way I seem to be able to make this stuff load properly.
;; @TODO - fix :initform to be a form, not a quoted value
;; @TODO - Prefix non-clos functions with `eieio-'.
;; TODO: better integrate CL's defstructs and classes. E.g. make it possible
;; to create a new class that inherits from a struct.
;;; Code:
(defvar eieio-version "1.4"
......@@ -924,7 +924,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
;;; Start of automatically extracted autoloads.
;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "9a908efef1720439feb6323c1dd01770")
;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "6baa78cfc590cc0422e12b7eb55abf24")
;;; Generated autoloads from eieio-custom.el
(autoload 'customize-object "eieio-custom" "\
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment