1;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -*- lexical-binding:t -*- 2;;; or maybe Eric's Implementation of Emacs Interpreted Objects 3 4;; Copyright (C) 1995-1996, 1998-2021 Free Software Foundation, Inc. 5 6;; Author: Eric M. Ludlam <zappo@gnu.org> 7;; Version: 1.4 8;; Keywords: OO, lisp 9 10;; This file is part of GNU Emacs. 11 12;; GNU Emacs is free software: you can redistribute it and/or modify 13;; it under the terms of the GNU General Public License as published by 14;; the Free Software Foundation, either version 3 of the License, or 15;; (at your option) any later version. 16 17;; GNU Emacs is distributed in the hope that it will be useful, 18;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20;; GNU General Public License for more details. 21 22;; You should have received a copy of the GNU General Public License 23;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 24 25;;; Commentary: 26;; 27;; EIEIO is a series of Lisp routines which implements a subset of 28;; CLOS, the Common Lisp Object System. In addition, EIEIO also adds 29;; a few new features which help it integrate more strongly with the 30;; Emacs running environment. 31;; 32;; See eieio.texi for complete documentation on using this package. 33;; 34;; Note: the implementation of the c3 algorithm is based on: 35;; Kim Barrett et al.: A Monotonic Superclass Linearization for Dylan 36;; Retrieved from: 37;; http://192.220.96.201/dylan/linearization-oopsla96.html 38 39;; @TODO - fix :initform to be a form, not a quoted value 40;; @TODO - Prefix non-clos functions with `eieio-'. 41 42;; TODO: better integrate CL's defstructs and classes. E.g. make it possible 43;; to create a new class that inherits from a struct. 44 45;;; Code: 46 47(defvar eieio-version "1.4" 48 "Current version of EIEIO.") 49 50(defun eieio-version () 51 "Display the current version of EIEIO." 52 (interactive) 53 (message eieio-version)) 54 55(require 'eieio-core) 56(eval-when-compile (require 'subr-x)) 57 58 59;;; Defining a new class 60;; 61(defmacro defclass (name superclasses slots &rest options-and-doc) 62 "Define NAME as a new class derived from SUPERCLASS with SLOTS. 63OPTIONS-AND-DOC is used as the class' options and base documentation. 64SUPERCLASSES is a list of superclasses to inherit from, with SLOTS 65being the slots residing in that class definition. Supported tags are: 66 67 :initform - Initializing form. 68 :initarg - Tag used during initialization. 69 :accessor - Tag used to create a function to access this slot. 70 :allocation - Specify where the value is stored. 71 Defaults to `:instance', but could also be `:class'. 72 :writer - A function symbol which will `write' an object's slot. 73 :reader - A function symbol which will `read' an object. 74 :type - The type of data allowed in this slot (see `typep'). 75 :documentation 76 - A string documenting use of this slot. 77 78The following are extensions on CLOS: 79 :custom - When customizing an object, the custom :type. Public only. 80 :label - A text string label used for a slot when customizing. 81 :group - Name of a customization group this slot belongs in. 82 :printer - A function to call to print the value of a slot. 83 See `eieio-override-prin1' as an example. 84 85A class can also have optional options. These options happen in place 86of documentation (including a :documentation tag), in addition to 87documentation, or not at all. Supported options are: 88 89 :documentation - The doc-string used for this class. 90 91Options added to EIEIO: 92 93 :allow-nil-initform - Non-nil to skip typechecking of null initforms. 94 :custom-groups - List of custom group names. Organizes slots into 95 reasonable groups for customizations. 96 :abstract - Non-nil to prevent instances of this class. 97 If a string, use as an error string if someone does 98 try to make an instance. 99 :method-invocation-order 100 - Control the method invocation order if there is 101 multiple inheritance. Valid values are: 102 :breadth-first - The default. 103 :depth-first 104 105Options in CLOS not supported in EIEIO: 106 107 :metaclass - Class to use in place of `standard-class' 108 :default-initargs - Initargs to use when initializing new objects of 109 this class. 110 111Due to the way class options are set up, you can add any tags you wish, 112and reference them using the function `class-option'." 113 (declare (doc-string 4) (indent defun)) 114 (cl-check-type superclasses list) 115 116 (cond ((and (stringp (car options-and-doc)) 117 (/= 1 (% (length options-and-doc) 2))) 118 (error "Too many arguments to `defclass'")) 119 ((and (symbolp (car options-and-doc)) 120 (/= 0 (% (length options-and-doc) 2))) 121 (error "Too many arguments to `defclass'"))) 122 123 (if (stringp (car options-and-doc)) 124 (setq options-and-doc 125 (cons :documentation options-and-doc))) 126 127 ;; Make sure the method invocation order is a valid value. 128 (let ((io (eieio--class-option-assoc options-and-doc 129 :method-invocation-order))) 130 (when (and io (not (member io '(:depth-first :breadth-first :c3)))) 131 (error "Method invocation order %s is not allowed" io))) 132 133 (let ((testsym1 (intern (concat (symbol-name name) "-p"))) 134 (testsym2 (intern (format "%s--eieio-childp" name))) 135 (warnings '()) 136 (accessors ())) 137 138 ;; Collect the accessors we need to define. 139 (pcase-dolist (`(,sname . ,soptions) slots) 140 (let* ((acces (plist-get soptions :accessor)) 141 (initarg (plist-get soptions :initarg)) 142 (reader (plist-get soptions :reader)) 143 (writer (plist-get soptions :writer)) 144 (alloc (plist-get soptions :allocation)) 145 (label (plist-get soptions :label))) 146 147 ;; Update eieio--known-slot-names already in case we compile code which 148 ;; uses this before the class is loaded. 149 (cl-pushnew sname eieio--known-slot-names) 150 (when (eq alloc :class) 151 (cl-pushnew sname eieio--known-class-slot-names)) 152 153 (if eieio-error-unsupported-class-tags 154 (let ((tmp soptions)) 155 (while tmp 156 (if (not (member (car tmp) '(:accessor 157 :initform 158 :initarg 159 :documentation 160 :protection 161 :reader 162 :writer 163 :allocation 164 :type 165 :custom 166 :label 167 :group 168 :printer 169 :allow-nil-initform 170 :custom-groups))) 171 (signal 'invalid-slot-type (list (car tmp)))) 172 (setq tmp (cdr (cdr tmp)))))) 173 174 ;; Make sure the :allocation parameter has a valid value. 175 (if (not (memq alloc '(nil :class :instance))) 176 (signal 'invalid-slot-type (list :allocation alloc))) 177 178 ;; Label is nil, or a string 179 (if (not (or (null label) (stringp label))) 180 (signal 'invalid-slot-type (list :label label))) 181 182 ;; Is there an initarg, but allocation of class? 183 (when (and initarg (eq alloc :class)) 184 (push (format "Meaningless :initarg for class allocated slot '%S'" 185 sname) 186 warnings)) 187 188 (let ((init (plist-get soptions :initform))) 189 (unless (or (macroexp-const-p init) 190 (eieio--eval-default-p init)) 191 ;; FIXME: Historically, EIEIO used a heuristic to try and guess 192 ;; whether the initform is a form to be evaluated or just 193 ;; a constant. We use `eieio--eval-default-p' to see what the 194 ;; heuristic says and if it disagrees with normal evaluation 195 ;; then tweak the initform to make it fit and emit 196 ;; a warning accordingly. 197 (push (format "Ambiguous initform needs quoting: %S" init) 198 warnings))) 199 200 ;; Anyone can have an accessor function. This creates a function 201 ;; of the specified name, and also performs a `defsetf' if applicable 202 ;; so that users can `setf' the space returned by this function. 203 (when acces 204 (push `(cl-defmethod (setf ,acces) (value (this ,name)) 205 (eieio-oset this ',sname value)) 206 accessors) 207 (push `(cl-defmethod ,acces ((this ,name)) 208 ,(internal--format-docstring-line 209 "Retrieve the slot `%S' from an object of class `%S'." 210 sname name) 211 ;; FIXME: Why is this different from the :reader case? 212 (if (slot-boundp this ',sname) (eieio-oref this ',sname))) 213 accessors) 214 (when (and eieio-backward-compatibility (eq alloc :class)) 215 ;; FIXME: How could I declare this *method* as obsolete. 216 (push `(cl-defmethod ,acces ((this (subclass ,name))) 217 ,(format 218 "Retrieve the class slot `%S' from a class `%S'. 219This method is obsolete." 220 sname name) 221 (if (slot-boundp this ',sname) 222 (eieio-oref-default this ',sname))) 223 accessors))) 224 225 ;; If a writer is defined, then create a generic method of that 226 ;; name whose purpose is to set the value of the slot. 227 (if writer 228 (push `(cl-defmethod ,writer ((this ,name) value) 229 ,(format "Set the slot `%S' of an object of class `%S'." 230 sname name) 231 (setf (slot-value this ',sname) value)) 232 accessors)) 233 ;; If a reader is defined, then create a generic method 234 ;; of that name whose purpose is to access this slot value. 235 (if reader 236 (push `(cl-defmethod ,reader ((this ,name)) 237 ,(format "Access the slot `%S' from object of class `%S'." 238 sname name) 239 (slot-value this ',sname)) 240 accessors)) 241 )) 242 243 `(progn 244 ,@(mapcar (lambda (w) 245 (macroexp-warn-and-return w `(progn ',w) nil 'compile-only)) 246 warnings) 247 ;; This test must be created right away so we can have self- 248 ;; referencing classes. ei, a class whose slot can contain only 249 ;; pointers to itself. 250 251 ;; Create the test functions. 252 (defalias ',testsym1 (eieio-make-class-predicate ',name)) 253 (defalias ',testsym2 (eieio-make-child-predicate ',name)) 254 255 ,@(when eieio-backward-compatibility 256 (let ((f (intern (format "%s-child-p" name)))) 257 `((defalias ',f #',testsym2) 258 (make-obsolete 259 ',f ,(format "use (cl-typep ... \\='%s) instead" name) 260 "25.1")))) 261 262 ;; When using typep, (typep OBJ 'myclass) returns t for objects which 263 ;; are subclasses of myclass. For our predicates, however, it is 264 ;; important for EIEIO to be backwards compatible, where 265 ;; myobject-p, and myobject-child-p are different. 266 ;; "cl" uses this technique to specify symbols with specific typep 267 ;; test, so we can let typep have the CLOS documented behavior 268 ;; while keeping our above predicate clean. 269 270 (define-symbol-prop ',name 'cl-deftype-satisfies #',testsym2) 271 272 (eieio-defclass-internal ',name ',superclasses ',slots ',options-and-doc) 273 274 ,@accessors 275 276 ;; Create the constructor function 277 ,(if (eieio--class-option-assoc options-and-doc :abstract) 278 ;; Abstract classes cannot be instantiated. Say so. 279 (let ((abs (eieio--class-option-assoc options-and-doc :abstract))) 280 (if (not (stringp abs)) 281 (setq abs (format "Class %s is abstract" name))) 282 `(defun ,name (&rest _) 283 ,(format "You cannot create a new object of type `%S'." name) 284 (error ,abs))) 285 286 ;; Non-abstract classes need a constructor. 287 `(defun ,name (&rest slots) 288 ,(internal--format-docstring-line 289 "Create a new object of class type `%S'." name) 290 (declare (compiler-macro 291 (lambda (whole) 292 (if (not (stringp (car slots))) 293 whole 294 (macroexp-warn-and-return 295 (format "Obsolete name arg %S to constructor %S" 296 (car slots) (car whole)) 297 ;; Keep the name arg, for backward compatibility, 298 ;; but hide it so we don't trigger indefinitely. 299 `(,(car whole) (identity ,(car slots)) 300 ,@(cdr slots))))))) 301 (apply #'make-instance ',name slots)))))) 302 303 304;;; Get/Set slots in an object. 305;; 306(defmacro oref (obj slot) 307 "Retrieve the value stored in OBJ in the slot named by SLOT." 308 (declare (debug (form symbolp))) 309 `(eieio-oref ,obj (quote ,slot))) 310 311(defalias 'slot-value #'eieio-oref) 312(defalias 'set-slot-value #'eieio-oset) 313(make-obsolete 'set-slot-value "use (setf (slot-value ..) ..) instead" "25.1") 314 315(defmacro oref-default (class slot) 316 "Get the value of class allocated slot SLOT. 317CLASS can also be an object, in which case we use the object's class." 318 (declare (debug (form symbolp))) 319 `(eieio-oref-default ,class (quote ,slot))) 320 321;;; Handy CLOS macros 322;; 323(defmacro with-slots (spec-list object &rest body) 324 "Bind SPEC-LIST lexically to slot values in OBJECT, and execute BODY. 325This establishes a lexical environment for referring to the slots in 326the instance named by the given slot-names as though they were 327variables. Within such a context the value of the slot can be 328specified by using its slot name, as if it were a lexically bound 329variable. Both setf and setq can be used to set the value of the 330slot. 331 332SPEC-LIST is of a form similar to `let'. For example: 333 334 ((VAR1 SLOT1) 335 SLOT2 336 SLOTN 337 (VARN+1 SLOTN+1)) 338 339Where each VAR is the local variable given to the associated 340SLOT. A slot specified without a variable name is given a 341variable name of the same name as the slot." 342 (declare (indent 2) (debug (sexp sexp def-body))) 343 (require 'cl-lib) 344 ;; Transform the spec-list into a cl-symbol-macrolet spec-list. 345 (macroexp-let2 nil object object 346 `(cl-symbol-macrolet 347 ,(mapcar (lambda (entry) 348 (let ((var (if (listp entry) (car entry) entry)) 349 (slot (if (listp entry) (cadr entry) entry))) 350 (list var `(slot-value ,object ',slot)))) 351 spec-list) 352 ,@body))) 353 354;; Keep it as a non-inlined function, so the internals of object don't get 355;; hard-coded in random .elc files. 356(defun eieio-pcase-slot-index-table (obj) 357 "Return some data structure from which can be extracted the slot offset." 358 (eieio--class-index-table (eieio--object-class obj))) 359 360(defun eieio-pcase-slot-index-from-index-table (index-table slot) 361 "Find the index to pass to `aref' to access SLOT." 362 (gethash slot index-table)) 363 364(pcase-defmacro eieio (&rest fields) 365 "Pcase patterns that match EIEIO object EXPVAL. 366Elements of FIELDS can be of the form (NAME PAT) in which case the 367contents of field NAME is matched against PAT, or they can be of 368 the form NAME which is a shorthand for (NAME NAME)." 369 (declare (debug (&rest [&or (sexp pcase-PAT) sexp]))) 370 ;; FIXME: This generates a horrendous mess of redundant let bindings. 371 ;; `pcase' needs to be improved somehow to introduce let-bindings more 372 ;; sparingly, or the byte-compiler needs to be taught to optimize 373 ;; them away. 374 ;; FIXME: `pcase' does not do a good job here of sharing tests&code among 375 ;; various branches. 376 `(and (pred eieio-object-p) 377 ,@(mapcar (lambda (field) 378 (pcase-exhaustive field 379 (`(,name ,pat) 380 `(app (pcase--flip eieio-oref ',name) ,pat)) 381 ((pred symbolp) 382 `(app (pcase--flip eieio-oref ',field) ,field)))) 383 fields))) 384 385;;; Simple generators, and query functions. None of these would do 386;; well embedded into an object. 387;; 388 389(define-obsolete-function-alias 390 'object-class-fast #'eieio-object-class "24.4") 391 392;; In the past, every EIEIO object had a `name' field, so we had the 393;; two methods `eieio-object-name-string' and 394;; `eieio-object-set-name-string' "for free". Since this field is 395;; very rarely used, we got rid of it and instead we keep it in a weak 396;; hash-tables, for those very rare objects that use it. 397;; Really, those rare objects should inherit from `eieio-named' instead! 398(defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key)) 399 400(cl-defgeneric eieio-object-name-string (obj) 401 "Return a string which is OBJ's name." 402 (or (gethash obj eieio--object-names) 403 (format "%s-%x" (eieio-object-class obj) (sxhash-eq obj)))) 404 405(define-obsolete-function-alias 406 'object-name-string #'eieio-object-name-string "24.4") 407 408(defun eieio-object-name (obj &optional extra) 409 "Return a printed representation for object OBJ. 410If EXTRA, include that in the string returned to represent the symbol." 411 (cl-check-type obj eieio-object) 412 (format "#<%s %s%s>" (eieio-object-class obj) 413 (eieio-object-name-string obj) 414 (cond 415 ((null extra) 416 "") 417 ((listp extra) 418 (concat " " (mapconcat #'identity extra " "))) 419 (t 420 extra)))) 421(define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") 422 423(defun eieio-object-class (obj) 424 "Return the class struct defining OBJ." 425 ;; FIXME: We say we return a "struct" but we return a symbol instead! 426 (cl-check-type obj eieio-object) 427 (eieio--class-name (eieio--object-class obj))) 428(define-obsolete-function-alias 'object-class #'eieio-object-class "24.4") 429;; CLOS name, maybe? 430(define-obsolete-function-alias 'class-of #'eieio-object-class "24.4") 431 432(defun eieio-object-class-name (obj) 433 "Return a Lisp like symbol name for OBJ's class." 434 (cl-check-type obj eieio-object) 435 (eieio-class-name (eieio--object-class obj))) 436(define-obsolete-function-alias 437 'object-class-name #'eieio-object-class-name "24.4") 438 439(defun eieio-class-parents (class) 440 ;; FIXME: What does "(overload of variable)" mean here? 441 "Return parent classes to CLASS. (overload of variable). 442 443The CLOS function `class-direct-superclasses' is aliased to this function." 444 (eieio--class-parents (eieio--full-class-object class))) 445 446(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") 447 448(defun eieio-class-children (class) 449 "Return child classes to CLASS. 450The CLOS function `class-direct-subclasses' is aliased to this function." 451 (cl-check-type class class) 452 (eieio--class-children (cl--find-class class))) 453(define-obsolete-function-alias 454 'class-children #'eieio-class-children "24.4") 455 456;; Official CLOS functions. 457(define-obsolete-function-alias 458 'class-direct-superclasses #'eieio-class-parents "24.4") 459(define-obsolete-function-alias 460 'class-direct-subclasses #'eieio-class-children "24.4") 461 462(defmacro eieio-class-parent (class) 463 "Return first parent class to CLASS. (overload of variable)." 464 `(car (eieio-class-parents ,class))) 465(define-obsolete-function-alias 'class-parent #'eieio-class-parent "24.4") 466 467(defun same-class-p (obj class) 468 "Return t if OBJ is of class-type CLASS." 469 (setq class (eieio--class-object class)) 470 (cl-check-type class eieio--class) 471 (cl-check-type obj eieio-object) 472 (eq (eieio--object-class obj) class)) 473 474(defun object-of-class-p (obj class) 475 "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." 476 (cl-check-type obj eieio-object) 477 ;; class will be checked one layer down 478 (child-of-class-p (eieio--object-class obj) class)) 479;; Backwards compatibility 480(defalias 'obj-of-class-p #'object-of-class-p) 481 482(defun child-of-class-p (child class) 483 "Return non-nil if CHILD class is a subclass of CLASS." 484 (setq child (eieio--full-class-object child)) 485 (cl-check-type child eieio--class) 486 ;; `eieio-default-superclass' is never mentioned in eieio--class-parents, 487 ;; so we have to special case it here. 488 (or (eq class 'eieio-default-superclass) 489 (let ((p nil)) 490 (setq class (eieio--class-object class)) 491 (cl-check-type class eieio--class) 492 (while (and child (not (eq child class))) 493 (setq p (append p (eieio--class-parents child)) 494 child (pop p))) 495 (if child t)))) 496 497(defun eieio-slot-descriptor-name (slot) 498 (cl--slot-descriptor-name slot)) 499 500(defun eieio-class-slots (class) 501 "Return list of slots available in instances of CLASS." 502 ;; FIXME: This only gives the instance slots and ignores the 503 ;; class-allocated slots. 504 (setq class (eieio--class-object class)) 505 (cl-check-type class eieio--class) 506 (mapcar #'identity (eieio--class-slots class))) 507 508(defun object-slots (obj) 509 "Return list of slot names available in OBJ." 510 (declare (obsolete eieio-class-slots "25.1")) 511 (cl-check-type obj eieio-object) 512 (mapcar #'cl--slot-descriptor-name 513 (eieio-class-slots (eieio--object-class obj)))) 514 515(defun eieio--class-slot-initarg (class slot) 516 "Fetch from CLASS, SLOT's :initarg." 517 (cl-check-type class eieio--class) 518 (let ((ia (eieio--class-initarg-tuples class)) 519 (f nil)) 520 (while (and ia (not f)) 521 (if (eq (cdr (car ia)) slot) 522 (setq f (car (car ia)))) 523 (setq ia (cdr ia))) 524 f)) 525 526;;; Object Set macros 527;; 528(defmacro oset (obj slot value) 529 "Set the value in OBJ for slot SLOT to VALUE. 530SLOT is the slot name as specified in `defclass' or the tag created 531with in the :initarg slot. VALUE can be any Lisp object." 532 (declare (debug (form symbolp form))) 533 `(eieio-oset ,obj (quote ,slot) ,value)) 534 535(defmacro oset-default (class slot value) 536 "Set the default slot in CLASS for SLOT to VALUE. 537The default value is usually set with the :initform tag during class 538creation. This allows users to change the default behavior of classes 539after they are created." 540 (declare (debug (form symbolp form))) 541 `(eieio-oset-default ,class (quote ,slot) ,value)) 542 543;;; CLOS queries into classes and slots 544;; 545(defun slot-boundp (object slot) 546 "Return non-nil if OBJECT's SLOT is bound. 547Setting a slot's value makes it bound. Calling `slot-makeunbound' will 548make a slot unbound. 549OBJECT can be an instance or a class." 550 ;; Skip typechecking while retrieving this value. 551 (let ((eieio-skip-typecheck t)) 552 ;; Return nil if the magic symbol is in there. 553 (not (eq (cond 554 ((eieio-object-p object) (eieio-oref object slot)) 555 ((symbolp object) (eieio-oref-default object slot)) 556 (t (signal 'wrong-type-argument (list 'eieio-object-p object)))) 557 eieio--unbound)))) 558 559(defun slot-makeunbound (object slot) 560 "In OBJECT, make SLOT unbound." 561 (eieio-oset object slot eieio--unbound)) 562 563(defun slot-exists-p (object-or-class slot) 564 "Return non-nil if OBJECT-OR-CLASS has SLOT." 565 (let ((cv (cond ((eieio-object-p object-or-class) 566 (eieio--object-class object-or-class)) 567 ((eieio--class-p object-or-class) object-or-class) 568 (t (find-class object-or-class 'error))))) 569 (or (gethash slot (eieio--class-index-table cv)) 570 ;; FIXME: We could speed this up by adding class slots into the 571 ;; index-table (e.g. with a negative index?). 572 (let ((cs (eieio--class-class-slots cv)) 573 found) 574 (dotimes (i (length cs)) 575 (if (eq slot (cl--slot-descriptor-name (aref cs i))) 576 (setq found t))) 577 found)))) 578 579(defun find-class (symbol &optional errorp) 580 "Return the class that SYMBOL represents. 581If there is no class, nil is returned if ERRORP is nil. 582If ERRORP is non-nil, `wrong-argument-type' is signaled." 583 (let ((class (cl--find-class symbol))) 584 (cond 585 ((eieio--class-p class) class) 586 (errorp (signal 'wrong-type-argument (list 'class-p symbol)))))) 587 588;;; Slightly more complex utility functions for objects 589;; 590(defun object-assoc (key slot list) 591 "Return an object if KEY is `equal' to SLOT's value of an object in LIST. 592LIST is a list of objects whose slots are searched. 593Objects in LIST do not need to have a slot named SLOT, nor does 594SLOT need to be bound. If these errors occur, those objects will 595be ignored." 596 (cl-check-type list list) 597 (while (and list (not (condition-case nil 598 ;; This prevents errors for missing slots. 599 (equal key (eieio-oref (car list) slot)) 600 (error nil)))) 601 (setq list (cdr list))) 602 (car list)) 603 604(defun object-assoc-list (slot list) 605 "Return an association list with the contents of SLOT as the key element. 606LIST must be a list of objects with SLOT in it. 607This is useful when you need to do completing read on an object group." 608 (cl-check-type list list) 609 (let ((assoclist nil)) 610 (while list 611 (setq assoclist (cons (cons (eieio-oref (car list) slot) 612 (car list)) 613 assoclist)) 614 (setq list (cdr list))) 615 (nreverse assoclist))) 616 617(defun object-assoc-list-safe (slot list) 618 "Return an association list with the contents of SLOT as the key element. 619LIST must be a list of objects, but those objects do not need to have 620SLOT in it. If it does not, then that element is left out of the association 621list." 622 (cl-check-type list list) 623 (let ((assoclist nil)) 624 (while list 625 (if (slot-exists-p (car list) slot) 626 (setq assoclist (cons (cons (eieio-oref (car list) slot) 627 (car list)) 628 assoclist))) 629 (setq list (cdr list))) 630 (nreverse assoclist))) 631 632(defun object-add-to-list (object slot item &optional append) 633 "In OBJECT's SLOT, add ITEM to the list of elements. 634Optional argument APPEND indicates we need to append to the list. 635If ITEM already exists in the list in SLOT, then it is not added. 636Comparison is done with `equal' through the `member' function call. 637If SLOT is unbound, bind it to the list containing ITEM." 638 (let (ov) 639 ;; Find the originating list. 640 (if (not (slot-boundp object slot)) 641 (setq ov (list item)) 642 (setq ov (eieio-oref object slot)) 643 ;; turn it into a list. 644 (unless (listp ov) 645 (setq ov (list ov))) 646 ;; Do the combination 647 (if (not (member item ov)) 648 (setq ov 649 (if append 650 (append ov (list item)) 651 (cons item ov))))) 652 ;; Set back into the slot. 653 (eieio-oset object slot ov))) 654 655(defun object-remove-from-list (object slot item) 656 "In OBJECT's SLOT, remove occurrences of ITEM. 657Deletion is done with `delete', which deletes by side effect, 658and comparisons are done with `equal'. 659If SLOT is unbound, do nothing." 660 (if (not (slot-boundp object slot)) 661 nil 662 (eieio-oset object slot (delete item (eieio-oref object slot))))) 663 664 665;;; 666;; We want all objects created by EIEIO to have some default set of 667;; behaviors so we can create object utilities, and allow various 668;; types of error checking. To do this, create the default EIEIO 669;; class, and when no parent class is specified, use this as the 670;; default. (But don't store it in the other classes as the default, 671;; allowing for transparent support.) 672;; 673 674(defclass eieio-default-superclass nil 675 nil 676 "Default parent class for classes with no specified parent class. 677Its slots are automatically adopted by classes with no specified parents. 678This class is not stored in the `parent' slot of a class vector." 679 :abstract t) 680 681(setq eieio-default-superclass (cl--find-class 'eieio-default-superclass)) 682 683(define-obsolete-function-alias 'standard-class 684 #'eieio-default-superclass "26.1") 685 686(cl-defgeneric make-instance (class &rest initargs) 687 "Make a new instance of CLASS based on INITARGS. 688For example: 689 690 (make-instance \\='foo) 691 692INITARGS is a property list with keywords based on the `:initarg' 693for each slot. For example: 694 695 (make-instance \\='foo :slot1 value1 :slotN valueN)") 696 697(define-obsolete-function-alias 'constructor #'make-instance "25.1") 698 699(cl-defmethod make-instance 700 ((class (subclass eieio-default-superclass)) &rest slots) 701 "Default constructor for CLASS `eieio-default-superclass'. 702SLOTS are the initialization slots used by `initialize-instance'. 703This static method is called when an object is constructed. 704It allocates the vector used to represent an EIEIO object, and then 705calls `initialize-instance' on that object." 706 (let* ((new-object (copy-sequence (eieio--class-default-object-cache 707 (eieio--class-object class))))) 708 (if (and slots 709 (let ((x (car slots))) 710 (or (stringp x) (null x)))) 711 (funcall (if eieio-backward-compatibility #'ignore #'message) 712 "Obsolete name %S passed to %S constructor" 713 (pop slots) class)) 714 ;; Call the initialize method on the new object with the slots 715 ;; that were passed down to us. 716 (initialize-instance new-object slots) 717 (when eieio-backward-compatibility 718 ;; Use symbol as type descriptor, for backwards compatibility. 719 (aset new-object 0 class)) 720 ;; Return the created object. 721 new-object)) 722 723;; FIXME: CLOS uses "&rest INITARGS" instead. 724(cl-defgeneric shared-initialize (obj slots) 725 "Set slots of OBJ with SLOTS which is a list of name/value pairs. 726Called from the constructor routine.") 727 728(cl-defmethod shared-initialize ((obj eieio-default-superclass) slots) 729 "Set slots of OBJ with SLOTS which is a list of name/value pairs. 730Called from the constructor routine." 731 (while slots 732 (let ((rn (eieio--initarg-to-attribute (eieio--object-class obj) 733 (car slots)))) 734 (if (not rn) 735 (slot-missing obj (car slots) 'oset (car (cdr slots))) 736 (eieio-oset obj rn (car (cdr slots))))) 737 (setq slots (cdr (cdr slots))))) 738 739;; FIXME: CLOS uses "&rest INITARGS" instead. 740(cl-defgeneric initialize-instance (this &optional slots) 741 "Construct the new object THIS based on SLOTS.") 742 743(cl-defmethod initialize-instance ((this eieio-default-superclass) 744 &optional args) 745 "Construct the new object THIS based on ARGS. 746ARGS is a property list where odd numbered elements are tags, and 747even numbered elements are the values to store in the tagged slot. 748If you overload the `initialize-instance', there you will need to 749call `shared-initialize' yourself, or you can call `call-next-method' 750to have this constructor called automatically. If these steps are 751not taken, then new objects of your class will not have their values 752dynamically set from ARGS." 753 (let* ((this-class (eieio--object-class this)) 754 (initargs args) 755 (slots (eieio--class-slots this-class))) 756 (dotimes (i (length slots)) 757 ;; For each slot, see if we need to evaluate its initform. 758 (let* ((slot (aref slots i)) 759 (slot-name (eieio-slot-descriptor-name slot)) 760 (initform (cl--slot-descriptor-initform slot))) 761 (unless (or (when-let ((initarg 762 (car (rassq slot-name 763 (eieio--class-initarg-tuples 764 this-class))))) 765 (plist-get initargs initarg)) 766 ;; Those slots whose initform is constant already have 767 ;; the right value set in the default-object. 768 (macroexp-const-p initform)) 769 ;; FIXME: Use `aset' instead of `eieio-oset', relying on that 770 ;; vector returned by `eieio--class-slots' 771 ;; should be congruent with the object itself. 772 (eieio-oset this slot-name (eval initform t)))))) 773 ;; Shared initialize will parse our args for us. 774 (shared-initialize this args)) 775 776(cl-defgeneric slot-missing (object slot-name _operation &optional _new-value) 777 "Method invoked when an attempt to access a slot in OBJECT fails. 778SLOT-NAME is the name of the failed slot, OPERATION is the type of access 779that was requested, and optional NEW-VALUE is the value that was desired 780to be set. 781 782This method is called from `oref', `oset', and other functions which 783directly reference slots in EIEIO objects." 784 (signal 'invalid-slot-name 785 (list (if (eieio-object-p object) (eieio-object-name object) object) 786 slot-name))) 787 788(cl-defgeneric slot-unbound (object class slot-name fn) 789 "Slot unbound is invoked during an attempt to reference an unbound slot.") 790 791(cl-defmethod slot-unbound ((object eieio-default-superclass) 792 class slot-name fn) 793 "Slot unbound is invoked during an attempt to reference an unbound slot. 794OBJECT is the instance of the object being reference. CLASS is the 795class of OBJECT, and SLOT-NAME is the offending slot. This function 796throws the signal `unbound-slot'. You can overload this function and 797return the value to use in place of the unbound value. 798Argument FN is the function signaling this error. 799Use `slot-boundp' to determine if a slot is bound or not. 800 801In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but 802EIEIO can only dispatch on the first argument, so the first two are swapped." 803 (signal 'unbound-slot (list (eieio-class-name class) 804 (eieio-object-name object) 805 slot-name fn))) 806 807(cl-defgeneric clone (obj &rest params) 808 "Make a copy of OBJ, and then supply PARAMS. 809PARAMS is a parameter list of the same form used by `initialize-instance'. 810 811When overloading `clone', be sure to call `call-next-method' 812first and modify the returned object.") 813 814(cl-defmethod clone ((obj eieio-default-superclass) &rest params) 815 "Make a copy of OBJ, and then apply PARAMS." 816 (let ((nobj (copy-sequence obj))) 817 (if (stringp (car params)) 818 (funcall (if eieio-backward-compatibility #'ignore #'message) 819 "Obsolete name %S passed to clone" (pop params))) 820 (if params (shared-initialize nobj params)) 821 nobj)) 822 823(cl-defgeneric destructor (_this &rest _params) 824 "Destructor for cleaning up any dynamic links to our object." 825 (declare (obsolete nil "26.1")) 826 ;; No cleanup... yet. 827 nil) 828 829(cl-defgeneric object-print (this &rest _strings) 830 "Pretty printer for object THIS. 831 832It is sometimes useful to put a summary of the object into the 833default #<notation> string when using EIEIO browsing tools. 834Implement this method to customize the summary." 835 (declare (obsolete cl-print-object "26.1")) 836 (format "%S" this)) 837 838(with-suppressed-warnings ((obsolete object-print)) 839 (cl-defmethod object-print ((this eieio-default-superclass) &rest strings) 840 "Pretty printer for object THIS. Call function `object-name' with STRINGS. 841The default method for printing object THIS is to use the 842function `object-name'. 843 844It is sometimes useful to put a summary of the object into the 845default #<notation> string when using EIEIO browsing tools. 846 847Implement this function and specify STRINGS in a call to 848`call-next-method' to provide additional summary information. 849When passing in extra strings from child classes, always remember 850to prepend a space." 851 (eieio-object-name this (apply #'concat strings)))) 852 853(with-suppressed-warnings ((obsolete object-print)) 854 (cl-defmethod cl-print-object ((object eieio-default-superclass) stream) 855 "Default printer for EIEIO objects." 856 ;; Fallback to the old `object-print'. There should be no 857 ;; `object-print' methods in the Emacs tree, but there may be some 858 ;; out-of-tree. 859 (princ (object-print object) stream))) 860 861 862(defvar eieio-print-depth 0 863 "The current indentation depth while printing. 864Ignored if `eieio-print-indentation' is nil.") 865 866(defvar eieio-print-indentation t 867 "When non-nil, indent contents of printed objects.") 868 869(defvar eieio-print-object-name t 870 "When non-nil write the object name in `object-write'. 871Does not affect objects subclassing `eieio-named'. Note that 872Emacs<26 requires that object names be present.") 873 874(cl-defgeneric object-write (this &optional comment) 875 "Write out object THIS to the current stream. 876Optional COMMENT will add comments to the beginning of the output.") 877 878(cl-defmethod object-write ((this eieio-default-superclass) &optional comment) 879 "Write object THIS out to the current stream. 880This writes out the vector version of this object. Complex and recursive 881object are discouraged from being written. 882 If optional COMMENT is non-nil, include comments when outputting 883this object." 884 (when (and comment eieio-print-object-name) 885 (princ ";; Object ") 886 (princ (eieio-object-name-string this)) 887 (princ "\n")) 888 (when comment 889 (princ comment) 890 (princ "\n")) 891 (let* ((cl (eieio-object-class this)) 892 (cv (cl--find-class cl))) 893 ;; Now output readable lisp to recreate this object 894 ;; It should look like this: 895 ;; (<constructor> <name> <slot> <slot> ... ) 896 ;; Each slot's slot is written using its :writer. 897 (when eieio-print-indentation 898 (princ (make-string (* eieio-print-depth 2) ? ))) 899 (princ "(") 900 (princ (symbol-name (eieio--class-constructor (eieio-object-class this)))) 901 (when eieio-print-object-name 902 (princ " ") 903 (prin1 (eieio-object-name-string this)) 904 (princ "\n")) 905 ;; Loop over all the public slots 906 (let ((slots (eieio--class-slots cv)) 907 (eieio-print-depth (1+ eieio-print-depth))) 908 (dotimes (i (length slots)) 909 (let ((slot (aref slots i))) 910 (when (slot-boundp this (cl--slot-descriptor-name slot)) 911 (let ((i (eieio--class-slot-initarg 912 cv (cl--slot-descriptor-name slot))) 913 (v (eieio-oref this (cl--slot-descriptor-name slot)))) 914 (unless (or (not i) (equal v (cl--slot-descriptor-initform slot))) 915 (unless (bolp) 916 (princ "\n")) 917 (when eieio-print-indentation 918 (princ (make-string (* eieio-print-depth 2) ? ))) 919 (princ (symbol-name i)) 920 (if (alist-get :printer (cl--slot-descriptor-props slot)) 921 ;; Use our public printer 922 (progn 923 (princ " ") 924 (funcall (alist-get :printer 925 (cl--slot-descriptor-props slot)) 926 v)) 927 ;; Use our generic override prin1 function. 928 (princ (if (or (eieio-object-p v) 929 (eieio-object-p (car-safe v))) 930 "\n" " ")) 931 (eieio-override-prin1 v)))))))) 932 (princ ")") 933 (when (zerop eieio-print-depth) 934 (princ "\n")))) 935 936(defun eieio-override-prin1 (thing) 937 "Perform a `prin1' on THING taking advantage of object knowledge." 938 (cond ((eieio-object-p thing) 939 (object-write thing)) 940 ((consp thing) 941 (eieio-list-prin1 thing)) 942 ((hash-table-p thing) 943 (let ((copy (copy-hash-table thing))) 944 (maphash 945 (lambda (key val) 946 (setf (gethash key copy) 947 (read 948 (with-output-to-string 949 (eieio-override-prin1 val))))) 950 copy) 951 (prin1 copy))) 952 ((vectorp thing) 953 (let ((copy (copy-sequence thing))) 954 (dotimes (i (length copy)) 955 (aset copy i 956 (read 957 (with-output-to-string 958 (eieio-override-prin1 959 (aref copy i)))))) 960 (prin1 copy))) 961 ((eieio--class-p thing) 962 (princ (eieio--class-print-name thing))) 963 (t (prin1 thing)))) 964 965(defun eieio-list-prin1 (list) 966 "Display LIST where list may contain objects." 967 (if (not (eieio-object-p (car list))) 968 (progn 969 (princ "'") 970 (prin1 list)) 971 (when eieio-print-indentation 972 (princ (make-string (* eieio-print-depth 2) ? ))) 973 (princ "(list") 974 (let ((eieio-print-depth (1+ eieio-print-depth))) 975 (while list 976 (princ "\n") 977 (if (eieio-object-p (car list)) 978 (object-write (car list)) 979 (when eieio-print-indentation 980 (princ (make-string (* eieio-print-depth) ? ))) 981 (eieio-override-prin1 (car list))) 982 (setq list (cdr list)))) 983 (princ ")"))) 984 985 986;;; Unimplemented functions from CLOS 987;; 988(defun eieio-change-class (_obj _class) 989 "Change the class of OBJ to type CLASS. 990This may create or delete slots, but does not affect the return value 991of `eq'." 992 (error "EIEIO: `change-class' is unimplemented")) 993(define-obsolete-function-alias 'change-class #'eieio-change-class "26.1") 994 995(provide 'eieio) 996 997;;; eieio.el ends here 998