Commit 50c117fe authored by Stefan Monnier's avatar Stefan Monnier
Browse files

EIEIO: Change class's representation to unify instance & class slots

* lisp/emacs-lisp/eieio-core.el (eieio--class): Change field names and order
to match those of cl--class; use cl--slot for both instance slots and
class slots.
(eieio--object-num-slots): Use cl-struct-slot-info.
(eieio--object-class): Rename from eieio--object-class-object.
(eieio--object-class-name): Remove.
(eieio-defclass-internal): Adjust to new slot representation.
Store doc in class rather than in `variable-documentation'.
(eieio--perform-slot-validation-for-default): Change API to take
a slot object.
(eieio--slot-override): New function.
(eieio--add-new-slot): Rewrite.
(eieio-copy-parents-into-subclass): Rewrite.
(eieio--validate-slot-value, eieio--validate-class-slot-value)
(eieio-oref-default, eieio-oset-default)
(eieio--class-slot-name-index, eieio-set-defaults): Adjust to new
slot representation.
(eieio--c3-merge-lists): Simplify.
(eieio--class/struct-parents): New function.
(eieio--class-precedence-bfs): Use it.

* lisp/emacs-lisp/eieio.el (with-slots): Use macroexp-let2.
(object-class-fast): Change recommend replacement.
(eieio-object-class): Rewrite.
(slot-exists-p): Adjust to new slot representation.
(initialize-instance): Adjust to new slot representation.
(object-write): Adjust to new slot representation.

* lisp/emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object):
Manually map initargs to slot names.
(eieio-persistent-validate/fix-slot-value): Adjust to new
slot representation.

* lisp/emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-specializers):
Extract from eieio--generic-static-symbol-generalizer.
(eieio--generic-static-symbol-generalizer): Use it.

* lisp/emacs-lisp/eieio-custom.el (eieio-object-value-create)
(eieio-object-value-get): Adjust to new slot representation.

* lisp/emacs-lisp/eieio-datadebug.el (data-debug/eieio-insert-slots):
Declare to silence warnings.
(data-debug-insert-object-button): Avoid `object-slots'.
(data-debug/eieio-insert-slots): Adjust to new slot representation.

* lisp/emacs-lisp/eieio-opt.el (eieio--help-print-slot): New function
extracted from eieio-help-class-slots.
(eieio-help-class-slots): Use it.  Adjust to new slot representation.

* test/automated/eieio-test-methodinvoke.el (make-instance): Use new-style
`subclass' specializer for a change.

* test/automated/eieio-test-persist.el (persist-test-save-and-compare):
Adjust to new slot representation.

* test/automated/eieio-tests.el (eieio-test-17-virtual-slot): Don't use
initarg in `oset'.
(eieio-test-32-slot-attribute-override-2): Adjust to new
slot representation.

* lisp/emacs-lisp/cl-preloaded.el (cl--class): Fix type of `parents'.
parent f469024e
2015-03-19 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/eieio.el (with-slots): Use macroexp-let2.
(object-class-fast): Change recommend replacement.
(eieio-object-class): Rewrite.
(slot-exists-p): Adjust to new slot representation.
(initialize-instance): Adjust to new slot representation.
(object-write): Adjust to new slot representation.
* emacs-lisp/eieio-opt.el (eieio--help-print-slot): New function
extracted from eieio-help-class-slots.
(eieio-help-class-slots): Use it. Adjust to new slot representation.
* emacs-lisp/eieio-datadebug.el (data-debug/eieio-insert-slots):
Declare to silence warnings.
(data-debug-insert-object-button): Avoid `object-slots'.
(data-debug/eieio-insert-slots): Adjust to new slot representation.
* emacs-lisp/eieio-custom.el (eieio-object-value-create)
(eieio-object-value-get): Adjust to new slot representation.
EIEIO: Change class's representation to unify instance and class slots
* emacs-lisp/eieio-core.el (eieio--class): Change field names and order
to match those of cl--class; use cl--slot for both instance slots and
class slots.
(eieio--object-num-slots): Use cl-struct-slot-info.
(eieio--object-class): Rename from eieio--object-class-object.
(eieio--object-class-name): Remove.
(eieio-defclass-internal): Adjust to new slot representation.
Store doc in class rather than in `variable-documentation'.
(eieio--perform-slot-validation-for-default): Change API to take
a slot object.
(eieio--slot-override): New function.
(eieio--add-new-slot): Rewrite.
(eieio-copy-parents-into-subclass): Rewrite.
(eieio--validate-slot-value, eieio--validate-class-slot-value)
(eieio-oref-default, eieio-oset-default)
(eieio--class-slot-name-index, eieio-set-defaults): Adjust to new
slot representation.
(eieio--c3-merge-lists): Simplify.
(eieio--class/struct-parents): New function.
(eieio--class-precedence-bfs): Use it.
* emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-specializers):
Extract from eieio--generic-static-symbol-generalizer.
(eieio--generic-static-symbol-generalizer): Use it.
* emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object):
Manually map initargs to slot names.
(eieio-persistent-validate/fix-slot-value): Adjust to new
slot representation.
* emacs-lisp/cl-preloaded.el (cl--class): Fix type of `parents'.
2015-03-19 Vibhav Pant <vibhavp@gmail.com>
 
