diff options
| -rw-r--r-- | lisp/ChangeLog | 35 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 3 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-base.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-core.el | 111 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-datadebug.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-opt.el | 99 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio.el | 71 | ||||
| -rw-r--r-- | test/ChangeLog | 4 | ||||
| -rw-r--r-- | test/automated/eieio-tests.el | 5 |
9 files changed, 145 insertions, 189 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 3724388dfd..0a3c7c9592 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,38 @@ +2015-01-31 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/eieio.el (defclass): Use new eieio-make-class-predicate + and eieio-make-child-predicate. + (eieio-class-parents): Use eieio--class-object. + (slot-boundp, find-class, eieio-override-prin1): Avoid class-p. + (slot-exists-p): Use find-class. + + * emacs-lisp/eieio-opt.el (eieio-help-class, eieio-help-constructor): + Use find-lisp-object-file-name, help-fns-short-filename and new calling + convention for eieio-class-def. + (eieio-build-class-list): Remove function, unused. + (eieio-method-def): Remove button type, unused. + (eieio-class-def): Inherit from help-function-def. + (eieio--defclass-regexp): New constant. + (find-function-regexp-alist): Use it. + (eieio--specializers-apply-to-class-p): Handle eieio--static as well. + (eieio-help-find-method-definition, eieio-help-find-class-definition): + Remove functions. + + * emacs-lisp/eieio-core.el (eieio--check-type): Remove. + Use cl-check-type everywhere instead. + (eieio-class-object): Remove, use find-class instead when needed. + (class-p): Don't inline. + (eieio-object-p): Check more thoroughly, so we don't treat cl-structs, + such as eieio classes, as objects. Don't inline. + (object-p): Mark as obsolete. + (eieio-defclass-autoload, eieio-defclass-internal, eieio-oref) + (eieio--generic-tagcode): Avoid `class-p'. + (eieio-make-class-predicate, eieio-make-child-predicate): New functions. + (eieio-defclass-internal): Use current-load-list rather than + `class-location'. + + * emacs-lisp/cl-generic.el (cl--generic-search-method): Fix regexp. + 2015-01-30 Stefan Monnier <monnier@iro.umontreal.ca> * emacs-lisp/backquote.el (backquote-delay-process): Don't reuse `s' diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 3e34ab6e4d..72ec8ec180 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -635,7 +635,8 @@ Can only be used from within the lexical body of a primary or around method." (defun cl--generic-search-method (met-name) (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+" - (regexp-quote (format "%s\\_>" (car met-name)))))) + (regexp-quote (format "%s" (car met-name))) + "\\_>"))) (or (re-search-forward (concat base-re "[^&\"\n]*" diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index feb06711cb..46585ee76c 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -219,7 +219,7 @@ for CLASS. Optional ALLOW-SUBCLASS says that it is ok for being pedantic." (unless class (message "Unsafe call to `eieio-persistent-read'.")) - (when class (eieio--check-type class-p class)) + (when class (cl-check-type class class)) (let ((ret nil) (buffstr nil)) (unwind-protect @@ -481,7 +481,7 @@ instance." (cl-defmethod eieio-object-set-name-string ((obj eieio-named) name) "Set the string which is OBJ's NAME." - (eieio--check-type stringp name) + (cl-check-type name string) (eieio-oset obj 'object-name name)) (cl-defmethod clone ((obj eieio-named) &rest params) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index d8d39020d0..77d8c01388 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -40,6 +40,8 @@ (declare-function slot-unbound "eieio") (declare-function slot-missing "eieio") (declare-function child-of-class-p "eieio") +(declare-function same-class-p "eieio") +(declare-function object-of-class-p "eieio") ;;; @@ -154,15 +156,6 @@ Currently under control of this var: ;;; Important macros used internally in eieio. -;; -(defmacro eieio--check-type (type obj) - (unless (symbolp obj) - (error "eieio--check-type wants OBJ to be a variable")) - `(if (not ,(cond - ((eq 'or (car-safe type)) - `(or ,@(mapcar (lambda (type) `(,type ,obj)) (cdr type)))) - (t `(,type ,obj)))) - (signal 'wrong-type-argument (list ',type ,obj)))) (defmacro eieio--class-v (class) ;Use a macro, so it acts as a GV place. "Internal: Return the class vector from the CLASS symbol." @@ -183,27 +176,17 @@ Currently under control of this var: (eq (aref class 0) 'defclass) (error nil))) -(defsubst eieio-class-object (class) - "Check that CLASS is a class and return the corresponding object." - (let ((c (eieio--class-object class))) - (eieio--check-type eieio--class-p c) - c)) - -(defsubst class-p (class) +(defun class-p (class) "Return non-nil if CLASS is a valid class vector. CLASS is a symbol." ;FIXME: Is it a vector or a symbol? - ;; this new method is faster since it doesn't waste time checking lots of - ;; things. - (condition-case nil - (eq (aref (eieio--class-v class) 0) 'defclass) - (error nil))) + (and (symbolp class) (eieio--class-p (eieio--class-v class)))) (defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS." ;; FIXME: What's a "Lisp like symbol name"? ;; FIXME: CLOS returns a symbol, but the code returns a string. (if (eieio--class-p class) (setq class (eieio--class-symbol class))) - (eieio--check-type class-p class) + (cl-check-type class class) ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, ;; and I wanted a string. Arg! (format "#<class %s>" (symbol-name class))) @@ -221,14 +204,17 @@ CLASS is a symbol." ;FIXME: Is it a vector or a symbol? Return nil if that option doesn't exist." (eieio--class-option-assoc (eieio--class-options class) option)) -(defsubst eieio-object-p (obj) +(defun eieio-object-p (obj) "Return non-nil if OBJ is an EIEIO object." (and (vectorp obj) (> (length obj) 0) - (eq (symbol-function (eieio--class-tag obj)) - :quick-object-witness-check))) + (let ((tag (eieio--object-class-tag obj))) + (and (symbolp tag) + ;; (eq (symbol-function tag) :quick-object-witness-check) + (boundp tag) + (eieio--class-p (symbol-value tag)))))) -(defalias 'object-p 'eieio-object-p) +(define-obsolete-function-alias 'object-p 'eieio-object-p "25.1") (defsubst class-abstract-p (class) "Return non-nil if CLASS is abstract. @@ -266,10 +252,9 @@ It creates an autoload function for CNAME's constructor." ;; simply not exist yet. So instead we just don't store the list of parents ;; here in eieio-defclass-autoload at all, since it seems that they're just ;; not needed before the class is actually loaded. - (let* ((oldc (when (class-p cname) (eieio--class-v cname))) - (newc (eieio--class-make cname)) - ) - (if oldc + (let* ((oldc (eieio--class-v cname)) + (newc (eieio--class-make cname))) + (if (eieio--class-p oldc) nil ;; Do nothing if we already have this class. ;; turn this into a usable self-pointing symbol @@ -300,7 +285,21 @@ It creates an autoload function for CNAME's constructor." (cl-every (lambda (elem) (cl-typep elem ',elem-type)) list))))) -(declare-function eieio--defmethod "eieio-generic" (method kind argclass code)) + +(defun eieio-make-class-predicate (class) + (lambda (obj) + ;; (:docstring (format "Test OBJ to see if it's an object of type %S." + ;; class)) + (and (eieio-object-p obj) + (same-class-p obj class)))) + +(defun eieio-make-child-predicate (class) + (lambda (obj) + ;; (:docstring (format + ;; "Test OBJ to see if it's an object is a child of type %S." + ;; class)) + (and (eieio-object-p obj) + (object-of-class-p obj class)))) (defun eieio-defclass-internal (cname superclasses slots options) "Define CNAME as a new subclass of SUPERCLASSES. @@ -314,7 +313,7 @@ See `defclass' for more information." (setq eieio-hook nil) (let* ((pname superclasses) - (oldc (when (class-p cname) (eieio--class-v cname))) + (oldc (let ((c (eieio--class-v cname))) (if (eieio--class-p c) c))) (newc (if (and oldc (not (eieio--class-default-object-cache oldc))) ;; The oldc class is a stub setup by eieio-defclass-autoload. ;; Reuse it instead of creating a new one, so that existing @@ -342,19 +341,20 @@ See `defclass' for more information." (if pname (progn (dolist (p pname) - (if (and p (symbolp p)) - (if (not (class-p p)) + (if (not (and p (symbolp p))) + (error "Invalid parent class %S" p) + (let ((c (eieio--class-v p))) + (if (not (eieio--class-p c)) ;; bad class (error "Given parent class %S is not a class" p) ;; good parent class... ;; save new child in parent - (cl-pushnew cname (eieio--class-children (eieio--class-v p))) + (cl-pushnew cname (eieio--class-children c)) ;; Get custom groups, and store them into our local copy. (mapc (lambda (g) (cl-pushnew g groups :test #'equal)) - (eieio--class-option (eieio--class-v p) :custom-groups)) - ;; save parent in child - (push (eieio--class-v p) (eieio--class-parent newc))) - (error "Invalid parent class %S" p))) + (eieio--class-option c :custom-groups)) + ;; Save parent in child. + (push c (eieio--class-parent newc)))))) ;; Reverse the list of our parents so that they are prioritized in ;; the same order as specified in the code. (cl-callf nreverse (eieio--class-parent newc))) @@ -506,13 +506,7 @@ See `defclass' for more information." (eieio--class-option-assoc options :documentation)) ;; Save the file location where this class is defined. - (let ((fname (if load-in-progress - load-file-name - buffer-file-name))) - (when fname - (when (string-match "\\.elc\\'" fname) - (setq fname (substring fname 0 (1- (length fname))))) - (put cname 'class-location fname))) + (add-to-list 'current-load-list `(eieio-defclass . ,cname)) ;; We have a list of custom groups. Store them into the options. (let ((g (eieio--class-option-assoc options :custom-groups))) @@ -909,12 +903,13 @@ Argument FN is the function calling this verifier." ;; (defun eieio-oref (obj slot) "Return the value in OBJ at SLOT in the object vector." - (eieio--check-type (or eieio-object-p class-p) obj) - (eieio--check-type symbolp slot) - (if (class-p obj) (eieio-class-un-autoload obj)) + (cl-check-type slot symbol) + (cl-check-type obj (or eieio-object class)) (let* ((class (cond ((symbolp obj) (error "eieio-oref called on a class!") - (eieio--class-v obj)) + (let ((c (eieio--class-v obj))) + (if (eieio--class-p c) (eieio-class-un-autoload obj)) + c)) (t (eieio--object-class-object obj)))) (c (eieio--slot-name-index class obj slot))) (if (not c) @@ -929,15 +924,15 @@ Argument FN is the function calling this verifier." (slot-missing obj slot 'oref) ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) ) - (eieio--check-type eieio-object-p obj) + (cl-check-type obj eieio-object) (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) (defun eieio-oref-default (obj slot) "Do the work for the macro `oref-default' with similar parameters. Fills in OBJ's SLOT with its default value." - (eieio--check-type (or eieio-object-p class-p) obj) - (eieio--check-type symbolp slot) + (cl-check-type obj (or eieio-object class)) + (cl-check-type slot symbol) (let* ((cl (cond ((symbolp obj) (eieio--class-v obj)) (t (eieio--object-class-object obj)))) (c (eieio--slot-name-index cl obj slot))) @@ -975,8 +970,8 @@ Fills in OBJ's SLOT with its default value." (defun eieio-oset (obj slot value) "Do the work for the macro `oset'. Fills in OBJ's SLOT with VALUE." - (eieio--check-type eieio-object-p obj) - (eieio--check-type symbolp slot) + (cl-check-type obj eieio-object) + (cl-check-type slot symbol) (let* ((class (eieio--object-class-object obj)) (c (eieio--slot-name-index class obj slot))) (if (not c) @@ -1000,8 +995,8 @@ Fills in OBJ's SLOT with VALUE." "Do the work for the macro `oset-default'. Fills in the default value in CLASS' in SLOT with VALUE." (setq class (eieio--class-object class)) - (eieio--check-type eieio--class-p class) - (eieio--check-type symbolp slot) + (cl-check-type class eieio--class) + (cl-check-type slot symbol) (let* ((c (eieio--slot-name-index class nil slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. @@ -1223,7 +1218,7 @@ method invocation orders of the involved classes." ;; 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) + (and (eieio--class-p (eieio--class-object type)) ;; Use the exact same code as for cl-struct, so that methods ;; that dispatch on both kinds of objects get to share this ;; part of the dispatch code. diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 119f7cce03..82349192e5 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -117,7 +117,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button." (setq publa (cdr publa))))))) ;;; Augment the Data debug thing display list. -(data-debug-add-specialized-thing (lambda (thing) (object-p thing)) +(data-debug-add-specialized-thing (lambda (thing) (eieio-object-p thing)) #'data-debug-insert-object-button) ;;; DEBUG METHODS diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 8d40edf562..304ee364dc 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -45,7 +45,7 @@ variable `eieio-default-superclass'." nil t))) nil)) (if (not root-class) (setq root-class 'eieio-default-superclass)) - (eieio--check-type class-p root-class) + (cl-check-type root-class class) (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t) (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*") (erase-buffer) @@ -58,7 +58,7 @@ variable `eieio-default-superclass'." Argument THIS-ROOT is the local root of the tree. Argument PREFIX is the character prefix to use. Argument CH-PREFIX is another character prefix to display." - (eieio--check-type class-p this-root) + (cl-check-type this-root class) (let ((myname (symbol-name this-root)) (chl (eieio--class-children (eieio--class-v this-root))) (fprefix (concat ch-prefix " +--")) @@ -85,12 +85,12 @@ If CLASS is actually an object, then also display current values of that object. "n abstract" "") " class") - (let ((location (get class 'class-location))) + (let ((location (find-lisp-object-file-name class 'eieio-defclass))) (when location (insert " in `") (help-insert-xref-button - (file-name-nondirectory location) - 'eieio-class-def class location) + (help-fns-short-filename location) + 'eieio-class-def class location 'eieio-defclass) (insert "'"))) (insert ".\n") ;; Parents @@ -204,15 +204,6 @@ Outputs to the current buffer." prot (cdr prot) i (1+ i))))) -(defun eieio-build-class-list (class) - "Return a list of all classes that inherit from CLASS." - (if (class-p class) - (cl-mapcan - (lambda (c) - (append (list c) (eieio-build-class-list c))) - (eieio--class-children (eieio--class-v class))) - (list class))) - (defun eieio-build-class-alist (&optional class instantiable-only buildlist) "Return an alist of all currently active classes for completion purposes. Optional argument CLASS is the class to start with. @@ -256,24 +247,22 @@ are not abstract." ;;; METHOD COMPLETION / DOC -(define-button-type 'eieio-method-def - :supertype 'help-xref - 'help-function (lambda (class method file) - (eieio-help-find-method-definition class method file)) - 'help-echo (purecopy "mouse-2, RET: find method's definition")) - (define-button-type 'eieio-class-def - :supertype 'help-xref - 'help-function (lambda (class file) - (eieio-help-find-class-definition class file)) + :supertype 'help-function-def 'help-echo (purecopy "mouse-2, RET: find class definition")) +(defconst eieio--defclass-regexp "(defclass[ \t\r\n]+%s[ \t\r\n]+") +(with-eval-after-load 'find-func + (defvar find-function-regexp-alist) + (add-to-list 'find-function-regexp-alist + `(eieio-defclass . eieio--defclass-regexp))) + ;;;###autoload (defun eieio-help-constructor (ctr) "Describe CTR if it is a class constructor." (when (class-p ctr) (erase-buffer) - (let ((location (get ctr 'class-location)) + (let ((location (find-lisp-object-file-name ctr 'eieio-defclass)) (def (symbol-function ctr))) (goto-char (point-min)) (prin1 ctr) @@ -288,8 +277,8 @@ are not abstract." (when location (insert " in `") (help-insert-xref-button - (file-name-nondirectory location) - 'eieio-class-def ctr location) + (help-fns-short-filename location) + 'eieio-class-def ctr location 'eieio-defclass) (insert "'")) (insert ".\nCreates an object of class " (symbol-name ctr) ".") (goto-char (point-max)) @@ -304,7 +293,7 @@ are not abstract." "Return non-nil if a method with SPECIALIZERS applies to CLASS." (let ((applies nil)) (dolist (specializer specializers) - (if (eq 'subclass (car-safe specializer)) + (if (memq (car-safe specializer) '(subclass eieio--static)) (setq specializer (nth 1 specializer))) ;; Don't include the methods that are "too generic", such as those ;; applying to `eieio-default-superclass'. @@ -443,60 +432,6 @@ The value returned is a list of elements of the form (terpri) )) -;;; HELP AUGMENTATION -;; -(defun eieio-help-find-method-definition (class method file) - (let ((filename (find-library-name file)) - location buf) - (when (symbolp class) - (setq class (symbol-name class))) - (when (symbolp method) - (setq method (symbol-name method))) - (when (null filename) - (error "Cannot find library %s" file)) - (setq buf (find-file-noselect filename)) - (with-current-buffer buf - (goto-char (point-min)) - (when - (re-search-forward - ;; Regexp for searching methods. - (concat "(defmethod[ \t\r\n]+" method - "\\([ \t\r\n]+:[a-zA-Z]+\\)?" - "[ \t\r\n]+(\\s-*(\\(\\sw\\|\\s_\\)+\\s-+" - class - "\\s-*)") - nil t) - (setq location (match-beginning 0)))) - (if (null location) - (message "Unable to find location in file") - (pop-to-buffer buf) - (goto-char location) - (recenter) - (beginning-of-line)))) - -(defun eieio-help-find-class-definition (class file) - (when (symbolp class) - (setq class (symbol-name class))) - (let ((filename (find-library-name file)) - location buf) - (when (null filename) - (error "Cannot find library %s" file)) - (setq buf (find-file-noselect filename)) - (with-current-buffer buf - (goto-char (point-min)) - (when - (re-search-forward - ;; Regexp for searching a class. - (concat "(defclass[ \t\r\n]+" class "[ \t\r\n]+") - nil t) - (setq location (match-beginning 0)))) - (if (null location) - (message "Unable to find location in file") - (pop-to-buffer buf) - (goto-char location) - (recenter) - (beginning-of-line)))) - ;;; SPEEDBAR SUPPORT ;; @@ -546,7 +481,7 @@ current expansion depth." (defun eieio-class-button (class depth) "Draw a speedbar button at the current point for CLASS at DEPTH." - (eieio--check-type class-p class) + (cl-check-type class class) (let ((subclasses (eieio--class-children (eieio--class-v class)))) (if subclasses (speedbar-make-tag-line 'angle ?+ diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 91469b4b96..526090954a 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -110,7 +110,7 @@ Options in CLOS not supported in EIEIO: Due to the way class options are set up, you can add any tags you wish, and reference them using the function `class-option'." (declare (doc-string 4)) - (eieio--check-type listp superclasses) + (cl-check-type superclasses list) (cond ((and (stringp (car options-and-doc)) (/= 1 (% (length options-and-doc) 2))) @@ -223,18 +223,9 @@ This method is obsolete." ;; referencing classes. ei, a class whose slot can contain only ;; pointers to itself. - ;; Create the test function. - (defun ,testsym1 (obj) - ,(format "Test OBJ to see if it an object of type %S." name) - (and (eieio-object-p obj) - (same-class-p obj ',name))) - - (defun ,testsym2 (obj) - ,(format - "Test OBJ to see if it an object is a child of type %S." - name) - (and (eieio-object-p obj) - (object-of-class-p obj ',name))) + ;; Create the test functions. + (defalias ',testsym1 (eieio-make-class-predicate ',name)) + (defalias ',testsym2 (eieio-make-child-predicate ',name)) ,@(when eieio-backward-compatibility (let ((f (intern (format "%s-child-p" name)))) @@ -374,7 +365,7 @@ variable name of the same name as the slot." (defun eieio-object-name (obj &optional extra) "Return a Lisp like symbol string for object OBJ. If EXTRA, include that in the string returned to represent the symbol." - (eieio--check-type eieio-object-p obj) + (cl-check-type obj eieio-object) (format "#<%s %s%s>" (eieio--object-class-name obj) (eieio-object-name-string obj) (or extra ""))) (define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") @@ -394,7 +385,7 @@ If EXTRA, include that in the string returned to represent the symbol." (cl-defmethod eieio-object-set-name-string (obj name) "Set the string which is OBJ's NAME." (declare (obsolete eieio-named "25.1")) - (eieio--check-type stringp name) + (cl-check-type name string) (setf (gethash obj eieio--object-names) name)) (define-obsolete-function-alias 'object-set-name-string 'eieio-object-set-name-string "24.4") @@ -402,7 +393,7 @@ If EXTRA, include that in the string returned to represent the symbol." (defun eieio-object-class (obj) "Return the class struct defining OBJ." ;; FIXME: We say we return a "struct" but we return a symbol instead! - (eieio--check-type eieio-object-p obj) + (cl-check-type obj eieio-object) (eieio--object-class-name obj)) (define-obsolete-function-alias 'object-class #'eieio-object-class "24.4") ;; CLOS name, maybe? @@ -410,7 +401,7 @@ If EXTRA, include that in the string returned to represent the symbol." (defun eieio-object-class-name (obj) "Return a Lisp like symbol name for OBJ's class." - (eieio--check-type eieio-object-p obj) + (cl-check-type obj eieio-object) (eieio-class-name (eieio--object-class-name obj))) (define-obsolete-function-alias 'object-class-name 'eieio-object-class-name "24.4") @@ -419,15 +410,14 @@ If EXTRA, include that in the string returned to represent the symbol." "Return parent classes to CLASS. (overload of variable). The CLOS function `class-direct-superclasses' is aliased to this function." - (let ((c (eieio-class-object class))) - (eieio--class-parent c))) + (eieio--class-parent (eieio--class-object class))) (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") (defun eieio-class-children (class) "Return child classes to CLASS. The CLOS function `class-direct-subclasses' is aliased to this function." - (eieio--check-type class-p class) + (cl-check-type class class) (eieio--class-children (eieio--class-v class))) (define-obsolete-function-alias 'class-children #'eieio-class-children "24.4") @@ -446,13 +436,13 @@ The CLOS function `class-direct-subclasses' is aliased to this function." (defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." (setq class (eieio--class-object class)) - (eieio--check-type eieio--class-p class) - (eieio--check-type eieio-object-p obj) + (cl-check-type class eieio--class) + (cl-check-type obj eieio-object) (eq (eieio--object-class-object obj) class)) (defun object-of-class-p (obj class) "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." - (eieio--check-type eieio-object-p obj) + (cl-check-type obj eieio-object) ;; class will be checked one layer down (child-of-class-p (eieio--object-class-object obj) class)) ;; Backwards compatibility @@ -461,13 +451,13 @@ The CLOS function `class-direct-subclasses' is aliased to this function." (defun child-of-class-p (child class) "Return non-nil if CHILD class is a subclass of CLASS." (setq child (eieio--class-object child)) - (eieio--check-type eieio--class-p child) + (cl-check-type child eieio--class) ;; `eieio-default-superclass' is never mentioned in eieio--class-parent, ;; so we have to special case it here. (or (eq class 'eieio-default-superclass) (let ((p nil)) (setq class (eieio--class-object class)) - (eieio--check-type eieio--class-p class) + (cl-check-type class eieio--class) (while (and child (not (eq child class))) (setq p (append p (eieio--class-parent child)) child (pop p))) @@ -475,11 +465,11 @@ The CLOS function `class-direct-subclasses' is aliased to this function." (defun object-slots (obj) "Return list of slots available in OBJ." - (eieio--check-type eieio-object-p obj) + (cl-check-type obj eieio-object) (eieio--class-public-a (eieio--object-class-object obj))) (defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." - (eieio--check-type eieio--class-p class) + (cl-check-type class eieio--class) (let ((ia (eieio--class-initarg-tuples class)) (f nil)) (while (and ia (not f)) @@ -517,7 +507,7 @@ OBJECT can be an instance or a class." ;; Return nil if the magic symbol is in there. (not (eq (cond ((eieio-object-p object) (eieio-oref object slot)) - ((class-p object) (eieio-oref-default object slot)) + ((symbolp object) (eieio-oref-default object slot)) (t (signal 'wrong-type-argument (list 'eieio-object-p object)))) eieio-unbound)))) @@ -529,7 +519,8 @@ OBJECT can be an instance or a class." "Return non-nil if OBJECT-OR-CLASS has SLOT." (let ((cv (cond ((eieio-object-p object-or-class) (eieio--object-class-object object-or-class)) - (t (eieio-class-object object-or-class))))) + ((eieio--class-p object-or-class) object-or-class) + (t (find-class object-or-class 'error))))) (or (memq slot (eieio--class-public-a cv)) (memq slot (eieio--class-class-allocation-a cv))) )) @@ -538,10 +529,10 @@ OBJECT can be an instance or a class." "Return the class that SYMBOL represents. If there is no class, nil is returned if ERRORP is nil. If ERRORP is non-nil, `wrong-argument-type' is signaled." - (if (not (class-p symbol)) - (if errorp (signal 'wrong-type-argument (list 'class-p symbol)) - nil) - (eieio--class-v symbol))) + (let ((class (eieio--class-v symbol))) + (cond + ((eieio--class-p class) class) + (errorp (signal 'wrong-type-argument (list 'class-p symbol)))))) ;;; Slightly more complex utility functions for objects ;; @@ -551,7 +542,7 @@ LIST is a list of objects whose slots are searched. Objects in LIST do not need to have a slot named SLOT, nor does SLOT need to be bound. If these errors occur, those objects will be ignored." - (eieio--check-type listp list) + (cl-check-type list list) (while (and list (not (condition-case nil ;; This prevents errors for missing slots. (equal key (eieio-oref (car list) slot)) @@ -563,7 +554,7 @@ be ignored." "Return an association list with the contents of SLOT as the key element. LIST must be a list of objects with SLOT in it. This is useful when you need to do completing read on an object group." - (eieio--check-type listp list) + (cl-check-type list list) (let ((assoclist nil)) (while list (setq assoclist (cons (cons (eieio-oref (car list) slot) @@ -577,7 +568,7 @@ This is useful when you need to do completing read on an object group." LIST must be a list of objects, but those objects do not need to have SLOT in it. If it does not, then that element is left out of the association list." - (eieio--check-type listp list) + (cl-check-type list list) (let ((assoclist nil)) (while list (if (slot-exists-p (car list) slot) @@ -869,12 +860,8 @@ this object." (object-write thing)) ((consp thing) (eieio-list-prin1 thing)) - ((class-p thing) + ((eieio--class-p thing) (princ (eieio-class-name thing))) - ((or (keywordp thing) (booleanp thing)) - (prin1 thing)) - ((symbolp thing) - (princ (concat "'" (symbol-name thing)))) (t (prin1 thing)))) (defun eieio-list-prin1 (list) @@ -942,7 +929,7 @@ Optional argument GROUP is the sub-group of slots to display. ;;;*** -;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "b849f8bf1312d5ef57e53d02173e4b5a") +;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "ff1097f185bc2c253276a7d19fe2f54a") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ diff --git a/test/ChangeLog b/test/ChangeLog index 8e4fdb884a..a9834cc0f3 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,7 @@ +2015-01-31 Stefan Monnier <monnier@iro.umontreal.ca> + + * automated/eieio-tests.el (eieio-test-23-inheritance-check): Simplify. + 2015-01-30 Stefan Monnier <monnier@iro.umontreal.ca> * automated/core-elisp-tests.el (core-elisp-tests-3-backquote): New test. diff --git a/test/automated/eieio-tests.el b/test/automated/eieio-tests.el index 847aefd63f..7532609c4c 100644 --- a/test/automated/eieio-tests.el +++ b/test/automated/eieio-tests.el @@ -537,9 +537,8 @@ METHOD is the method that was attempting to be called." (should (object-of-class-p eitest-ab 'class-b)) (should (object-of-class-p eitest-ab 'class-ab)) (should (eq (eieio-class-parents 'class-a) nil)) - ;; FIXME: eieio-class-parents now returns class objects! - (should (equal (mapcar #'eieio-class-object (eieio-class-parents 'class-ab)) - (mapcar #'eieio-class-object '(class-a class-b)))) + (should (equal (eieio-class-parents 'class-ab) + (mapcar #'find-class '(class-a class-b)))) (should (same-class-p eitest-a 'class-a)) (should (class-a-p eitest-a)) (should (not (class-a-p eitest-ab))) |