diff options
| author | Stefan Monnier | 2015-01-04 23:11:37 -0500 |
|---|---|---|
| committer | Stefan Monnier | 2015-01-04 23:11:37 -0500 |
| commit | cb4db863192aed6c4d0b28e6490f08d5518ff3e7 (patch) | |
| tree | 5d8e5dd834b7a3991e61631fcfcc209a7a25416e | |
| parent | 232823a1f163cebeafdab20ea2eb3f2da9645185 (diff) | |
| download | emacs-cb4db863192aed6c4d0b28e6490f08d5518ff3e7.tar.gz emacs-cb4db863192aed6c4d0b28e6490f08d5518ff3e7.zip | |
* lisp/emacs-lisp/eieio*.el: Use class objects in `parent' field.
* 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.
| -rw-r--r-- | lisp/ChangeLog | 65 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-base.el | 6 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-core.el | 443 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-custom.el | 13 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-datadebug.el | 6 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-opt.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio.el | 41 | ||||
| -rw-r--r-- | test/ChangeLog | 13 | ||||
| -rw-r--r-- | test/automated/eieio-test-persist.el | 11 | ||||
| -rw-r--r-- | test/automated/eieio-tests.el | 14 |
10 files changed, 357 insertions, 257 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 209c833fbe3..971253b3014 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog | |||
| @@ -1,3 +1,68 @@ | |||
| 1 | 2015-01-05 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | * emacs-lisp/eieio.el (eieio-class-parents): Accept class objects. | ||
| 4 | (eieio--class-slot-initarg): Rename from class-slot-initarg. | ||
| 5 | Change `class' arg to be a class object. Update all callers. | ||
| 6 | (call-next-method): Adjust to new return value of `eieio-generic-form'. | ||
| 7 | (eieio-default-superclass): Set var to the class object. | ||
| 8 | (eieio-edebug-prin1-to-string): Fix recursive call for lists. | ||
| 9 | Change print behavior to affect class objects rather than | ||
| 10 | class symbols. | ||
| 11 | |||
| 12 | * emacs-lisp/eieio-core.el (eieio-class-object): New function. | ||
| 13 | (eieio-class-parents-fast): Remove macro. | ||
| 14 | (eieio--class-option-assoc): Rename from class-option-assoc. | ||
| 15 | Update all callers. | ||
| 16 | (eieio--class-option): Rename from class-option. Change `class' arg to | ||
| 17 | be a class object. Update all callers. | ||
| 18 | (eieio--class-method-invocation-order): Rename from | ||
| 19 | class-method-invocation-order. Change `class' arg to be a class | ||
| 20 | object. Update all callers. | ||
| 21 | (eieio-defclass-autoload, eieio-defclass): Set the `parent' field to | ||
| 22 | a list of class objects rather than names. | ||
| 23 | (eieio-defclass): Remove redundant quotes. Use `eieio-oref-default' | ||
| 24 | for accessors to class allocated slots. | ||
| 25 | (eieio--perform-slot-validation-for-default): Rename from | ||
| 26 | eieio-perform-slot-validation-for-default. Update all callers. | ||
| 27 | (eieio--add-new-slot): Rename from eieio-add-new-slot. | ||
| 28 | Update all callers. Use push. | ||
| 29 | (eieio-copy-parents-into-subclass): Adjust to new content of | ||
| 30 | `parent' field. Use dolist. | ||
| 31 | (eieio-oref): Remove support for providing a class rather than | ||
| 32 | an object. | ||
| 33 | (eieio-oref-default): Prefer class objects over class names. | ||
| 34 | (eieio--slot-originating-class-p): Rename from | ||
| 35 | eieio-slot-originating-class-p. Update all callers. Use `or'. | ||
| 36 | (eieio--slot-name-index): Turn check into assertion. | ||
| 37 | (eieio--class-slot-name-index): Rename from | ||
| 38 | eieio-class-slot-name-index. Change `class' arg to be a class object. | ||
| 39 | Update all callers. | ||
| 40 | (eieio-attribute-to-initarg): Move to eieio-test-persist.el. | ||
| 41 | (eieio--c3-candidate): Rename from eieio-c3-candidate. | ||
| 42 | Update all callers. | ||
| 43 | (eieio--c3-merge-lists): Rename from eieio-c3-merge-lists. | ||
| 44 | Update all callers. | ||
| 45 | (eieio--class-precedence-c3): Rename from eieio-class-precedence-c3. | ||
| 46 | Update all callers. | ||
| 47 | (eieio--class-precedence-dfs): Rename from eieio-class-precedence-dfs. | ||
| 48 | Update all callers. | ||
| 49 | (eieio--class-precedence-bfs): Rename from eieio-class-precedence-bfs. | ||
| 50 | Update all callers. Adjust to new `parent' content. | ||
| 51 | (eieio--class-precedence-list): Rename from -class-precedence-list. | ||
| 52 | Update all callers. | ||
| 53 | (eieio-generic-call): Use autoloadp and autoload-do-load. | ||
| 54 | Slight simplification. | ||
| 55 | (eieio-generic-call, eieio-generic-call-primary-only): Adjust to new | ||
| 56 | return value of `eieio-generic-form'. | ||
| 57 | (eieiomt-add): Index the hashtable with class objects rather than | ||
| 58 | class names. | ||
| 59 | (eieio-generic-form): Accept class objects as well. | ||
| 60 | |||
| 61 | * emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object): | ||
| 62 | Adjust to new convention for eieio-persistent-validate/fix-slot-value. | ||
| 63 | (eieio-persistent-validate/fix-slot-value): | ||
| 64 | Change `class' arg to be a class object. Update all callers. | ||
| 65 | |||
| 1 | 2014-12-29 Stefan Monnier <monnier@iro.umontreal.ca> | 66 | 2014-12-29 Stefan Monnier <monnier@iro.umontreal.ca> |
| 2 | 67 | ||
| 3 | * emacs-lisp/eieio.el (child-of-class-p): Make it accept class objects | 68 | * emacs-lisp/eieio.el (child-of-class-p): Make it accept class objects |
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index e841ed664c0..7c0161b25d2 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el | |||
| @@ -270,7 +270,7 @@ identified, and needing more object creation." | |||
| 270 | ;; In addition, strip out quotes, list functions, and update | 270 | ;; In addition, strip out quotes, list functions, and update |
| 271 | ;; object constructors as needed. | 271 | ;; object constructors as needed. |
| 272 | (setq value (eieio-persistent-validate/fix-slot-value | 272 | (setq value (eieio-persistent-validate/fix-slot-value |
| 273 | objclass name value)) | 273 | (eieio--class-v objclass) name value)) |
| 274 | 274 | ||
| 275 | (push name createslots) | 275 | (push name createslots) |
| 276 | (push value createslots) | 276 | (push value createslots) |
| @@ -290,13 +290,13 @@ constructor functions are considered valid. | |||
| 290 | Second, any text properties will be stripped from strings." | 290 | Second, any text properties will be stripped from strings." |
| 291 | (cond ((consp proposed-value) | 291 | (cond ((consp proposed-value) |
| 292 | ;; Lists with something in them need special treatment. | 292 | ;; Lists with something in them need special treatment. |
| 293 | (let ((slot-idx (eieio--slot-name-index (eieio--class-v class) | 293 | (let ((slot-idx (eieio--slot-name-index class |
| 294 | nil slot)) | 294 | nil slot)) |
| 295 | (type nil) | 295 | (type nil) |
| 296 | (classtype nil)) | 296 | (classtype nil)) |
| 297 | (setq slot-idx (- slot-idx | 297 | (setq slot-idx (- slot-idx |
| 298 | (eval-when-compile eieio--object-num-slots))) | 298 | (eval-when-compile eieio--object-num-slots))) |
| 299 | (setq type (aref (eieio--class-public-type (eieio--class-v class)) | 299 | (setq type (aref (eieio--class-public-type class) |
| 300 | slot-idx)) | 300 | slot-idx)) |
| 301 | 301 | ||
| 302 | (setq classtype (eieio-persistent-slot-type-is-class-p | 302 | (setq classtype (eieio-persistent-slot-type-is-class-p |
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 924886c5ba1..950d70f450a 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el | |||
| @@ -1,6 +1,6 @@ | |||
| 1 | ;;; eieio-core.el --- Core implementation for eieio -*- lexical-binding:t -*- | 1 | ;;; eieio-core.el --- Core implementation for eieio -*- lexical-binding:t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | 5 | ;; Author: Eric M. Ludlam <zappo@gnu.org> |
| 6 | ;; Version: 1.4 | 6 | ;; Version: 1.4 |
| @@ -225,6 +225,12 @@ Stored outright without modifications or stripping."))) | |||
| 225 | (eq (aref class 0) 'defclass) | 225 | (eq (aref class 0) 'defclass) |
| 226 | (error nil))) | 226 | (error nil))) |
| 227 | 227 | ||
| 228 | (defsubst eieio-class-object (class) | ||
| 229 | "Check that CLASS is a class and return the corresponding object." | ||
| 230 | (let ((c (eieio--class-object class))) | ||
| 231 | (eieio--check-type eieio--class-p c) | ||
| 232 | c)) | ||
| 233 | |||
| 228 | (defsubst class-p (class) | 234 | (defsubst class-p (class) |
| 229 | "Return non-nil if CLASS is a valid class vector. | 235 | "Return non-nil if CLASS is a valid class vector. |
| 230 | CLASS is a symbol." ;FIXME: Is it a vector or a symbol? | 236 | 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? | |||
| 238 | "Return a Lisp like symbol name for CLASS." | 244 | "Return a Lisp like symbol name for CLASS." |
| 239 | ;; FIXME: What's a "Lisp like symbol name"? | 245 | ;; FIXME: What's a "Lisp like symbol name"? |
| 240 | ;; FIXME: CLOS returns a symbol, but the code returns a string. | 246 | ;; FIXME: CLOS returns a symbol, but the code returns a string. |
| 247 | (if (eieio--class-p class) (setq class (eieio--class-symbol class))) | ||
| 241 | (eieio--check-type class-p class) | 248 | (eieio--check-type class-p class) |
| 242 | ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, | 249 | ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, |
| 243 | ;; and I wanted a string. Arg! | 250 | ;; and I wanted a string. Arg! |
| 244 | (format "#<class %s>" (symbol-name class))) | 251 | (format "#<class %s>" (symbol-name class))) |
| 245 | (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") | 252 | (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") |
| 246 | 253 | ||
| 247 | (defmacro eieio-class-parents-fast (class) | ||
| 248 | "Return parent classes to CLASS with no check." | ||
| 249 | `(eieio--class-parent (eieio--class-v ,class))) | ||
| 250 | |||
| 251 | (defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check." | 254 | (defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check." |
| 255 | ;; FIXME: Remove. And change `children' to contain class objects rather than | ||
| 256 | ;; class names. | ||
| 252 | `(eieio--class-children (eieio--class-v ,class))) | 257 | `(eieio--class-children (eieio--class-v ,class))) |
| 253 | 258 | ||
| 254 | (defsubst same-class-fast-p (obj class-name) | 259 | (defsubst same-class-fast-p (obj class-name) |
| @@ -299,14 +304,14 @@ Methods with only primary implementations are executed in an optimized way." | |||
| 299 | (aref M eieio--method-generic-after))) | 304 | (aref M eieio--method-generic-after))) |
| 300 | ))) | 305 | ))) |
| 301 | 306 | ||
| 302 | (defmacro class-option-assoc (list option) | 307 | (defmacro eieio--class-option-assoc (list option) |
| 303 | "Return from LIST the found OPTION, or nil if it doesn't exist." | 308 | "Return from LIST the found OPTION, or nil if it doesn't exist." |
| 304 | `(car-safe (cdr (memq ,option ,list)))) | 309 | `(car-safe (cdr (memq ,option ,list)))) |
| 305 | 310 | ||
| 306 | (defmacro class-option (class option) | 311 | (defsubst eieio--class-option (class option) |
| 307 | "Return the value stored for CLASS' OPTION. | 312 | "Return the value stored for CLASS' OPTION. |
| 308 | Return nil if that option doesn't exist." | 313 | Return nil if that option doesn't exist." |
| 309 | `(class-option-assoc (eieio--class-options (eieio--class-v ,class)) ',option)) | 314 | (eieio--class-option-assoc (eieio--class-options class) option)) |
| 310 | 315 | ||
| 311 | (defsubst eieio-object-p (obj) | 316 | (defsubst eieio-object-p (obj) |
| 312 | "Return non-nil if OBJ is an EIEIO object." | 317 | "Return non-nil if OBJ is an EIEIO object." |
| @@ -320,13 +325,13 @@ Return nil if that option doesn't exist." | |||
| 320 | (defsubst class-abstract-p (class) | 325 | (defsubst class-abstract-p (class) |
| 321 | "Return non-nil if CLASS is abstract. | 326 | "Return non-nil if CLASS is abstract. |
| 322 | Abstract classes cannot be instantiated." | 327 | Abstract classes cannot be instantiated." |
| 323 | (class-option class :abstract)) | 328 | (eieio--class-option (eieio--class-v class) :abstract)) |
| 324 | 329 | ||
| 325 | (defmacro class-method-invocation-order (class) | 330 | (defsubst eieio--class-method-invocation-order (class) |
| 326 | "Return the invocation order of CLASS. | 331 | "Return the invocation order of CLASS. |
| 327 | Abstract classes cannot be instantiated." | 332 | Abstract classes cannot be instantiated." |
| 328 | `(or (class-option ,class :method-invocation-order) | 333 | (or (eieio--class-option class :method-invocation-order) |
| 329 | :breadth-first)) | 334 | :breadth-first)) |
| 330 | 335 | ||
| 331 | 336 | ||
| 332 | 337 | ||
| @@ -380,7 +385,7 @@ It creates an autoload function for CNAME's constructor." | |||
| 380 | (gethash SC eieio-defclass-autoload-map))) | 385 | (gethash SC eieio-defclass-autoload-map))) |
| 381 | 386 | ||
| 382 | ;; Save parent in child. | 387 | ;; Save parent in child. |
| 383 | (push SC (eieio--class-parent newc))) | 388 | (push (eieio--class-v SC) (eieio--class-parent newc))) |
| 384 | 389 | ||
| 385 | ;; turn this into a usable self-pointing symbol | 390 | ;; turn this into a usable self-pointing symbol |
| 386 | (set cname cname) | 391 | (set cname cname) |
| @@ -476,9 +481,9 @@ See `defclass' for more information." | |||
| 476 | (cl-pushnew cname (eieio--class-children (eieio--class-v p))) | 481 | (cl-pushnew cname (eieio--class-children (eieio--class-v p))) |
| 477 | ;; Get custom groups, and store them into our local copy. | 482 | ;; Get custom groups, and store them into our local copy. |
| 478 | (mapc (lambda (g) (cl-pushnew g groups :test #'equal)) | 483 | (mapc (lambda (g) (cl-pushnew g groups :test #'equal)) |
| 479 | (class-option p :custom-groups)) | 484 | (eieio--class-option (eieio--class-v p) :custom-groups)) |
| 480 | ;; save parent in child | 485 | ;; save parent in child |
| 481 | (push p (eieio--class-parent newc))) | 486 | (push (eieio--class-v p) (eieio--class-parent newc))) |
| 482 | (error "Invalid parent class %S" p))) | 487 | (error "Invalid parent class %S" p))) |
| 483 | ;; Reverse the list of our parents so that they are prioritized in | 488 | ;; Reverse the list of our parents so that they are prioritized in |
| 484 | ;; the same order as specified in the code. | 489 | ;; the same order as specified in the code. |
| @@ -488,11 +493,10 @@ See `defclass' for more information." | |||
| 488 | (unless (eq cname 'eieio-default-superclass) | 493 | (unless (eq cname 'eieio-default-superclass) |
| 489 | ;; adopt the default parent here, but clear it later... | 494 | ;; adopt the default parent here, but clear it later... |
| 490 | (setq clearparent t) | 495 | (setq clearparent t) |
| 491 | ;; save new child in parent | 496 | ;; save new child in parent |
| 492 | (cl-pushnew cname (eieio--class-children | 497 | (cl-pushnew cname (eieio--class-children eieio-default-superclass)) |
| 493 | (eieio--class-v 'eieio-default-superclass))) | 498 | ;; save parent in child |
| 494 | ;; save parent in child | 499 | (setf (eieio--class-parent newc) (list eieio-default-superclass)))) |
| 495 | (setf (eieio--class-parent newc) '(eieio-default-superclass)))) | ||
| 496 | 500 | ||
| 497 | ;; turn this into a usable self-pointing symbol; FIXME: Why? | 501 | ;; turn this into a usable self-pointing symbol; FIXME: Why? |
| 498 | (set cname cname) | 502 | (set cname cname) |
| @@ -510,7 +514,7 @@ See `defclass' for more information." | |||
| 510 | (same-class-p obj ',cname))))) | 514 | (same-class-p obj ',cname))))) |
| 511 | 515 | ||
| 512 | ;; Make sure the method invocation order is a valid value. | 516 | ;; Make sure the method invocation order is a valid value. |
| 513 | (let ((io (class-option-assoc options :method-invocation-order))) | 517 | (let ((io (eieio--class-option-assoc options :method-invocation-order))) |
| 514 | (when (and io (not (member io '(:depth-first :breadth-first :c3)))) | 518 | (when (and io (not (member io '(:depth-first :breadth-first :c3)))) |
| 515 | (error "Method invocation order %s is not allowed" io) | 519 | (error "Method invocation order %s is not allowed" io) |
| 516 | )) | 520 | )) |
| @@ -568,23 +572,23 @@ See `defclass' for more information." | |||
| 568 | (let* ((slot1 (car slots)) | 572 | (let* ((slot1 (car slots)) |
| 569 | (name (car slot1)) | 573 | (name (car slot1)) |
| 570 | (slot (cdr slot1)) | 574 | (slot (cdr slot1)) |
| 571 | (acces (plist-get slot ':accessor)) | 575 | (acces (plist-get slot :accessor)) |
| 572 | (init (or (plist-get slot ':initform) | 576 | (init (or (plist-get slot :initform) |
| 573 | (if (member ':initform slot) nil | 577 | (if (member :initform slot) nil |
| 574 | eieio-unbound))) | 578 | eieio-unbound))) |
| 575 | (initarg (plist-get slot ':initarg)) | 579 | (initarg (plist-get slot :initarg)) |
| 576 | (docstr (plist-get slot ':documentation)) | 580 | (docstr (plist-get slot :documentation)) |
| 577 | (prot (plist-get slot ':protection)) | 581 | (prot (plist-get slot :protection)) |
| 578 | (reader (plist-get slot ':reader)) | 582 | (reader (plist-get slot :reader)) |
| 579 | (writer (plist-get slot ':writer)) | 583 | (writer (plist-get slot :writer)) |
| 580 | (alloc (plist-get slot ':allocation)) | 584 | (alloc (plist-get slot :allocation)) |
| 581 | (type (plist-get slot ':type)) | 585 | (type (plist-get slot :type)) |
| 582 | (custom (plist-get slot ':custom)) | 586 | (custom (plist-get slot :custom)) |
| 583 | (label (plist-get slot ':label)) | 587 | (label (plist-get slot :label)) |
| 584 | (customg (plist-get slot ':group)) | 588 | (customg (plist-get slot :group)) |
| 585 | (printer (plist-get slot ':printer)) | 589 | (printer (plist-get slot :printer)) |
| 586 | 590 | ||
| 587 | (skip-nil (class-option-assoc options :allow-nil-initform)) | 591 | (skip-nil (eieio--class-option-assoc options :allow-nil-initform)) |
| 588 | ) | 592 | ) |
| 589 | 593 | ||
| 590 | (if eieio-error-unsupported-class-tags | 594 | (if eieio-error-unsupported-class-tags |
| @@ -613,18 +617,18 @@ See `defclass' for more information." | |||
| 613 | ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) | 617 | ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) |
| 614 | ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) | 618 | ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) |
| 615 | ((eq prot nil) nil) | 619 | ((eq prot nil) nil) |
| 616 | (t (signal 'invalid-slot-type (list ':protection prot)))) | 620 | (t (signal 'invalid-slot-type (list :protection prot)))) |
| 617 | 621 | ||
| 618 | ;; Make sure the :allocation parameter has a valid value. | 622 | ;; Make sure the :allocation parameter has a valid value. |
| 619 | (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) | 623 | (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) |
| 620 | (signal 'invalid-slot-type (list ':allocation alloc))) | 624 | (signal 'invalid-slot-type (list :allocation alloc))) |
| 621 | 625 | ||
| 622 | ;; The default type specifier is supposed to be t, meaning anything. | 626 | ;; The default type specifier is supposed to be t, meaning anything. |
| 623 | (if (not type) (setq type t)) | 627 | (if (not type) (setq type t)) |
| 624 | 628 | ||
| 625 | ;; Label is nil, or a string | 629 | ;; Label is nil, or a string |
| 626 | (if (not (or (null label) (stringp label))) | 630 | (if (not (or (null label) (stringp label))) |
| 627 | (signal 'invalid-slot-type (list ':label label))) | 631 | (signal 'invalid-slot-type (list :label label))) |
| 628 | 632 | ||
| 629 | ;; Is there an initarg, but allocation of class? | 633 | ;; Is there an initarg, but allocation of class? |
| 630 | (if (and initarg (eq alloc :class)) | 634 | (if (and initarg (eq alloc :class)) |
| @@ -641,11 +645,11 @@ See `defclass' for more information." | |||
| 641 | ;; The customgroup better be a symbol, or list of symbols. | 645 | ;; The customgroup better be a symbol, or list of symbols. |
| 642 | (mapc (lambda (cg) | 646 | (mapc (lambda (cg) |
| 643 | (if (not (symbolp cg)) | 647 | (if (not (symbolp cg)) |
| 644 | (signal 'invalid-slot-type (list ':group cg)))) | 648 | (signal 'invalid-slot-type (list :group cg)))) |
| 645 | customg) | 649 | customg) |
| 646 | 650 | ||
| 647 | ;; First up, add this slot into our new class. | 651 | ;; First up, add this slot into our new class. |
| 648 | (eieio-add-new-slot newc name init docstr type custom label customg printer | 652 | (eieio--add-new-slot newc name init docstr type custom label customg printer |
| 649 | prot initarg alloc 'defaultoverride skip-nil) | 653 | prot initarg alloc 'defaultoverride skip-nil) |
| 650 | 654 | ||
| 651 | ;; We need to id the group, and store them in a group list attribute. | 655 | ;; We need to id the group, and store them in a group list attribute. |
| @@ -663,9 +667,13 @@ See `defclass' for more information." | |||
| 663 | "Retrieves the slot `%s' from an object of class `%s'" | 667 | "Retrieves the slot `%s' from an object of class `%s'" |
| 664 | name cname) | 668 | name cname) |
| 665 | (if (slot-boundp this ',name) | 669 | (if (slot-boundp this ',name) |
| 666 | (eieio-oref this ',name) | 670 | ;; Use oref-default for :class allocated slots, since |
| 667 | ;; Else - Some error? nil? | 671 | ;; these also accept the use of a class argument instead |
| 668 | nil))) | 672 | ;; of an object argument. |
| 673 | (,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref) | ||
| 674 | this ',name) | ||
| 675 | ;; Else - Some error? nil? | ||
| 676 | nil))) | ||
| 669 | 677 | ||
| 670 | ;; FIXME: We should move more of eieio-defclass into the | 678 | ;; FIXME: We should move more of eieio-defclass into the |
| 671 | ;; defclass macro so we don't have to use `eval' and require | 679 | ;; defclass macro so we don't have to use `eval' and require |
| @@ -674,7 +682,12 @@ See `defclass' for more information." | |||
| 674 | ;; function, but the define-setter below affects the whole | 682 | ;; function, but the define-setter below affects the whole |
| 675 | ;; generic function! | 683 | ;; generic function! |
| 676 | (eval `(gv-define-setter ,acces (eieio--store eieio--object) | 684 | (eval `(gv-define-setter ,acces (eieio--store eieio--object) |
| 677 | (list 'eieio-oset eieio--object '',name | 685 | ;; Apparently, eieio-oset-default doesn't work like |
| 686 | ;; oref-default and only accept class arguments! | ||
| 687 | (list ',(if nil ;; (eq alloc :class) | ||
| 688 | 'eieio-oset-default | ||
| 689 | 'eieio-oset) | ||
| 690 | eieio--object '',name | ||
| 678 | eieio--store))))) | 691 | eieio--store))))) |
| 679 | 692 | ||
| 680 | ;; If a writer is defined, then create a generic method of that | 693 | ;; If a writer is defined, then create a generic method of that |
| @@ -737,9 +750,9 @@ See `defclass' for more information." | |||
| 737 | (setf (eieio--class-symbol-hashtable newc) oa)) | 750 | (setf (eieio--class-symbol-hashtable newc) oa)) |
| 738 | 751 | ||
| 739 | ;; Create the constructor function | 752 | ;; Create the constructor function |
| 740 | (if (class-option-assoc options :abstract) | 753 | (if (eieio--class-option-assoc options :abstract) |
| 741 | ;; Abstract classes cannot be instantiated. Say so. | 754 | ;; Abstract classes cannot be instantiated. Say so. |
| 742 | (let ((abs (class-option-assoc options :abstract))) | 755 | (let ((abs (eieio--class-option-assoc options :abstract))) |
| 743 | (if (not (stringp abs)) | 756 | (if (not (stringp abs)) |
| 744 | (setq abs (format "Class %s is abstract" cname))) | 757 | (setq abs (format "Class %s is abstract" cname))) |
| 745 | (fset cname | 758 | (fset cname |
| @@ -762,7 +775,7 @@ See `defclass' for more information." | |||
| 762 | ;; Set up a specialized doc string. | 775 | ;; Set up a specialized doc string. |
| 763 | ;; Use stored value since it is calculated in a non-trivial way | 776 | ;; Use stored value since it is calculated in a non-trivial way |
| 764 | (put cname 'variable-documentation | 777 | (put cname 'variable-documentation |
| 765 | (class-option-assoc options :documentation)) | 778 | (eieio--class-option-assoc options :documentation)) |
| 766 | 779 | ||
| 767 | ;; Save the file location where this class is defined. | 780 | ;; Save the file location where this class is defined. |
| 768 | (let ((fname (if load-in-progress | 781 | (let ((fname (if load-in-progress |
| @@ -774,7 +787,7 @@ See `defclass' for more information." | |||
| 774 | (put cname 'class-location fname))) | 787 | (put cname 'class-location fname))) |
| 775 | 788 | ||
| 776 | ;; We have a list of custom groups. Store them into the options. | 789 | ;; We have a list of custom groups. Store them into the options. |
| 777 | (let ((g (class-option-assoc options :custom-groups))) | 790 | (let ((g (eieio--class-option-assoc options :custom-groups))) |
| 778 | (mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups) | 791 | (mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups) |
| 779 | (if (memq :custom-groups options) | 792 | (if (memq :custom-groups options) |
| 780 | (setcar (cdr (memq :custom-groups options)) g) | 793 | (setcar (cdr (memq :custom-groups options)) g) |
| @@ -814,16 +827,16 @@ See `defclass' for more information." | |||
| 814 | "Whether the default value VAL should be evaluated for use." | 827 | "Whether the default value VAL should be evaluated for use." |
| 815 | (and (consp val) (symbolp (car val)) (fboundp (car val)))) | 828 | (and (consp val) (symbolp (car val)) (fboundp (car val)))) |
| 816 | 829 | ||
| 817 | (defun eieio-perform-slot-validation-for-default (slot spec value skipnil) | 830 | (defun eieio--perform-slot-validation-for-default (slot spec value skipnil) |
| 818 | "For SLOT, signal if SPEC does not match VALUE. | 831 | "For SLOT, signal if SPEC does not match VALUE. |
| 819 | If SKIPNIL is non-nil, then if VALUE is nil return t instead." | 832 | If SKIPNIL is non-nil, then if VALUE is nil return t instead." |
| 820 | (if (and (not (eieio-eval-default-p value)) | 833 | (if (not (or (eieio-eval-default-p value) ;FIXME: Why? |
| 821 | (not eieio-skip-typecheck) | 834 | eieio-skip-typecheck |
| 822 | (not (and skipnil (null value))) | 835 | (and skipnil (null value)) |
| 823 | (not (eieio-perform-slot-validation spec value))) | 836 | (eieio-perform-slot-validation spec value))) |
| 824 | (signal 'invalid-slot-type (list slot spec value)))) | 837 | (signal 'invalid-slot-type (list slot spec value)))) |
| 825 | 838 | ||
| 826 | (defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc | 839 | (defun eieio--add-new-slot (newc a d doc type cust label custg print prot init alloc |
| 827 | &optional defaultoverride skipnil) | 840 | &optional defaultoverride skipnil) |
| 828 | "Add into NEWC attribute A. | 841 | "Add into NEWC attribute A. |
| 829 | If A already exists in NEWC, then do nothing. If it doesn't exist, | 842 | If A already exists in NEWC, then do nothing. If it doesn't exist, |
| @@ -844,9 +857,9 @@ if default value is nil." | |||
| 844 | 857 | ||
| 845 | ;; To prevent override information w/out specification of storage, | 858 | ;; To prevent override information w/out specification of storage, |
| 846 | ;; we need to do this little hack. | 859 | ;; we need to do this little hack. |
| 847 | (if (member a (eieio--class-class-allocation-a newc)) (setq alloc ':class)) | 860 | (if (member a (eieio--class-class-allocation-a newc)) (setq alloc :class)) |
| 848 | 861 | ||
| 849 | (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) | 862 | (if (or (not alloc) (and (symbolp alloc) (eq alloc :instance))) |
| 850 | ;; In this case, we modify the INSTANCE version of a given slot. | 863 | ;; In this case, we modify the INSTANCE version of a given slot. |
| 851 | 864 | ||
| 852 | (progn | 865 | (progn |
| @@ -854,16 +867,16 @@ if default value is nil." | |||
| 854 | ;; Only add this element if it is so-far unique | 867 | ;; Only add this element if it is so-far unique |
| 855 | (if (not (member a (eieio--class-public-a newc))) | 868 | (if (not (member a (eieio--class-public-a newc))) |
| 856 | (progn | 869 | (progn |
| 857 | (eieio-perform-slot-validation-for-default a type d skipnil) | 870 | (eieio--perform-slot-validation-for-default a type d skipnil) |
| 858 | (setf (eieio--class-public-a newc) (cons a (eieio--class-public-a newc))) | 871 | (push a (eieio--class-public-a newc)) |
| 859 | (setf (eieio--class-public-d newc) (cons d (eieio--class-public-d newc))) | 872 | (push d (eieio--class-public-d newc)) |
| 860 | (setf (eieio--class-public-doc newc) (cons doc (eieio--class-public-doc newc))) | 873 | (push doc (eieio--class-public-doc newc)) |
| 861 | (setf (eieio--class-public-type newc) (cons type (eieio--class-public-type newc))) | 874 | (push type (eieio--class-public-type newc)) |
| 862 | (setf (eieio--class-public-custom newc) (cons cust (eieio--class-public-custom newc))) | 875 | (push cust (eieio--class-public-custom newc)) |
| 863 | (setf (eieio--class-public-custom-label newc) (cons label (eieio--class-public-custom-label newc))) | 876 | (push label (eieio--class-public-custom-label newc)) |
| 864 | (setf (eieio--class-public-custom-group newc) (cons custg (eieio--class-public-custom-group newc))) | 877 | (push custg (eieio--class-public-custom-group newc)) |
| 865 | (setf (eieio--class-public-printer newc) (cons print (eieio--class-public-printer newc))) | 878 | (push print (eieio--class-public-printer newc)) |
| 866 | (setf (eieio--class-protection newc) (cons prot (eieio--class-protection newc))) | 879 | (push prot (eieio--class-protection newc)) |
| 867 | (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) | 880 | (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) |
| 868 | ) | 881 | ) |
| 869 | ;; When defaultoverride is true, we are usually adding new local | 882 | ;; When defaultoverride is true, we are usually adding new local |
| @@ -889,7 +902,7 @@ if default value is nil." | |||
| 889 | type tp a))) | 902 | type tp a))) |
| 890 | ;; If we have a repeat, only update the initarg... | 903 | ;; If we have a repeat, only update the initarg... |
| 891 | (unless (eq d eieio-unbound) | 904 | (unless (eq d eieio-unbound) |
| 892 | (eieio-perform-slot-validation-for-default a tp d skipnil) | 905 | (eieio--perform-slot-validation-for-default a tp d skipnil) |
| 893 | (setcar dp d)) | 906 | (setcar dp d)) |
| 894 | ;; If we have a new initarg, check for it. | 907 | ;; If we have a new initarg, check for it. |
| 895 | (when init | 908 | (when init |
| @@ -966,19 +979,19 @@ if default value is nil." | |||
| 966 | (let ((value (eieio-default-eval-maybe d))) | 979 | (let ((value (eieio-default-eval-maybe d))) |
| 967 | (if (not (member a (eieio--class-class-allocation-a newc))) | 980 | (if (not (member a (eieio--class-class-allocation-a newc))) |
| 968 | (progn | 981 | (progn |
| 969 | (eieio-perform-slot-validation-for-default a type value skipnil) | 982 | (eieio--perform-slot-validation-for-default a type value skipnil) |
| 970 | ;; Here we have found a :class version of a slot. This | 983 | ;; Here we have found a :class version of a slot. This |
| 971 | ;; requires a very different approach. | 984 | ;; requires a very different approach. |
| 972 | (setf (eieio--class-class-allocation-a newc) (cons a (eieio--class-class-allocation-a newc))) | 985 | (push a (eieio--class-class-allocation-a newc)) |
| 973 | (setf (eieio--class-class-allocation-doc newc) (cons doc (eieio--class-class-allocation-doc newc))) | 986 | (push doc (eieio--class-class-allocation-doc newc)) |
| 974 | (setf (eieio--class-class-allocation-type newc) (cons type (eieio--class-class-allocation-type newc))) | 987 | (push type (eieio--class-class-allocation-type newc)) |
| 975 | (setf (eieio--class-class-allocation-custom newc) (cons cust (eieio--class-class-allocation-custom newc))) | 988 | (push cust (eieio--class-class-allocation-custom newc)) |
| 976 | (setf (eieio--class-class-allocation-custom-label newc) (cons label (eieio--class-class-allocation-custom-label newc))) | 989 | (push label (eieio--class-class-allocation-custom-label newc)) |
| 977 | (setf (eieio--class-class-allocation-custom-group newc) (cons custg (eieio--class-class-allocation-custom-group newc))) | 990 | (push custg (eieio--class-class-allocation-custom-group newc)) |
| 978 | (setf (eieio--class-class-allocation-protection newc) (cons prot (eieio--class-class-allocation-protection newc))) | 991 | (push prot (eieio--class-class-allocation-protection newc)) |
| 979 | ;; Default value is stored in the 'values section, since new objects | 992 | ;; Default value is stored in the 'values section, since new objects |
| 980 | ;; can't initialize from this element. | 993 | ;; can't initialize from this element. |
| 981 | (setf (eieio--class-class-allocation-values newc) (cons value (eieio--class-class-allocation-values newc)))) | 994 | (push value (eieio--class-class-allocation-values newc))) |
| 982 | (when defaultoverride | 995 | (when defaultoverride |
| 983 | ;; There is a match, and we must override the old value. | 996 | ;; There is a match, and we must override the old value. |
| 984 | (let* ((ca (eieio--class-class-allocation-a newc)) | 997 | (let* ((ca (eieio--class-class-allocation-a newc)) |
| @@ -1003,7 +1016,7 @@ if default value is nil." | |||
| 1003 | ;; is to change the default, so allow unbound in. | 1016 | ;; is to change the default, so allow unbound in. |
| 1004 | 1017 | ||
| 1005 | ;; If we have a repeat, only update the value... | 1018 | ;; If we have a repeat, only update the value... |
| 1006 | (eieio-perform-slot-validation-for-default a tp value skipnil) | 1019 | (eieio--perform-slot-validation-for-default a tp value skipnil) |
| 1007 | (setcar dp value)) | 1020 | (setcar dp value)) |
| 1008 | 1021 | ||
| 1009 | ;; PLN Tue Jun 26 11:57:06 2007 : The protection is | 1022 | ;; PLN Tue Jun 26 11:57:06 2007 : The protection is |
| @@ -1052,71 +1065,66 @@ if default value is nil." | |||
| 1052 | "Copy into NEWC the slots of PARENTS. | 1065 | "Copy into NEWC the slots of PARENTS. |
| 1053 | Follow the rules of not overwriting early parents when applying to | 1066 | Follow the rules of not overwriting early parents when applying to |
| 1054 | the new child class." | 1067 | the new child class." |
| 1055 | (let ((ps (eieio--class-parent newc)) | 1068 | (let ((sn (eieio--class-option-assoc (eieio--class-options newc) |
| 1056 | (sn (class-option-assoc (eieio--class-options newc) | 1069 | :allow-nil-initform))) |
| 1057 | ':allow-nil-initform))) | 1070 | (dolist (pcv (eieio--class-parent newc)) |
| 1058 | (while ps | ||
| 1059 | ;; First, duplicate all the slots of the parent. | 1071 | ;; First, duplicate all the slots of the parent. |
| 1060 | (let ((pcv (eieio--class-v (car ps)))) | 1072 | (let ((pa (eieio--class-public-a pcv)) |
| 1061 | (let ((pa (eieio--class-public-a pcv)) | 1073 | (pd (eieio--class-public-d pcv)) |
| 1062 | (pd (eieio--class-public-d pcv)) | 1074 | (pdoc (eieio--class-public-doc pcv)) |
| 1063 | (pdoc (eieio--class-public-doc pcv)) | 1075 | (ptype (eieio--class-public-type pcv)) |
| 1064 | (ptype (eieio--class-public-type pcv)) | 1076 | (pcust (eieio--class-public-custom pcv)) |
| 1065 | (pcust (eieio--class-public-custom pcv)) | 1077 | (plabel (eieio--class-public-custom-label pcv)) |
| 1066 | (plabel (eieio--class-public-custom-label pcv)) | 1078 | (pcustg (eieio--class-public-custom-group pcv)) |
| 1067 | (pcustg (eieio--class-public-custom-group pcv)) | 1079 | (printer (eieio--class-public-printer pcv)) |
| 1068 | (printer (eieio--class-public-printer pcv)) | 1080 | (pprot (eieio--class-protection pcv)) |
| 1069 | (pprot (eieio--class-protection pcv)) | 1081 | (pinit (eieio--class-initarg-tuples pcv)) |
| 1070 | (pinit (eieio--class-initarg-tuples pcv)) | 1082 | (i 0)) |
| 1071 | (i 0)) | 1083 | (while pa |
| 1072 | (while pa | 1084 | (eieio--add-new-slot newc |
| 1073 | (eieio-add-new-slot newc | 1085 | (car pa) (car pd) (car pdoc) (aref ptype i) |
| 1074 | (car pa) (car pd) (car pdoc) (aref ptype i) | 1086 | (car pcust) (car plabel) (car pcustg) |
| 1075 | (car pcust) (car plabel) (car pcustg) | 1087 | (car printer) |
| 1076 | (car printer) | 1088 | (car pprot) (car-safe (car pinit)) nil nil sn) |
| 1077 | (car pprot) (car-safe (car pinit)) nil nil sn) | 1089 | ;; Increment each value. |
| 1078 | ;; Increment each value. | 1090 | (setq pa (cdr pa) |
| 1079 | (setq pa (cdr pa) | 1091 | pd (cdr pd) |
| 1080 | pd (cdr pd) | 1092 | pdoc (cdr pdoc) |
| 1081 | pdoc (cdr pdoc) | 1093 | i (1+ i) |
| 1082 | i (1+ i) | 1094 | pcust (cdr pcust) |
| 1083 | pcust (cdr pcust) | 1095 | plabel (cdr plabel) |
| 1084 | plabel (cdr plabel) | 1096 | pcustg (cdr pcustg) |
| 1085 | pcustg (cdr pcustg) | 1097 | printer (cdr printer) |
| 1086 | printer (cdr printer) | 1098 | pprot (cdr pprot) |
| 1087 | pprot (cdr pprot) | 1099 | pinit (cdr pinit)) |
| 1088 | pinit (cdr pinit)) | 1100 | )) ;; while/let |
| 1089 | )) ;; while/let | 1101 | ;; Now duplicate all the class alloc slots. |
| 1090 | ;; Now duplicate all the class alloc slots. | 1102 | (let ((pa (eieio--class-class-allocation-a pcv)) |
| 1091 | (let ((pa (eieio--class-class-allocation-a pcv)) | 1103 | (pdoc (eieio--class-class-allocation-doc pcv)) |
| 1092 | (pdoc (eieio--class-class-allocation-doc pcv)) | 1104 | (ptype (eieio--class-class-allocation-type pcv)) |
| 1093 | (ptype (eieio--class-class-allocation-type pcv)) | 1105 | (pcust (eieio--class-class-allocation-custom pcv)) |
| 1094 | (pcust (eieio--class-class-allocation-custom pcv)) | 1106 | (plabel (eieio--class-class-allocation-custom-label pcv)) |
| 1095 | (plabel (eieio--class-class-allocation-custom-label pcv)) | 1107 | (pcustg (eieio--class-class-allocation-custom-group pcv)) |
| 1096 | (pcustg (eieio--class-class-allocation-custom-group pcv)) | 1108 | (printer (eieio--class-class-allocation-printer pcv)) |
| 1097 | (printer (eieio--class-class-allocation-printer pcv)) | 1109 | (pprot (eieio--class-class-allocation-protection pcv)) |
| 1098 | (pprot (eieio--class-class-allocation-protection pcv)) | 1110 | (pval (eieio--class-class-allocation-values pcv)) |
| 1099 | (pval (eieio--class-class-allocation-values pcv)) | 1111 | (i 0)) |
| 1100 | (i 0)) | 1112 | (while pa |
| 1101 | (while pa | 1113 | (eieio--add-new-slot newc |
| 1102 | (eieio-add-new-slot newc | 1114 | (car pa) (aref pval i) (car pdoc) (aref ptype i) |
| 1103 | (car pa) (aref pval i) (car pdoc) (aref ptype i) | 1115 | (car pcust) (car plabel) (car pcustg) |
| 1104 | (car pcust) (car plabel) (car pcustg) | 1116 | (car printer) |
| 1105 | (car printer) | 1117 | (car pprot) nil :class sn) |
| 1106 | (car pprot) nil ':class sn) | 1118 | ;; Increment each value. |
| 1107 | ;; Increment each value. | 1119 | (setq pa (cdr pa) |
| 1108 | (setq pa (cdr pa) | 1120 | pdoc (cdr pdoc) |
| 1109 | pdoc (cdr pdoc) | 1121 | pcust (cdr pcust) |
| 1110 | pcust (cdr pcust) | 1122 | plabel (cdr plabel) |
| 1111 | plabel (cdr plabel) | 1123 | pcustg (cdr pcustg) |
| 1112 | pcustg (cdr pcustg) | 1124 | printer (cdr printer) |
| 1113 | printer (cdr printer) | 1125 | pprot (cdr pprot) |
| 1114 | pprot (cdr pprot) | 1126 | i (1+ i)) |
| 1115 | i (1+ i)) | 1127 | ))))) |
| 1116 | ))) ;; while/let | ||
| 1117 | ;; Loop over each parent class | ||
| 1118 | (setq ps (cdr ps))) | ||
| 1119 | )) | ||
| 1120 | 1128 | ||
| 1121 | 1129 | ||
| 1122 | ;;; CLOS methods and generics | 1130 | ;;; CLOS methods and generics |
| @@ -1333,14 +1341,17 @@ Argument FN is the function calling this verifier." | |||
| 1333 | (eieio--check-type (or eieio-object-p class-p) obj) | 1341 | (eieio--check-type (or eieio-object-p class-p) obj) |
| 1334 | (eieio--check-type symbolp slot) | 1342 | (eieio--check-type symbolp slot) |
| 1335 | (if (class-p obj) (eieio-class-un-autoload obj)) | 1343 | (if (class-p obj) (eieio-class-un-autoload obj)) |
| 1336 | (let* ((class (if (class-p obj) obj (eieio--object-class-name obj))) | 1344 | (let* ((class (cond ((symbolp obj) |
| 1337 | (c (eieio--slot-name-index (eieio--class-v class) obj slot))) | 1345 | (error "eieio-oref called on a class!") |
| 1346 | (eieio--class-v obj)) | ||
| 1347 | (t (eieio--object-class-object obj)))) | ||
| 1348 | (c (eieio--slot-name-index class obj slot))) | ||
| 1338 | (if (not c) | 1349 | (if (not c) |
| 1339 | ;; It might be missing because it is a :class allocated slot. | 1350 | ;; It might be missing because it is a :class allocated slot. |
| 1340 | ;; Let's check that info out. | 1351 | ;; Let's check that info out. |
| 1341 | (if (setq c (eieio-class-slot-name-index class slot)) | 1352 | (if (setq c (eieio--class-slot-name-index class slot)) |
| 1342 | ;; Oref that slot. | 1353 | ;; Oref that slot. |
| 1343 | (aref (eieio--class-class-allocation-values (eieio--class-v class)) c) | 1354 | (aref (eieio--class-class-allocation-values class) c) |
| 1344 | ;; The slot-missing method is a cool way of allowing an object author | 1355 | ;; The slot-missing method is a cool way of allowing an object author |
| 1345 | ;; to intercept missing slot definitions. Since it is also the LAST | 1356 | ;; to intercept missing slot definitions. Since it is also the LAST |
| 1346 | ;; thing called in this fn, its return value would be retrieved. | 1357 | ;; thing called in this fn, its return value would be retrieved. |
| @@ -1356,24 +1367,25 @@ Argument FN is the function calling this verifier." | |||
| 1356 | Fills in OBJ's SLOT with its default value." | 1367 | Fills in OBJ's SLOT with its default value." |
| 1357 | (eieio--check-type (or eieio-object-p class-p) obj) | 1368 | (eieio--check-type (or eieio-object-p class-p) obj) |
| 1358 | (eieio--check-type symbolp slot) | 1369 | (eieio--check-type symbolp slot) |
| 1359 | (let* ((cl (if (eieio-object-p obj) (eieio--object-class-name obj) obj)) | 1370 | (let* ((cl (cond ((symbolp obj) (eieio--class-v obj)) |
| 1360 | (c (eieio--slot-name-index (eieio--class-v cl) obj slot))) | 1371 | (t (eieio--object-class-object obj)))) |
| 1372 | (c (eieio--slot-name-index cl obj slot))) | ||
| 1361 | (if (not c) | 1373 | (if (not c) |
| 1362 | ;; It might be missing because it is a :class allocated slot. | 1374 | ;; It might be missing because it is a :class allocated slot. |
| 1363 | ;; Let's check that info out. | 1375 | ;; Let's check that info out. |
| 1364 | (if (setq c | 1376 | (if (setq c |
| 1365 | (eieio-class-slot-name-index cl slot)) | 1377 | (eieio--class-slot-name-index cl slot)) |
| 1366 | ;; Oref that slot. | 1378 | ;; Oref that slot. |
| 1367 | (aref (eieio--class-class-allocation-values (eieio--class-v cl)) | 1379 | (aref (eieio--class-class-allocation-values cl) |
| 1368 | c) | 1380 | c) |
| 1369 | (slot-missing obj slot 'oref-default) | 1381 | (slot-missing obj slot 'oref-default) |
| 1370 | ;;(signal 'invalid-slot-name (list (class-name cl) slot)) | 1382 | ;;(signal 'invalid-slot-name (list (class-name cl) slot)) |
| 1371 | ) | 1383 | ) |
| 1372 | (eieio-barf-if-slot-unbound | 1384 | (eieio-barf-if-slot-unbound |
| 1373 | (let ((val (nth (- c (eval-when-compile eieio--object-num-slots)) | 1385 | (let ((val (nth (- c (eval-when-compile eieio--object-num-slots)) |
| 1374 | (eieio--class-public-d (eieio--class-v cl))))) | 1386 | (eieio--class-public-d cl)))) |
| 1375 | (eieio-default-eval-maybe val)) | 1387 | (eieio-default-eval-maybe val)) |
| 1376 | obj cl 'oref-default)))) | 1388 | obj (eieio--class-symbol cl) 'oref-default)))) |
| 1377 | 1389 | ||
| 1378 | (defun eieio-default-eval-maybe (val) | 1390 | (defun eieio-default-eval-maybe (val) |
| 1379 | "Check VAL, and return what `oref-default' would provide." | 1391 | "Check VAL, and return what `oref-default' would provide." |
| @@ -1398,7 +1410,7 @@ Fills in OBJ's SLOT with VALUE." | |||
| 1398 | ;; It might be missing because it is a :class allocated slot. | 1410 | ;; It might be missing because it is a :class allocated slot. |
| 1399 | ;; Let's check that info out. | 1411 | ;; Let's check that info out. |
| 1400 | (if (setq c | 1412 | (if (setq c |
| 1401 | (eieio-class-slot-name-index (eieio--class-symbol class) slot)) | 1413 | (eieio--class-slot-name-index class slot)) |
| 1402 | ;; Oset that slot. | 1414 | ;; Oset that slot. |
| 1403 | (progn | 1415 | (progn |
| 1404 | (eieio-validate-class-slot-value (eieio--class-symbol class) | 1416 | (eieio-validate-class-slot-value (eieio--class-symbol class) |
| @@ -1422,7 +1434,7 @@ Fills in the default value in CLASS' in SLOT with VALUE." | |||
| 1422 | (if (not c) | 1434 | (if (not c) |
| 1423 | ;; It might be missing because it is a :class allocated slot. | 1435 | ;; It might be missing because it is a :class allocated slot. |
| 1424 | ;; Let's check that info out. | 1436 | ;; Let's check that info out. |
| 1425 | (if (setq c (eieio-class-slot-name-index class slot)) | 1437 | (if (setq c (eieio--class-slot-name-index (eieio--class-v class) slot)) |
| 1426 | (progn | 1438 | (progn |
| 1427 | ;; Oref that slot. | 1439 | ;; Oref that slot. |
| 1428 | (eieio-validate-class-slot-value class c value slot) | 1440 | (eieio-validate-class-slot-value class c value slot) |
| @@ -1442,19 +1454,19 @@ Fills in the default value in CLASS' in SLOT with VALUE." | |||
| 1442 | 1454 | ||
| 1443 | ;;; EIEIO internal search functions | 1455 | ;;; EIEIO internal search functions |
| 1444 | ;; | 1456 | ;; |
| 1445 | (defun eieio-slot-originating-class-p (start-class slot) | 1457 | (defun eieio--slot-originating-class-p (start-class slot) |
| 1446 | "Return non-nil if START-CLASS is the first class to define SLOT. | 1458 | "Return non-nil if START-CLASS is the first class to define SLOT. |
| 1447 | This is for testing if the class currently in scope is the class that defines SLOT | 1459 | This is for testing if the class currently in scope is the class that defines SLOT |
| 1448 | so that we can protect private slots." | 1460 | so that we can protect private slots." |
| 1449 | (let ((par (eieio--class-parent start-class)) | 1461 | (let ((par (eieio--class-parent start-class)) |
| 1450 | (ret t)) | 1462 | (ret t)) |
| 1451 | (if (not par) | 1463 | (or (not par) |
| 1452 | t | 1464 | (progn |
| 1453 | (while (and par ret) | 1465 | (while (and par ret) |
| 1454 | (if (gethash slot (eieio--class-symbol-hashtable (eieio--class-v (car par)))) | 1466 | (if (gethash slot (eieio--class-symbol-hashtable (car par))) |
| 1455 | (setq ret nil)) | 1467 | (setq ret nil)) |
| 1456 | (setq par (cdr par))) | 1468 | (setq par (cdr par))) |
| 1457 | ret))) | 1469 | ret)))) |
| 1458 | 1470 | ||
| 1459 | (defun eieio--slot-name-index (class obj slot) | 1471 | (defun eieio--slot-name-index (class obj slot) |
| 1460 | "In CLASS for OBJ find the index of the named SLOT. | 1472 | "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." | |||
| 1475 | (eieio--scoped-class) | 1487 | (eieio--scoped-class) |
| 1476 | (or (child-of-class-p class (eieio--scoped-class)) | 1488 | (or (child-of-class-p class (eieio--scoped-class)) |
| 1477 | (and (eieio-object-p obj) | 1489 | (and (eieio-object-p obj) |
| 1478 | (child-of-class-p class (eieio--object-class-object obj))))) | 1490 | ;; AFAICT, for all callers, if `obj' is not a class, |
| 1491 | ;; then its class is `class'. | ||
| 1492 | ;;(child-of-class-p class (eieio--object-class-object obj)) | ||
| 1493 | (progn | ||
| 1494 | (cl-assert (eq class (eieio--object-class-object obj))) | ||
| 1495 | t)))) | ||
| 1479 | (+ (eval-when-compile eieio--object-num-slots) fsi)) | 1496 | (+ (eval-when-compile eieio--object-num-slots) fsi)) |
| 1480 | ((and (eq (cdr fsym) 'private) | 1497 | ((and (eq (cdr fsym) 'private) |
| 1481 | (or (and (eieio--scoped-class) | 1498 | (or (and (eieio--scoped-class) |
| 1482 | (eieio-slot-originating-class-p (eieio--scoped-class) slot)) | 1499 | (eieio--slot-originating-class-p |
| 1500 | (eieio--scoped-class) slot)) | ||
| 1483 | eieio-initializing-object)) | 1501 | eieio-initializing-object)) |
| 1484 | (+ (eval-when-compile eieio--object-num-slots) fsi)) | 1502 | (+ (eval-when-compile eieio--object-num-slots) fsi)) |
| 1485 | (t nil)) | 1503 | (t nil)) |
| 1486 | (let ((fn (eieio--initarg-to-attribute class slot))) | 1504 | (let ((fn (eieio--initarg-to-attribute class slot))) |
| 1487 | (if fn (eieio--slot-name-index class obj fn) nil))))) | 1505 | (if fn (eieio--slot-name-index class obj fn) nil))))) |
| 1488 | 1506 | ||
| 1489 | (defun eieio-class-slot-name-index (class slot) | 1507 | (defun eieio--class-slot-name-index (class slot) |
| 1490 | "In CLASS find the index of the named SLOT. | 1508 | "In CLASS find the index of the named SLOT. |
| 1491 | The slot is a symbol which is installed in CLASS by the `defclass' | 1509 | The slot is a symbol which is installed in CLASS by the `defclass' |
| 1492 | call. If SLOT is the value created with :initarg instead, | 1510 | call. If SLOT is the value created with :initarg instead, |
| 1493 | reverse-lookup that name, and recurse with the associated slot value." | 1511 | reverse-lookup that name, and recurse with the associated slot value." |
| 1494 | ;; This will happen less often, and with fewer slots. Do this the | 1512 | ;; This will happen less often, and with fewer slots. Do this the |
| 1495 | ;; storage cheap way. | 1513 | ;; storage cheap way. |
| 1496 | (let* ((a (eieio--class-class-allocation-a (eieio--class-v class))) | 1514 | (let* ((a (eieio--class-class-allocation-a class)) |
| 1497 | (l1 (length a)) | 1515 | (l1 (length a)) |
| 1498 | (af (memq slot a)) | 1516 | (af (memq slot a)) |
| 1499 | (l2 (length af))) | 1517 | (l2 (length af))) |
| @@ -1528,18 +1546,10 @@ need be... May remove that later...)" | |||
| 1528 | (cdr tuple) | 1546 | (cdr tuple) |
| 1529 | nil))) | 1547 | nil))) |
| 1530 | 1548 | ||
| 1531 | (defun eieio-attribute-to-initarg (class attribute) | ||
| 1532 | "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. | ||
| 1533 | This is usually a symbol that starts with `:'." | ||
| 1534 | (let ((tuple (rassoc attribute (eieio--class-initarg-tuples (eieio--class-v class))))) | ||
| 1535 | (if tuple | ||
| 1536 | (car tuple) | ||
| 1537 | nil))) | ||
| 1538 | |||
| 1539 | ;;; | 1549 | ;;; |
| 1540 | ;; Method Invocation order: C3 | 1550 | ;; Method Invocation order: C3 |
| 1541 | (defun eieio-c3-candidate (class remaining-inputs) | 1551 | (defun eieio--c3-candidate (class remaining-inputs) |
| 1542 | "Return CLASS if it can go in the result now, otherwise nil" | 1552 | "Return CLASS if it can go in the result now, otherwise nil." |
| 1543 | ;; Ensure CLASS is not in any position but the first in any of the | 1553 | ;; Ensure CLASS is not in any position but the first in any of the |
| 1544 | ;; element lists of REMAINING-INPUTS. | 1554 | ;; element lists of REMAINING-INPUTS. |
| 1545 | (and (not (let ((found nil)) | 1555 | (and (not (let ((found nil)) |
| @@ -1549,7 +1559,7 @@ This is usually a symbol that starts with `:'." | |||
| 1549 | found)) | 1559 | found)) |
| 1550 | class)) | 1560 | class)) |
| 1551 | 1561 | ||
| 1552 | (defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) | 1562 | (defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs) |
| 1553 | "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. | 1563 | "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. |
| 1554 | If a consistent order does not exist, signal an error." | 1564 | If a consistent order does not exist, signal an error." |
| 1555 | (if (let ((tail remaining-inputs) | 1565 | (if (let ((tail remaining-inputs) |
| @@ -1568,41 +1578,38 @@ If a consistent order does not exist, signal an error." | |||
| 1568 | (next (progn | 1578 | (next (progn |
| 1569 | (while (and tail (not found)) | 1579 | (while (and tail (not found)) |
| 1570 | (setq found (and (car tail) | 1580 | (setq found (and (car tail) |
| 1571 | (eieio-c3-candidate (caar tail) | 1581 | (eieio--c3-candidate (caar tail) |
| 1572 | remaining-inputs)) | 1582 | remaining-inputs)) |
| 1573 | tail (cdr tail))) | 1583 | tail (cdr tail))) |
| 1574 | found))) | 1584 | found))) |
| 1575 | (if next | 1585 | (if next |
| 1576 | ;; The graph is consistent so far, add NEXT to result and | 1586 | ;; The graph is consistent so far, add NEXT to result and |
| 1577 | ;; merge input lists, dropping NEXT from their heads where | 1587 | ;; merge input lists, dropping NEXT from their heads where |
| 1578 | ;; applicable. | 1588 | ;; applicable. |
| 1579 | (eieio-c3-merge-lists | 1589 | (eieio--c3-merge-lists |
| 1580 | (cons next reversed-partial-result) | 1590 | (cons next reversed-partial-result) |
| 1581 | (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l)) | 1591 | (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l)) |
| 1582 | remaining-inputs)) | 1592 | remaining-inputs)) |
| 1583 | ;; The graph is inconsistent, give up | 1593 | ;; The graph is inconsistent, give up |
| 1584 | (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) | 1594 | (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) |
| 1585 | 1595 | ||
| 1586 | (defun eieio-class-precedence-c3 (class) | 1596 | (defun eieio--class-precedence-c3 (class) |
| 1587 | "Return all parents of CLASS in c3 order." | 1597 | "Return all parents of CLASS in c3 order." |
| 1588 | (let ((parents (eieio-class-parents-fast class))) | 1598 | (let ((parents (eieio--class-parent (eieio--class-v class)))) |
| 1589 | (eieio-c3-merge-lists | 1599 | (eieio--c3-merge-lists |
| 1590 | (list class) | 1600 | (list class) |
| 1591 | (append | 1601 | (append |
| 1592 | (or | 1602 | (or |
| 1593 | (mapcar | 1603 | (mapcar #'eieio--class-precedence-c3 parents) |
| 1594 | (lambda (x) | 1604 | `((,eieio-default-superclass))) |
| 1595 | (eieio-class-precedence-c3 x)) | ||
| 1596 | parents) | ||
| 1597 | '((eieio-default-superclass))) | ||
| 1598 | (list parents)))) | 1605 | (list parents)))) |
| 1599 | ) | 1606 | ) |
| 1600 | ;;; | 1607 | ;;; |
| 1601 | ;; Method Invocation Order: Depth First | 1608 | ;; Method Invocation Order: Depth First |
| 1602 | 1609 | ||
| 1603 | (defun eieio-class-precedence-dfs (class) | 1610 | (defun eieio--class-precedence-dfs (class) |
| 1604 | "Return all parents of CLASS in depth-first order." | 1611 | "Return all parents of CLASS in depth-first order." |
| 1605 | (let* ((parents (eieio-class-parents-fast class)) | 1612 | (let* ((parents (eieio--class-parent class)) |
| 1606 | (classes (copy-sequence | 1613 | (classes (copy-sequence |
| 1607 | (apply #'append | 1614 | (apply #'append |
| 1608 | (list class) | 1615 | (list class) |
| @@ -1610,9 +1617,9 @@ If a consistent order does not exist, signal an error." | |||
| 1610 | (mapcar | 1617 | (mapcar |
| 1611 | (lambda (parent) | 1618 | (lambda (parent) |
| 1612 | (cons parent | 1619 | (cons parent |
| 1613 | (eieio-class-precedence-dfs parent))) | 1620 | (eieio--class-precedence-dfs parent))) |
| 1614 | parents) | 1621 | parents) |
| 1615 | '((eieio-default-superclass)))))) | 1622 | `((,eieio-default-superclass)))))) |
| 1616 | (tail classes)) | 1623 | (tail classes)) |
| 1617 | ;; Remove duplicates. | 1624 | ;; Remove duplicates. |
| 1618 | (while tail | 1625 | (while tail |
| @@ -1622,40 +1629,40 @@ If a consistent order does not exist, signal an error." | |||
| 1622 | 1629 | ||
| 1623 | ;;; | 1630 | ;;; |
| 1624 | ;; Method Invocation Order: Breadth First | 1631 | ;; Method Invocation Order: Breadth First |
| 1625 | (defun eieio-class-precedence-bfs (class) | 1632 | (defun eieio--class-precedence-bfs (class) |
| 1626 | "Return all parents of CLASS in breadth-first order." | 1633 | "Return all parents of CLASS in breadth-first order." |
| 1627 | (let ((result) | 1634 | (let* ((result) |
| 1628 | (queue (or (eieio-class-parents-fast class) | 1635 | (queue (or (eieio--class-parent class) |
| 1629 | '(eieio-default-superclass)))) | 1636 | `(,eieio-default-superclass)))) |
| 1630 | (while queue | 1637 | (while queue |
| 1631 | (let ((head (pop queue))) | 1638 | (let ((head (pop queue))) |
| 1632 | (unless (member head result) | 1639 | (unless (member head result) |
| 1633 | (push head result) | 1640 | (push head result) |
| 1634 | (unless (eq head 'eieio-default-superclass) | 1641 | (unless (eq head eieio-default-superclass) |
| 1635 | (setq queue (append queue (or (eieio-class-parents-fast head) | 1642 | (setq queue (append queue (or (eieio--class-parent head) |
| 1636 | '(eieio-default-superclass)))))))) | 1643 | `(,eieio-default-superclass)))))))) |
| 1637 | (cons class (nreverse result))) | 1644 | (cons class (nreverse result))) |
| 1638 | ) | 1645 | ) |
| 1639 | 1646 | ||
| 1640 | ;;; | 1647 | ;;; |
| 1641 | ;; Method Invocation Order | 1648 | ;; Method Invocation Order |
| 1642 | 1649 | ||
| 1643 | (defun eieio-class-precedence-list (class) | 1650 | (defun eieio--class-precedence-list (class) |
| 1644 | "Return (transitively closed) list of parents of CLASS. | 1651 | "Return (transitively closed) list of parents of CLASS. |
| 1645 | The order, in which the parents are returned depends on the | 1652 | The order, in which the parents are returned depends on the |
| 1646 | method invocation orders of the involved classes." | 1653 | method invocation orders of the involved classes." |
| 1647 | (if (or (null class) (eq class 'eieio-default-superclass)) | 1654 | (if (or (null class) (eq class eieio-default-superclass)) |
| 1648 | nil | 1655 | nil |
| 1649 | (cl-case (class-method-invocation-order class) | 1656 | (cl-case (eieio--class-method-invocation-order class) |
| 1650 | (:depth-first | 1657 | (:depth-first |
| 1651 | (eieio-class-precedence-dfs class)) | 1658 | (eieio--class-precedence-dfs class)) |
| 1652 | (:breadth-first | 1659 | (:breadth-first |
| 1653 | (eieio-class-precedence-bfs class)) | 1660 | (eieio--class-precedence-bfs class)) |
| 1654 | (:c3 | 1661 | (:c3 |
| 1655 | (eieio-class-precedence-c3 class)))) | 1662 | (eieio--class-precedence-c3 class)))) |
| 1656 | ) | 1663 | ) |
| 1657 | (define-obsolete-function-alias | 1664 | (define-obsolete-function-alias |
| 1658 | 'class-precedence-list 'eieio-class-precedence-list "24.4") | 1665 | 'class-precedence-list 'eieio--class-precedence-list "24.4") |
| 1659 | 1666 | ||
| 1660 | 1667 | ||
| 1661 | ;;; CLOS generics internal function handling | 1668 | ;;; CLOS generics internal function handling |
| @@ -1688,9 +1695,8 @@ This should only be called from a generic function." | |||
| 1688 | ;; function loaded anyway. | 1695 | ;; function loaded anyway. |
| 1689 | (if (and (symbolp firstarg) | 1696 | (if (and (symbolp firstarg) |
| 1690 | (fboundp firstarg) | 1697 | (fboundp firstarg) |
| 1691 | (listp (symbol-function firstarg)) | 1698 | (autoloadp (symbol-function firstarg))) |
| 1692 | (eq 'autoload (car (symbol-function firstarg)))) | 1699 | (autoload-do-load (symbol-function firstarg))) |
| 1693 | (load (nth 1 (symbol-function firstarg)))) | ||
| 1694 | ;; Determine the class to use. | 1700 | ;; Determine the class to use. |
| 1695 | (cond ((eieio-object-p firstarg) | 1701 | (cond ((eieio-object-p firstarg) |
| 1696 | (setq mclass (eieio--object-class-name firstarg))) | 1702 | (setq mclass (eieio--object-class-name firstarg))) |
| @@ -1700,7 +1706,7 @@ This should only be called from a generic function." | |||
| 1700 | ;; Make sure the class is a valid class | 1706 | ;; Make sure the class is a valid class |
| 1701 | ;; mclass can be nil (meaning a generic for should be used. | 1707 | ;; mclass can be nil (meaning a generic for should be used. |
| 1702 | ;; mclass cannot have a value that is not a class, however. | 1708 | ;; mclass cannot have a value that is not a class, however. |
| 1703 | (when (and (not (null mclass)) (not (class-p mclass))) | 1709 | (unless (or (null mclass) (class-p mclass)) |
| 1704 | (error "Cannot dispatch method %S on class %S" | 1710 | (error "Cannot dispatch method %S on class %S" |
| 1705 | method mclass) | 1711 | method mclass) |
| 1706 | ) | 1712 | ) |
| @@ -1776,7 +1782,7 @@ This should only be called from a generic function." | |||
| 1776 | (let ((rval nil) (lastval nil) (found nil)) | 1782 | (let ((rval nil) (lastval nil) (found nil)) |
| 1777 | (while lambdas | 1783 | (while lambdas |
| 1778 | (if (car lambdas) | 1784 | (if (car lambdas) |
| 1779 | (eieio--with-scoped-class (eieio--class-v (cdr (car lambdas))) | 1785 | (eieio--with-scoped-class (cdr (car lambdas)) |
| 1780 | (let* ((eieio-generic-call-key (car keys)) | 1786 | (let* ((eieio-generic-call-key (car keys)) |
| 1781 | (has-return-val | 1787 | (has-return-val |
| 1782 | (or (= eieio-generic-call-key eieio--method-primary) | 1788 | (or (= eieio-generic-call-key eieio--method-primary) |
| @@ -1844,7 +1850,7 @@ for this common case to improve performance." | |||
| 1844 | 1850 | ||
| 1845 | ;; Now loop through all occurrences forms which we must execute | 1851 | ;; Now loop through all occurrences forms which we must execute |
| 1846 | ;; (which are happily sorted now) and execute them all! | 1852 | ;; (which are happily sorted now) and execute them all! |
| 1847 | (eieio--with-scoped-class (eieio--class-v (cdr lambdas)) | 1853 | (eieio--with-scoped-class (cdr lambdas) |
| 1848 | (let* ((rval nil) (lastval nil) | 1854 | (let* ((rval nil) (lastval nil) |
| 1849 | (eieio-generic-call-key eieio--method-primary) | 1855 | (eieio-generic-call-key eieio--method-primary) |
| 1850 | ;; Use the cdr, as the first element is the fcn | 1856 | ;; 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." | |||
| 1884 | ;; Collect lambda expressions stored for the class and its parent | 1890 | ;; Collect lambda expressions stored for the class and its parent |
| 1885 | ;; classes. | 1891 | ;; classes. |
| 1886 | (let (lambdas) | 1892 | (let (lambdas) |
| 1887 | (dolist (ancestor (eieio-class-precedence-list class)) | 1893 | (dolist (ancestor (eieio--class-precedence-list (eieio--class-v class))) |
| 1888 | ;; Lookup the form to use for the PRIMARY object for the next level | 1894 | ;; Lookup the form to use for the PRIMARY object for the next level |
| 1889 | (let ((tmpl (eieio-generic-form method key ancestor))) | 1895 | (let ((tmpl (eieio-generic-form method key ancestor))) |
| 1890 | (when (and tmpl | 1896 | (when (and tmpl |
| @@ -1961,7 +1967,7 @@ CLASS is the class this method is associated with." | |||
| 1961 | ;; said symbol in the correct hashtable, otherwise use the | 1967 | ;; said symbol in the correct hashtable, otherwise use the |
| 1962 | ;; other array to keep this stuff. | 1968 | ;; other array to keep this stuff. |
| 1963 | (if (< key eieio--method-num-lists) | 1969 | (if (< key eieio--method-num-lists) |
| 1964 | (puthash class (list method) (aref emto key))) | 1970 | (puthash (eieio--class-v class) (list method) (aref emto key))) |
| 1965 | ;; Save the defmethod file location in a symbol property. | 1971 | ;; Save the defmethod file location in a symbol property. |
| 1966 | (let ((fname (if load-in-progress | 1972 | (let ((fname (if load-in-progress |
| 1967 | load-file-name | 1973 | load-file-name |
| @@ -1986,7 +1992,7 @@ This is different from function `class-parent' as class parent returns | |||
| 1986 | nil for superclasses. This function performs no type checking!" | 1992 | nil for superclasses. This function performs no type checking!" |
| 1987 | ;; No type-checking because all calls are made from functions which | 1993 | ;; No type-checking because all calls are made from functions which |
| 1988 | ;; are safe and do checking for us. | 1994 | ;; are safe and do checking for us. |
| 1989 | (or (eieio-class-parents-fast class) | 1995 | (or (eieio--class-parent (eieio--class-v class)) |
| 1990 | (if (eq class 'eieio-default-superclass) | 1996 | (if (eq class 'eieio-default-superclass) |
| 1991 | nil | 1997 | nil |
| 1992 | '(eieio-default-superclass)))) | 1998 | '(eieio-default-superclass)))) |
| @@ -1999,7 +2005,7 @@ nil for superclasses. This function performs no type checking!" | |||
| 1999 | ;; we replace the nil from above. | 2005 | ;; we replace the nil from above. |
| 2000 | (catch 'done | 2006 | (catch 'done |
| 2001 | (dolist (ancestor | 2007 | (dolist (ancestor |
| 2002 | (cl-rest (eieio-class-precedence-list class))) | 2008 | (cl-rest (eieio--class-precedence-list class))) |
| 2003 | (let ((ov (gethash ancestor eieiomt--optimizing-hashtable))) | 2009 | (let ((ov (gethash ancestor eieiomt--optimizing-hashtable))) |
| 2004 | (when (car ov) | 2010 | (when (car ov) |
| 2005 | (setcdr s ancestor) ;; store ov as our next symbol | 2011 | (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 | |||
| 2011 | no form, but has a parent class, then trace to that parent class. | 2017 | no form, but has a parent class, then trace to that parent class. |
| 2012 | The first time a form is requested from a symbol, an optimized path | 2018 | The first time a form is requested from a symbol, an optimized path |
| 2013 | is memorized for faster future use." | 2019 | is memorized for faster future use." |
| 2020 | (if (symbolp class) (setq class (eieio--class-v class))) | ||
| 2014 | (let ((emto (aref (get method 'eieio-method-hashtable) | 2021 | (let ((emto (aref (get method 'eieio-method-hashtable) |
| 2015 | (if class key (eieio-specialized-key-to-generic-key key))))) | 2022 | (if class key (eieio-specialized-key-to-generic-key key))))) |
| 2016 | (if (class-p class) | 2023 | (if (eieio--class-p class) |
| 2017 | ;; 1) find our symbol | 2024 | ;; 1) find our symbol |
| 2018 | (let ((cs (gethash class emto))) | 2025 | (let ((cs (gethash class emto))) |
| 2019 | (unless cs | 2026 | (unless cs |
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 15a11ddb20f..fe88c864d52 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el | |||
| @@ -208,8 +208,8 @@ Optional argument IGNORE is an extraneous parameter." | |||
| 208 | chil))) | 208 | chil))) |
| 209 | ;; Display information about the group being shown | 209 | ;; Display information about the group being shown |
| 210 | (when master-group | 210 | (when master-group |
| 211 | (let ((groups (class-option (eieio--object-class-name obj) | 211 | (let ((groups (eieio--class-option (eieio--object-class-object obj) |
| 212 | :custom-groups))) | 212 | :custom-groups))) |
| 213 | (widget-insert "Groups:") | 213 | (widget-insert "Groups:") |
| 214 | (while groups | 214 | (while groups |
| 215 | (widget-insert " ") | 215 | (widget-insert " ") |
| @@ -261,8 +261,8 @@ Optional argument IGNORE is an extraneous parameter." | |||
| 261 | (car flabel) | 261 | (car flabel) |
| 262 | (let ((s (symbol-name | 262 | (let ((s (symbol-name |
| 263 | (or | 263 | (or |
| 264 | (class-slot-initarg | 264 | (eieio--class-slot-initarg |
| 265 | (eieio--object-class-name obj) | 265 | (eieio--object-class-object obj) |
| 266 | (car slots)) | 266 | (car slots)) |
| 267 | (car slots))))) | 267 | (car slots))))) |
| 268 | (capitalize | 268 | (capitalize |
| @@ -452,7 +452,7 @@ Must return the created widget." | |||
| 452 | (vector (concat "Group " (symbol-name group)) | 452 | (vector (concat "Group " (symbol-name group)) |
| 453 | (list 'customize-object obj (list 'quote group)) | 453 | (list 'customize-object obj (list 'quote group)) |
| 454 | t)) | 454 | t)) |
| 455 | (class-option (eieio--object-class-name obj) :custom-groups))) | 455 | (eieio--class-option (eieio--object-class-object obj) :custom-groups))) |
| 456 | 456 | ||
| 457 | (defvar eieio-read-custom-group-history nil | 457 | (defvar eieio-read-custom-group-history nil |
| 458 | "History for the custom group reader.") | 458 | "History for the custom group reader.") |
| @@ -460,7 +460,8 @@ Must return the created widget." | |||
| 460 | (defmethod eieio-read-customization-group ((obj eieio-default-superclass)) | 460 | (defmethod eieio-read-customization-group ((obj eieio-default-superclass)) |
| 461 | "Do a completing read on the name of a customization group in OBJ. | 461 | "Do a completing read on the name of a customization group in OBJ. |
| 462 | Return the symbol for the group, or nil" | 462 | Return the symbol for the group, or nil" |
| 463 | (let ((g (class-option (eieio--object-class-name obj) :custom-groups))) | 463 | (let ((g (eieio--class-option (eieio--object-class-object obj) |
| 464 | :custom-groups))) | ||
| 464 | (if (= (length g) 1) | 465 | (if (= (length g) 1) |
| 465 | (car g) | 466 | (car g) |
| 466 | ;; Make the association list | 467 | ;; Make the association list |
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index d18501b414c..69e72573deb 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el | |||
| @@ -96,7 +96,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button." | |||
| 96 | ) | 96 | ) |
| 97 | (while publa | 97 | (while publa |
| 98 | (if (slot-boundp obj (car publa)) | 98 | (if (slot-boundp obj (car publa)) |
| 99 | (let* ((i (class-slot-initarg cl (car publa))) | 99 | (let* ((i (eieio--class-slot-initarg (eieio--class-v cl) |
| 100 | (car publa))) | ||
| 100 | (v (eieio-oref obj (car publa)))) | 101 | (v (eieio-oref obj (car publa)))) |
| 101 | (data-debug-insert-thing | 102 | (data-debug-insert-thing |
| 102 | v prefix (concat | 103 | v prefix (concat |
| @@ -104,7 +105,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button." | |||
| 104 | (symbol-name (car publa))) | 105 | (symbol-name (car publa))) |
| 105 | " "))) | 106 | " "))) |
| 106 | ;; Unbound case | 107 | ;; Unbound case |
| 107 | (let ((i (class-slot-initarg cl (car publa)))) | 108 | (let ((i (eieio--class-slot-initarg (eieio--class-v cl) |
| 109 | (car publa)))) | ||
| 108 | (data-debug-insert-custom | 110 | (data-debug-insert-custom |
| 109 | "#unbound" prefix | 111 | "#unbound" prefix |
| 110 | (concat (if i (symbol-name i) | 112 | (concat (if i (symbol-name i) |
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 1987385de0b..be3c2b0cc94 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el | |||
| @@ -81,7 +81,7 @@ If CLASS is actually an object, then also display current values of that object. | |||
| 81 | ;; Header line | 81 | ;; Header line |
| 82 | (prin1 class) | 82 | (prin1 class) |
| 83 | (insert " is a" | 83 | (insert " is a" |
| 84 | (if (class-option class :abstract) | 84 | (if (eieio--class-option (eieio--class-v class) :abstract) |
| 85 | "n abstract" | 85 | "n abstract" |
| 86 | "") | 86 | "") |
| 87 | " class") | 87 | " class") |
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index e80791f9f75..878667106c8 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el | |||
| @@ -1,7 +1,7 @@ | |||
| 1 | ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -*- lexical-binding:t -*- | 1 | ;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -*- lexical-binding:t -*- |
| 2 | ;;; or maybe Eric's Implementation of Emacs Interpreted Objects | 2 | ;;; or maybe Eric's Implementation of Emacs Interpreted Objects |
| 3 | 3 | ||
| 4 | ;; Copyright (C) 1995-1996, 1998-2014 Free Software Foundation, Inc. | 4 | ;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc. |
| 5 | 5 | ||
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> |
| 7 | ;; Version: 1.4 | 7 | ;; Version: 1.4 |
| @@ -319,8 +319,9 @@ If EXTRA, include that in the string returned to represent the symbol." | |||
| 319 | "Return parent classes to CLASS. (overload of variable). | 319 | "Return parent classes to CLASS. (overload of variable). |
| 320 | 320 | ||
| 321 | The CLOS function `class-direct-superclasses' is aliased to this function." | 321 | The CLOS function `class-direct-superclasses' is aliased to this function." |
| 322 | (eieio--check-type class-p class) | 322 | (let ((c (eieio-class-object class))) |
| 323 | (eieio-class-parents-fast class)) | 323 | (eieio--class-parent c))) |
| 324 | |||
| 324 | (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") | 325 | (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") |
| 325 | 326 | ||
| 326 | (defun eieio-class-children (class) | 327 | (defun eieio-class-children (class) |
| @@ -366,10 +367,8 @@ The CLOS function `class-direct-subclasses' is aliased to this function." | |||
| 366 | (setq class (eieio--class-object class)) | 367 | (setq class (eieio--class-object class)) |
| 367 | (eieio--check-type eieio--class-p class) | 368 | (eieio--check-type eieio--class-p class) |
| 368 | (while (and child (not (eq child class))) | 369 | (while (and child (not (eq child class))) |
| 369 | ;; FIXME: eieio--class-parent should return class-objects rather than | ||
| 370 | ;; class-names! | ||
| 371 | (setq p (append p (eieio--class-parent child)) | 370 | (setq p (append p (eieio--class-parent child)) |
| 372 | child (eieio--class-v (pop p)))) | 371 | child (pop p))) |
| 373 | (if child t)))) | 372 | (if child t)))) |
| 374 | 373 | ||
| 375 | (defun object-slots (obj) | 374 | (defun object-slots (obj) |
| @@ -377,9 +376,9 @@ The CLOS function `class-direct-subclasses' is aliased to this function." | |||
| 377 | (eieio--check-type eieio-object-p obj) | 376 | (eieio--check-type eieio-object-p obj) |
| 378 | (eieio--class-public-a (eieio--object-class-object obj))) | 377 | (eieio--class-public-a (eieio--object-class-object obj))) |
| 379 | 378 | ||
| 380 | (defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." | 379 | (defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." |
| 381 | (eieio--check-type class-p class) | 380 | (eieio--check-type eieio--class-p class) |
| 382 | (let ((ia (eieio--class-initarg-tuples (eieio--class-v class))) | 381 | (let ((ia (eieio--class-initarg-tuples class)) |
| 383 | (f nil)) | 382 | (f nil)) |
| 384 | (while (and ia (not f)) | 383 | (while (and ia (not f)) |
| 385 | (if (eq (cdr (car ia)) slot) | 384 | (if (eq (cdr (car ia)) slot) |
| @@ -426,11 +425,9 @@ OBJECT can be an instance or a class." | |||
| 426 | 425 | ||
| 427 | (defun slot-exists-p (object-or-class slot) | 426 | (defun slot-exists-p (object-or-class slot) |
| 428 | "Return non-nil if OBJECT-OR-CLASS has SLOT." | 427 | "Return non-nil if OBJECT-OR-CLASS has SLOT." |
| 429 | (let ((cv (eieio--class-v (cond ((eieio-object-p object-or-class) | 428 | (let ((cv (cond ((eieio-object-p object-or-class) |
| 430 | (eieio-object-class object-or-class)) | 429 | (eieio--object-class-object object-or-class)) |
| 431 | ((class-p object-or-class) | 430 | (t (eieio-class-object object-or-class))))) |
| 432 | object-or-class)) | ||
| 433 | ))) | ||
| 434 | (or (memq slot (eieio--class-public-a cv)) | 431 | (or (memq slot (eieio--class-public-a cv)) |
| 435 | (memq slot (eieio--class-class-allocation-a cv))) | 432 | (memq slot (eieio--class-class-allocation-a cv))) |
| 436 | )) | 433 | )) |
| @@ -555,7 +552,7 @@ Use `next-method-p' to find out if there is a next method to call." | |||
| 555 | (eieio-generic-call-arglst newargs) | 552 | (eieio-generic-call-arglst newargs) |
| 556 | (fcn (car next)) | 553 | (fcn (car next)) |
| 557 | ) | 554 | ) |
| 558 | (eieio--with-scoped-class (eieio--class-v (cdr next)) | 555 | (eieio--with-scoped-class (cdr next) |
| 559 | (apply fcn newargs)) )))) | 556 | (apply fcn newargs)) )))) |
| 560 | 557 | ||
| 561 | ;;; Here are some CLOS items that need the CL package | 558 | ;;; 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. | |||
| 580 | This class is not stored in the `parent' slot of a class vector." | 577 | This class is not stored in the `parent' slot of a class vector." |
| 581 | :abstract t) | 578 | :abstract t) |
| 582 | 579 | ||
| 580 | (setq eieio-default-superclass (eieio--class-v 'eieio-default-superclass)) | ||
| 581 | |||
| 583 | (defalias 'standard-class 'eieio-default-superclass) | 582 | (defalias 'standard-class 'eieio-default-superclass) |
| 584 | 583 | ||
| 585 | (defgeneric eieio-constructor (class &rest slots) | 584 | (defgeneric eieio-constructor (class &rest slots) |
| @@ -797,7 +796,7 @@ this object." | |||
| 797 | (eieio-print-depth (1+ eieio-print-depth))) | 796 | (eieio-print-depth (1+ eieio-print-depth))) |
| 798 | (while publa | 797 | (while publa |
| 799 | (when (slot-boundp this (car publa)) | 798 | (when (slot-boundp this (car publa)) |
| 800 | (let ((i (class-slot-initarg cl (car publa))) | 799 | (let ((i (eieio--class-slot-initarg cv (car publa))) |
| 801 | (v (eieio-oref this (car publa))) | 800 | (v (eieio-oref this (car publa))) |
| 802 | ) | 801 | ) |
| 803 | (unless (or (not i) (equal v (car publd))) | 802 | (unless (or (not i) (equal v (car publd))) |
| @@ -874,11 +873,13 @@ of `eq'." | |||
| 874 | Used as advice around `edebug-prin1-to-string', held in the | 873 | Used as advice around `edebug-prin1-to-string', held in the |
| 875 | variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to | 874 | variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to |
| 876 | `prin1-to-string' when appropriate." | 875 | `prin1-to-string' when appropriate." |
| 877 | (cond ((class-p object) (eieio-class-name object)) | 876 | (cond ((eieio--class-p object) (eieio-class-name object)) |
| 878 | ((eieio-object-p object) (object-print object)) | 877 | ((eieio-object-p object) (object-print object)) |
| 879 | ((and (listp object) (or (class-p (car object)) | 878 | ((and (listp object) (or (eieio--class-p (car object)) |
| 880 | (eieio-object-p (car object)))) | 879 | (eieio-object-p (car object)))) |
| 881 | (concat "(" (mapconcat #'eieio-edebug-prin1-to-string object " ") | 880 | (concat "(" (mapconcat |
| 881 | (lambda (x) (eieio-edebug-prin1-to-string print-function x)) | ||
| 882 | object " ") | ||
| 882 | ")")) | 883 | ")")) |
| 883 | (t (funcall print-function object noescape)))) | 884 | (t (funcall print-function object noescape)))) |
| 884 | 885 | ||
| @@ -888,7 +889,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to | |||
| 888 | 889 | ||
| 889 | ;;; Start of automatically extracted autoloads. | 890 | ;;; Start of automatically extracted autoloads. |
| 890 | 891 | ||
| 891 | ;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "2b4c57cf907e879e8bbc88d8f0e2de4c") | 892 | ;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "a3f314e2a27e52444df4597c6ae51458") |
| 892 | ;;; Generated autoloads from eieio-custom.el | 893 | ;;; Generated autoloads from eieio-custom.el |
| 893 | 894 | ||
| 894 | (autoload 'customize-object "eieio-custom" "\ | 895 | (autoload 'customize-object "eieio-custom" "\ |
diff --git a/test/ChangeLog b/test/ChangeLog index 53e2c49c9d7..8e3b83efbb0 100644 --- a/test/ChangeLog +++ b/test/ChangeLog | |||
| @@ -1,3 +1,16 @@ | |||
| 1 | 2015-01-05 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | * automated/eieio-tests.el (eieio-test-04-static-method) | ||
| 4 | (eieio-test-05-static-method-2): Use oref-default to access | ||
| 5 | class slots. | ||
| 6 | (eieio-test-23-inheritance-check): Don't assume that | ||
| 7 | eieio-class-parents returns class names, or that a class can only have | ||
| 8 | a single name. | ||
| 9 | |||
| 10 | * automated/eieio-test-persist.el (eieio--attribute-to-initarg): | ||
| 11 | Move from eieio-core.el. Rename from eieio-attribute-to-initarg. | ||
| 12 | Change arg to be a class object. Update all callers. | ||
| 13 | |||
| 1 | 2014-12-29 Stefan Monnier <monnier@iro.umontreal.ca> | 14 | 2014-12-29 Stefan Monnier <monnier@iro.umontreal.ca> |
| 2 | 15 | ||
| 3 | * automated/eieio-test-methodinvoke.el (eieio-test-method-store): | 16 | * automated/eieio-test-methodinvoke.el (eieio-test-method-store): |
diff --git a/test/automated/eieio-test-persist.el b/test/automated/eieio-test-persist.el index 00de3cf0d7c..5ea7cf25740 100644 --- a/test/automated/eieio-test-persist.el +++ b/test/automated/eieio-test-persist.el | |||
| @@ -32,6 +32,14 @@ | |||
| 32 | (require 'eieio-base) | 32 | (require 'eieio-base) |
| 33 | (require 'ert) | 33 | (require 'ert) |
| 34 | 34 | ||
| 35 | (defun eieio--attribute-to-initarg (class attribute) | ||
| 36 | "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. | ||
| 37 | This is usually a symbol that starts with `:'." | ||
| 38 | (let ((tuple (rassoc attribute (eieio--class-initarg-tuples class)))) | ||
| 39 | (if tuple | ||
| 40 | (car tuple) | ||
| 41 | nil))) | ||
| 42 | |||
| 35 | (defun persist-test-save-and-compare (original) | 43 | (defun persist-test-save-and-compare (original) |
| 36 | "Compare the object ORIGINAL against the one read fromdisk." | 44 | "Compare the object ORIGINAL against the one read fromdisk." |
| 37 | 45 | ||
| @@ -53,7 +61,8 @@ | |||
| 53 | (let* ((oneslot (car slot-names)) | 61 | (let* ((oneslot (car slot-names)) |
| 54 | (origvalue (eieio-oref original oneslot)) | 62 | (origvalue (eieio-oref original oneslot)) |
| 55 | (fromdiskvalue (eieio-oref fromdisk oneslot)) | 63 | (fromdiskvalue (eieio-oref fromdisk oneslot)) |
| 56 | (initarg-p (eieio-attribute-to-initarg class oneslot)) | 64 | (initarg-p (eieio--attribute-to-initarg |
| 65 | (eieio--class-v class) oneslot)) | ||
| 57 | ) | 66 | ) |
| 58 | 67 | ||
| 59 | (if initarg-p | 68 | (if initarg-p |
diff --git a/test/automated/eieio-tests.el b/test/automated/eieio-tests.el index 91ddfc4fcf3..f3088bacf32 100644 --- a/test/automated/eieio-tests.el +++ b/test/automated/eieio-tests.el | |||
| @@ -1,6 +1,6 @@ | |||
| 1 | ;;; eieio-tests.el -- eieio tests routines | 1 | ;;; eieio-tests.el -- eieio tests routines |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1999-2003, 2005-2010, 2012-2014 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1999-2003, 2005-2010, 2012-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | 5 | ;; Author: Eric M. Ludlam <zappo@gnu.org> |
| 6 | 6 | ||
| @@ -199,9 +199,9 @@ Argument C is the class bound to this static method." | |||
| 199 | (ert-deftest eieio-test-04-static-method () | 199 | (ert-deftest eieio-test-04-static-method () |
| 200 | ;; Call static method on a class and see if it worked | 200 | ;; Call static method on a class and see if it worked |
| 201 | (static-method-class-method static-method-class 'class) | 201 | (static-method-class-method static-method-class 'class) |
| 202 | (should (eq (oref static-method-class some-slot) 'class)) | 202 | (should (eq (oref-default static-method-class some-slot) 'class)) |
| 203 | (static-method-class-method (static-method-class) 'object) | 203 | (static-method-class-method (static-method-class) 'object) |
| 204 | (should (eq (oref static-method-class some-slot) 'object))) | 204 | (should (eq (oref-default static-method-class some-slot) 'object))) |
| 205 | 205 | ||
| 206 | (ert-deftest eieio-test-05-static-method-2 () | 206 | (ert-deftest eieio-test-05-static-method-2 () |
| 207 | (defclass static-method-class-2 (static-method-class) | 207 | (defclass static-method-class-2 (static-method-class) |
| @@ -215,9 +215,9 @@ Argument C is the class bound to this static method." | |||
| 215 | (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) | 215 | (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) |
| 216 | 216 | ||
| 217 | (static-method-class-method static-method-class-2 'class) | 217 | (static-method-class-method static-method-class-2 'class) |
| 218 | (should (eq (oref static-method-class-2 some-slot) 'moose-class)) | 218 | (should (eq (oref-default static-method-class-2 some-slot) 'moose-class)) |
| 219 | (static-method-class-method (static-method-class-2) 'object) | 219 | (static-method-class-method (static-method-class-2) 'object) |
| 220 | (should (eq (oref static-method-class-2 some-slot) 'moose-object))) | 220 | (should (eq (oref-default static-method-class-2 some-slot) 'moose-object))) |
| 221 | 221 | ||
| 222 | 222 | ||
| 223 | ;;; Perform method testing | 223 | ;;; Perform method testing |
| @@ -536,7 +536,9 @@ METHOD is the method that was attempting to be called." | |||
| 536 | (should (object-of-class-p eitest-ab class-b)) | 536 | (should (object-of-class-p eitest-ab class-b)) |
| 537 | (should (object-of-class-p eitest-ab class-ab)) | 537 | (should (object-of-class-p eitest-ab class-ab)) |
| 538 | (should (eq (eieio-class-parents class-a) nil)) | 538 | (should (eq (eieio-class-parents class-a) nil)) |
| 539 | (should (equal (eieio-class-parents class-ab) '(class-a class-b))) | 539 | ;; FIXME: eieio-class-parents now returns class objects! |
| 540 | (should (equal (mapcar #'eieio-class-object (eieio-class-parents class-ab)) | ||
| 541 | (mapcar #'eieio-class-object '(class-a class-b)))) | ||
| 540 | (should (same-class-p eitest-a class-a)) | 542 | (should (same-class-p eitest-a class-a)) |
| 541 | (should (class-a-p eitest-a)) | 543 | (should (class-a-p eitest-a)) |
| 542 | (should (not (class-a-p eitest-ab))) | 544 | (should (not (class-a-p eitest-ab))) |