1;;;; Common Lisp Object System for CLISP 2;;;; Class metaobjects 3;;;; Part n-1: Generic functions specified in the MOP. 4;;;; Bruno Haible 2004-05-25 5;;;; Sam Steingold 2005-2008, 2017 6 7(in-package "CLOS") 8 9;;; =========================================================================== 10 11;; Make creation of <defined-class> instances customizable. 12 13;; Installing the accessor methods can only be done after a class has been 14;; initialized, but must be done in a _primary_ initialize-instance method, 15;; so that it doesn't interfere with :after/:around methods that a user could 16;; install. See MOP p. 60. 17(defmethod initialize-instance ((class defined-class) &rest args) 18 (declare (ignore args)) 19 (call-next-method) ; == (apply #'shared-initialize class 't args) 20 (install-class-direct-accessors class) 21 class) 22 23(defmethod initialize-instance ((class structure-class) &rest args 24 &key ((defclass-form defclass-form)) 25 &allow-other-keys) 26 (if (eq defclass-form 'defstruct) ; called from DEFINE-STRUCTURE-CLASS 27 ;; we do not (CALL-NEXT-METHOD) because the 28 ;; INITIALIZE-INSTANCE@DEFINED-CLASS method calls 29 ;; INSTALL-CLASS-DIRECT-ACCESSORS which installs slot accessors 30 ;; immediately overwritten by the accessors defined by DEFSTRUCT 31 (apply #'shared-initialize class 't args) 32 (call-next-method)) ; initialize-instance@defined-class 33 class) 34 35(setf (fdefinition 'initialize-instance-<built-in-class>) #'initialize-instance) 36(setf (fdefinition 'make-instance-<built-in-class>) #'make-instance) 37(setf (fdefinition 'initialize-instance-<structure-class>) #'initialize-instance) 38(setf (fdefinition 'make-instance-<structure-class>) #'make-instance) 39(setf (fdefinition 'initialize-instance-<standard-class>) #'initialize-instance) 40(setf (fdefinition 'make-instance-<standard-class>) #'make-instance) 41(setf (fdefinition 'initialize-instance-<funcallable-standard-class>) #'initialize-instance) 42(setf (fdefinition 'make-instance-<funcallable-standard-class>) #'make-instance) 43 44;;; =========================================================================== 45 46;;; Optimized class-xxx accessors. 47;;; These are possible thanks to the :fixed-slot-locations class option. 48 49(defun check-class-initialized (class level) 50 (unless (>= (class-initialized class) level) 51 (error (TEXT "The class ~S has not yet been initialized.") 52 class))) 53 54(defun check-class-finalized (class level) 55 (check-class-initialized class 2) 56 (unless (>= (class-initialized class) level) 57 (error (TEXT "The class ~S has not yet been finalized.") 58 class))) 59 60;; Not in MOP. 61(defun class-classname (class) 62 (accessor-typecheck class 'potential-class 'class-classname) 63 (sys::%record-ref class *<potential-class>-classname-location*)) 64(defun (setf class-classname) (new-value class) 65 (accessor-typecheck class 'potential-class '(setf class-classname)) 66 (setf (sys::%record-ref class *<potential-class>-classname-location*) new-value)) 67;; MOP p. 76 68(defgeneric class-name (class) 69 (declare (dynamically-modifiable)) 70 (:method ((class defined-class)) 71 (check-class-initialized class 1) 72 (class-classname class)) 73 (:method ((class forward-reference-to-class)) 74 (slot-value class '$classname))) 75; No extended method check because this GF is specified in ANSI CL. 76;(initialize-extended-method-check #'class-name) 77;; MOP p. 92 78(defgeneric (setf class-name) (new-value class) 79 (declare (dynamically-modifiable)) 80 (:method (new-value (class potential-class)) 81 (unless (symbolp new-value) 82 (error-of-type 'type-error 83 :datum new-value :expected-type 'symbol 84 (TEXT "~S: The name of a class must be a symbol, not ~S") 85 '(setf class-name) new-value)) 86 (when (built-in-class-p class) 87 (error-of-type 'error 88 (TEXT "~S: The name of the built-in class ~S cannot be modified") 89 '(setf class-name) class)) 90 (reinitialize-instance class :name new-value) 91 new-value)) 92(initialize-extended-method-check #'(setf class-name)) 93 94;; Not in MOP. 95(defun class-direct-subclasses-table (class) 96 (accessor-typecheck class 'super-class 'class-direct-subclasses-table) 97 (if (potential-class-p class) 98 (sys::%record-ref class *<potential-class>-direct-subclasses-location*) 99 (slot-value class '$direct-subclasses))) 100(defun (setf class-direct-subclasses-table) (new-value class) 101 (accessor-typecheck class 'super-class '(setf class-direct-subclasses-table)) 102 (if (potential-class-p class) 103 (setf (sys::%record-ref class *<potential-class>-direct-subclasses-location*) new-value) 104 (setf (slot-value class '$direct-subclasses) new-value))) 105;; MOP p. 76 106(defgeneric class-direct-subclasses (class) 107 (declare (dynamically-modifiable)) 108 (:method ((class defined-class)) 109 (check-class-initialized class 2) 110 (list-direct-subclasses class)) 111 (:method ((class forward-reference-to-class)) 112 (list-direct-subclasses class))) 113 114(defun class-not-yet-defined (method class) 115 (clos-warning (TEXT "~S being called on ~S, but class ~S is not yet defined.") 116 method class (class-name class))) 117 118;; MOP p. 76 119(defgeneric class-direct-superclasses (class) 120 (declare (dynamically-modifiable)) 121 (:method ((class defined-class)) 122 (check-class-initialized class 2) 123 (sys::%record-ref class *<defined-class>-direct-superclasses-location*)) 124 (:method ((class forward-reference-to-class)) 125 ;; Broken MOP. Any use of this method is a bug. 126 (class-not-yet-defined 'class-direct-superclasses class) 127 '())) 128(initialize-extended-method-check #'class-direct-superclasses) 129;; Not in MOP. 130(defun (setf class-direct-superclasses) (new-value class) 131 (accessor-typecheck class 'defined-class '(setf class-direct-superclasses)) 132 (setf (sys::%record-ref class *<defined-class>-direct-superclasses-location*) new-value)) 133 134;; Not in MOP. 135(defun class-all-superclasses (class) 136 (accessor-typecheck class 'defined-class 'class-all-superclasses) 137 (sys::%record-ref class *<defined-class>-all-superclasses-location*)) 138(defun (setf class-all-superclasses) (new-value class) 139 (accessor-typecheck class 'defined-class '(setf class-all-superclasses)) 140 (setf (sys::%record-ref class *<defined-class>-all-superclasses-location*) new-value)) 141 142;; MOP p. 76 143(defgeneric class-precedence-list (class) 144 (:method ((class defined-class)) 145 (check-class-finalized class 3) 146 (sys::%record-ref class *<defined-class>-precedence-list-location*))) 147(initialize-extended-method-check #'class-precedence-list) 148;; Not in MOP. 149(defun (setf class-precedence-list) (new-value class) 150 (accessor-typecheck class 'defined-class '(setf class-precedence-list)) 151 (setf (sys::%record-ref class *<defined-class>-precedence-list-location*) new-value)) 152 153;; MOP p. 75 154(defgeneric class-direct-slots (class) 155 (:method ((class defined-class)) 156 (check-class-initialized class 2) 157 (sys::%record-ref class *<defined-class>-direct-slots-location*)) 158 (:method ((class forward-reference-to-class)) 159 ;; Broken MOP. Any use of this method is a bug. 160 (class-not-yet-defined 'class-direct-slots class) 161 '())) 162(initialize-extended-method-check #'class-direct-slots) 163;; Not in MOP. 164(defun (setf class-direct-slots) (new-value class) 165 (accessor-typecheck class 'defined-class '(setf class-direct-slots)) 166 (setf (sys::%record-ref class *<defined-class>-direct-slots-location*) new-value)) 167 168;; MOP p. 77 169(defgeneric class-slots (class) 170 (:method ((class defined-class)) 171 (check-class-finalized class 5) 172 (sys::%record-ref class *<defined-class>-slots-location*))) 173(initialize-extended-method-check #'class-slots) 174;; Not in MOP. 175(defun (setf class-slots) (new-value class) 176 (accessor-typecheck class 'defined-class '(setf class-slots)) 177 (setf (sys::%record-ref class *<defined-class>-slots-location*) new-value)) 178 179;; Not in MOP. 180(defun class-slot-location-table (class) 181 (accessor-typecheck class 'defined-class 'class-slot-location-table) 182 (sys::%record-ref class *<defined-class>-slot-location-table-location*)) 183(defun (setf class-slot-location-table) (new-value class) 184 (accessor-typecheck class 'defined-class '(setf class-slot-location-table)) 185 (setf (sys::%record-ref class *<defined-class>-slot-location-table-location*) new-value)) 186 187;; MOP p. 75 188(defgeneric class-direct-default-initargs (class) 189 (:method ((class defined-class)) 190 (check-class-initialized class 2) 191 (sys::%record-ref class *<defined-class>-direct-default-initargs-location*)) 192 (:method ((class forward-reference-to-class)) 193 ;; Broken MOP. Any use of this method is a bug. 194 (class-not-yet-defined 'class-direct-default-initargs class) 195 '())) 196(initialize-extended-method-check #'class-direct-default-initargs) 197;; Not in MOP. 198(defun (setf class-direct-default-initargs) (new-value class) 199 (accessor-typecheck class 'defined-class '(setf class-direct-default-initargs)) 200 (setf (sys::%record-ref class *<defined-class>-direct-default-initargs-location*) new-value)) 201 202;; MOP p. 75 203(defgeneric class-default-initargs (class) 204 (:method ((class defined-class)) 205 (check-class-finalized class 6) 206 (sys::%record-ref class *<defined-class>-default-initargs-location*))) 207(initialize-extended-method-check #'class-default-initargs) 208;; Not in MOP. 209(defun (setf class-default-initargs) (new-value class) 210 (accessor-typecheck class 'defined-class '(setf class-default-initargs)) 211 (setf (sys::%record-ref class *<defined-class>-default-initargs-location*) new-value)) 212 213;; Not in MOP. 214(defun class-documentation (class) 215 (accessor-typecheck class 'defined-class 'class-documentation) 216 (sys::%record-ref class *<defined-class>-documentation-location*)) 217(defun (setf class-documentation) (new-value class) 218 (accessor-typecheck class 'defined-class '(setf class-documentation)) 219 (setf (sys::%record-ref class *<defined-class>-documentation-location*) new-value)) 220 221;; Not in MOP. 222(defun class-listeners (class) 223 (accessor-typecheck class 'defined-class 'class-listeners) 224 (sys::%record-ref class *<defined-class>-listeners-location*)) 225(defun (setf class-listeners) (new-value class) 226 (accessor-typecheck class 'defined-class '(setf class-listeners)) 227 (setf (sys::%record-ref class *<defined-class>-listeners-location*) new-value)) 228 229;; Not in MOP. 230(defun class-initialized (class) 231 (accessor-typecheck class 'defined-class 'class-initialized) 232 (sys::%record-ref class *<defined-class>-initialized-location*)) 233(defun (setf class-initialized) (new-value class) 234 (accessor-typecheck class 'defined-class '(setf class-initialized)) 235 (setf (sys::%record-ref class *<defined-class>-initialized-location*) new-value)) 236 237;; Not in MOP. 238(defun class-subclass-of-stablehash-p (class) 239 (accessor-typecheck class 'slotted-class 'class-subclass-of-stablehash-p) 240 (sys::%record-ref class *<slotted-class>-subclass-of-stablehash-p-location*)) 241(defun (setf class-subclass-of-stablehash-p) (new-value class) 242 (accessor-typecheck class 'slotted-class '(setf class-subclass-of-stablehash-p)) 243 (setf (sys::%record-ref class *<slotted-class>-subclass-of-stablehash-p-location*) new-value)) 244 245;; Not in MOP. 246(defun class-generic-accessors (class) 247 (accessor-typecheck class 'slotted-class 'class-generic-accessors) 248 (sys::%record-ref class *<slotted-class>-generic-accessors-location*)) 249(defun (setf class-generic-accessors) (new-value class) 250 (accessor-typecheck class 'slotted-class '(setf class-generic-accessors)) 251 (setf (sys::%record-ref class *<slotted-class>-generic-accessors-location*) new-value)) 252 253;; Not in MOP. 254(defun class-direct-accessors (class) 255 (accessor-typecheck class 'slotted-class 'class-direct-accessors) 256 (sys::%record-ref class *<slotted-class>-direct-accessors-location*)) 257(defun (setf class-direct-accessors) (new-value class) 258 (accessor-typecheck class 'slotted-class '(setf class-direct-accessors)) 259 (setf (sys::%record-ref class *<slotted-class>-direct-accessors-location*) new-value)) 260 261;; Not in MOP. 262(defun class-valid-initargs-from-slots (class) 263 (accessor-typecheck class 'slotted-class 'class-valid-initargs-from-slots) 264 (sys::%record-ref class *<slotted-class>-valid-initargs-from-slots-location*)) 265(defun (setf class-valid-initargs-from-slots) (new-value class) 266 (accessor-typecheck class 'slotted-class '(setf class-valid-initargs-from-slots)) 267 ;; When the valid-initargs-from-slots change, the result of 268 ;; (valid-initarg-keywords class ...) changes, therefore we need to invalidate 269 ;; all the caches that use valid-initarg-keywords: 270 (when (or (eq (sys::%unbound) (sys::%record-ref class *<slotted-class>-valid-initargs-from-slots-location*)) 271 (set-exclusive-or (sys::%record-ref class *<slotted-class>-valid-initargs-from-slots-location*) new-value)) 272 (remhash class *make-instance-table*) 273 (remhash class *reinitialize-instance-table*) 274 (remhash class *update-instance-for-redefined-class-table*) 275 (remhash class *update-instance-for-different-class-table*)) 276 (setf (sys::%record-ref class *<slotted-class>-valid-initargs-from-slots-location*) new-value)) 277 278;; Not in MOP. 279(defun class-instance-size (class) 280 (accessor-typecheck class 'slotted-class 'class-instance-size) 281 (sys::%record-ref class *<slotted-class>-instance-size-location*)) 282(defun (setf class-instance-size) (new-value class) 283 (accessor-typecheck class 'slotted-class '(setf class-instance-size)) 284 (setf (sys::%record-ref class *<slotted-class>-instance-size-location*) new-value)) 285 286;; Not in MOP. 287(defun class-names (class) 288 (accessor-typecheck class 'structure-class 'class-names) 289 (sys::%record-ref class *<structure-class>-names-location*)) 290(defun (setf class-names) (new-value class) 291 (accessor-typecheck class 'structure-class '(setf class-names)) 292 (setf (sys::%record-ref class *<structure-class>-names-location*) new-value)) 293 294;; Not in MOP. 295(defun class-kconstructor (class) 296 (accessor-typecheck class 'structure-class 'class-kconstructor) 297 (sys::%record-ref class *<structure-class>-kconstructor-location*)) 298(defun (setf class-kconstructor) (new-value class) 299 (accessor-typecheck class 'structure-class '(setf class-kconstructor)) 300 (setf (sys::%record-ref class *<structure-class>-kconstructor-location*) new-value)) 301 302;; Not in MOP. 303(defun class-boa-constructors (class) 304 (accessor-typecheck class 'structure-class 'class-boa-constructors) 305 (sys::%record-ref class *<structure-class>-boa-constructors-location*)) 306(defun (setf class-boa-constructors) (new-value class) 307 (accessor-typecheck class 'structure-class '(setf class-boa-constructors)) 308 (setf (sys::%record-ref class *<structure-class>-boa-constructors-location*) new-value)) 309 310;; Not in MOP. 311(defun class-copier (class) 312 (accessor-typecheck class 'structure-class 'class-copier) 313 (sys::%record-ref class *<structure-class>-copier-location*)) 314(defun (setf class-copier) (new-value class) 315 (accessor-typecheck class 'structure-class '(setf class-copier)) 316 (setf (sys::%record-ref class *<structure-class>-copier-location*) new-value)) 317 318;; Not in MOP. 319(defun class-predicate (class) 320 (accessor-typecheck class 'structure-class 'class-predicate) 321 (sys::%record-ref class *<structure-class>-predicate-location*)) 322(defun (setf class-predicate) (new-value class) 323 (accessor-typecheck class 'structure-class '(setf class-predicate)) 324 (setf (sys::%record-ref class *<structure-class>-predicate-location*) new-value)) 325 326;; Not in MOP. 327(defun class-current-version (class) 328 (accessor-typecheck class 'semi-standard-class 'class-current-version) 329 (sys::%record-ref class *<semi-standard-class>-current-version-location*)) 330(defun (setf class-current-version) (new-value class) 331 (accessor-typecheck class 'semi-standard-class '(setf class-current-version)) 332 (setf (sys::%record-ref class *<semi-standard-class>-current-version-location*) new-value)) 333 334;; Not in MOP. 335(defun class-funcallablep (class) 336 (accessor-typecheck class 'semi-standard-class 'class-funcallablep) 337 (sys::%record-ref class *<semi-standard-class>-funcallablep-location*)) 338(defun (setf class-funcallablep) (new-value class) 339 (accessor-typecheck class 'semi-standard-class '(setf class-funcallablep)) 340 (setf (sys::%record-ref class *<semi-standard-class>-funcallablep-location*) new-value)) 341 342;; Not in MOP. 343(defun class-fixed-slot-locations (class) 344 (accessor-typecheck class 'semi-standard-class 'class-fixed-slot-locations) 345 (sys::%record-ref class *<semi-standard-class>-fixed-slot-locations-location*)) 346(defun (setf class-fixed-slot-locations) (new-value class) 347 (accessor-typecheck class 'semi-standard-class '(setf class-fixed-slot-locations)) 348 (setf (sys::%record-ref class *<semi-standard-class>-fixed-slot-locations-location*) new-value)) 349 350;; Not in MOP. 351(defun class-instantiated (class) 352 (accessor-typecheck class 'semi-standard-class 'class-instantiated) 353 (sys::%record-ref class *<semi-standard-class>-instantiated-location*)) 354(defun (setf class-instantiated) (new-value class) 355 (accessor-typecheck class 'semi-standard-class '(setf class-instantiated)) 356 (setf (sys::%record-ref class *<semi-standard-class>-instantiated-location*) new-value)) 357 358;; Not in MOP. 359(defun class-direct-instance-specializers-table (class) 360 (accessor-typecheck class 'semi-standard-class 'class-direct-instance-specializers-table) 361 (sys::%record-ref class *<semi-standard-class>-direct-instance-specializers-location*)) 362(defun (setf class-direct-instance-specializers-table) (new-value class) 363 (accessor-typecheck class 'semi-standard-class '(setf class-direct-instance-specializers-table)) 364 (setf (sys::%record-ref class *<semi-standard-class>-direct-instance-specializers-location*) new-value)) 365 366;; Not in MOP. 367(defun class-finalized-direct-subclasses-table (class) 368 (accessor-typecheck class 'semi-standard-class 'class-finalized-direct-subclasses-table) 369 (sys::%record-ref class *<semi-standard-class>-finalized-direct-subclasses-location*)) 370(defun (setf class-finalized-direct-subclasses-table) (new-value class) 371 (accessor-typecheck class 'semi-standard-class '(setf class-finalized-direct-subclasses-table)) 372 (setf (sys::%record-ref class *<semi-standard-class>-finalized-direct-subclasses-location*) new-value)) 373 374;; MOP p. 77 375(defgeneric class-prototype (class) 376 (:method ((class semi-standard-class)) 377 (check-class-finalized class 6) 378 (or (sys::%record-ref class *<semi-standard-class>-prototype-location*) 379 (setf (sys::%record-ref class *<semi-standard-class>-prototype-location*) 380 (let ((old-instantiated (class-instantiated class))) 381 (prog1 382 (clos::%allocate-instance class) 383 ;; The allocation of the prototype doesn't need to flag the 384 ;; class as being instantiated, because 1. the prototype is 385 ;; thrown away when the class is redefined, 2. we don't want 386 ;; a redefinition with nonexistent or non-finalized 387 ;; superclasses to succeed despite of the prototype. 388 (setf (class-instantiated class) old-instantiated)))))) 389 (:method ((class built-in-class)) 390 (let ((prototype (sys::%record-ref class *<built-in-class>-prototype-location*))) 391 (if (eq (sys::%unbound) prototype) 392 (error (TEXT "~S: ~S is an abstract class and therefore does not have a direct instance") 393 'class-prototype class) 394 prototype))) 395 ;; CLISP extension: 396 (:method ((class structure-class)) 397 (or (sys::%record-ref class *<structure-class>-prototype-location*) 398 (setf (sys::%record-ref class *<structure-class>-prototype-location*) 399 (clos::%allocate-instance class))))) 400(initialize-extended-method-check #'class-prototype) 401;; Not in MOP. 402(defun (setf class-prototype) (new-value class) 403 (accessor-typecheck class 'semi-standard-class '(setf class-prototype)) 404 (setf (sys::%record-ref class *<semi-standard-class>-prototype-location*) new-value)) 405 406;;; =========================================================================== 407 408;;; Class Specification Protocol 409 410;; Not in MOP. 411(defgeneric compute-direct-slot-definition-initargs (class &rest slot-spec) 412 (declare (dynamically-modifiable)) 413 (:method ((class defined-class) &rest slot-spec) 414 slot-spec)) 415 416;;; =========================================================================== 417 418;;; Class Finalization Protocol 419 420;; MOP p. 76 421(defgeneric class-finalized-p (class) 422 (:method ((class defined-class)) 423 (= (class-initialized class) 6)) 424 (:method ((class forward-reference-to-class)) 425 nil) 426 ;; CLISP extension: Convenience method on symbols. 427 (:method ((name symbol)) 428 (class-finalized-p (find-class name)))) 429(initialize-extended-method-check #'class-finalized-p) 430 431;; MOP p. 54 432(defgeneric finalize-inheritance (class) 433 (:method ((class semi-standard-class)) 434 (finalize-inheritance-<semi-standard-class> class)) 435 ;; CLISP extension: No-op method on other classes. 436 (:method ((class defined-class)) 437 class) 438 ;; CLISP extension: Convenience method on symbols. 439 (:method ((name symbol)) 440 (finalize-inheritance (find-class name)))) 441(initialize-extended-method-check #'finalize-inheritance) 442 443;; MOP p. 38 444(defgeneric compute-class-precedence-list (class) 445 (declare (dynamically-modifiable)) 446 (:method ((class defined-class)) 447 (compute-class-precedence-list-<defined-class> class))) 448 449;; Not in MOP. 450(defgeneric compute-effective-slot-definition-initargs (class direct-slot-definitions) 451 (declare (dynamically-modifiable)) 452 (:method ((class defined-class) direct-slot-definitions) 453 (compute-effective-slot-definition-initargs-<defined-class> class direct-slot-definitions))) 454 455;; MOP p. 42 456(defgeneric compute-effective-slot-definition (class slotname direct-slot-definitions) 457 (declare (dynamically-modifiable)) 458 (:method ((class defined-class) slotname direct-slot-definitions) 459 (compute-effective-slot-definition-<defined-class> class slotname direct-slot-definitions))) 460 461;; MOP p. 43 462(defgeneric compute-slots (class) 463 (declare (dynamically-modifiable)) 464 (:method ((class semi-standard-class)) 465 (compute-slots-<defined-class>-primary class)) 466 (:method :around ((class semi-standard-class)) 467 (compute-slots-<slotted-class>-around class 468 #'(lambda (c) (call-next-method c))))) 469 470;; MOP p. 39 471(defgeneric compute-default-initargs (class) 472 (declare (dynamically-modifiable)) 473 (:method ((class defined-class)) 474 (compute-default-initargs-<defined-class> class))) 475 476;;; =========================================================================== 477 478;;; Class definition customization 479 480;; MOP p. 47 481(defgeneric ensure-class-using-class (class name 482 &key metaclass 483 direct-superclasses 484 direct-slots 485 direct-default-initargs 486 documentation 487 ; CLISP specific extension: 488 fixed-slot-locations 489 &allow-other-keys) 490 (declare (dynamically-modifiable)) 491 (:method ((class potential-class) name &rest args) 492 (apply #'ensure-class-using-class-<t> class name args)) 493 (:method ((class null) name &rest args) 494 (apply #'ensure-class-using-class-<t> class name args))) 495 496;; MOP p. 102 497(defgeneric validate-superclass (class superclass) 498 (declare (dynamically-modifiable)) 499 (:method ((class potential-class) (superclass potential-class)) 500 (or (eq superclass <t>) 501 (eq (class-of class) (class-of superclass)) 502 (and (eq (class-of class) <funcallable-standard-class>) 503 (eq (class-of superclass) <standard-class>)) 504 ;; This makes no sense: If the superclass is a 505 ;; funcallable-standard-class, it is a subclass of FUNCTION, 506 ;; therefore class will become a subclass of FUNCTION too, but there 507 ;; is no way to FUNCALL or APPLY it. Where did the MOP authors have 508 ;; their brain here? 509 (and (eq (class-of class) <standard-class>) 510 (eq (class-of superclass) <funcallable-standard-class>)) 511 ;; Needed for clos-genfun1.lisp: 512 (and (eq superclass <function>) 513 (eq (class-classname class) 'funcallable-standard-object)) 514 ;; CLISP specific extension: 515 (subclassp (class-of class) (class-of superclass))))) 516 517;;; =========================================================================== 518 519;;; Subclass relationship change notification 520 521;; MOP p. 32 522(defgeneric add-direct-subclass (class subclass) 523 (declare (dynamically-modifiable)) 524 (:method ((class super-class) (subclass potential-class)) 525 (add-direct-subclass-internal class subclass))) 526 527;; MOP p. 90 528(defgeneric remove-direct-subclass (class subclass) 529 (declare (dynamically-modifiable)) 530 (:method ((class super-class) (subclass potential-class)) 531 (remove-direct-subclass-internal class subclass))) 532 533;;; =========================================================================== 534 535;;; Accessor definition customization 536 537;; MOP p. 86 538(defgeneric reader-method-class (class direct-slot &rest initargs) 539 (declare (dynamically-modifiable)) 540 (:method ((class defined-class) direct-slot &rest initargs) 541 (declare (ignore direct-slot initargs)) 542 <standard-reader-method>)) 543 544;; MOP p. 103 545(defgeneric writer-method-class (class direct-slot &rest initargs) 546 (declare (dynamically-modifiable)) 547 (:method ((class defined-class) direct-slot &rest initargs) 548 (declare (ignore direct-slot initargs)) 549 <standard-writer-method>)) 550