From: Stefan Monnier Date: Thu, 16 Mar 2017 02:48:28 +0000 (-0400) Subject: Make EIEIO use records. X-Git-Tag: emacs-26.0.90~521^2~735 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=8e6f204f44b6183ba73c7d1bec5841f2b7b8bdd0;p=emacs.git Make EIEIO use records. * lisp/emacs-lisp/eieio-compat.el (eieio--generic-static-object-generalizer): Adjust to new tags. * lisp/emacs-lisp/eieio-core.el: Use records, and place the class object directly as tag. (eieio--object-class): Adjust to new tag representation. (eieio-object-p): Rewrite, and adapt to new `type-of' behavior. (eieio-defclass-internal): Use `make-record'. (eieio--generic-generalizer): Adjust generalizer code accordingly. * lisp/emacs-lisp/eieio.el (make-instance, clone): Use copy-record. * lisp/emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates): Add `recordp'. * doc/lispref/records.texi, doc/misc/eieio.texi: Update for records. --- diff --git a/doc/lispref/records.texi b/doc/lispref/records.texi index 618f30a72ce..822fd2bf36e 100644 --- a/doc/lispref/records.texi +++ b/doc/lispref/records.texi @@ -9,7 +9,8 @@ The purpose of records is to allow programmers to create objects with new types that are not built into Emacs. They are used as the -underlying representation of @code{cl-defstruct} instances. +underlying representation of @code{cl-defstruct} and @code{defclass} +instances. Internally, a record object is much like a vector; its slots can be accessed using @code{aref}. However, the first slot is used to hold diff --git a/doc/misc/eieio.texi b/doc/misc/eieio.texi index dfae565deed..7076c244222 100644 --- a/doc/misc/eieio.texi +++ b/doc/misc/eieio.texi @@ -1017,7 +1017,7 @@ If @var{errorp} is non-@code{nil}, @code{wrong-argument-type} is signaled. @defun class-p class @anchor{class-p} -Return @code{t} if @var{class} is a valid class vector. +Return @code{t} if @var{class} is a valid class object. @var{class} is a symbol. @end defun @@ -1055,7 +1055,7 @@ Will fetch the documentation string for @code{eieio-default-superclass}. Return a string of the form @samp{#} for @var{obj}. This should look like Lisp symbols from other parts of Emacs such as buffers and processes, and is shorter and cleaner than printing the -object's vector. It is more useful to use @code{object-print} to get +object's record. It is more useful to use @code{object-print} to get and object's print form, as this allows the object to add extra display information into the symbol. @end defun @@ -1212,7 +1212,7 @@ items defined in this second slot. Introspection permits a programmer to peek at the contents of a class without any previous knowledge of that class. While @eieio{} implements -objects on top of vectors, and thus everything is technically visible, +objects on top of records, and thus everything is technically visible, some functions have been provided. None of these functions are a part of CLOS. @@ -1525,7 +1525,7 @@ Currently, the default superclass is defined as follows: nil "Default parent class for classes with no specified parent class. Its slots are automatically adopted by classes with no specified -parents. This class is not stored in the `parent' slot of a class vector." +parents. This class is not stored in the `parent' slot of a class object." :abstract t) @end example diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 986d0285172..33c71ec5807 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -294,8 +294,7 @@ Second, any text properties will be stripped from strings." (cond ((consp proposed-value) ;; Lists with something in them need special treatment. (let* ((slot-idx (- (eieio--slot-name-index class slot) - (eval-when-compile - (length (cl-struct-slot-info 'eieio--object))))) + (eval-when-compile eieio--object-num-slots))) (type (cl--slot-descriptor-type (aref (eieio--class-slots class) slot-idx))) (classtype (eieio-persistent-slot-type-is-class-p type))) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 888d85f6038..d6eb0b416f8 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -145,7 +145,7 @@ Summary: ;; interleaved list comes before the class's non-interleaved list. 51 #'cl--generic-struct-tag (lambda (tag &rest _) - (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag)) + (and (symbolp tag) (setq tag (cl--find-class tag)) (eieio--class-p tag) (let ((superclasses (eieio--class-precedence-list tag)) (specializers ())) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 5cc6d020eaf..c59f85d6fb2 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -108,21 +108,14 @@ Currently under control of this var: (cl-declaim (optimize (safety 1)))) -(cl-defstruct (eieio--object - (:type vector) ;We manage our own tagging system. - (:constructor nil) - (:copier nil)) - ;; `class-tag' holds a symbol, which is not the class name, but is instead - ;; properly prefixed as an internal EIEIO thingy and which holds the class - ;; object/struct in its `symbol-value' slot. - class-tag) +(eval-and-compile + (defconst eieio--object-num-slots 1)) -(eval-when-compile - (defconst eieio--object-num-slots - (length (cl-struct-slot-info 'eieio--object)))) +(defsubst eieio--object-class-tag (obj) + (aref obj 0)) (defsubst eieio--object-class (obj) - (symbol-value (eieio--object-class-tag obj))) + (eieio--object-class-tag obj)) ;;; Important macros used internally in eieio. @@ -166,13 +159,8 @@ Return nil if that option doesn't exist." (defun eieio-object-p (obj) "Return non-nil if OBJ is an EIEIO object." - (and (vectorp obj) - (> (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)))))) + (and (recordp obj) + (eieio--class-p (eieio--object-class-tag obj)))) (define-obsolete-function-alias 'object-p 'eieio-object-p "25.1") @@ -496,18 +484,11 @@ See `defclass' for more information." (if clearparent (setf (eieio--class-parents newc) nil)) ;; Create the cached default object. - (let ((cache (make-vector (+ (length (eieio--class-slots newc)) - (eval-when-compile eieio--object-num-slots)) - nil)) - ;; We don't strictly speaking need to use a symbol, but the old - ;; code used the class's name rather than the class's object, so - ;; we follow this preference for using a symbol, which is probably - ;; convenient to keep the printed representation of such Elisp - ;; 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 ((cache (make-record newc + (+ (length (eieio--class-slots newc)) + (eval-when-compile eieio--object-num-slots) + -1) + nil))) (let ((eieio-skip-typecheck t)) ;; All type-checking has been done to our satisfaction ;; before this call. Don't waste our time in this call.. @@ -1060,9 +1041,10 @@ method invocation orders of the involved classes." ;; part of the dispatch code. 50 #'cl--generic-struct-tag (lambda (tag &rest _) - (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) - (mapcar #'eieio--class-name - (eieio--class-precedence-list (symbol-value tag)))))) + (let ((class (cl--find-class tag))) + (and (eieio--class-p class) + (mapcar #'eieio--class-name + (eieio--class-precedence-list class)))))) (cl-defmethod cl-generic-generalizers :extra "class" (specializer) "Support for dispatch on types defined by EIEIO's `defclass'." diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 1a6d5e9d7c1..858b2fdaa04 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -337,14 +337,12 @@ variable name of the same name as the slot." ;; hard-coded in random .elc files. (defun eieio-pcase-slot-index-table (obj) "Return some data structure from which can be extracted the slot offset." - (eieio--class-index-table - (symbol-value (eieio--object-class-tag obj)))) + (eieio--class-index-table (eieio--object-class obj))) (defun eieio-pcase-slot-index-from-index-table (index-table slot) "Find the index to pass to `aref' to access SLOT." (let ((index (gethash slot index-table))) - (if index (+ (eval-when-compile - (length (cl-struct-slot-info 'eieio--object))) + (if index (+ (eval-when-compile eieio--object-num-slots) index)))) (pcase-defmacro eieio (&rest fields) @@ -701,8 +699,8 @@ SLOTS are the initialization slots used by `initialize-instance'. This static method is called when an object is constructed. It allocates the vector used to represent an EIEIO object, and then calls `initialize-instance' on that object." - (let* ((new-object (copy-sequence (eieio--class-default-object-cache - (eieio--class-object class))))) + (let* ((new-object (copy-record (eieio--class-default-object-cache + (eieio--class-object class))))) (if (and slots (let ((x (car slots))) (or (stringp x) (null x)))) @@ -806,7 +804,7 @@ first and modify the returned object.") (cl-defmethod clone ((obj eieio-default-superclass) &rest params) "Make a copy of OBJ, and then apply PARAMS." - (let ((nobj (copy-sequence obj))) + (let ((nobj (copy-record obj))) (if (stringp (car params)) (funcall (if eieio-backward-compatibility #'ignore #'message) "Obsolete name %S passed to clone" (pop params))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index fc5474ecc43..4a06ab25d3e 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -503,24 +503,30 @@ MATCH is the pattern that needs to be matched, of the form: (symbolp . vectorp) (symbolp . stringp) (symbolp . byte-code-function-p) + (symbolp . recordp) (integerp . consp) (integerp . arrayp) (integerp . vectorp) (integerp . stringp) (integerp . byte-code-function-p) + (integerp . recordp) (numberp . consp) (numberp . arrayp) (numberp . vectorp) (numberp . stringp) (numberp . byte-code-function-p) + (numberp . recordp) (consp . arrayp) (consp . atom) (consp . vectorp) (consp . stringp) (consp . byte-code-function-p) + (consp . recordp) (arrayp . byte-code-function-p) (vectorp . byte-code-function-p) + (vectorp . recordp) (stringp . vectorp) + (stringp . recordp) (stringp . byte-code-function-p))) (defun pcase--mutually-exclusive-p (pred1 pred2)