mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-24 14:30:43 -08:00
Code Issues Projects Releases Wiki Activity

* lisp/emacs-lisp/eieio*.el: Use class objects in `parent' field.

Browse source 
* lisp/emacs-lisp/eieio-core.el (eieio-class-object): New function.
(eieio-class-parents-fast): Remove macro.
(eieio--class-option-assoc): Rename from class-option-assoc.
Update all callers.
(eieio--class-option): Rename from class-option.  Change `class' arg to
be a class object.  Update all callers.
(eieio--class-method-invocation-order): Rename from
class-method-invocation-order.  Change `class' arg to be a class
object.  Update all callers.
(eieio-defclass-autoload, eieio-defclass): Set the `parent' field to
a list of class objects rather than names.
(eieio-defclass): Remove redundant quotes.  Use `eieio-oref-default'
for accessors to class allocated slots.
(eieio--perform-slot-validation-for-default): Rename from
eieio-perform-slot-validation-for-default.  Update all callers.
(eieio--add-new-slot): Rename from eieio-add-new-slot.
Update all callers.  Use push.
(eieio-copy-parents-into-subclass): Adjust to new content of
`parent' field.  Use dolist.
(eieio-oref): Remove support for providing a class rather than
an object.
(eieio-oref-default): Prefer class objects over class names.
(eieio--slot-originating-class-p): Rename from
eieio-slot-originating-class-p.  Update all callers.  Use `or'.
(eieio--slot-name-index): Turn check into assertion.
(eieio--class-slot-name-index): Rename from
eieio-class-slot-name-index.  Change `class' arg to be a class object.
Update all callers.
(eieio-attribute-to-initarg): Move to eieio-test-persist.el.
(eieio--c3-candidate): Rename from eieio-c3-candidate.
Update all callers.
(eieio--c3-merge-lists): Rename from eieio-c3-merge-lists.
Update all callers.
(eieio--class-precedence-c3): Rename from eieio-class-precedence-c3.
Update all callers.
(eieio--class-precedence-dfs): Rename from eieio-class-precedence-dfs.
Update all callers.
(eieio--class-precedence-bfs): Rename from eieio-class-precedence-bfs.
Update all callers.  Adjust to new `parent' content.
(eieio--class-precedence-list): Rename from -class-precedence-list.
Update all callers.
(eieio-generic-call): Use autoloadp and autoload-do-load.
Slight simplification.
(eieio-generic-call, eieio-generic-call-primary-only): Adjust to new
return value of `eieio-generic-form'.
(eieiomt-add): Index the hashtable with class objects rather than
class names.
(eieio-generic-form): Accept class objects as well.

* lisp/emacs-lisp/eieio.el (eieio-class-parents): Accept class objects.
(eieio--class-slot-initarg): Rename from class-slot-initarg.
Change `class' arg to be a class object.  Update all callers.
(call-next-method): Adjust to new return value of `eieio-generic-form'.
(eieio-default-superclass): Set var to the class object.
(eieio-edebug-prin1-to-string): Fix recursive call for lists.
Change print behavior to affect class objects rather than
class symbols.

