Commit 483c98a0 authored by Stefan Monnier's avatar Stefan Monnier

* lisp/emacs-lisp/eieio-core.el: Provide support for cl-generic.

(eieio--generic-tagcode): New function.
(cl-generic-tagcode-function): Use it.
(eieio--generic-tag-types): New function.
(cl-generic-tag-types-function): Use it.
(eieio-object-p): Tighten up the test.

* lisp/emacs-lisp/cl-generic.el (cl-generic-define-method): Fix paren typo.

* test/automated/eieio-test-methodinvoke.el (eieio-test-method-store): Add
keysym arg instead of relying on internal var eieio--generic-call-key.
Update all callers.
(eieio-test-cl-generic-1): New tests.
parent 9def17e9
2015-01-15 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/eieio-core.el: Provide support for cl-generic.
(eieio--generic-tagcode): New function.
(cl-generic-tagcode-function): Use it.
(eieio--generic-tag-types): New function.
(cl-generic-tag-types-function): Use it.
(eieio-object-p): Tighten up the test.
* emacs-lisp/cl-generic.el (cl-generic-define-method): Fix paren typo.
2015-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/cl-generic.el: New file.
......
......@@ -305,10 +305,10 @@ which case this method will be invoked when the argument is `eql' to VAL.
(setq i (1+ i))))
(if me (setcdr me (cons uses-cnm function))
(setf (cl--generic-method-table generic)
(cons `(,key ,uses-cnm . ,function) mt))
;; For aliases, cl--generic-name gives us the actual name.
(defalias (cl--generic-name generic)
(cl--generic-make-function generic)))))
(cons `(,key ,uses-cnm . ,function) mt)))
;; For aliases, cl--generic-name gives us the actual name.
(defalias (cl--generic-name generic)
(cl--generic-make-function generic))))
(defmacro cl--generic-with-memoization (place &rest code)
(declare (indent 1) (debug t))
......
......@@ -264,7 +264,7 @@ Return nil if that option doesn't exist."
(defsubst eieio-object-p (obj)
"Return non-nil if OBJ is an EIEIO object."
(and (arrayp obj)
(and (vectorp obj)
(condition-case nil
(eq (aref (eieio--object-class-object obj) 0) 'defclass)
(error nil))))
......@@ -1303,10 +1303,34 @@ method invocation orders of the involved classes."
(define-error 'unbound-slot "Unbound slot")
(define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy")
;;; Hooking into cl-generic.
(require 'cl-generic)
(add-function :before-until cl-generic-tagcode-function
#'eieio--generic-tagcode)
(defun eieio--generic-tagcode (type name)
;; CLHS says:
;; A class must be defined before it can be used as a parameter
;; specializer in a defmethod form.
;; So we can ignore types that are not known to denote classes.
(and (class-p type)
;; Prefer (aref ,name 0) over (eieio--class-tag ,name) so that
;; the tagcode is identical to the tagcode used for cl-struct.
`(50 . (and (vectorp ,name) (aref ,name 0)))))
(add-function :before-until cl-generic-tag-types-function
#'eieio--generic-tag-types)
(defun eieio--generic-tag-types (tag)
(and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))
(mapcar #'eieio--class-symbol
(eieio--class-precedence-list (symbol-value tag)))))
;;; Backward compatibility functions
;; To support .elc files compiled for older versions of EIEIO.
(defun eieio-defclass (cname superclasses slots options)
(declare (obsolete eieio-defclass-internal "25.1"))
(eval `(defclass ,cname ,superclasses ,slots ,@options)))
......
2015-01-15 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/eieio-test-methodinvoke.el (eieio-test-method-store): Add
keysym arg instead of relying on internal var eieio--generic-call-key.
Update all callers.
(eieio-test-cl-generic-1): New tests.
2015-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/cl-generic-tests.el: New file.
......
......@@ -58,12 +58,10 @@
(defvar eieio-test-method-order-list nil
"List of symbols stored during method invocation.")
(defun eieio-test-method-store ()
(defun eieio-test-method-store (keysym)
"Store current invocation class symbol in the invocation order list."
(let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ]
(or eieio--generic-call-key 0)))
;; FIXME: Don't depend on `eieio--scoped-class'!
(c (list keysym (eieio--class-symbol (eieio--scoped-class)))))
;; FIXME: Don't depend on `eieio--scoped-class'!
(let* ((c (list keysym (eieio--class-symbol (eieio--scoped-class)))))
(push c eieio-test-method-order-list)))
(defun eieio-test-match (rightanswer)
......@@ -88,36 +86,36 @@
(defclass eitest-B (eitest-B-base1 eitest-B-base2) ())
(defmethod eitest-F :BEFORE ((p eitest-B-base1))
(eieio-test-method-store))
(eieio-test-method-store :BEFORE))
(defmethod eitest-F :BEFORE ((p eitest-B-base2))
(eieio-test-method-store))
(eieio-test-method-store :BEFORE))
(defmethod eitest-F :BEFORE ((p eitest-B))
(eieio-test-method-store))
(eieio-test-method-store :BEFORE))
(defmethod eitest-F ((p eitest-B))
(eieio-test-method-store)
(eieio-test-method-store :PRIMARY)
(call-next-method))
(defmethod eitest-F ((p eitest-B-base1))
(eieio-test-method-store)
(eieio-test-method-store :PRIMARY)
(call-next-method))
(defmethod eitest-F ((p eitest-B-base2))
(eieio-test-method-store)
(eieio-test-method-store :PRIMARY)
(when (next-method-p)
(call-next-method))
)
(defmethod eitest-F :AFTER ((p eitest-B-base1))
(eieio-test-method-store))
(eieio-test-method-store :AFTER))
(defmethod eitest-F :AFTER ((p eitest-B-base2))
(eieio-test-method-store))
(eieio-test-method-store :AFTER))
(defmethod eitest-F :AFTER ((p eitest-B))
(eieio-test-method-store))
(eieio-test-method-store :AFTER))
(ert-deftest eieio-test-method-order-list-3 ()
(let ((eieio-test-method-order-list nil)
......@@ -152,15 +150,15 @@
;;; Return value from :PRIMARY
;;
(defmethod eitest-I :BEFORE ((a eitest-A))
(eieio-test-method-store)
(eieio-test-method-store :BEFORE)
":before")
(defmethod eitest-I :PRIMARY ((a eitest-A))
(eieio-test-method-store)
(eieio-test-method-store :PRIMARY)
":primary")
(defmethod eitest-I :AFTER ((a eitest-A))
(eieio-test-method-store)
(eieio-test-method-store :AFTER)
":after")
(ert-deftest eieio-test-method-order-list-5 ()
......@@ -179,17 +177,17 @@
;; Just use the obsolete name once, to make sure it also works.
(defmethod constructor :STATIC ((p C-base1) &rest args)
(eieio-test-method-store)
(eieio-test-method-store :STATIC)
(if (next-method-p) (call-next-method))
)
(defmethod eieio-constructor :STATIC ((p C-base2) &rest args)
(eieio-test-method-store)
(eieio-test-method-store :STATIC)
(if (next-method-p) (call-next-method))
)
(defmethod eieio-constructor :STATIC ((p C) &rest args)
(eieio-test-method-store)
(eieio-test-method-store :STATIC)
(call-next-method)
)
......@@ -216,24 +214,24 @@
(defmethod eitest-F ((p D))
"D"
(eieio-test-method-store)
(eieio-test-method-store :PRIMARY)
(call-next-method))
(defmethod eitest-F ((p D-base0))
"D-base0"
(eieio-test-method-store)
(eieio-test-method-store :PRIMARY)
;; This should have no next
;; (when (next-method-p) (call-next-method))
)
(defmethod eitest-F ((p D-base1))
"D-base1"
(eieio-test-method-store)
(eieio-test-method-store :PRIMARY)
(call-next-method))
(defmethod eitest-F ((p D-base2))
"D-base2"
(eieio-test-method-store)
(eieio-test-method-store :PRIMARY)
(when (next-method-p)
(call-next-method))
)
......@@ -258,21 +256,21 @@
(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)
(defmethod eitest-F ((p E))
(eieio-test-method-store)
(eieio-test-method-store :PRIMARY)
(call-next-method))
(defmethod eitest-F ((p E-base0))
(eieio-test-method-store)
(eieio-test-method-store :PRIMARY)
;; This should have no next
;; (when (next-method-p) (call-next-method))
)
(defmethod eitest-F ((p E-base1))
(eieio-test-method-store)
(eieio-test-method-store :PRIMARY)
(call-next-method))
(defmethod eitest-F ((p E-base2))
(eieio-test-method-store)
(eieio-test-method-store :PRIMARY)
(when (next-method-p)
(call-next-method))
)
......@@ -380,3 +378,21 @@
'(CNM-1-1 CNM-2 INIT)))
(should (equal (eieio-test-arguments-for 'CNM-2)
'(INIT)))))
;;; Check cl-generic integration.
(cl-defgeneric eieio-test--1 (x y))
(ert-deftest eieio-test-cl-generic-1 ()
(cl-defmethod eieio-test--1 (x y) (list x y))
(cl-defmethod eieio-test--1 ((_x CNM-0) y)
(cons "CNM-0" (cl-call-next-method 7 y)))
(cl-defmethod eieio-test--1 ((_x CNM-1-1) _y)
(cons "CNM-1-1" (cl-call-next-method)))
(cl-defmethod eieio-test--1 ((_x CNM-1-2) y)
(cons "CNM-1-2" (cl-call-next-method)))
(should (equal (eieio-test--1 4 5) '(4 5)))
(should (equal (eieio-test--1 (make-instance 'CNM-0) 5)
'("CNM-0" 7 5)))
(should (equal (eieio-test--1 (make-instance 'CNM-2) 5)
'("CNM-1-1" "CNM-1-2" "CNM-0" 7 5))))
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