1;;;; Common Lisp Object System for CLISP 2;;;; Class metaobjects 3;;;; Part 3: Class definition and redefinition. 4;;;; Bruno Haible 21.8.1993 - 2004 5;;;; Sam Steingold 1998 - 2010 6;;;; German comments translated into English: Stefan Kain 2002-04-08 7 8(in-package "CLOS") 9 10 11;; Wipe out all traces of an earlier loaded CLOS. 12(eval-when (load eval) 13 (do-all-symbols (s) (remprop s 'CLOSCLASS))) 14 15;; CLtL2 28.1.4., ANSI CL 4.3.7. Integrating Types and Classes 16(defun subclassp (class1 class2) 17 (unless (>= (class-initialized class1) 4) (finalize-inheritance class1)) 18 (values 19 (gethash class2 (class-all-superclasses class1)))) ; T or (default) NIL 20 21;; Continue bootstrapping. 22(%defclos 23 ;; distinctive marks for CLASS-P 24 *<standard-class>-class-version* 25 *<structure-class>-class-version* 26 *<built-in-class>-class-version* 27 'defined-class 28 'class 29 ;; built-in-classes for CLASS-OF - order in sync with constobj.d 30 (vector 'array 'bit-vector 'character 'complex 'cons 'float 'function 31 'hash-table 'integer 'list 'null 'package 'pathname 32 #+LOGICAL-PATHNAMES 'logical-pathname 33 'random-state 'ratio 'readtable 34 'stream 'file-stream 'synonym-stream 'broadcast-stream 35 'concatenated-stream 'two-way-stream 'echo-stream 'string-stream 36 'string 'symbol 't 'vector)) 37 38;; Bootstrapping support. 39(defun replace-class-version (class class-version) 40 (replace class-version (class-current-version class)) 41 (setf (class-current-version class) class-version)) 42 43;;; -------------------------------- DEFCLASS -------------------------------- 44 45(defmacro defclass (&whole whole-form 46 name superclass-specs slot-specs &rest options) 47 (setq name (sys::check-not-declaration name 'defclass)) 48 (let* ((superclass-forms 49 (progn 50 (unless (listp superclass-specs) 51 (error-of-type 'ext:source-program-error 52 :form whole-form 53 :detail superclass-specs 54 (TEXT "~S ~S: expecting list of superclasses instead of ~S") 55 'defclass name superclass-specs)) 56 (mapcar #'(lambda (superclass) 57 (unless (symbolp superclass) 58 (error-of-type 'ext:source-program-error 59 :form whole-form 60 :detail superclass 61 (TEXT "~S ~S: superclass name ~S should be a symbol") 62 'defclass name superclass)) 63 `',superclass) 64 superclass-specs))) 65 (accessor-method-decl-forms '()) 66 (accessor-function-decl-forms '()) 67 (generic-accessors nil) (generic-accessors-arg 'T) 68 (slot-forms 69 (let ((slot-names '())) 70 (unless (listp slot-specs) 71 (error-of-type 'ext:source-program-error 72 :form whole-form 73 :detail slot-specs 74 (TEXT "~S ~S: expecting list of slot specifications instead of ~S") 75 'defclass name slot-specs)) 76 (when (and (oddp (length slot-specs)) (cdr slot-specs) 77 (do ((l (cdr slot-specs) (cddr l))) 78 ((endp l) t) 79 (unless (keywordp (car l)) 80 (return nil)))) 81 ;; Typical beginner error: Omission of the parentheses around the 82 ;; slot-specs. Probably someone who knows DEFSTRUCT and uses 83 ;; DEFCLASS for the first time. 84 (clos-warn 'simple-clos-novice-warning (TEXT "~S ~S: Every second slot name is a keyword, and these slots have no options. If you want to define a slot with options, you need to enclose all slot specifications in parentheses: ~S, not ~S.") 85 'defclass name (list slot-specs) slot-specs)) 86 (mapcar #'(lambda (slot-spec) 87 (let ((slot-name slot-spec) (slot-options '())) 88 (when (consp slot-spec) 89 (setq slot-name (car slot-spec) 90 slot-options (cdr slot-spec))) 91 (unless (symbolp slot-name) 92 (error-of-type 'ext:source-program-error 93 :form whole-form 94 :detail slot-name 95 (TEXT "~S ~S: slot name ~S should be a symbol") 96 'defclass name slot-name)) 97 (if (memq slot-name slot-names) 98 (error-of-type 'ext:source-program-error 99 :form whole-form 100 :detail slot-names 101 (TEXT "~S ~S: There may be only one direct slot with the name ~S.") 102 'defclass name slot-name) 103 (push slot-name slot-names)) 104 (let ((readers '()) 105 (writers '()) 106 (allocations '()) 107 (initargs '()) 108 (initform nil) (initfunction nil) 109 (types '()) 110 (documentation nil) 111 (user-defined-args nil)) 112 (when (oddp (length slot-options)) 113 (error-of-type 'ext:source-program-error 114 :form whole-form 115 :detail slot-options 116 (TEXT "~S ~S: slot options for slot ~S must come in pairs") 117 'defclass name slot-name)) 118 (do ((optionsr slot-options (cddr optionsr))) 119 ((atom optionsr)) 120 (let ((optionkey (first optionsr)) 121 (argument (second optionsr))) 122 (case optionkey 123 (:READER 124 (unless (and (symbolp argument) argument) 125 (error-of-type 'ext:source-program-error 126 :form whole-form 127 :detail argument 128 (TEXT "~S ~S, slot option for slot ~S: ~S is not a non-NIL symbol") 129 'defclass name slot-name argument)) 130 (push argument readers)) 131 (:WRITER 132 (unless (function-name-p argument) 133 (error-of-type 'ext:source-program-error 134 :form whole-form 135 :detail argument 136 (TEXT "~S ~S, slot option for slot ~S: ~S is not a function name") 137 'defclass name slot-name argument)) 138 (push argument writers)) 139 (:ACCESSOR 140 (unless (and (symbolp argument) argument) 141 (error-of-type 'ext:source-program-error 142 :form whole-form 143 :detail argument 144 (TEXT "~S ~S, slot option for slot ~S: ~S is not a non-NIL symbol") 145 'defclass name slot-name argument)) 146 (push argument readers) 147 (push `(SETF ,argument) writers)) 148 (:ALLOCATION 149 (unless (symbolp argument) 150 (error-of-type 'ext:source-program-error 151 :form whole-form 152 :detail argument 153 (TEXT "~S ~S, slot option ~S for slot ~S: ~S is not a symbol") 154 'defclass name ':allocation slot-name argument)) 155 (when allocations 156 (error-of-type 'ext:source-program-error 157 :form whole-form 158 :detail slot-options 159 (TEXT "~S ~S, slot option ~S for slot ~S may only be given once") 160 'defclass name ':allocation slot-name)) 161 (setq allocations (list argument))) 162 (:INITARG 163 (unless (symbolp argument) 164 (error-of-type 'ext:source-program-error 165 :form whole-form 166 :detail argument 167 (TEXT "~S ~S, slot option for slot ~S: ~S is not a symbol") 168 'defclass name slot-name argument)) 169 (push argument initargs)) 170 (:INITFORM 171 (when initform 172 (error-of-type 'ext:source-program-error 173 :form whole-form 174 :detail slot-options 175 (TEXT "~S ~S, slot option ~S for slot ~S may only be given once") 176 'defclass name ':initform slot-name)) 177 (setq initform `(QUOTE ,argument) 178 initfunction (make-initfunction-form argument slot-name))) 179 (:TYPE 180 (when types 181 (error-of-type 'ext:source-program-error 182 :form whole-form 183 :detail slot-options 184 (TEXT "~S ~S, slot option ~S for slot ~S may only be given once") 185 'defclass name ':type slot-name)) 186 (setq types (list argument))) 187 (:DOCUMENTATION 188 (when documentation 189 (error-of-type 'ext:source-program-error 190 :form whole-form 191 :detail slot-options 192 (TEXT "~S ~S, slot option ~S for slot ~S may only be given once") 193 'defclass name ':documentation slot-name)) 194 (unless (stringp argument) 195 (error-of-type 'ext:source-program-error 196 :form whole-form 197 :detail argument 198 (TEXT "~S ~S, slot option for slot ~S: ~S is not a string") 199 'defclass name slot-name argument)) 200 (setq documentation argument)) 201 ((:NAME :READERS :WRITERS :INITARGS :INITFUNCTION) 202 ;; These are valid initialization keywords for 203 ;; <direct-slot-definition>, but nevertheless 204 ;; not valid DEFCLASS slot options. 205 (error-of-type 'ext:source-program-error 206 :form whole-form 207 :detail optionkey 208 (TEXT "~S ~S, slot option for slot ~S: ~S is not a valid slot option") 209 'defclass name slot-name optionkey)) 210 (t 211 (if (symbolp optionkey) 212 (let ((acons (assoc optionkey user-defined-args))) 213 (if acons 214 (push argument (cdr acons)) 215 (push (list optionkey argument) user-defined-args))) 216 (error-of-type 'ext:source-program-error 217 :form whole-form 218 :detail optionkey 219 (TEXT "~S ~S, slot option for slot ~S: ~S is not a valid slot option") 220 'defclass name slot-name optionkey)))))) 221 (setq readers (nreverse readers)) 222 (setq writers (nreverse writers)) 223 (setq user-defined-args (nreverse user-defined-args)) 224 (let ((type (if types (first types) 'T))) 225 (dolist (funname readers) 226 (push `(DECLAIM-METHOD ,funname ((OBJECT ,name))) 227 accessor-method-decl-forms) 228 (push `(PROCLAIM '(FUNCTION ,funname (,name) ,type)) 229 accessor-function-decl-forms) 230 (push `(SYSTEM::EVAL-WHEN-COMPILE (SYSTEM::C-DEFUN ',funname (SYSTEM::LAMBDA-LIST-TO-SIGNATURE '(OBJECT)))) 231 accessor-function-decl-forms)) 232 (dolist (funname writers) 233 (push `(DECLAIM-METHOD ,funname (NEW-VALUE (OBJECT ,name))) 234 accessor-method-decl-forms) 235 (push `(PROCLAIM '(FUNCTION ,funname (,type ,name) ,type)) 236 accessor-function-decl-forms) 237 (push `(SYSTEM::EVAL-WHEN-COMPILE (SYSTEM::C-DEFUN ',funname (SYSTEM::LAMBDA-LIST-TO-SIGNATURE '(NEW-VALUE OBJECT)))) 238 accessor-function-decl-forms))) 239 `(LIST 240 :NAME ',slot-name 241 ,@(when readers `(:READERS ',readers)) 242 ,@(when writers `(:WRITERS ',writers)) 243 ,@(when allocations `(:ALLOCATION ',(first allocations))) 244 ,@(when initargs `(:INITARGS ',(nreverse initargs))) 245 ,@(when initform `(:INITFORM ,initform :INITFUNCTION ,initfunction)) 246 ,@(when types `(:TYPE ',(first types))) 247 ,@(when documentation `(:DOCUMENTATION ',documentation)) 248 ,@(when user-defined-args 249 ;; For error-checking purposes: 250 `('DEFCLASS-FORM ',whole-form)) 251 ,@(mapcan #'(lambda (option) 252 (list `',(car option) 253 ;; If there are multiple occurrences 254 ;; of the same option, the values are 255 ;; passed as a list. Otherwise a single 256 ;; value is passed (not a 1-element list)! 257 `',(if (cddr option) 258 (nreverse (cdr option)) 259 (cadr option)))) 260 user-defined-args))))) 261 slot-specs))) 262 (metaclass nil) (metaclass-arg nil) 263 (direct-default-initargs nil) 264 (documentation nil) 265 (user-defined-args nil)) 266 (dolist (option options) 267 (block nil 268 (when (listp option) 269 (let ((optionkey (first option))) 270 (when (case optionkey 271 (:METACLASS metaclass) 272 (:DEFAULT-INITARGS direct-default-initargs) 273 (:DOCUMENTATION documentation)) 274 (error-of-type 'ext:source-program-error 275 :form whole-form 276 :detail options 277 (TEXT "~S ~S: option ~S may only be given once") 278 'defclass name optionkey)) 279 (case optionkey 280 (:METACLASS 281 (when (eql (length option) 2) 282 (let ((argument (second option))) 283 (unless (symbolp argument) 284 (error-of-type 'ext:source-program-error 285 :form whole-form 286 :detail argument 287 (TEXT "~S ~S, option ~S: ~S is not a symbol") 288 'defclass name option argument)) 289 (setq metaclass-arg argument) 290 (setq metaclass `(FIND-CLASS ',argument))) 291 (return))) 292 (:DEFAULT-INITARGS 293 (let ((list (rest option))) 294 (when (oddp (length list)) 295 (error-of-type 'ext:source-program-error 296 :form whole-form 297 :detail list 298 (TEXT "~S ~S, option ~S: arguments must come in pairs") 299 'defclass name option)) 300 (setq direct-default-initargs 301 `(:DIRECT-DEFAULT-INITARGS 302 (LIST 303 ,@(let ((arglist nil) (formlist nil)) 304 (do ((listr list (cddr listr))) 305 ((atom listr)) 306 (unless (symbolp (first listr)) 307 (error-of-type 'ext:source-program-error 308 :form whole-form 309 :detail (first listr) 310 (TEXT "~S ~S, option ~S: ~S is not a symbol") 311 'defclass name option (first listr))) 312 (when (member (first listr) arglist) 313 (error-of-type 'ext:source-program-error 314 :form whole-form 315 :detail list 316 (TEXT "~S ~S, option ~S: ~S may only be given once") 317 'defclass name option (first listr))) 318 (push (first listr) arglist) 319 (push (second listr) formlist)) 320 (mapcan #'(lambda (arg form) 321 `((LIST ',arg ',form ,(make-initfunction-form form arg)))) 322 (nreverse arglist) (nreverse formlist))))))) 323 (return)) 324 (:DOCUMENTATION 325 (when (eql (length option) 2) 326 (let ((argument (second option))) 327 (unless (stringp argument) 328 (error-of-type 'ext:source-program-error 329 :form whole-form 330 :detail argument 331 (TEXT "~S ~S, option ~S: ~S is not a string") 332 'defclass name option argument)) 333 (setq documentation 334 `(:DOCUMENTATION ',argument))) 335 (return))) 336 ((:NAME :DIRECT-SUPERCLASSES :DIRECT-SLOTS :DIRECT-DEFAULT-INITARGS) 337 ;; These are valid initialization keywords for <defined-class>, 338 ;; but nevertheless not valid DEFCLASS options. 339 (error-of-type 'ext:source-program-error 340 :form whole-form 341 :detail option 342 (TEXT "~S ~S: invalid option ~S") 343 'defclass name option)) 344 (:GENERIC-ACCESSORS 345 (when (eql (length option) 2) 346 (let ((argument (second option))) 347 (setq generic-accessors-arg argument) 348 (setq generic-accessors `(:GENERIC-ACCESSORS ',argument)) 349 (return)))) 350 (T 351 (when (symbolp optionkey) 352 (when (assoc optionkey user-defined-args) 353 (error-of-type 'ext:source-program-error 354 :form whole-form 355 :detail options 356 (TEXT "~S ~S: option ~S may only be given once") 357 'defclass name optionkey)) 358 (push option user-defined-args) 359 (return)))))) 360 (error-of-type 'ext:source-program-error 361 :form whole-form 362 :detail option 363 (TEXT "~S ~S: invalid option ~S") 364 'defclass name option))) 365 (setq user-defined-args (nreverse user-defined-args)) 366 (let ((metaclass-var (gensym)) 367 (metaclass-keywords-var (gensym))) 368 `(LET () 369 (EVAL-WHEN (COMPILE LOAD EVAL) 370 (LET* ((,metaclass-var ,(or metaclass '<STANDARD-CLASS>)) 371 ,@(if user-defined-args 372 `((,metaclass-keywords-var 373 ,(cond ((or (null metaclass) (eq metaclass-arg 'STANDARD-CLASS)) 374 '*<STANDARD-CLASS>-VALID-INITIALIZATION-KEYWORDS*) 375 ((eq metaclass-arg 'FUNCALLABLE-STANDARD-CLASS) 376 '*<FUNCALLABLE-STANDARD-CLASS>-VALID-INITIALIZATION-KEYWORDS*) 377 (t `(CLASS-VALID-INITIALIZATION-KEYWORDS ,metaclass-var))))))) 378 ;; Provide good error messages. The error message from 379 ;; ENSURE-CLASS (actually MAKE-INSTANCE) later is unintelligible. 380 ,@(if user-defined-args 381 `((UNLESS (EQ ,metaclass-keywords-var 'T) 382 ,@(mapcar #'(lambda (option) 383 `(UNLESS (MEMBER ',(first option) ,metaclass-keywords-var) 384 (ERROR-OF-TYPE 'EXT:SOURCE-PROGRAM-ERROR 385 :FORM ',whole-form 386 :DETAIL ',option 387 (TEXT "~S ~S: invalid option ~S") 388 'DEFCLASS ',name ',option))) 389 user-defined-args)))) 390 (APPLY #'ENSURE-CLASS 391 ',name 392 :DIRECT-SUPERCLASSES (LIST ,@superclass-forms) 393 :DIRECT-SLOTS (LIST ,@slot-forms) 394 :METACLASS ,metaclass-var 395 ,@direct-default-initargs 396 ,@documentation 397 ,@generic-accessors 398 ;; Pass user-defined initargs of the metaclass. 399 ,@(mapcan #'(lambda (option) 400 (list `',(first option) `',(rest option))) 401 user-defined-args) 402 (APPEND 403 ;; Pass the default initargs of the metaclass, in 404 ;; order to erase leftovers from the previous definition. 405 ,(if metaclass 406 `(MAPCAN #'(LAMBDA (X) (LIST (FIRST X) (FUNCALL (THIRD X)))) 407 (CLASS-DEFAULT-INITARGS ,metaclass-var)) 408 `',*<standard-class>-default-initargs*) 409 (LIST 410 ;; Here we use (unless ... '(... NIL)) because when a class 411 ;; is being redefined, passing :DOCUMENTATION NIL to 412 ;; ENSURE-CLASS means to erase the documentation string, 413 ;; while nothing means to keep it! See MOP p. 57. 414 ,@(unless direct-default-initargs '(:DIRECT-DEFAULT-INITARGS NIL)) 415 ,@(unless documentation '(:DOCUMENTATION NIL)) 416 ,@(unless generic-accessors '(:GENERIC-ACCESSORS 'T))))))) 417 ,@(if generic-accessors-arg 418 (nreverse accessor-method-decl-forms) ; the DECLAIM-METHODs 419 (nreverse accessor-function-decl-forms)) ; the C-DEFUNs 420 (FIND-CLASS ',name))))) 421 422;; DEFCLASS execution: 423 424;; The function responsible for a MAKE-INSTANCES-OBSOLETE call. 425(defvar *make-instances-obsolete-caller* 'make-instances-obsolete) 426 427(defun ensure-class-using-class-<t> (class name &rest all-keys 428 &key (metaclass <standard-class>) 429 (direct-superclasses '()) 430 (direct-slots '()) 431 (direct-default-initargs '()) 432 (documentation nil) 433 (fixed-slot-locations nil) 434 &allow-other-keys) 435 (declare (ignore direct-slots direct-default-initargs documentation 436 fixed-slot-locations)) 437 ;; Argument checks. 438 (unless (symbolp name) 439 (error (TEXT "~S: class name ~S should be a symbol") 440 'ensure-class-using-class name)) 441 (unless (defined-class-p metaclass) 442 (if (symbolp metaclass) 443 (setq metaclass 444 (cond ((eq metaclass 'standard-class) <standard-class>) ; for bootstrapping 445 (t (find-class metaclass)))) 446 (error (TEXT "~S for class ~S: metaclass ~S is neither a class or a symbol") 447 'ensure-class-using-class name metaclass))) 448 (unless (or (eq metaclass <standard-class>) ; for bootstrapping 449 (subclassp metaclass <defined-class>)) 450 (error (TEXT "~S for class ~S: metaclass ~S is not a subclass of CLASS") 451 'ensure-class-using-class name metaclass)) 452 (unless (proper-list-p direct-superclasses) 453 (error (TEXT "~S for class ~S: The ~S argument should be a proper list, not ~S") 454 'ensure-class-using-class name ':direct-superclasses direct-superclasses)) 455 (unless (every #'(lambda (x) 456 (or (defined-class-p x) 457 (forward-reference-to-class-p x) 458 (symbolp x))) 459 direct-superclasses) 460 (error (TEXT "~S for class ~S: The direct-superclasses list should consist of classes and symbols, not ~S") 461 'ensure-class-using-class name direct-superclasses)) 462 ;; Ignore the old class if the given name is not its "proper name". 463 ;; (This is an ANSI CL requirement; it's not clear whether it belongs 464 ;; here or in ENSURE-CLASS.) 465 (when (and class (not (eq (class-name class) name))) 466 (return-from ensure-class-using-class-<t> 467 (apply #'ensure-class-using-class nil name all-keys))) 468 ;; Decide whether to modify the given class or ignore it. 469 (let ((a-semi-standard-class-p (or (eq metaclass <standard-class>) 470 (subclassp metaclass <semi-standard-class>)))) 471 (when class 472 (cond ((not (eq metaclass (class-of class))) 473 ;; This can occur when mixing DEFSTRUCT and DEFCLASS. 474 ;; MOP p. 48 says "If the class of the class argument is not the 475 ;; same as the class specified by the :metaclass argument, an 476 ;; error is signalled." But we can do better: ignore the old 477 ;; class, warn and proceed. The old instances will thus keep 478 ;; pointing to the old class. 479 (clos-warning (TEXT "Cannot redefine ~S with a different metaclass ~S") 480 class metaclass) 481 (setq class nil)) 482 ((not a-semi-standard-class-p) 483 ;; This can occur when redefining a class defined through 484 ;; (DEFCLASS ... (:METACLASS STRUCTURE-CLASS)), which is 485 ;; equivalent to re-executed DEFSTRUCT. 486 ;; Only <semi-standard-class> subclasses support making instances 487 ;; obsolete. Ignore the old class and proceed. The old instances 488 ;; will thus keep pointing to the old class. 489 (setq class nil))) 490 (unless class 491 (return-from ensure-class-using-class-<t> 492 (apply #'ensure-class-using-class nil name all-keys)))) 493 ;; Preparation of class initialization arguments. 494 (setq all-keys (copy-list all-keys)) 495 (remf all-keys ':metaclass) 496 ;; See which direct superclasses are already defined. 497 (setq direct-superclasses 498 (mapcar #'(lambda (c) 499 (if (defined-class-p c) 500 c 501 (let ((cn (if (forward-reference-to-class-p c) (class-name c) c))) 502 (assert (symbolp cn)) 503 (if a-semi-standard-class-p 504 ;; Need a class. Allocate a forward-referenced-class 505 ;; if none is yet allocated. 506 (or (get cn 'CLOSCLASS) 507 (setf (get cn 'CLOSCLASS) 508 (make-instance 'forward-referenced-class 509 :name cn))) 510 ;; Need a defined-class. 511 (find-class cn))))) 512 direct-superclasses)) 513 (if class 514 ;; Modify the class and return the modified class. 515 (apply #'reinitialize-instance ; => #'reinitialize-instance-<defined-class> 516 class 517 :direct-superclasses direct-superclasses 518 all-keys) 519 (setf (find-class name) 520 (setq class 521 (apply (cond ((eq metaclass <standard-class>) 522 #'make-instance-<standard-class>) 523 ((eq metaclass <funcallable-standard-class>) 524 #'make-instance-<funcallable-standard-class>) 525 ((eq metaclass <built-in-class>) 526 #'make-instance-<built-in-class>) 527 ((eq metaclass <structure-class>) 528 #'make-instance-<structure-class>) 529 (t #'make-instance)) 530 metaclass 531 :name name 532 :direct-superclasses direct-superclasses 533 all-keys)))) 534 class)) 535 536;; Preliminary. 537(predefun ensure-class-using-class (class name &rest args 538 &key (metaclass <standard-class>) 539 (direct-superclasses '()) 540 (direct-slots '()) 541 (direct-default-initargs '()) 542 (documentation nil) 543 (fixed-slot-locations nil) 544 &allow-other-keys) 545 (declare (ignore metaclass direct-superclasses direct-slots 546 direct-default-initargs documentation fixed-slot-locations)) 547 (apply #'ensure-class-using-class-<t> class name args)) 548 549;; MOP p. 46 550(defun ensure-class (name &rest args 551 &key (metaclass <standard-class>) 552 (direct-superclasses '()) 553 (direct-slots '()) 554 (direct-default-initargs '()) 555 (documentation nil) 556 (fixed-slot-locations nil) 557 &allow-other-keys) 558 (declare (ignore metaclass direct-superclasses direct-slots 559 direct-default-initargs documentation fixed-slot-locations)) 560 (unless (symbolp name) 561 (error (TEXT "~S: class name ~S should be a symbol") 562 'ensure-class name)) 563 (let ((result 564 (apply #'ensure-class-using-class (find-class name nil) name args))) 565 ; A check, to verify that user-defined methods on ensure-class-using-class 566 ; work as they should. 567 (unless (defined-class-p result) 568 (error (TEXT "Wrong ~S result for ~S: not a class: ~S") 569 'ensure-class-using-class name result)) 570 result)) 571 572;; Preliminary. 573(predefun reader-method-class (class direct-slot &rest initargs) 574 (declare (ignore class direct-slot initargs)) 575 <standard-reader-method>) 576(predefun writer-method-class (class direct-slot &rest initargs) 577 (declare (ignore class direct-slot initargs)) 578 <standard-writer-method>) 579 580;; ---------------------------- Class redefinition ---------------------------- 581 582;; When this is true, all safety checks about the metaclasses 583;; of superclasses are omitted. 584(defparameter *allow-mixing-metaclasses* nil) 585 586(defun reinitialize-instance-<defined-class> (class &rest all-keys 587 &key (name nil name-p) 588 (direct-superclasses '() direct-superclasses-p) 589 (direct-slots '() direct-slots-p) 590 (direct-default-initargs '() direct-default-initargs-p) 591 (documentation nil documentation-p) 592 (fixed-slot-locations nil fixed-slot-locations-p) 593 &allow-other-keys 594 &aux (metaclass (class-of class))) 595 (if (and (>= (class-initialized class) 4) ; already finalized? 596 (subclassp class <metaobject>)) 597 ;; Things would go awry when we try to redefine <class> and similar. 598 (clos-warning (TEXT "Redefining metaobject class ~S has no effect.") class) 599 (progn 600 (when direct-superclasses-p 601 ;; Normalize the (class-direct-superclasses class) in the same way as 602 ;; the direct-superclasses argument, so that we can compare the two 603 ;; lists using EQUAL. 604 (when (and (subclassp metaclass <standard-class>) 605 (< (class-initialized class) 3)) 606 (do ((l (class-direct-superclasses class) (cdr l))) 607 ((atom l)) 608 (let ((c (car l))) 609 (unless (defined-class-p c) 610 (let ((new-c 611 (let ((cn (if (forward-reference-to-class-p c) (class-name c) c))) 612 (assert (symbolp cn)) 613 ;; Need a class. Allocate a forward-referenced-class 614 ;; if none is yet allocated. 615 (or (get cn 'CLOSCLASS) 616 (setf (get cn 'CLOSCLASS) 617 (make-instance 'forward-referenced-class 618 :name cn)))))) 619 (unless (eq new-c c) 620 (when (defined-class-p new-c) 621 ; changed from forward-referenced-class to defined-class 622 (check-allowed-superclass class new-c)) 623 (setf (car l) new-c) 624 (when (or (defined-class-p c) (forward-reference-to-class-p c)) 625 (remove-direct-subclass c class)) 626 (add-direct-subclass new-c class)))))))) 627 (when direct-slots-p 628 ;; Convert the direct-slots to <direct-slot-definition> instances. 629 (setq direct-slots (convert-direct-slots class direct-slots))) 630 (when fixed-slot-locations-p 631 ;; Convert from list to boolean. 632 (when (consp fixed-slot-locations) 633 (setq fixed-slot-locations (car fixed-slot-locations)))) 634 ;; Trivial changes (that can occur when loading the same code twice) 635 ;; do not require updating the instances: 636 ;; changed slot-options :initform, :documentation, 637 ;; changed class-options :name, :default-initargs, :documentation. 638 (if (or (and direct-superclasses-p 639 (not (equal (or direct-superclasses (default-direct-superclasses class)) 640 (class-direct-superclasses class)))) 641 (and direct-slots-p 642 (not (equal-direct-slots direct-slots (class-direct-slots class)))) 643 (and direct-default-initargs-p 644 (not (equal-default-initargs direct-default-initargs 645 (class-direct-default-initargs class)))) 646 (and fixed-slot-locations-p 647 (not (eq fixed-slot-locations (class-fixed-slot-locations class))))) 648 ;; Instances have to be updated: 649 (let* ((was-finalized (>= (class-initialized class) 6)) 650 (must-be-finalized 651 (and was-finalized 652 (some #'class-instantiated (list-all-finalized-subclasses class)))) 653 (old-direct-superclasses (class-direct-superclasses class)) 654 (old-direct-accessors (class-direct-accessors class)) 655 (old-class-precedence-list (and was-finalized (class-precedence-list class))) 656 old-class) 657 ;; ANSI CL 4.3.6. Remove accessor methods created by old DEFCLASS. 658 (remove-accessor-methods old-direct-accessors) 659 (setf (class-direct-accessors class) '()) 660 ;; Clear the cached prototype. 661 (setf (class-prototype class) nil) 662 ;; Declare all instances as obsolete, and backup the class object. 663 (let ((old-version (class-current-version class)) 664 (*make-instances-obsolete-caller* 'defclass)) 665 (make-instances-obsolete class) 666 (setq old-class (cv-class old-version))) 667 (locally (declare (compile)) 668 (sys::%handler-bind 669 #'(lambda () 670 (apply #'shared-initialize 671 ; => #'shared-initialize-<built-in-class> 672 ; #'shared-initialize-<standard-class> 673 ; #'shared-initialize-<structure-class> 674 class nil 675 `(,@(if direct-slots-p 676 (list 'direct-slots direct-slots) '()) 677 ,@all-keys)) 678 ;; If the class could be finalized (although not a "must"), 679 ;; keep it finalized and don't unfinalize it. 680 (when (>= (class-initialized class) 6) 681 (setq must-be-finalized t)) 682 (update-subclasses-for-redefined-class 683 class was-finalized must-be-finalized 684 old-direct-superclasses)) 685 ;; If an error occurs during the class redefinition, 686 ;; switch back to the old definition, so that existing 687 ;; instances can continue to be used. 688 'ERROR #'(lambda (condition) 689 (declare (ignore condition)) 690 (let ((tmp-direct-superclasses (class-direct-superclasses class))) 691 ;; Restore the class using the backup copy. 692 (let ((new-version (class-current-version class))) 693 (dotimes (i (sys::%record-length class)) 694 (setf (sys::%record-ref class i) (sys::%record-ref old-class i))) 695 (setf (class-current-version class) new-version)) 696 ;; Restore the direct-subclasses pointers. 697 (dolist (super tmp-direct-superclasses) 698 (remove-direct-subclass-internal super class)) 699 (dolist (super old-direct-superclasses) 700 (add-direct-subclass-internal super class)) 701 ;; Restore the finalized-direct-subclasses pointers. 702 (dolist (super tmp-direct-superclasses) 703 (when (semi-standard-class-p super) 704 (remove-finalized-direct-subclass super class))) 705 (when (>= (class-initialized class) 6) 706 (dolist (super old-direct-superclasses) 707 (when (semi-standard-class-p super) 708 (add-finalized-direct-subclass super class)))) 709 ;; Restore the accessor methods. 710 (add-accessor-methods old-direct-accessors) 711 (setf (class-direct-accessors class) old-direct-accessors))))) 712 (let ((new-class-precedence-list 713 (and (>= (class-initialized class) 6) (class-precedence-list class)))) 714 (unless (equal old-class-precedence-list new-class-precedence-list) 715 (update-subclass-instance-specializer-generic-functions class) 716 (update-subclass-cpl-specializer-generic-functions class 717 old-class-precedence-list new-class-precedence-list))) 718 (install-class-direct-accessors class)) 719 ;; Instances don't need to be updated: 720 (progn 721 (when name-p 722 ;; Store new name: 723 (setf (class-classname class) name)) 724 (when direct-slots-p 725 ;; Store new slot-inits: 726 (do ((l-old (class-direct-slots class) (cdr l-old)) 727 (l-new direct-slots (cdr l-new))) 728 ((null l-new)) 729 (let ((old (car l-old)) 730 (new (car l-new))) 731 (setf (slot-definition-initform old) (slot-definition-initform new)) 732 (setf (slot-definition-initfunction old) (slot-definition-initfunction new)) 733 (setf (slot-definition-documentation old) (slot-definition-documentation new))))) 734 (when direct-default-initargs-p 735 ;; Store new default-initargs: 736 (do ((l-old (class-direct-default-initargs class) (cdr l-old)) 737 (l-new direct-default-initargs (cdr l-new))) 738 ((null l-new)) 739 (let ((old (cdar l-old)) 740 (new (cdar l-new))) 741 ;; Move initform and initfunction from new destructively into 742 ;; the old one: 743 (setf (car old) (car new)) 744 (setf (cadr old) (cadr new))))) 745 (when documentation-p 746 ;; Store new documentation: 747 (setf (class-documentation class) documentation)) 748 ;; NB: These modifications are automatically inherited by the 749 ;; subclasses of class! Due to <inheritable-slot-definition-initer> 750 ;; and <inheritable-slot-definition-doc>. 751 ;; No need to call (install-class-direct-accessors class) here. 752 ) ) 753 ;; Try to finalize it (mop-cl-reinit-mo, https://sourceforge.net/p/clisp/bugs/353/) 754 (unless *allow-mixing-metaclasses* ; for gray.lisp 755 (when (finalizable-p class) 756 (finalize-inheritance class))) 757 ;; Notification of listeners: 758 (map-dependents class 759 #'(lambda (dependent) 760 (apply #'update-dependent class dependent all-keys))) 761 ) ) 762 class) 763 764(defun equal-direct-slots (slots1 slots2) 765 (or (and (null slots1) (null slots2)) 766 (and (consp slots1) (consp slots2) 767 (equal-direct-slot (first slots1) (first slots2)) 768 (equal-direct-slots (rest slots1) (rest slots2))))) 769(defun equal-default-initargs (initargs1 initargs2) 770 (or (and (null initargs1) (null initargs2)) 771 (and (consp initargs1) (consp initargs2) 772 (eq (car (first initargs1)) (car (first initargs2))) 773 (equal-default-initargs (cdr initargs1) (cdr initargs2))))) 774 775(defun map-dependents-<defined-class> (class function) 776 (dolist (dependent (class-listeners class)) 777 (funcall function dependent))) 778 779;; ------------------- General routines for <defined-class> ------------------- 780 781;; Preliminary. 782(predefun class-name (class) 783 (class-classname class)) 784 785;; Returns the list of implicit direct superclasses when none was specified. 786(defun default-direct-superclasses (class) 787 (cond ((typep class <standard-class>) (list <standard-object>)) 788 ((typep class <funcallable-standard-class>) (list <funcallable-standard-object>)) 789 ((typep class <structure-class>) (list <structure-object>)) 790 (t '()))) 791 792(defun check-metaclass-mix (name direct-superclasses metaclass-test metaclass) 793 (unless *allow-mixing-metaclasses* 794 (unless (every metaclass-test direct-superclasses) 795 (error-of-type 'error 796 (TEXT "(~S ~S): superclass ~S should be of class ~S") 797 'DEFCLASS name (find-if-not metaclass-test direct-superclasses) 798 metaclass)))) 799 800;; Preliminary. 801(predefun validate-superclass (class superclass) 802 (or ;; Green light if class and superclass belong to the same metaclass. 803 (eq (sys::%record-ref class 0) (sys::%record-ref superclass 0)) 804 ;; Green light also if class is a funcallable-standard-class and 805 ;; superclass is a standard-class. 806 (and (eq (sys::%record-ref class 0) *<funcallable-standard-class>-class-version*) 807 (eq (sys::%record-ref superclass 0) *<standard-class>-class-version*)) 808 ;; Other than that, only <standard-object> and <structure-object> can 809 ;; inherit from <t> without belonging to the same metaclass. 810 (and (eq superclass <t>) 811 (memq (class-classname class) '(standard-object structure-object))) 812 ;; And only <funcallable-standard-object> can inherit from <function> 813 ;; without belonging to the same metaclass. 814 (and (eq superclass <function>) 815 (eq (class-classname class) 'funcallable-standard-object)))) 816 817(defun check-allowed-superclass (class superclass) 818 (unless (validate-superclass class superclass) 819 (error (TEXT "(~S ~S) for class ~S: ~S does not allow ~S to become a subclass of ~S. You may define a method on ~S to allow this.") 820 'initialize-instance 'class (class-classname class) 'validate-superclass class superclass 821 'validate-superclass))) 822 823;;; The direct-subclasses slot can be either 824;;; - NIL or a weak-list (for saving memory when there are few subclasses), or 825;;; - a weak-hash-table (for speed when there are many subclasses). 826#| 827;; Adds a class to the list of direct subclasses. 828(defun add-direct-subclass (class subclass) ...) 829;; Removes a class from the list of direct subclasses. 830(defun remove-direct-subclass (class subclass) ...) 831;; Returns the currently existing direct subclasses, as a freshly consed list. 832(defun list-direct-subclasses (class) ...) 833|# 834(def-weak-set-accessors class-direct-subclasses-table defined-class 835 add-direct-subclass-internal 836 remove-direct-subclass-internal 837 list-direct-subclasses) 838 839;; Preliminary. 840(predefun add-direct-subclass (class subclass) 841 (add-direct-subclass-internal class subclass)) 842(predefun remove-direct-subclass (class subclass) 843 (remove-direct-subclass-internal class subclass)) 844(predefun class-direct-subclasses (class) 845 (list-direct-subclasses class)) 846 847(defun checked-class-direct-subclasses (class) 848 (let ((result (class-direct-subclasses class))) 849 ; Some checks, to guarantee that user-defined methods on 850 ; class-direct-subclasses don't break our CLOS. 851 (unless (proper-list-p result) 852 (error (TEXT "Wrong ~S result for class ~S: not a proper list: ~S") 853 'class-direct-subclasses (class-name class) result)) 854 (dolist (c result) 855 (unless (defined-class-p c) 856 (error (TEXT "Wrong ~S result for class ~S: list element is not a class: ~S") 857 'class-direct-subclasses (class-name class) c)) 858 (unless (memq class (class-direct-superclasses c)) 859 (error (TEXT "Wrong ~S result for class ~S: ~S is not a direct superclass of ~S") 860 'class-direct-subclasses (class-name class) class c))) 861 result)) 862 863(defun update-subclasses-sets (class old-direct-superclasses new-direct-superclasses) 864 (unless (equal old-direct-superclasses new-direct-superclasses) 865 (let ((removed-direct-superclasses 866 (set-difference old-direct-superclasses new-direct-superclasses)) 867 (added-direct-superclasses 868 (set-difference new-direct-superclasses old-direct-superclasses))) 869 (dolist (super removed-direct-superclasses) 870 (remove-direct-subclass super class)) 871 (dolist (super added-direct-superclasses) 872 (add-direct-subclass super class))))) 873 874;; ---------------------------------------------------------------------------- 875;; CLtL2 28.1.5., ANSI CL 4.3.5. Determining the Class Precedence List 876 877;; The set of all classes forms a directed graph: Class C is located 878;; below the direct superclasses of C. This graph is acyclic, because 879;; at the moment of definition of the class C all direct superclasses must 880;; already be present. 881 882;; Hence, one can use Noether Induction (Induction from above to below in 883;; the class graph) . 884 885;; For a class C let DS(n) be the list of all direct superclasses of C. 886;; The set of all superclasses (incl. C itself) is inductively defined as 887;; S(C) := {C} union union_{D in DS(C)} S(D). 888 889;; In other words: 890;; S(C) = { C_n : C_n in DS(C_{n-1}), ..., C_1 in DS(C_0), C_0 = C } 891 892;; Lemma 1: (a) C in S(C). 893;; (b) DS(C) subset S(C). 894;; (c) D in DS(C) ==> S(D) subset S(C). 895;; (d) D in S(C) ==> S(D) subset S(C). 896;; proof: (a) follows from the definition. 897;; (b) from (a) and from the definition. 898;; (c) from the definition. 899;; (d) from (c) with fixed D via induction over C. 900 901;; The CPL of a class C is one order of set S(C). 902;; If CPL(C) = (... D1 ... D2 ...), one writes D1 < D2. 903;; The relation introduced by this is a total order upon S(C). 904;; The following set of restrictions has to be taken into account: 905;; R(C) := union_{D in S(C)} DR(D) with 906;; DR(C) := { C < C1, C1 < C2, ..., C{n-1} < C_n } if DS(C) = (C1, ..., Cn). 907;; If R(C) contains a cycle, R(C) cannot be completed into a total order, 908;; of course. Then, R(C) is called inconsistent. 909;; CPL(C) is constructed as follows: 910;; L := (), R := R(C). 911;; L := (L | C), remove all (C < ..) from R. 912;; while R /= {}, deal with the set M of all minimal elements of R 913;; (those classes, that can be added to L without violating R(C) ). 914;; If M is empty, then there is a cycle in R(C) and 915;; the algorithm is finished. Else, choose that element among the 916;; elements E of M, which has a D being rightmost in L with 917;; E in DS(D) . 918;; L := (L | E), remove all (E < ..) from R. 919;; CPL(C) := L. 920;; L is lengthened stepwise by one element, R is shortened stepwise, 921;; and R always consists solely of relations between elements 922;; of S(C)\L. 923 924;; Lemma 2: (a) CPL(C) = (C ...). 925;; (b) If DS(C) = (C1, ..., Cn), then 926;; CPL(C) = (C ... C1 ... C2 ... ... Cn ...). 927;; proof: (a) obvious by construction. 928;; (b) If Ci is added to the CPL, then the restriction 929;; C{i-1} < Ci can no longer be in R, so C{i-1} must already be 930;; in the CPL. 931 932;; The following statement is wrong: 933;; (*) If D is in DS(C) and CPL(D) = (D1, ..., Dn), then 934;; CPL(C) = (C ... D1 ... D2 ... ... Dn ...). 935;; Example: 936;; z 937;; /|\ CPL(z) = (z) 938;; / | \ CPL(x) = (x z) 939;; x | x CPL(y) = (y z) 940;; | | | CPL(d) = (d x z) 941;; d y e CPL(e) = (e x z) 942;; \/ \/ CPL(b) = (b d x y z) 943;; b c CPL(c) = (c y e x z) 944;; \ / CPL(a) = (a b d c y e x z) 945;; a 946;; CPL(a) does not contain CPL(b) ! 947 948#|| 949 (defclass z () ()) 950 (defclass x (z) ()) 951 (defclass y (z) ()) 952 (defclass d (x z) ()) 953 (defclass e (x z) ()) 954 (defclass b (d y) ()) 955 (defclass c (y e) ()) 956 (defclass a (b c) ()) 957 (mapcar #'find-class '(z x y d e b c a)) 958||# 959 960(defun std-compute-cpl (class direct-superclasses) 961 (let* ((superclasses ; list of all superclasses in any order 962 (remove-duplicates 963 (mapcap #'class-precedence-list direct-superclasses))) 964 (L '()) 965 (R1 (list (cons class direct-superclasses))) 966 (R2 (mapcar #'(lambda (D) (cons D (class-direct-superclasses D))) 967 superclasses))) 968 (loop 969 ;; L is the reversed, so far constructed CPL. 970 ;; R1 is the list of the so far relevant restrictions, in the form 971 ;; R1 = (... (Dj ... Dn) ...) if from DR(D) = (D1 ... Dn) only 972 ;; Dj,...,Dn is left over. The order in R1 corresponds to that in L. 973 ;; R2 is the list of all so far irrelevant restrictions. 974 (when (null R1) 975 (return)) ; R1 = R2 = () -> finished 976 (let ((M (remove-duplicates (mapcar #'first R1) :from-end t))) 977 (setq M (remove-if #'(lambda (E) 978 (or (dolist (r R1 nil) 979 (when (member E (cdr r)) (return t))) 980 (dolist (r R2 nil) 981 (when (member E (cdr r)) (return t))))) 982 (the list M))) 983 (when (null M) 984 (error-of-type 'error 985 (TEXT "~S ~S: inconsistent precedence graph, cycle ~S") 986 'defclass (class-classname class) 987 ;; find cycle: advance to ever smaller elements 988 ;; with aid of the restrictions. 989 (let* ((R0 (append R1 R2)) 990 (cycle (list (car (first R0))))) 991 (loop 992 (let* ((last (car cycle)) 993 (next (dolist (r R0 nil) 994 (when (member last (cdr r)) 995 (return (nth (position last (cdr r)) r)))))) 996 (when (null next) 997 ;; last is now apparently a minimal element, after all! 998 (return '??)) 999 (when (member next cycle) 1000 (setf (cdr (member next cycle)) nil) 1001 (return cycle)) 1002 (push next cycle)))))) 1003 (let ((E (first M))) 1004 (push E L) 1005 (push (assoc E R2) R1) 1006 (setq R2 (delete E R2 :key #'first)) 1007 (mapl #'(lambda (r) (when (eq (first (car r)) E) (pop (car r)))) R1) 1008 (setq R1 (delete-if #'null R1))))) 1009 (setq L (nreverse L)) 1010 ;; Test, if L is compatible with the CPL(D), D in direct-superclasses: 1011 (mapc #'(lambda (D) 1012 (unless ; Is (class-precedence-list D) sublist of L ? 1013 (do ((CL L) 1014 (DL (class-precedence-list D) (cdr DL))) 1015 ((null DL) t) 1016 (when (null (setq CL (member (car DL) CL))) (return nil))) 1017 (clos-warning (TEXT "(class-precedence-list ~S) and (class-precedence-list ~S) are inconsistent") 1018 class D))) 1019 direct-superclasses) 1020 L)) 1021 1022(defun compute-class-precedence-list-<defined-class> (class) 1023 (std-compute-cpl class (class-direct-superclasses class))) 1024 1025;; Preliminary. 1026(predefun compute-class-precedence-list (class) 1027 (compute-class-precedence-list-<defined-class> class)) 1028 1029(defun checked-compute-class-precedence-list (class) 1030 (let ((cpl (compute-class-precedence-list class)) 1031 (name (class-name class))) 1032 ; Some checks, to guarantee that user-defined methods on 1033 ; compute-class-precedence-list don't break our CLOS. 1034 (unless (proper-list-p cpl) 1035 (error (TEXT "Wrong ~S result for class ~S: not a proper list: ~S") 1036 'compute-class-precedence-list name cpl)) 1037 (dolist (c cpl) 1038 (unless (defined-class-p c) 1039 (error (TEXT "Wrong ~S result for class ~S: list element is not a class: ~S") 1040 'compute-class-precedence-list name c))) 1041 (unless (eq (first cpl) class) 1042 (error (TEXT "Wrong ~S result for class ~S: list doesn't start with the class itself: ~S") 1043 'compute-class-precedence-list name cpl)) 1044 (unless (or (eq name 't) ; for bootstrapping 1045 (eq (car (last cpl)) <t>)) 1046 (error (TEXT "Wrong ~S result for class ~S: list doesn't end with ~S: ~S") 1047 'compute-class-precedence-list name <t> cpl)) 1048 (unless (= (length cpl) (length (remove-duplicates cpl :test #'eq))) 1049 (error (TEXT "Wrong ~S result for class ~S: list contains duplicates: ~S") 1050 'compute-class-precedence-list name cpl)) 1051 (let ((superclasses (reduce #'union 1052 (mapcar #'class-precedence-list 1053 (class-direct-superclasses class)) 1054 :initial-value '()))) 1055 (let ((forgotten (set-difference superclasses cpl))) 1056 (when forgotten 1057 (error (TEXT "Wrong ~S result for class ~S: list doesn't contain the superclass~[~;~:;es~] ~{~S~^, ~}.") 1058 'compute-class-precedence-list name (length forgotten) forgotten))) 1059 (let ((extraneous (set-difference (rest cpl) superclasses))) 1060 (when extraneous 1061 (error (TEXT "Wrong ~S result for class ~S: list contains elements that are not superclasses: ~{~S~^, ~}") 1062 'compute-class-precedence-list name extraneous)))) 1063 ; Now we've checked the CPL is OK. 1064 cpl)) 1065 1066;; Stuff all superclasses (from the precedence-list) into a hash-table. 1067(defun std-compute-superclasses (precedence-list) 1068 (let ((ht (make-hash-table :key-type 'defined-class :value-type '(eql t) 1069 :test 'ext:stablehash-eq :warn-if-needs-rehash-after-gc t))) 1070 (mapc #'(lambda (superclass) (setf (gethash superclass ht) t)) 1071 precedence-list) 1072 ht)) 1073 1074;; Determine whether a class inherits from <standard-stablehash> or 1075;; <structure-stablehash>. 1076(defun std-compute-subclass-of-stablehash-p (class) 1077 (dolist (superclass (class-precedence-list class) nil) 1078 (let ((superclassname (class-classname superclass))) 1079 (when (or (eq superclassname 'standard-stablehash) 1080 (eq superclassname 'structure-stablehash)) 1081 (return t))))) 1082 1083;; ---------------------------------------------------------------------------- 1084;; CLtL2 28.1.3.2., ANSI CL 7.5.3. Inheritance of Slots and Slot Options 1085 1086(defun compute-effective-slot-definition-initargs-<defined-class> (class directslotdefs) 1087 (declare (ignore class)) 1088 (unless (and (proper-list-p directslotdefs) (consp directslotdefs)) 1089 (error (TEXT "~S: argument should be a non-empty proper list, not ~S") 1090 'compute-effective-slot-definition-initargs directslotdefs)) 1091 (dolist (slot directslotdefs) 1092 (unless (direct-slot-definition-p slot) 1093 (error (TEXT "~S: argument list element is not a ~S: ~S") 1094 'compute-effective-slot-definition-initargs 'direct-slot-definition 1095 slot))) 1096 (let ((name (slot-definition-name (first directslotdefs)))) 1097 (dolist (slot (rest directslotdefs)) 1098 (unless (eql name (slot-definition-name slot)) 1099 (error (TEXT "~S: argument list elements should all have the same name, not ~S and ~S") 1100 'compute-effective-slot-definition-initargs name (slot-definition-name slot)))) 1101 `(:name ,name 1102 ; "The allocation of a slot is controlled by the most 1103 ; specific slot specifier." 1104 :allocation ,(slot-definition-allocation (first directslotdefs)) 1105 ; "The set of initialization arguments that initialize a 1106 ; given slot is the union of the initialization arguments 1107 ; declared in the :initarg slot options in all the slot 1108 ; specifiers. 1109 ,@(let ((initargs 1110 (remove-duplicates 1111 (mapcap #'slot-definition-initargs directslotdefs) 1112 :from-end t))) 1113 (if initargs `(:initargs ,initargs))) 1114 ; "The default initial value form for a slot is the value 1115 ; of the :initform slot option in the most specific slot 1116 ; specifier that contains one." 1117 ,@(dolist (slot directslotdefs '()) 1118 (when (slot-definition-initfunction slot) 1119 (return `(:initform ,(slot-definition-initform slot) 1120 :initfunction ,(slot-definition-initfunction slot) 1121 inheritable-initer ,(slot-definition-inheritable-initer slot))))) 1122 ; "The contents of a slot will always be of type 1123 ; (and T1 ... Tn) where T1 ...Tn are the values of the 1124 ; :type slot options contained in all of the slot specifiers." 1125 ,@(let ((types '())) 1126 (dolist (slot directslotdefs) 1127 (push (slot-definition-type slot) types)) 1128 `(:type ,(if types `(AND ,@(nreverse types)) 'T))) 1129 ; "The documentation string for a slot is the value of the 1130 ; :documentation slot option in the most specific slot 1131 ; specifier that contains one." 1132 ,@(dolist (slot directslotdefs '()) 1133 (when (slot-definition-documentation slot) 1134 (return `(:documentation ,(slot-definition-documentation slot) 1135 inheritable-doc ,(slot-definition-inheritable-doc slot))))) 1136 #|| ; Commented out because <effective-slot-definition> 1137 ; doesn't have readers and writers. 1138 ,@(let ((readers (mapcap #'slot-definition-readers directslotdefs))) 1139 (if readers `(:readers ,readers))) 1140 ,@(let ((writers (mapcap #'slot-definition-writers directslotdefs))) 1141 (if writers `(:writers ,writers))) 1142 ||# 1143 ))) 1144 1145;; Preliminary. 1146(predefun compute-effective-slot-definition-initargs (class direct-slot-definitions) 1147 (compute-effective-slot-definition-initargs-<defined-class> class direct-slot-definitions)) 1148 1149(defun compute-effective-slot-definition-<defined-class> (class name directslotdefs) 1150 (let ((args (compute-effective-slot-definition-initargs class directslotdefs))) 1151 ; Some checks, to guarantee that user-defined primary methods on 1152 ; compute-effective-slot-definition-initargs don't break our CLOS. 1153 (unless (and (proper-list-p args) (evenp (length args))) 1154 (error (TEXT "Wrong ~S result for ~S: not a list of keyword/value pairs: ~S") 1155 'compute-effective-slot-definition-initargs class args)) 1156 (let* ((default '#:default) 1157 (returned-name (getf args ':name '#:default))) 1158 (unless (eql returned-name name) 1159 (if (eq returned-name default) 1160 (error (TEXT "Wrong ~S result for ~S: missing ~S") 1161 'compute-effective-slot-definition-initargs class ':name) 1162 (error (TEXT "Wrong ~S result for ~S: invalid ~S value") 1163 'compute-effective-slot-definition-initargs class ':name)))) 1164 (let ((slot-definition-class 1165 (apply #'effective-slot-definition-class class args))) 1166 (cond ((semi-standard-class-p class) 1167 (unless (or ; for bootstrapping 1168 (eq slot-definition-class 'standard-effective-slot-definition) 1169 (and (defined-class-p slot-definition-class) 1170 (subclassp slot-definition-class <standard-effective-slot-definition>))) 1171 (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S") 1172 'effective-slot-definition-class (class-name class) 1173 'standard-effective-slot-definition slot-definition-class))) 1174 ((structure-class-p class) 1175 (unless (and (defined-class-p slot-definition-class) 1176 (subclassp slot-definition-class <structure-effective-slot-definition>)) 1177 (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S") 1178 'effective-slot-definition-class (class-name class) 1179 'structure-effective-slot-definition slot-definition-class)))) 1180 (apply (cond ((eq slot-definition-class 'standard-effective-slot-definition) 1181 #'make-instance-<standard-effective-slot-definition>) 1182 (t #'make-instance)) 1183 slot-definition-class args)))) 1184 1185;; Preliminary. 1186(predefun compute-effective-slot-definition (class slotname direct-slot-definitions) 1187 (compute-effective-slot-definition-<defined-class> class slotname direct-slot-definitions)) 1188 1189(defun compute-slots-<defined-class>-primary (class) 1190 ;; Gather all slot-specifiers, ordered by precedence: 1191 (let ((all-slots 1192 (mapcan #'(lambda (c) (nreverse (copy-list (class-direct-slots c)))) 1193 (class-precedence-list class)))) 1194 ;; Partition by slot-names: 1195 (setq all-slots 1196 (let ((ht (make-hash-table :key-type 'symbol :value-type 't 1197 :test 'ext:stablehash-eql :warn-if-needs-rehash-after-gc t))) 1198 (dolist (slot all-slots) 1199 (let ((slot-name (slot-definition-name slot))) 1200 (push slot (gethash slot-name ht nil)))) 1201 (let ((L nil)) 1202 (maphash #'(lambda (name slot-list) 1203 (push (cons name (nreverse slot-list)) L)) 1204 ht) 1205 L))) ; not (nreverse L), because maphash reverses the order 1206 ;; Bring the slots into final order: Superclass before subclass, and 1207 ;; inside each class, keeping the same order as in the direct-slots. 1208 (setq all-slots (nreverse all-slots)) 1209 ;; all-slots is now a list of lists of the form 1210 ;; (name most-specific-slot ... least-specific-slot). 1211 (mapcar 1212 #'(lambda (slotbag) 1213 (let ((name (car slotbag)) 1214 (directslotdefs (cdr slotbag))) 1215 ;; Create the effective slot definition in a way that depends 1216 ;; only on the class, name, and direct-slot-definitions. 1217 (let ((eff-slot 1218 (compute-effective-slot-definition class name directslotdefs))) 1219 ; Some checks, to guarantee that user-defined methods on 1220 ; compute-effective-slot-definition don't break our CLOS. 1221 (unless (effective-slot-definition-p eff-slot) 1222 (error (TEXT "Wrong ~S result for class ~S, slot ~S: not an ~S instance: ~S") 1223 'compute-effective-slot-definition class name 'effective-slot-definition eff-slot)) 1224 eff-slot))) 1225 all-slots))) 1226 1227;; Allocation of local and shared slots. 1228;; Side effects done by this function: The slot-definition-location of the 1229;; slots is determined. 1230(defun compute-slots-<slotted-class>-around (class next-method) 1231 (let ((cpl (class-precedence-list class)) 1232 (slots (funcall next-method class))) 1233 ; Some checks, to guarantee that user-defined primary methods on 1234 ; compute-slots don't break our CLOS. 1235 (unless (proper-list-p slots) 1236 (error (TEXT "Wrong ~S result for class ~S: not a proper list: ~S") 1237 'compute-slots (class-name class) slots)) 1238 (cond ((semi-standard-class-p class) 1239 (dolist (slot slots) 1240 (unless (standard-effective-slot-definition-p slot) 1241 (error (TEXT "Wrong ~S result for class ~S: list element is not a ~S: ~S") 1242 'compute-slots (class-name class) 1243 'standard-effective-slot-definition slot)))) 1244 ((structure-class-p class) 1245 (dolist (slot slots) 1246 (unless (typep-class slot <structure-effective-slot-definition>) 1247 (error (TEXT "Wrong ~S result for class ~S: list element is not a ~S: ~S") 1248 'compute-slots (class-name class) 1249 'structure-effective-slot-definition slot))))) 1250 (unless (= (length slots) 1251 (length (delete-duplicates (mapcar #'slot-definition-name slots)))) 1252 (error (TEXT "Wrong ~S result for class ~S: list contains duplicate slot names: ~S") 1253 'compute-slots (class-name class) slots)) 1254 ;; Implementation of fixed-slot-locations policy. 1255 (let ((superclasses-with-fixed-slot-locations 1256 (remove-if-not #'(lambda (c) 1257 (and (semi-standard-class-p c) 1258 (class-fixed-slot-locations c))) 1259 (cdr (class-precedence-list class))))) 1260 (when superclasses-with-fixed-slot-locations 1261 (dolist (slot slots) 1262 (let ((name (slot-definition-name slot)) 1263 (location nil)) 1264 (dolist (superclass superclasses-with-fixed-slot-locations) 1265 (let ((slot-in-superclass (find name (class-slots superclass) 1266 :key #'slot-definition-name))) 1267 (when slot-in-superclass 1268 (when (eq (slot-definition-allocation slot-in-superclass) ':instance) 1269 (let ((guaranteed-location 1270 (slot-definition-location slot-in-superclass))) 1271 (assert (integerp guaranteed-location)) 1272 (if location 1273 (unless (equal location guaranteed-location) 1274 (error (TEXT "In class ~S, the slot ~S is constrained by incompatible constraints inherited from the superclasses.") 1275 (class-name class) name)) 1276 (setq location guaranteed-location))))))) 1277 (when location 1278 (unless (eq (slot-definition-allocation slot) ':instance) 1279 (error (TEXT "In class ~S, non-local slot ~S is constrained to be a local slot at offset ~S.") 1280 (class-name class) name location)) 1281 (setf (slot-definition-location slot) location)))))) 1282 (let ((constrained-indices 1283 (let ((constrained-slots (remove-if-not #'slot-definition-location slots))) 1284 (setq constrained-slots (copy-list constrained-slots)) 1285 (setq constrained-slots (sort constrained-slots #'< :key #'slot-definition-location)) 1286 (do ((l constrained-slots (cdr l))) 1287 ((null (cdr l))) 1288 (when (= (slot-definition-location (car l)) (slot-definition-location (cadr l))) 1289 (error (TEXT "In class ~S, the slots ~S and ~S are constrained from the superclasses to both be located at offset ~S.") 1290 (class-name class) 1291 (slot-definition-name (car l)) (slot-definition-name (cadr l)) 1292 (slot-definition-location (car l))))) 1293 (mapcar #'slot-definition-location constrained-slots))) 1294 (local-index (class-instance-size class)) 1295 (shared-index 0)) 1296 ;; Actually the constrained-indices must form a list of consecutive indices 1297 ;; (1 2 ... n), but we don't need to make use of this. 1298 ;; Now determine the location of each slot. 1299 (when (and constrained-indices (< (first constrained-indices) local-index)) 1300 (error (TEXT "In class ~S, a slot constrained from a superclass wants to be located at offset ~S, which is impossible.") 1301 (class-name class) (first constrained-indices))) 1302 (flet ((skip-constrained-indices () 1303 (loop 1304 (if (and constrained-indices 1305 (= (first constrained-indices) local-index)) 1306 (progn (incf local-index) (pop constrained-indices)) 1307 (return))))) 1308 (skip-constrained-indices) 1309 (dolist (slot slots) 1310 (let ((name (slot-definition-name slot)) 1311 (allocation (slot-definition-allocation slot))) 1312 (setf (slot-definition-location slot) 1313 (cond ((eq allocation ':instance) 1314 ;; Local slot. 1315 (or (slot-definition-location slot) 1316 (prog1 1317 local-index 1318 (incf local-index) 1319 (skip-constrained-indices)))) 1320 ((eq allocation ':class) 1321 ;; Shared slot. 1322 ;; This is a flaw in the compute-slots protocol: the 1323 ;; primary compute-slots method returns a list of slots, 1324 ;; without information about the class where the slot 1325 ;; comes from. So we have to re-scan the direct slots 1326 ;; lists. 1327 (let ((origin 1328 (dolist (superclass cpl class) 1329 (when (find name (class-direct-slots superclass) 1330 :key #'slot-definition-name) 1331 (return superclass))))) 1332 (if (eq origin class) 1333 ;; New shared slot. 1334 (prog1 1335 (cons (class-current-version class) shared-index) 1336 (incf shared-index)) 1337 ;; Inherited shared slot. 1338 (let ((inh-descriptor 1339 (gethash name (class-slot-location-table origin)))) 1340 (if (effective-slot-definition-p inh-descriptor) 1341 (slot-definition-location inh-descriptor) 1342 inh-descriptor))))) 1343 (t ;; Don't signal an error for user-defined allocation 1344 ;; types. They can be handled by user-defined around 1345 ;; methods. 1346 nil)))))) 1347 ;; Actually the constrained-indices must already have been emptied by 1348 ;; the first (skip-constrained-indices) call, but we don't need to make 1349 ;; use of this. Warn if :fixed-slot-locations would cause a waste of 1350 ;; space. 1351 (when constrained-indices 1352 (setq local-index (1+ (car (last constrained-indices)))) 1353 (clos-warning (TEXT "In class ~S, constrained slot locations cause holes to appear.") 1354 (class-name class))) 1355 slots))) 1356 1357;; Preliminary. 1358(predefun compute-slots (class) 1359 (compute-slots-<slotted-class>-around class #'compute-slots-<defined-class>-primary)) 1360 1361(defun checked-compute-slots (class) 1362 (let ((slots (compute-slots class))) 1363 ; Some checks, to guarantee that user-defined around methods on 1364 ; compute-slots don't break our CLOS. 1365 (unless (proper-list-p slots) 1366 (error (TEXT "Wrong ~S result for class ~S: not a proper list: ~S") 1367 'compute-slots (class-name class) slots)) 1368 (dolist (slot slots) 1369 (unless (standard-effective-slot-definition-p slot) 1370 (error (TEXT "Wrong ~S result for class ~S: list element is not a ~S: ~S") 1371 'compute-slots (class-name class) 1372 'standard-effective-slot-definition slot))) 1373 (unless (= (length slots) 1374 (length (delete-duplicates (mapcar #'slot-definition-name slots)))) 1375 (error (TEXT "Wrong ~S result for class ~S: list contains duplicate slot names: ~S") 1376 'compute-slots (class-name class) slots)) 1377 (dolist (slot slots) 1378 (case (slot-definition-allocation slot) 1379 ((:INSTANCE :CLASS) 1380 (unless (slot-definition-location slot) 1381 (error (TEXT "Wrong ~S result for class ~S: no slot location has been assigned to ~S") 1382 'compute-slots (class-name class) slot))))) 1383 slots)) 1384 1385;; The MOP lacks a way to customize the instance size as a function of the 1386;; slots. This becomes an issue when you have slots which occupy more than one 1387;; word, and such a slot is the last local slot. 1388(defun compute-instance-size (class) 1389 (let ((size (class-instance-size class))) ; initial size depends on the metaclass 1390 (dolist (slot (class-slots class)) 1391 (when (eq (slot-definition-allocation slot) ':instance) 1392 (let ((location (slot-definition-location slot))) 1393 (assert (integerp location)) 1394 (setq size (max size (+ location 1)))))) 1395 size)) 1396 1397;; Similarly, the MOP lacks a way to customize the shared slot values vector's 1398;; size as a function of the slots. 1399(defun compute-shared-size (class) 1400 (let ((shared-size 0)) 1401 (dolist (slot (class-slots class)) 1402 (let ((location (slot-definition-location slot))) 1403 (when (and (consp location) (eq (cv-newest-class (car location)) class)) 1404 (let ((shared-index (cdr location))) 1405 (setq shared-size (max shared-size (+ shared-index 1))))))) 1406 shared-size)) 1407 1408;; Creates the shared slot values vector for a class. 1409(defun create-shared-slots-vector (class shared-size old-slot-location-table) 1410 (let ((v (make-array shared-size :initial-element 'DEADBEEF))) 1411 (dolist (slot (class-slots class)) 1412 (let ((location (slot-definition-location slot))) 1413 (when (and (consp location) 1414 (eq (cv-newest-class (car location)) class)) 1415 (let ((shared-index (cdr location))) 1416 (setf (svref v shared-index) 1417 (let* ((old-slot-descriptor 1418 (gethash (slot-definition-name slot) old-slot-location-table)) 1419 (old-slot-location 1420 (if (effective-slot-definition-p old-slot-descriptor) 1421 (slot-definition-location old-slot-descriptor) 1422 old-slot-descriptor))) 1423 (if (and (consp old-slot-location) 1424 (eq (cv-newest-class (car old-slot-location)) class)) 1425 ;; The slot was already shared. Retain its value. 1426 (svref (cv-shared-slots (car old-slot-location)) 1427 (cdr old-slot-location)) 1428 ;; A new shared slot. 1429 (let ((initfunction (slot-definition-initfunction slot))) 1430 (if initfunction 1431 (funcall initfunction) 1432 (sys::%unbound)))))))))) 1433 v)) 1434 1435(defun compute-slot-location-table (class) 1436 (let ((slots (class-slots class))) 1437 (if slots 1438 (make-hash-table 1439 :key-type 'symbol :value-type 't 1440 :test 'ext:stablehash-eq :warn-if-needs-rehash-after-gc t 1441 :initial-contents 1442 (mapcar #'(lambda (slot) 1443 (cons (slot-definition-name slot) 1444 (compute-slot-location-table-entry class slot))) 1445 slots)) 1446 empty-ht))) 1447 1448(defun compute-slot-location-table-entry (class slot) 1449 (let ((location (slot-definition-location slot)) 1450 ;; Compute the effective methods of SLOT-VALUE-USING-CLASS etc. 1451 ;; Note that we cannot use (class-prototype class) yet. 1452 ;; Also, SLOT-VALUE-USING-CLASS etc. are not defined on STRUCTURE-CLASS. 1453 (efm-svuc 1454 (if (and (semi-standard-class-p class) *classes-finished*) 1455 (compute-applicable-methods-effective-method-for-set 1456 |#'slot-value-using-class| 1457 (list `(EQL ,class) `(INSTANCE-OF-P ,class) `(EQL ,slot)) 1458 (list class '`(CLASS-PROTOTYPE ,class) slot)) 1459 #'%slot-value-using-class)) 1460 (efm-ssvuc 1461 (if (and (semi-standard-class-p class) *classes-finished*) 1462 (compute-applicable-methods-effective-method-for-set 1463 |#'(setf slot-value-using-class)| 1464 (list `(TYPEP ,<t>) `(EQL ,class) `(INSTANCE-OF-P ,class) `(EQL ,slot)) 1465 (list 'ANY-VALUE class '`(CLASS-PROTOTYPE ,class) slot)) 1466 #'%set-slot-value-using-class)) 1467 (efm-sbuc 1468 (if (and (semi-standard-class-p class) *classes-finished*) 1469 (compute-applicable-methods-effective-method-for-set 1470 |#'slot-boundp-using-class| 1471 (list `(EQL ,class) `(INSTANCE-OF-P ,class) `(EQL ,slot)) 1472 (list class '`(CLASS-PROTOTYPE ,class) slot)) 1473 #'%slot-boundp-using-class)) 1474 (efm-smuc 1475 (if (and (semi-standard-class-p class) *classes-finished*) 1476 (compute-applicable-methods-effective-method-for-set 1477 |#'slot-makunbound-using-class| 1478 (list `(EQL ,class) `(INSTANCE-OF-P ,class) `(EQL ,slot)) 1479 (list class '`(CLASS-PROTOTYPE ,class) slot)) 1480 #'%slot-makunbound-using-class))) 1481 (setf (slot-definition-efm-svuc slot) efm-svuc) 1482 (setf (slot-definition-efm-ssvuc slot) efm-ssvuc) 1483 (setf (slot-definition-efm-sbuc slot) efm-sbuc) 1484 (setf (slot-definition-efm-smuc slot) efm-smuc) 1485 (if (and (eq efm-svuc #'%slot-value-using-class) 1486 (eq efm-ssvuc #'%set-slot-value-using-class) 1487 (eq efm-sbuc #'%slot-boundp-using-class) 1488 (eq efm-smuc #'%slot-makunbound-using-class)) 1489 location 1490 slot))) 1491 1492;; ---------------------------------------------------------------------------- 1493;; CLtL2 28.1.3.3., ANSI CL 4.3.4.2. Inheritance of Default-Initargs 1494 1495(defun compute-default-initargs-<defined-class> (class) 1496 (remove-duplicates 1497 (mapcap #'class-direct-default-initargs (class-precedence-list class)) 1498 :key #'car 1499 :from-end t)) 1500 1501;; Preliminary. 1502(predefun compute-default-initargs (class) 1503 (compute-default-initargs-<defined-class> class)) 1504 1505(defun checked-compute-default-initargs (class) 1506 (let ((default-initargs (compute-default-initargs class))) 1507 ; Some checks, to guarantee that user-defined methods on 1508 ; compute-default-initargs don't break our CLOS. 1509 (unless (proper-list-p default-initargs) 1510 (error (TEXT "Wrong ~S result for class ~S: not a proper list: ~S") 1511 'compute-default-initargs (class-name class) default-initargs)) 1512 (dolist (di default-initargs) 1513 (unless (canonicalized-default-initarg-p di) 1514 (error (TEXT "Wrong ~S result for class ~S: list element is not a canonicalized default initarg: ~S") 1515 'compute-default-initargs (class-name class) di))) 1516 (unless (= (length default-initargs) 1517 (length (delete-duplicates (mapcar #'first default-initargs)))) 1518 (error (TEXT "Wrong ~S result for class ~S: list contains duplicate initarg names: ~S") 1519 'compute-default-initargs (class-name class) default-initargs)) 1520 default-initargs)) 1521 1522;; ----------------------------- Accessor Methods ----------------------------- 1523 1524;; Flag to avoid bootstrapping issues with the compiler. 1525(defvar *compile-accessor-functions* nil) 1526 1527(defun check-method-redefinition (funname qualifiers spec-list caller) 1528 (sys::check-redefinition 1529 (list* funname qualifiers spec-list) caller 1530 ;; do not warn about redefinition when no method was defined 1531 (and (fboundp 'find-method) (fboundp funname) 1532 (typep-class (fdefinition funname) <generic-function>) 1533 (not (safe-gf-undeterminedp (fdefinition funname))) 1534 (eql (sig-req-num (safe-gf-signature (fdefinition funname))) 1535 (length spec-list)) 1536 (find-method (fdefinition funname) qualifiers spec-list nil) 1537 (TEXT "method")))) 1538 1539;; Install the accessor methods corresponding to the direct slots of a class. 1540(defun install-class-direct-accessors (class) 1541 (dolist (slot (class-direct-slots class)) 1542 (let ((slot-name (slot-definition-name slot)) 1543 (readers (slot-definition-readers slot)) 1544 (writers (slot-definition-writers slot))) 1545 (when (or readers writers) 1546 (let ((generic-p (class-generic-accessors class)) 1547 (access-place 1548 (let (effective-slot) 1549 (if (and (semi-standard-class-p class) 1550 (class-fixed-slot-locations class) 1551 (setq effective-slot 1552 (find slot-name (class-slots class) 1553 :key #'slot-definition-name)) 1554 (eq (slot-definition-allocation effective-slot) 1555 ':instance)) 1556 (progn 1557 (assert (typep (slot-definition-location effective-slot) 'integer)) 1558 `(STANDARD-INSTANCE-ACCESS OBJECT ,(slot-definition-location effective-slot))) 1559 (if (and (structure-class-p class) 1560 (setq effective-slot 1561 (find slot-name (class-slots class) 1562 :key #'slot-definition-name)) 1563 (eq (slot-definition-allocation effective-slot) 1564 ':instance)) 1565 (progn 1566 (assert (typep (slot-definition-location effective-slot) 'integer)) 1567 `(SYSTEM::%STRUCTURE-REF ',(class-name class) OBJECT ,(slot-definition-location effective-slot))) 1568 `(SLOT-VALUE OBJECT ',slot-name)))))) 1569 ;; Generic accessors are defined as methods and listed in the 1570 ;; direct-accessors list, so they can be removed upon class redefinition. 1571 ;; Non-generic accessors are defined as plain functions. 1572 ;; Call CHECK-REDEFINITION appropriately. 1573 (dolist (funname readers) 1574 (if generic-p 1575 (progn 1576 (check-method-redefinition funname nil (list class) 'defclass) 1577 (setf (class-direct-accessors class) 1578 (list* funname 1579 (do-defmethod funname 1580 (let* ((args 1581 (list 1582 :specializers (list class) 1583 :qualifiers nil 1584 :lambda-list '(OBJECT) 1585 'signature (sys::memoized (make-signature :req-num 1)) 1586 :slot-definition slot)) 1587 (method-class 1588 (apply #'reader-method-class 1589 class slot args))) 1590 (unless (and (defined-class-p method-class) 1591 (subclassp method-class <standard-reader-method>)) 1592 (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S") 1593 'reader-method-class (class-name class) 'standard-reader-method method-class)) 1594 (apply #'make-instance method-class 1595 (nconc (method-function-initargs 1596 method-class 1597 (eval 1598 `(LOCALLY (DECLARE (COMPILE 1599 ,funname)) 1600 (%OPTIMIZE-FUNCTION-LAMBDA 1601 (T) (#:CONTINUATION OBJECT) 1602 (DECLARE (COMPILE)) 1603 ,access-place)))) 1604 args)))) 1605 (class-direct-accessors class)))) 1606 (progn 1607 (sys::check-redefinition 1608 funname 'defclass (sys::fbound-string funname)) 1609 (setf (fdefinition funname) 1610 (eval `(FUNCTION ,funname (LAMBDA (OBJECT) 1611 ,@(if *compile-accessor-functions* 1612 `((DECLARE (COMPILE ,funname)))) 1613 (UNLESS (TYPEP OBJECT ',class) 1614 (ERROR-ACCESSOR-TYPECHECK ',funname OBJECT ',class)) 1615 ,access-place))))))) 1616 (dolist (funname writers) 1617 (if generic-p 1618 (progn 1619 (check-method-redefinition funname nil (list class) 'defclass) 1620 (setf (class-direct-accessors class) 1621 (list* funname 1622 (do-defmethod funname 1623 (let* ((args 1624 (list 1625 :specializers (list <t> class) 1626 :qualifiers nil 1627 :lambda-list '(NEW-VALUE OBJECT) 1628 'signature (sys::memoized (make-signature :req-num 2)) 1629 :slot-definition slot)) 1630 (method-class 1631 (apply #'writer-method-class 1632 class slot args))) 1633 (unless (and (defined-class-p method-class) 1634 (subclassp method-class <standard-writer-method>)) 1635 (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S") 1636 'writer-method-class 1637 (class-name class) 1638 'standard-writer-method method-class)) 1639 (apply #'make-instance method-class 1640 (nconc (method-function-initargs 1641 method-class 1642 (eval 1643 `(LOCALLY (DECLARE (COMPILE 1644 ,funname)) 1645 (%OPTIMIZE-FUNCTION-LAMBDA 1646 (T) (#:CONTINUATION NEW-VALUE OBJECT) 1647 (DECLARE (COMPILE)) 1648 (SETF ,access-place NEW-VALUE))))) 1649 args)))) 1650 (class-direct-accessors class)))) 1651 (progn 1652 (sys::check-redefinition 1653 funname 'defclass (sys::fbound-string 1654 (sys::get-funname-symbol funname))) 1655 (setf (fdefinition funname) 1656 (eval `(FUNCTION ,funname (LAMBDA (NEW-VALUE OBJECT) 1657 ,@(if *compile-accessor-functions* 1658 `((DECLARE (COMPILE ,funname)))) 1659 (UNLESS (TYPEP OBJECT ',class) 1660 (ERROR-ACCESSOR-TYPECHECK ',funname OBJECT ',class)) 1661 (SETF ,access-place NEW-VALUE))))))))))))) 1662 1663;; Remove a set of accessor methods given as a plist. 1664(defun remove-accessor-methods (plist) 1665 (do ((l plist (cddr l))) 1666 ((endp l)) 1667 (let ((funname (car l)) 1668 (method (cadr l))) 1669 (remove-method (fdefinition funname) method)))) 1670 1671;; Add a set of accessor methods given as a plist. 1672(defun add-accessor-methods (plist) 1673 (do ((l plist (cddr l))) 1674 ((endp l)) 1675 (let ((funname (car l)) 1676 (method (cadr l))) 1677 (add-method (fdefinition funname) method)))) 1678 1679;; --------------- Creation of an instance of <built-in-class> --------------- 1680 1681(defun make-instance-<built-in-class> (metaclass &rest args 1682 &key name (direct-superclasses '()) 1683 &allow-other-keys) 1684 ;; metaclass = <built-in-class> 1685 ;; Don't add functionality here! This is a preliminary definition that is 1686 ;; replaced with #'make-instance later. 1687 (declare (ignore metaclass name direct-superclasses)) 1688 (let ((class (allocate-metaobject-instance *<built-in-class>-class-version* 1689 *<built-in-class>-instance-size*))) 1690 (apply #'initialize-instance-<built-in-class> class args))) 1691 1692(defun initialize-instance-<built-in-class> (class &rest args 1693 &key &allow-other-keys) 1694 ;; Don't add functionality here! This is a preliminary definition that is 1695 ;; replaced with #'initialize-instance later. 1696 (apply #'shared-initialize-<built-in-class> class 't args) 1697 (install-class-direct-accessors class) 1698 class) 1699 1700(defun shared-initialize-<built-in-class> (class situation &rest args 1701 &key (name nil name-p) 1702 (direct-superclasses '() direct-superclasses-p) 1703 ((prototype prototype) nil prototype-p) 1704 &allow-other-keys) 1705 (when (or (eq situation 't) direct-superclasses-p) 1706 (check-metaclass-mix (if name-p name (class-classname class)) 1707 direct-superclasses 1708 #'built-in-class-p 'built-in-class)) 1709 (apply #'shared-initialize-<defined-class> class situation args) 1710 ; Initialize the remaining <defined-class> slots: 1711 (when (or (eq situation 't) direct-superclasses-p) 1712 (setf (class-precedence-list class) 1713 (checked-compute-class-precedence-list class)) 1714 (when (eq situation 't) 1715 (setf (class-initialized class) 3)) 1716 (setf (class-all-superclasses class) 1717 (std-compute-superclasses (class-precedence-list class))) 1718 (when (eq situation 't) 1719 (setf (class-initialized class) 4))) 1720 (when (eq situation 't) 1721 (setf (class-slots class) '()) 1722 (setf (class-initialized class) 5) 1723 (setf (class-default-initargs class) '()) 1724 (setf (class-initialized class) 6)) 1725 (when (or (eq situation 't) prototype-p) 1726 (setf (sys::%record-ref class *<built-in-class>-prototype-location*) prototype)) 1727 ; Done. 1728 class) 1729 1730;; --------------- Creation of an instance of <structure-class> --------------- 1731 1732(defun make-instance-<structure-class> (metaclass &rest args 1733 &key name (direct-superclasses '()) 1734 ;; The following keys come from ENSURE-CLASS. 1735 ((:direct-slots direct-slots-as-lists) '()) 1736 (direct-default-initargs '()) 1737 ;; The following keys come from DEFINE-STRUCTURE-CLASS. 1738 ((names names) nil) 1739 ((kconstructor kconstructor) nil) 1740 ((boa-constructors boa-constructors) '()) 1741 ((copier copier) nil) 1742 ((predicate predicate) nil) 1743 (documentation nil) 1744 ((direct-slots direct-slots-as-metaobjects) '()) 1745 ((slots slots) '()) ((size size) 1) 1746 &allow-other-keys) 1747 ;; metaclass = <structure-class> 1748 ;; Don't add functionality here! This is a preliminary definition that is 1749 ;; replaced with #'make-instance later. 1750 (declare (ignore metaclass name direct-superclasses direct-slots-as-lists 1751 direct-default-initargs documentation 1752 names kconstructor boa-constructors copier predicate 1753 direct-slots-as-metaobjects slots size)) 1754 (let ((class (allocate-metaobject-instance *<structure-class>-class-version* 1755 *<structure-class>-instance-size*))) 1756 (apply #'initialize-instance-<structure-class> class args))) 1757 1758(defun initialize-instance-<structure-class> (class &rest args 1759 &key &allow-other-keys) 1760 ;; Don't add functionality here! This is a preliminary definition that is 1761 ;; replaced with #'initialize-instance later. 1762 (apply #'shared-initialize-<structure-class> class 't args) 1763 ;; avoid slot accessor redefinition warning 1764 ;; (install-class-direct-accessors class) 1765 class) 1766 1767(defun shared-initialize-<structure-class> (class situation &rest args 1768 &key (name nil name-p) 1769 (direct-superclasses '() direct-superclasses-p) 1770 (generic-accessors t generic-accessors-p) 1771 ;; The following keys come from ENSURE-CLASS. 1772 ((:direct-slots direct-slots-as-lists) '() direct-slots-as-lists-p) 1773 (direct-default-initargs '() direct-default-initargs-p) 1774 ;; The following keys come from DEFINE-STRUCTURE-CLASS. 1775 (documentation nil documentation-p) 1776 ((names names) nil names-p) 1777 ((kconstructor kconstructor) nil kconstructor-p) 1778 ((boa-constructors boa-constructors) '() boa-constructors-p) 1779 ((copier copier) nil copier-p) 1780 ((predicate predicate) nil predicate-p) 1781 ((direct-slots direct-slots-as-metaobjects) '() direct-slots-as-metaobjects-p) 1782 ((slots slots) '()) 1783 ((size size) 1) 1784 &allow-other-keys) 1785 ;; metaclass ⊆ <structure-class> 1786 (declare (ignore generic-accessors generic-accessors-p direct-slots-as-lists 1787 direct-slots-as-metaobjects direct-default-initargs)) 1788 (when (or (eq situation 't) direct-superclasses-p) 1789 (check-metaclass-mix (if name-p name (class-classname class)) 1790 direct-superclasses 1791 #'structure-class-p 'STRUCTURE-CLASS)) 1792 (apply #'shared-initialize-<slotted-class> class situation args) 1793 (setq direct-superclasses (class-direct-superclasses class)) ; augmented 1794 ; Initialize the remaining <defined-class> slots: 1795 (when (or (eq situation 't) direct-superclasses-p) 1796 (setf (class-precedence-list class) 1797 (checked-compute-class-precedence-list class)) 1798 (when (eq situation 't) 1799 (setf (class-initialized class) 3)) 1800 (setf (class-all-superclasses class) 1801 (std-compute-superclasses (class-precedence-list class))) 1802 (when (eq situation 't) 1803 (setf (class-initialized class) 4))) 1804 (when (or (eq situation 't) direct-superclasses-p 1805 direct-slots-as-lists-p direct-slots-as-metaobjects-p) 1806 (setf (class-slots class) slots) 1807 (when (eq situation 't) 1808 (setf (class-initialized class) 5)) 1809 (setf (class-slot-location-table class) (compute-slot-location-table class)) 1810 (setf (class-instance-size class) size) 1811 (unless names 1812 (setf (class-instance-size class) 1) 1813 (setf (class-slots class) 1814 (compute-slots-<slotted-class>-around class #'compute-slots-<defined-class>-primary)) 1815 (setf (class-instance-size class) (max size (compute-instance-size class))) 1816 (when (class-slots class) 1817 (let ((ht (class-slot-location-table class))) 1818 (when (eq ht empty-ht) ; avoid clobbering empty-ht! 1819 (setq ht (setf (class-slot-location-table class) 1820 (make-hash-table 1821 :key-type 'symbol :value-type 't 1822 :test 'ext:stablehash-eq :warn-if-needs-rehash-after-gc t)))) 1823 (dolist (slot (class-slots class)) 1824 (setf (gethash (slot-definition-name slot) ht) 1825 (slot-definition-location slot))))) 1826 (when (plusp (compute-shared-size class)) 1827 (error-of-type 'error 1828 (TEXT "(~S ~S): metaclass ~S does not support shared slots") 1829 'DEFCLASS name 'STRUCTURE-CLASS)))) 1830 (when documentation-p 1831 (setf (class-documentation class) documentation)) 1832 (when (or (eq situation 't) direct-superclasses-p direct-default-initargs-p) 1833 (setf (class-default-initargs class) 1834 (checked-compute-default-initargs class))) 1835 (when (eq situation 't) 1836 (setf (class-initialized class) 6)) 1837 ; Initialize the remaining <slotted-class> slots: 1838 (when (or (eq situation 't) direct-superclasses-p) 1839 (setf (class-subclass-of-stablehash-p class) 1840 (std-compute-subclass-of-stablehash-p class))) 1841 (when (or (eq situation 't) direct-superclasses-p 1842 direct-slots-as-lists-p direct-slots-as-metaobjects-p) 1843 (setf (class-valid-initargs-from-slots class) 1844 (remove-duplicates (mapcap #'slot-definition-initargs (class-slots class))))) 1845 ; Initialize the remaining <structure-class> slots: 1846 (when (or (eq situation 't) direct-superclasses-p names-p) 1847 (unless names 1848 (setq names 1849 (cons name 1850 (if direct-superclasses 1851 (class-names (first direct-superclasses)) 1852 '())))) 1853 (setf (class-names class) names)) 1854 (when (or (eq situation 't) kconstructor-p) 1855 (setf (class-kconstructor class) kconstructor)) 1856 (when (or (eq situation 't) boa-constructors-p) 1857 (setf (class-boa-constructors class) boa-constructors)) 1858 (when (or (eq situation 't) copier-p) 1859 (setf (class-copier class) copier)) 1860 (when (or (eq situation 't) predicate-p) 1861 (setf (class-predicate class) predicate)) 1862 (when (eq situation 't) 1863 (setf (sys::%record-ref class *<structure-class>-prototype-location*) nil)) 1864 ; Done. 1865 (when (eq situation 't) 1866 (system::note-new-structure-class)) 1867 class) 1868 1869;; DEFSTRUCT-Hook 1870(defun define-structure-class (name names keyword-constructor boa-constructors copier predicate all-slots direct-slots documentation) ; ABI 1871 (setf (find-class name) 1872 (make-instance-<structure-class> <structure-class> 1873 :name name 1874 :direct-superclasses 1875 (if (cdr names) (list (find-class (second names))) '()) 1876 'names names 1877 'kconstructor keyword-constructor 1878 'boa-constructors boa-constructors 1879 'copier copier 1880 'predicate predicate 1881 'direct-slots direct-slots 1882 'slots all-slots 1883 'size (if all-slots 1884 (1+ (slot-definition-location (car (last all-slots)))) 1885 1) 1886 :generic-accessors nil 1887 :documentation documentation 1888 'clos::defclass-form 'defstruct))) 1889(defun undefine-structure-class (name) ; ABI 1890 (setf (find-class name) nil)) 1891 1892;; ------------- Creation of an instance of <semi-standard-class> ------------- 1893 1894(defun shared-initialize-<semi-standard-class> (class situation &rest args 1895 &key (direct-superclasses '() direct-superclasses-p) 1896 ((:direct-slots direct-slots-as-lists) '() direct-slots-as-lists-p) 1897 ((direct-slots direct-slots-as-metaobjects) '() direct-slots-as-metaobjects-p) 1898 (direct-default-initargs '() direct-default-initargs-p) 1899 (documentation nil documentation-p) 1900 (generic-accessors t generic-accessors-p) 1901 (fixed-slot-locations nil fixed-slot-locations-p) 1902 &allow-other-keys) 1903 (declare (ignore direct-superclasses direct-superclasses-p 1904 direct-slots-as-lists direct-slots-as-lists-p 1905 direct-slots-as-metaobjects direct-slots-as-metaobjects-p 1906 direct-default-initargs direct-default-initargs-p 1907 documentation documentation-p generic-accessors 1908 generic-accessors-p)) 1909 (apply #'shared-initialize-<slotted-class> class situation args) 1910 (when (eq situation 't) 1911 (setf (class-current-version class) 1912 (make-class-version :newest-class class 1913 :class class 1914 :serial 0)) 1915 (unless *classes-finished* 1916 ; Bootstrapping: Simulate the effect of #'%shared-initialize. 1917 (setf (class-instantiated class) nil) 1918 (setf (class-direct-instance-specializers-table class) '()) 1919 (setf (class-finalized-direct-subclasses-table class) '()))) 1920 ; Initialize the remaining <defined-class> slots: 1921 (setf (class-initialized class) 2) ; mark as not yet finalized 1922 (setf (class-precedence-list class) nil) ; mark as not yet finalized 1923 (setf (class-all-superclasses class) nil) ; mark as not yet finalized 1924 ; Initialize the remaining <slotted-class> slots: 1925 ; Initialize the remaining <semi-standard-class> slots: 1926 (when (or (eq situation 't) fixed-slot-locations-p) 1927 ;; Convert from list to boolean. 1928 (when (consp fixed-slot-locations) 1929 (setq fixed-slot-locations (car fixed-slot-locations))) 1930 (setf (class-fixed-slot-locations class) fixed-slot-locations)) 1931 (setf (class-prototype class) nil) 1932 ; Try to finalize it. 1933 (when (finalizable-p class) 1934 (finalize-inheritance class)) 1935 ; Done. 1936 class) 1937 1938;; ------------- Finalizing an instance of <semi-standard-class> ------------- 1939 1940;; Tests whether a class can be finalized, by recursing on the 1941;; direct-superclasses list. May call finalize-inheritance on some of the 1942;; superclasses. 1943;; Returns T if all the direct-superclasses could be finalized. 1944;; Returns NIL if this is not possible, and as second value a list from the 1945;; direct-superclass that couldn't be finalized up to the forward-reference 1946;; that is not yet defined. 1947(defun finalizable-p (class &optional (stack nil)) 1948 (assert (defined-class-p class)) 1949 (when (memq class stack) 1950 (error-of-type 'program-error 1951 (TEXT "~S: class definition circularity: ~S depends on itself") 1952 'defclass class)) 1953 (let ((stack (cons class stack))) 1954 (do ((superclassesr (class-direct-superclasses class) (cdr superclassesr))) 1955 ((endp superclassesr)) 1956 (let ((superclass (car superclassesr))) 1957 (unless (defined-class-p superclass) 1958 (unless (forward-reference-to-class-p superclass) 1959 (error (TEXT "~S has a direct-superclasses element ~S, which is invalid.") 1960 class superclass)) 1961 (let ((real-superclass 1962 (or (find-class (class-name superclass) nil) 1963 (return-from finalizable-p (values nil (list superclass)))))) 1964 ;; Changed from forward-reference-to-class to defined-class. 1965 (check-allowed-superclass class real-superclass) 1966 (setf (car superclassesr) real-superclass) 1967 (remove-direct-subclass superclass class) 1968 (add-direct-subclass real-superclass class) 1969 (setq superclass real-superclass))) 1970 (assert (defined-class-p superclass)) 1971 (unless (>= (class-initialized superclass) 6) ; not already finalized? 1972 ;; Here we get only for instances of STANDARD-CLASS, since instances 1973 ;; of BUILT-IN-CLASS and STRUCTURE-CLASS are already finalized when 1974 ;; they are constructed. 1975 (multiple-value-bind (done failure-cause) (finalizable-p superclass stack) 1976 (unless done 1977 ;; Finalization of a superclass was impossible. 1978 (return-from finalizable-p (values nil (cons superclass failure-cause))))) 1979 ;; Now finalize the superclass. (We could also do this later, from 1980 ;; inside finalize-inheritance, but then we would need some extra 1981 ;; bookkeeping to ensure that the running time for a class hierarchy 1982 ;; like this 1983 ;; A1 1984 ;; / \ 1985 ;; B1 C1 1986 ;; \ / 1987 ;; A2 1988 ;; / \ 1989 ;; B2 C2 1990 ;; \ / 1991 ;; A3 1992 ;; .... 1993 ;; A(n-1) 1994 ;; / \ 1995 ;; B(n-1) C(n-1) 1996 ;; \ / 1997 ;; An 1998 ;; is linear, not exponential, in the number of classes.) 1999 (finalize-inheritance superclass))))) 2000 t) 2001 2002;; Preliminary. 2003(predefun finalize-inheritance (class) 2004 (finalize-inheritance-<semi-standard-class> class)) 2005 2006(defun finalize-inheritance-<semi-standard-class> (class) 2007 (multiple-value-bind (done failure-cause) (finalizable-p class) 2008 (unless done 2009 (let ((pretty-cause (mapcar #'class-pretty (cons class failure-cause)))) 2010 (error (TEXT "~S: Cannot finalize class ~S. ~:{Class ~S inherits from class ~S. ~}Class ~S is not yet defined.") 2011 'finalize-inheritance (first pretty-cause) 2012 (mapcar #'list pretty-cause (rest pretty-cause)) 2013 (car (last pretty-cause)))))) 2014 ;; Now we know that all direct superclasses are finalized. 2015 (when (boundp 'class-finalized-p) 2016 (assert (every #'class-finalized-p (class-direct-superclasses class)))) 2017 ;; Now compute the class-precedence-list. 2018 (finalize-instance-semi-standard-class class) 2019 class) 2020 2021(defun finalize-instance-semi-standard-class (class 2022 &aux (direct-superclasses (class-direct-superclasses class)) 2023 (name (class-name class)) 2024 (old-slot-location-table (class-slot-location-table class))) 2025 ;; metaclass ⊆ <semi-standard-class> 2026 (if (standard-class-p class) 2027 (check-metaclass-mix name direct-superclasses 2028 #'standard-class-p 'STANDARD-CLASS) 2029 (check-metaclass-mix name direct-superclasses 2030 #'semi-standard-class-p 'SEMI-STANDARD-CLASS)) 2031 (setf (class-precedence-list class) 2032 (checked-compute-class-precedence-list class)) 2033 (when (< (class-initialized class) 3) 2034 (setf (class-initialized class) 3)) 2035 (setf (class-all-superclasses class) 2036 (std-compute-superclasses (class-precedence-list class))) 2037 (when (< (class-initialized class) 4) 2038 (setf (class-initialized class) 4)) 2039 (dolist (super direct-superclasses) 2040 (when (semi-standard-class-p super) 2041 (add-finalized-direct-subclass super class))) 2042 (setf (class-subclass-of-stablehash-p class) 2043 (std-compute-subclass-of-stablehash-p class)) 2044 (setf (class-funcallablep class) 2045 ; <funcallable-standard-object> or a subclass of it? 2046 (if (gethash <function> (class-all-superclasses class)) t nil)) 2047 (setf (class-instance-size class) 2048 (if (class-funcallablep class) 2049 3 ; see comments in clos-genfun1.lisp 2050 1)) ; slot 0 is the class_version pointer 2051 (setf (class-slots class) (checked-compute-slots class)) 2052 (when (< (class-initialized class) 5) 2053 (setf (class-initialized class) 5)) 2054 (setf (class-instance-size class) (compute-instance-size class)) 2055 (setf (class-slot-location-table class) (compute-slot-location-table class)) 2056 (let ((shared-size (compute-shared-size class))) 2057 (when (plusp shared-size) 2058 (setf (cv-shared-slots (class-current-version class)) 2059 (create-shared-slots-vector class shared-size old-slot-location-table)))) 2060 ;; CLtL2 28.1.3.3., ANSI CL 4.3.4.2. Inheritance of Class Options 2061 (setf (class-default-initargs class) (checked-compute-default-initargs class)) 2062 (setf (class-valid-initargs-from-slots class) 2063 (remove-duplicates (mapcap #'slot-definition-initargs (class-slots class)))) 2064 (when (< (class-initialized class) 6) 2065 (setf (class-initialized class) 6)) 2066 (system::note-new-standard-class)) 2067 2068;; ------------- Redefining an instance of <semi-standard-class> ------------- 2069 2070;; Preliminary definition. 2071(predefun make-instances-obsolete (class) 2072 (make-instances-obsolete-<semi-standard-class> class)) 2073 2074(defun make-instances-obsolete-<semi-standard-class> (class) 2075 (when (>= (class-initialized class) 6) ; nothing to do if not yet finalized 2076 ;; Recurse to the subclasses. (Even if there are no direct instances of 2077 ;; this class: the subclasses may have instances.) 2078 (mapc #'make-instances-obsolete-<semi-standard-class>-nonrecursive 2079 (list-all-finalized-subclasses class)))) 2080 2081(defun make-instances-obsolete-<semi-standard-class>-nonrecursive (class) 2082 (if (and (>= (class-initialized class) 4) ; already finalized? 2083 (subclassp class <metaobject>)) 2084 ; Don't obsolete metaobject instances. 2085 (let ((name (class-name class)) 2086 (caller *make-instances-obsolete-caller*) 2087 ;; Rebind *make-instances-obsolete-caller* because WARN may enter a 2088 ;; nested REP-loop. 2089 (*make-instances-obsolete-caller* 'make-instances-obsolete)) 2090 (clos-warning (TEXT "~S: Class ~S (or one of its ancestors) is being redefined, but its instances cannot be made obsolete") 2091 caller name)) 2092 (progn 2093 (when (class-instantiated class) ; don't warn if there are no instances 2094 (let ((name (class-name class)) 2095 (caller *make-instances-obsolete-caller*) 2096 ;; Rebind *make-instances-obsolete-caller* because WARN may enter a 2097 ;; nested REP-loop. 2098 (*make-instances-obsolete-caller* 'make-instances-obsolete)) 2099 (if (eq caller 'defclass) 2100 (clos-warn 'simple-class-obsolescence-warning (TEXT "~S: Class ~S (or one of its ancestors) is being redefined, instances are obsolete") 2101 caller name) 2102 (clos-warn 'simple-class-obsolescence-warning (TEXT "~S: instances of class ~S are made obsolete") 2103 caller name)))) 2104 ;; Create a new class-version. (Even if there are no instances: the 2105 ;; shared-slots may need change.) 2106 (let* ((copy (copy-standard-class class)) 2107 (old-version (class-current-version copy)) 2108 (new-version 2109 (make-class-version :newest-class class 2110 :class class 2111 :serial (1+ (cv-serial old-version))))) 2112 (setf (cv-class old-version) copy) 2113 (setf (cv-next old-version) new-version) 2114 (setf (class-current-version class) new-version))))) 2115 2116;; After a class redefinition, finalize the subclasses so that the instances 2117;; can be updated. 2118(defun update-subclasses-for-redefined-class (class was-finalized must-be-finalized old-direct-superclasses) 2119 (when was-finalized ; nothing to do if not finalized before the redefinition 2120 ;; Handle the class itself specially, because its superclasses list now is 2121 ;; not the same as before. 2122 (setf (class-initialized class) 2) ; mark as not yet finalized 2123 (setf (class-precedence-list class) nil) ; mark as not yet finalized 2124 (setf (class-all-superclasses class) nil) ; mark as not yet finalized 2125 (if must-be-finalized 2126 ;; The class remains finalized. 2127 (progn 2128 (finalize-inheritance class) 2129 (let ((new-direct-superclasses (class-direct-superclasses class))) 2130 (unless (equal old-direct-superclasses new-direct-superclasses) 2131 (let ((removed-direct-superclasses 2132 (set-difference old-direct-superclasses new-direct-superclasses)) 2133 (added-direct-superclasses 2134 (set-difference new-direct-superclasses old-direct-superclasses))) 2135 (dolist (super removed-direct-superclasses) 2136 (when (semi-standard-class-p super) 2137 (remove-finalized-direct-subclass super class))) 2138 (dolist (super added-direct-superclasses) 2139 (when (semi-standard-class-p super) 2140 (add-finalized-direct-subclass super class))))))) 2141 ;; The class becomes unfinalized. 2142 (dolist (super old-direct-superclasses) 2143 (when (semi-standard-class-p super) 2144 (remove-finalized-direct-subclass super class)))) 2145 ;; Now handle the true subclasses. 2146 (mapc #'update-subclasses-for-redefined-class-nonrecursive 2147 (rest (list-all-finalized-subclasses class))))) 2148 2149(defun update-subclasses-for-redefined-class-nonrecursive (class) 2150 (when (>= (class-initialized class) 6) ; nothing to do if not yet finalized 2151 (setf (class-initialized class) 2) ; mark as not yet finalized 2152 (setf (class-precedence-list class) nil) ; mark as not yet finalized 2153 (setf (class-all-superclasses class) nil) ; mark as not yet finalized 2154 (if (class-instantiated class) 2155 ;; The class remains finalized. 2156 (finalize-inheritance class) 2157 ;; The class becomes unfinalized. If it has an instantiated subclass, the 2158 ;; subclass' finalize-inheritance invocation will re-finalize this one. 2159 (dolist (super (class-direct-superclasses class)) 2160 (when (semi-standard-class-p super) 2161 (remove-finalized-direct-subclass super class)))))) 2162 2163;; After a class redefinition that changed the class-precedence-list, 2164;; update the generic functions that use specializers whose object is a 2165;; direct instance of this class or of a subclass. 2166(defun update-subclass-instance-specializer-generic-functions (class) 2167 (dolist (subclass (list-all-finalized-subclasses class)) 2168 ;; Since the CPL of the class has changed, the CPL of the subclass has 2169 ;; most likely changed as well. It is not worth testing whether it has 2170 ;; really changed. 2171 (dolist (specializer (list-direct-instance-specializers subclass)) 2172 ;; specializer's location in the type hierarchy has now changed. 2173 (dolist (gf (specializer-direct-generic-functions specializer)) 2174 (when (typep-class gf <standard-generic-function>) 2175 ;; Clear the discriminating function. 2176 ;; The effective method cache does not need to be invalidated. 2177 #|(setf (std-gf-effective-method-cache gf) '())|# 2178 (finalize-fast-gf gf)))))) 2179 2180;; After a class redefinition that changed the class-precedence-list, 2181;; update the generic functions that could be affected. 2182(defun update-subclass-cpl-specializer-generic-functions (class old-cpl new-cpl) 2183 ;; Class definitions change the type hierarchy, therefore the discriminating 2184 ;; function of some generic functions has to be invalidated and recomputed 2185 ;; later. 2186 ;; The effective method cache does not need to be invalidated, since it takes 2187 ;; a sorted method list as input and compute-effective-method-as-function 2188 ;; doesn't do computations in the type hierarchy. 2189 ;; 2190 ;; Now, which generic functions are affected? The discriminating function of 2191 ;; a generic depends on the following. (x denotes an object occurring as 2192 ;; argument, and x-class means (class-of x).) 2193 ;; 1. The computation of the applicable method list for given arguments x 2194 ;; depends on 2195 ;; (subclassp x-class specializer) 2196 ;; for all specializers occurring in methods of the GF. 2197 ;; 2. The discriminating function is also free to exploit the result of 2198 ;; (subclassp specializer1 specializer2) 2199 ;; for any two specializer1, specializer2 occurring in methods of the GF. 2200 ;; 3. The sorting of the applicable method list for given arguments x 2201 ;; depends on the relative order of specializer1 and specializer2 in 2202 ;; (cpl x-class), for any two specializer1, specializer2 occurring in 2203 ;; methods of the GF. 2204 ;; 2205 ;; What effects can a change of (cpl class) = old-cpl -> new-cpl have? 2206 ;; Assume that some classes S+ are added, some classes S- are removed from 2207 ;; the CPL, and some classes S* are reordered in the CPL. What effects does 2208 ;; this have on (cpl o-class), where o-class is any other class? 2209 ;; - If o-class is not a subclass of class, (cpl o-class) doesn't change. 2210 ;; - If o-class if subclass of class, 2211 ;; the elements of S+ are added or, if already present, possibly 2212 ;; reordered, 2213 ;; the elements of S- are possibly removed or reordered, 2214 ;; the elements of S* are possibly reordered. 2215 ;; ("Possibly" because o-class can also inherit from other classes that 2216 ;; are not under the given class but under elements of S+, S-, S*.) 2217 ;; 2218 ;; Now back to the problem of finding the affected generic functions. 2219 ;; 1. (subclassp x-class specializer) == (member specializer (cpl x-class)) 2220 ;; - doesn't change if x-class is not a subclass of class, 2221 ;; - doesn't change if specializer is not an element of S+ or S-. 2222 ;; Because of the implicit "for all x", we cannot exploit the first 2223 ;; statement. But the second statement tells us that we have to go 2224 ;; from the elements of S+ and S- to the methods and generic functions 2225 ;; using these classes as specializers. 2226 ;; 2. (subclassp specializer1 specializer2) 2227 ;; == (member specializer2 (cpl specializer1)) 2228 ;; - doesn't change if specializer1 is not a subclass of class, 2229 ;; - doesn't change if specializer2 is not an element of S+ or S-. 2230 ;; So we have to intersect 2231 ;; - the set of GFs using a subclass of class as specializer, 2232 ;; - the set of GFs using an element of S+ or S- as specializer. 2233 ;; This is a subset of the one we got in point 1. It is redundant. 2234 ;; 3. We know that if 2235 ;; old (cpl x-class) = (... specializer1 ... specializer2 ...) 2236 ;; and new (cpl x-class) = (... specializer2 ... specializer1 ...) 2237 ;; then x-class is a subclass of the given class, and one of 2238 ;; specializer1, specializer2 (at least) is a member of S+, S- or S*. 2239 ;; Because of the implicit "for all x", the first condition is hard to 2240 ;; exploit: we need to recurse through all x-class that are subclasses 2241 ;; the given class. It is easier to exploit the second condition: 2242 ;; Go from the elements of S+, S-, S* to the methods and generic functions 2243 ;; using these classes as specializers. 2244 ;; 2245 ;; Cf. MOP p. 41 compute-discriminating-function item (iv). This says that 2246 ;; all generic functions which use a specializer whose class precedence list 2247 ;; has changed (i.e. essentially a specializer which is a subclass of the 2248 ;; given class) should invalidate their discriminating function. This is not 2249 ;; needed! 2250 ;; 2251 ;; Cf. MOP p. 41 compute-discriminating-function item (v). This says that 2252 ;; all generic functions which have a cache entry containing a class whose 2253 ;; class precedence list has changed (i.e. essentially a subclass of the 2254 ;; given class) should invalidate their discriminating function. This is 2255 ;; also far more than is needed; all that's needed is 1. and 3. 2256 ;; 2257 (declare (ignore class)) 2258 (let* ((added-superclasses (set-difference new-cpl old-cpl)) 2259 (removed-superclasses (set-difference old-cpl new-cpl)) 2260 (permuted-superclasses 2261 (let ((common-superclasses-in-old-order 2262 (remove-if #'(lambda (x) (memq x removed-superclasses)) 2263 (the list old-cpl))) 2264 (common-superclasses-in-new-order 2265 (remove-if #'(lambda (x) (memq x added-superclasses)) 2266 (the list new-cpl)))) 2267 (assert (= (length common-superclasses-in-old-order) 2268 (length common-superclasses-in-new-order))) 2269 (subseq common-superclasses-in-old-order 2270 0 2271 (or (mismatch common-superclasses-in-old-order 2272 common-superclasses-in-new-order 2273 :test #'eq 2274 :from-end t) 2275 0))))) 2276 ;; Build the set of affected generic functions. 2277 (let ((gf-set 2278 (make-hash-table :key-type 'generic-function :value-type '(eql t) 2279 :test 'ext:fasthash-eq))) 2280 (dolist (specializer (append added-superclasses removed-superclasses 2281 permuted-superclasses)) 2282 (dolist (gf (specializer-direct-generic-functions specializer)) 2283 (setf (gethash gf gf-set) t))) 2284 #| 2285 (format *debug-io* "~&added = ~:S, removed = ~:S, permuted = ~:S, affected = ~:S~%" 2286 added-superclasses removed-superclasses permuted-superclasses 2287 (let ((l '())) 2288 (maphash #'(lambda (gf ignored) 2289 (declare (ignore ignored)) 2290 (push gf l)) 2291 gf-set) 2292 l)) 2293 |# 2294 ;; Clear their discriminating function. 2295 (maphash #'(lambda (gf ignored) 2296 (declare (ignore ignored)) 2297 (when (typep-class gf <standard-generic-function>) 2298 (finalize-fast-gf gf))) 2299 gf-set)))) 2300 2301;; Store the information needed by the update of obsolete instances in a 2302;; class-version object. Invoked when an instance needs to be updated. 2303(defun class-version-compute-slotlists (old-version) 2304 (let ((old-class (cv-class old-version)) 2305 (new-class (cv-class (cv-next old-version))) 2306 ; old-class is already finalized - otherwise no instance could exist. 2307 ; new-class is already finalized, because ensure-class guarantees it. 2308 (kept2 '()) 2309 (added '()) 2310 (discarded '()) 2311 (discarded2 '())) 2312 (dolist (old-slot (class-slots old-class)) 2313 (let* ((name (slot-definition-name old-slot)) 2314 (new-slot (find name (class-slots new-class) 2315 :test #'eq :key #'slot-definition-name))) 2316 (if (and new-slot (atom (slot-definition-location new-slot))) 2317 ;; Local slot remains local, or shared slot becomes local. 2318 (setq kept2 (list* (slot-definition-location old-slot) 2319 (slot-definition-location new-slot) 2320 kept2)) 2321 (if (atom (slot-definition-location old-slot)) 2322 ;; Local slot is discarded or becomes shared. 2323 (setq discarded (cons name discarded) 2324 discarded2 (list* name (slot-definition-location old-slot) discarded2)))))) 2325 (dolist (new-slot (class-slots new-class)) 2326 (let* ((name (slot-definition-name new-slot)) 2327 (old-slot (find name (class-slots old-class) 2328 :test #'eq :key #'slot-definition-name))) 2329 (unless old-slot 2330 ;; Newly added local slot. 2331 (setq added (cons name added))))) 2332 (setf (cv-kept-slot-locations old-version) kept2) 2333 (setf (cv-added-slots old-version) added) 2334 (setf (cv-discarded-slots old-version) discarded) 2335 (setf (cv-discarded-slot-locations old-version) discarded2) 2336 (setf (cv-slotlists-valid-p old-version) t))) 2337 2338;; -------------- Auxiliary functions for <semi-standard-class> -------------- 2339 2340;;; Maintaining the list of eql-specializers of direct instances that are or 2341;;; were used in a method. (We need this for notifying the generic functions 2342;;; to which these methods belong, when the class or a superclass of it is 2343;;; redefined in a way that changes the class-precedence-list.) 2344 2345#| 2346;; Adds a class to the list of direct instance specializers. 2347(defun add-direct-instance-specializer (class eql-specializer) ...) 2348;; Removes a class from the list of direct instance specializers. 2349(defun remove-direct-instance-specializer (class eql-specializer) ...) 2350;; Returns the currently existing direct instance specializers, as a freshly 2351;; consed list. 2352(defun list-direct-instance-specializers (class) ...) 2353|# 2354(def-weak-set-accessors class-direct-instance-specializers-table eql-specializer 2355 add-direct-instance-specializer 2356 remove-direct-instance-specializer 2357 list-direct-instance-specializers) 2358 2359;;; Maintaining the weak references to the finalized direct subclasses. 2360;;; (We need only the finalized subclasses, because: 2361;;; - The only use of these references is for make-instances-obsolete and for 2362;;; update-subclasses-for-redefined-class. 2363;;; - A non-finalized class cannot have instances. 2364;;; - Without an instance one cannot even access the shared slots.) 2365 2366;;; The finalized-direct-subclasses slot can be either 2367;;; - NIL or a weak-list (for saving memory when there are few subclasses), or 2368;;; - a weak-hash-table (for speed when there are many subclasses). 2369 2370#| 2371;; Adds a class to the list of direct subclasses. 2372(defun add-finalized-direct-subclass (class subclass) ...) 2373;; Removes a class from the list of direct subclasses. 2374(defun remove-finalized-direct-subclass (class subclass) ...) 2375;; Returns the currently existing direct subclasses, as a freshly consed list. 2376(defun list-finalized-direct-subclasses (class) ...) 2377|# 2378(def-weak-set-accessors class-finalized-direct-subclasses-table class 2379 add-finalized-direct-subclass 2380 remove-finalized-direct-subclass 2381 list-finalized-direct-subclasses) 2382 2383;; Returns the currently existing finalized subclasses, in top-down order, 2384;; including the class itself as first element. 2385(defun list-all-finalized-subclasses (class) 2386 ; Use a breadth-first search which removes duplicates. 2387 (let ((as-list '()) 2388 (as-set (make-hash-table :key-type 'defined-class :value-type '(eql t) 2389 :test 'ext:stablehash-eq :warn-if-needs-rehash-after-gc t 2390 :rehash-size 2s0)) 2391 (pending (list class))) 2392 (loop 2393 (unless pending (return)) 2394 (let ((new-pending '())) 2395 (dolist (class pending) 2396 (unless (gethash class as-set) 2397 (push class as-list) 2398 (setf (gethash class as-set) t) 2399 (setq new-pending 2400 (nreconc (if (semi-standard-class-p class) 2401 ; <semi-standard-class> stores the finalized direct-subclasses. 2402 (list-finalized-direct-subclasses class) 2403 ; <defined-class> stores only the complete direct-subclasses list. 2404 (remove-if-not #'(lambda (c) (= (class-initialized c) 6)) 2405 (checked-class-direct-subclasses class))) 2406 new-pending)))) 2407 (setq pending (nreverse new-pending)))) 2408 ;; Now reorder the list so that superclasses come before, not after, a 2409 ;; class. This is needed by update-subclasses-for-redefined-class. (It's 2410 ;; a "topological sorting" algorithm w.r.t. to the superclass relation.) 2411 (let ((tsorted-list '())) 2412 (labels ((add-with-superclasses-first (cls) 2413 (when (gethash cls as-set) 2414 (remhash cls as-set) 2415 (dolist (supercls (class-direct-superclasses cls)) 2416 (add-with-superclasses-first supercls)) 2417 (push cls tsorted-list)))) 2418 (mapc #'add-with-superclasses-first as-list)) 2419 (setq tsorted-list (nreverse tsorted-list)) 2420 (assert (eq (first tsorted-list) class)) 2421 tsorted-list))) 2422 2423;; --------------- Creation of an instance of <standard-class> --------------- 2424 2425(defun make-instance-<standard-class> (metaclass &rest args 2426 &key name 2427 (direct-superclasses '()) 2428 (direct-slots '()) 2429 (direct-default-initargs '()) 2430 &allow-other-keys) 2431 ;; metaclass = <standard-class> 2432 ;; Don't add functionality here! This is a preliminary definition that is 2433 ;; replaced with #'make-instance later. 2434 (declare (ignore metaclass name direct-superclasses direct-slots 2435 direct-default-initargs)) 2436 (let ((class (allocate-metaobject-instance *<standard-class>-class-version* 2437 *<standard-class>-instance-size*))) 2438 (apply #'initialize-instance-<standard-class> class args))) 2439 2440(defun initialize-instance-<standard-class> (class &rest args 2441 &key &allow-other-keys) 2442 ;; Don't add functionality here! This is a preliminary definition that is 2443 ;; replaced with #'initialize-instance later. 2444 (apply #'shared-initialize-<standard-class> class 't args) 2445 (install-class-direct-accessors class) 2446 class) 2447 2448(defun shared-initialize-<standard-class> (class situation &rest args 2449 &key (direct-superclasses '() direct-superclasses-p) 2450 ((:direct-slots direct-slots-as-lists) '() direct-slots-as-lists-p) 2451 ((direct-slots direct-slots-as-metaobjects) '() direct-slots-as-metaobjects-p) 2452 (direct-default-initargs '() direct-default-initargs-p) 2453 (documentation nil documentation-p) 2454 (generic-accessors t generic-accessors-p) 2455 (fixed-slot-locations nil fixed-slot-locations-p) 2456 &allow-other-keys) 2457 (declare (ignore direct-superclasses direct-superclasses-p 2458 direct-slots-as-lists direct-slots-as-lists-p 2459 direct-slots-as-metaobjects direct-slots-as-metaobjects-p 2460 direct-default-initargs direct-default-initargs-p 2461 documentation documentation-p generic-accessors 2462 generic-accessors-p fixed-slot-locations 2463 fixed-slot-locations-p)) 2464 (apply #'shared-initialize-<semi-standard-class> class situation args) 2465 class) 2466 2467;; --------------------------------------------------------------------------- 2468 2469;; Bootstrapping 2470(progn 2471 (setq <function> nil) 2472 2473 ;; 1. Define the class <t>. 2474 (setq <t> 2475 (make-instance-<built-in-class> nil 2476 :name 't 2477 :direct-superclasses '() 2478 'prototype (byte 1 0))) 2479 (setf (find-class 't) <t>) 2480 2481 ;; 2. Define the class <standard-object>. 2482 (setq <standard-object> 2483 (let ((*allow-mixing-metaclasses* t)) 2484 (make-instance-<standard-class> nil 2485 :name 'standard-object 2486 :direct-superclasses `(,<t>) 2487 :direct-slots '() 2488 :slots '() 2489 :slot-location-table empty-ht 2490 :instance-size 1 2491 :direct-default-initargs '() 2492 :default-initargs '()))) 2493 (setf (find-class 'standard-object) <standard-object>) 2494 2495 ;; 3. Define the class <metaobject>. 2496 (setq <metaobject> 2497 (macrolet ((form () *<metaobject>-defclass*)) 2498 (form))) 2499 2500 ;; 4. Define the class <standard-stablehash>. 2501 (macrolet ((form () *<standard-stablehash>-defclass*)) 2502 (form)) 2503 2504 ;; 5. Define the class <specializer>. 2505 (macrolet ((form () *<specializer>-defclass*)) 2506 (form)) 2507 2508 ;; 6. Define the classes <super-class>, <potential-class>. 2509 (macrolet ((form () *<super-class>-defclass*)) 2510 (form)) 2511 (setq <potential-class> 2512 (macrolet ((form () *<potential-class>-defclass*)) 2513 (form))) 2514 2515 ;; 7. Define the class <defined-class>. 2516 (setq <defined-class> 2517 (macrolet ((form () *<defined-class>-defclass*)) 2518 (form))) 2519 2520 ;; 8. Define the class <built-in-class>. 2521 (setq <built-in-class> 2522 (macrolet ((form () *<built-in-class>-defclass*)) 2523 (form))) 2524 (replace-class-version <built-in-class> 2525 *<built-in-class>-class-version*) 2526 2527 ;; 9. Define the classes <slotted-class>, <semi-standard-class>, 2528 ;; <standard-class>, <structure-class>. 2529 (macrolet ((form () *<slotted-class>-defclass*)) 2530 (form)) 2531 (setq <semi-standard-class> 2532 (macrolet ((form () *<semi-standard-class>-defclass*)) 2533 (form))) 2534 (setq <standard-class> 2535 (macrolet ((form () *<standard-class>-defclass*)) 2536 (form))) 2537 (replace-class-version <standard-class> 2538 *<standard-class>-class-version*) 2539 (setq <structure-class> 2540 (macrolet ((form () *<structure-class>-defclass*)) 2541 (form))) 2542 (replace-class-version <structure-class> 2543 *<structure-class>-class-version*) 2544 2545 ;; 10. Define the class <structure-object>. 2546 (setq <structure-object> 2547 (let ((*allow-mixing-metaclasses* t)) 2548 (make-instance-<structure-class> <structure-class> 2549 :name 'structure-object 2550 :direct-superclasses `(,<t>) 2551 :direct-slots '() 2552 :direct-default-initargs '() 2553 'names (list 'structure-object)))) 2554 (setf (find-class 'structure-object) <structure-object>) 2555 2556 ;; 11. Define other classes whose definition was delayed. 2557 2558 ;; Define the class <slot-definition>. 2559 (macrolet ((form () *<slot-definition>-defclass*)) 2560 (form)) 2561 2562 ;; Define the class <direct-slot-definition>. 2563 (setq <direct-slot-definition> 2564 (macrolet ((form () *<direct-slot-definition>-defclass*)) 2565 (form))) 2566 2567 ;; Define the class <effective-slot-definition>. 2568 (setq <effective-slot-definition> 2569 (macrolet ((form () *<effective-slot-definition>-defclass*)) 2570 (form))) 2571 2572 ;; Define the class <standard-slot-definition>. 2573 (macrolet ((form () *<standard-slot-definition>-defclass*)) 2574 (form)) 2575 2576 ;; Define the class <standard-direct-slot-definition>. 2577 (setq <standard-direct-slot-definition> 2578 (macrolet ((form () *<standard-direct-slot-definition>-defclass*)) 2579 (form))) 2580 (replace-class-version (find-class 'standard-direct-slot-definition) 2581 *<standard-direct-slot-definition>-class-version*) 2582 2583 ;; Define the class <standard-effective-slot-definition>. 2584 (setq <standard-effective-slot-definition> 2585 (macrolet ((form () *<standard-effective-slot-definition>-defclass*)) 2586 (form))) 2587 (replace-class-version (find-class 'standard-effective-slot-definition) 2588 *<standard-effective-slot-definition>-class-version*) 2589 2590 ;; Define the class <structure-direct-slot-definition>. 2591 (setq <structure-direct-slot-definition> 2592 (macrolet ((form () *<structure-direct-slot-definition>-defclass*)) 2593 (form))) 2594 (replace-class-version (find-class 'structure-direct-slot-definition) 2595 *<structure-direct-slot-definition>-class-version*) 2596 2597 ;; Define the class <structure-effective-slot-definition>. 2598 (setq <structure-effective-slot-definition> 2599 (macrolet ((form () *<structure-effective-slot-definition>-defclass*)) 2600 (form))) 2601 (replace-class-version (find-class 'structure-effective-slot-definition) 2602 *<structure-effective-slot-definition>-class-version*) 2603 2604 ;; Define the class <eql-specializer>. 2605 (setq <eql-specializer> 2606 (macrolet ((form () *<eql-specializer>-defclass*)) 2607 (form))) 2608 (replace-class-version (find-class 'eql-specializer) 2609 *<eql-specializer>-class-version*) 2610 2611 ;; Define the classes <forward-reference-to-class>, 2612 ;; <misdesigned-forward-referenced-class>. 2613 (setq <forward-reference-to-class> 2614 (macrolet ((form () *<forward-reference-to-class>-defclass*)) 2615 (form))) 2616 (setq <misdesigned-forward-referenced-class> 2617 (macrolet ((form () *<misdesigned-forward-referenced-class>-defclass*)) 2618 (form))) 2619 2620);progn 2621 2622;;; Install built-in classes: 2623;; See CLtL2 p. 783 table 28-1, ANSI CL 4.3.7. 2624(macrolet ((def (&rest classes) 2625 (setq classes (reverse classes)) 2626 (let* ((prototype-form (pop classes)) 2627 (new (pop classes)) 2628 (name (intern (string-trim "<>" (symbol-name new))))) 2629 `(setf (find-class ',name) 2630 (setq ,new 2631 (make-instance-<built-in-class> <built-in-class> 2632 :name ',name 2633 :direct-superclasses (list ,@classes) 2634 ,@(unless (eq prototype-form '-+-ABSTRACT-+-) 2635 `('prototype ,prototype-form)))))))) 2636 ;(def <t> (byte 1 0)) 2637 (def <t> <character> #\Space) 2638 (def <t> <function> #'cons) 2639 (def <t> <hash-table> empty-ht) 2640 (def <t> <package> (find-package "KEYWORD")) 2641 (def <t> <pathname> (make-pathname)) 2642 #+LOGICAL-PATHNAMES 2643 (def <pathname> <logical-pathname> (logical-pathname ":")) 2644 (def <t> <random-state> *random-state*) 2645 (def <t> <readtable> *readtable*) 2646 (def <t> <stream> -+-ABSTRACT-+-) 2647 (def <stream> <file-stream> (open *load-pathname* :direction :probe)) 2648 (def <stream> <synonym-stream> (make-synonym-stream '*terminal-io*)) 2649 (def <stream> <broadcast-stream> (make-broadcast-stream)) 2650 (def <stream> <concatenated-stream> (make-concatenated-stream)) 2651 (def <stream> <two-way-stream> (make-two-way-stream (make-concatenated-stream) (make-broadcast-stream))) 2652 (def <stream> <echo-stream> (make-echo-stream (make-concatenated-stream) (make-broadcast-stream))) 2653 (def <stream> <string-stream> (make-string-output-stream)) 2654 (def <t> <symbol> 't) 2655 (def <t> <sequence> -+-ABSTRACT-+-) 2656 (def <sequence> <list> -+-ABSTRACT-+-) 2657 (def <list> <cons> '(t)) 2658 (def <list> <symbol> <null> 'nil) 2659 (def <t> <array> '#2A()) 2660 (def <sequence> <array> <vector> '#()) 2661 (def <vector> <bit-vector> '#*) 2662 (def <vector> <string> "") 2663 (def <t> <number> -+-ABSTRACT-+-) 2664 (def <number> <complex> #c(3 4)) 2665 (def <number> <real> -+-ABSTRACT-+-) 2666 (def <real> <float> 1.0s0) 2667 (def <real> <rational> -+-ABSTRACT-+-) 2668 (def <rational> <ratio> 1/2) 2669 (def <rational> <integer> 0) 2670) 2671 2672;; Continue bootstrapping. 2673(%defclos 2674 ;; distinctive marks for CLASS-P 2675 *<standard-class>-class-version* 2676 *<structure-class>-class-version* 2677 *<built-in-class>-class-version* 2678 <defined-class> 2679 <potential-class> 2680 ;; built-in-classes for CLASS-OF - order in sync with constobj.d 2681 (vector <array> <bit-vector> <character> <complex> <cons> <float> <function> 2682 <hash-table> <integer> <list> <null> <package> <pathname> 2683 #+LOGICAL-PATHNAMES <logical-pathname> 2684 <random-state> <ratio> <readtable> 2685 <stream> <file-stream> <synonym-stream> <broadcast-stream> 2686 <concatenated-stream> <two-way-stream> <echo-stream> <string-stream> 2687 <string> <symbol> <t> <vector>)) 2688 2689;;; Intersection of two built-in-classes: 2690;; Deviations from the single-inheritance are only 2691;; (AND <sequence> <array>) = <vector> and (AND <list> <symbol>) = <null>. 2692(defun bc-p (class) 2693 (or (built-in-class-p class) 2694 (eq class <standard-object>) 2695 (eq class <structure-object>))) 2696(defun bc-and (class1 class2) ; returns (AND class1 class2) 2697 (cond ((subclassp class1 class2) class1) 2698 ((subclassp class2 class1) class2) 2699 ((or (and (subclassp <sequence> class1) (subclassp <array> class2)) 2700 (and (subclassp <sequence> class2) (subclassp <array> class1))) 2701 <vector>) 2702 ((or (and (subclassp <list> class1) (subclassp <symbol> class2)) 2703 (and (subclassp <list> class2) (subclassp <symbol> class1))) 2704 <null>) 2705 (t nil))) 2706(defun bc-and-not (class1 class2) ; returns a class c with 2707 ; (AND class1 (NOT class2)) <= c <= class1 2708 (cond ((subclassp class1 class2) nil) 2709 ((and (eq class1 <sequence>) (subclassp <vector> class2)) <list>) 2710 ((and (eq class1 <sequence>) (subclassp <list> class2)) <vector>) 2711 ((and (eq class1 <list>) (subclassp <null> class2)) <cons>) 2712 (t class1))) 2713