* lisp/emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object):
Adjust to new convention for eieio-persistent-validate/fix-slot-value.
(eieio-persistent-validate/fix-slot-value):
Change `class' arg to be a class object.  Update all callers.

* test/automated/eieio-test-persist.el (eieio--attribute-to-initarg):
Move from eieio-core.el.  Rename from eieio-attribute-to-initarg.
Change arg to be a class object.  Update all callers.

* test/automated/eieio-tests.el (eieio-test-04-static-method)
(eieio-test-05-static-method-2): Use oref-default to access
class slots.
(eieio-test-23-inheritance-check): Don't assume that
eieio-class-parents returns class names, or that a class can only have
a single name.
This commit is contained in:
Stefan Monnier 2015-01-04 23:11:37 -05:00
parent 232823a1f1
commit cb4db86319
10 changed files with 356 additions and 256 deletions
Download patch file Download diff file Expand all files Collapse all files

65
lisp/ChangeLog
View file

@ -1,3 +1,68 @@
2015-01-05 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/eieio.el (eieio-class-parents): Accept class objects.
(eieio--class-slot-initarg): Rename from class-slot-initarg.
Change `class' arg to be a class object. Update all callers.
(call-next-method): Adjust to new return value of `eieio-generic-form'.
(eieio-default-superclass): Set var to the class object.
(eieio-edebug-prin1-to-string): Fix recursive call for lists.
Change print behavior to affect class objects rather than
class symbols.
* emacs-lisp/eieio-core.el (eieio-class-object): New function.
(eieio-class-parents-fast): Remove macro.
(eieio--class-option-assoc): Rename from class-option-assoc.
Update all callers.
(eieio--class-option): Rename from class-option. Change `class' arg to
be a class object. Update all callers.
(eieio--class-method-invocation-order): Rename from
class-method-invocation-order. Change `class' arg to be a class
object. Update all callers.
(eieio-defclass-autoload, eieio-defclass): Set the `parent' field to
a list of class objects rather than names.
(eieio-defclass): Remove redundant quotes. Use `eieio-oref-default'
for accessors to class allocated slots.
(eieio--perform-slot-validation-for-default): Rename from
eieio-perform-slot-validation-for-default. Update all callers.
(eieio--add-new-slot): Rename from eieio-add-new-slot.
Update all callers. Use push.
(eieio-copy-parents-into-subclass): Adjust to new content of
`parent' field. Use dolist.
(eieio-oref): Remove support for providing a class rather than
an object.
(eieio-oref-default): Prefer class objects over class names.
(eieio--slot-originating-class-p): Rename from
eieio-slot-originating-class-p. Update all callers. Use `or'.
(eieio--slot-name-index): Turn check into assertion.
(eieio--class-slot-name-index): Rename from
eieio-class-slot-name-index. Change `class' arg to be a class object.
Update all callers.
(eieio-attribute-to-initarg): Move to eieio-test-persist.el.
(eieio--c3-candidate): Rename from eieio-c3-candidate.
Update all callers.
(eieio--c3-merge-lists): Rename from eieio-c3-merge-lists.
Update all callers.
(eieio--class-precedence-c3): Rename from eieio-class-precedence-c3.
Update all callers.
(eieio--class-precedence-dfs): Rename from eieio-class-precedence-dfs.
Update all callers.
(eieio--class-precedence-bfs): Rename from eieio-class-precedence-bfs.
Update all callers. Adjust to new `parent' content.
(eieio--class-precedence-list): Rename from -class-precedence-list.
Update all callers.
(eieio-generic-call): Use autoloadp and autoload-do-load.
Slight simplification.
(eieio-generic-call, eieio-generic-call-primary-only): Adjust to new
return value of `eieio-generic-form'.
(eieiomt-add): Index the hashtable with class objects rather than
class names.
(eieio-generic-form): Accept class objects as well.
* emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object):
Adjust to new convention for eieio-persistent-validate/fix-slot-value.
(eieio-persistent-validate/fix-slot-value):
Change `class' arg to be a class object. Update all callers.
2014-12-29 Stefan Monnier <monnier@iro.umontreal.ca> 2014-12-29 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/eieio.el (child-of-class-p): Make it accept class objects * emacs-lisp/eieio.el (child-of-class-p): Make it accept class objects

6
lisp/emacs-lisp/eieio-base.el
View file

@ -270,7 +270,7 @@ identified, and needing more object creation."
;; In addition, strip out quotes, list functions, and update ;; In addition, strip out quotes, list functions, and update
;; object constructors as needed. ;; object constructors as needed.
(setq value (eieio-persistent-validate/fix-slot-value (setq value (eieio-persistent-validate/fix-slot-value
objclass name value)) (eieio--class-v objclass) name value))
(push name createslots) (push name createslots)
(push value createslots) (push value createslots)
@ -290,13 +290,13 @@ constructor functions are considered valid.
Second, any text properties will be stripped from strings." Second, any text properties will be stripped from strings."
(cond ((consp proposed-value) (cond ((consp proposed-value)
;; Lists with something in them need special treatment. ;; Lists with something in them need special treatment.
(let ((slot-idx (eieio--slot-name-index (eieio--class-v class) (let ((slot-idx (eieio--slot-name-index class
nil slot)) nil slot))
(type nil) (type nil)
(classtype nil)) (classtype nil))
(setq slot-idx (- slot-idx (setq slot-idx (- slot-idx
(eval-when-compile eieio--object-num-slots))) (eval-when-compile eieio--object-num-slots)))
(setq type (aref (eieio--class-public-type (eieio--class-v class)) (setq type (aref (eieio--class-public-type class)
slot-idx)) slot-idx))
(setq classtype (eieio-persistent-slot-type-is-class-p (setq classtype (eieio-persistent-slot-type-is-class-p

441
lisp/emacs-lisp/eieio-core.el
View file

@ -1,6 +1,6 @@
;;; eieio-core.el --- Core implementation for eieio -*- lexical-binding:t -*- ;;; eieio-core.el --- Core implementation for eieio -*- lexical-binding:t -*-
;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc. ;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 1.4 ;; Version: 1.4
@ -225,6 +225,12 @@ Stored outright without modifications or stripping.")))
(eq (aref class 0) 'defclass) (eq (aref class 0) 'defclass)
(error nil))) (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) (defsubst class-p (class)
"Return non-nil if CLASS is a valid class vector. "Return non-nil if CLASS is a valid class vector.
CLASS is a symbol." ;FIXME: Is it a vector or a symbol? CLASS is a symbol." ;FIXME: Is it a vector or a symbol?
@ -238,17 +244,16 @@ CLASS is a symbol." ;FIXME: Is it a vector or a symbol?
"Return a Lisp like symbol name for CLASS." "Return a Lisp like symbol name for CLASS."
;; FIXME: What's a "Lisp like symbol name"? ;; FIXME: What's a "Lisp like symbol name"?
;; FIXME: CLOS returns a symbol, but the code returns a string. ;; 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) (eieio--check-type class-p class)
;; I think this is supposed to return a symbol, but to me CLASS is a symbol, ;; I think this is supposed to return a symbol, but to me CLASS is a symbol,
;; and I wanted a string. Arg! ;; and I wanted a string. Arg!
(format "#<class %s>" (symbol-name class))) (format "#<class %s>" (symbol-name class)))
(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4")
(defmacro eieio-class-parents-fast (class)
"Return parent classes to CLASS with no check."
`(eieio--class-parent (eieio--class-v ,class)))
(defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check." (defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check."
;; FIXME: Remove. And change `children' to contain class objects rather than
;; class names.
`(eieio--class-children (eieio--class-v ,class))) `(eieio--class-children (eieio--class-v ,class)))
(defsubst same-class-fast-p (obj class-name) (defsubst same-class-fast-p (obj class-name)
@ -299,14 +304,14 @@ Methods with only primary implementations are executed in an optimized way."
(aref M eieio--method-generic-after))) (aref M eieio--method-generic-after)))
))) )))
(defmacro class-option-assoc (list option) (defmacro eieio--class-option-assoc (list option)
"Return from LIST the found OPTION, or nil if it doesn't exist." "Return from LIST the found OPTION, or nil if it doesn't exist."
`(car-safe (cdr (memq ,option ,list)))) `(car-safe (cdr (memq ,option ,list))))
(defmacro class-option (class option) (defsubst eieio--class-option (class option)
"Return the value stored for CLASS' OPTION. "Return the value stored for CLASS' OPTION.
Return nil if that option doesn't exist." Return nil if that option doesn't exist."
`(class-option-assoc (eieio--class-options (eieio--class-v ,class)) ',option)) (eieio--class-option-assoc (eieio--class-options class) option))
(defsubst eieio-object-p (obj) (defsubst eieio-object-p (obj)
"Return non-nil if OBJ is an EIEIO object." "Return non-nil if OBJ is an EIEIO object."
@ -320,13 +325,13 @@ Return nil if that option doesn't exist."
(defsubst class-abstract-p (class) (defsubst class-abstract-p (class)
"Return non-nil if CLASS is abstract. "Return non-nil if CLASS is abstract.
Abstract classes cannot be instantiated." Abstract classes cannot be instantiated."
(class-option class :abstract)) (eieio--class-option (eieio--class-v class) :abstract))
(defmacro class-method-invocation-order (class) (defsubst eieio--class-method-invocation-order (class)
"Return the invocation order of CLASS. "Return the invocation order of CLASS.
Abstract classes cannot be instantiated." Abstract classes cannot be instantiated."
`(or (class-option ,class :method-invocation-order) (or (eieio--class-option class :method-invocation-order)
:breadth-first)) :breadth-first))
@ -380,7 +385,7 @@ It creates an autoload function for CNAME's constructor."
(gethash SC eieio-defclass-autoload-map))) (gethash SC eieio-defclass-autoload-map)))
;; Save parent in child. ;; Save parent in child.
(push SC (eieio--class-parent newc))) (push (eieio--class-v SC) (eieio--class-parent newc)))
;; turn this into a usable self-pointing symbol ;; turn this into a usable self-pointing symbol
(set cname cname) (set cname cname)
@ -476,9 +481,9 @@ See `defclass' for more information."
(cl-pushnew cname (eieio--class-children (eieio--class-v p))) (cl-pushnew cname (eieio--class-children (eieio--class-v p)))
;; Get custom groups, and store them into our local copy. ;; Get custom groups, and store them into our local copy.
(mapc (lambda (g) (cl-pushnew g groups :test #'equal)) (mapc (lambda (g) (cl-pushnew g groups :test #'equal))
(class-option p :custom-groups)) (eieio--class-option (eieio--class-v p) :custom-groups))
;; save parent in child ;; save parent in child
(push p (eieio--class-parent newc))) (push (eieio--class-v p) (eieio--class-parent newc)))
(error "Invalid parent class %S" p))) (error "Invalid parent class %S" p)))
;; Reverse the list of our parents so that they are prioritized in ;; Reverse the list of our parents so that they are prioritized in
;; the same order as specified in the code. ;; the same order as specified in the code.
@ -488,11 +493,10 @@ See `defclass' for more information."
(unless (eq cname 'eieio-default-superclass) (unless (eq cname 'eieio-default-superclass)
;; adopt the default parent here, but clear it later... ;; adopt the default parent here, but clear it later...
(setq clearparent t) (setq clearparent t)
;; save new child in parent ;; save new child in parent
(cl-pushnew cname (eieio--class-children (cl-pushnew cname (eieio--class-children eieio-default-superclass))
(eieio--class-v 'eieio-default-superclass))) ;; save parent in child
;; save parent in child (setf (eieio--class-parent newc) (list eieio-default-superclass))))
(setf (eieio--class-parent newc) '(eieio-default-superclass))))
;; turn this into a usable self-pointing symbol; FIXME: Why? ;; turn this into a usable self-pointing symbol; FIXME: Why?
(set cname cname) (set cname cname)
@ -510,7 +514,7 @@ See `defclass' for more information."
(same-class-p obj ',cname))))) (same-class-p obj ',cname)))))
;; Make sure the method invocation order is a valid value. ;; Make sure the method invocation order is a valid value.
(let ((io (class-option-assoc options :method-invocation-order))) (let ((io (eieio--class-option-assoc options :method-invocation-order)))
(when (and io (not (member io '(:depth-first :breadth-first :c3)))) (when (and io (not (member io '(:depth-first :breadth-first :c3))))
(error "Method invocation order %s is not allowed" io) (error "Method invocation order %s is not allowed" io)
)) ))
@ -568,23 +572,23 @@ See `defclass' for more information."
(let* ((slot1 (car slots)) (let* ((slot1 (car slots))
(name (car slot1)) (name (car slot1))
(slot (cdr slot1)) (slot (cdr slot1))
(acces (plist-get slot ':accessor)) (acces (plist-get slot :accessor))
(init (or (plist-get slot ':initform) (init (or (plist-get slot :initform)
(if (member ':initform slot) nil (if (member :initform slot) nil
eieio-unbound))) eieio-unbound)))
(initarg (plist-get slot ':initarg)) (initarg (plist-get slot :initarg))
(docstr (plist-get slot ':documentation)) (docstr (plist-get slot :documentation))
(prot (plist-get slot ':protection)) (prot (plist-get slot :protection))
(reader (plist-get slot ':reader)) (reader (plist-get slot :reader))
(writer (plist-get slot ':writer)) (writer (plist-get slot :writer))
(alloc (plist-get slot ':allocation)) (alloc (plist-get slot :allocation))
(type (plist-get slot ':type)) (type (plist-get slot :type))
(custom (plist-get slot ':custom)) (custom (plist-get slot :custom))
(label (plist-get slot ':label)) (label (plist-get slot :label))
(customg (plist-get slot ':group)) (customg (plist-get slot :group))
(printer (plist-get slot ':printer)) (printer (plist-get slot :printer))
(skip-nil (class-option-assoc options :allow-nil-initform)) (skip-nil (eieio--class-option-assoc options :allow-nil-initform))
) )
(if eieio-error-unsupported-class-tags (if eieio-error-unsupported-class-tags
@ -613,18 +617,18 @@ See `defclass' for more information."
((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected))
((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) ((or (eq prot 'private) (eq prot :private)) (setq prot 'private))
((eq prot nil) nil) ((eq prot nil) nil)
(t (signal 'invalid-slot-type (list ':protection prot)))) (t (signal 'invalid-slot-type (list :protection prot))))
;; Make sure the :allocation parameter has a valid value. ;; Make sure the :allocation parameter has a valid value.
(if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance)))
(signal 'invalid-slot-type (list ':allocation alloc))) (signal 'invalid-slot-type (list :allocation alloc)))
;; The default type specifier is supposed to be t, meaning anything. ;; The default type specifier is supposed to be t, meaning anything.
(if (not type) (setq type t)) (if (not type) (setq type t))
;; Label is nil, or a string ;; Label is nil, or a string
(if (not (or (null label) (stringp label))) (if (not (or (null label) (stringp label)))
(signal 'invalid-slot-type (list ':label label))) (signal 'invalid-slot-type (list :label label)))
;; Is there an initarg, but allocation of class? ;; Is there an initarg, but allocation of class?
(if (and initarg (eq alloc :class)) (if (and initarg (eq alloc :class))
@ -641,11 +645,11 @@ See `defclass' for more information."
;; The customgroup better be a symbol, or list of symbols. ;; The customgroup better be a symbol, or list of symbols.
(mapc (lambda (cg) (mapc (lambda (cg)
(if (not (symbolp cg)) (if (not (symbolp cg))
(signal 'invalid-slot-type (list ':group cg)))) (signal 'invalid-slot-type (list :group cg))))
customg) customg)
;; First up, add this slot into our new class. ;; First up, add this slot into our new class.
(eieio-add-new-slot newc name init docstr type custom label customg printer (eieio--add-new-slot newc name init docstr type custom label customg printer
prot initarg alloc 'defaultoverride skip-nil) prot initarg alloc 'defaultoverride skip-nil)
;; We need to id the group, and store them in a group list attribute. ;; We need to id the group, and store them in a group list attribute.
@ -663,9 +667,13 @@ See `defclass' for more information."
"Retrieves the slot `%s' from an object of class `%s'" "Retrieves the slot `%s' from an object of class `%s'"
name cname) name cname)
(if (slot-boundp this ',name) (if (slot-boundp this ',name)
(eieio-oref this ',name) ;; Use oref-default for :class allocated slots, since
;; Else - Some error? nil? ;; these also accept the use of a class argument instead
nil))) ;; of an object argument.
(,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref)
this ',name)
;; Else - Some error? nil?
nil)))
;; FIXME: We should move more of eieio-defclass into the ;; FIXME: We should move more of eieio-defclass into the
;; defclass macro so we don't have to use `eval' and require ;; defclass macro so we don't have to use `eval' and require
@ -674,7 +682,12 @@ See `defclass' for more information."
;; function, but the define-setter below affects the whole ;; function, but the define-setter below affects the whole
;; generic function! ;; generic function!
(eval `(gv-define-setter ,acces (eieio--store eieio--object) (eval `(gv-define-setter ,acces (eieio--store eieio--object)
(list 'eieio-oset eieio--object '',name ;; Apparently, eieio-oset-default doesn't work like
;; oref-default and only accept class arguments!
(list ',(if nil ;; (eq alloc :class)
'eieio-oset-default
'eieio-oset)
eieio--object '',name
eieio--store))))) eieio--store)))))
;; If a writer is defined, then create a generic method of that ;; If a writer is defined, then create a generic method of that
@ -737,9 +750,9 @@ See `defclass' for more information."
(setf (eieio--class-symbol-hashtable newc) oa)) (setf (eieio--class-symbol-hashtable newc) oa))
;; Create the constructor function ;; Create the constructor function
(if (class-option-assoc options :abstract) (if (eieio--class-option-assoc options :abstract)
;; Abstract classes cannot be instantiated. Say so. ;; Abstract classes cannot be instantiated. Say so.
(let ((abs (class-option-assoc options :abstract))) (let ((abs (eieio--class-option-assoc options :abstract)))
(if (not (stringp abs)) (if (not (stringp abs))
(setq abs (format "Class %s is abstract" cname))) (setq abs (format "Class %s is abstract" cname)))
(fset cname (fset cname
@ -762,7 +775,7 @@ See `defclass' for more information."
;; Set up a specialized doc string. ;; Set up a specialized doc string.
;; Use stored value since it is calculated in a non-trivial way ;; Use stored value since it is calculated in a non-trivial way
(put cname 'variable-documentation (put cname 'variable-documentation
(class-option-assoc options :documentation)) (eieio--class-option-assoc options :documentation))
;; Save the file location where this class is defined. ;; Save the file location where this class is defined.
(let ((fname (if load-in-progress (let ((fname (if load-in-progress
@ -774,7 +787,7 @@ See `defclass' for more information."
(put cname 'class-location fname))) (put cname 'class-location fname)))
;; We have a list of custom groups. Store them into the options. ;; We have a list of custom groups. Store them into the options.
(let ((g (class-option-assoc options :custom-groups))) (let ((g (eieio--class-option-assoc options :custom-groups)))
(mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups) (mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups)
(if (memq :custom-groups options) (if (memq :custom-groups options)
(setcar (cdr (memq :custom-groups options)) g) (setcar (cdr (memq :custom-groups options)) g)
@ -814,16 +827,16 @@ See `defclass' for more information."
"Whether the default value VAL should be evaluated for use." "Whether the default value VAL should be evaluated for use."
(and (consp val) (symbolp (car val)) (fboundp (car val)))) (and (consp val) (symbolp (car val)) (fboundp (car val))))
(defun eieio-perform-slot-validation-for-default (slot spec value skipnil) (defun eieio--perform-slot-validation-for-default (slot spec value skipnil)
"For SLOT, signal if SPEC does not match VALUE. "For SLOT, signal if SPEC does not match VALUE.
If SKIPNIL is non-nil, then if VALUE is nil return t instead." If SKIPNIL is non-nil, then if VALUE is nil return t instead."
(if (and (not (eieio-eval-default-p value)) (if (not (or (eieio-eval-default-p value) ;FIXME: Why?
(not eieio-skip-typecheck) eieio-skip-typecheck
(not (and skipnil (null value))) (and skipnil (null value))
(not (eieio-perform-slot-validation spec value))) (eieio-perform-slot-validation spec value)))
(signal 'invalid-slot-type (list slot spec value)))) (signal 'invalid-slot-type (list slot spec value))))
(defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc (defun eieio--add-new-slot (newc a d doc type cust label custg print prot init alloc
&optional defaultoverride skipnil) &optional defaultoverride skipnil)
"Add into NEWC attribute A. "Add into NEWC attribute A.
If A already exists in NEWC, then do nothing. If it doesn't exist, If A already exists in NEWC, then do nothing. If it doesn't exist,
@ -844,9 +857,9 @@ if default value is nil."
;; To prevent override information w/out specification of storage, ;; To prevent override information w/out specification of storage,
;; we need to do this little hack. ;; we need to do this little hack.
(if (member a (eieio--class-class-allocation-a newc)) (setq alloc ':class)) (if (member a (eieio--class-class-allocation-a newc)) (setq alloc :class))
(if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) (if (or (not alloc) (and (symbolp alloc) (eq alloc :instance)))
;; In this case, we modify the INSTANCE version of a given slot. ;; In this case, we modify the INSTANCE version of a given slot.
(progn (progn
@ -854,16 +867,16 @@ if default value is nil."
;; Only add this element if it is so-far unique ;; Only add this element if it is so-far unique
(if (not (member a (eieio--class-public-a newc))) (if (not (member a (eieio--class-public-a newc)))
(progn (progn
(eieio-perform-slot-validation-for-default a type d skipnil) (eieio--perform-slot-validation-for-default a type d skipnil)
(setf (eieio--class-public-a newc) (cons a (eieio--class-public-a newc))) (push a (eieio--class-public-a newc))
(setf (eieio--class-public-d newc) (cons d (eieio--class-public-d newc))) (push d (eieio--class-public-d newc))
(setf (eieio--class-public-doc newc) (cons doc (eieio--class-public-doc newc))) (push doc (eieio--class-public-doc newc))
(setf (eieio--class-public-type newc) (cons type (eieio--class-public-type newc))) (push type (eieio--class-public-type newc))
(setf (eieio--class-public-custom newc) (cons cust (eieio--class-public-custom newc))) (push cust (eieio--class-public-custom newc))
(setf (eieio--class-public-custom-label newc) (cons label (eieio--class-public-custom-label newc))) (push label (eieio--class-public-custom-label newc))
(setf (eieio--class-public-custom-group newc) (cons custg (eieio--class-public-custom-group newc))) (push custg (eieio--class-public-custom-group newc))
(setf (eieio--class-public-printer newc) (cons print (eieio--class-public-printer newc))) (push print (eieio--class-public-printer newc))
(setf (eieio--class-protection newc) (cons prot (eieio--class-protection newc))) (push prot (eieio--class-protection newc))
(setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc)))
) )
;; When defaultoverride is true, we are usually adding new local ;; When defaultoverride is true, we are usually adding new local
@ -889,7 +902,7 @@ if default value is nil."
type tp a))) type tp a)))
;; If we have a repeat, only update the initarg... ;; If we have a repeat, only update the initarg...
(unless (eq d eieio-unbound) (unless (eq d eieio-unbound)
(eieio-perform-slot-validation-for-default a tp d skipnil) (eieio--perform-slot-validation-for-default a tp d skipnil)
(setcar dp d)) (setcar dp d))
;; If we have a new initarg, check for it. ;; If we have a new initarg, check for it.
(when init (when init
@ -966,19 +979,19 @@ if default value is nil."
(let ((value (eieio-default-eval-maybe d))) (let ((value (eieio-default-eval-maybe d)))
(if (not (member a (eieio--class-class-allocation-a newc))) (if (not (member a (eieio--class-class-allocation-a newc)))
(progn (progn
(eieio-perform-slot-validation-for-default a type value skipnil) (eieio--perform-slot-validation-for-default a type value skipnil)
;; Here we have found a :class version of a slot. This ;; Here we have found a :class version of a slot. This
;; requires a very different approach. ;; requires a very different approach.
(setf (eieio--class-class-allocation-a newc) (cons a (eieio--class-class-allocation-a newc))) (push a (eieio--class-class-allocation-a newc))
(setf (eieio--class-class-allocation-doc newc) (cons doc (eieio--class-class-allocation-doc newc))) (push doc (eieio--class-class-allocation-doc newc))
(setf (eieio--class-class-allocation-type newc) (cons type (eieio--class-class-allocation-type newc))) (push type (eieio--class-class-allocation-type newc))
(setf (eieio--class-class-allocation-custom newc) (cons cust (eieio--class-class-allocation-custom newc))) (push cust (eieio--class-class-allocation-custom newc))
(setf (eieio--class-class-allocation-custom-label newc) (cons label (eieio--class-class-allocation-custom-label newc))) (push label (eieio--class-class-allocation-custom-label newc))
(setf (eieio--class-class-allocation-custom-group newc) (cons custg (eieio--class-class-allocation-custom-group newc))) (push custg (eieio--class-class-allocation-custom-group newc))
(setf (eieio--class-class-allocation-protection newc) (cons prot (eieio--class-class-allocation-protection newc))) (push prot (eieio--class-class-allocation-protection newc))
;; Default value is stored in the 'values section, since new objects ;; Default value is stored in the 'values section, since new objects
;; can't initialize from this element. ;; can't initialize from this element.
(setf (eieio--class-class-allocation-values newc) (cons value (eieio--class-class-allocation-values newc)))) (push value (eieio--class-class-allocation-values newc)))
(when defaultoverride (when defaultoverride
;; There is a match, and we must override the old value. ;; There is a match, and we must override the old value.
(let* ((ca (eieio--class-class-allocation-a newc)) (let* ((ca (eieio--class-class-allocation-a newc))
@ -1003,7 +1016,7 @@ if default value is nil."
;; is to change the default, so allow unbound in. ;; is to change the default, so allow unbound in.
;; If we have a repeat, only update the value... ;; If we have a repeat, only update the value...
(eieio-perform-slot-validation-for-default a tp value skipnil) (eieio--perform-slot-validation-for-default a tp value skipnil)
(setcar dp value)) (setcar dp value))
;; PLN Tue Jun 26 11:57:06 2007 : The protection is ;; PLN Tue Jun 26 11:57:06 2007 : The protection is
@ -1052,71 +1065,66 @@ if default value is nil."
"Copy into NEWC the slots of PARENTS. "Copy into NEWC the slots of PARENTS.
Follow the rules of not overwriting early parents when applying to Follow the rules of not overwriting early parents when applying to
the new child class." the new child class."
(let ((ps (eieio--class-parent newc)) (let ((sn (eieio--class-option-assoc (eieio--class-options newc)
(sn (class-option-assoc (eieio--class-options newc) :allow-nil-initform)))
':allow-nil-initform))) (dolist (pcv (eieio--class-parent newc))
(while ps
;; First, duplicate all the slots of the parent. ;; First, duplicate all the slots of the parent.
(let ((pcv (eieio--class-v (car ps)))) (let ((pa (eieio--class-public-a pcv))
(let ((pa (eieio--class-public-a pcv)) (pd (eieio--class-public-d pcv))
(pd (eieio--class-public-d pcv)) (pdoc (eieio--class-public-doc pcv))
(pdoc (eieio--class-public-doc pcv)) (ptype (eieio--class-public-type pcv))
(ptype (eieio--class-public-type pcv)) (pcust (eieio--class-public-custom pcv))
(pcust (eieio--class-public-custom pcv)) (plabel (eieio--class-public-custom-label pcv))
(plabel (eieio--class-public-custom-label pcv)) (pcustg (eieio--class-public-custom-group pcv))
(pcustg (eieio--class-public-custom-group pcv)) (printer (eieio--class-public-printer pcv))
(printer (eieio--class-public-printer pcv)) (pprot (eieio--class-protection pcv))
(pprot (eieio--class-protection pcv)) (pinit (eieio--class-initarg-tuples pcv))
(pinit (eieio--class-initarg-tuples pcv)) (i 0))
(i 0)) (while pa
(while pa (eieio--add-new-slot newc
(eieio-add-new-slot newc (car pa) (car pd) (car pdoc) (aref ptype i)
(car pa) (car pd) (car pdoc) (aref ptype i) (car pcust) (car plabel) (car pcustg)
(car pcust) (car plabel) (car pcustg) (car printer)
(car printer) (car pprot) (car-safe (car pinit)) nil nil sn)
(car pprot) (car-safe (car pinit)) nil nil sn) ;; Increment each value.
;; Increment each value. (setq pa (cdr pa)
(setq pa (cdr pa) pd (cdr pd)
pd (cdr pd) pdoc (cdr pdoc)
pdoc (cdr pdoc) i (1+ i)
i (1+ i) pcust (cdr pcust)
pcust (cdr pcust) plabel (cdr plabel)
plabel (cdr plabel) pcustg (cdr pcustg)
pcustg (cdr pcustg) printer (cdr printer)
printer (cdr printer) pprot (cdr pprot)
pprot (cdr pprot) pinit (cdr pinit))
pinit (cdr pinit)) )) ;; while/let
)) ;; while/let ;; Now duplicate all the class alloc slots.
;; Now duplicate all the class alloc slots. (let ((pa (eieio--class-class-allocation-a pcv))
(let ((pa (eieio--class-class-allocation-a pcv)) (pdoc (eieio--class-class-allocation-doc pcv))
(pdoc (eieio--class-class-allocation-doc pcv)) (ptype (eieio--class-class-allocation-type pcv))
(ptype (eieio--class-class-allocation-type pcv)) (pcust (eieio--class-class-allocation-custom pcv))
(pcust (eieio--class-class-allocation-custom pcv)) (plabel (eieio--class-class-allocation-custom-label pcv))
(plabel (eieio--class-class-allocation-custom-label pcv)) (pcustg (eieio--class-class-allocation-custom-group pcv))
(pcustg (eieio--class-class-allocation-custom-group pcv)) (printer (eieio--class-class-allocation-printer pcv))
(printer (eieio--class-class-allocation-printer pcv)) (pprot (eieio--class-class-allocation-protection pcv))
(pprot (eieio--class-class-allocation-protection pcv)) (pval (eieio--class-class-allocation-values pcv))
(pval (eieio--class-class-allocation-values pcv)) (i 0))
(i 0)) (while pa
(while pa (eieio--add-new-slot newc
(eieio-add-new-slot newc (car pa) (aref pval i) (car pdoc) (aref ptype i)
(car pa) (aref pval i) (car pdoc) (aref ptype i) (car pcust) (car plabel) (car pcustg)
(car pcust) (car plabel) (car pcustg) (car printer)
(car printer) (car pprot) nil :class sn)
(car pprot) nil ':class sn) ;; Increment each value.
;; Increment each value. (setq pa (cdr pa)
(setq pa (cdr pa) pdoc (cdr pdoc)
pdoc (cdr pdoc) pcust (cdr pcust)
pcust (cdr pcust) plabel (cdr plabel)
plabel (cdr plabel) pcustg (cdr pcustg)
pcustg (cdr pcustg) printer (cdr printer)
printer (cdr printer) pprot (cdr pprot)
pprot (cdr pprot) i (1+ i))
i (1+ i)) )))))
))) ;; while/let
;; Loop over each parent class
(setq ps (cdr ps)))
))
;;; CLOS methods and generics ;;; CLOS methods and generics
@ -1333,14 +1341,17 @@ Argument FN is the function calling this verifier."
(eieio--check-type (or eieio-object-p class-p) obj) (eieio--check-type (or eieio-object-p class-p) obj)
(eieio--check-type symbolp slot) (eieio--check-type symbolp slot)
(if (class-p obj) (eieio-class-un-autoload obj)) (if (class-p obj) (eieio-class-un-autoload obj))
(let* ((class (if (class-p obj) obj (eieio--object-class-name obj))) (let* ((class (cond ((symbolp obj)
(c (eieio--slot-name-index (eieio--class-v class) obj slot))) (error "eieio-oref called on a class!")
(eieio--class-v obj))
(t (eieio--object-class-object obj))))
(c (eieio--slot-name-index class obj slot)))
(if (not c) (if (not c)
;; It might be missing because it is a :class allocated slot. ;; It might be missing because it is a :class allocated slot.
;; Let's check that info out. ;; Let's check that info out.
(if (setq c (eieio-class-slot-name-index class slot)) (if (setq c (eieio--class-slot-name-index class slot))
;; Oref that slot. ;; Oref that slot.
(aref (eieio--class-class-allocation-values (eieio--class-v class)) c) (aref (eieio--class-class-allocation-values class) c)
;; The slot-missing method is a cool way of allowing an object author ;; The slot-missing method is a cool way of allowing an object author
;; to intercept missing slot definitions. Since it is also the LAST ;; to intercept missing slot definitions. Since it is also the LAST
;; thing called in this fn, its return value would be retrieved. ;; thing called in this fn, its return value would be retrieved.
@ -1356,24 +1367,25 @@ Argument FN is the function calling this verifier."
Fills in OBJ's SLOT with its default value." Fills in OBJ's SLOT with its default value."
(eieio--check-type (or eieio-object-p class-p) obj) (eieio--check-type (or eieio-object-p class-p) obj)
(eieio--check-type symbolp slot) (eieio--check-type symbolp slot)
(let* ((cl (if (eieio-object-p obj) (eieio--object-class-name obj) obj)) (let* ((cl (cond ((symbolp obj) (eieio--class-v obj))
(c (eieio--slot-name-index (eieio--class-v cl) obj slot))) (t (eieio--object-class-object obj))))
(c (eieio--slot-name-index cl obj slot)))
(if (not c) (if (not c)
;; It might be missing because it is a :class allocated slot. ;; It might be missing because it is a :class allocated slot.
;; Let's check that info out. ;; Let's check that info out.
(if (setq c (if (setq c
(eieio-class-slot-name-index cl slot)) (eieio--class-slot-name-index cl slot))
;; Oref that slot. ;; Oref that slot.
(aref (eieio--class-class-allocation-values (eieio--class-v cl)) (aref (eieio--class-class-allocation-values cl)
c) c)
(slot-missing obj slot 'oref-default) (slot-missing obj slot 'oref-default)
;;(signal 'invalid-slot-name (list (class-name cl) slot)) ;;(signal 'invalid-slot-name (list (class-name cl) slot))
) )
(eieio-barf-if-slot-unbound (eieio-barf-if-slot-unbound
(let ((val (nth (- c (eval-when-compile eieio--object-num-slots)) (let ((val (nth (- c (eval-when-compile eieio--object-num-slots))
(eieio--class-public-d (eieio--class-v cl))))) (eieio--class-public-d cl))))
(eieio-default-eval-maybe val)) (eieio-default-eval-maybe val))
obj cl 'oref-default)))) obj (eieio--class-symbol cl) 'oref-default))))
(defun eieio-default-eval-maybe (val) (defun eieio-default-eval-maybe (val)
"Check VAL, and return what `oref-default' would provide." "Check VAL, and return what `oref-default' would provide."
@ -1398,7 +1410,7 @@ Fills in OBJ's SLOT with VALUE."
;; It might be missing because it is a :class allocated slot. ;; It might be missing because it is a :class allocated slot.
;; Let's check that info out. ;; Let's check that info out.
(if (setq c (if (setq c
(eieio-class-slot-name-index (eieio--class-symbol class) slot)) (eieio--class-slot-name-index class slot))
;; Oset that slot. ;; Oset that slot.
(progn (progn
(eieio-validate-class-slot-value (eieio--class-symbol class) (eieio-validate-class-slot-value (eieio--class-symbol class)
@ -1422,7 +1434,7 @@ Fills in the default value in CLASS' in SLOT with VALUE."
(if (not c) (if (not c)
;; It might be missing because it is a :class allocated slot. ;; It might be missing because it is a :class allocated slot.
;; Let's check that info out. ;; Let's check that info out.
(if (setq c (eieio-class-slot-name-index class slot)) (if (setq c (eieio--class-slot-name-index (eieio--class-v class) slot))
(progn (progn
;; Oref that slot. ;; Oref that slot.
(eieio-validate-class-slot-value class c value slot) (eieio-validate-class-slot-value class c value slot)
@ -1442,19 +1454,19 @@ Fills in the default value in CLASS' in SLOT with VALUE."
;;; EIEIO internal search functions ;;; EIEIO internal search functions
;; ;;
(defun eieio-slot-originating-class-p (start-class slot) (defun eieio--slot-originating-class-p (start-class slot)
"Return non-nil if START-CLASS is the first class to define SLOT. "Return non-nil if START-CLASS is the first class to define SLOT.
This is for testing if the class currently in scope is the class that defines SLOT This is for testing if the class currently in scope is the class that defines SLOT
so that we can protect private slots." so that we can protect private slots."
(let ((par (eieio--class-parent start-class)) (let ((par (eieio--class-parent start-class))
(ret t)) (ret t))
(if (not par) (or (not par)
t (progn
(while (and par ret) (while (and par ret)
(if (gethash slot (eieio--class-symbol-hashtable (eieio--class-v (car par)))) (if (gethash slot (eieio--class-symbol-hashtable (car par)))
(setq ret nil)) (setq ret nil))
(setq par (cdr par))) (setq par (cdr par)))
ret))) ret))))
(defun eieio--slot-name-index (class obj slot) (defun eieio--slot-name-index (class obj slot)
"In CLASS for OBJ find the index of the named SLOT. "In CLASS for OBJ find the index of the named SLOT.
@ -1475,25 +1487,31 @@ reverse-lookup that name, and recurse with the associated slot value."
(eieio--scoped-class) (eieio--scoped-class)
(or (child-of-class-p class (eieio--scoped-class)) (or (child-of-class-p class (eieio--scoped-class))
(and (eieio-object-p obj) (and (eieio-object-p obj)
(child-of-class-p class (eieio--object-class-object obj))))) ;; AFAICT, for all callers, if `obj' is not a class,
;; then its class is `class'.
;;(child-of-class-p class (eieio--object-class-object obj))
(progn
(cl-assert (eq class (eieio--object-class-object obj)))
t))))
(+ (eval-when-compile eieio--object-num-slots) fsi)) (+ (eval-when-compile eieio--object-num-slots) fsi))
((and (eq (cdr fsym) 'private) ((and (eq (cdr fsym) 'private)
(or (and (eieio--scoped-class) (or (and (eieio--scoped-class)
(eieio-slot-originating-class-p (eieio--scoped-class) slot)) (eieio--slot-originating-class-p
(eieio--scoped-class) slot))
eieio-initializing-object)) eieio-initializing-object))
(+ (eval-when-compile eieio--object-num-slots) fsi)) (+ (eval-when-compile eieio--object-num-slots) fsi))
(t nil)) (t nil))
(let ((fn (eieio--initarg-to-attribute class slot))) (let ((fn (eieio--initarg-to-attribute class slot)))
(if fn (eieio--slot-name-index class obj fn) nil))))) (if fn (eieio--slot-name-index class obj fn) nil)))))
(defun eieio-class-slot-name-index (class slot) (defun eieio--class-slot-name-index (class slot)
"In CLASS find the index of the named SLOT. "In CLASS find the index of the named SLOT.
The slot is a symbol which is installed in CLASS by the `defclass' The slot is a symbol which is installed in CLASS by the `defclass'
call. If SLOT is the value created with :initarg instead, call. If SLOT is the value created with :initarg instead,
reverse-lookup that name, and recurse with the associated slot value." reverse-lookup that name, and recurse with the associated slot value."
;; This will happen less often, and with fewer slots. Do this the ;; This will happen less often, and with fewer slots. Do this the
;; storage cheap way. ;; storage cheap way.
(let* ((a (eieio--class-class-allocation-a (eieio--class-v class))) (let* ((a (eieio--class-class-allocation-a class))
(l1 (length a)) (l1 (length a))
(af (memq slot a)) (af (memq slot a))
(l2 (length af))) (l2 (length af)))
@ -1528,18 +1546,10 @@ need be... May remove that later...)"
(cdr tuple) (cdr tuple)
nil))) nil)))
(defun eieio-attribute-to-initarg (class attribute)
"In CLASS, convert the ATTRIBUTE into the corresponding init argument tag.
This is usually a symbol that starts with `:'."
(let ((tuple (rassoc attribute (eieio--class-initarg-tuples (eieio--class-v class)))))
(if tuple
(car tuple)
nil)))
;;; ;;;
;; Method Invocation order: C3 ;; Method Invocation order: C3
(defun eieio-c3-candidate (class remaining-inputs) (defun eieio--c3-candidate (class remaining-inputs)
"Return CLASS if it can go in the result now, otherwise nil" "Return CLASS if it can go in the result now, otherwise nil."
;; Ensure CLASS is not in any position but the first in any of the ;; Ensure CLASS is not in any position but the first in any of the
;; element lists of REMAINING-INPUTS. ;; element lists of REMAINING-INPUTS.
(and (not (let ((found nil)) (and (not (let ((found nil))
@ -1549,7 +1559,7 @@ This is usually a symbol that starts with `:'."
found)) found))
class)) class))
(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) (defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs)
"Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible.
If a consistent order does not exist, signal an error." If a consistent order does not exist, signal an error."
(if (let ((tail remaining-inputs) (if (let ((tail remaining-inputs)
@ -1568,41 +1578,38 @@ If a consistent order does not exist, signal an error."
(next (progn (next (progn
(while (and tail (not found)) (while (and tail (not found))
(setq found (and (car tail) (setq found (and (car tail)
(eieio-c3-candidate (caar tail) (eieio--c3-candidate (caar tail)
remaining-inputs)) remaining-inputs))
tail (cdr tail))) tail (cdr tail)))
found))) found)))
(if next (if next
;; The graph is consistent so far, add NEXT to result and ;; The graph is consistent so far, add NEXT to result and
;; merge input lists, dropping NEXT from their heads where ;; merge input lists, dropping NEXT from their heads where
;; applicable. ;; applicable.
(eieio-c3-merge-lists (eieio--c3-merge-lists
(cons next reversed-partial-result) (cons next reversed-partial-result)
(mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l)) (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l))
remaining-inputs)) remaining-inputs))
;; The graph is inconsistent, give up ;; The graph is inconsistent, give up
(signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) (signal 'inconsistent-class-hierarchy (list remaining-inputs))))))
(defun eieio-class-precedence-c3 (class) (defun eieio--class-precedence-c3 (class)
"Return all parents of CLASS in c3 order." "Return all parents of CLASS in c3 order."
(let ((parents (eieio-class-parents-fast class))) (let ((parents (eieio--class-parent (eieio--class-v class))))
(eieio-c3-merge-lists (eieio--c3-merge-lists
(list class) (list class)
(append (append
(or (or
(mapcar (mapcar #'eieio--class-precedence-c3 parents)
(lambda (x) `((,eieio-default-superclass)))
(eieio-class-precedence-c3 x))
parents)
'((eieio-default-superclass)))
(list parents)))) (list parents))))
) )
;;; ;;;
;; Method Invocation Order: Depth First ;; Method Invocation Order: Depth First
(defun eieio-class-precedence-dfs (class) (defun eieio--class-precedence-dfs (class)
"Return all parents of CLASS in depth-first order." "Return all parents of CLASS in depth-first order."
(let* ((parents (eieio-class-parents-fast class)) (let* ((parents (eieio--class-parent class))
(classes (copy-sequence (classes (copy-sequence
(apply #'append (apply #'append
(list class) (list class)
@ -1610,9 +1617,9 @@ If a consistent order does not exist, signal an error."
(mapcar (mapcar
(lambda (parent) (lambda (parent)
(cons parent (cons parent
(eieio-class-precedence-dfs parent))) (eieio--class-precedence-dfs parent)))
parents) parents)
'((eieio-default-superclass)))))) `((,eieio-default-superclass))))))
(tail classes)) (tail classes))
;; Remove duplicates. ;; Remove duplicates.
(while tail (while tail
@ -1622,40 +1629,40 @@ If a consistent order does not exist, signal an error."
;;; ;;;
;; Method Invocation Order: Breadth First ;; Method Invocation Order: Breadth First
(defun eieio-class-precedence-bfs (class) (defun eieio--class-precedence-bfs (class)
"Return all parents of CLASS in breadth-first order." "Return all parents of CLASS in breadth-first order."
(let ((result) (let* ((result)
(queue (or (eieio-class-parents-fast class) (queue (or (eieio--class-parent class)
'(eieio-default-superclass)))) `(,eieio-default-superclass))))
(while queue (while queue
(let ((head (pop queue))) (let ((head (pop queue)))
(unless (member head result) (unless (member head result)
(push head result) (push head result)
(unless (eq head 'eieio-default-superclass) (unless (eq head eieio-default-superclass)
(setq queue (append queue (or (eieio-class-parents-fast head) (setq queue (append queue (or (eieio--class-parent head)
'(eieio-default-superclass)))))))) `(,eieio-default-superclass))))))))
(cons class (nreverse result))) (cons class (nreverse result)))
) )
;;; ;;;
;; Method Invocation Order ;; Method Invocation Order
(defun eieio-class-precedence-list (class) (defun eieio--class-precedence-list (class)
"Return (transitively closed) list of parents of CLASS. "Return (transitively closed) list of parents of CLASS.
The order, in which the parents are returned depends on the The order, in which the parents are returned depends on the
method invocation orders of the involved classes." method invocation orders of the involved classes."
(if (or (null class) (eq class 'eieio-default-superclass)) (if (or (null class) (eq class eieio-default-superclass))
nil nil
(cl-case (class-method-invocation-order class) (cl-case (eieio--class-method-invocation-order class)
(:depth-first (:depth-first
(eieio-class-precedence-dfs class)) (eieio--class-precedence-dfs class))
(:breadth-first (:breadth-first
(eieio-class-precedence-bfs class)) (eieio--class-precedence-bfs class))
(:c3 (:c3
(eieio-class-precedence-c3 class)))) (eieio--class-precedence-c3 class))))
) )
(define-obsolete-function-alias (define-obsolete-function-alias
'class-precedence-list 'eieio-class-precedence-list "24.4") 'class-precedence-list 'eieio--class-precedence-list "24.4")
;;; CLOS generics internal function handling ;;; CLOS generics internal function handling
@ -1688,9 +1695,8 @@ This should only be called from a generic function."
;; function loaded anyway. ;; function loaded anyway.
(if (and (symbolp firstarg) (if (and (symbolp firstarg)
(fboundp firstarg) (fboundp firstarg)
(listp (symbol-function firstarg)) (autoloadp (symbol-function firstarg)))
(eq 'autoload (car (symbol-function firstarg)))) (autoload-do-load (symbol-function firstarg)))
(load (nth 1 (symbol-function firstarg))))
;; Determine the class to use. ;; Determine the class to use.
(cond ((eieio-object-p firstarg) (cond ((eieio-object-p firstarg)
(setq mclass (eieio--object-class-name firstarg))) (setq mclass (eieio--object-class-name firstarg)))
@ -1700,7 +1706,7 @@ This should only be called from a generic function."
;; Make sure the class is a valid class ;; Make sure the class is a valid class
;; mclass can be nil (meaning a generic for should be used. ;; mclass can be nil (meaning a generic for should be used.
;; mclass cannot have a value that is not a class, however. ;; mclass cannot have a value that is not a class, however.
(when (and (not (null mclass)) (not (class-p mclass))) (unless (or (null mclass) (class-p mclass))
(error "Cannot dispatch method %S on class %S" (error "Cannot dispatch method %S on class %S"
method mclass) method mclass)
) )
@ -1776,7 +1782,7 @@ This should only be called from a generic function."
(let ((rval nil) (lastval nil) (found nil)) (let ((rval nil) (lastval nil) (found nil))
(while lambdas (while lambdas
(if (car lambdas) (if (car lambdas)
(eieio--with-scoped-class (eieio--class-v (cdr (car lambdas))) (eieio--with-scoped-class (cdr (car lambdas))
(let* ((eieio-generic-call-key (car keys)) (let* ((eieio-generic-call-key (car keys))
(has-return-val (has-return-val
(or (= eieio-generic-call-key eieio--method-primary) (or (= eieio-generic-call-key eieio--method-primary)
@ -1844,7 +1850,7 @@ for this common case to improve performance."
;; Now loop through all occurrences forms which we must execute ;; Now loop through all occurrences forms which we must execute
;; (which are happily sorted now) and execute them all! ;; (which are happily sorted now) and execute them all!
(eieio--with-scoped-class (eieio--class-v (cdr lambdas)) (eieio--with-scoped-class (cdr lambdas)
(let* ((rval nil) (lastval nil) (let* ((rval nil) (lastval nil)
(eieio-generic-call-key eieio--method-primary) (eieio-generic-call-key eieio--method-primary)
;; Use the cdr, as the first element is the fcn ;; Use the cdr, as the first element is the fcn
@ -1884,7 +1890,7 @@ If CLASS is nil, then an empty list of methods should be returned."
;; Collect lambda expressions stored for the class and its parent ;; Collect lambda expressions stored for the class and its parent
;; classes. ;; classes.
(let (lambdas) (let (lambdas)
(dolist (ancestor (eieio-class-precedence-list class)) (dolist (ancestor (eieio--class-precedence-list (eieio--class-v class)))
;; Lookup the form to use for the PRIMARY object for the next level ;; Lookup the form to use for the PRIMARY object for the next level
(let ((tmpl (eieio-generic-form method key ancestor))) (let ((tmpl (eieio-generic-form method key ancestor)))
(when (and tmpl (when (and tmpl
@ -1961,7 +1967,7 @@ CLASS is the class this method is associated with."
;; said symbol in the correct hashtable, otherwise use the ;; said symbol in the correct hashtable, otherwise use the
;; other array to keep this stuff. ;; other array to keep this stuff.
(if (< key eieio--method-num-lists) (if (< key eieio--method-num-lists)
(puthash class (list method) (aref emto key))) (puthash (eieio--class-v class) (list method) (aref emto key)))
;; Save the defmethod file location in a symbol property. ;; Save the defmethod file location in a symbol property.
(let ((fname (if load-in-progress (let ((fname (if load-in-progress
load-file-name load-file-name
@ -1986,7 +1992,7 @@ This is different from function `class-parent' as class parent returns
nil for superclasses. This function performs no type checking!" nil for superclasses. This function performs no type checking!"
;; No type-checking because all calls are made from functions which ;; No type-checking because all calls are made from functions which
;; are safe and do checking for us. ;; are safe and do checking for us.
(or (eieio-class-parents-fast class) (or (eieio--class-parent (eieio--class-v class))
(if (eq class 'eieio-default-superclass) (if (eq class 'eieio-default-superclass)
nil nil
'(eieio-default-superclass)))) '(eieio-default-superclass))))
@ -1999,7 +2005,7 @@ nil for superclasses. This function performs no type checking!"
;; we replace the nil from above. ;; we replace the nil from above.
(catch 'done (catch 'done
(dolist (ancestor (dolist (ancestor
(cl-rest (eieio-class-precedence-list class))) (cl-rest (eieio--class-precedence-list class)))
(let ((ov (gethash ancestor eieiomt--optimizing-hashtable))) (let ((ov (gethash ancestor eieiomt--optimizing-hashtable)))
(when (car ov) (when (car ov)
(setcdr s ancestor) ;; store ov as our next symbol (setcdr s ancestor) ;; store ov as our next symbol
@ -2011,9 +2017,10 @@ If CLASS is not a class then use `generic' instead. If class has
no form, but has a parent class, then trace to that parent class. no form, but has a parent class, then trace to that parent class.
The first time a form is requested from a symbol, an optimized path The first time a form is requested from a symbol, an optimized path
is memorized for faster future use." is memorized for faster future use."
(if (symbolp class) (setq class (eieio--class-v class)))
(let ((emto (aref (get method 'eieio-method-hashtable) (let ((emto (aref (get method 'eieio-method-hashtable)
(if class key (eieio-specialized-key-to-generic-key key))))) (if class key (eieio-specialized-key-to-generic-key key)))))
(if (class-p class) (if (eieio--class-p class)
;; 1) find our symbol ;; 1) find our symbol
(let ((cs (gethash class emto))) (let ((cs (gethash class emto)))
(unless cs (unless cs

13
lisp/emacs-lisp/eieio-custom.el
View file

@ -208,8 +208,8 @@ Optional argument IGNORE is an extraneous parameter."
chil))) chil)))
;; Display information about the group being shown ;; Display information about the group being shown
(when master-group (when master-group
(let ((groups (class-option (eieio--object-class-name obj) (let ((groups (eieio--class-option (eieio--object-class-object obj)
:custom-groups))) :custom-groups)))
(widget-insert "Groups:") (widget-insert "Groups:")
(while groups (while groups
(widget-insert " ") (widget-insert " ")
@ -261,8 +261,8 @@ Optional argument IGNORE is an extraneous parameter."
(car flabel) (car flabel)
(let ((s (symbol-name (let ((s (symbol-name
(or (or
(class-slot-initarg (eieio--class-slot-initarg
(eieio--object-class-name obj) (eieio--object-class-object obj)
(car slots)) (car slots))
(car slots))))) (car slots)))))
(capitalize (capitalize
@ -452,7 +452,7 @@ Must return the created widget."
(vector (concat "Group " (symbol-name group)) (vector (concat "Group " (symbol-name group))
(list 'customize-object obj (list 'quote group)) (list 'customize-object obj (list 'quote group))
t)) t))
(class-option (eieio--object-class-name obj) :custom-groups))) (eieio--class-option (eieio--object-class-object obj) :custom-groups)))
(defvar eieio-read-custom-group-history nil (defvar eieio-read-custom-group-history nil
"History for the custom group reader.") "History for the custom group reader.")
@ -460,7 +460,8 @@ Must return the created widget."
(defmethod eieio-read-customization-group ((obj eieio-default-superclass)) (defmethod eieio-read-customization-group ((obj eieio-default-superclass))
"Do a completing read on the name of a customization group in OBJ. "Do a completing read on the name of a customization group in OBJ.
Return the symbol for the group, or nil" Return the symbol for the group, or nil"
(let ((g (class-option (eieio--object-class-name obj) :custom-groups))) (let ((g (eieio--class-option (eieio--object-class-object obj)
:custom-groups)))
(if (= (length g) 1) (if (= (length g) 1)
(car g) (car g)
;; Make the association list ;; Make the association list

6
lisp/emacs-lisp/eieio-datadebug.el
View file

@ -96,7 +96,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
) )
(while publa (while publa
(if (slot-boundp obj (car publa)) (if (slot-boundp obj (car publa))
(let* ((i (class-slot-initarg cl (car publa))) (let* ((i (eieio--class-slot-initarg (eieio--class-v cl)
(car publa)))
(v (eieio-oref obj (car publa)))) (v (eieio-oref obj (car publa))))
(data-debug-insert-thing (data-debug-insert-thing
v prefix (concat v prefix (concat
@ -104,7 +105,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
(symbol-name (car publa))) (symbol-name (car publa)))
" "))) " ")))
;; Unbound case ;; Unbound case
(let ((i (class-slot-initarg cl (car publa)))) (let ((i (eieio--class-slot-initarg (eieio--class-v cl)
(car publa))))
(data-debug-insert-custom (data-debug-insert-custom
"#unbound" prefix "#unbound" prefix
(concat (if i (symbol-name i) (concat (if i (symbol-name i)

2
lisp/emacs-lisp/eieio-opt.el
View file

@ -81,7 +81,7 @@ If CLASS is actually an object, then also display current values of that object.
;; Header line ;; Header line
(prin1 class) (prin1 class)
(insert " is a" (insert " is a"
(if (class-option class :abstract) (if (eieio--class-option (eieio--class-v class) :abstract)
"n abstract" "n abstract"
"") "")
" class") " class")

41
lisp/emacs-lisp/eieio.el
View file

@ -1,7 +1,7 @@
;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -*- lexical-binding:t -*- ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -*- lexical-binding:t -*-
;;; or maybe Eric's Implementation of Emacs Interpreted Objects ;;; or maybe Eric's Implementation of Emacs Interpreted Objects
;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc. ;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 1.4 ;; Version: 1.4
@ -319,8 +319,9 @@ If EXTRA, include that in the string returned to represent the symbol."
"Return parent classes to CLASS. (overload of variable). "Return parent classes to CLASS. (overload of variable).
The CLOS function `class-direct-superclasses' is aliased to this function." The CLOS function `class-direct-superclasses' is aliased to this function."
(eieio--check-type class-p class) (let ((c (eieio-class-object class)))
(eieio-class-parents-fast class)) (eieio--class-parent c)))
(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4")
(defun eieio-class-children (class) (defun eieio-class-children (class)
@ -366,10 +367,8 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
(setq class (eieio--class-object class)) (setq class (eieio--class-object class))
(eieio--check-type eieio--class-p class) (eieio--check-type eieio--class-p class)
(while (and child (not (eq child class))) (while (and child (not (eq child class)))
;; FIXME: eieio--class-parent should return class-objects rather than
;; class-names!
(setq p (append p (eieio--class-parent child)) (setq p (append p (eieio--class-parent child))
child (eieio--class-v (pop p)))) child (pop p)))
(if child t)))) (if child t))))
(defun object-slots (obj) (defun object-slots (obj)
@ -377,9 +376,9 @@ The CLOS function `class-direct-subclasses' is aliased to this function."
(eieio--check-type eieio-object-p obj) (eieio--check-type eieio-object-p obj)
(eieio--class-public-a (eieio--object-class-object obj))) (eieio--class-public-a (eieio--object-class-object obj)))
(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." (defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg."
(eieio--check-type class-p class) (eieio--check-type eieio--class-p class)
(let ((ia (eieio--class-initarg-tuples (eieio--class-v class))) (let ((ia (eieio--class-initarg-tuples class))
(f nil)) (f nil))
(while (and ia (not f)) (while (and ia (not f))
(if (eq (cdr (car ia)) slot) (if (eq (cdr (car ia)) slot)
@ -426,11 +425,9 @@ OBJECT can be an instance or a class."
(defun slot-exists-p (object-or-class slot) (defun slot-exists-p (object-or-class slot)
"Return non-nil if OBJECT-OR-CLASS has SLOT." "Return non-nil if OBJECT-OR-CLASS has SLOT."
(let ((cv (eieio--class-v (cond ((eieio-object-p object-or-class) (let ((cv (cond ((eieio-object-p object-or-class)
(eieio-object-class object-or-class)) (eieio--object-class-object object-or-class))
((class-p object-or-class) (t (eieio-class-object object-or-class)))))
object-or-class))
)))
(or (memq slot (eieio--class-public-a cv)) (or (memq slot (eieio--class-public-a cv))
(memq slot (eieio--class-class-allocation-a cv))) (memq slot (eieio--class-class-allocation-a cv)))
)) ))
@ -555,7 +552,7 @@ Use `next-method-p' to find out if there is a next method to call."
(eieio-generic-call-arglst newargs) (eieio-generic-call-arglst newargs)
(fcn (car next)) (fcn (car next))
) )
(eieio--with-scoped-class (eieio--class-v (cdr next)) (eieio--with-scoped-class (cdr next)
(apply fcn newargs)) )))) (apply fcn newargs)) ))))
;;; Here are some CLOS items that need the CL package ;;; Here are some CLOS items that need the CL package
@ -580,6 +577,8 @@ Its slots are automatically adopted by classes with no specified parents.
This class is not stored in the `parent' slot of a class vector." This class is not stored in the `parent' slot of a class vector."
:abstract t) :abstract t)
(setq eieio-default-superclass (eieio--class-v 'eieio-default-superclass))
(defalias 'standard-class 'eieio-default-superclass) (defalias 'standard-class 'eieio-default-superclass)
(defgeneric eieio-constructor (class &rest slots) (defgeneric eieio-constructor (class &rest slots)
@ -797,7 +796,7 @@ this object."
(eieio-print-depth (1+ eieio-print-depth))) (eieio-print-depth (1+ eieio-print-depth)))
(while publa (while publa
(when (slot-boundp this (car publa)) (when (slot-boundp this (car publa))
(let ((i (class-slot-initarg cl (car publa))) (let ((i (eieio--class-slot-initarg cv (car publa)))
(v (eieio-oref this (car publa))) (v (eieio-oref this (car publa)))
) )
(unless (or (not i) (equal v (car publd))) (unless (or (not i) (equal v (car publd)))
@ -874,11 +873,13 @@ of `eq'."
Used as advice around `edebug-prin1-to-string', held in the Used as advice around `edebug-prin1-to-string', held in the
variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
`prin1-to-string' when appropriate." `prin1-to-string' when appropriate."
(cond ((class-p object) (eieio-class-name object)) (cond ((eieio--class-p object) (eieio-class-name object))
((eieio-object-p object) (object-print object)) ((eieio-object-p object) (object-print object))
((and (listp object) (or (class-p (car object)) ((and (listp object) (or (eieio--class-p (car object))
(eieio-object-p (car object)))) (eieio-object-p (car object))))
(concat "(" (mapconcat #'eieio-edebug-prin1-to-string object " ") (concat "(" (mapconcat
(lambda (x) (eieio-edebug-prin1-to-string print-function x))
object " ")
")")) ")"))
(t (funcall print-function object noescape)))) (t (funcall print-function object noescape))))
@ -888,7 +889,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to
;;; Start of automatically extracted autoloads. ;;; Start of automatically extracted autoloads.
;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "2b4c57cf907e879e8bbc88d8f0e2de4c") ;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "a3f314e2a27e52444df4597c6ae51458")
;;; Generated autoloads from eieio-custom.el ;;; Generated autoloads from eieio-custom.el
(autoload 'customize-object "eieio-custom" "\ (autoload 'customize-object "eieio-custom" "\

13
test/ChangeLog
View file

@ -1,3 +1,16 @@
2015-01-05 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/eieio-tests.el (eieio-test-04-static-method)
(eieio-test-05-static-method-2): Use oref-default to access
class slots.
(eieio-test-23-inheritance-check): Don't assume that
eieio-class-parents returns class names, or that a class can only have
a single name.
* automated/eieio-test-persist.el (eieio--attribute-to-initarg):
Move from eieio-core.el. Rename from eieio-attribute-to-initarg.
Change arg to be a class object. Update all callers.
2014-12-29 Stefan Monnier <monnier@iro.umontreal.ca> 2014-12-29 Stefan Monnier <monnier@iro.umontreal.ca>
* automated/eieio-test-methodinvoke.el (eieio-test-method-store): * automated/eieio-test-methodinvoke.el (eieio-test-method-store):

11
test/automated/eieio-test-persist.el
View file

@ -32,6 +32,14 @@
(require 'eieio-base) (require 'eieio-base)
(require 'ert) (require 'ert)
(defun eieio--attribute-to-initarg (class attribute)
"In CLASS, convert the ATTRIBUTE into the corresponding init argument tag.
This is usually a symbol that starts with `:'."
(let ((tuple (rassoc attribute (eieio--class-initarg-tuples class))))
(if tuple
(car tuple)
nil)))
(defun persist-test-save-and-compare (original) (defun persist-test-save-and-compare (original)
"Compare the object ORIGINAL against the one read fromdisk." "Compare the object ORIGINAL against the one read fromdisk."
@ -53,7 +61,8 @@
(let* ((oneslot (car slot-names)) (let* ((oneslot (car slot-names))
(origvalue (eieio-oref original oneslot)) (origvalue (eieio-oref original oneslot))
(fromdiskvalue (eieio-oref fromdisk oneslot)) (fromdiskvalue (eieio-oref fromdisk oneslot))
(initarg-p (eieio-attribute-to-initarg class oneslot)) (initarg-p (eieio--attribute-to-initarg
(eieio--class-v class) oneslot))
) )
(if initarg-p (if initarg-p

14
test/automated/eieio-tests.el
View file

@ -1,6 +1,6 @@
;;; eieio-tests.el -- eieio tests routines ;;; eieio-tests.el -- eieio tests routines
;; Copyright (C) 1999-2003, 2005-2010, 2012-2014 Free Software Foundation, Inc. ;; Copyright (C) 1999-2003, 2005-2010, 2012-2015 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Author: Eric M. Ludlam <zappo@gnu.org>
@ -199,9 +199,9 @@ Argument C is the class bound to this static method."
(ert-deftest eieio-test-04-static-method () (ert-deftest eieio-test-04-static-method ()
;; Call static method on a class and see if it worked ;; Call static method on a class and see if it worked
(static-method-class-method static-method-class 'class) (static-method-class-method static-method-class 'class)
(should (eq (oref static-method-class some-slot) 'class)) (should (eq (oref-default static-method-class some-slot) 'class))
(static-method-class-method (static-method-class) 'object) (static-method-class-method (static-method-class) 'object)
(should (eq (oref static-method-class some-slot) 'object))) (should (eq (oref-default static-method-class some-slot) 'object)))
(ert-deftest eieio-test-05-static-method-2 () (ert-deftest eieio-test-05-static-method-2 ()
(defclass static-method-class-2 (static-method-class) (defclass static-method-class-2 (static-method-class)
@ -215,9 +215,9 @@ Argument C is the class bound to this static method."
(oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) (oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))
(static-method-class-method static-method-class-2 'class) (static-method-class-method static-method-class-2 'class)
(should (eq (oref static-method-class-2 some-slot) 'moose-class)) (should (eq (oref-default static-method-class-2 some-slot) 'moose-class))
(static-method-class-method (static-method-class-2) 'object) (static-method-class-method (static-method-class-2) 'object)
(should (eq (oref static-method-class-2 some-slot) 'moose-object))) (should (eq (oref-default static-method-class-2 some-slot) 'moose-object)))
;;; Perform method testing ;;; Perform method testing
@ -536,7 +536,9 @@ 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-b))
(should (object-of-class-p eitest-ab class-ab)) (should (object-of-class-p eitest-ab class-ab))
(should (eq (eieio-class-parents class-a) nil)) (should (eq (eieio-class-parents class-a) nil))
(should (equal (eieio-class-parents class-ab) '(class-a class-b))) ;; 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 (same-class-p eitest-a class-a)) (should (same-class-p eitest-a class-a))
(should (class-a-p eitest-a)) (should (class-a-p eitest-a))
(should (not (class-a-p eitest-ab))) (should (not (class-a-p eitest-ab)))