[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Cleaning up the EIEIO namespace
|
From: |
Stefan Monnier |
|
Subject: |
Cleaning up the EIEIO namespace |
|
Date: |
Sun, 10 Feb 2013 13:10:48 -0500 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.3.50 (gnu/linux) |
Here is a patch that attempts to clean up part of the EIEIO namespace.
If you like it, please install it upstream, so it will get merged into
Emacs later on. If you prefer, I can install it into Emacs directly and
you'll merge it later on upstream, of course.
Stefan
=== modified file 'lisp/emacs-lisp/eieio-base.el'
--- lisp/emacs-lisp/eieio-base.el 2013-01-01 09:11:05 +0000
+++ lisp/emacs-lisp/eieio-base.el 2013-01-17 18:10:13 +0000
@@ -65,19 +64,19 @@
"Clone OBJ, initializing `:parent' to OBJ.
All slots are unbound, except those initialized with PARAMS."
(let ((nobj (make-vector (length obj) eieio-unbound))
- (nm (aref obj object-name))
+ (nm (eieio--object-name obj))
(passname (and params (stringp (car params))))
(num 1))
(aset nobj 0 'object)
- (aset nobj object-class (aref obj object-class))
+ (setf (eieio--object-class nobj) (eieio--object-class obj))
;; The following was copied from the default clone.
(if (not passname)
(save-match-data
(if (string-match "-\\([0-9]+\\)" nm)
(setq num (1+ (string-to-number (match-string 1 nm)))
nm (substring nm 0 (match-beginning 0))))
- (aset nobj object-name (concat nm "-" (int-to-string num))))
- (aset nobj object-name (car params)))
+ (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
+ (setf (eieio--object-name nobj) (car params)))
;; Now initialize from params.
(if params (shared-initialize nobj (if passname (cdr params) params)))
(oset nobj parent-instance obj)
@@ -232,8 +231,7 @@
being pedantic."
(unless class
(message "Unsafe call to `eieio-persistent-read'."))
- (when (and class (not (class-p class)))
- (signal 'wrong-type-argument (list 'class-p class)))
+ (when class (eieio--check-type class-p class))
(let ((ret nil)
(buffstr nil))
(unwind-protect
@@ -308,7 +306,7 @@
(type nil)
(classtype nil))
(setq slot-idx (- slot-idx 3))
- (setq type (aref (aref (class-v class) class-public-type)
+ (setq type (aref (eieio--class-public-type (class-v class))
slot-idx))
(setq classtype (eieio-persistent-slot-type-is-class-p
@@ -482,14 +480,13 @@
OPERATION is the type of access, such as `oref' or `oset'.
NEW-VALUE is the value that was being set into SLOT if OPERATION were
a set type."
- (if (or (eq slot-name 'object-name)
- (eq slot-name :object-name))
+ (if (memq slot-name '(object-name :object-name))
(cond ((eq operation 'oset)
(if (not (stringp new-value))
(signal 'invalid-slot-type
(list obj slot-name 'string new-value)))
- (object-set-name-string obj new-value))
- (t (object-name-string obj)))
+ (eieio-object-set-name-string obj new-value))
+ (t (eieio-object-name-string obj)))
(call-next-method)))
(provide 'eieio-base)
=== modified file 'lisp/emacs-lisp/eieio-custom.el'
--- lisp/emacs-lisp/eieio-custom.el 2013-01-01 09:11:05 +0000
+++ lisp/emacs-lisp/eieio-custom.el 2013-01-17 18:10:29 +0000
@@ -192,22 +192,22 @@
(let* ((chil nil)
(obj (widget-get widget :value))
(master-group (widget-get widget :eieio-group))
- (cv (class-v (object-class-fast obj)))
- (slots (aref cv class-public-a))
- (flabel (aref cv class-public-custom-label))
- (fgroup (aref cv class-public-custom-group))
- (fdoc (aref cv class-public-doc))
- (fcust (aref cv class-public-custom)))
+ (cv (class-v (eieio--object-class 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)))
;; First line describes the object, but may not editable.
(if (widget-get widget :eieio-show-name)
(setq chil (cons (widget-create-child-and-convert
widget 'string :tag "Object "
:sample-face 'bold
- (object-name-string obj))
+ (eieio-object-name-string obj))
chil)))
;; Display information about the group being shown
(when master-group
- (let ((groups (class-option (object-class-fast obj) :custom-groups)))
+ (let ((groups (class-option (eieio--object-class obj) :custom-groups)))
(widget-insert "Groups:")
(while groups
(widget-insert " ")
@@ -260,7 +260,7 @@
(let ((s (symbol-name
(or
(class-slot-initarg
- (object-class-fast obj)
+ (eieio--object-class obj)
(car slots))
(car slots)))))
(capitalize
@@ -287,17 +287,17 @@
"Get the value of WIDGET."
(let* ((obj (widget-get widget :value))
(master-group eieio-cog)
- (cv (class-v (object-class-fast obj)))
- (fgroup (aref cv class-public-custom-group))
+ (cv (class-v (eieio--object-class 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 (class-v (object-class-fast obj)))
- (slots (aref cv class-public-a))
- (fcust (aref cv class-public-custom)))
+ (cv (class-v (eieio--object-class obj)))
+ (slots (eieio--class-public-a cv))
+ (fcust (eieio--class-public-custom cv)))
;; If there are any prefix widgets, clear them.
;; -- None yet
;; Create a batch of initargs for each slot.
@@ -316,7 +316,7 @@
fgroup (cdr fgroup)
fcust (cdr fcust)))
;; Set any name updates on it.
- (if name (aset obj object-name name))
+ (if name (setf (eieio--object-name obj) name))
;; This is the same object we had before.
obj))
@@ -354,7 +354,7 @@
(let* ((g (or group 'default)))
(switch-to-buffer (get-buffer-create
(concat "*CUSTOMIZE "
- (object-name obj) " "
+ (eieio-object-name obj) " "
(symbol-name g) "*")))
(setq buffer-read-only nil)
(kill-all-local-variables)
@@ -367,7 +367,7 @@
;; Add an apply reset option at the top of the buffer.
(eieio-custom-object-apply-reset obj)
(widget-insert "\n\n")
- (widget-insert "Edit object " (object-name obj) "\n\n")
+ (widget-insert "Edit object " (eieio-object-name obj) "\n\n")
;; Create the widget editing the object.
(make-local-variable 'eieio-wo)
(setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g))
@@ -452,7 +452,7 @@
(vector (concat "Group " (symbol-name group))
(list 'customize-object obj (list 'quote group))
t))
- (class-option (object-class-fast obj) :custom-groups)))
+ (class-option (eieio--object-class obj) :custom-groups)))
(defvar eieio-read-custom-group-history nil
"History for the custom group reader.")
@@ -460,7 +460,7 @@
(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 (class-option (object-class-fast obj) :custom-groups)))
+ (let ((g (class-option (eieio--object-class obj) :custom-groups)))
(if (= (length g) 1)
(car g)
;; Make the association list
=== modified file 'lisp/emacs-lisp/eieio-datadebug.el'
--- lisp/emacs-lisp/eieio-datadebug.el 2013-01-01 09:11:05 +0000
+++ lisp/emacs-lisp/eieio-datadebug.el 2013-01-17 18:10:53 +0000
@@ -58,9 +58,9 @@
(end nil)
(str (object-print object))
(tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots"
- (object-name-string object)
- (object-class object)
- (class-parents (object-class object))
+ (eieio-object-name-string object)
+ (eieio-object-class object)
+ (eieio-class-parents (eieio-object-class object))
(length (object-slots object))
))
)
@@ -82,16 +82,16 @@
(defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
prefix)
"Insert the slots of OBJ into the current DDEBUG buffer."
- (data-debug-insert-thing (object-name-string obj)
+ (data-debug-insert-thing (eieio-object-name-string obj)
prefix
"Name: ")
- (let* ((cl (object-class obj))
+ (let* ((cl (eieio-object-class obj))
(cv (class-v cl)))
(data-debug-insert-thing (class-constructor cl)
prefix
"Class: ")
;; Loop over all the public slots
- (let ((publa (aref cv class-public-a))
+ (let ((publa (eieio--class-public-a cv))
)
(while publa
(if (slot-boundp obj (car publa))
@@ -123,7 +123,7 @@
;;
(defmethod data-debug-show ((obj eieio-default-superclass))
"Run ddebug against any EIEIO object OBJ."
- (data-debug-new-buffer (format "*%s DDEBUG*" (object-name obj)))
+ (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj)))
(data-debug-insert-object-slots obj "]"))
;;; DEBUG FUNCTIONS
=== modified file 'lisp/emacs-lisp/eieio-opt.el'
--- lisp/emacs-lisp/eieio-opt.el 2013-01-01 09:11:05 +0000
+++ lisp/emacs-lisp/eieio-opt.el 2013-01-17 18:04:49 +0000
@@ -45,7 +45,7 @@
nil t)))
nil))
(if (not root-class) (setq root-class 'eieio-default-superclass))
- (if (not (class-p root-class)) (signal 'wrong-type-argument (list 'class-p
root-class)))
+ (eieio--check-type class-p root-class)
(display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t)
(with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*")
(erase-buffer)
@@ -58,9 +58,9 @@
Argument THIS-ROOT is the local root of the tree.
Argument PREFIX is the character prefix to use.
Argument CH-PREFIX is another character prefix to display."
- (if (not (class-p (eval this-root))) (signal 'wrong-type-argument (list
'class-p this-root)))
+ (eieio--check-type class-p this-root)
(let ((myname (symbol-name this-root))
- (chl (aref (class-v this-root) class-children))
+ (chl (eieio--class-children (class-v this-root)))
(fprefix (concat ch-prefix " +--"))
(mprefix (concat ch-prefix " | "))
(lprefix (concat ch-prefix " ")))
@@ -99,7 +99,7 @@
(princ "'"))
(terpri)
;; Inheritance tree information
- (let ((pl (class-parents class)))
+ (let ((pl (eieio-class-parents class)))
(when pl
(princ " Inherits from ")
(while pl
@@ -107,7 +107,7 @@
(setq pl (cdr pl))
(if pl (princ ", ")))
(terpri)))
- (let ((ch (class-children class)))
+ (let ((ch (eieio-class-children class)))
(when ch
(princ " Children ")
(while ch
@@ -177,13 +177,13 @@
"Describe the slots in CLASS.
Outputs to the standard output."
(let* ((cv (class-v class))
- (docs (aref cv class-public-doc))
- (names (aref cv class-public-a))
- (deflt (aref cv class-public-d))
- (types (aref cv class-public-type))
- (publp (aref cv class-public-printer))
+ (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 (aref cv class-protection))
+ (prot (eieio--class-protection cv))
)
(princ "Instance Allocated Slots:")
(terpri)
@@ -213,11 +213,11 @@
publp (cdr publp)
prot (cdr prot)
i (1+ i)))
- (setq docs (aref cv class-class-allocation-doc)
- names (aref cv class-class-allocation-a)
- types (aref cv class-class-allocation-type)
+ (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 (aref cv class-class-allocation-protection))
+ prot (eieio--class-class-allocation-protection cv))
(when names
(terpri)
(princ "Class Allocated Slots:"))
@@ -281,7 +281,7 @@
(mapcar
(lambda (c)
(append (list c) (eieio-build-class-list c)))
- (class-children-fast class)))
+ (eieio-class-children-fast class)))
(list class)))
(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
@@ -291,7 +291,7 @@
are not abstract, otherwise allow all classes.
Optional argument BUILDLIST is more list to attach and is used internally."
(let* ((cc (or class eieio-default-superclass))
- (sublst (aref (class-v cc) class-children)))
+ (sublst (eieio--class-children (class-v cc))))
(unless (assoc (symbol-name cc) buildlist)
(when (or (not instantiable-only) (not (class-abstract-p cc)))
(setq buildlist (cons (cons (symbol-name cc) 1) buildlist))))
@@ -335,8 +335,7 @@
"Describe the generic function GENERIC.
Also extracts information about all methods specific to this generic."
(interactive (list (eieio-read-generic "Generic Method: ")))
- (if (not (generic-p generic))
- (signal 'wrong-type-argument '(generic-p generic)))
+ (eieio--check-type generic-p generic)
(with-output-to-temp-buffer (help-buffer) ; "*Help*"
(help-setup-xref (list #'eieio-describe-generic generic)
(called-interactively-p 'interactive))
@@ -757,9 +756,8 @@
(defun eieio-class-button (class depth)
"Draw a speedbar button at the current point for CLASS at DEPTH."
- (if (not (class-p class))
- (signal 'wrong-type-argument (list 'class-p class)))
- (let ((subclasses (aref (class-v class) class-children)))
+ (eieio--check-type class-p class)
+ (let ((subclasses (eieio--class-children (class-v class))))
(if subclasses
(speedbar-make-tag-line 'angle ?+
'eieio-sb-expand
@@ -784,7 +782,7 @@
(speedbar-with-writable
(save-excursion
(end-of-line) (forward-char 1)
- (let ((subclasses (aref (class-v class) class-children)))
+ (let ((subclasses (eieio--class-children (class-v class))))
(while subclasses
(eieio-class-button (car subclasses) (1+ indent))
(setq subclasses (cdr subclasses)))))))
=== modified file 'lisp/emacs-lisp/eieio-speedbar.el'
--- lisp/emacs-lisp/eieio-speedbar.el 2013-01-01 09:11:05 +0000
+++ lisp/emacs-lisp/eieio-speedbar.el 2013-01-17 18:04:21 +0000
@@ -198,7 +198,7 @@
(defmethod eieio-speedbar-description (object)
"Return a string describing OBJECT."
- (object-name-string object))
+ (eieio-object-name-string object))
(defmethod eieio-speedbar-derive-line-path (object)
"Return the path which OBJECT has something to do with."
@@ -206,7 +206,7 @@
(defmethod eieio-speedbar-object-buttonname (object)
"Return a string to use as a speedbar button for OBJECT."
- (object-name-string object))
+ (eieio-object-name-string object))
(defmethod eieio-speedbar-make-tag-line (object depth)
"Insert a tag line into speedbar at point for OBJECT.
@@ -324,7 +324,7 @@
(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth)
"Base method for creating tag lines for non-object children."
(error "You must implement `eieio-speedbar-child-make-tag-lines' for %s"
- (object-name object)))
+ (eieio-object-name object)))
(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth)
"Expand OBJECT at indentation DEPTH.
@@ -365,7 +365,7 @@
(defmethod eieio-speedbar-child-description ((obj eieio-speedbar))
"Return a description for a child of OBJ which is not an object."
(error "You must implement `eieio-speedbar-child-description' for %s"
- (object-name obj)))
+ (eieio-object-name obj)))
(defun eieio-speedbar-item-info ()
"Display info for the current line when in EDE display mode."
=== modified file 'lisp/emacs-lisp/eieio.el'
--- lisp/emacs-lisp/eieio.el 2013-02-02 03:38:21 +0000
+++ lisp/emacs-lisp/eieio.el 2013-02-03 13:29:10 +0000
@@ -105,49 +105,68 @@
;; This is a bootstrap for eieio-default-superclass so it has a value
;; while it is being built itself.
-(defvar eieio-default-superclass nil)
+(defvar eieio-default-superclass nil))
-;; FIXME: The constants below should have an `eieio-' prefix added!!
-(defconst class-symbol 1 "Class's symbol (self-referencing.).")
-(defconst class-parent 2 "Class parent slot.")
-(defconst class-children 3 "Class children class slot.")
-(defconst class-symbol-obarray 4 "Obarray permitting fast access to variable
position indexes.")
-;; @todo
-;; the word "public" here is leftovers from the very first version.
-;; Get rid of it!
-(defconst class-public-a 5 "Class attribute index.")
-(defconst class-public-d 6 "Class attribute defaults index.")
-(defconst class-public-doc 7 "Class documentation strings for attributes.")
-(defconst class-public-type 8 "Class type for a slot.")
-(defconst class-public-custom 9 "Class custom type for a slot.")
-(defconst class-public-custom-label 10 "Class custom group for a slot.")
-(defconst class-public-custom-group 11 "Class custom group for a slot.")
-(defconst class-public-printer 12 "Printer for a slot.")
-(defconst class-protection 13 "Class protection for a slot.")
-(defconst class-initarg-tuples 14 "Class initarg tuples list.")
-(defconst class-class-allocation-a 15 "Class allocated attributes.")
-(defconst class-class-allocation-doc 16 "Class allocated documentation.")
-(defconst class-class-allocation-type 17 "Class allocated value type.")
-(defconst class-class-allocation-custom 18 "Class allocated custom
descriptor.")
-(defconst class-class-allocation-custom-label 19 "Class allocated custom
descriptor.")
-(defconst class-class-allocation-custom-group 20 "Class allocated custom
group.")
-(defconst class-class-allocation-printer 21 "Class allocated printer for a
slot.")
-(defconst class-class-allocation-protection 22 "Class allocated protection
list.")
-(defconst class-class-allocation-values 23 "Class allocated value vector.")
-(defconst class-default-object-cache 24
- "Cache index of what a newly created object would look like.
+(defmacro eieio--define-field-accessors (prefix fields)
+ (declare (indent 1))
+ (let ((index 0)
+ (defs '()))
+ (dolist (field fields)
+ (let ((doc (if (listp field)
+ (prog1 (cadr field) (setq field (car field))))))
+ (push `(defmacro ,(intern (format "eieio--%s-%s" prefix field)) (x)
+ ,@(if doc (list (format (if (string-match "\n" doc)
+ "Return %s" "Return %s of a %s.")
+ doc prefix)))
+ (list 'aref x ,index))
+ defs)
+ (setq index (1+ index))))
+ `(progn
+ ,@(nreverse defs)
+ (eval-and-compile
+ (defconst ,(intern (format "eieio--%s-num-slots" prefix)) ,index)))))
+
+(eieio--define-field-accessors class
+ (-unused-0 ;;FIXME: not sure, but at least there was no accessor!
+ (symbol "symbol (self-referencing)")
+ parent children
+ (symbol-obarray "obarray permitting fast access to variable position
indexes")
+ ;; @todo
+ ;; the word "public" here is leftovers from the very first version.
+ ;; Get rid of it!
+ (public-a "class attribute index")
+ (public-d "class attribute defaults index")
+ (public-doc "class documentation strings for attributes")
+ (public-type "class type for a slot")
+ (public-custom "class custom type for a slot")
+ (public-custom-label "class custom group for a slot")
+ (public-custom-group "class custom group for a slot")
+ (public-printer "printer for a slot")
+ (protection "protection for a slot")
+ (initarg-tuples "initarg tuples list")
+ (class-allocation-a "class allocated attributes")
+ (class-allocation-doc "class allocated documentation")
+ (class-allocation-type "class allocated value type")
+ (class-allocation-custom "class allocated custom descriptor")
+ (class-allocation-custom-label "class allocated custom descriptor")
+ (class-allocation-custom-group "class allocated custom group")
+ (class-allocation-printer "class allocated printer for a slot")
+ (class-allocation-protection "class allocated protection list")
+ (class-allocation-values "class allocated value vector")
+ (default-object-cache "what a newly created object would look like.
This will speed up instantiation time as only a `copy-sequence' will
be needed, instead of looping over all the values and setting them
from the default.")
-(defconst class-options 25
- "Storage location of tagged class options.
-Stored outright without modifications or stripping.")
+ (options "storage location of tagged class options.
+Stored outright without modifications or stripping.")))
-(defconst class-num-slots 26
- "Number of slots in the class definition object.")
+(eieio--define-field-accessors object
+ (-unused-0 ;;FIXME: not sure, but at least there was no accessor!
+ (class "class struct defining OBJ")
+ name))
-(defconst object-class 1 "Index in an object vector where the class is
stored.")
-(defconst object-name 2 "Index in an object where the name is stored.")
+(eval-and-compile
+;; FIXME: The constants below should have an `eieio-' prefix added!!
(defconst method-static 0 "Index into :static tag on a method.")
(defconst method-before 1 "Index into :before tag on a method.")
@@ -188,13 +207,13 @@
`(condition-case nil
(let ((tobj ,obj))
(and (eq (aref tobj 0) 'object)
- (class-p (aref tobj object-class))))
+ (class-p (eieio--object-class tobj))))
(error nil)))
(defalias 'object-p 'eieio-object-p)
(defmacro class-constructor (class)
"Return the symbol representing the constructor of CLASS."
- `(aref (class-v ,class) class-symbol))
+ `(eieio--class-symbol (class-v ,class)))
(defmacro generic-p (method)
"Return t if symbol METHOD is a generic function.
@@ -241,7 +260,7 @@
(defmacro class-option (class option)
"Return the value stored for CLASS' OPTION.
Return nil if that option doesn't exist."
- `(class-option-assoc (aref (class-v ,class) class-options) ',option))
+ `(class-option-assoc (eieio--class-options (class-v ,class)) ',option))
(defmacro class-abstract-p (class)
"Return non-nil if CLASS is abstract.
@@ -334,14 +353,14 @@
;; Assume we've already debugged inputs.
(let* ((oldc (when (class-p cname) (class-v cname)))
- (newc (make-vector class-num-slots nil))
+ (newc (make-vector eieio--class-num-slots nil))
)
(if oldc
nil ;; Do nothing if we already have this class.
;; Create the class in NEWC, but don't fill anything else in.
(aset newc 0 'defclass)
- (aset newc class-symbol cname)
+ (setf (eieio--class-symbol newc) cname)
(let ((clear-parent nil))
;; No parents?
@@ -371,12 +390,12 @@
)
;; We have a parent, save the child in there.
- (when (not (member cname (aref (class-v SC) class-children)))
- (aset (class-v SC) class-children
- (cons cname (aref (class-v SC) class-children)))))
+ (when (not (member cname (eieio--class-children (class-v SC))))
+ (setf (eieio--class-children (class-v SC))
+ (cons cname (eieio--class-children (class-v SC))))))
;; save parent in child
- (aset newc class-parent (cons SC (aref newc class-parent)))
+ (setf (eieio--class-parent newc) (cons SC (eieio--class-parent newc)))
)
;; turn this into a usable self-pointing symbol
@@ -389,7 +408,7 @@
(put cname 'eieio-class-definition newc)
;; Clear the parent
- (if clear-parent (aset newc class-parent nil))
+ (if clear-parent (setf (eieio--class-parent newc) nil))
;; Create an autoload on top of our constructor function.
(autoload cname filename doc nil nil)
@@ -404,6 +423,15 @@
(when (eq (car-safe (symbol-function cname)) 'autoload)
(load-library (car (cdr (symbol-function cname))))))
+(defmacro eieio--check-type (type obj)
+ (unless (symbolp obj)
+ (error "eieio--check-type wants OBJ to be a variable"))
+ `(if (not ,(cond
+ ((eq 'or (car-safe type))
+ `(or ,@(mapcar (lambda (type) `(,type ,obj)) (cdr type))))
+ (t `(,type ,obj))))
+ (signal 'wrong-type-argument (list ',type ,obj))))
+
(defun eieio-defclass (cname superclasses slots options-and-doc)
;; FIXME: Most of this should be moved to the `defclass' macro.
"Define CNAME as a new subclass of SUPERCLASSES.
@@ -416,18 +444,17 @@
(run-hooks 'eieio-hook)
(setq eieio-hook nil)
- (if (not (listp superclasses))
- (signal 'wrong-type-argument '(listp superclasses)))
+ (eieio--check-type listp superclasses)
(let* ((pname superclasses)
- (newc (make-vector class-num-slots nil))
+ (newc (make-vector eieio--class-num-slots nil))
(oldc (when (class-p cname) (class-v cname)))
(groups nil) ;; list of groups id'd from slots
(options nil)
(clearparent nil))
(aset newc 0 'defclass)
- (aset newc class-symbol cname)
+ (setf (eieio--class-symbol newc) cname)
;; If this class already existed, and we are updating its structure,
;; make sure we keep the old child list. This can cause bugs, but
@@ -435,13 +462,13 @@
;; method table breakage, particularly when the users is only
;; byte compiling an EIEIO file.
(if oldc
- (aset newc class-children (aref oldc class-children))
+ (setf (eieio--class-children newc) (eieio--class-children oldc))
;; If the old class did not exist, but did exist in the autoload map,
then adopt those children.
;; This is like the above, but deals with autoloads nicely.
(let ((sym (intern-soft (symbol-name cname)
eieio-defclass-autoload-map)))
(when sym
(condition-case nil
- (aset newc class-children (symbol-value sym))
+ (setf (eieio--class-children newc) (symbol-value sym))
(error nil))
(unintern (symbol-name cname) eieio-defclass-autoload-map)
))
@@ -469,30 +496,30 @@
(error "Given parent class %s is not a class" (car pname))
;; good parent class...
;; save new child in parent
- (when (not (member cname (aref (class-v (car pname))
class-children)))
- (aset (class-v (car pname)) class-children
- (cons cname (aref (class-v (car pname))
class-children))))
+ (when (not (member cname (eieio--class-children (class-v (car
pname)))))
+ (setf (eieio--class-children (class-v (car pname)))
+ (cons cname (eieio--class-children (class-v (car
pname))))))
;; Get custom groups, and store them into our local copy.
(mapc (lambda (g) (add-to-list 'groups g))
(class-option (car pname) :custom-groups))
;; save parent in child
- (aset newc class-parent (cons (car pname) (aref newc
class-parent))))
+ (setf (eieio--class-parent newc) (cons (car pname)
(eieio--class-parent newc))))
(error "Invalid parent class %s" pname))
(setq pname (cdr pname)))
;; Reverse the list of our parents so that they are prioritized in
;; the same order as specified in the code.
- (aset newc class-parent (nreverse (aref newc class-parent))) )
+ (setf (eieio--class-parent newc) (nreverse (eieio--class-parent
newc))) )
;; If there is nothing to loop over, then inherit from the
;; default superclass.
(unless (eq cname 'eieio-default-superclass)
;; adopt the default parent here, but clear it later...
(setq clearparent t)
;; save new child in parent
- (if (not (member cname (aref (class-v 'eieio-default-superclass)
class-children)))
- (aset (class-v 'eieio-default-superclass) class-children
- (cons cname (aref (class-v 'eieio-default-superclass)
class-children))))
+ (if (not (member cname (eieio--class-children (class-v
'eieio-default-superclass))))
+ (setf (eieio--class-children (class-v 'eieio-default-superclass))
+ (cons cname (eieio--class-children (class-v
'eieio-default-superclass)))))
;; save parent in child
- (aset newc class-parent (list eieio-default-superclass))))
+ (setf (eieio--class-parent newc) (list eieio-default-superclass))))
;; turn this into a usable self-pointing symbol
(set cname cname)
@@ -714,26 +741,26 @@
;; Now that everything has been loaded up, all our lists are backwards!
;; Fix that up now.
- (aset newc class-public-a (nreverse (aref newc class-public-a)))
- (aset newc class-public-d (nreverse (aref newc class-public-d)))
- (aset newc class-public-doc (nreverse (aref newc class-public-doc)))
- (aset newc class-public-type
- (apply 'vector (nreverse (aref newc class-public-type))))
- (aset newc class-public-custom (nreverse (aref newc class-public-custom)))
- (aset newc class-public-custom-label (nreverse (aref newc
class-public-custom-label)))
- (aset newc class-public-custom-group (nreverse (aref newc
class-public-custom-group)))
- (aset newc class-public-printer (nreverse (aref newc
class-public-printer)))
- (aset newc class-protection (nreverse (aref newc class-protection)))
- (aset newc class-initarg-tuples (nreverse (aref newc
class-initarg-tuples)))
+ (setf (eieio--class-public-a newc) (nreverse (eieio--class-public-a newc)))
+ (setf (eieio--class-public-d newc) (nreverse (eieio--class-public-d newc)))
+ (setf (eieio--class-public-doc newc) (nreverse (eieio--class-public-doc
newc)))
+ (setf (eieio--class-public-type newc)
+ (apply 'vector (nreverse (eieio--class-public-type newc))))
+ (setf (eieio--class-public-custom newc) (nreverse
(eieio--class-public-custom newc)))
+ (setf (eieio--class-public-custom-label newc) (nreverse
(eieio--class-public-custom-label newc)))
+ (setf (eieio--class-public-custom-group newc) (nreverse
(eieio--class-public-custom-group newc)))
+ (setf (eieio--class-public-printer newc) (nreverse
(eieio--class-public-printer newc)))
+ (setf (eieio--class-protection newc) (nreverse (eieio--class-protection
newc)))
+ (setf (eieio--class-initarg-tuples newc) (nreverse
(eieio--class-initarg-tuples newc)))
;; The storage for class-class-allocation-type needs to be turned into
;; a vector now.
- (aset newc class-class-allocation-type
- (apply 'vector (aref newc class-class-allocation-type)))
+ (setf (eieio--class-class-allocation-type newc)
+ (apply 'vector (eieio--class-class-allocation-type newc)))
;; Also, take class allocated values, and vectorize them for speed.
- (aset newc class-class-allocation-values
- (apply 'vector (aref newc class-class-allocation-values)))
+ (setf (eieio--class-class-allocation-values newc)
+ (apply 'vector (eieio--class-class-allocation-values newc)))
;; Attach slot symbols into an obarray, and store the index of
;; this slot as the variable slot in this new symbol. We need to
@@ -741,8 +768,8 @@
;; prime number length, and we also need to make our vector small
;; to save space, and also optimal for the number of items we have.
(let* ((cnt 0)
- (pubsyms (aref newc class-public-a))
- (prots (aref newc class-protection))
+ (pubsyms (eieio--class-public-a newc))
+ (prots (eieio--class-protection newc))
(l (length pubsyms))
(vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47
53 59 61 67 71 73 79 83 89 97 101 )))
@@ -758,7 +785,7 @@
(if (car prots) (put newsym 'protection (car prots)))
(setq pubsyms (cdr pubsyms)
prots (cdr prots)))
- (aset newc class-symbol-obarray oa)
+ (setf (eieio--class-symbol-obarray newc) oa)
)
;; Create the constructor function
@@ -790,7 +817,7 @@
buffer-file-name))
loc)
(when fname
- (when (string-match "\\.elc$" fname)
+ (when (string-match "\\.elc\\'" fname)
(setq fname (substring fname 0 (1- (length fname)))))
(put cname 'class-location fname)))
@@ -802,23 +829,23 @@
(setq options (cons :custom-groups (cons g options)))))
;; Set up the options we have collected.
- (aset newc class-options options)
+ (setf (eieio--class-options newc) options)
;; if this is a superclass, clear out parent (which was set to the
;; default superclass eieio-default-superclass)
- (if clearparent (aset newc class-parent nil))
+ (if clearparent (setf (eieio--class-parent newc) nil))
;; Create the cached default object.
- (let ((cache (make-vector (+ (length (aref newc class-public-a))
- 3) nil)))
+ (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) 3)
+ nil)))
(aset cache 0 'object)
- (aset cache object-class cname)
- (aset cache object-name 'default-cache-object)
+ (setf (eieio--object-class cache) cname)
+ (setf (eieio--object-name cache) 'default-cache-object)
(let ((eieio-skip-typecheck t))
;; All type-checking has been done to our satisfaction
;; before this call. Don't waste our time in this call..
(eieio-set-defaults cache t))
- (aset newc class-default-object-cache cache))
+ (setf (eieio--class-default-object-cache newc) cache))
;; Return our new class object
;; newc
@@ -855,7 +882,7 @@
;; To prevent override information w/out specification of storage,
;; we need to do this little hack.
- (if (member a (aref newc class-class-allocation-a)) (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)))
;; In this case, we modify the INSTANCE version of a given slot.
@@ -863,31 +890,31 @@
(progn
;; Only add this element if it is so-far unique
- (if (not (member a (aref newc class-public-a)))
+ (if (not (member a (eieio--class-public-a newc)))
(progn
(eieio-perform-slot-validation-for-default a type d skipnil)
- (aset newc class-public-a (cons a (aref newc class-public-a)))
- (aset newc class-public-d (cons d (aref newc class-public-d)))
- (aset newc class-public-doc (cons doc (aref newc
class-public-doc)))
- (aset newc class-public-type (cons type (aref newc
class-public-type)))
- (aset newc class-public-custom (cons cust (aref newc
class-public-custom)))
- (aset newc class-public-custom-label (cons label (aref newc
class-public-custom-label)))
- (aset newc class-public-custom-group (cons custg (aref newc
class-public-custom-group)))
- (aset newc class-public-printer (cons print (aref newc
class-public-printer)))
- (aset newc class-protection (cons prot (aref newc
class-protection)))
- (aset newc class-initarg-tuples (cons (cons init a) (aref newc
class-initarg-tuples)))
+ (setf (eieio--class-public-a newc) (cons a (eieio--class-public-a
newc)))
+ (setf (eieio--class-public-d newc) (cons d (eieio--class-public-d
newc)))
+ (setf (eieio--class-public-doc newc) (cons doc
(eieio--class-public-doc newc)))
+ (setf (eieio--class-public-type newc) (cons type
(eieio--class-public-type newc)))
+ (setf (eieio--class-public-custom newc) (cons cust
(eieio--class-public-custom newc)))
+ (setf (eieio--class-public-custom-label newc) (cons label
(eieio--class-public-custom-label newc)))
+ (setf (eieio--class-public-custom-group newc) (cons custg
(eieio--class-public-custom-group newc)))
+ (setf (eieio--class-public-printer newc) (cons print
(eieio--class-public-printer newc)))
+ (setf (eieio--class-protection newc) (cons prot
(eieio--class-protection 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
;; attributes which must override the default value of any slot
;; passed in by one of the parent classes.
(when defaultoverride
;; There is a match, and we must override the old value.
- (let* ((ca (aref newc class-public-a))
+ (let* ((ca (eieio--class-public-a newc))
(np (member a ca))
(num (- (length ca) (length np)))
- (dp (if np (nthcdr num (aref newc class-public-d))
+ (dp (if np (nthcdr num (eieio--class-public-d newc))
nil))
- (tp (if np (nth num (aref newc class-public-type))))
+ (tp (if np (nth num (eieio--class-public-type newc))))
)
(if (not np)
(error "EIEIO internal error overriding default value for %s"
@@ -904,7 +931,7 @@
(setcar dp d))
;; If we have a new initarg, check for it.
(when init
- (let* ((inits (aref newc class-initarg-tuples))
+ (let* ((inits (eieio--class-initarg-tuples newc))
(inita (rassq a inits)))
;; Replace the CAR of the associate INITA.
;;(message "Initarg: %S replace %s" inita init)
@@ -920,7 +947,7 @@
;; EML - We used to have (if prot... here,
;; but a prot of 'nil means public.
;;
- (let ((super-prot (nth num (aref newc class-protection)))
+ (let ((super-prot (nth num (eieio--class-protection newc)))
)
(if (not (eq prot super-prot))
(error "Child slot protection `%s' does not match
inherited protection `%s' for `%s'"
@@ -932,7 +959,7 @@
;; groups and new ones.
(when custg
(let* ((groups
- (nthcdr num (aref newc class-public-custom-group)))
+ (nthcdr num (eieio--class-public-custom-group newc)))
(list1 (car groups))
(list2 (if (listp custg) custg (list custg))))
(if (< (length list1) (length list2))
@@ -947,20 +974,20 @@
;; set, simply replaces the old one.
(when cust
;; (message "Custom type redefined to %s" cust)
- (setcar (nthcdr num (aref newc class-public-custom)) cust))
+ (setcar (nthcdr num (eieio--class-public-custom newc)) cust))
;; If a new label is specified, it simply replaces
;; the old one.
(when label
;; (message "Custom label redefined to %s" label)
- (setcar (nthcdr num (aref newc class-public-custom-label))
label))
+ (setcar (nthcdr num (eieio--class-public-custom-label newc))
label))
;; End PLN
;; PLN Sat Jun 30 17:24:42 2007 : when a new
;; doc is specified, simply replaces the old one.
(when doc
;;(message "Documentation redefined to %s" doc)
- (setcar (nthcdr num (aref newc class-public-doc))
+ (setcar (nthcdr num (eieio--class-public-doc newc))
doc))
;; End PLN
@@ -968,38 +995,38 @@
;; the old one.
(when print
;; (message "printer redefined to %s" print)
- (setcar (nthcdr num (aref newc class-public-printer)) print))
+ (setcar (nthcdr num (eieio--class-public-printer newc))
print))
)))
))
;; CLASS ALLOCATED SLOTS
(let ((value (eieio-default-eval-maybe d)))
- (if (not (member a (aref newc class-class-allocation-a)))
+ (if (not (member a (eieio--class-class-allocation-a newc)))
(progn
(eieio-perform-slot-validation-for-default a type value skipnil)
;; Here we have found a :class version of a slot. This
;; requires a very different approach.
- (aset newc class-class-allocation-a (cons a (aref newc
class-class-allocation-a)))
- (aset newc class-class-allocation-doc (cons doc (aref newc
class-class-allocation-doc)))
- (aset newc class-class-allocation-type (cons type (aref newc
class-class-allocation-type)))
- (aset newc class-class-allocation-custom (cons cust (aref newc
class-class-allocation-custom)))
- (aset newc class-class-allocation-custom-label (cons label (aref
newc class-class-allocation-custom-label)))
- (aset newc class-class-allocation-custom-group (cons custg (aref
newc class-class-allocation-custom-group)))
- (aset newc class-class-allocation-protection (cons prot (aref newc
class-class-allocation-protection)))
+ (setf (eieio--class-class-allocation-a newc) (cons a
(eieio--class-class-allocation-a newc)))
+ (setf (eieio--class-class-allocation-doc newc) (cons doc
(eieio--class-class-allocation-doc newc)))
+ (setf (eieio--class-class-allocation-type newc) (cons type
(eieio--class-class-allocation-type newc)))
+ (setf (eieio--class-class-allocation-custom newc) (cons cust
(eieio--class-class-allocation-custom newc)))
+ (setf (eieio--class-class-allocation-custom-label newc) (cons 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)))
+ (setf (eieio--class-class-allocation-protection newc) (cons prot
(eieio--class-class-allocation-protection newc)))
;; Default value is stored in the 'values section, since new objects
;; can't initialize from this element.
- (aset newc class-class-allocation-values (cons value (aref newc
class-class-allocation-values))))
+ (setf (eieio--class-class-allocation-values newc) (cons value
(eieio--class-class-allocation-values newc))))
(when defaultoverride
;; There is a match, and we must override the old value.
- (let* ((ca (aref newc class-class-allocation-a))
+ (let* ((ca (eieio--class-class-allocation-a newc))
(np (member a ca))
(num (- (length ca) (length np)))
(dp (if np
(nthcdr num
- (aref newc class-class-allocation-values))
+ (eieio--class-class-allocation-values newc))
nil))
- (tp (if np (nth num (aref newc class-class-allocation-type))
+ (tp (if np (nth num (eieio--class-class-allocation-type newc))
nil)))
(if (not np)
(error "EIEIO internal error overriding default value for %s"
@@ -1023,7 +1050,7 @@
;; I wonder if a more flexible schedule might be
;; implemented.
(let ((super-prot
- (car (nthcdr num (aref newc
class-class-allocation-protection)))))
+ (car (nthcdr num (eieio--class-class-allocation-protection
newc)))))
(if (not (eq prot super-prot))
(error "Child slot protection `%s' does not match inherited
protection `%s' for `%s'"
prot super-prot a)))
@@ -1031,7 +1058,7 @@
;; and new ones.
(when custg
(let* ((groups
- (nthcdr num (aref newc
class-class-allocation-custom-group)))
+ (nthcdr num (eieio--class-class-allocation-custom-group
newc)))
(list1 (car groups))
(list2 (if (listp custg) custg (list custg))))
(if (< (length list1) (length list2))
@@ -1045,7 +1072,7 @@
;; doc is specified, simply replaces the old one.
(when doc
;;(message "Documentation redefined to %s" doc)
- (setcar (nthcdr num (aref newc class-class-allocation-doc))
+ (setcar (nthcdr num (eieio--class-class-allocation-doc newc))
doc))
;; End PLN
@@ -1053,7 +1080,7 @@
;; the old one.
(when print
;; (message "printer redefined to %s" print)
- (setcar (nthcdr num (aref newc class-class-allocation-printer))
print))
+ (setcar (nthcdr num (eieio--class-class-allocation-printer newc))
print))
))
))
@@ -1063,22 +1090,22 @@
"Copy into NEWC the slots of PARENTS.
Follow the rules of not overwriting early parents when applying to
the new child class."
- (let ((ps (aref newc class-parent))
- (sn (class-option-assoc (aref newc class-options)
+ (let ((ps (eieio--class-parent newc))
+ (sn (class-option-assoc (eieio--class-options newc)
':allow-nil-initform)))
(while ps
;; First, duplicate all the slots of the parent.
(let ((pcv (class-v (car ps))))
- (let ((pa (aref pcv class-public-a))
- (pd (aref pcv class-public-d))
- (pdoc (aref pcv class-public-doc))
- (ptype (aref pcv class-public-type))
- (pcust (aref pcv class-public-custom))
- (plabel (aref pcv class-public-custom-label))
- (pcustg (aref pcv class-public-custom-group))
- (printer (aref pcv class-public-printer))
- (pprot (aref pcv class-protection))
- (pinit (aref pcv class-initarg-tuples))
+ (let ((pa (eieio--class-public-a pcv))
+ (pd (eieio--class-public-d pcv))
+ (pdoc (eieio--class-public-doc pcv))
+ (ptype (eieio--class-public-type pcv))
+ (pcust (eieio--class-public-custom pcv))
+ (plabel (eieio--class-public-custom-label pcv))
+ (pcustg (eieio--class-public-custom-group pcv))
+ (printer (eieio--class-public-printer pcv))
+ (pprot (eieio--class-protection pcv))
+ (pinit (eieio--class-initarg-tuples pcv))
(i 0))
(while pa
(eieio-add-new-slot newc
@@ -1099,15 +1126,15 @@
pinit (cdr pinit))
)) ;; while/let
;; Now duplicate all the class alloc slots.
- (let ((pa (aref pcv class-class-allocation-a))
- (pdoc (aref pcv class-class-allocation-doc))
- (ptype (aref pcv class-class-allocation-type))
- (pcust (aref pcv class-class-allocation-custom))
- (plabel (aref pcv class-class-allocation-custom-label))
- (pcustg (aref pcv class-class-allocation-custom-group))
- (printer (aref pcv class-class-allocation-printer))
- (pprot (aref pcv class-class-allocation-protection))
- (pval (aref pcv class-class-allocation-values))
+ (let ((pa (eieio--class-class-allocation-a pcv))
+ (pdoc (eieio--class-class-allocation-doc pcv))
+ (ptype (eieio--class-class-allocation-type pcv))
+ (pcust (eieio--class-class-allocation-custom pcv))
+ (plabel (eieio--class-class-allocation-custom-label pcv))
+ (pcustg (eieio--class-class-allocation-custom-group pcv))
+ (printer (eieio--class-class-allocation-printer pcv))
+ (pprot (eieio--class-class-allocation-protection pcv))
+ (pval (eieio--class-class-allocation-values pcv))
(i 0))
(while pa
(eieio-add-new-slot newc
@@ -1252,7 +1279,7 @@
;; We do have an object. Make sure it is the right type.
(if ,(if (eq class eieio-default-superclass)
nil ; default superclass means just an obj. Already asked.
- `(not (child-of-class-p (aref (car local-args) object-class)
+ `(not (child-of-class-p (eieio--object-class (car local-args))
',class)))
;; If not the right kind of object, call no applicable
@@ -1335,27 +1362,20 @@
(defun eieio--defmethod (method kind argclass code)
"Work part of the `defmethod' macro defining METHOD with ARGS."
(let ((key
- ;; find optional keys
- (cond ((or (eq ':BEFORE kind)
- (eq ':before kind))
- method-before)
- ((or (eq ':AFTER kind)
- (eq ':after kind))
- method-after)
- ((or (eq ':PRIMARY kind)
- (eq ':primary kind))
- method-primary)
- ((or (eq ':STATIC kind)
- (eq ':static kind))
- method-static)
- ;; Primary key
- (t method-primary))))
+ ;; Find optional keys.
+ (cond ((memq kind '(:BEFORE :before)) method-before)
+ ((memq kind '(:AFTER :after)) method-after)
+ ((memq kind '(:STATIC :static)) method-static)
+ ((memq kind '(:PRIMARY :primary nil)) method-primary)
+ ;; Primary key.
+ ;; (t method-primary)
+ (t (error "Unknown method kind %S" kind)))))
;; Make sure there is a generic (when called from defclass).
(eieio--defalias
method (eieio--defgeneric-init-form
method (or (documentation code)
(format "Generically created method `%s'." method))))
- ;; create symbol for property to bind to. If the first arg is of
+ ;; Create symbol for property to bind to. If the first arg is of
;; the form (varname vartype) and `vartype' is a class, then
;; that class will be the type symbol. If not, then it will fall
;; under the type `primary' which is a non-specific calling of the
@@ -1364,11 +1384,9 @@
(if (not (class-p argclass))
(error "Unknown class type %s in method parameters"
argclass))
- (if (= key -1)
- (signal 'wrong-type-argument (list :static 'non-class-arg)))
- ;; generics are higher
+ ;; Generics are higher.
(setq key (eieio-specialized-key-to-generic-key key)))
- ;; Put this lambda into the symbol so we can find it
+ ;; Put this lambda into the symbol so we can find it.
(eieiomt-add method code key argclass)
)
@@ -1449,7 +1467,7 @@
nil
;; Trim off object IDX junk added in for the object index.
(setq slot-idx (- slot-idx 3))
- (let ((st (aref (aref (class-v class) class-public-type) slot-idx)))
+ (let ((st (aref (eieio--class-public-type (class-v class)) slot-idx)))
(if (not (eieio-perform-slot-validation st value))
(signal 'invalid-slot-type (list class slot st value))))))
@@ -1460,7 +1478,7 @@
an error."
(if eieio-skip-typecheck
nil
- (let ((st (aref (aref (class-v class) class-class-allocation-type)
+ (let ((st (aref (eieio--class-class-allocation-type (class-v class))
slot-idx)))
(if (not (eieio-perform-slot-validation st value))
(signal 'invalid-slot-type (list class slot st value))))))
@@ -1471,7 +1489,7 @@
slot. If the slot is ok, return VALUE.
Argument FN is the function calling this verifier."
(if (and (eq value eieio-unbound) (not eieio-skip-typecheck))
- (slot-unbound instance (object-class instance) slotname fn)
+ (slot-unbound instance (eieio-object-class instance) slotname fn)
value))
;;; Get/Set slots in an object.
@@ -1484,27 +1502,24 @@
(defun eieio-oref (obj slot)
"Return the value in OBJ at SLOT in the object vector."
- (if (not (or (eieio-object-p obj) (class-p obj)))
- (signal 'wrong-type-argument (list '(or eieio-object-p class-p) obj)))
- (if (not (symbolp slot))
- (signal 'wrong-type-argument (list 'symbolp slot)))
+ (eieio--check-type (or eieio-object-p class-p) obj)
+ (eieio--check-type symbolp slot)
(if (class-p obj) (eieio-class-un-autoload obj))
- (let* ((class (if (class-p obj) obj (aref obj object-class)))
+ (let* ((class (if (class-p obj) obj (eieio--object-class obj)))
(c (eieio-slot-name-index class obj slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
;; Let's check that info out.
(if (setq c (eieio-class-slot-name-index class slot))
;; Oref that slot.
- (aref (aref (class-v class) class-class-allocation-values) c)
+ (aref (eieio--class-class-allocation-values (class-v class)) c)
;; The slot-missing method is a cool way of allowing an object author
;; to intercept missing slot definitions. Since it is also the LAST
;; thing called in this fn, its return value would be retrieved.
(slot-missing obj slot 'oref)
- ;;(signal 'invalid-slot-name (list (object-name obj) slot))
+ ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot))
)
- (if (not (eieio-object-p obj))
- (signal 'wrong-type-argument (list 'eieio-object-p obj)))
+ (eieio--check-type eieio-object-p obj)
(eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref))))
(defalias 'slot-value 'eieio-oref)
@@ -1520,9 +1535,9 @@
(defun eieio-oref-default (obj slot)
"Do the work for the macro `oref-default' with similar parameters.
Fills in OBJ's SLOT with its default value."
- (if (not (or (eieio-object-p obj) (class-p obj))) (signal
'wrong-type-argument (list 'eieio-object-p obj)))
- (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot)))
- (let* ((cl (if (eieio-object-p obj) (aref obj object-class) obj))
+ (eieio--check-type (or eieio-object-p class-p) obj)
+ (eieio--check-type symbolp slot)
+ (let* ((cl (if (eieio-object-p obj) (eieio--object-class obj) obj))
(c (eieio-slot-name-index cl obj slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
@@ -1530,13 +1545,13 @@
(if (setq c
(eieio-class-slot-name-index cl slot))
;; Oref that slot.
- (aref (aref (class-v cl) class-class-allocation-values)
+ (aref (eieio--class-class-allocation-values (class-v cl))
c)
(slot-missing obj slot 'oref-default)
;;(signal 'invalid-slot-name (list (class-name cl) slot))
)
(eieio-barf-if-slot-unbound
- (let ((val (nth (- c 3) (aref (class-v cl) class-public-d))))
+ (let ((val (nth (- c 3) (eieio--class-public-d (class-v cl)))))
(eieio-default-eval-maybe val))
obj cl 'oref-default))))
@@ -1590,62 +1605,78 @@
;;; Simple generators, and query functions. None of these would do
;; well embedded into an object.
;;
-(defmacro object-class-fast (obj) "Return the class struct defining OBJ with
no check."
- `(aref ,obj object-class))
+(define-obsolete-function-alias
+ 'object-class-fast #'eieio--object-class "future")
-(defun class-name (class) "Return a Lisp like symbol name for CLASS."
- (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p
class)))
+(defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS."
+ (eieio--check-type class-p class)
;; I think this is supposed to return a symbol, but to me CLASS is a symbol,
;; and I wanted a string. Arg!
(format "#<class %s>" (symbol-name class)))
+(define-obsolete-function-alias 'class-name #'eieio-class-name "future")
-(defun object-name (obj &optional extra)
+(defun eieio-object-name (obj &optional extra)
"Return a Lisp like symbol string for object OBJ.
If EXTRA, include that in the string returned to represent the symbol."
- (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list
'eieio-object-p obj)))
- (format "#<%s %s%s>" (symbol-name (object-class-fast obj))
- (aref obj object-name) (or extra "")))
-
-(defun object-name-string (obj) "Return a string which is OBJ's name."
- (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list
'eieio-object-p obj)))
- (aref obj object-name))
-
-(defun object-set-name-string (obj name) "Set the string which is OBJ's NAME."
- (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list
'eieio-object-p obj)))
- (if (not (stringp name)) (signal 'wrong-type-argument (list 'stringp name)))
- (aset obj object-name name))
-
-(defun object-class (obj) "Return the class struct defining OBJ."
- (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list
'eieio-object-p obj)))
- (object-class-fast obj))
-(defalias 'class-of 'object-class)
-
-(defun object-class-name (obj) "Return a Lisp like symbol name for OBJ's
class."
- (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list
'eieio-object-p obj)))
- (class-name (object-class-fast obj)))
-
-(defmacro class-parents-fast (class) "Return parent classes to CLASS with no
check."
- `(aref (class-v ,class) class-parent))
+ (eieio--check-type eieio-object-p obj)
+ (format "#<%s %s%s>" (symbol-name (eieio--object-class obj))
+ (eieio--object-name obj) (or extra "")))
+(define-obsolete-function-alias 'object-name #'eieio-object-name "future")
+
+(defun eieio-object-name-string (obj) "Return a string which is OBJ's name."
+ (eieio--check-type eieio-object-p obj)
+ (eieio--object-name obj))
+(define-obsolete-function-alias
+ 'object-name-string #'eieio-object-name-string "future")
+
+(defun eieio-object-set-name-string (obj name)
+ "Set the string which is OBJ's NAME."
+ (eieio--check-type eieio-object-p obj)
+ (eieio--check-type stringp name)
+ (setf (eieio--object-name obj) name))
+(define-obsolete-function-alias
+ 'object-set-name-string 'eieio-object-set-name-string "future")
+
+(defun eieio-object-class (obj) "Return the class struct defining OBJ."
+ (eieio--check-type eieio-object-p obj)
+ (eieio--object-class obj))
+(define-obsolete-function-alias 'object-class #'eieio-object-class "future")
+;; CLOS name, maybe?
+(define-obsolete-function-alias 'class-of #'eieio-object-class "future")
+
+(defun eieio-object-class-name (obj)
+ "Return a Lisp like symbol name for OBJ's class."
+ (eieio--check-type eieio-object-p obj)
+ (eieio-class-name (eieio--object-class obj)))
+(define-obsolete-function-alias
+ 'object-class-name 'eieio-object-class-name "future")
+
+(defmacro eieio-class-parents-fast (class)
+ "Return parent classes to CLASS with no check."
+ `(eieio--class-parent (class-v ,class)))
-(defun class-parents (class)
+(defun eieio-class-parents (class)
"Return parent classes to CLASS. (overload of variable).
The CLOS function `class-direct-superclasses' is aliased to this function."
- (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p
class)))
- (class-parents-fast class))
+ (eieio--check-type class-p class)
+ (eieio-class-parents-fast class))
+(define-obsolete-function-alias 'class-parents #'eieio-class-parents "future")
-(defmacro class-children-fast (class) "Return child classes to CLASS with no
check."
- `(aref (class-v ,class) class-children))
+(defmacro eieio-class-children-fast (class) "Return child classes to CLASS
with no check."
+ `(eieio--class-children (class-v ,class)))
-(defun class-children (class)
-"Return child classes to CLASS.
+(defun eieio-class-children (class)
+ "Return child classes to CLASS.
The CLOS function `class-direct-subclasses' is aliased to this function."
- (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p
class)))
- (class-children-fast class))
+ (eieio--check-type class-p class)
+ (eieio-class-children-fast class))
+(define-obsolete-function-alias
+ 'class-children #'eieio-class-children "future")
(defun eieio-c3-candidate (class remaining-inputs)
- "Returns 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
;; element lists of REMAINING-INPUTS.
(and (not (let ((found nil))
@@ -1691,7 +1722,7 @@
(defun eieio-class-precedence-dfs (class)
"Return all parents of CLASS in depth-first order."
- (let* ((parents (class-parents-fast class))
+ (let* ((parents (eieio-class-parents-fast class))
(classes (copy-sequence
(apply #'append
(list class)
@@ -1712,21 +1743,21 @@
(defun eieio-class-precedence-bfs (class)
"Return all parents of CLASS in breadth-first order."
(let ((result)
- (queue (or (class-parents-fast class)
+ (queue (or (eieio-class-parents-fast class)
'(eieio-default-superclass))))
(while queue
(let ((head (pop queue)))
(unless (member head result)
(push head result)
(unless (eq head 'eieio-default-superclass)
- (setq queue (append queue (or (class-parents-fast head)
+ (setq queue (append queue (or (eieio-class-parents-fast head)
'(eieio-default-superclass))))))))
(cons class (nreverse result)))
)
(defun eieio-class-precedence-c3 (class)
"Return all parents of CLASS in c3 order."
- (let ((parents (class-parents-fast class)))
+ (let ((parents (eieio-class-parents-fast class)))
(eieio-c3-merge-lists
(list class)
(append
@@ -1739,7 +1770,7 @@
(list parents))))
)
-(defun class-precedence-list (class)
+(defun eieio-class-precedence-list (class)
"Return (transitively closed) list of parents of CLASS.
The order, in which the parents are returned depends on the
method invocation orders of the involved classes."
@@ -1753,52 +1784,60 @@
(:c3
(eieio-class-precedence-c3 class))))
)
+(define-obsolete-function-alias
+ 'class-precedence-list 'eieio-class-precedence-list "future")
;; Official CLOS functions.
-(defalias 'class-direct-superclasses 'class-parents)
-(defalias 'class-direct-subclasses 'class-children)
-
-(defmacro class-parent-fast (class) "Return first parent class to CLASS with
no check."
- `(car (class-parents-fast ,class)))
-
-(defmacro class-parent (class) "Return first parent class to CLASS. (overload
of variable)."
- `(car (class-parents ,class)))
-
-(defmacro same-class-fast-p (obj class) "Return t if OBJ is of class-type
CLASS with no error checking."
- `(eq (aref ,obj object-class) ,class))
+(define-obsolete-function-alias
+ 'class-direct-superclasses #'eieio-class-parents "future")
+(define-obsolete-function-alias
+ 'class-direct-subclasses #'eieio-class-children "future")
+
+(defmacro eieio-class-parent-fast (class)
+ "Return first parent class to CLASS with no check."
+ `(car (eieio-class-parents-fast ,class)))
+
+(defmacro eieio-class-parent (class)
+ "Return first parent class to CLASS. (overload of variable)."
+ `(car (eieio-class-parents ,class)))
+(define-obsolete-function-alias 'class-parent #'eieio-class-parent "future")
+
+(defmacro same-class-fast-p (obj class)
+ "Return t if OBJ is of class-type CLASS with no error checking."
+ `(eq (eieio--object-class ,obj) ,class))
(defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS."
- (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p
class)))
- (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list
'eieio-object-p obj)))
+ (eieio--check-type class-p class)
+ (eieio--check-type eieio-object-p obj)
(same-class-fast-p obj class))
(defun object-of-class-p (obj class)
"Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses."
- (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list
'eieio-object-p obj)))
+ (eieio--check-type eieio-object-p obj)
;; class will be checked one layer down
- (child-of-class-p (aref obj object-class) class))
+ (child-of-class-p (eieio--object-class obj) class))
;; Backwards compatibility
(defalias 'obj-of-class-p 'object-of-class-p)
(defun child-of-class-p (child class)
"Return non-nil if CHILD class is a subclass of CLASS."
- (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p
class)))
- (if (not (class-p child)) (signal 'wrong-type-argument (list 'class-p
child)))
+ (eieio--check-type class-p class)
+ (eieio--check-type class-p child)
(let ((p nil))
(while (and child (not (eq child class)))
- (setq p (append p (aref (class-v child) class-parent))
+ (setq p (append p (eieio--class-parent (class-v child)))
child (car p)
p (cdr p)))
(if child t)))
(defun object-slots (obj)
"Return list of slots available in OBJ."
- (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list
'eieio-object-p obj)))
- (aref (class-v (object-class-fast obj)) class-public-a))
+ (eieio--check-type eieio-object-p obj)
+ (eieio--class-public-a (class-v (eieio--object-class obj))))
(defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg."
- (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p
class)))
- (let ((ia (aref (class-v class) class-initarg-tuples))
+ (eieio--check-type class-p class)
+ (let ((ia (eieio--class-initarg-tuples (class-v class)))
(f nil))
(while (and ia (not f))
(if (eq (cdr (car ia)) slot)
@@ -1817,25 +1856,24 @@
(defun eieio-oset (obj slot value)
"Do the work for the macro `oset'.
Fills in OBJ's SLOT with VALUE."
- (if (not (eieio-object-p obj)) (signal 'wrong-type-argument (list
'eieio-object-p obj)))
- (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot)))
- (let ((c (eieio-slot-name-index (object-class-fast obj) obj slot)))
+ (eieio--check-type eieio-object-p obj)
+ (eieio--check-type symbolp slot)
+ (let ((c (eieio-slot-name-index (eieio--object-class obj) obj slot)))
(if (not c)
;; It might be missing because it is a :class allocated slot.
;; Let's check that info out.
(if (setq c
- (eieio-class-slot-name-index (aref obj object-class) slot))
+ (eieio-class-slot-name-index (eieio--object-class obj) slot))
;; Oset that slot.
(progn
- (eieio-validate-class-slot-value (object-class-fast obj) c value
slot)
- (aset (aref (class-v (aref obj object-class))
- class-class-allocation-values)
+ (eieio-validate-class-slot-value (eieio--object-class obj) c
value slot)
+ (aset (eieio--class-class-allocation-values (class-v
(eieio--object-class obj)))
c value))
;; See oref for comment on `slot-missing'
(slot-missing obj slot 'oset value)
- ;;(signal 'invalid-slot-name (list (object-name obj) slot))
+ ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot))
)
- (eieio-validate-slot-value (object-class-fast obj) c value slot)
+ (eieio-validate-slot-value (eieio--object-class obj) c value slot)
(aset obj c value))))
(defmacro oset-default (class slot value)
@@ -1848,8 +1886,8 @@
(defun eieio-oset-default (class slot value)
"Do the work for the macro `oset-default'.
Fills in the default value in CLASS' in SLOT with VALUE."
- (if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p
class)))
- (if (not (symbolp slot)) (signal 'wrong-type-argument (list 'symbolp slot)))
+ (eieio--check-type class-p class)
+ (eieio--check-type symbolp slot)
(let* ((scoped-class class)
(c (eieio-slot-name-index class nil slot)))
(if (not c)
@@ -1859,15 +1897,15 @@
(progn
;; Oref that slot.
(eieio-validate-class-slot-value class c value slot)
- (aset (aref (class-v class) class-class-allocation-values) c
+ (aset (eieio--class-class-allocation-values (class-v class)) c
value))
- (signal 'invalid-slot-name (list (class-name class) slot)))
+ (signal 'invalid-slot-name (list (eieio-class-name class) slot)))
(eieio-validate-slot-value class c value slot)
;; Set this into the storage for defaults.
- (setcar (nthcdr (- c 3) (aref (class-v class) class-public-d))
+ (setcar (nthcdr (- c 3) (eieio--class-public-d (class-v class)))
value)
;; Take the value, and put it into our cache object.
- (eieio-oset (aref (class-v class) class-default-object-cache)
+ (eieio-oset (eieio--class-default-object-cache (class-v class))
slot value)
)))
@@ -1894,12 +1932,12 @@
(defun slot-exists-p (object-or-class slot)
"Return non-nil if OBJECT-OR-CLASS has SLOT."
(let ((cv (class-v (cond ((eieio-object-p object-or-class)
- (object-class object-or-class))
+ (eieio-object-class object-or-class))
((class-p object-or-class)
object-or-class))
)))
- (or (memq slot (aref cv class-public-a))
- (memq slot (aref cv class-class-allocation-a)))
+ (or (memq slot (eieio--class-public-a cv))
+ (memq slot (eieio--class-class-allocation-a cv)))
))
(defun find-class (symbol &optional errorp)
@@ -1919,7 +1957,7 @@
Objects in LIST do not need to have a slot named SLOT, nor does
SLOT need to be bound. If these errors occur, those objects will
be ignored."
- (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list)))
+ (eieio--check-type listp list)
(while (and list (not (condition-case nil
;; This prevents errors for missing slots.
(equal key (eieio-oref (car list) slot))
@@ -1931,7 +1969,7 @@
"Return an association list with the contents of SLOT as the key element.
LIST must be a list of objects with SLOT in it.
This is useful when you need to do completing read on an object group."
- (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list)))
+ (eieio--check-type listp list)
(let ((assoclist nil))
(while list
(setq assoclist (cons (cons (eieio-oref (car list) slot)
@@ -1945,7 +1983,7 @@
LIST must be a list of objects, but those objects do not need to have
SLOT in it. If it does not, then that element is left out of the association
list."
- (if (not (listp list)) (signal 'wrong-type-argument (list 'listp list)))
+ (eieio--check-type listp list)
(let ((assoclist nil))
(while list
(if (slot-exists-p (car list) slot)
@@ -1993,14 +2031,13 @@
"Return non-nil if START-CLASS is the first class to define SLOT.
This is for testing if `scoped-class' is the class that defines SLOT
so that we can protect private slots."
- (let ((par (class-parents start-class))
+ (let ((par (eieio-class-parents start-class))
(ret t))
(if (not par)
t
(while (and par ret)
(if (intern-soft (symbol-name slot)
- (aref (class-v (car par))
- class-symbol-obarray))
+ (eieio--class-symbol-obarray (class-v (car par))))
(setq ret nil))
(setq par (cdr par)))
ret)))
@@ -2015,8 +2052,7 @@
reverse-lookup that name, and recurse with the associated slot value."
;; Removed checks to outside this call
(let* ((fsym (intern-soft (symbol-name slot)
- (aref (class-v class)
- class-symbol-obarray)))
+ (eieio--class-symbol-obarray (class-v class))))
(fsi (if (symbolp fsym) (symbol-value fsym) nil)))
(if (integerp fsi)
(cond
@@ -2026,7 +2062,7 @@
(bound-and-true-p scoped-class)
(or (child-of-class-p class scoped-class)
(and (eieio-object-p obj)
- (child-of-class-p class (object-class obj)))))
+ (child-of-class-p class (eieio-object-class obj)))))
(+ 3 fsi))
((and (eq (get fsym 'protection) 'private)
(or (and (bound-and-true-p scoped-class)
@@ -2044,7 +2080,7 @@
reverse-lookup that name, and recurse with the associated slot value."
;; This will happen less often, and with fewer slots. Do this the
;; storage cheap way.
- (let* ((a (aref (class-v class) class-class-allocation-a))
+ (let* ((a (eieio--class-class-allocation-a (class-v class)))
(l1 (length a))
(af (memq slot a))
(l2 (length af)))
@@ -2099,7 +2135,7 @@
(load (nth 1 (symbol-function firstarg))))
;; Determine the class to use.
(cond ((eieio-object-p firstarg)
- (setq mclass (object-class-fast firstarg)))
+ (setq mclass (eieio--object-class firstarg)))
((class-p firstarg)
(setq mclass firstarg))
)
@@ -2236,7 +2272,7 @@
;; Determine the class to use.
(cond ((eieio-object-p firstarg)
- (setq mclass (object-class-fast firstarg)))
+ (setq mclass (eieio--object-class firstarg)))
((not firstarg)
(error "Method %s called on nil" method))
((not (eieio-object-p firstarg))
@@ -2303,7 +2339,7 @@
;; Collect lambda expressions stored for the class and its parent
;; classes.
(let (lambdas)
- (dolist (ancestor (class-precedence-list class))
+ (dolist (ancestor (eieio-class-precedence-list class))
;; Lookup the form to use for the PRIMARY object for the next level
(let ((tmpl (eieio-generic-form method key ancestor)))
(when (and tmpl
@@ -2447,7 +2483,7 @@
nil for superclasses. This function performs no type checking!"
;; No type-checking because all calls are made from functions which
;; are safe and do checking for us.
- (or (class-parents-fast class)
+ (or (eieio-class-parents-fast class)
(if (eq class 'eieio-default-superclass)
nil
'(eieio-default-superclass))))
@@ -2460,7 +2496,7 @@
;; we replace the nil from above.
(let ((external-symbol (intern-soft (symbol-name s))))
(catch 'done
- (dolist (ancestor (rest (class-precedence-list external-symbol)))
+ (dolist (ancestor (rest (eieio-class-precedence-list external-symbol)))
(let ((ov (intern-soft (symbol-name ancestor)
eieiomt-optimizing-obarray)))
(when (fboundp ov)
@@ -2489,7 +2525,7 @@
(eieiomt-sym-optimize cs))))
;; 3) If it's bound return this one.
(if (fboundp cs)
- (cons cs (aref (class-v class) class-symbol))
+ (cons cs (eieio--class-symbol (class-v class)))
;; 4) If it's not bound then this variable knows something
(if (symbol-value cs)
(progn
@@ -2499,8 +2535,7 @@
;; 4.2) The optimizer should always have chosen a
;; function-symbol
;;(if (fboundp cs)
- (cons cs (aref (class-v (intern (symbol-name class)))
- class-symbol))
+ (cons cs (eieio--class-symbol (class-v (intern (symbol-name
class)))))
;;(error "EIEIO optimizer: erratic data loss!"))
)
;; There never will be a funcall...
@@ -2523,9 +2558,9 @@
If SET-ALL is non-nil, then when a default is nil, that value is
reset. If SET-ALL is nil, the slots are only reset if the default is
not nil."
- (let ((scoped-class (aref obj object-class))
+ (let ((scoped-class (eieio--object-class obj))
(eieio-initializing-object t)
- (pub (aref (class-v (aref obj object-class)) class-public-a)))
+ (pub (eieio--class-public-a (class-v (eieio--object-class obj)))))
(while pub
(let ((df (eieio-oref-default obj (car pub))))
(if (or df set-all)
@@ -2536,7 +2571,7 @@
"For CLASS, convert INITARG to the actual attribute name.
If there is no translation, pass it in directly (so we can cheat if
need be... May remove that later...)"
- (let ((tuple (assoc initarg (aref (class-v class) class-initarg-tuples))))
+ (let ((tuple (assoc initarg (eieio--class-initarg-tuples (class-v class)))))
(if tuple
(cdr tuple)
nil)))
@@ -2544,7 +2579,7 @@
(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 (aref (class-v class) class-initarg-tuples))))
+ (let ((tuple (rassoc attribute (eieio--class-initarg-tuples (class-v
class)))))
(if tuple
(car tuple)
nil)))
@@ -2632,10 +2667,9 @@
This static method is called when an object is constructed.
It allocates the vector used to represent an EIEIO object, and then
calls `shared-initialize' on that object."
- (let* ((new-object (copy-sequence (aref (class-v class)
- class-default-object-cache))))
+ (let* ((new-object (copy-sequence (eieio--class-default-object-cache
(class-v class)))))
;; Update the name for the newly created object.
- (aset new-object object-name newname)
+ (setf (eieio--object-name new-object) newname)
;; Call the initialize method on the new object with the slots
;; that were passed down to us.
(initialize-instance new-object slots)
@@ -2649,9 +2683,9 @@
(defmethod shared-initialize ((obj eieio-default-superclass) slots)
"Set slots of OBJ with SLOTS which is a list of name/value pairs.
Called from the constructor routine."
- (let ((scoped-class (aref obj object-class)))
+ (let ((scoped-class (eieio--object-class obj)))
(while slots
- (let ((rn (eieio-initarg-to-attribute (object-class-fast obj)
+ (let ((rn (eieio-initarg-to-attribute (eieio--object-class obj)
(car slots))))
(if (not rn)
(slot-missing obj (car slots) 'oset (car (cdr slots)))
@@ -2673,9 +2707,9 @@
dynamically set from SLOTS."
;; First, see if any of our defaults are `lambda', and
;; re-evaluate them and apply the value to our slots.
- (let* ((scoped-class (class-v (aref this object-class)))
- (slot (aref scoped-class class-public-a))
- (defaults (aref scoped-class class-public-d)))
+ (let* ((scoped-class (class-v (eieio--object-class this)))
+ (slot (eieio--class-public-a scoped-class))
+ (defaults (eieio--class-public-d scoped-class)))
(while slot
;; For each slot, see if we need to evaluate it.
;;
@@ -2705,7 +2739,7 @@
This method is called from `oref', `oset', and other functions which
directly reference slots in EIEIO objects."
- (signal 'invalid-slot-name (list (object-name object)
+ (signal 'invalid-slot-name (list (eieio-object-name object)
slot-name)))
(defgeneric slot-unbound (object class slot-name fn)
@@ -2723,7 +2757,7 @@
In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but
EIEIO can only dispatch on the first argument, so the first two are swapped."
- (signal 'unbound-slot (list (class-name class) (object-name object)
+ (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name
object)
slot-name fn)))
(defgeneric no-applicable-method (object method &rest args)
@@ -2737,7 +2771,7 @@
Implement this for a class to block this signal. The return
value becomes the return value of the original method call."
- (signal 'no-method-definition (list method (object-name object)))
+ (signal 'no-method-definition (list method (eieio-object-name object)))
)
(defgeneric no-next-method (object &rest args)
@@ -2751,7 +2785,7 @@
This method signals `no-next-method' by default. Override this
method to not throw an error, and its return value becomes the
return value of `call-next-method'."
- (signal 'no-next-method (list (object-name object) args))
+ (signal 'no-next-method (list (eieio-object-name object) args))
)
(defgeneric clone (obj &rest params)
@@ -2764,7 +2798,7 @@
(defmethod clone ((obj eieio-default-superclass) &rest params)
"Make a copy of OBJ, and then apply PARAMS."
(let ((nobj (copy-sequence obj))
- (nm (aref obj object-name))
+ (nm (eieio--object-name obj))
(passname (and params (stringp (car params))))
(num 1))
(if params (shared-initialize nobj (if passname (cdr params) params)))
@@ -2773,8 +2807,8 @@
(if (string-match "-\\([0-9]+\\)" nm)
(setq num (1+ (string-to-number (match-string 1 nm)))
nm (substring nm 0 (match-beginning 0))))
- (aset nobj object-name (concat nm "-" (int-to-string num))))
- (aset nobj object-name (car params)))
+ (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
+ (setf (eieio--object-name nobj) (car params)))
nobj))
(defgeneric destructor (this &rest params)
@@ -2806,7 +2840,7 @@
`call-next-method' to provide additional summary information.
When passing in extra strings from child classes, always remember
to prepend a space."
- (object-name this (apply 'concat strings)))
+ (eieio-object-name this (apply 'concat strings)))
(defvar eieio-print-depth 0
"When printing, keep track of the current indentation depth.")
@@ -2823,11 +2857,11 @@
this object."
(when comment
(princ ";; Object ")
- (princ (object-name-string this))
+ (princ (eieio-object-name-string this))
(princ "\n")
(princ comment)
(princ "\n"))
- (let* ((cl (object-class this))
+ (let* ((cl (eieio-object-class this))
(cv (class-v cl)))
;; Now output readable lisp to recreate this object
;; It should look like this:
@@ -2835,14 +2869,14 @@
;; Each slot's slot is writen using its :writer.
(princ (make-string (* eieio-print-depth 2) ? ))
(princ "(")
- (princ (symbol-name (class-constructor (object-class this))))
+ (princ (symbol-name (class-constructor (eieio-object-class this))))
(princ " ")
- (prin1 (object-name-string this))
+ (prin1 (eieio-object-name-string this))
(princ "\n")
;; Loop over all the public slots
- (let ((publa (aref cv class-public-a))
- (publd (aref cv class-public-d))
- (publp (aref cv class-public-printer))
+ (let ((publa (eieio--class-public-a cv))
+ (publd (eieio--class-public-d cv))
+ (publp (eieio--class-public-printer cv))
(eieio-print-depth (1+ eieio-print-depth)))
(while publa
(when (slot-boundp this (car publa))
@@ -2877,7 +2911,7 @@
((consp thing)
(eieio-list-prin1 thing))
((class-p thing)
- (princ (class-name thing)))
+ (princ (eieio-class-name thing)))
((or (keywordp thing) (booleanp thing))
(prin1 thing))
((symbolp thing)
@@ -2921,34 +2955,30 @@
(let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa)
;; find optional keys
(setq key
- (cond ((or (eq ':BEFORE (car args))
- (eq ':before (car args)))
+ (cond ((memq (car args) '(:BEFORE :before))
(setq args (cdr args))
method-before)
- ((or (eq ':AFTER (car args))
- (eq ':after (car args)))
+ ((memq (car args) '(:AFTER :after))
(setq args (cdr args))
method-after)
- ((or (eq ':PRIMARY (car args))
- (eq ':primary (car args)))
- (setq args (cdr args))
- method-primary)
- ((or (eq ':STATIC (car args))
- (eq ':static (car args)))
+ ((memq (car args) '(:STATIC :static))
(setq args (cdr args))
method-static)
- ;; Primary key
+ ((memq (car args) '(:PRIMARY :primary))
+ (setq args (cdr args))
+ method-primary)
+ ;; Primary key.
(t method-primary)))
- ;; get body, and fix contents of args to be the arguments of the fn.
+ ;; Get body, and fix contents of args to be the arguments of the fn.
(setq body (cdr args)
args (car args))
(setq loopa args)
- ;; Create a fixed version of the arguments
+ ;; Create a fixed version of the arguments.
(while loopa
(setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa))
argfix))
(setq loopa (cdr loopa)))
- ;; make sure there is a generic
+ ;; Make sure there is a generic.
(eieio-defgeneric
method
(if (stringp (car body))
@@ -2965,11 +2995,9 @@
(if (not (class-p argclass))
(error "Unknown class type %s in method parameters"
(nth 1 firstarg))))
- (if (= key -1)
- (signal 'wrong-type-argument (list :static 'non-class-arg)))
- ;; generics are higher
+ ;; Generics are higher.
(setq key (eieio-specialized-key-to-generic-key key)))
- ;; Put this lambda into the symbol so we can find it
+ ;; Put this lambda into the symbol so we can find it.
(if (byte-code-function-p (car-safe body))
(eieiomt-add method (car-safe body) key argclass)
(eieiomt-add method (append (list 'lambda (reverse argfix)) body)
@@ -3019,7 +3047,7 @@
"Display EIEIO OBJECT in fancy format.
Overrides the edebug default.
Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate."
- (cond ((class-p object) (class-name object))
+ (cond ((class-p object) (eieio-class-name object))
((eieio-object-p object) (object-print object))
((and (listp object) (or (class-p (car object))
(eieio-object-p (car object))))
- Cleaning up the EIEIO namespace,
Stefan Monnier <=
- Re: Cleaning up the EIEIO namespace, David Engster, 2013/02/12
- Re: Cleaning up the EIEIO namespace, Stefan Monnier, 2013/02/12
- Re: Cleaning up the EIEIO namespace, David Engster, 2013/02/13
- Re: [cedet-eieio] Cleaning up the EIEIO namespace, Eric M. Ludlam, 2013/02/13
- Re: [cedet-eieio] Cleaning up the EIEIO namespace, Stefan Monnier, 2013/02/14
- Re: [cedet-eieio] Cleaning up the EIEIO namespace, Xue Fuqiao, 2013/02/14
- Re: [cedet-eieio] Cleaning up the EIEIO namespace, David Engster, 2013/02/14