diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/backquote.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 30 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 215 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-preloaded.el | 48 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl.el | 1 | ||||
| -rw-r--r-- | lisp/emacs-lisp/easy-mmode.el | 11 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-base.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-core.el | 121 | ||||
| -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 |
11 files changed, 285 insertions, 321 deletions
diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index 082955e0823..d5cdca2b1b5 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -120,9 +120,7 @@ Vectors work just like lists. Nested backquotes are permitted." This simply recurses through the body." (let ((exp (backquote-listify (list (cons 0 (list 'quote (car s)))) (backquote-process (cdr s) level)))) - (if (eq (car-safe exp) 'quote) - (cons 0 (list 'quote s)) - (cons 1 exp)))) + (cons (if (eq (car-safe exp) 'quote) 0 1) exp))) (defun backquote-process (s &optional level) "Process the body of a backquote. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 1bb70963a57..72ec8ec1801 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]*" @@ -724,6 +725,14 @@ Can only be used from within the lexical body of a primary or around method." (add-function :before-until cl-generic-tagcode-function #'cl--generic-struct-tagcode) + +(defun cl--generic-struct-tag (name) + `(and (vectorp ,name) + (> (length ,name) 0) + (let ((tag (aref ,name 0))) + (if (eq (symbol-function tag) :quick-object-witness-check) + tag)))) + (defun cl--generic-struct-tagcode (type name) (and (symbolp type) (get type 'cl-struct-type) @@ -733,12 +742,19 @@ Can only be used from within the lexical body of a primary or around method." (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots))) (error "Can't dispatch on cl-struct %S: no tag in slot 0" type)) - ;; We could/should check the vector has length >0, - ;; but really, mixing vectors and structs is a bad idea, - ;; so let's not waste time trying to handle the case - ;; of an empty vector. - ;; BEWARE: this returns a bogus tag for non-struct vectors. - `(50 . (and (vectorp ,name) (aref ,name 0))))) + ;; It's tempting to use (and (vectorp ,name) (aref ,name 0)) + ;; but that would suffer from some problems: + ;; - the vector may have size 0. + ;; - when called on an actual vector (rather than an object), we'd + ;; end up returning an arbitrary value, possibly colliding with + ;; other tagcode's values. + ;; - it can also result in returning all kinds of irrelevant + ;; values which would end up filling up the method-cache with + ;; lots of irrelevant/redundant entries. + ;; FIXME: We could speed this up by introducing a dedicated + ;; vector type at the C level, so we could do something like + ;; (and (vector-objectp ,name) (aref ,name 0)) + `(50 . ,(cl--generic-struct-tag name)))) (add-function :before-until cl-generic-tag-types-function #'cl--generic-struct-tag-types) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 38f15b89b0e..eaec2c5263c 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -221,7 +221,7 @@ The name is made by appending a number to PREFIX, default \"G\"." '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) (defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) -(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms) +(defvar cl--bind-lets) (defvar cl--bind-forms) (defun cl--transform-lambda (form bind-block) "Transform a function form FORM of name BIND-BLOCK. @@ -229,9 +229,11 @@ BIND-BLOCK is the name of the symbol to which the function will be bound, and which will be used for the name of the `cl-block' surrounding the function's body. FORM is of the form (ARGS . BODY)." + ;; FIXME: (lambda (a &aux b) 1) expands to (lambda (a &rest --cl-rest--) ...) + ;; where the --cl-rest-- is clearly undesired. (let* ((args (car form)) (body (cdr form)) (orig-args args) (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) - (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) + (cl--bind-lets nil) (cl--bind-forms nil) (header nil) (simple-args nil)) (while (or (stringp (car body)) (memq (car-safe (car body)) '(interactive declare cl-declare))) @@ -244,10 +246,10 @@ FORM is of the form (ARGS . BODY)." (if (setq cl--bind-enquote (memq '&cl-quote args)) (setq args (delq '&cl-quote args))) (if (memq '&whole args) (error "&whole not currently implemented")) - (let* ((p (memq '&environment args)) (v (cadr p)) - (env-exp 'macroexpand-all-environment)) + (let* ((p (memq '&environment args)) + (v (cadr p))) (if p (setq args (nconc (delq (car p) (delq v args)) - (list '&aux (list v env-exp)))))) + `(&aux (,v macroexpand-all-environment)))))) (while (and args (symbolp (car args)) (not (memq (car args) '(nil &rest &body &key &aux))) (not (and (eq (car args) '&optional) @@ -261,8 +263,7 @@ FORM is of the form (ARGS . BODY)." (cl--do-arglist args nil (- (length simple-args) (if (memq '&optional simple-args) 1 0))) (setq cl--bind-lets (nreverse cl--bind-lets)) - (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) - ,@(nreverse cl--bind-inits))) + (cl-list* nil (nconc (nreverse simple-args) (list '&rest (car (pop cl--bind-lets)))) (nconc (let ((hdr (nreverse header))) @@ -390,6 +391,11 @@ its argument list allows full Common Lisp conventions." (t x))) (defun cl--make-usage-args (arglist) + (let ((aux (ignore-errors (cl-position '&aux arglist)))) + (when aux + ;; `&aux' args aren't arguments, so let's just drop them from the + ;; usage info. + (setq arglist (cl-subseq arglist 0 aux)))) (if (cdr-safe (last arglist)) ;Not a proper list. (let* ((last (last arglist)) (tail (cdr last))) @@ -426,7 +432,7 @@ its argument list allows full Common Lisp conventions." )))) arglist)))) -(defun cl--do-arglist (args expr &optional num) ; uses bind-* +(defun cl--do-arglist (args expr &optional num) ; uses cl--bind-* (if (nlistp args) (if (or (memq args cl--lambda-list-keywords) (not (symbolp args))) (error "Invalid argument name: %s" args) @@ -441,9 +447,9 @@ its argument list allows full Common Lisp conventions." (keys nil) (laterarg nil) (exactarg nil) minarg) (or num (setq num 0)) - (if (listp (cadr restarg)) - (setq restarg (make-symbol "--cl-rest--")) - (setq restarg (cadr restarg))) + (setq restarg (if (listp (cadr restarg)) + (make-symbol "--cl-rest--") + (cadr restarg))) (push (list restarg expr) cl--bind-lets) (if (eq (car args) '&whole) (push (list (cl--pop2 args) restarg) cl--bind-lets)) @@ -570,12 +576,11 @@ its argument list allows full Common Lisp conventions." "Bind the variables in ARGS to the result of EXPR and execute BODY." (declare (indent 2) (debug (&define cl-macro-list def-form cl-declarations def-body))) - (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-inits nil) + (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-defs nil) (cl--bind-block 'cl-none) (cl--bind-enquote nil)) (cl--do-arglist (or args '(&aux)) expr) - (append '(progn) cl--bind-inits - (list `(let* ,(nreverse cl--bind-lets) - ,@(nreverse cl--bind-forms) ,@body))))) + (macroexp-let* (nreverse cl--bind-lets) + (macroexp-progn (append (nreverse cl--bind-forms) body))))) ;;; The `cl-eval-when' form. @@ -655,30 +660,26 @@ allowed only in the final clause, and matches if no other keys match. Key values are compared by `eql'. \n(fn EXPR (KEYLIST BODY...)...)" (declare (indent 1) (debug (form &rest (sexp body)))) - (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) - (head-list nil) - (body (cons - 'cond - (mapcar - (function - (lambda (c) - (cons (cond ((memq (car c) '(t otherwise)) t) - ((eq (car c) 'cl--ecase-error-flag) - `(error "cl-ecase failed: %s, %s" - ,temp ',(reverse head-list))) - ((listp (car c)) - (setq head-list (append (car c) head-list)) - `(cl-member ,temp ',(car c))) - (t - (if (memq (car c) head-list) - (error "Duplicate key in case: %s" - (car c))) - (push (car c) head-list) - `(eql ,temp ',(car c)))) - (or (cdr c) '(nil))))) - clauses)))) - (if (eq temp expr) body - `(let ((,temp ,expr)) ,body)))) + (macroexp-let2 macroexp-copyable-p temp expr + (let* ((head-list nil)) + `(cond + ,@(mapcar + (lambda (c) + (cons (cond ((memq (car c) '(t otherwise)) t) + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-ecase failed: %s, %s" + ,temp ',(reverse head-list))) + ((listp (car c)) + (setq head-list (append (car c) head-list)) + `(cl-member ,temp ',(car c))) + (t + (if (memq (car c) head-list) + (error "Duplicate key in case: %s" + (car c))) + (push (car c) head-list) + `(eql ,temp ',(car c)))) + (or (cdr c) '(nil)))) + clauses))))) ;;;###autoload (defmacro cl-ecase (expr &rest clauses) @@ -698,24 +699,22 @@ final clause, and matches if no other keys match. \n(fn EXPR (TYPE BODY...)...)" (declare (indent 1) (debug (form &rest ([&or cl-type-spec "otherwise"] body)))) - (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) - (type-list nil) - (body (cons - 'cond - (mapcar - (function - (lambda (c) - (cons (cond ((eq (car c) 'otherwise) t) - ((eq (car c) 'cl--ecase-error-flag) - `(error "cl-etypecase failed: %s, %s" - ,temp ',(reverse type-list))) - (t - (push (car c) type-list) - (cl--make-type-test temp (car c)))) - (or (cdr c) '(nil))))) - clauses)))) - (if (eq temp expr) body - `(let ((,temp ,expr)) ,body)))) + (macroexp-let2 macroexp-copyable-p temp expr + (let* ((type-list nil)) + (cons + 'cond + (mapcar + (function + (lambda (c) + (cons (cond ((eq (car c) 'otherwise) t) + ((eq (car c) 'cl--ecase-error-flag) + `(error "cl-etypecase failed: %s, %s" + ,temp ',(reverse type-list))) + (t + (push (car c) type-list) + `(cl-typep ,temp ',(car c)))) + (or (cdr c) '(nil))))) + clauses))))) ;;;###autoload (defmacro cl-etypecase (expr &rest clauses) @@ -1439,16 +1438,14 @@ For more details, see Info node `(cl)Loop Facility'. (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) ((memq word '(minimize minimizing maximize maximizing)) - (let* ((what (pop cl--loop-args)) - (temp (if (cl--simple-expr-p what) what - (make-symbol "--cl-var--"))) - (var (cl--loop-handle-accum nil)) - (func (intern (substring (symbol-name word) 0 3))) - (set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) - (push `(progn ,(if (eq temp what) set - `(let ((,temp ,what)) ,set)) - t) - cl--loop-body))) + (push `(progn ,(macroexp-let2 macroexp-copyable-p temp + (pop cl--loop-args) + (let* ((var (cl--loop-handle-accum nil)) + (func (intern (substring (symbol-name word) + 0 3)))) + `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) + t) + cl--loop-body)) ((eq word 'with) (let ((bindings nil)) @@ -2104,14 +2101,11 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (< cl--optimize-speed 3) (= cl--optimize-safety 3))) form - (let* ((temp (if (cl--simple-expr-p form 3) - form (make-symbol "--cl-var--"))) - (body `(progn (unless ,(cl--make-type-test temp type) - (signal 'wrong-type-argument - (list ',type ,temp ',form))) - ,temp))) - (if (eq temp form) body - `(let ((,temp ,form)) ,body))))) + (macroexp-let2 macroexp-copyable-p temp form + `(progn (unless (cl-typep ,temp ',type) + (signal 'wrong-type-argument + (list ',type ,temp ',form))) + ,temp)))) (defvar cl--proclaim-history t) ; for future compilers (defvar cl--declare-stack t) ; for future compilers @@ -2425,15 +2419,11 @@ non-nil value, that slot cannot be set via `setf'. (tag (intern (format "cl-struct-%s" name))) (tag-symbol (intern (format "cl-struct-%s-tags" name))) (include-descs nil) - (side-eff nil) (type nil) (named nil) (forms nil) + (docstring (if (stringp (car descs)) (pop descs))) pred-form pred-check) - (if (stringp (car descs)) - (push `(put ',name 'structure-documentation - ,(pop descs)) - forms)) (setq descs (cons '(cl-tag-slot) (mapcar (function (lambda (x) (if (consp x) x (list x)))) descs))) @@ -2458,6 +2448,7 @@ non-nil value, that slot cannot be set via `setf'. ((eq opt :predicate) (if args (setq predicate (car args)))) ((eq opt :include) + (when include (error "Can't :include more than once")) (setq include (car args) include-descs (mapcar (function (lambda (x) @@ -2511,20 +2502,19 @@ non-nil value, that slot cannot be set via `setf'. (if named (setq tag name))) (setq type 'vector named 'true))) (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) - (push `(defvar ,tag-symbol) forms) (when (and (null predicate) named) (setq predicate (intern (format "cl--struct-%s-p" name)))) (setq pred-form (and named (let ((pos (- (length descs) (length (memq (assq 'cl-tag-slot descs) descs))))) - (if (eq type 'vector) - `(and (vectorp cl-x) - (>= (length cl-x) ,(length descs)) - (memq (aref cl-x ,pos) ,tag-symbol)) - (if (= pos 0) - `(memq (car-safe cl-x) ,tag-symbol) - `(and (consp cl-x) + (cond + ((eq type 'vector) + `(and (vectorp cl-x) + (>= (length cl-x) ,(length descs)) + (memq (aref cl-x ,pos) ,tag-symbol))) + ((= pos 0) `(memq (car-safe cl-x) ,tag-symbol)) + (t `(and (consp cl-x) (memq (nth ,pos cl-x) ,tag-symbol)))))) pred-check (and pred-form (> safety 0) (if (and (eq (cl-caadr pred-form) 'vectorp) @@ -2546,6 +2536,7 @@ non-nil value, that slot cannot be set via `setf'. (push slot slots) (push (nth 1 desc) defaults) (push `(cl-defsubst ,accessor (cl-x) + (declare (side-effect-free t)) ,@(and pred-check (list `(or ,pred-check (error "%s accessing a non-%s" @@ -2554,7 +2545,6 @@ non-nil value, that slot cannot be set via `setf'. (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))) forms) - (push (cons accessor t) side-eff) (if (cadr (memq :read-only (cddr desc))) (push `(gv-define-expander ,accessor (lambda (_cl-do _cl-x) @@ -2587,15 +2577,14 @@ non-nil value, that slot cannot be set via `setf'. defaults (nreverse defaults)) (when pred-form (push `(cl-defsubst ,predicate (cl-x) + (declare (side-effect-free error-free)) ,(if (eq (car pred-form) 'and) (append pred-form '(t)) `(and ,pred-form t))) forms) - (push `(put ',name 'cl-deftype-satisfies ',predicate) forms) - (push (cons predicate 'error-free) side-eff)) + (push `(put ',name 'cl-deftype-satisfies ',predicate) forms)) (and copier - (progn (push `(defun ,copier (x) (copy-sequence x)) forms) - (push (cons copier t) side-eff))) + (push `(defalias ',copier #'copy-sequence) forms)) (if constructor (push (list constructor (cons '&key (delq nil (copy-sequence slots)))) @@ -2607,11 +2596,11 @@ non-nil value, that slot cannot be set via `setf'. (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) (push `(cl-defsubst ,name - (&cl-defs '(nil ,@descs) ,@args) + (&cl-defs '(nil ,@descs) ,@args) + ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) + '((declare (side-effect-free t)))) (,type ,@make)) - forms) - (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) - (push (cons name t) side-eff)))) + forms))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) ;; Don't bother adding to cl-custom-print-functions since it's not used ;; by anything anyway! @@ -2624,17 +2613,14 @@ non-nil value, that slot cannot be set via `setf'. ;; (and ,pred-form ,print-func)) ;; cl-custom-print-functions)) ;; forms)) - (push `(setq ,tag-symbol (list ',tag)) forms) - (push `(cl-eval-when (compile load eval) - (put ',name 'cl-struct-slots ',descs) - (put ',name 'cl-struct-type ',(list type (eq named t))) - (put ',name 'cl-struct-include ',include) - (put ',name 'cl-struct-print ,print-auto) - ,@(mapcar (lambda (x) - `(function-put ',(car x) 'side-effect-free ',(cdr x))) - side-eff)) - forms) - `(progn ,@(nreverse (cons `',name forms))))) + `(progn + (defvar ,tag-symbol) + ,@(nreverse forms) + (eval-and-compile + (cl-struct-define ',name ,docstring ',include + ',type ,(eq named t) ',descs ',tag-symbol ',tag + ',print-auto)) + ',name))) (defun cl-struct-sequence-type (struct-type) "Return the sequence used to build STRUCT-TYPE. @@ -2741,14 +2727,11 @@ STRING is an optional description of the desired type." (declare (debug (place cl-type-spec &optional stringp))) (and (or (not (cl--compiling-file)) (< cl--optimize-speed 3) (= cl--optimize-safety 3)) - (let* ((temp (if (cl--simple-expr-p form 3) - form (make-symbol "--cl-var--"))) - (body `(or ,(cl--make-type-test temp type) - (signal 'wrong-type-argument - (list ,(or string `',type) - ,temp ',form))))) - (if (eq temp form) `(progn ,body nil) - `(let ((,temp ,form)) ,body nil))))) + (macroexp-let2 macroexp-copyable-p temp form + `(progn (or (cl-typep ,temp ',type) + (signal 'wrong-type-argument + (list ,(or string `',type) ,temp ',form))) + nil)))) ;;;###autoload (defmacro cl-assert (form &optional show-args string &rest args) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el new file mode 100644 index 00000000000..c9867b412a1 --- /dev/null +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -0,0 +1,48 @@ +;;; cl-preloaded.el --- Preloaded part of the CL library -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; The expectation is that structs defined with cl-defstruct do not +;; need cl-lib at run-time, but we'd like to hide the details of the +;; cl-struct metadata behind the cl-struct-define function, so we put +;; it in this pre-loaded file. + +;;; Code: + +(defun cl-struct-define (name docstring parent type named slots children-sym + tag print-auto) + (if (boundp children-sym) + (add-to-list children-sym tag) + (set children-sym (list tag))) + ;; If the cl-generic support, we need to be able to check + ;; if a vector is a cl-struct object, without knowing its particular type. + ;; So we use the (otherwise) unused function slots of the tag symbol + ;; to put a special witness value, to make the check easy and reliable. + (unless named (fset tag :quick-object-witness-check)) + (put name 'cl-struct-slots slots) + (put name 'cl-struct-type (list type named)) + (if parent (put name 'cl-struct-include parent)) + (if print-auto (put name 'cl-struct-print print-auto)) + (if docstring (put name 'structure-documentation docstring))) + +(provide 'cl-preloaded) +;;; cl-preloaded.el ends here diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 1cd7bd76b0e..5da1cea6bb3 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -376,7 +376,6 @@ The two cases that are handled are: (setq cl--function-convert-cache (cons newf res)) res)))) (t - (setq cl--labels-convert-cache cl--function-convert-cache) (cl--labels-convert f)))) (defmacro lexical-let (bindings &rest body) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 7e6f56518a2..f7e8619948a 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -149,11 +149,12 @@ For example, you could write ...BODY CODE...)" (declare (doc-string 2) (debug (&define name string-or-null-p - [&optional [¬ keywordp] sexp - &optional [¬ keywordp] sexp - &optional [¬ keywordp] sexp] - [&rest [keywordp sexp]] - def-body))) + [&optional [¬ keywordp] sexp + &optional [¬ keywordp] sexp + &optional [¬ keywordp] sexp] + [&rest [keywordp sexp]] + def-body)) + (indent 1)) ;; Allow skipping the first three args. (cond diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index feb06711cb3..46585ee76c6 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 7492f0522ab..77d8c01388b 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) - (condition-case nil - (eq (aref (eieio--object-class-object obj) 0) 'defclass) - (error nil)))) + (> (length obj) 0) + (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))) @@ -539,6 +533,7 @@ See `defclass' for more information." ;; objects readable. (tag (intern (format "eieio-class-tag--%s" cname)))) (set tag newc) + (fset tag :quick-object-witness-check) (setf (eieio--object-class-tag cache) tag) (let ((eieio-skip-typecheck t)) ;; All type-checking has been done to our satisfaction @@ -908,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) @@ -928,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))) @@ -974,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) @@ -999,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. @@ -1222,10 +1218,11 @@ 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) - ;; 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))))) + (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. + `(50 . ,(cl--generic-struct-tag name)))) (add-function :before-until cl-generic-tag-types-function #'eieio--generic-tag-types) diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 119f7cce038..82349192e5e 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 8d40edf5624..304ee364dc8 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 91469b4b96c..526090954a9 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" "\ |