* lisp/leim/quail/hangul.el
......
......@@ -212,7 +212,9 @@
;; Intended to be shared between defstruct and defclass.
(name nil :type symbol) ;The type name.
(docstring nil :type string)
(parents nil :type (or cl--class (list-of cl--class)))
;; For structs there can only be one parent, but when EIEIO classes inherit
;; from cl--class, we'll need this to hold a list.
(parents nil :type (list-of cl--class))
(slots nil :type (vector cl-slot-descriptor))
(index-table nil :type hash-table))
......
......@@ -254,25 +254,28 @@ malicious code.
Note: This function recurses when a slot of :type of some object is
identified, and needing more object creation."
(let ((objclass (nth 0 inputlist))
;; (objname (nth 1 inputlist))
(slots (nthcdr 2 inputlist))
(createslots nil))
;; If OBJCLASS is an eieio autoload object, then we need to load it.
(eieio-class-un-autoload objclass)
(let* ((objclass (nth 0 inputlist))
;; (objname (nth 1 inputlist))
(slots (nthcdr 2 inputlist))
(createslots nil)
(class
(progn
;; If OBJCLASS is an eieio autoload object, then we need to
;; load it.
(eieio-class-un-autoload objclass)
(eieio--class-object objclass))))
(while slots
(let ((name (car slots))
(let ((initarg (car slots))
(value (car (cdr slots))))
;; Make sure that the value proposed for SLOT is valid.
;; In addition, strip out quotes, list functions, and update
;; object constructors as needed.
(setq value (eieio-persistent-validate/fix-slot-value
(eieio--class-v objclass) name value))
class (eieio--initarg-to-attribute class initarg) value))
(push name createslots)
(push initarg createslots)
(push value createslots)
)
......@@ -290,16 +293,11 @@ constructor functions are considered valid.
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))
(type nil)
(classtype nil))
(setq slot-idx (- slot-idx
(let* ((slot-idx (- (eieio--slot-name-index class slot)
(eval-when-compile eieio--object-num-slots)))
(setq type (aref (eieio--class-public-type class)
slot-idx))
(setq classtype (eieio-persistent-slot-type-is-class-p
type))
(type (cl--slot-descriptor-type (aref (eieio--class-slots class)
slot-idx)))
(classtype (eieio-persistent-slot-type-is-class-p type)))
(cond ((eq (car proposed-value) 'quote)
(car (cdr proposed-value)))
......
......@@ -124,19 +124,22 @@ Summary:
(defgeneric ,method ,args)
(eieio--defmethod ',method ',key ',class #',code))))
(defun eieio--generic-static-symbol-specializers (tag)
(cl-assert (or (null tag) (eieio--class-p tag)))
(when (eieio--class-p tag)
(let ((superclasses (eieio--generic-subclass-specializers tag))
(specializers ()))
(dolist (superclass superclasses)
(push superclass specializers)
(push `(eieio--static ,(cadr superclass)) specializers))
(nreverse specializers))))
(defconst eieio--generic-static-symbol-generalizer
(cl-generic-make-generalizer
;; Give it a slightly higher priority than `subclass' so that the
;; interleaved list comes before subclass's non-interleaved list.
61 (lambda (name) `(and (symbolp ,name) (eieio--class-v ,name)))
(lambda (tag)
(when (eieio--class-p tag)
(let ((superclasses (eieio--generic-subclass-specializers tag))
(specializers ()))
(dolist (superclass superclasses)
(push superclass specializers)
(push `(eieio--static ,(cadr superclass)) specializers))
(nreverse specializers))))))
#'eieio--generic-static-symbol-specializers))
(defconst eieio--generic-static-object-generalizer
(cl-generic-make-generalizer
;; Give it a slightly higher priority than `class' so that the
......@@ -148,7 +151,7 @@ Summary:
(let ((superclasses (eieio--class-precedence-list tag))
(specializers ()))
(dolist (superclass superclasses)
(setq superclass (eieio--class-symbol superclass))
(setq superclass (eieio--class-name superclass))
(push superclass specializers)
(push `(eieio--static ,superclass) specializers))
(nreverse specializers))))))
......
This diff is collapsed.
......@@ -193,12 +193,8 @@ Optional argument IGNORE is an extraneous parameter."
(let* ((chil nil)
(obj (widget-get widget :value))
(master-group (widget-get widget :eieio-group))
(cv (eieio--object-class-object obj))
(slots (eieio--class-public-a cv))
(flabel (eieio--class-public-custom-label cv))
(fgroup (eieio--class-public-custom-group cv))
(fdoc (eieio--class-public-doc cv))
(fcust (eieio--class-public-custom cv)))
(cv (eieio--object-class obj))
(slots (eieio--class-slots cv)))
;; First line describes the object, but may not editable.
(if (widget-get widget :eieio-show-name)
(setq chil (cons (widget-create-child-and-convert
......@@ -208,7 +204,7 @@ Optional argument IGNORE is an extraneous parameter."
chil)))
;; Display information about the group being shown
(when master-group
(let ((groups (eieio--class-option (eieio--object-class-object obj)
(let ((groups (eieio--class-option (eieio--object-class obj)
:custom-groups)))
(widget-insert "Groups:")
(while groups
......@@ -225,63 +221,59 @@ Optional argument IGNORE is an extraneous parameter."
(setq groups (cdr groups)))
(widget-insert "\n\n")))
;; Loop over all the slots, creating child widgets.
(while slots
;; Output this slot if it has a customize flag associated with it.
(when (and (car fcust)
(or (not master-group) (member master-group (car fgroup)))
(slot-boundp obj (car slots)))
;; In this case, this slot has a custom type. Create its
;; children widgets.
(let ((type (eieio-filter-slot-type widget (car fcust)))
(stuff nil))
;; This next bit is an evil hack to get some EDE functions
;; working the way I like.
(if (and (listp type)
(setq stuff (member :slotofchoices type)))
(let ((choices (eieio-oref obj (car (cdr stuff))))
(newtype nil))
(while (not (eq (car type) :slotofchoices))
(setq newtype (cons (car type) newtype)
type (cdr type)))
(while choices
(setq newtype (cons (list 'const (car choices))
newtype)
choices (cdr choices)))
(setq type (nreverse newtype))))
(setq chil (cons (widget-create-child-and-convert
widget 'object-slot
:childtype type
:sample-face 'eieio-custom-slot-tag-face
:tag
(concat
(make-string
(or (widget-get widget :indent) 0)
? )
(if (car flabel)
(car flabel)
(let ((s (symbol-name
(or
(eieio--class-slot-initarg
(eieio--object-class-object obj)
(car slots))
(car slots)))))
(capitalize
(if (string-match "^:" s)
(substring s (match-end 0))
s)))))
:value (slot-value obj (car slots))
:doc (if (car fdoc) (car fdoc)
"Slot not Documented.")
:eieio-custom-visibility 'visible
)
chil))
)
)
(setq slots (cdr slots)
fdoc (cdr fdoc)
fcust (cdr fcust)
flabel (cdr flabel)
fgroup (cdr fgroup)))
(dotimes (i (length slots))
(let* ((slot (aref slots i))
(props (cl--slot-descriptor-props slot)))
;; Output this slot if it has a customize flag associated with it.
(when (and (alist-get :custom props)
(or (not master-group)
(member master-group (alist-get :group props)))
(slot-boundp obj (cl--slot-descriptor-name slot)))
;; In this case, this slot has a custom type. Create its
;; children widgets.
(let ((type (eieio-filter-slot-type widget (alist-get :custom props)))
(stuff nil))
;; This next bit is an evil hack to get some EDE functions
;; working the way I like.
(if (and (listp type)
(setq stuff (member :slotofchoices type)))
(let ((choices (eieio-oref obj (car (cdr stuff))))
(newtype nil))
(while (not (eq (car type) :slotofchoices))
(setq newtype (cons (car type) newtype)
type (cdr type)))
(while choices
(setq newtype (cons (list 'const (car choices))
newtype)
choices (cdr choices)))
(setq type (nreverse newtype))))
(setq chil (cons (widget-create-child-and-convert
widget 'object-slot
:childtype type
:sample-face 'eieio-custom-slot-tag-face
:tag
(concat
(make-string
(or (widget-get widget :indent) 0)
?\s)
(or (alist-get :label props)
(let ((s (symbol-name
(or
(eieio--class-slot-initarg
(eieio--object-class obj)
(car slots))
(car slots)))))
(capitalize
(if (string-match "^:" s)
(substring s (match-end 0))
s)))))
:value (slot-value obj (car slots))
:doc (or (alist-get :documentation props)
"Slot not Documented.")
:eieio-custom-visibility 'visible
)
chil))
))))
(widget-put widget :children (nreverse chil))
))
......@@ -289,34 +281,33 @@ Optional argument IGNORE is an extraneous parameter."
"Get the value of WIDGET."
(let* ((obj (widget-get widget :value))
(master-group eieio-cog)
(cv (eieio--object-class-object obj))
(fgroup (eieio--class-public-custom-group cv))
(wids (widget-get widget :children))
(name (if (widget-get widget :eieio-show-name)
(car (widget-apply (car wids) :value-inline))
nil))
(chil (if (widget-get widget :eieio-show-name)
(nthcdr 1 wids) wids))
(cv (eieio--object-class-object obj))
(slots (eieio--class-public-a cv))
(fcust (eieio--class-public-custom cv)))
(cv (eieio--object-class obj))
(i 0)
(slots (eieio--class-slots cv)))
;; If there are any prefix widgets, clear them.
;; -- None yet
;; Create a batch of initargs for each slot.
(while (and slots chil)
(if (and (car fcust)
(or eieio-custom-ignore-eieio-co
(not master-group) (member master-group (car fgroup)))
(slot-boundp obj (car slots)))
(progn
;; Only customized slots have widgets
(let ((eieio-custom-ignore-eieio-co t))
(eieio-oset obj (car slots)
(car (widget-apply (car chil) :value-inline))))
(setq chil (cdr chil))))
(setq slots (cdr slots)
fgroup (cdr fgroup)
fcust (cdr fcust)))
(while (and (< i (length slots)) chil)
(let* ((slot (aref slots i))
(props (cl--slot-descriptor-props slot))
(cust (alist-get :custom props)))
(if (and cust
(or eieio-custom-ignore-eieio-co
(not master-group)
(member master-group (alist-get :group props)))
(slot-boundp obj (cl--slot-descriptor-name slot)))
(progn
;; Only customized slots have widgets
(let ((eieio-custom-ignore-eieio-co t))
(eieio-oset obj (cl--slot-descriptor-name slot)
(car (widget-apply (car chil) :value-inline))))
(setq chil (cdr chil))))))
;; Set any name updates on it.
(if name (eieio-object-set-name-string obj name))
;; This is the same object we had before.
......@@ -452,7 +443,7 @@ Must return the created widget."
(vector (concat "Group " (symbol-name group))
(list 'customize-object obj (list 'quote group))
t))
(eieio--class-option (eieio--object-class-object obj) :custom-groups)))
(eieio--class-option (eieio--object-class obj) :custom-groups)))
(defvar eieio-read-custom-group-history nil
"History for the custom group reader.")
......@@ -460,7 +451,7 @@ Must return the created widget."
(cl-defmethod eieio-read-customization-group ((obj eieio-default-superclass))
"Do a completing read on the name of a customization group in OBJ.
Return the symbol for the group, or nil"
(let ((g (eieio--class-option (eieio--object-class-object obj)
(let ((g (eieio--class-option (eieio--object-class obj)
:custom-groups)))
(if (= (length g) 1)
(car g)
......
......@@ -31,6 +31,9 @@
;;; Code:
(declare-function data-debug/eieio-insert-slots "eieio-datadebug"
(obj eieio-default-superclass))
(defun data-debug-insert-object-slots (object prefix)
"Insert all the slots of OBJECT.
PREFIX specifies what to insert at the start of each line."
......@@ -54,16 +57,17 @@ PREFIX specifies what to insert at the start of each line."
"Insert a button representing OBJECT.
PREFIX is the text that precedes the button.
PREBUTTONTEXT is some text between PREFIX and the object button."
(let ((start (point))
(end nil)
(str (object-print object))
(tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots"
(eieio-object-name-string object)
(eieio-object-class object)
(eieio-class-parents (eieio-object-class object))
(length (object-slots object))
))
)
(let* ((start (point))
(end nil)
(str (object-print object))
(class (eieio-object-class object))
(tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots"
(eieio-object-name-string object)
class
(eieio-class-parents class)
(length (eieio-class-slots class))
))
)
(insert prefix prebuttontext str)
(setq end (point))
(put-text-property (- end (length str)) end 'face 'font-lock-keyword-face)
......@@ -80,41 +84,31 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
;; Each object should have an opportunity to show stuff about itself.
(cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
prefix)
prefix)
"Insert the slots of OBJ into the current DDEBUG buffer."
(let ((inhibit-read-only t))
(data-debug-insert-thing (eieio-object-name-string obj)
prefix
"Name: ")
(let* ((cl (eieio-object-class obj))
(cv (eieio--class-v cl)))
(data-debug-insert-thing (eieio--class-constructor cl)
(let* ((cv (eieio--object-class obj)))
(data-debug-insert-thing (eieio--class-name cv)
prefix
"Class: ")
;; Loop over all the public slots
(let ((publa (eieio--class-public-a cv))
)
(while publa
(if (slot-boundp obj (car publa))
(let* ((i (eieio--class-slot-initarg (eieio--class-v cl)
(car publa)))
(v (eieio-oref obj (car publa))))
(data-debug-insert-thing
v prefix (concat
(if i (symbol-name i)
(symbol-name (car publa)))
" ")))
;; Unbound case
(let ((i (eieio--class-slot-initarg (eieio--class-v cl)
(car publa))))
(data-debug-insert-custom
"#unbound" prefix
(concat (if i (symbol-name i)
(symbol-name (car publa)))
" ")
'font-lock-keyword-face))
)
(setq publa (cdr publa)))))))
(let ((slots (eieio--class-slots cv)))
(dotimes (i (length slots))
(let* ((slot (aref slots i))
(sname (cl--slot-descriptor-name slot))
(i (eieio--class-slot-initarg cv sname))
(sstr (concat (symbol-name (or i sname)) " ")))
(if (slot-boundp obj sname)
(let* ((v (eieio-oref obj sname)))
(data-debug-insert-thing v prefix sstr))
;; Unbound case
(data-debug-insert-custom
"#unbound" prefix sstr
'font-lock-keyword-face)
)))))))
;;; Augment the Data debug thing display list.
(data-debug-add-specialized-thing (lambda (thing) (eieio-object-p thing))
......
......@@ -99,7 +99,7 @@ If CLASS is actually an object, then also display current values of that object.
(when pl
(insert " Inherits from ")
(while (setq cur (pop pl))
(setq cur (eieio--class-symbol cur))
(setq cur (eieio--class-name cur))
(insert "`")
(help-insert-xref-button (symbol-name cur)
'help-function cur)
......@@ -136,74 +136,40 @@ If CLASS is actually an object, then also display current values of that object.
(or doc "")))
(insert "\n\n")))))
(defun eieio--help-print-slot (slot)
(insert
(concat
(propertize "Slot: " 'face 'bold)
(prin1-to-string (cl--slot-descriptor-name slot))
(unless (eq (cl--slot-descriptor-type slot) t)
(concat " type = "
(prin1-to-string (cl--slot-descriptor-type slot))))
(unless (eq (cl--slot-descriptor-initform slot) eieio-unbound)
(concat " default = "
(prin1-to-string (cl--slot-descriptor-initform slot))))
(when (alist-get :printer (cl--slot-descriptor-props slot))
(concat " printer = "
(prin1-to-string
(alist-get :printer (cl--slot-descriptor-props slot)))))
(when (alist-get :documentation (cl--slot-descriptor-props slot))
(concat "\n " (alist-get :documentation (cl--slot-descriptor-props slot))
"\n")))
"\n"))
(defun eieio-help-class-slots (class)
"Print help description for the slots in CLASS.
Outputs to the current buffer."
(let* ((cv (eieio--class-v class))
(docs (eieio--class-public-doc cv))
(names (eieio--class-public-a cv))
(deflt (eieio--class-public-d cv))
(types (eieio--class-public-type cv))
(publp (eieio--class-public-printer cv))
(i 0)
(prot (eieio--class-protection cv))
)
(slots (eieio--class-slots cv))
(cslots (eieio--class-class-slots cv)))
(insert (propertize "Instance Allocated Slots:\n\n"
'face 'bold))
(while names
(insert
(concat
(when (car prot)
(propertize "Private " 'face 'bold))
(propertize "Slot: " 'face 'bold)
(prin1-to-string (car names))
(unless (eq (aref types i) t)
(concat " type = "
(prin1-to-string (aref types i))))
(unless (eq (car deflt) eieio-unbound)
(concat " default = "
(prin1-to-string (car deflt))))
(when (car publp)
(concat " printer = "
(prin1-to-string (car publp))))
(when (car docs)
(concat "\n " (car docs) "\n"))
"\n"))
(setq names (cdr names)
docs (cdr docs)
deflt (cdr deflt)
publp (cdr publp)
prot (cdr prot)
i (1+ i)))
(setq docs (eieio--class-class-allocation-doc cv)
names (eieio--class-class-allocation-a cv)
types (eieio--class-class-allocation-type cv)
i 0
prot (eieio--class-class-allocation-protection cv))
(when names
(dotimes (i (length slots))
(eieio--help-print-slot (aref slots i)))
(when (> (length cslots) 0)
(insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)))
(while names
(insert
(concat
(when (car prot)
"Private ")
"Slot: "
(prin1-to-string (car names))
(unless (eq (aref types i) t)
(concat " type = "
(prin1-to-string (aref types i))))
(condition-case nil
(let ((value (eieio-oref class (car names))))
(concat " value = "
(prin1-to-string value)))
(error nil))
(when (car docs)
(concat "\n\n " (car docs) "\n"))
"\n"))
(setq names (cdr names)
docs (cdr docs)
prot (cdr prot)
i (1+ i)))))
(dotimes (i (length cslots))
(eieio--help-print-slot (aref cslots i)))))
(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
"Return an alist of all currently active classes for completion purposes.
......
......@@ -320,19 +320,21 @@ variable name of the same name as the slot."
(declare (indent 2) (debug (sexp sexp def-body)))
(require 'cl-lib)
;; Transform the spec-list into a cl-symbol-macrolet spec-list.
(let ((mappings (mapcar (lambda (entry)
(let ((var (if (listp entry) (car entry) entry))
(slot (if (listp entry) (cadr entry) entry)))
(list var `(slot-value ,object ',slot))))
spec-list)))
(append (list 'cl-symbol-macrolet mappings)
body)))
(macroexp-let2 nil object object