1;; -*- Lisp -*- vim:filetype=lisp 2;; Test some MOP-like CLOS features 3 4; Make the MOP symbols accessible from package CLOS. 5#-(or CLISP GCL ALLEGRO LISPWORKS) 6(let ((packname 7 #+SBCL "SB-PCL" ; or "SB-MOP"? 8 #+CMU "PCL" ; or "MOP"? 9 #+OpenMCL "OPENMCL-MOP" ; or "CCL" ? 10 )) 11 #+SBCL (unlock-package packname) 12 (rename-package packname packname (cons "CLOS" (package-nicknames packname))) 13 t) 14#-(or CLISP GCL ALLEGRO LISPWORKS) 15T 16 17#+ALLEGRO 18(without-package-locks 19 (import 'excl::compute-effective-slot-definition-initargs "CLOS") 20 (export 'excl::compute-effective-slot-definition-initargs "CLOS")) 21#+ALLEGRO 22T 23 24#+CMU 25(export 'pcl::compute-effective-slot-definition-initargs "PCL") 26#+CMU 27T 28 29#+SBCL 30(export 'sb-pcl::compute-effective-slot-definition-initargs "SB-PCL") 31#+SBCL 32T 33 34#+OpenMCL 35(progn 36 (import 'ccl::funcallable-standard-object "OPENMCL-MOP") 37 (export 'ccl::funcallable-standard-object "OPENMCL-MOP") 38 (import 'ccl::eql-specializer "OPENMCL-MOP") 39 (export 'ccl::eql-specializer "OPENMCL-MOP") 40 (import 'ccl::slot-definition "OPENMCL-MOP") 41 (export 'ccl::slot-definition "OPENMCL-MOP") 42 (import 'ccl::direct-slot-definition "OPENMCL-MOP") 43 (export 'ccl::direct-slot-definition "OPENMCL-MOP") 44 (import 'ccl::effective-slot-definition "OPENMCL-MOP") 45 (export 'ccl::effective-slot-definition "OPENMCL-MOP")) 46#+OpenMCL 47T 48 49#+LISPWORKS 50(progn 51 (export 'clos::compute-default-initargs "CLOS") 52 (export 'clos::compute-discriminating-function "CLOS") 53 (export 'clos::compute-effective-slot-definition-initargs "CLOS")) 54#+LISPWORKS 55T 56 57#+LISPWORKS 58(progn 59 (defun gc () (mark-and-sweep 3)) 60 t) 61#+LISPWORKS 62T 63 64#-(or ALLEGRO CMU18 OpenMCL LISPWORKS) 65(progn 66 (defstruct rectangle1 (x 0.0) (y 0.0)) 67 (defclass counted1-class (structure-class) 68 ((counter :initform 0))) 69 (defclass counted1-rectangle (rectangle1) () (:metaclass counted1-class)) 70 (defmethod make-instance :after ((c counted1-class) &rest args) 71 (incf (slot-value c 'counter))) 72 (slot-value (find-class 'counted1-rectangle) 'counter) 73 (make-instance 'counted1-rectangle) 74 (list (slot-value (find-class 'counted1-rectangle) 'counter) 75 (symbols-cleanup '(rectangle1 counted1-class counted1-rectangle)))) 76#-(or ALLEGRO CMU18 OpenMCL LISPWORKS) 77(1 ()) 78 79#-CMU18 80(progn 81 (defclass rectangle2 () 82 ((x :initform 0.0 :initarg x) (y :initform 0.0 :initarg y))) 83 (defclass counted2-class (standard-class) 84 ((counter :initform 0))) 85 #-CLISP 86 (defmethod clos:validate-superclass ((c1 counted2-class) (c2 standard-class)) 87 t) 88 (defclass counted2-rectangle (rectangle2) () (:metaclass counted2-class)) 89 (defmethod make-instance :after ((c counted2-class) &rest args) 90 (incf (slot-value c 'counter))) 91 (slot-value (find-class 'counted2-rectangle) 'counter) 92 (make-instance 'counted2-rectangle) 93 (list (slot-value (find-class 'counted2-rectangle) 'counter) 94 (symbols-cleanup '(rectangle2 counted2-class counted2-rectangle)))) 95#-CMU18 96(1 ()) 97 98(progn 99 (defclass counter () 100 ((count :allocation :class :initform 0 :reader how-many))) 101 (defclass counted-object (counter) ((name :initarg :name))) 102 (defmethod initialize-instance :after ((obj counter) &rest args) 103 (incf (slot-value obj 'count))) 104 (unless (clos:class-finalized-p (find-class 'counter)) 105 (clos:finalize-inheritance (find-class 'counter))) 106 (list (how-many (make-instance 'counted-object :name 'foo)) 107 (how-many (clos:class-prototype (find-class 'counter))) 108 (how-many (make-instance 'counted-object :name 'bar)) 109 (how-many (clos:class-prototype (find-class 'counter))) 110 #+CLISP (clos::gf-dynamically-modifiable #'how-many) 111 (symbols-cleanup '(counter counted-object how-many)))) 112(1 1 2 2 #+CLISP NIL ()) 113 114;; Check that the slot :accessor option works also on structure-class. 115#-(or ALLEGRO OpenMCL LISPWORKS) 116(progn 117 (defclass structure01 () ((x :initarg :x :accessor structure01-x)) 118 (:metaclass structure-class)) 119 (let ((object (make-instance 'structure01 :x 17))) 120 (list (typep #'structure01-x 'generic-function) 121 (structure01-x object) 122 (progn (incf (structure01-x object)) (structure01-x object)) 123 (symbols-cleanup '(structure01 structure01-x))))) 124#-(or ALLEGRO OpenMCL LISPWORKS) 125(t 17 18 ()) 126 127;; Check that defstruct and defclass interoperate with each other. 128#-(or ALLEGRO LISPWORKS) 129(progn 130 (defstruct structure02a 131 slot1 132 (slot2 t) 133 (slot3 (floor pi)) 134 #-(or CMU SBCL) (slot4 44)) 135 (defclass structure02b (structure02a) 136 ((slot4 :initform -44) 137 (slot5) 138 (slot6 :initform t) 139 (slot7 :initform (floor (* pi pi))) 140 (slot8 :initform 88)) 141 (:metaclass structure-class)) 142 (defstruct (structure02c (:include structure02b (slot8 -88))) 143 slot9 144 (slot10 t) 145 (slot11 (floor (exp 3)))) 146 (let ((a (make-structure02c)) 147 (b (make-instance 'structure02c))) 148 (list (structure02c-slot1 a) 149 (structure02c-slot2 a) 150 (structure02c-slot3 a) 151 (structure02c-slot4 a) 152 (structure02c-slot5 a) 153 (structure02c-slot6 a) 154 (structure02c-slot7 a) 155 (structure02c-slot8 a) 156 (structure02c-slot9 a) 157 (structure02c-slot10 a) 158 (structure02c-slot11 a) 159 ;(structure02c-slot1 b) ; may be #<UNBOUND> 160 (structure02c-slot2 b) 161 (structure02c-slot3 b) 162 (structure02c-slot4 b) 163 ;(structure02c-slot5 b) ; #<UNBOUND> 164 (structure02c-slot6 b) 165 (structure02c-slot7 b) 166 (structure02c-slot8 b) 167 ;(structure02c-slot9 b) ; may be #<UNBOUND> 168 (structure02c-slot10 b) 169 (structure02c-slot11 b) 170 (equalp a (copy-structure a)) 171 (equalp b (copy-structure b)) 172 (equalp a b) 173 (symbols-cleanup '(structure02a structure02b structure02c))))) 174#-(or ALLEGRO LISPWORKS) 175(nil t 3 -44 nil t 9 -88 nil t 20 176 t 3 -44 t 9 -88 t 20 177 t t nil ()) 178 179;; Check that defstruct and defclass interoperate with each other. 180#-(or ALLEGRO LISPWORKS) 181(progn 182 (defclass structure03a () 183 ((slot1) 184 (slot2 :initform t) 185 (slot3 :initform (floor pi)) 186 (slot4 :initform 44)) 187 (:metaclass structure-class)) 188 (defstruct (structure03b (:include structure03a (slot4 -44))) 189 slot5 190 (slot6 t) 191 (slot7 (floor (* pi pi))) 192 #-(or CMU SBCL) (slot8 88)) 193 (defclass structure03c (structure03b) 194 ((slot8 :initform -88) 195 (slot9) 196 (slot10 :initform t) 197 (slot11 :initform (floor (exp 3)))) 198 (:metaclass structure-class)) 199 (let ((b (make-instance 'structure03c))) 200 (list ;(slot-value b 'slot1) ; #<UNBOUND> 201 (slot-value b 'slot2) 202 (slot-value b 'slot3) 203 (slot-value b 'slot4) 204 ;(slot-value b 'slot5) ; may be #<UNBOUND> 205 (slot-value b 'slot6) 206 (slot-value b 'slot7) 207 (slot-value b 'slot8) 208 ;(slot-value b 'slot9) ; #<UNBOUND> 209 (slot-value b 'slot10) 210 (slot-value b 'slot11) 211 (equalp b (copy-structure b)) 212 (symbols-cleanup '(structure03a structure03b structure03c))))) 213#-(or ALLEGRO LISPWORKS) 214( t 3 -44 t 9 -88 t 20 215 t ()) 216 217;; Check that print-object can print all kinds of uninitialized metaobjects. 218(defun as-string (obj) 219 (let ((string (write-to-string obj :escape t :pretty nil))) 220 ;; For CLISP: Remove pattern #x[0-9A-F]* from it: 221 (let ((i (search "#x" string))) 222 (when i 223 (let ((j (or (position-if-not #'(lambda (c) (digit-char-p c 16)) string 224 :start (+ i 2)) 225 (length string)))) 226 (setq string (concatenate 'string (subseq string 0 i) (subseq string j)))))) 227 ;; For CMUCL, SBCL: Substitute {} for pattern {[0-9A-F]*} : 228 (do ((pos 0)) 229 (nil) 230 (let ((i (search "{" string :start2 pos))) 231 (unless i (return)) 232 (let ((j (position-if-not #'(lambda (c) (digit-char-p c 16)) string 233 :start (+ i 1)))) 234 (if (and j (eql (char string j) #\})) 235 (progn 236 (setq string (concatenate 'string (subseq string 0 (+ i 1)) (subseq string j))) 237 (setq pos (+ i 2))) 238 (setq pos (+ i 1)))))) 239 ;; For LISPWORKS: Substitute > for pattern [0-9A-F]{8}> : 240 (do ((pos 0)) 241 (nil) 242 (let ((i (search ">" string :start2 pos))) 243 (unless i (return)) 244 (if (and (>= (- i pos) 8) 245 (eql (position-if-not #'(lambda (c) (digit-char-p c 16)) string 246 :start (- i 8)) 247 i)) 248 (progn 249 (setq string (concatenate 'string (subseq string 0 (- i 8)) (subseq string i))) 250 (setq pos (+ (- i 8) 1))) 251 (setq pos (+ i 1))))) 252 string)) 253AS-STRING 254 255#-LISPWORKS 256(as-string (allocate-instance (find-class 'clos:specializer))) 257#+CLISP "#<SPECIALIZER >" 258#+ALLEGRO "#<ACLMOP:SPECIALIZER @ >" 259#+CMU "#<PCL:SPECIALIZER {}>" 260#+SBCL "#<SB-MOP:SPECIALIZER {}>" 261#+OpenMCL "#<SPECIALIZER >" 262#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 263 264#-OpenMCL 265(as-string (allocate-instance (find-class 'class))) 266#+CLISP "#<CLASS #<UNBOUND>>" 267#+ALLEGRO "#<CLASS \"Unnamed\" @ >" 268#+CMU "#<CLASS \"unbound\" {}>" 269#+SBCL "#<CLASS \"unbound\">" 270#+LISPWORKS "#<CLASS >" 271#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 272 273#-OpenMCL 274(as-string (allocate-instance (find-class 'standard-class))) 275#+CLISP "#<STANDARD-CLASS #<UNBOUND> :UNINITIALIZED>" 276#+ALLEGRO "#<STANDARD-CLASS \"Unnamed\" @ >" 277#+CMU "#<STANDARD-CLASS \"unbound\" {}>" 278#+SBCL "#<STANDARD-CLASS \"unbound\">" 279#+LISPWORKS "#<STANDARD-CLASS >" 280#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 281 282#-OpenMCL 283(as-string (allocate-instance (find-class 'structure-class))) 284#+CLISP "#<STRUCTURE-CLASS #<UNBOUND>>" 285#+ALLEGRO "#<STRUCTURE-CLASS \"Unnamed\" @ >" 286#+CMU "#<STRUCTURE-CLASS \"unbound\" {}>" 287#+SBCL "#<STRUCTURE-CLASS \"unbound\">" 288#+LISPWORKS "#<STRUCTURE-CLASS >" 289#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 290 291#-LISPWORKS 292(as-string (allocate-instance (find-class 'clos:eql-specializer))) 293#+CLISP "#<EQL-SPECIALIZER #<UNBOUND>>" 294#+ALLEGRO "#<ACLMOP:EQL-SPECIALIZER #<Printer Error, obj=: #<UNBOUND-SLOT @ #x>>>" 295#+CMU "#<PCL:EQL-SPECIALIZER {}>" 296#+SBCL "#<SB-MOP:EQL-SPECIALIZER {}>" 297#+OpenMCL "#<EQL-SPECIALIZER \"<unbound>\" >" 298#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 299 300#-OpenMCL 301(as-string (allocate-instance (find-class 'clos:slot-definition))) 302#+CLISP "#<SLOT-DEFINITION #<UNBOUND> >" 303#+ALLEGRO "#<ACLMOP:SLOT-DEFINITION @ >" 304#+CMU "#<SLOT-DEFINITION \"unbound\" {}>" 305#+SBCL "#<SB-MOP:SLOT-DEFINITION \"unbound\">" 306#+LISPWORKS "#<SLOT-DEFINITION >" 307#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 308 309#-OpenMCL 310(as-string (allocate-instance (find-class 'clos:direct-slot-definition))) 311#+CLISP "#<DIRECT-SLOT-DEFINITION #<UNBOUND> >" 312#+ALLEGRO "#<ACLMOP:DIRECT-SLOT-DEFINITION @ >" 313#+CMU "#<DIRECT-SLOT-DEFINITION \"unbound\" {}>" 314#+SBCL "#<SB-MOP:DIRECT-SLOT-DEFINITION \"unbound\">" 315#+LISPWORKS "#<DIRECT-SLOT-DEFINITION >" 316#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 317 318#-OpenMCL 319(as-string (allocate-instance (find-class 'clos:effective-slot-definition))) 320#+CLISP "#<EFFECTIVE-SLOT-DEFINITION #<UNBOUND> >" 321#+ALLEGRO "#<ACLMOP:EFFECTIVE-SLOT-DEFINITION @ >" 322#+CMU "#<EFFECTIVE-SLOT-DEFINITION \"unbound\" {}>" 323#+SBCL "#<SB-MOP:EFFECTIVE-SLOT-DEFINITION \"unbound\">" 324#+LISPWORKS "#<EFFECTIVE-SLOT-DEFINITION >" 325#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 326 327#-OpenMCL 328(as-string (allocate-instance (find-class 'clos:standard-direct-slot-definition))) 329#+CLISP "#<STANDARD-DIRECT-SLOT-DEFINITION #<UNBOUND> >" 330#+ALLEGRO "#<ACLMOP:STANDARD-DIRECT-SLOT-DEFINITION #<Printer Error, obj=: #<UNBOUND-SLOT @ #x>>>" 331#+CMU "#<STANDARD-DIRECT-SLOT-DEFINITION \"unbound\" {}>" 332#+SBCL "#<SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION \"unbound\">" 333#+LISPWORKS "#<STANDARD-DIRECT-SLOT-DEFINITION \"#< Unbound Slot >\" >" 334#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 335 336#-OpenMCL 337(as-string (allocate-instance (find-class 'clos:standard-effective-slot-definition))) 338#+CLISP "#<STANDARD-EFFECTIVE-SLOT-DEFINITION #<UNBOUND> >" 339#+ALLEGRO "#<ACLMOP:STANDARD-EFFECTIVE-SLOT-DEFINITION #<Printer Error, obj=: #<UNBOUND-SLOT @ #x>>>" 340#+CMU "#<STANDARD-EFFECTIVE-SLOT-DEFINITION \"unbound\" {}>" 341#+SBCL "#<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION \"unbound\">" 342#+LISPWORKS "#<STANDARD-EFFECTIVE-SLOT-DEFINITION \"#< Unbound Slot >\" >" 343#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 344 345#-OpenMCL 346(as-string (allocate-instance (find-class 'method-combination))) 347#+CLISP "#<METHOD-COMBINATION #<UNBOUND> >" 348#+ALLEGRO "#<METHOD-COMBINATION @ >" 349#+(or CMU SBCL) "#<METHOD-COMBINATION {}>" 350#+LISPWORKS "#<METHOD-COMBINATION NIL >" 351#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 352 353(as-string (allocate-instance (find-class 'method))) 354#+CLISP "#<METHOD >" 355#+ALLEGRO "#<METHOD @ >" 356#+(or CMU SBCL) "#<METHOD {}>" 357#+OpenMCL "#<METHOD >" 358#+LISPWORKS "#<METHOD >" 359#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 360 361#-OpenMCL 362(as-string (allocate-instance (find-class 'standard-method))) 363#+CLISP "#<STANDARD-METHOD :UNINITIALIZED>" 364#+ALLEGRO "#<Printer Error, obj=: #<UNBOUND-SLOT @ #x>>" 365#+CMU "#<#<STANDARD-METHOD {}> {}>" 366#+SBCL "#<STANDARD-METHOD #<STANDARD-METHOD {}> {}>" 367#+LISPWORKS "#<STANDARD-METHOD >" 368#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 369 370#-OpenMCL 371(as-string (allocate-instance (find-class 'clos:standard-reader-method))) 372#+CLISP "#<STANDARD-READER-METHOD :UNINITIALIZED>" 373#+ALLEGRO "#<Printer Error, obj=: #<UNBOUND-SLOT @ #x>>" 374#+CMU "#<#<#<PCL:STANDARD-READER-METHOD {}> {}> {}>" 375#+SBCL "#<SB-MOP:STANDARD-READER-METHOD #<SB-MOP:STANDARD-READER-METHOD #<SB-MOP:STANDARD-READER-METHOD {}> {}> {}>" 376#+LISPWORKS "#<STANDARD-READER-METHOD >" 377#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 378 379#-OpenMCL 380(as-string (allocate-instance (find-class 'clos:standard-writer-method))) 381#+CLISP "#<STANDARD-WRITER-METHOD :UNINITIALIZED>" 382#+ALLEGRO "#<Printer Error, obj=: #<UNBOUND-SLOT @ #x>>" 383#+CMU "#<#<#<PCL:STANDARD-WRITER-METHOD {}> {}> {}>" 384#+SBCL "#<SB-MOP:STANDARD-WRITER-METHOD #<SB-MOP:STANDARD-WRITER-METHOD #<SB-MOP:STANDARD-WRITER-METHOD {}> {}> {}>" 385#+LISPWORKS "#<STANDARD-WRITER-METHOD >" 386#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 387 388(as-string (allocate-instance (find-class 'clos:funcallable-standard-object))) 389#+CLISP "#<FUNCALLABLE-STANDARD-OBJECT #<UNBOUND>>" 390#+ALLEGRO "#<ACLMOP:FUNCALLABLE-STANDARD-OBJECT @ >" 391#+CMU "#<PCL:FUNCALLABLE-STANDARD-OBJECT {}>" 392#+SBCL "#<SB-MOP:FUNCALLABLE-STANDARD-OBJECT {}>" 393#+OpenMCL "#<CCL::FUNCALLABLE-STANDARD-OBJECT >" 394#+LISPWORKS "#<CLOS:FUNCALLABLE-STANDARD-OBJECT >" 395#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 396 397(as-string (allocate-instance (find-class 'generic-function))) 398#+CLISP "#<GENERIC-FUNCTION #<UNBOUND>>" 399#+ALLEGRO "#<GENERIC-FUNCTION #<Printer Error, obj=: #<PROGRAM-ERROR @ #x>>>" 400#+(or CMU SBCL) "#<GENERIC-FUNCTION {}>" 401#+OpenMCL "#<GENERIC-FUNCTION >" 402#+LISPWORKS "#<GENERIC-FUNCTION >" 403#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 404 405(as-string (allocate-instance (find-class 'standard-generic-function))) 406#+CLISP "#<STANDARD-GENERIC-FUNCTION #<UNBOUND>>" 407#+ALLEGRO "#<STANDARD-GENERIC-FUNCTION #<Printer Error, obj=: #<UNBOUND-SLOT @ #x>>>" 408#+CMU "#<STANDARD-GENERIC-FUNCTION \"unbound\" \"?\" {}>" 409#+SBCL "#<STANDARD-GENERIC-FUNCTION \"unbound\" \"?\">" 410#+OpenMCL "#<Anonymous STANDARD-GENERIC-FUNCTION >" 411#+LISPWORKS "#<STANDARD-GENERIC-FUNCTION >" 412#-(or CLISP ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN 413 414 415;; It is possible to redefine a class in a way that makes it non-finalized, 416;; if it was not yet instantiated. Fetching the class-prototype doesn't count 417;; as an instantiation. 418(progn 419 (defclass foo135b () ((s :initarg :s :accessor foo135b-s))) 420 (unless (clos:class-finalized-p (find-class 'foo135b)) 421 (clos:finalize-inheritance (find-class 'foo135b))) 422 (clos:class-prototype (find-class 'foo135b)) 423 (defclass foo135b (foo135a) ((s :accessor foo135b-s))) 424 (symbols-cleanup '(foo135b foo135b-s)) 425 t) 426T 427 428 429;; Check that the prototype of every non-abstract built-in class is correct. 430(let ((wrong '())) 431 (labels ((check-tree (c) 432 (unless (member (class-name c) 433 '(stream sequence list number real rational)) 434 (let ((p (clos:class-prototype c))) 435 (unless (eq (class-of p) c) (push (list c p) wrong)))) 436 (unless (or (member (find-class 'standard-object) (clos:class-precedence-list c)) 437 (member (find-class 'structure-object) (clos:class-precedence-list c))) 438 (mapc #'check-tree (clos:class-direct-subclasses c))))) 439 (check-tree (find-class 't)) 440 wrong)) 441NIL 442 443 444;; Check that undefined classes are treated as undefined, even though they 445;; are represented by a FORWARD-REFERENCED-CLASS. 446(progn 447 #+CLISP (setq custom:*forward-referenced-class-misdesign* t) 448 (defclass foo133 (forwardclass03) ()) 449 (defparameter *forwardclass* (first (clos:class-direct-superclasses (find-class 'foo133)))) 450 t) 451T 452(typep 1 *forwardclass*) 453ERROR 454(locally (declare (compile)) (typep 1 *forwardclass*)) 455ERROR 456(type-expand *forwardclass*) 457ERROR 458(subtypep *forwardclass* 't) 459ERROR 460(subtypep 'nil *forwardclass*) 461ERROR 462#+CLISP (sys::subtype-integer *forwardclass*) 463#+CLISP ERROR 464#+CLISP (sys::subtype-sequence *forwardclass*) 465#+CLISP NIL ; should also be ERROR 466(write-to-string *forwardclass* :readably t) 467ERROR 468(setf (find-class 'foo133a) *forwardclass*) 469ERROR 470(class-name *forwardclass*) 471FORWARDCLASS03 472(setf (class-name *forwardclass*) 'forwardclass03changed) 473ERROR 474(class-name *forwardclass*) 475FORWARDCLASS03 476(clos:class-direct-superclasses *forwardclass*) 477NIL 478(clos:class-direct-slots *forwardclass*) 479NIL 480(clos:class-direct-default-initargs *forwardclass*) 481NIL 482(clos:class-precedence-list *forwardclass*) 483ERROR 484(clos:class-slots *forwardclass*) 485ERROR 486(clos:class-default-initargs *forwardclass*) 487ERROR 488(clos:class-finalized-p *forwardclass*) 489NIL 490(clos:class-prototype *forwardclass*) 491ERROR 492(clos:finalize-inheritance *forwardclass*) 493ERROR 494(clos:class-finalized-p *forwardclass*) 495NIL 496(eval `(defmethod foo133a ((x ,*forwardclass*)))) 497ERROR 498(progn 499 (defgeneric foo133b (x) 500 (:method ((x integer)) x)) 501 (add-method #'foo133b 502 (make-instance 'standard-method 503 :qualifiers '() 504 :lambda-list '(x) 505 :specializers (list *forwardclass*) 506 :function #'(lambda (args next-methods) (first args)))) 507 #-CLISP (foo133b 7)) 508ERROR 509(not (not (typep *forwardclass* 'class))) 510T ; misdesign! 511#-LISPWORKS (not (not (typep *forwardclass* 'clos:specializer))) 512#-LISPWORKS T ; misdesign! 513(subtypep 'clos:forward-referenced-class 'class) 514T ; misdesign! 515#-LISPWORKS (subtypep 'clos:forward-referenced-class 'clos:specializer) 516#-LISPWORKS T ; misdesign! 517;; Same thing with opposite setting of *forward-referenced-class-misdesign*. 518(progn 519 #+CLISP (setq custom:*forward-referenced-class-misdesign* nil) 520 (defclass foo134 (forwardclass04) ()) 521 (defparameter *forwardclass* (first (clos:class-direct-superclasses (find-class 'foo134)))) 522 t) 523T 524(typep 1 *forwardclass*) 525ERROR 526(locally (declare (compile)) (typep 1 *forwardclass*)) 527ERROR 528(type-expand *forwardclass*) 529ERROR 530(subtypep *forwardclass* 't) 531ERROR 532(subtypep 'nil *forwardclass*) 533ERROR 534#+CLISP (sys::subtype-integer *forwardclass*) 535#+CLISP ERROR 536#+CLISP (sys::subtype-sequence *forwardclass*) 537#+CLISP NIL ; should also be ERROR 538(write-to-string *forwardclass* :readably t) 539ERROR 540(setf (find-class 'foo134a) *forwardclass*) 541ERROR 542(class-name *forwardclass*) 543FORWARDCLASS04 544(setf (class-name *forwardclass*) 'forwardclass04changed) 545ERROR 546(class-name *forwardclass*) 547FORWARDCLASS04 548(clos:class-direct-superclasses *forwardclass*) 549NIL 550(clos:class-direct-slots *forwardclass*) 551NIL 552(clos:class-direct-default-initargs *forwardclass*) 553NIL 554(clos:class-precedence-list *forwardclass*) 555ERROR 556(clos:class-slots *forwardclass*) 557ERROR 558(clos:class-default-initargs *forwardclass*) 559ERROR 560(clos:class-finalized-p *forwardclass*) 561NIL 562(clos:class-prototype *forwardclass*) 563ERROR 564(clos:finalize-inheritance *forwardclass*) 565ERROR 566(clos:class-finalized-p *forwardclass*) 567NIL 568(eval `(defmethod foo134a ((x ,*forwardclass*)))) 569ERROR 570(progn 571 (defgeneric foo134b (x) 572 (:method ((x integer)) x)) 573 (add-method #'foo134b 574 (make-instance 'standard-method 575 :qualifiers '() 576 :lambda-list '(x) 577 :specializers (list *forwardclass*) 578 :function #'(lambda (args next-methods) (first args)))) 579 #-CLISP (foo134b 7)) 580ERROR 581(not (not (typep *forwardclass* 'class))) 582#+CLISP NIL 583#-CLISP T ; misdesign! 584#-LISPWORKS (not (not (typep *forwardclass* 'clos:specializer))) 585#+CLISP NIL 586#-(or CLISP LISPWORKS) T ; misdesign! 587(subtypep 'clos:forward-referenced-class 'class) 588#+CLISP NIL 589#-CLISP T ; misdesign! 590#-LISPWORKS (subtypep 'clos:forward-referenced-class 'clos:specializer) 591#+CLISP NIL 592#-(or CLISP LISPWORKS) T ; misdesign! 593 594 595;; Funcallable instances 596 597; Check set-funcallable-instance-function with a SUBR. 598#-LISPWORKS 599(let ((f (make-instance 'clos:funcallable-standard-object))) 600 (clos:set-funcallable-instance-function f #'cons) 601 (funcall f 'a 'b)) 602#-LISPWORKS 603(A . B) 604 605; Check set-funcallable-instance-function with a small compiled-function. 606#-LISPWORKS 607(let ((f (make-instance 'clos:funcallable-standard-object))) 608 (clos:set-funcallable-instance-function f #'(lambda (x y) (declare (compile)) (cons x y))) 609 (funcall f 'a 'b)) 610#-LISPWORKS 611(A . B) 612 613; Check set-funcallable-instance-function with a large compiled-function. 614#-LISPWORKS 615(let ((f (make-instance 'clos:funcallable-standard-object))) 616 (clos:set-funcallable-instance-function f #'(lambda (x y) (declare (compile)) (list 'start x y 'end))) 617 (funcall f 'a 'b)) 618#-LISPWORKS 619(START A B END) 620 621; Check set-funcallable-instance-function with an interpreted function. 622#-LISPWORKS 623(let ((f (make-instance 'clos:funcallable-standard-object))) 624 (clos:set-funcallable-instance-function f #'(lambda (x y) (cons x y))) 625 (funcall f 'a 'b)) 626#-LISPWORKS 627(A . B) 628 629; Check set-funcallable-instance-function with a generic. 630#-LISPWORKS 631(let ((f (make-instance 'clos:funcallable-standard-object))) 632 (defgeneric test-funcallable-01 (x y) 633 (:method (x y) (cons x y))) 634 (clos:set-funcallable-instance-function f #'test-funcallable-01) 635 (list (funcall f 'a 'b) 636 (symbol-cleanup 'test-funcallable-01))) 637#-LISPWORKS 638((A . B) T) 639 640 641;; Check that changing the class of a generic function works. 642;; MOP p. 61 doesn't allow this, but CLISP supports it as an extension. 643 644(progn 645 (defclass my-gf-class (standard-generic-function) 646 ((myslot :initform 17 :accessor my-myslot)) 647 (:metaclass clos:funcallable-standard-class)) 648 t) 649T 650 651#-OpenMCL 652(progn 653 (defgeneric foo110 (x)) 654 (defmethod foo110 ((x integer)) (* x x)) 655 (defgeneric foo110 (x) (:generic-function-class my-gf-class)) 656 (defmethod foo110 ((x float)) (* x x x)) 657 (list (foo110 10) (foo110 3.0) (my-myslot #'foo110) (symbol-cleanup 'foo110))) 658#-OpenMCL 659(100 27.0 17 T) 660 661; Also check that the GC cleans up forward pointers. 662 663#-OpenMCL 664(progn 665 (defgeneric foo111 (x)) 666 (defmethod foo111 ((x integer)) (* x x)) 667 (defgeneric foo111 (x) (:generic-function-class my-gf-class)) 668 (gc) 669 (defmethod foo111 ((x float)) (* x x x)) 670 (list (foo111 10) (foo111 3.0) (my-myslot #'foo111) 671 #+CLISP (eq (sys::%record-ref #'foo111 0) 672 (clos::class-current-version (find-class 'my-gf-class))) 673 (symbol-cleanup 'foo111))) 674#-OpenMCL 675(100 27.0 17 #+CLISP T T) 676 677#-OpenMCL 678(progn 679 (defgeneric foo112 (x)) 680 (defmethod foo112 ((x integer)) (* x x)) 681 (defgeneric foo112 (x) (:generic-function-class my-gf-class)) 682 (defmethod foo112 ((x float)) (* x x x)) 683 (gc) 684 (list (foo112 10) (foo112 3.0) (my-myslot #'foo112) 685 #+CLISP (eq (sys::%record-ref #'foo112 0) 686 (clos::class-current-version (find-class 'my-gf-class))) 687 (symbol-cleanup 'foo112))) 688#-OpenMCL 689(100 27.0 17 #+CLISP T T) 690 691 692;; Check that ensure-generic-function supports both :DECLARE (ANSI CL) 693;; and :DECLARATIONS (MOP). 694 695(progn 696 (ensure-generic-function 'foo113 :declare '((optimize (speed 3)))) 697 (list (clos:generic-function-declarations #'foo113) (symbol-cleanup 'foo113))) 698(((OPTIMIZE (SPEED 3))) T) 699 700(progn 701 (ensure-generic-function 'foo114 :declarations '((optimize (speed 3)))) 702 (list (clos:generic-function-declarations #'foo114) (symbol-cleanup 'foo114))) 703(((OPTIMIZE (SPEED 3))) T) 704 705 706;; Check that ensure-generic-function without :lambda-list argument works. 707(progn 708 (ensure-generic-function 'foo115) 709 (defmethod foo115 (x y) (list x y)) 710 (list (foo115 3 4) (symbol-cleanup 'foo115))) 711((3 4) T) 712 713 714;; Check that defclass supports user-defined options. 715(progn 716 (defclass option-class (standard-class) 717 ((option :accessor cl-option :initarg :my-option))) 718 #-CLISP 719 (defmethod clos:validate-superclass ((c1 option-class) (c2 standard-class)) 720 t) 721 (macrolet ((eval-succeeds (form) 722 `(not (nth-value 1 (ignore-errors (eval ',form)))))) 723 (list (eval-succeeds 724 (defclass testclass02a () 725 () 726 (:my-option foo) 727 (:metaclass option-class))) 728 (cl-option (find-class 'testclass02a)) 729 (eval-succeeds 730 (defclass testclass02b () 731 () 732 (:my-option bar) 733 (:my-option baz) 734 (:metaclass option-class))) 735 (eval-succeeds 736 (defclass testclass02c () 737 () 738 (:other-option foo) 739 (:metaclass option-class))) 740 (symbols-cleanup '(option-class testclass02a testclass02b testclass02c))))) 741(T (FOO) NIL NIL ()) 742 743 744;; Check that defclass supports user-defined slot options. 745(progn 746 (defclass option-slot-definition (clos:standard-direct-slot-definition) 747 ((option :accessor sl-option :initarg :my-option))) 748 (defclass option-slot-class (standard-class) 749 ()) 750 (defmethod clos:direct-slot-definition-class ((c option-slot-class) &rest args) 751 (declare (ignore args)) 752 (find-class 'option-slot-definition)) 753 #-CLISP 754 (defmethod clos:validate-superclass ((c1 option-slot-class) (c2 standard-class)) 755 t) 756 (macrolet ((eval-succeeds (form) 757 `(not (nth-value 1 (ignore-errors (eval ',form)))))) 758 (list (eval-succeeds 759 (defclass testclass03a () 760 ((x :my-option foo)) 761 (:metaclass option-slot-class))) 762 (sl-option (first (clos:class-direct-slots (find-class 'testclass03a)))) 763 (eval-succeeds 764 (defclass testclass03b () 765 ((x :my-option bar :my-option baz)) 766 (:metaclass option-slot-class))) 767 (sl-option (first (clos:class-direct-slots (find-class 'testclass03b)))) 768 (eval-succeeds 769 (defclass testclass03c () 770 ((x :other-option foo)) 771 (:metaclass option-slot-class))) 772 (eval-succeeds 773 (defclass testclass03d () 774 ((x :my-option foo)) 775 (:my-option bar) 776 (:metaclass option-slot-class))) 777 (symbols-cleanup '(option-slot-definition option-slot-class 778 testclass03a testclass03b testclass03c testclass03d))))) 779(T FOO T (BAR BAZ) NIL NIL ()) 780 781;; Check that after a class redefinition, new user-defined direct slots 782;; have replaced the old direct slots. 783(progn 784 (defclass extended-slot-definition (clos:standard-direct-slot-definition) 785 ((option1 :initarg :option1) 786 (option2 :initarg :option2))) 787 (defclass extended-slot-class (standard-class) 788 ()) 789 (defmethod clos:direct-slot-definition-class ((c extended-slot-class) &rest args) 790 (declare (ignore args)) 791 (find-class 'extended-slot-definition)) 792 #-CLISP 793 (defmethod clos:validate-superclass ((c1 extended-slot-class) (c2 standard-class)) 794 t) 795 (defclass testclass03e () ((x :option1 bar)) (:metaclass extended-slot-class)) 796 (defclass testclass03e () ((x :option2 baz)) (:metaclass extended-slot-class)) 797 (let ((cl (find-class 'testclass03e))) 798 (list (length (clos:class-direct-slots cl)) 799 (slot-boundp (first (clos:class-direct-slots cl)) 'option1) 800 (slot-boundp (first (clos:class-direct-slots cl)) 'option2) 801 (symbols-cleanup '(extended-slot-definition extended-slot-class 802 testclass03e))))) 803(1 NIL T ()) 804 805 806;; Check that in defclass, the default-initargs of the metaclass have 807;; precedence over the usual defaults. 808(progn 809 (defclass testclass51 (standard-class) 810 () 811 (:default-initargs 812 :documentation "some doc")) 813 #-CLISP 814 (defmethod clos:validate-superclass ((c1 testclass51) (c2 standard-class)) 815 t) 816 (list 817 (mapcar #'(lambda (x) (documentation x 'type)) 818 (list 819 (defclass testclass51a () ()) 820 (defclass testclass51b () () 821 (:metaclass testclass51)) 822 (defclass testclass51c () () 823 (:documentation "some other doc") 824 (:metaclass testclass51)))) 825 (symbols-cleanup '(testclass51 testclass51a testclass51b testclass51c)))) 826((NIL "some doc" "some other doc") ()) 827 828 829;; Check that defgeneric supports user-defined options. 830#-(or ALLEGRO CMU SBCL OpenMCL LISPWORKS) 831(progn 832 (defclass option-generic-function (standard-generic-function) 833 ((option :accessor gf-option :initarg :my-option)) 834 (:metaclass clos:funcallable-standard-class)) 835 (macrolet ((eval-succeeds (form) 836 `(not (nth-value 1 (ignore-errors (eval ',form)))))) 837 (list (eval-succeeds 838 (defgeneric testgf04a (x y) 839 (:my-option foo) 840 (:generic-function-class option-generic-function))) 841 (gf-option #'testgf04a) 842 (eval-succeeds 843 (defgeneric testgf04b (x y) 844 (:my-option bar) 845 (:my-option baz) 846 (:generic-function-class option-generic-function))) 847 (eval-succeeds 848 (defgeneric testgf04c (x y) 849 (:my-option bar) 850 (:other-option baz) 851 (:generic-function-class option-generic-function))) 852 (symbols-cleanup '(option-generic-function testgf04a testgf04b testgf04c))))) 853#-(or ALLEGRO CMU SBCL OpenMCL LISPWORKS) 854(T (FOO) NIL NIL ()) 855 856 857;; Check that in defgeneric, the default-initargs of the generic-function-class 858;; have precedence over the usual defaults. 859(progn 860 (defclass testmethod50 (standard-method) 861 ()) 862 (defclass testgenericfunction50 (standard-generic-function) 863 () 864 (:default-initargs 865 :method-class (find-class 'testmethod50)) 866 (:metaclass clos:funcallable-standard-class)) 867 (list 868 (mapcar #'class-name 869 (mapcar #'clos:generic-function-method-class 870 (list 871 (defgeneric testgf50a (x)) 872 (defgeneric testgf50b (x) 873 (:generic-function-class testgenericfunction50)) 874 (defgeneric testgf50c (x) 875 (:method-class standard-method) 876 (:generic-function-class testgenericfunction50)) 877 (defgeneric testgf50d (x) 878 (:method-class testmethod50) 879 (:generic-function-class testgenericfunction50))))) 880 (symbols-cleanup '(testmethod50 testgenericfunction50 881 testgf50a testgf50b testgf50c testgf50d)))) 882((STANDARD-METHOD TESTMETHOD50 STANDARD-METHOD TESTMETHOD50) ()) 883#| 884; Same thing with generic-flet. 885(progn 886 (defclass testmethod51 (standard-method) 887 ()) 888 (defclass testgenericfunction51 (standard-generic-function) 889 () 890 (:default-initargs 891 :method-class (find-class 'testmethod51)) 892 (:metaclass clos:funcallable-standard-class)) 893 (mapcar #'class-name 894 (mapcar #'clos:generic-function-method-class 895 (list 896 (generic-flet ((testgf (x))) 897 #'testgf) 898 (generic-flet ((testgf (x) 899 (:generic-function-class testgenericfunction51))) 900 #'testgf) 901 (generic-flet ((testgf (x) 902 (:method-class standard-method) 903 (:generic-function-class testgenericfunction51))) 904 #'testgf) 905 (generic-flet ((testgf (x) 906 (:method-class testmethod51) 907 (:generic-function-class testgenericfunction51))) 908 #'testgf))))) 909(STANDARD-METHOD TESTMETHOD50 STANDARD-METHOD TESTMETHOD50) 910|# 911 912 913;; Check dependents notification on classes. 914(progn 915 (defclass dependent05 () ((counter :initform 0))) 916 (defclass testclass05 () ()) 917 (defmethod clos:update-dependent ((c class) (d dependent05) &rest args) 918 (incf (slot-value d 'counter))) 919 (let ((testclass (find-class 'testclass05)) 920 (dep1 (make-instance 'dependent05)) 921 (dep2 (make-instance 'dependent05)) 922 (dep3 (make-instance 'dependent05))) 923 (clos:add-dependent testclass dep1) 924 (clos:add-dependent testclass dep2) 925 (clos:add-dependent testclass dep3) 926 (clos:add-dependent testclass dep1) 927 (reinitialize-instance testclass :name 'testclass05-renamed) 928 (clos:remove-dependent testclass dep2) 929 (reinitialize-instance testclass :name 'testclass05-rerenamed) 930 (list (slot-value dep1 'counter) 931 (slot-value dep2 'counter) 932 (slot-value dep3 'counter) 933 (symbols-cleanup '(dependent05 testclass05))))) 934(2 1 2 ()) 935 936(defun dependent-methods (objects slot) 937 (mapcar (lambda (obj) 938 (mapcar (lambda (event) 939 (mapcar (lambda (x) 940 (if (typep x 'method) 941 (list 'method (mapcar #'class-name 942 (method-specializers x))) 943 x)) 944 event)) 945 (reverse (slot-value obj slot)))) 946 objects)) 947DEPENDENT-METHODS 948 949;; Check dependents notification on generic functions. 950(progn 951 (defclass dependent06 () ((history :initform '()))) 952 (defgeneric testgf06 (x)) 953 (defmethod clos:update-dependent ((gf generic-function) (d dependent06) &rest args) 954 (push args (slot-value d 'history))) 955 (let ((testgf #'testgf06) 956 (dep1 (make-instance 'dependent06)) 957 (dep2 (make-instance 'dependent06)) 958 (dep3 (make-instance 'dependent06))) 959 (clos:add-dependent testgf dep1) 960 (clos:add-dependent testgf dep2) 961 (clos:add-dependent testgf dep3) 962 (clos:add-dependent testgf dep1) 963 (reinitialize-instance testgf :name 'testgf06-renamed) 964 (defmethod testgf06 ((x integer))) 965 (clos:remove-dependent testgf dep2) 966 (defmethod testgf06 ((x real))) 967 (remove-method testgf (find-method testgf '() (list (find-class 'integer)))) 968 (list 969 (dependent-methods (list dep1 dep2 dep3) 'history) 970 (symbols-cleanup '(dependent06 testgf06))))) 971((((:name testgf06-renamed) (add-method (method (integer))) 972 (add-method (method (real))) (remove-method (method (integer)))) 973 ((:name testgf06-renamed) (add-method (method (integer)))) 974 ((:name testgf06-renamed) (add-method (method (integer))) 975 (add-method (method (real))) (remove-method (method (integer))))) 976 ()) 977 978 979;;; Check the dependent protocol 980;;; add-dependent remove-dependent map-dependents 981 982(progn 983 (defparameter *timestamp* 0) 984 (defclass prioritized-dependent () 985 ((priority :type real :initform 0 :initarg :priority :reader dependent-priority))) 986 (defclass prioritized-dispatcher () 987 ((dependents :type list :initform nil))) 988 (defmethod clos:add-dependent ((metaobject prioritized-dispatcher) (dependent prioritized-dependent)) 989 (unless (member dependent (slot-value metaobject 'dependents)) 990 (setf (slot-value metaobject 'dependents) 991 (sort (cons dependent (slot-value metaobject 'dependents)) #'> 992 :key #'dependent-priority)))) 993 (defmethod clos:remove-dependent ((metaobject prioritized-dispatcher) (dependent prioritized-dependent)) 994 (setf (slot-value metaobject 'dependents) 995 (delete dependent (slot-value metaobject 'dependents)))) 996 (defmethod clos:map-dependents ((metaobject prioritized-dispatcher) function) 997 ; Process the dependents list in decreasing priority order. 998 (dolist (dependent (slot-value metaobject 'dependents)) 999 (funcall function dependent) 1000 (incf *timestamp*))) 1001 t) 1002T 1003 1004;; Check that notification on classes can proceed by priorities. 1005(progn 1006 (setq *timestamp* 0) 1007 (defclass prioritized-class (prioritized-dispatcher standard-class) 1008 ()) 1009 #-CLISP 1010 (defmethod clos:validate-superclass ((c1 prioritized-class) (c2 standard-class)) 1011 t) 1012 (defclass testclass07 () () (:metaclass prioritized-class)) 1013 (defclass dependent07 (prioritized-dependent) ((history :initform nil))) 1014 (defmethod clos:update-dependent ((c class) (d dependent07) &rest args) 1015 (push (cons *timestamp* args) (slot-value d 'history))) 1016 (let ((testclass (find-class 'testclass07)) 1017 (dep1 (make-instance 'dependent07 :priority 5)) 1018 (dep2 (make-instance 'dependent07 :priority 10)) 1019 (dep3 (make-instance 'dependent07 :priority 1))) 1020 (clos:add-dependent testclass dep1) 1021 (clos:add-dependent testclass dep2) 1022 (clos:add-dependent testclass dep3) 1023 (clos:add-dependent testclass dep1) 1024 (reinitialize-instance testclass :name 'testclass07-renamed) 1025 (clos:remove-dependent testclass dep2) 1026 (reinitialize-instance testclass :name 'testclass07-rerenamed) 1027 (list (reverse (slot-value dep1 'history)) 1028 (reverse (slot-value dep2 'history)) 1029 (reverse (slot-value dep3 'history)) 1030 (symbols-cleanup '(prioritized-class testclass07 dependent07))))) 1031(((1 :name testclass07-renamed) (3 :name testclass07-rerenamed)) 1032 ((0 :name testclass07-renamed)) 1033 ((2 :name testclass07-renamed) (4 :name testclass07-rerenamed)) 1034 ()) 1035 1036;; Check that notification on generic-functions can proceed by priorities. 1037(progn 1038 (setq *timestamp* 0) 1039 (defclass prioritized-generic-function (prioritized-dispatcher standard-generic-function) 1040 () 1041 (:metaclass clos:funcallable-standard-class)) 1042 (defgeneric testgf08 (x) (:generic-function-class prioritized-generic-function)) 1043 (defclass dependent08 (prioritized-dependent) ((history :initform '()))) 1044 (defmethod clos:update-dependent ((gf generic-function) (d dependent08) &rest args) 1045 (push (cons *timestamp* args) (slot-value d 'history))) 1046 (let ((testgf #'testgf08) 1047 (dep1 (make-instance 'dependent08 :priority 1)) 1048 (dep2 (make-instance 'dependent08 :priority 10)) 1049 (dep3 (make-instance 'dependent08 :priority 5))) 1050 (clos:add-dependent testgf dep1) 1051 (clos:add-dependent testgf dep2) 1052 (clos:add-dependent testgf dep3) 1053 (clos:add-dependent testgf dep1) 1054 (reinitialize-instance testgf :name 'testgf08-renamed) 1055 (defmethod testgf08 ((x integer))) 1056 (clos:remove-dependent testgf dep2) 1057 (defmethod testgf08 ((x real))) 1058 (remove-method testgf (find-method testgf '() (list (find-class 'integer)))) 1059 (list 1060 (dependent-methods (list dep1 dep2 dep3) 'history) 1061 (symbols-cleanup '(prioritized-generic-function testgf08 dependent08))))) 1062((((2 :name testgf08-renamed) (5 add-method (method (integer))) 1063 (7 add-method (method (real))) (9 remove-method (method (integer)))) 1064 ((0 :name testgf08-renamed) (3 add-method (method (integer)))) 1065 ((1 :name testgf08-renamed) (4 add-method (method (integer))) 1066 (6 add-method (method (real))) (8 remove-method (method (integer))))) 1067 ()) 1068 1069;; check that reinitialize-instance calls finalize-inheritance https://sourceforge.net/p/clisp/bugs/353/ 1070(progn 1071 (defclass reinit-instance-class (standard-class) ()) 1072 (defmethod validate-superclass ((class reinit-instance-class) 1073 (superclass standard-class)) 1074 t) 1075 (defparameter *finalize-inheritance-count* 0) 1076 (defmethod finalize-inheritance :before ((class reinit-instance-class)) 1077 (incf *finalize-inheritance-count*)) 1078 (defclass reinit-instance-object () ((a-slot)) 1079 (:metaclass reinit-instance-class)) 1080 (unless (class-finalized-p (find-class 'reinit-instance-object)) 1081 (finalize-inheritance (find-class 'reinit-instance-object))) 1082 (reinitialize-instance (find-class 'reinit-instance-object)) 1083 (list *finalize-inheritance-count* 1084 (symbols-cleanup '(reinit-instance-class *finalize-inheritance-count* 1085 reinit-instance-object)))) 1086(2 ()) 1087 1088;;; Check the direct-methods protocol 1089;;; add-direct-method remove-direct-method 1090;;; specializer-direct-generic-functions specializer-direct-methods 1091 1092;; Check that it's possible to avoid storing all trivially specialized methods. 1093;; We can do this since the class <t> will never change. 1094(let ((<t> (find-class 't)) 1095 (operation-counter 0)) 1096 (defmethod clos:add-direct-method ((specializer (eql <t>)) (method method)) 1097 (incf operation-counter)) 1098 (defmethod clos:remove-direct-method ((specializer (eql <t>)) (method method)) 1099 (incf operation-counter)) 1100 (defmethod clos:specializer-direct-generic-functions ((class (eql <t>))) 1101 '()) 1102 (defmethod clos:specializer-direct-methods ((class (eql <t>))) 1103 '()) 1104 (setq operation-counter 0) 1105 ;; Note that add-direct-method is called once for each specializer of the 1106 ;; new method; since it has three times the specializer <t>, add-direct-method 1107 ;; is called three times. 1108 (fmakunbound 'testgf09) 1109 (defmethod testgf09 (x y z) (+ x y z)) 1110 (list (null (clos:specializer-direct-generic-functions (find-class 't))) 1111 (null (clos:specializer-direct-methods (find-class 't))) 1112 operation-counter 1113 #+CLISP (clos::gf-dynamically-modifiable #'testgf09) 1114 (symbol-cleanup 'testgf09))) 1115(t t 3 #+CLISP NIL T) 1116 1117;; Check that redefinition of a generic function correctly updates the lists 1118;; of generic functions belonging to each specializer. 1119(progn 1120 (defgeneric foo142 (x) (:method ((x t)))) 1121 (defgeneric foo142 (x)) 1122 (list (null (member #'foo142 1123 (clos:specializer-direct-generic-functions (find-class 't)))) 1124 (symbol-cleanup 'foo142))) 1125(T T) 1126 1127 1128;;; Check the direct-subclasses protocol 1129;;; add-direct-subclass remove-direct-subclass class-direct-subclasses 1130 1131;; Check that it's possible to count only instantiated direct subclasses. 1132;; (Subclasses that have no instances yet can be treated like garbage-collected 1133;; subclasses and be ignored.) 1134(progn 1135 (defclass volatile-class (standard-class) 1136 ((instantiated :type boolean :initform nil))) 1137 (defparameter *volatile-class-hack* nil) 1138 (defmethod clos:add-direct-subclass :around ((superclass volatile-class) (subclass volatile-class)) 1139 (when *volatile-class-hack* (call-next-method))) 1140 (defmethod clos:remove-direct-subclass :around ((superclass volatile-class) (subclass volatile-class)) 1141 nil) 1142 (defun note-volatile-class-instantiated (class) 1143 (unless (slot-value class 'instantiated) 1144 (setf (slot-value class 'instantiated) t) 1145 (dolist (superclass (clos:class-direct-superclasses class)) 1146 (when (typep superclass 'volatile-class) 1147 (unless (member class (clos:class-direct-subclasses superclass)) 1148 (let ((*volatile-class-hack* t)) 1149 (clos:add-direct-subclass superclass class)) 1150 (note-volatile-class-instantiated superclass)))))) 1151 (defmethod allocate-instance :after ((class volatile-class) &rest initargs) 1152 (note-volatile-class-instantiated class)) 1153 #-CLISP 1154 (defmethod clos:validate-superclass ((c1 volatile-class) (c2 standard-class)) 1155 t) 1156 (defclass testclass10 () () (:metaclass volatile-class)) 1157 (defclass testclass10a (testclass10) () (:metaclass volatile-class)) 1158 (defclass testclass10b (testclass10) () (:metaclass volatile-class)) 1159 (defclass testclass10c (testclass10) () (:metaclass volatile-class)) 1160 (defclass testclass10d (testclass10b) () (:metaclass volatile-class)) 1161 (let ((results '())) 1162 (push (clos:class-direct-subclasses (find-class 'testclass10)) results) 1163 (push (clos:class-direct-subclasses (find-class 'testclass10a)) results) 1164 (push (clos:class-direct-subclasses (find-class 'testclass10b)) results) 1165 (push (clos:class-direct-subclasses (find-class 'testclass10c)) results) 1166 (push (clos:class-direct-subclasses (find-class 'testclass10d)) results) 1167 (make-instance 'testclass10d) 1168 (push (clos:class-direct-subclasses (find-class 'testclass10)) results) 1169 (push (clos:class-direct-subclasses (find-class 'testclass10a)) results) 1170 (push (clos:class-direct-subclasses (find-class 'testclass10b)) results) 1171 (push (clos:class-direct-subclasses (find-class 'testclass10c)) results) 1172 (push (clos:class-direct-subclasses (find-class 'testclass10d)) results) 1173 (list (mapcar #'(lambda (l) (mapcar #'class-name l)) (nreverse results)) 1174 (symbols-cleanup '(volatile-class *volatile-class-hack* 1175 note-volatile-class-instantiated testclass10 1176 testclass10a testclass10b testclass10c testclass10d))))) 1177((() () () () () (testclass10b) () (testclass10d) () ()) ()) 1178 1179 1180;;; Check the compute-applicable-methods protocol 1181;;; compute-applicable-methods compute-applicable-methods-using-classes 1182 1183;; Check that it's possible to change the order of applicable methods from 1184;; most-specific-first to most-specific-last. 1185(progn 1186 (defclass msl-generic-function (standard-generic-function) 1187 () 1188 (:metaclass clos:funcallable-standard-class)) 1189 (defun reverse-method-list (methods) 1190 (let ((result '())) 1191 (dolist (method methods) 1192 (if (and (consp result) 1193 (equal (method-qualifiers method) (method-qualifiers (caar result)))) 1194 (push method (car result)) 1195 (push (list method) result))) 1196 (reduce #'append result))) 1197 (defmethod compute-applicable-methods ((gf msl-generic-function) arguments) 1198 (reverse-method-list (call-next-method))) 1199 #-LISPWORKS 1200 (defmethod clos:compute-applicable-methods-using-classes ((gf msl-generic-function) classes) 1201 (reverse-method-list (call-next-method))) 1202 (defgeneric testgf11 (x) (:generic-function-class msl-generic-function) 1203 (:method ((x integer)) (cons 'integer (if (next-method-p) (call-next-method)))) 1204 (:method ((x real)) (cons 'real (if (next-method-p) (call-next-method)))) 1205 (:method ((x number)) (cons 'number (if (next-method-p) (call-next-method)))) 1206 (:method :around ((x integer)) (coerce (call-next-method) 'vector))) 1207 (list (testgf11 5.0) (testgf11 17) 1208 (symbols-cleanup '(msl-generic-function reverse-method-list testgf11)))) 1209((number real) #(number real integer) ()) 1210 1211;; Check that it's possible to filter-out applicable methods. 1212(progn 1213 (defclass nonumber-generic-function (standard-generic-function) 1214 () 1215 (:metaclass clos:funcallable-standard-class)) 1216 (defun nonumber-method-list (methods) 1217 (remove-if #'(lambda (method) 1218 (member (find-class 'number) (clos:method-specializers method))) 1219 methods)) 1220 (defmethod compute-applicable-methods ((gf nonumber-generic-function) arguments) 1221 (nonumber-method-list (call-next-method))) 1222 #-LISPWORKS 1223 (defmethod clos:compute-applicable-methods-using-classes ((gf nonumber-generic-function) classes) 1224 (nonumber-method-list (call-next-method))) 1225 (defgeneric testgf12 (x) (:generic-function-class nonumber-generic-function) 1226 (:method ((x integer)) (cons 'integer (if (next-method-p) (call-next-method)))) 1227 (:method ((x real)) (cons 'real (if (next-method-p) (call-next-method)))) 1228 (:method ((x number)) (cons 'number (if (next-method-p) (call-next-method)))) 1229 (:method :around ((x integer)) (coerce (call-next-method) 'vector))) 1230 (list (testgf12 5.0) (testgf12 17) 1231 (symbols-cleanup '(nonumber-generic-function nonumber-method-list testgf12)))) 1232((real) #(integer real) ()) 1233 1234 1235;;; Check the compute-class-precedence-list protocol 1236;;; compute-class-precedence-list 1237 1238;; Check that it's possible to compute the precedence list using a 1239;; breadth-first search instead of a depth-first search. 1240(progn 1241 (defclass bfs-class (standard-class) 1242 ()) 1243 (defmethod clos:compute-class-precedence-list ((class bfs-class)) 1244 (let ((queue (list class)) 1245 (next-queue '()) 1246 (cpl '())) 1247 (loop 1248 (when (null queue) 1249 (setq queue (reverse next-queue) next-queue '()) 1250 (when (null queue) 1251 (return))) 1252 (let ((c (pop queue))) 1253 (unless (member c cpl) 1254 (push c cpl) 1255 (setq next-queue (revappend (clos:class-direct-superclasses c) next-queue))))) 1256 (nreverse cpl))) 1257 #-CLISP 1258 (defmethod clos:validate-superclass ((c1 bfs-class) (c2 standard-class)) 1259 t) 1260 ; a 1261 ; / \ 1262 ; b d 1263 ; | | 1264 ; c e 1265 ; \ / 1266 ; f 1267 (defclass testclass13a () () (:metaclass bfs-class)) 1268 (defclass testclass13b (testclass13a) () (:metaclass bfs-class)) 1269 (defclass testclass13c (testclass13b) () (:metaclass bfs-class)) 1270 (defclass testclass13d (testclass13a) () (:metaclass bfs-class)) 1271 (defclass testclass13e (testclass13d) () (:metaclass bfs-class)) 1272 (defclass testclass13f (testclass13c testclass13e) () (:metaclass bfs-class)) 1273 (unless (clos:class-finalized-p (find-class 'testclass13f)) 1274 (clos:finalize-inheritance (find-class 'testclass13f))) 1275 (list (mapcar #'class-name (subseq (clos:class-precedence-list (find-class 'testclass13f)) 0 6)) 1276 (symbols-cleanup '(bfs-class testclass13a testclass13b testclass13c 1277 testclass13d testclass13e testclass13f)))) 1278;; With the default depth-first / topological-sort search algorithm: 1279;; (testclass13f testclass13c testclass13b testclass13e testclass13d testclass13a) 1280((testclass13f testclass13c testclass13e testclass13b testclass13d testclass13a) ()) 1281 1282 1283;;; Check the compute-default-initargs protocol 1284;;; compute-default-initargs 1285 1286;; Check that it's possible to add additional initargs. 1287(progn 1288 (defparameter *extra-value* 'extra) 1289 (defclass custom-default-initargs-class (standard-class) 1290 ()) 1291 (defmethod clos:compute-default-initargs ((class custom-default-initargs-class)) 1292 (let ((original-default-initargs 1293 (remove-duplicates 1294 (reduce #'append 1295 (mapcar #'clos:class-direct-default-initargs 1296 (clos:class-precedence-list class))) 1297 :key #'car 1298 :from-end t))) 1299 (cons (list ':extra '*extra-value* #'(lambda () *extra-value*)) 1300 (remove ':extra original-default-initargs :key #'car)))) 1301 #-CLISP 1302 (defmethod clos:validate-superclass ((c1 custom-default-initargs-class) (c2 standard-class)) 1303 t) 1304 (defclass testclass14 () ((slot :initarg :extra)) (:metaclass custom-default-initargs-class)) 1305 (list (slot-value (make-instance 'testclass14) 'slot) 1306 (symbols-cleanup '(*extra-value* custom-default-initargs-class testclass14)))) 1307(EXTRA ()) 1308 1309 1310;;; Check the compute-direct-slot-definition-initargs protocol 1311;;; compute-direct-slot-definition-initargs 1312 1313;; Check that it's possible to generate accessors automatically. 1314#+CLISP 1315(progn 1316 (defclass auto-accessors-2-class (standard-class) 1317 ()) 1318 #-CLISP 1319 (defmethod clos:validate-superclass ((c1 auto-accessors-2-class) (c2 standard-class)) 1320 t) 1321 (defmethod clos::compute-direct-slot-definition-initargs ((class auto-accessors-2-class) &rest slot-spec) 1322 (if (and (null (getf slot-spec ':readers)) (null (getf slot-spec ':writers))) 1323 (let* ((containing-class-name (class-name class)) 1324 (accessor-name 1325 (intern (concatenate 'string 1326 (symbol-name containing-class-name) 1327 "-" 1328 (symbol-name (getf slot-spec ':name))) 1329 (symbol-package containing-class-name)))) 1330 (list* ;; Here are the additional reader/writer lists. 1331 :readers (list accessor-name) 1332 :writers (list (list 'setf accessor-name)) 1333 (call-next-method))) 1334 (call-next-method))) 1335 (defclass testclass15 () 1336 ((x :initarg :x) (y)) 1337 (:metaclass auto-accessors-2-class)) 1338 (let ((inst (make-instance 'testclass15 :x 12))) 1339 (list (testclass15-x inst) (setf (testclass15-y inst) 13) 1340 (symbols-cleanup '(auto-accessors-2-class testclass15))))) 1341#+CLISP 1342(12 13 ()) 1343 1344 1345;;; Check the compute-discriminating-function protocol 1346;;; compute-discriminating-function 1347 1348;; Check that it's possible to add tracing to a generic function. 1349(progn 1350 (defclass traced-generic-function (standard-generic-function) 1351 () 1352 (:metaclass clos:funcallable-standard-class)) 1353 (defvar *last-traced-arguments* nil) 1354 (defvar *last-traced-values* nil) 1355 (defmethod clos:compute-discriminating-function ((gf traced-generic-function)) 1356 (let ((orig-df (call-next-method)) 1357 (name (clos:generic-function-name gf))) 1358 #'(lambda (&rest arguments) 1359 (declare (compile)) 1360 (format *trace-output* "~%=> ~S arguments: ~:S" name arguments) 1361 (setq *last-traced-arguments* arguments) 1362 (let ((values (multiple-value-list (apply orig-df arguments)))) 1363 (format *trace-output* "~%<= ~S values: ~:S" name values) 1364 (setq *last-traced-values* values) 1365 (values-list values))))) 1366 (defgeneric testgf15 (x) (:generic-function-class traced-generic-function) 1367 (:method ((x number)) (values x (- x) (* x x) (/ x)))) 1368 (testgf15 5) 1369 (list *last-traced-arguments* *last-traced-values* 1370 (symbols-cleanup '(traced-generic-function *last-traced-arguments* 1371 *last-traced-values* testgf15)))) 1372((5) (5 -5 25 1/5) ()) 1373 1374 1375;;; Check the compute-effective-method protocol 1376;;; compute-effective-method 1377 1378;; Check that it is possible to modify the effective-method in a way that is 1379;; orthogonal to the method-combination. In particular, check that it's 1380;; possible to provide 'redo' and 'return' restarts for each method invocation. 1381(progn 1382 (defun prompt-for-new-values () 1383 (format *debug-io* "~&New values: ") 1384 (list (read *debug-io*))) 1385 (defun add-method-restarts (form method) 1386 (let ((block (gensym)) 1387 (tag (gensym))) 1388 `(BLOCK ,block 1389 (TAGBODY 1390 ,tag 1391 (RETURN-FROM ,block 1392 (RESTART-CASE ,form 1393 (METHOD-REDO () 1394 :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Try calling ~S again." ,method)) 1395 (GO ,tag)) 1396 (METHOD-RETURN (L) 1397 :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Specify return values for ~S call." ,method)) 1398 :INTERACTIVE (LAMBDA () (PROMPT-FOR-NEW-VALUES)) 1399 (RETURN-FROM ,block (VALUES-LIST L))))))))) 1400 (defun convert-effective-method (efm) 1401 (if (consp efm) 1402 (if (eq (car efm) 'CALL-METHOD) 1403 (let ((method-list (third efm))) 1404 (if (or (typep (first method-list) 'method) (rest method-list)) 1405 ; Reduce the case of multiple methods to a single one. 1406 ; Make the call to the next-method explicit. 1407 (convert-effective-method 1408 `(CALL-METHOD ,(second efm) 1409 ((MAKE-METHOD 1410 (CALL-METHOD ,(first method-list) ,(rest method-list)))))) 1411 ; Now the case of at most one method. 1412 (if (typep (second efm) 'method) 1413 ; Wrap the method call in a RESTART-CASE. 1414 (add-method-restarts 1415 (cons (convert-effective-method (car efm)) 1416 (convert-effective-method (cdr efm))) 1417 (second efm)) 1418 ; Normal recursive processing. 1419 (cons (convert-effective-method (car efm)) 1420 (convert-effective-method (cdr efm)))))) 1421 (cons (convert-effective-method (car efm)) 1422 (convert-effective-method (cdr efm)))) 1423 efm)) 1424 (defclass debuggable-generic-function (standard-generic-function) 1425 () 1426 (:metaclass clos:funcallable-standard-class)) 1427 (defmethod clos:compute-effective-method ((gf debuggable-generic-function) method-combination methods) 1428 (convert-effective-method (call-next-method))) 1429 (defgeneric testgf16 (x) (:generic-function-class debuggable-generic-function)) 1430 (defclass testclass16a () ()) 1431 (defclass testclass16b (testclass16a) ()) 1432 (defclass testclass16c (testclass16a) ()) 1433 (defclass testclass16d (testclass16b testclass16c) ()) 1434 (defmethod testgf16 ((x testclass16a)) 1435 (list 'a 1436 (not (null (find-restart 'method-redo))) 1437 (not (null (find-restart 'method-return))))) 1438 (defmethod testgf16 ((x testclass16b)) 1439 (cons 'b (call-next-method))) 1440 (defmethod testgf16 ((x testclass16c)) 1441 (cons 'c (call-next-method))) 1442 (defmethod testgf16 ((x testclass16d)) 1443 (cons 'd (call-next-method))) 1444 (list (testgf16 (make-instance 'testclass16d)) 1445 (symbols-cleanup '(prompt-for-new-values add-method-restarts 1446 convert-effective-method debuggable-generic-function 1447 testgf16 testclass16a testclass16b testclass16c 1448 testclass16d)))) 1449((D B C A T T) ()) 1450 1451 1452;;; Check the compute-effective-slot-definition protocol 1453;;; compute-effective-slot-definition 1454 1455;; Check that it's possible to generate initargs automatically and have a 1456;; default initform of 42. 1457#-(or ALLEGRO OpenMCL LISPWORKS) 1458(progn 1459 (defclass auto-initargs-class (standard-class) 1460 ()) 1461 (defmethod clos:compute-effective-slot-definition ((class auto-initargs-class) name direct-slot-definitions) 1462 (let ((eff-slot (call-next-method))) 1463 ;; NB: The MOP doesn't specify setters for slot-definition objects, but 1464 ;; most implementations have it. Without these setters, it is not possible 1465 ;; to make use of compute-effective-slot-definition, since the MOP p. 43 1466 ;; says "the value returned by the extending method must be the value 1467 ;; returned by [the predefined] method". 1468 (unless (clos:slot-definition-initargs eff-slot) 1469 (setf (clos:slot-definition-initargs eff-slot) 1470 (list (intern (symbol-name (clos:slot-definition-name eff-slot)) 1471 (find-package "KEYWORD"))))) 1472 (unless (clos:slot-definition-initfunction eff-slot) 1473 (setf (clos:slot-definition-initfunction eff-slot) #'(lambda () 42) 1474 (clos:slot-definition-initform eff-slot) '42)) 1475 eff-slot)) 1476 #-CLISP 1477 (defmethod clos:validate-superclass ((c1 auto-initargs-class) (c2 standard-class)) 1478 t) 1479 (defclass testclass17 () ((x) (y)) (:metaclass auto-initargs-class)) 1480 (let ((inst (make-instance 'testclass17 :x 17))) 1481 (list (slot-value inst 'x) (slot-value inst 'y) 1482 (symbols-cleanup '(auto-initargs-class testclass17))))) 1483#-(or ALLEGRO OpenMCL LISPWORKS) 1484(17 42 ()) 1485 1486 1487;;; Check the compute-effective-slot-definition-initargs protocol 1488;;; compute-effective-slot-definition-initargs 1489 1490;; Check that it's possible to generate initargs automatically and have a 1491;; default initform of 42. 1492#+(or CLISP ALLEGRO CMU SBCL LISPWORKS) 1493(progn 1494 (defclass auto-initargs-2-class (standard-class) 1495 ()) 1496 (defmethod clos:compute-effective-slot-definition-initargs ((class auto-initargs-2-class) #+LISPWORKS name direct-slot-definitions) 1497 (let ((initargs (call-next-method))) 1498 (unless (getf initargs ':initargs) 1499 (setq initargs 1500 (list* ':initargs 1501 (list (intern (symbol-name (getf initargs ':name)) 1502 (find-package "KEYWORD"))) 1503 initargs))) 1504 (unless (getf initargs ':initfunction) 1505 (setq initargs 1506 (list* ':initfunction #'(lambda () 42) 1507 ':initform '42 1508 initargs))) 1509 initargs)) 1510 #-CLISP 1511 (defmethod clos:validate-superclass ((c1 auto-initargs-2-class) (c2 standard-class)) 1512 t) 1513 (defclass testclass17-2 () ((x) (y)) (:metaclass auto-initargs-2-class)) 1514 (let ((inst (make-instance 'testclass17-2 :x 17))) 1515 (list (slot-value inst 'x) (slot-value inst 'y) 1516 (symbols-cleanup '(auto-initargs-2-class testclass17-2))))) 1517#+(or CLISP ALLEGRO CMU SBCL LISPWORKS) 1518(17 42 ()) 1519 1520 1521;;; Check the compute-slots protocol 1522;;; compute-slots 1523 1524;; Check that it's possible to add additional local slots. 1525(progn 1526 (defclass testclass18b (testclass18a) ()) 1527 (defmethod clos:compute-slots ((class (eql (find-class 'testclass18b)))) 1528 (append (call-next-method) 1529 (list (make-instance 'clos:standard-effective-slot-definition 1530 :name 'y 1531 :allocation :instance)))) 1532 (defclass testclass18a () 1533 ((x :allocation :class))) 1534 (clos:finalize-inheritance (find-class 'testclass18b)) 1535 ;; testclass18b should now have a shared slot, X, and a local slot, Y. 1536 (append 1537 (mapcar #'(lambda (slot) 1538 (list (clos:slot-definition-name slot) 1539 (integerp (clos:slot-definition-location slot)))) 1540 (clos:class-slots (find-class 'testclass18b))) 1541 (let ((inst1 (make-instance 'testclass18b)) 1542 (inst2 (make-instance 'testclass18b))) 1543 (setf (slot-value inst1 'y) 'abc) 1544 (setf (slot-value inst2 'y) 'def) 1545 (list (slot-value inst1 'y) (slot-value inst2 'y))) 1546 (symbols-cleanup '(testclass18a testclass18b)))) 1547((X NIL) (Y T) ABC DEF) 1548 1549;; Check that it's possible to add additional shared slots. 1550(progn 1551 (defclass testclass19b (testclass19a) ()) 1552 (defmethod clos:compute-slots ((class (eql (find-class 'testclass19b)))) 1553 (append (call-next-method) 1554 (list (make-instance 'clos:standard-effective-slot-definition 1555 :name 'y 1556 :allocation :class)))) 1557 (defclass testclass19a () 1558 ((x :allocation :class))) 1559 (clos:finalize-inheritance (find-class 'testclass19b)) 1560 ;; testclass19b should now have two shared slots, X and Y. 1561 (append 1562 (mapcar #'(lambda (slot) 1563 (list (clos:slot-definition-name slot) 1564 (integerp (clos:slot-definition-location slot)))) 1565 (clos:class-slots (find-class 'testclass19b))) 1566 (let ((inst1 (make-instance 'testclass19b)) 1567 (inst2 (make-instance 'testclass19b))) 1568 (setf (slot-value inst1 'y) 'abc) 1569 (setf (slot-value inst2 'y) 'def) 1570 (list (slot-value inst1 'y) (slot-value inst2 'y))) 1571 (symbols-cleanup '(testclass19b testclass19a)))) 1572((X NIL) (Y NIL) DEF DEF) 1573 1574 1575;;; Check the direct-slot-definition-class protocol 1576;;; direct-slot-definition-class 1577 1578;; Check that it's possible to generate accessors automatically. 1579(progn 1580 (defclass auto-accessors-direct-slot-definition-class (standard-class) 1581 ((containing-class-name :initarg :containing-class-name))) 1582 #-CLISP 1583 (defmethod clos:validate-superclass ((c1 auto-accessors-direct-slot-definition-class) (c2 standard-class)) 1584 t) 1585 (defclass auto-accessors-class (standard-class) 1586 ()) 1587 (defmethod clos:direct-slot-definition-class ((class auto-accessors-class) &rest initargs) 1588 (let ((dsd-class-name (gensym))) 1589 (clos:ensure-class dsd-class-name 1590 :metaclass (find-class 'auto-accessors-direct-slot-definition-class) 1591 :direct-superclasses (list (find-class 'clos:standard-direct-slot-definition)) 1592 :containing-class-name (class-name class)) 1593 (eval `(defmethod initialize-instance :around ((dsd ,dsd-class-name) &rest args) 1594 (if (and (null (getf args ':readers)) (null (getf args ':writers))) 1595 (let* ((containing-class-name (slot-value (class-of dsd) 'containing-class-name)) 1596 (accessor-name 1597 (intern (concatenate 'string 1598 (symbol-name containing-class-name) 1599 "-" 1600 (symbol-name (getf args ':name))) 1601 (symbol-package containing-class-name)))) 1602 (apply #'call-next-method dsd 1603 :readers (list accessor-name) 1604 :writers (list (list 'setf accessor-name)) 1605 args)) 1606 (call-next-method)))) 1607 (find-class dsd-class-name))) 1608 #-CLISP 1609 (defmethod clos:validate-superclass ((c1 auto-accessors-class) (c2 standard-class)) 1610 t) 1611 (defclass testclass20 () 1612 ((x :initarg :x) (y)) 1613 (:metaclass auto-accessors-class)) 1614 (let ((inst (make-instance 'testclass20 :x 12))) 1615 (list (testclass20-x inst) (setf (testclass20-y inst) 13) 1616 (symbols-cleanup '(auto-accessors-direct-slot-definition-class 1617 auto-accessors-class testclass20))))) 1618(12 13 ()) 1619 1620 1621;;; Check the effective-slot-definition-class protocol 1622;;; effective-slot-definition-class 1623 1624;; See below, with the slot-value-using-class protocol. 1625 1626 1627;;; Check the slot-value-using-class protocol 1628;;; slot-value-using-class (setf slot-value-using-class) 1629;;; slot-boundp-using-class slot-makunbound-using-class 1630 1631;; Check that it's possible to store all slot values in property lists. 1632(progn 1633 (defparameter *external-slot-values* '()) 1634 (defclass external-slot-definition (clos:standard-effective-slot-definition) 1635 ()) 1636 (let ((unbound (gensym "UNBOUND"))) 1637 (defmethod clos:slot-value-using-class ((class standard-class) instance (slot external-slot-definition)) 1638 (let ((value (getf (getf *external-slot-values* instance) (clos:slot-definition-name slot) unbound))) 1639 (if (eq value unbound) 1640 (slot-unbound class instance (clos:slot-definition-name slot)) 1641 value))) 1642 (defmethod (setf clos:slot-value-using-class) (new-value (class standard-class) instance (slot external-slot-definition)) 1643 (setf (getf (getf *external-slot-values* instance) (clos:slot-definition-name slot)) new-value)) 1644 (defmethod clos:slot-boundp-using-class ((class standard-class) instance (slot external-slot-definition)) 1645 (let ((value (getf (getf *external-slot-values* instance) (clos:slot-definition-name slot) unbound))) 1646 (not (eq value unbound)))) 1647 (defmethod clos:slot-makunbound-using-class ((class standard-class) instance (slot external-slot-definition)) 1648 (remf (getf *external-slot-values* instance) (clos:slot-definition-name slot)) 1649 instance)) 1650 (defclass external-slot-definition-class (standard-class) 1651 ()) 1652 #-CLISP 1653 (defmethod clos:validate-superclass ((c1 external-slot-definition-class) (c2 standard-class)) 1654 t) 1655 (defmethod clos:effective-slot-definition-class ((class external-slot-definition-class) &rest args) 1656 (find-class 'external-slot-definition)) 1657 (defclass testclass22 () 1658 ((x :initarg :x) (y :initarg :y)) 1659 (:metaclass external-slot-definition-class)) 1660 (let ((inst1 (make-instance 'testclass22 :x 3 :y 4)) 1661 (inst2 (make-instance 'testclass22 :x 5 :y 12)) 1662 (results '())) 1663 (push (slot-value inst1 'x) results) 1664 (push (slot-value inst2 'x) results) 1665 (push (slot-value inst1 'y) results) 1666 (push (slot-value inst2 'y) results) 1667 (push (or (equal *external-slot-values* 1668 (list inst2 (list 'x 5 'y 12) inst1 (list 'x 3 'y 4))) 1669 (equal *external-slot-values* 1670 (list inst2 (list 'y 12 'x 5) inst1 (list 'y 4 'x 3)))) 1671 results) 1672 (setf (slot-value inst2 'x) -5) 1673 (push (slot-value inst2 'x) results) 1674 (slot-makunbound inst1 'y) 1675 (push (list (slot-boundp inst1 'x) (slot-boundp inst1 'y)) results) 1676 (slot-makunbound inst1 'x) 1677 (push (or (equal *external-slot-values* 1678 (list inst2 (list 'x -5 'y 12) inst1 nil)) 1679 (equal *external-slot-values* 1680 (list inst2 (list 'y 12 'x -5) inst1 nil))) 1681 results) 1682 (list (nreverse results) 1683 (symbols-cleanup '(*external-slot-values* external-slot-definition 1684 external-slot-definition-class testclass22))))) 1685((3 5 4 12 T -5 (T NIL) T) ()) 1686 1687 1688;;; Check the ensure-class-using-class protocol 1689;;; ensure-class-using-class 1690 1691;; Check that it's possible to take the documentation from elsewhere. 1692(progn 1693 (defparameter *doc-database* 1694 '((testclass23 . "This is a dumb class for testing.") 1695 (testgf24 . "This is a dumb generic function for testing."))) 1696 (defclass externally-documented-class (standard-class) 1697 ()) 1698 #-CLISP 1699 (defmethod clos:validate-superclass ((c1 externally-documented-class) (c2 standard-class)) 1700 t) 1701 (dolist (given-name (mapcar #'car *doc-database*)) 1702 (defmethod clos:ensure-class-using-class ((class class) (name (eql given-name)) &rest args &key documentation &allow-other-keys) 1703 (if (and (null documentation) 1704 (setq documentation (cdr (assoc name *doc-database*)))) 1705 (apply #'call-next-method class name (list* ':documentation documentation args)) 1706 (call-next-method))) 1707 (defmethod clos:ensure-class-using-class ((class null) (name (eql given-name)) &rest args &key documentation &allow-other-keys) 1708 (if (and (null documentation) 1709 (setq documentation (cdr (assoc name *doc-database*)))) 1710 (apply #'call-next-method class name (list* ':documentation documentation args)) 1711 (call-next-method)))) 1712 (defclass testclass23 () 1713 () 1714 (:metaclass externally-documented-class)) 1715 (list (documentation 'testclass23 'type) 1716 (symbols-cleanup '(*doc-database* externally-documented-class testclass23)))) 1717("This is a dumb class for testing." ()) 1718 1719 1720;;; Check the ensure-generic-function-using-class protocol 1721;;; ensure-generic-function-using-class 1722 1723;; Check that it's possible to take the documentation from elsewhere. 1724(progn 1725 (defparameter *doc-database* 1726 '((testclass23 . "This is a dumb class for testing.") 1727 (testgf24 . "This is a dumb generic function for testing."))) 1728 (defclass externally-documented-generic-function (standard-generic-function) 1729 () 1730 (:metaclass clos:funcallable-standard-class)) 1731 (dolist (given-name (mapcar #'car *doc-database*)) 1732 (defmethod clos:ensure-generic-function-using-class ((gf generic-function) (name (eql given-name)) &rest args &key documentation &allow-other-keys) 1733 (if (and (null documentation) 1734 (setq documentation (cdr (assoc name *doc-database* :test #'equal)))) 1735 (apply #'call-next-method gf name (list* ':documentation documentation args)) 1736 (call-next-method))) 1737 (defmethod clos:ensure-generic-function-using-class ((gf null) (name (eql given-name)) &rest args &key documentation &allow-other-keys) 1738 (if (and (null documentation) 1739 (setq documentation (cdr (assoc name *doc-database* :test #'equal)))) 1740 (apply #'call-next-method gf name (list* ':documentation documentation args)) 1741 (call-next-method)))) 1742 (defgeneric testgf24 (x) 1743 (:generic-function-class externally-documented-generic-function)) 1744 (list (documentation 'testgf24 'function) 1745 (symbols-cleanup '(*doc-database* externally-documented-generic-function 1746 testgf24)))) 1747("This is a dumb generic function for testing." ()) 1748 1749 1750;;; Check the reader-method-class protocol 1751;;; reader-method-class 1752 1753;; Check that it's possible to define reader methods that do typechecking. 1754(progn 1755 (defclass typechecking-reader-method (clos:standard-reader-method) 1756 ()) 1757 (defmethod initialize-instance ((method typechecking-reader-method) &rest initargs 1758 &key slot-definition) 1759 (let ((name (clos:slot-definition-name slot-definition)) 1760 (type (clos:slot-definition-type slot-definition))) 1761 (apply #'call-next-method method 1762 :function #'(lambda (args next-methods) 1763 (declare (ignore next-methods)) 1764 #+CLISP (declare (compile)) 1765 (apply #'(lambda (instance) 1766 (let ((value (slot-value instance name))) 1767 (unless (typep value type) 1768 (error "Slot ~S of ~S is not of type ~S: ~S" 1769 name instance type value)) 1770 value)) 1771 args)) 1772 initargs))) 1773 (defclass typechecking-reader-class (standard-class) 1774 ()) 1775 #-CLISP 1776 (defmethod clos:validate-superclass ((c1 typechecking-reader-class) (c2 standard-class)) 1777 t) 1778 (defmethod reader-method-class ((class typechecking-reader-class) direct-slot &rest args) 1779 (find-class 'typechecking-reader-method)) 1780 (defclass testclass25 () 1781 ((pair :type (cons symbol (cons symbol null)) :initarg :pair :accessor testclass25-pair)) 1782 (:metaclass typechecking-reader-class)) 1783 (macrolet ((succeeds (form) 1784 `(not (nth-value 1 (ignore-errors ,form))))) 1785 (let ((p (list 'abc 'def)) 1786 (x (make-instance 'testclass25))) 1787 (list (succeeds (make-instance 'testclass25 :pair '(seventeen 17))) 1788 (succeeds (setf (testclass25-pair x) p)) 1789 (succeeds (setf (second p) 456)) 1790 (succeeds (testclass25-pair x)) 1791 (succeeds (slot-value x 'pair)) 1792 (symbols-cleanup '(typechecking-reader-method typechecking-reader-class 1793 testclass25 testclass25-pair)))))) 1794(t t t nil t ()) 1795 1796 1797;;; Check the writer-method-class protocol 1798;;; writer-method-class 1799 1800;; Check that it's possible to define writer methods that do typechecking. 1801(progn 1802 (defclass typechecking-writer-method (clos:standard-writer-method) 1803 ()) 1804 (defmethod initialize-instance ((method typechecking-writer-method) &rest initargs 1805 &key slot-definition) 1806 (let ((name (clos:slot-definition-name slot-definition)) 1807 (type (clos:slot-definition-type slot-definition))) 1808 (apply #'call-next-method method 1809 :function #'(lambda (args next-methods) 1810 (declare (ignore next-methods)) 1811 #+CLISP (declare (compile)) 1812 (apply #'(lambda (new-value instance) 1813 (unless (typep new-value type) 1814 (error "Slot ~S of ~S: new value is not of type ~S: ~S" 1815 name instance type new-value)) 1816 (setf (slot-value instance name) new-value)) 1817 args)) 1818 initargs))) 1819 (defclass typechecking-writer-class (standard-class) 1820 ()) 1821 #-CLISP 1822 (defmethod clos:validate-superclass ((c1 typechecking-writer-class) (c2 standard-class)) 1823 t) 1824 (defmethod writer-method-class ((class typechecking-writer-class) direct-slot &rest args) 1825 (find-class 'typechecking-writer-method)) 1826 (defclass testclass26 () 1827 ((pair :type (cons symbol (cons symbol null)) :initarg :pair :accessor testclass26-pair)) 1828 (:metaclass typechecking-writer-class)) 1829 (macrolet ((succeeds (form) 1830 `(not (nth-value 1 (ignore-errors ,form))))) 1831 (let ((p (list 'abc 'def)) 1832 (x (make-instance 'testclass26))) 1833 (list (succeeds (make-instance 'testclass26 :pair '(seventeen 17))) 1834 (succeeds (setf (testclass26-pair x) p)) 1835 (succeeds (setf (second p) 456)) 1836 (succeeds (testclass26-pair x)) 1837 (succeeds (setf (testclass26-pair x) p)) 1838 (succeeds (setf (slot-value x 'pair) p)) 1839 (symbols-cleanup '(typechecking-writer-method typechecking-writer-class 1840 testclass26 testclass26-pair)))))) 1841(t t t t nil t ()) 1842 1843 1844;;; Check the validate-superclass protocol 1845;;; validate-superclass 1846 1847;; Check that it's possible to create subclasses of generic-function 1848;; that are not instances of funcallable-standard-class. 1849(progn 1850 (defmethod clos:validate-superclass ((c1 standard-class) (c2 clos:funcallable-standard-class)) 1851 t) 1852 (defclass uncallable-generic-function (standard-generic-function) 1853 () 1854 (:metaclass standard-class)) 1855 (let ((inst (make-instance 'uncallable-generic-function 1856 :name 'testgf27 1857 :lambda-list '(x y) 1858 :method-class (find-class 'standard-method) 1859 :method-combination (clos:find-method-combination #'print-object 'standard nil)))) 1860 (list (typep inst 'standard-object) 1861 (typep inst 'clos:funcallable-standard-object) 1862 (typep (class-of inst) 'standard-class) 1863 (typep (class-of inst) 'clos:funcallable-standard-class)))) 1864#+(or CLISP ALLEGRO) ERROR 1865#-(or CLISP ALLEGRO) (T T T NIL) 1866 1867;; Check that it's possible to create uncounted subclasses of counted classes. 1868(progn 1869 (defparameter *counter27* 0) 1870 (defclass counted27-class (standard-class) 1871 ()) 1872 (defmethod make-instance :after ((c counted27-class) &rest args) 1873 (incf *counter27*)) 1874 #-CLISP 1875 (defmethod clos:validate-superclass ((c1 counted27-class) (c2 standard-class)) 1876 t) 1877 (defclass testclass27a () () (:metaclass counted27-class)) 1878 (make-instance 'testclass27a) 1879 (defmethod clos:validate-superclass ((c1 standard-class) (c2 counted27-class)) 1880 t) 1881 (defclass testclass27b (testclass27a) () (:metaclass standard-class)) 1882 (make-instance 'testclass27b) 1883 (make-instance 'testclass27b) 1884 (list *counter27* (symbols-cleanup '(*counter27* counted27-class 1885 testclass27a testclass27b)))) 1886(1 ()) 1887 1888 1889;;; Check that finalize-inheritance is called when it should be. 1890(let ((finalize-inheritance-history '())) 1891 (ext:without-package-lock ("CLOS") 1892 (defmethod clos:finalize-inheritance :after ((class class)) 1893 (push (class-name class) finalize-inheritance-history))) 1894 (defclass testclass52a () ()) 1895 (defclass testclass52c (testclass52a testclass52b) ()) 1896 (defclass testclass52d (testclass52c) ()) 1897 (defclass testclass52b () ()) 1898 (make-instance 'testclass52d) 1899 (list 1900 finalize-inheritance-history 1901 (progn 1902 (remove-method #'clos:finalize-inheritance 1903 (find-method #'clos:finalize-inheritance '(:after) 1904 (list (find-class 'class)))) 1905 (symbols-cleanup '(testclass52a testclass52b testclass52c testclass52d))))) 1906((TESTCLASS52D TESTCLASS52C TESTCLASS52B TESTCLASS52A) ()) 1907 1908 1909;;; Check that extending many MOP generic functions is possible, however 1910;;; overriding methods of these MOP generic functions is forbidden. 1911 1912;; Check class-default-initargs. 1913(let ((*sampclass* (defclass sampclass01 () ()))) 1914 (defmethod clos:class-default-initargs ((c (eql *sampclass*))) 1915 (call-next-method)) 1916 (unless (clos:class-finalized-p *sampclass*) 1917 (clos:finalize-inheritance *sampclass*)) 1918 (clos:class-default-initargs *sampclass*) 1919 t) 1920T 1921(let ((*sampclass* (defclass sampclass02 () ()))) 1922 (let ((badmethod 1923 (defmethod clos:class-default-initargs ((c (eql *sampclass*))) 1924 (values (call-next-method) t)))) 1925 (unless (clos:class-finalized-p *sampclass*) 1926 (clos:finalize-inheritance *sampclass*)) 1927 (unwind-protect 1928 (nth-value 1 (clos:class-default-initargs *sampclass*)) 1929 (remove-method #'clos:class-default-initargs badmethod)))) 1930#+CLISP ERROR 1931#-CLISP T 1932 1933;; Check class-direct-default-initargs. 1934(let ((*sampclass* (defclass sampclass03 () ()))) 1935 (defmethod clos:class-direct-default-initargs ((c (eql *sampclass*))) 1936 (call-next-method)) 1937 (clos:class-direct-default-initargs *sampclass*) 1938 t) 1939T 1940(let ((*sampclass* (defclass sampclass04 () ()))) 1941 (let ((badmethod 1942 (defmethod clos:class-direct-default-initargs ((c (eql *sampclass*))) 1943 (values (call-next-method) t)))) 1944 (unwind-protect 1945 (nth-value 1 (clos:class-direct-default-initargs *sampclass*)) 1946 (remove-method #'clos:class-direct-default-initargs badmethod)))) 1947#+CLISP ERROR 1948#-CLISP T 1949 1950;; Check class-direct-slots. 1951(let ((*sampclass* (defclass sampclass05 () ()))) 1952 (defmethod clos:class-direct-slots ((c (eql *sampclass*))) 1953 (call-next-method)) 1954 (clos:class-direct-slots *sampclass*) 1955 t) 1956T 1957(let ((*sampclass* (defclass sampclass06 () ()))) 1958 (let ((badmethod 1959 (defmethod clos:class-direct-slots ((c (eql *sampclass*))) 1960 (values (call-next-method) t)))) 1961 (unwind-protect 1962 (nth-value 1 (clos:class-direct-slots *sampclass*)) 1963 (remove-method #'clos:class-direct-slots badmethod)))) 1964#+CLISP ERROR 1965#-CLISP T 1966 1967;; Check class-direct-superclasses. 1968(let ((*sampclass* (defclass sampclass07 () ()))) 1969 (defmethod clos:class-direct-superclasses ((c (eql *sampclass*))) 1970 (call-next-method)) 1971 (clos:class-direct-superclasses *sampclass*) 1972 t) 1973T 1974(let ((*sampclass* (defclass sampclass08 () ()))) 1975 (let ((badmethod 1976 (defmethod clos:class-direct-superclasses ((c (eql *sampclass*))) 1977 (values (call-next-method) t)))) 1978 (unwind-protect 1979 (nth-value 1 (clos:class-direct-superclasses *sampclass*)) 1980 (remove-method #'clos:class-direct-superclasses badmethod)))) 1981#+CLISP ERROR 1982#-CLISP T 1983 1984;; Check class-finalized-p. 1985(let ((*sampclass* (defclass sampclass09 () ()))) 1986 (defmethod clos:class-finalized-p ((c (eql *sampclass*))) 1987 (call-next-method)) 1988 (clos:class-finalized-p *sampclass*) 1989 t) 1990T 1991(let ((*sampclass* (defclass sampclass10 () ()))) 1992 (let ((badmethod 1993 (defmethod clos:class-finalized-p ((c (eql *sampclass*))) 1994 (values (call-next-method) t)))) 1995 (unwind-protect 1996 (nth-value 1 (clos:class-finalized-p *sampclass*)) 1997 (remove-method #'clos:class-finalized-p badmethod)))) 1998#+CLISP ERROR 1999#-CLISP T 2000 2001;; Check class-precedence-list. 2002(let ((*sampclass* (defclass sampclass11 () ()))) 2003 (defmethod clos:class-precedence-list ((c (eql *sampclass*))) 2004 (call-next-method)) 2005 (unless (clos:class-finalized-p *sampclass*) 2006 (clos:finalize-inheritance *sampclass*)) 2007 (clos:class-precedence-list *sampclass*) 2008 t) 2009T 2010(let ((*sampclass* (defclass sampclass12 () ()))) 2011 (let ((badmethod 2012 (defmethod clos:class-precedence-list ((c (eql *sampclass*))) 2013 (values (call-next-method) t)))) 2014 (unless (clos:class-finalized-p *sampclass*) 2015 (clos:finalize-inheritance *sampclass*)) 2016 (unwind-protect 2017 (nth-value 1 (clos:class-precedence-list *sampclass*)) 2018 (remove-method #'clos:class-precedence-list badmethod)))) 2019#+CLISP ERROR 2020#-CLISP T 2021 2022;; Check class-prototype. 2023(let ((*sampclass* (defclass sampclass13 () ()))) 2024 (defmethod clos:class-prototype ((c (eql *sampclass*))) 2025 (call-next-method)) 2026 (unless (clos:class-finalized-p *sampclass*) 2027 (clos:finalize-inheritance *sampclass*)) 2028 (clos:class-prototype *sampclass*) 2029 t) 2030T 2031(let ((*sampclass* (defclass sampclass14 () ()))) 2032 (let ((badmethod 2033 (defmethod clos:class-prototype ((c (eql *sampclass*))) 2034 (values (call-next-method) t)))) 2035 (unless (clos:class-finalized-p *sampclass*) 2036 (clos:finalize-inheritance *sampclass*)) 2037 (unwind-protect 2038 (nth-value 1 (clos:class-prototype *sampclass*)) 2039 (remove-method #'clos:class-prototype badmethod)))) 2040#+CLISP ERROR 2041#-CLISP T 2042 2043;; Check class-slots. 2044(let ((*sampclass* (defclass sampclass15 () ()))) 2045 (defmethod clos:class-slots ((c (eql *sampclass*))) 2046 (call-next-method)) 2047 (unless (clos:class-finalized-p *sampclass*) 2048 (clos:finalize-inheritance *sampclass*)) 2049 (clos:class-slots *sampclass*) 2050 t) 2051T 2052(let ((*sampclass* (defclass sampclass16 () ()))) 2053 (let ((badmethod 2054 (defmethod clos:class-slots ((c (eql *sampclass*))) 2055 (values (call-next-method) t)))) 2056 (unless (clos:class-finalized-p *sampclass*) 2057 (clos:finalize-inheritance *sampclass*)) 2058 (unwind-protect 2059 (nth-value 1 (clos:class-slots *sampclass*)) 2060 (remove-method #'clos:class-slots badmethod)))) 2061#+CLISP ERROR 2062#-CLISP T 2063 2064;; Check (setf class-name). 2065(let ((*sampclass* (defclass sampclass17 () ()))) 2066 (defmethod (setf class-name) (new-value (c (eql *sampclass*))) 2067 (call-next-method)) 2068 (setf (class-name *sampclass*) 'sampclass17renamed) 2069 t) 2070T 2071(let ((*sampclass* (defclass sampclass18 () ()))) 2072 (let ((badmethod 2073 (defmethod (setf class-name) (new-value (c (eql *sampclass*))) 2074 (values (call-next-method) t)))) 2075 (unwind-protect 2076 (nth-value 1 (setf (class-name *sampclass*) 'sampclass18renamed)) 2077 (remove-method #'(setf class-name) badmethod)))) 2078#+CLISP ERROR 2079#-CLISP T 2080 2081;; Check finalize-inheritance. 2082(let ((*sampclass* (defclass sampclass19 () ()))) 2083 (defmethod clos:finalize-inheritance ((c (eql *sampclass*))) 2084 (call-next-method)) 2085 (clos:finalize-inheritance *sampclass*) 2086 t) 2087T 2088(let ((*sampclass* (defclass sampclass20 () ()))) 2089 (let ((badmethod 2090 (defmethod clos:finalize-inheritance ((c (eql *sampclass*))) 2091 (values (call-next-method) t)))) 2092 (unwind-protect 2093 (nth-value 1 (clos:finalize-inheritance *sampclass*)) 2094 (remove-method #'clos:finalize-inheritance badmethod)))) 2095#+CLISP ERROR 2096#-CLISP T 2097 2098;; Check find-method-combination. 2099(let ((*sampgf* (defgeneric sampgf01 (x y)))) 2100 (defmethod clos:find-method-combination ((gf (eql *sampgf*)) name options) 2101 (call-next-method)) 2102 (clos:find-method-combination *sampgf* 'standard nil) 2103 t) 2104T 2105(let ((*sampgf* (defgeneric sampgf02 (x y)))) 2106 (let ((badmethod 2107 (defmethod clos:find-method-combination ((gf (eql *sampgf*)) name options) 2108 (values (call-next-method) t)))) 2109 (unwind-protect 2110 (nth-value 1 (clos:find-method-combination *sampgf* 'standard nil)) 2111 (remove-method #'clos:find-method-combination badmethod)))) 2112#+CLISP ERROR 2113#-CLISP T 2114 2115;; Check generic-function-argument-precedence-order. 2116(let ((*sampgf* (defgeneric sampgf03 (x y)))) 2117 (defmethod clos:generic-function-argument-precedence-order ((gf (eql *sampgf*))) 2118 (call-next-method)) 2119 (clos:generic-function-argument-precedence-order *sampgf*) 2120 t) 2121T 2122(let ((*sampgf* (defgeneric sampgf04 (x y)))) 2123 (let ((badmethod 2124 (defmethod clos:generic-function-argument-precedence-order ((gf (eql *sampgf*))) 2125 (values (call-next-method) t)))) 2126 (unwind-protect 2127 (nth-value 1 (clos:generic-function-argument-precedence-order *sampgf*)) 2128 (remove-method #'clos:generic-function-argument-precedence-order badmethod)))) 2129#+CLISP ERROR 2130#-CLISP T 2131 2132;; Check generic-function-declarations. 2133(let ((*sampgf* (defgeneric sampgf05 (x y)))) 2134 (defmethod clos:generic-function-declarations ((gf (eql *sampgf*))) 2135 (call-next-method)) 2136 (clos:generic-function-declarations *sampgf*) 2137 t) 2138T 2139(let ((*sampgf* (defgeneric sampgf06 (x y)))) 2140 (let ((badmethod 2141 (defmethod clos:generic-function-declarations ((gf (eql *sampgf*))) 2142 (values (call-next-method) t)))) 2143 (unwind-protect 2144 (nth-value 1 (clos:generic-function-declarations *sampgf*)) 2145 (remove-method #'clos:generic-function-declarations badmethod)))) 2146#+CLISP ERROR 2147#-CLISP T 2148 2149;; Check generic-function-lambda-list. 2150(let ((*sampgf* (defgeneric sampgf07 (x y)))) 2151 (defmethod clos:generic-function-lambda-list ((gf (eql *sampgf*))) 2152 (call-next-method)) 2153 (clos:generic-function-lambda-list *sampgf*) 2154 t) 2155T 2156(let ((*sampgf* (defgeneric sampgf08 (x y)))) 2157 (let ((badmethod 2158 (defmethod clos:generic-function-lambda-list ((gf (eql *sampgf*))) 2159 (values (call-next-method) t)))) 2160 (unwind-protect 2161 (nth-value 1 (clos:generic-function-lambda-list *sampgf*)) 2162 (remove-method #'clos:generic-function-lambda-list badmethod)))) 2163#+CLISP ERROR 2164#-CLISP T 2165 2166;; Check generic-function-method-class. 2167(let ((*sampgf* (defgeneric sampgf09 (x y)))) 2168 (defmethod clos:generic-function-method-class ((gf (eql *sampgf*))) 2169 (call-next-method)) 2170 (clos:generic-function-method-class *sampgf*) 2171 t) 2172T 2173(let ((*sampgf* (defgeneric sampgf10 (x y)))) 2174 (let ((badmethod 2175 (defmethod clos:generic-function-method-class ((gf (eql *sampgf*))) 2176 (values (call-next-method) t)))) 2177 (unwind-protect 2178 (nth-value 1 (clos:generic-function-method-class *sampgf*)) 2179 (remove-method #'clos:generic-function-method-class badmethod)))) 2180#+CLISP ERROR 2181#-CLISP T 2182 2183;; Check generic-function-method-combination. 2184#-LISPWORKS 2185(let ((*sampgf* (defgeneric sampgf11 (x y)))) 2186 (defmethod clos:generic-function-method-combination ((gf (eql *sampgf*))) 2187 (call-next-method)) 2188 (clos:generic-function-method-combination *sampgf*) 2189 t) 2190#-LISPWORKS 2191T 2192#-LISPWORKS 2193(let ((*sampgf* (defgeneric sampgf12 (x y)))) 2194 (let ((badmethod 2195 (defmethod clos:generic-function-method-combination ((gf (eql *sampgf*))) 2196 (values (call-next-method) t)))) 2197 (unwind-protect 2198 (nth-value 1 (clos:generic-function-method-combination *sampgf*)) 2199 (remove-method #'clos:generic-function-method-combination badmethod)))) 2200#+CLISP ERROR 2201#-(or CLISP LISPWORKS) T 2202 2203;; Check generic-function-methods. 2204(let ((*sampgf* (defgeneric sampgf13 (x y)))) 2205 (defmethod clos:generic-function-methods ((gf (eql *sampgf*))) 2206 (call-next-method)) 2207 (clos:generic-function-methods *sampgf*) 2208 t) 2209T 2210(let ((*sampgf* (defgeneric sampgf14 (x y)))) 2211 (let ((badmethod 2212 (defmethod clos:generic-function-methods ((gf (eql *sampgf*))) 2213 (values (call-next-method) t)))) 2214 (unwind-protect 2215 (nth-value 1 (clos:generic-function-methods *sampgf*)) 2216 (remove-method #'clos:generic-function-methods badmethod)))) 2217#+CLISP ERROR 2218#-CLISP T 2219 2220;; Check generic-function-name. 2221(let ((*sampgf* (defgeneric sampgf15 (x y)))) 2222 (defmethod clos:generic-function-name ((gf (eql *sampgf*))) 2223 (call-next-method)) 2224 (clos:generic-function-name *sampgf*) 2225 t) 2226T 2227(let ((*sampgf* (defgeneric sampgf16 (x y)))) 2228 (let ((badmethod 2229 (defmethod clos:generic-function-name ((gf (eql *sampgf*))) 2230 (values (call-next-method) t)))) 2231 (unwind-protect 2232 (nth-value 1 (clos:generic-function-name *sampgf*)) 2233 (remove-method #'clos:generic-function-name badmethod)))) 2234#+CLISP ERROR 2235#-CLISP T 2236 2237;; Check (setf generic-function-name). 2238(let ((*sampgf* (defgeneric sampgf17 (x y)))) 2239 (defmethod (setf clos:generic-function-name) (new-value (gf (eql *sampgf*))) 2240 (call-next-method)) 2241 (setf (clos:generic-function-name *sampgf*) 'sampgf17renamed) 2242 t) 2243T 2244(let ((*sampgf* (defgeneric sampgf18 (x y)))) 2245 (let ((badmethod 2246 (defmethod (setf clos:generic-function-name) (new-value (gf (eql *sampgf*))) 2247 (values (call-next-method) t)))) 2248 (unwind-protect 2249 (nth-value 1 (setf (clos:generic-function-name *sampgf*) 'sampgf18renamed)) 2250 (remove-method #'(setf clos:generic-function-name) badmethod)))) 2251#+CLISP ERROR 2252#-CLISP T 2253 2254;; Check method-function. 2255(let ((*sampmethod* (defmethod sampgf19 () 'bar))) 2256 (defmethod clos:method-function ((method (eql *sampmethod*))) 2257 (call-next-method)) 2258 (clos:method-function *sampmethod*) 2259 t) 2260T 2261(let ((*sampmethod* (defmethod sampgf20 () 'bar))) 2262 (let ((badmethod 2263 (defmethod clos:method-function ((method (eql *sampmethod*))) 2264 (values (call-next-method) t)))) 2265 (unwind-protect 2266 (nth-value 1 (clos:method-function *sampmethod*)) 2267 (remove-method #'clos:method-function badmethod)))) 2268#+CLISP ERROR 2269#-CLISP T 2270 2271;; Check method-generic-function. 2272#-LISPWORKS 2273(let ((*sampmethod* (defmethod sampgf21 () 'bar))) 2274 (defmethod clos:method-generic-function ((method (eql *sampmethod*))) 2275 (call-next-method)) 2276 (clos:method-generic-function *sampmethod*) 2277 t) 2278#-LISPWORKS 2279T 2280#-LISPWORKS 2281(let ((*sampmethod* (defmethod sampgf22 () 'bar))) 2282 (let ((badmethod 2283 (defmethod clos:method-generic-function ((method (eql *sampmethod*))) 2284 (values (call-next-method) t)))) 2285 (unwind-protect 2286 (nth-value 1 (clos:method-generic-function *sampmethod*)) 2287 (remove-method #'clos:method-generic-function badmethod)))) 2288#+CLISP ERROR 2289#-(or CLISP LISPWORKS) T 2290 2291;; Check method-lambda-list. 2292(let ((*sampmethod* (defmethod sampgf23 () 'bar))) 2293 (defmethod clos:method-lambda-list ((method (eql *sampmethod*))) 2294 (call-next-method)) 2295 (clos:method-lambda-list *sampmethod*) 2296 t) 2297T 2298(let ((*sampmethod* (defmethod sampgf24 () 'bar))) 2299 (let ((badmethod 2300 (defmethod clos:method-lambda-list ((method (eql *sampmethod*))) 2301 (values (call-next-method) t)))) 2302 (unwind-protect 2303 (nth-value 1 (clos:method-lambda-list *sampmethod*)) 2304 (remove-method #'clos:method-lambda-list badmethod)))) 2305#+CLISP ERROR 2306#-CLISP T 2307 2308;; Check method-specializers. 2309#-LISPWORKS 2310(let ((*sampmethod* (defmethod sampgf25 () 'bar))) 2311 (defmethod clos:method-specializers ((method (eql *sampmethod*))) 2312 (call-next-method)) 2313 (clos:method-specializers *sampmethod*) 2314 t) 2315#-LISPWORKS 2316T 2317#-LISPWORKS 2318(let ((*sampmethod* (defmethod sampgf26 () 'bar))) 2319 (let ((badmethod 2320 (defmethod clos:method-specializers ((method (eql *sampmethod*))) 2321 (values (call-next-method) t)))) 2322 (unwind-protect 2323 (nth-value 1 (clos:method-specializers *sampmethod*)) 2324 (remove-method #'clos:method-specializers badmethod)))) 2325#+CLISP ERROR 2326#-(or CLISP LISPWORKS) T 2327 2328;; Check accessor-method-slot-definition. 2329#-LISPWORKS 2330(let ((*sampmethod* 2331 (progn (defclass sampclass21 () ((x :reader sampclass21x))) 2332 (first (clos:generic-function-methods #'sampclass21x))))) 2333 (defmethod clos:accessor-method-slot-definition ((method (eql *sampmethod*))) 2334 (call-next-method)) 2335 (clos:accessor-method-slot-definition *sampmethod*) 2336 t) 2337#-LISPWORKS 2338T 2339#-LISPWORKS 2340(let ((*sampmethod* 2341 (progn (defclass sampclass22 () ((x :reader sampclass22x))) 2342 (first (clos:generic-function-methods #'sampclass22x))))) 2343 (let ((badmethod 2344 (defmethod clos:accessor-method-slot-definition ((slotdef (eql *sampmethod*))) 2345 (values (call-next-method) t)))) 2346 (unwind-protect 2347 (nth-value 1 (clos:accessor-method-slot-definition *sampmethod*)) 2348 (remove-method #'clos:accessor-method-slot-definition badmethod)))) 2349#+CLISP ERROR 2350#-(or CLISP LISPWORKS) T 2351 2352;; Check slot-definition-allocation. 2353(let ((*sampslot* 2354 (first (clos:class-direct-slots (defclass sampclass23 () ((x))))))) 2355 (defmethod clos:slot-definition-allocation ((slotdef (eql *sampslot*))) 2356 (call-next-method)) 2357 (clos:slot-definition-allocation *sampslot*) 2358 t) 2359T 2360(let ((*sampslot* 2361 (first (clos:class-direct-slots (defclass sampclass24 () ((x))))))) 2362 (let ((badmethod 2363 (defmethod clos:slot-definition-allocation ((slotdef (eql *sampslot*))) 2364 (values (call-next-method) t)))) 2365 (unwind-protect 2366 (nth-value 1 (clos:slot-definition-allocation *sampslot*)) 2367 (remove-method #'clos:slot-definition-allocation badmethod)))) 2368#+CLISP ERROR 2369#-CLISP T 2370 2371;; Check slot-definition-initargs. 2372(let ((*sampslot* 2373 (first (clos:class-direct-slots (defclass sampclass25 () ((x))))))) 2374 (defmethod clos:slot-definition-initargs ((slotdef (eql *sampslot*))) 2375 (call-next-method)) 2376 (clos:slot-definition-initargs *sampslot*) 2377 t) 2378T 2379(let ((*sampslot* 2380 (first (clos:class-direct-slots (defclass sampclass26 () ((x))))))) 2381 (let ((badmethod 2382 (defmethod clos:slot-definition-initargs ((slotdef (eql *sampslot*))) 2383 (values (call-next-method) t)))) 2384 (unwind-protect 2385 (nth-value 1 (clos:slot-definition-initargs *sampslot*)) 2386 (remove-method #'clos:slot-definition-initargs badmethod)))) 2387#+CLISP ERROR 2388#-CLISP T 2389 2390;; Check slot-definition-initform. 2391(let ((*sampslot* 2392 (first (clos:class-direct-slots (defclass sampclass27 () ((x))))))) 2393 (defmethod clos:slot-definition-initform ((slotdef (eql *sampslot*))) 2394 (call-next-method)) 2395 (clos:slot-definition-initform *sampslot*) 2396 t) 2397T 2398(let ((*sampslot* 2399 (first (clos:class-direct-slots (defclass sampclass28 () ((x))))))) 2400 (let ((badmethod 2401 (defmethod clos:slot-definition-initform ((slotdef (eql *sampslot*))) 2402 (values (call-next-method) t)))) 2403 (unwind-protect 2404 (nth-value 1 (clos:slot-definition-initform *sampslot*)) 2405 (remove-method #'clos:slot-definition-initform badmethod)))) 2406#+CLISP ERROR 2407#-CLISP T 2408 2409;; Check slot-definition-initfunction. 2410(let ((*sampslot* 2411 (first (clos:class-direct-slots (defclass sampclass29 () ((x))))))) 2412 (defmethod clos:slot-definition-initfunction ((slotdef (eql *sampslot*))) 2413 (call-next-method)) 2414 (clos:slot-definition-initfunction *sampslot*) 2415 t) 2416T 2417(let ((*sampslot* 2418 (first (clos:class-direct-slots (defclass sampclass30 () ((x))))))) 2419 (let ((badmethod 2420 (defmethod clos:slot-definition-initfunction ((slotdef (eql *sampslot*))) 2421 (values (call-next-method) t)))) 2422 (unwind-protect 2423 (nth-value 1 (clos:slot-definition-initfunction *sampslot*)) 2424 (remove-method #'clos:slot-definition-initfunction badmethod)))) 2425#+CLISP ERROR 2426#-CLISP T 2427 2428;; Check slot-definition-name. 2429(let ((*sampslot* 2430 (first (clos:class-direct-slots (defclass sampclass31 () ((x))))))) 2431 (defmethod clos:slot-definition-name ((slotdef (eql *sampslot*))) 2432 (call-next-method)) 2433 (clos:slot-definition-name *sampslot*) 2434 t) 2435T 2436(let ((*sampslot* 2437 (first (clos:class-direct-slots (defclass sampclass32 () ((x))))))) 2438 (let ((badmethod 2439 (defmethod clos:slot-definition-name ((slotdef (eql *sampslot*))) 2440 (values (call-next-method) t)))) 2441 (unwind-protect 2442 (nth-value 1 (clos:slot-definition-name *sampslot*)) 2443 (remove-method #'clos:slot-definition-name badmethod)))) 2444#+CLISP ERROR 2445#-CLISP T 2446 2447;; Check slot-definition-type. 2448(let ((*sampslot* 2449 (first (clos:class-direct-slots (defclass sampclass33 () ((x))))))) 2450 (defmethod clos:slot-definition-type ((slotdef (eql *sampslot*))) 2451 (call-next-method)) 2452 (clos:slot-definition-type *sampslot*) 2453 t) 2454T 2455(let ((*sampslot* 2456 (first (clos:class-direct-slots (defclass sampclass34 () ((x))))))) 2457 (let ((badmethod 2458 (defmethod clos:slot-definition-type ((slotdef (eql *sampslot*))) 2459 (values (call-next-method) t)))) 2460 (unwind-protect 2461 (nth-value 1 (clos:slot-definition-type *sampslot*)) 2462 (remove-method #'clos:slot-definition-type badmethod)))) 2463#+CLISP ERROR 2464#-CLISP T 2465 2466;; Check slot-definition-readers. 2467(let ((*sampslot* 2468 (first (clos:class-direct-slots (defclass sampclass35 () ((x))))))) 2469 (defmethod clos:slot-definition-readers ((slotdef (eql *sampslot*))) 2470 (call-next-method)) 2471 (clos:slot-definition-readers *sampslot*) 2472 t) 2473T 2474(let ((*sampslot* 2475 (first (clos:class-direct-slots (defclass sampclass36 () ((x))))))) 2476 (let ((badmethod 2477 (defmethod clos:slot-definition-readers ((slotdef (eql *sampslot*))) 2478 (values (call-next-method) t)))) 2479 (unwind-protect 2480 (nth-value 1 (clos:slot-definition-readers *sampslot*)) 2481 (remove-method #'clos:slot-definition-readers badmethod)))) 2482#+CLISP ERROR 2483#-CLISP T 2484 2485#+CLISP 2486(let ((struct (defstruct struct04 slot1))) 2487 (nconc (mapcar #'clos:slot-definition-readers 2488 (clos:class-direct-slots (find-class struct))) 2489 (mapcar #'clos:slot-definition-writers 2490 (clos:class-direct-slots (find-class struct))))) 2491#+CLISP ((STRUCT04-SLOT1) ((SETF STRUCT04-SLOT1))) 2492 2493#+CLISP 2494(let ((struct (defstruct struct04ro (slot1 t :read-only t)))) 2495 (nconc (mapcar #'clos:slot-definition-readers 2496 (clos:class-direct-slots (find-class struct))) 2497 (mapcar #'clos:slot-definition-writers 2498 (clos:class-direct-slots (find-class struct))))) 2499#+CLISP ((STRUCT04RO-SLOT1) NIL) 2500 2501#+CLISP 2502(let ((struct (defstruct (struct04v (:type vector)) slot1))) 2503 (nconc (mapcar #'clos:slot-definition-readers 2504 (sys::structure-direct-slots struct)) 2505 (mapcar #'clos:slot-definition-writers 2506 (sys::structure-direct-slots struct)))) 2507#+CLISP ((STRUCT04V-SLOT1) ((SETF STRUCT04V-SLOT1))) 2508 2509#+CLISP 2510(let ((struct (defstruct (struct04rov (:type vector)) (slot1 t :read-only t)))) 2511 (nconc (mapcar #'clos:slot-definition-readers 2512 (sys::structure-direct-slots struct)) 2513 (mapcar #'clos:slot-definition-writers 2514 (sys::structure-direct-slots struct)))) 2515#+CLISP ((STRUCT04ROV-SLOT1) NIL) 2516 2517;; check that there are no redefinition warnings 2518(let* ((f "mop-tst-defstruct-test.lisp") 2519 #+CLISP (custom:*suppress-check-redefinition* nil) 2520 (*break-on-signals* t)) 2521 (with-open-file (s f :direction :output :if-exists :supersede) 2522 (write '(defstruct struct05 slot) :stream s) (terpri s) 2523 (write '(defstruct (struct05v (:type vector)) slotv) :stream s) (terpri s)) 2524 (unwind-protect (progn (compile-file f) nil) 2525 (post-compile-file-cleanup f))) 2526NIL 2527 2528;; Check slot-definition-writers. 2529(let ((*sampslot* 2530 (first (clos:class-direct-slots (defclass sampclass37 () ((x))))))) 2531 (defmethod clos:slot-definition-writers ((slotdef (eql *sampslot*))) 2532 (call-next-method)) 2533 (clos:slot-definition-writers *sampslot*) 2534 t) 2535T 2536(let ((*sampslot* 2537 (first (clos:class-direct-slots (defclass sampclass38 () ((x))))))) 2538 (let ((badmethod 2539 (defmethod clos:slot-definition-writers ((slotdef (eql *sampslot*))) 2540 (values (call-next-method) t)))) 2541 (unwind-protect 2542 (nth-value 1 (clos:slot-definition-writers *sampslot*)) 2543 (remove-method #'clos:slot-definition-writers badmethod)))) 2544#+CLISP ERROR 2545#-CLISP T 2546 2547;; Check slot-definition-location. 2548(let ((*sampclass* (defclass sampclass39 () ((x))))) 2549 (unless (clos:class-finalized-p *sampclass*) 2550 (clos:finalize-inheritance *sampclass*)) 2551 (let ((*sampslot* (first (clos:class-slots *sampclass*)))) 2552 (defmethod clos:slot-definition-location ((slotdef (eql *sampslot*))) 2553 (call-next-method)) 2554 (clos:slot-definition-location *sampslot*) 2555 t)) 2556T 2557(let ((*sampclass* (defclass sampclass39 () ((x))))) 2558 (unless (clos:class-finalized-p *sampclass*) 2559 (clos:finalize-inheritance *sampclass*)) 2560 (let ((*sampslot* (first (clos:class-slots *sampclass*)))) 2561 (let ((badmethod 2562 (defmethod clos:slot-definition-location ((slotdef (eql *sampslot*))) 2563 (values (call-next-method) t)))) 2564 (unwind-protect 2565 (nth-value 1 (clos:slot-definition-location *sampslot*)) 2566 (remove-method #'clos:slot-definition-location badmethod))))) 2567#+CLISP ERROR 2568#-CLISP T 2569 2570 2571;; Check that DEFMETHOD calls ADD-METHOD. 2572(let ((add-method-called nil)) 2573 (defclass testgenericfunction142 (standard-generic-function) 2574 () 2575 (:metaclass clos:funcallable-standard-class)) 2576 (defmethod add-method :before ((gf testgenericfunction142) (method standard-method)) 2577 (setq add-method-called t)) 2578 (defgeneric testgf142 (x) 2579 (:generic-function-class testgenericfunction142)) 2580 (defmethod testgf142 (x) 2581 (declare (ignore x))) 2582 (list add-method-called (symbols-cleanup '(testgenericfunction142 testgf142)))) 2583(T ()) 2584 2585 2586;; Check that DEFMETHOD calls REMOVE-METHOD. 2587(let ((remove-method-called nil)) 2588 (defclass testgenericfunction143 (standard-generic-function) 2589 () 2590 (:metaclass clos:funcallable-standard-class)) 2591 (defmethod remove-method :before ((gf testgenericfunction143) (method standard-method)) 2592 (setq remove-method-called t)) 2593 (defgeneric testgf143 (x) 2594 (:generic-function-class testgenericfunction143)) 2595 (defmethod testgf143 (x) 2596 (declare (ignore x)) 2597 17) 2598 (defmethod testgf143 (x) 2599 (declare (ignore x)) 2600 19) 2601 (list remove-method-called (symbols-cleanup '(testgenericfunction143 testgf143)))) 2602(T ()) 2603 2604 2605;; Check that it's possible to call methods individually. 2606(progn 2607 (defgeneric foo141 (x) 2608 (:method ((x integer)) (isqrt x)) 2609 (:method ((x real)) (- x))) 2610 (let ((my-method (find-method #'foo141 nil (list (find-class 'real)))) 2611 (my-arglist (list 43))) 2612 (list (funcall (clos:method-function my-method) my-arglist '()) 2613 (symbol-cleanup 'foo141)))) 2614(-43 T) 2615 2616 2617;; Check that it's possible to create custom method classes. 2618(progn 2619 (defclass custom-method (method) 2620 ((qualifiers :reader method-qualifiers 2621 :writer (setf custom-method-qualifiers)) 2622 (lambda-list :reader method-lambda-list 2623 :writer (setf custom-method-lambda-list)) 2624 (specializers :reader method-specializers 2625 :writer (setf custom-method-specializers)) 2626 (function :reader method-function 2627 :writer (setf custom-method-function)) 2628 (documentation :accessor custom-method-documentation) 2629 (generic-function :reader method-generic-function 2630 :writer (setf custom-method-generic-function)))) 2631 (defmethod shared-initialize ((method custom-method) situation &rest args 2632 &key (qualifiers nil qualifiers-p) 2633 (lambda-list nil lambda-list-p) 2634 (specializers nil specializers-p) 2635 (function nil function-p) 2636 (documentation nil documentation-p)) 2637 (call-next-method) 2638 (when (or (eq situation 't) qualifiers-p) 2639 (setf (custom-method-qualifiers method) qualifiers)) 2640 (when (or (eq situation 't) lambda-list-p) 2641 (setf (custom-method-lambda-list method) lambda-list)) 2642 (when (or (eq situation 't) specializers-p) 2643 (setf (custom-method-specializers method) specializers)) 2644 (when (or (eq situation 't) function-p) 2645 (setf (custom-method-function method) function)) 2646 (when (or (eq situation 't) documentation-p) 2647 (setf (custom-method-documentation method) documentation)) 2648 (when (eq situation 't) 2649 (setf (custom-method-generic-function method) nil)) 2650 method) 2651 (defmethod documentation ((x custom-method) (doc-type (eql 't))) 2652 (declare (ignore doc-type)) 2653 (custom-method-documentation x)) 2654 (defmethod (setf documentation) (new-value (x custom-method) (doc-type (eql 't))) 2655 (declare (ignore doc-type)) 2656 (setf (custom-method-documentation x) new-value)) 2657 ;; (setf method-generic-function) is a CLISP extension. 2658 (defmethod (setf method-generic-function) (new-gf (method custom-method)) 2659 (setf (custom-method-generic-function method) new-gf)) 2660 #| ; Instead of overriding add-method and remove-method: 2661 (defmethod add-method ((gf standard-generic-function) (m custom-method)) 2662 (setf (custom-method-generic-function m) gf) 2663 (call-next-method)) 2664 (defmethod remove-method ((gf standard-generic-function) (m custom-method)) 2665 (setf (custom-method-generic-function m) nil) 2666 (call-next-method)) 2667 |# 2668 (let ((result '())) 2669 (defgeneric testgf30 (a b) 2670 (:method ((a integer) (b integer)) (- (call-next-method) (floor a b))) 2671 (:method ((a real) (b real)) (/ (float a) (float b))) 2672 (:method-class custom-method)) 2673 (push (not (find-method #'testgf30 nil (list (find-class 'integer) (find-class 'integer)) nil)) 2674 result) 2675 (push (testgf30 17 2) result) 2676 (defgeneric testgf30 (a b) 2677 (:method ((a real) (b real)) (/ (float a) (float b))) 2678 (:method-class custom-method)) 2679 (push (not (find-method #'testgf30 nil (list (find-class 'integer) (find-class 'integer)) nil)) 2680 result) 2681 (push (testgf30 17 2) result) 2682 (list (nreverse result) 2683 #+CLISP (clos::gf-dynamically-modifiable #'(setf custom-method-function)) 2684 #+CLISP (clos::gf-dynamically-modifiable #'custom-method-documentation) 2685 (symbols-cleanup '(testgf30))))) 2686((NIL 0.5 T 8.5) #+CLISP NIL #+CLISP NIL ()) 2687 2688 2689;; Check that changing a method's class clears the generic function's 2690;; effective-methods or discriminating-function cache. 2691(progn 2692 (defgeneric testgf34 (x)) 2693 (defmethod testgf34 ((x integer)) 2694 'old-integer) 2695 (defmethod testgf34 ((x real)) 2696 'real) 2697 (list* 2698 (testgf34 3) ; OLD-INTEGER 2699 (testgf34 22/7) ; REAL 2700 (progn 2701 (let ((method (find-method #'testgf34 '() (list (find-class 'integer))))) 2702 (change-class method (find-class 'custom-method) 2703 :qualifiers '() 2704 :lambda-list '(x) 2705 :specializers (list (find-class 'rational)) 2706 :function #'(lambda (arguments next-methods) 'new-rational) 2707 :documentation nil)) 2708 (list 2709 (testgf34 3) ; NEW-RATIONAL 2710 (testgf34 22/7) ; NEW-RATIONAL 2711 (symbols-cleanup '(custom-method testgf34)) 2712 )))) 2713(OLD-INTEGER REAL NEW-RATIONAL NEW-RATIONAL ()) 2714 2715 2716;; Check that changing a generic function's class clears its 2717;; effective-methods and discriminating-function cache. 2718; The effective-methods cache: 2719#-OpenMCL 2720(progn 2721 (defgeneric testgf35 (x)) 2722 (defmethod testgf35 ((x integer)) 2723 (cons 'integer (if (next-method-p) (call-next-method)))) 2724 (defmethod testgf35 ((x real)) 2725 (cons 'real (if (next-method-p) (call-next-method)))) 2726 (defclass customized5-generic-function (standard-generic-function) 2727 () 2728 (:metaclass clos:funcallable-standard-class)) 2729 (defmethod clos:compute-effective-method ((gf customized5-generic-function) method-combination methods) 2730 `(REVERSE ,(call-next-method))) 2731 (list 2732 (testgf35 3) 2733 (progn 2734 (change-class #'testgf35 'customized5-generic-function) 2735 (testgf35 3)) 2736 (symbols-cleanup '(testgf35 customized5-generic-function)))) 2737#-OpenMCL 2738((INTEGER REAL) (REAL INTEGER) ()) 2739; The discriminating-function cache: 2740#-OpenMCL 2741(progn 2742 (defgeneric testgf36 (x)) 2743 (defmethod testgf36 ((x integer)) 2744 (cons 'integer (if (next-method-p) (call-next-method)))) 2745 (defmethod testgf36 ((x real)) 2746 (cons 'real (if (next-method-p) (call-next-method)))) 2747 (defclass customized6-generic-function (standard-generic-function) 2748 () 2749 (:metaclass clos:funcallable-standard-class)) 2750 (defmethod clos:compute-discriminating-function ((gf customized6-generic-function)) 2751 (let ((orig-df (call-next-method))) 2752 #'(lambda (&rest arguments) 2753 (reverse (apply orig-df arguments))))) 2754 (list 2755 (testgf36 3) 2756 (progn 2757 (change-class #'testgf36 'customized6-generic-function) 2758 (testgf36 3)) 2759 (symbols-cleanup '(testgf36 customized6-generic-function)))) 2760#-OpenMCL 2761((INTEGER REAL) (REAL INTEGER) ()) 2762 2763 2764#| ;; Not implemented, because the MOP's description of 2765 ;; compute-discriminating-function doesn't say that we need to invalidate 2766 ;; the effective method cache in this case. 2767 2768;; Check that defining a method on compute-applicable-methods[-using-classes] 2769;; invalidates the cache of all affected generic functions. 2770(progn 2771 (defclass customized1-generic-function (standard-generic-function) 2772 () 2773 (:metaclass clos:funcallable-standard-class)) 2774 (defgeneric testgf31 (x) 2775 (:generic-function-class customized1-generic-function)) 2776 (defmethod testgf31 ((x integer)) 2777 (cons 'integer (if (next-method-p) (call-next-method)))) 2778 (defmethod testgf31 ((x real)) 2779 (cons 'real (if (next-method-p) (call-next-method)))) 2780 (list 2781 (testgf31 3) 2782 (progn 2783 (defmethod compute-applicable-methods ((gf customized1-generic-function) args) 2784 (let ((all-applicable (call-next-method))) 2785 (if all-applicable (list (first all-applicable)) '()))) 2786 #-LISPWORKS 2787 (defmethod clos:compute-applicable-methods-using-classes ((gf customized1-generic-function) classes) 2788 (let ((all-applicable (call-next-method))) 2789 (if all-applicable (list (first all-applicable)) '()))) 2790 (testgf31 3)) 2791 (symbols-cleanup '(testgf31 customized1-generic-function)))) 2792((INTEGER REAL) (INTEGER) ()) 2793 2794;; Check that defining a method on compute-effective-method 2795;; invalidates the cache of all affected generic functions. 2796(progn 2797 (defclass customized2-generic-function (standard-generic-function) 2798 () 2799 (:metaclass clos:funcallable-standard-class)) 2800 (defgeneric testgf32 (x) 2801 (:generic-function-class customized2-generic-function)) 2802 (defmethod testgf32 ((x integer)) 2803 (cons 'integer (if (next-method-p) (call-next-method)))) 2804 (defmethod testgf32 ((x real)) 2805 (cons 'real (if (next-method-p) (call-next-method)))) 2806 (list 2807 (testgf32 3) 2808 (progn 2809 (defmethod clos:compute-effective-method ((gf customized2-generic-function) method-combination methods) 2810 `(REVERSE ,(call-next-method))) 2811 (testgf32 3)) 2812 (symbols-cleanup '(testgf32 customized2-generic-function)))) 2813((INTEGER REAL) (REAL INTEGER) ()) 2814 2815;; Check that defining a method on compute-discriminating-function 2816;; invalidates the cache of all affected generic functions. 2817(progn 2818 (defclass customized3-generic-function (standard-generic-function) 2819 () 2820 (:metaclass clos:funcallable-standard-class)) 2821 (defgeneric testgf33 (x) 2822 (:generic-function-class customized3-generic-function)) 2823 (defmethod testgf33 ((x integer)) 2824 (cons 'integer (if (next-method-p) (call-next-method)))) 2825 (defmethod testgf33 ((x real)) 2826 (cons 'real (if (next-method-p) (call-next-method)))) 2827 (list 2828 (testgf33 3) 2829 (progn 2830 (defmethod clos:compute-discriminating-function ((gf customized3-generic-function)) 2831 (let ((orig-df (call-next-method))) 2832 #'(lambda (&rest arguments) 2833 (reverse (apply orig-df arguments))))) 2834 (testgf33 3)) 2835 (symbols-cleanup '(testgf33 customized3-generic-function)))) 2836((INTEGER REAL) (REAL INTEGER) ()) 2837 2838|# 2839 2840 2841;;; Application example: Typechecked slots 2842 2843(progn 2844 (defclass typechecked-slot-definition (clos:standard-effective-slot-definition) 2845 ()) 2846 (defmethod clos:slot-value-using-class ((class standard-class) instance (slot typechecked-slot-definition)) 2847 (let ((value (call-next-method))) 2848 (unless (typep value (clos:slot-definition-type slot)) 2849 (error "Slot ~S of ~S has changed, no longer of type ~S" 2850 (clos:slot-definition-name slot) instance (clos:slot-definition-type slot))) 2851 value)) 2852 (defmethod (setf clos:slot-value-using-class) (new-value (class standard-class) instance (slot typechecked-slot-definition)) 2853 (unless (typep new-value (clos:slot-definition-type slot)) 2854 (error "Slot ~S of ~S: new value is not of type ~S: ~S" 2855 (clos:slot-definition-name slot) instance (clos:slot-definition-type slot) new-value)) 2856 (call-next-method)) 2857 (defclass typechecked-slot-definition-class (standard-class) 2858 ()) 2859 #-CLISP 2860 (defmethod clos:validate-superclass ((c1 typechecked-slot-definition-class) (c2 standard-class)) 2861 t) 2862 (defmethod clos:effective-slot-definition-class ((class typechecked-slot-definition-class) &rest args) 2863 (find-class 'typechecked-slot-definition)) 2864 (defclass testclass28 () 2865 ((pair :type (cons symbol (cons symbol null)) :initarg :pair :accessor testclass28-pair)) 2866 (:metaclass typechecked-slot-definition-class)) 2867 (macrolet ((succeeds (form) 2868 `(not (nth-value 1 (ignore-errors ,form))))) 2869 (let ((p (list 'abc 'def)) 2870 (x (make-instance 'testclass28))) 2871 (list (succeeds (make-instance 'testclass28 :pair '(seventeen 17))) 2872 (succeeds (setf (testclass28-pair x) p)) 2873 (succeeds (setf (second p) 456)) 2874 (succeeds (testclass28-pair x)) 2875 (succeeds (slot-value x 'pair)) 2876 (symbols-cleanup '(typechecked-slot-definition testclass28 testclass28-pair 2877 typechecked-slot-definition-class)))))) 2878(nil t t nil nil ()) 2879 2880 2881;;; Application example: Slot which has one value cell per subclass. 2882 2883#+(or CLISP CMU SBCL LISPWORKS) 2884(progn 2885 2886 ;; We must limit the support for per-subclass slots to those that inherit 2887 ;; from this class, because we need to specialize 2888 ;; clos:direct-slot-definition-class, clos:compute-slots and a few other 2889 ;; generic functions and must not override the method responsible for 2890 ;; standard-class. 2891 (defclass class-supporting-classof-slots (standard-class) 2892 ((slotname-to-dummyslotname :type list :initform nil))) 2893 #-CLISP 2894 (defmethod clos:validate-superclass ((c1 class-supporting-classof-slots) (c2 standard-class)) 2895 t) 2896 2897 ;; Define subclasses of direct-slot-definition that support a :per-subclass 2898 ;; option. (It's not portable to use :allocation :classof, so we use 2899 ;; :per-subclass t instead.) 2900 (defclass classof-direct-slot-definition-mixin () 2901 ()) 2902 (let ((add-mixin-table (make-hash-table :test #+clisp 'ext:stablehash-eq #-clisp 'eq))) 2903 ;; For a given direct slot definition class, returns a subclass that also 2904 ;; inherits from classof-direct-slot-definition-mixin. 2905 (defun add-classof-direct-mixin (slot-class) 2906 (if (subtypep slot-class (find-class 'classof-direct-slot-definition-mixin)) 2907 slot-class 2908 (or (gethash slot-class add-mixin-table) 2909 (setf (gethash slot-class add-mixin-table) 2910 (clos:ensure-class (make-symbol (concatenate 'string (symbol-name (class-name slot-class)) "-WITH-CLASSOF-SUPPORT")) 2911 :metaclass (class-of slot-class) 2912 :direct-superclasses (list slot-class (find-class 'classof-direct-slot-definition-mixin)))))))) 2913 (defmethod clos:direct-slot-definition-class ((class class-supporting-classof-slots) &rest initargs) 2914 (if (getf initargs ':per-subclass) 2915 (add-classof-direct-mixin (call-next-method)) 2916 (call-next-method))) 2917 (defmethod initialize-instance :after ((slot classof-direct-slot-definition-mixin) &rest initargs &key per-subclass) 2918 (declare (ignore per-subclass))) 2919 2920 ;; If the direct slot has :per-subclass t, let the effective slot have 2921 ;; :per-subclass t as well. 2922 (defmethod clos:compute-effective-slot-definition-initargs ((class class-supporting-classof-slots) #+LISPWORKS name direct-slot-definitions) 2923 (if (typep (first direct-slot-definitions) 'classof-direct-slot-definition-mixin) 2924 (append (call-next-method) (list ':per-subclass t)) 2925 (call-next-method))) 2926 2927 ;; Define subclasses of effective-slot-definition that support a :per-subclass 2928 ;; option. 2929 (defclass classof-effective-slot-definition-mixin () 2930 ((value-slot-name :type symbol))) 2931 (let ((add-mixin-table (make-hash-table :test #+clisp 'ext:stablehash-eq #-clisp 'eq))) 2932 ;; For a given effective slot definition class, returns a subclass that also 2933 ;; inherits from classof-effective-slot-definition-mixin. 2934 (defun add-classof-effective-mixin (slot-class) 2935 (if (subtypep slot-class (find-class 'classof-effective-slot-definition-mixin)) 2936 slot-class 2937 (or (gethash slot-class add-mixin-table) 2938 (setf (gethash slot-class add-mixin-table) 2939 (clos:ensure-class (make-symbol (concatenate 'string (symbol-name (class-name slot-class)) "-WITH-CLASSOF-SUPPORT")) 2940 :metaclass (class-of slot-class) 2941 :direct-superclasses (list slot-class (find-class 'classof-effective-slot-definition-mixin)))))))) 2942 (defmethod clos:effective-slot-definition-class ((class class-supporting-classof-slots) &rest initargs) 2943 (if (getf initargs ':per-subclass) 2944 (add-classof-effective-mixin (call-next-method)) 2945 (call-next-method))) 2946 (defmethod initialize-instance :after ((slot classof-effective-slot-definition-mixin) &rest initargs &key per-subclass) 2947 (declare (ignore per-subclass))) 2948 2949 ;; Add dummy effective slots, used to store the per-subclass value. 2950 ;; (Using a dummy slot here, instead of just storing the value in the 2951 ;; classof-effective-slot-definition-mixin, provides for smooth behaviour 2952 ;; when a class is redefined: the values of slots are kept, but 2953 ;; effective-slot-definitions and their contents are thrown away.) 2954 (defmethod clos:compute-slots ((class class-supporting-classof-slots)) 2955 (let* ((slots (call-next-method)) 2956 (dummy-slots 2957 (let ((old-dummyslotnames (slot-value class 'slotname-to-dummyslotname)) 2958 (new-dummyslotnames '())) 2959 (prog1 2960 (mapcan #'(lambda (slot) 2961 (if (typep slot 'classof-effective-slot-definition-mixin) 2962 (let* ((value-slot-name 2963 ;; Try to keep the same dummyslotname as in the previous 2964 ;; definition, so that the slot's value is preserved if possible. 2965 (or (getf old-dummyslotnames (clos:slot-definition-name slot)) 2966 (make-symbol (concatenate 'string 2967 "VALUE-OF-" 2968 (symbol-name (clos:slot-definition-name slot)) 2969 "-IN-" 2970 (symbol-name (class-name class)))))) 2971 (value-slot 2972 (make-instance 'clos:standard-effective-slot-definition 2973 :name value-slot-name 2974 :allocation :class 2975 :initform (clos:slot-definition-initform slot) 2976 :initfunction (clos:slot-definition-initfunction slot) 2977 :type (clos:slot-definition-type slot)))) 2978 (setf (slot-value slot 'value-slot-name) value-slot-name) 2979 (setf (getf new-dummyslotnames (clos:slot-definition-name slot)) value-slot-name) 2980 (list value-slot)) 2981 '())) 2982 slots) 2983 (setf (slot-value class 'slotname-to-dummyslotname) new-dummyslotnames))))) 2984 (append slots dummy-slots))) 2985 2986 ;; Redirect slot-value et al. from the slot with :per-subclass t to the dummy 2987 ;; slot. 2988 (defmethod clos:slot-value-using-class ((class standard-class) object (slot classof-effective-slot-definition-mixin)) 2989 (slot-value object (slot-value slot 'value-slot-name))) 2990 (defmethod (setf clos:slot-value-using-class) (new-value (class standard-class) object (slot classof-effective-slot-definition-mixin)) 2991 (setf (slot-value object (slot-value slot 'value-slot-name)) new-value)) 2992 (defmethod clos:slot-boundp-using-class ((class standard-class) object (slot classof-effective-slot-definition-mixin)) 2993 (slot-boundp object (slot-value slot 'value-slot-name))) 2994 (defmethod clos:slot-makunbound-using-class ((class standard-class) object (slot classof-effective-slot-definition-mixin)) 2995 (slot-makunbound object (slot-value slot 'value-slot-name))) 2996 2997 ;; Provide a general initialization hook, where the initform may depend on the 2998 ;; class in which it is located. 2999 (defgeneric initialize-classof-slot (class slot) 3000 (:method ((class class-supporting-classof-slots) (slot classof-effective-slot-definition-mixin)))) 3001 (defmethod initialize-instance :after ((class class-supporting-classof-slots) &rest initargs) 3002 (dolist (slot (clos:class-slots class)) 3003 (when (and (typep slot 'classof-effective-slot-definition-mixin) 3004 (not (slot-boundp (clos:class-prototype class) (clos:slot-definition-name slot)))) 3005 (initialize-classof-slot class slot)))) 3006 3007 ;; Test it. 3008 (defclass testclass29a () 3009 ((x :allocation :instance) 3010 (y :allocation :class :per-subclass t) 3011 (z :allocation :class)) 3012 (:metaclass class-supporting-classof-slots)) 3013 (defclass testclass29b (testclass29a) 3014 () 3015 (:metaclass class-supporting-classof-slots)) 3016 (let ((insta1 (make-instance 'testclass29a)) 3017 (insta2 (make-instance 'testclass29a)) 3018 (instb1 (make-instance 'testclass29b)) 3019 (instb2 (make-instance 'testclass29b))) 3020 (setf (slot-value insta1 'x) 'x1) 3021 (setf (slot-value insta1 'y) 'y1) 3022 (setf (slot-value insta1 'z) 'z1) 3023 (setf (slot-value instb1 'x) 'x2) 3024 (setf (slot-value instb1 'y) 'y2) 3025 (setf (slot-value instb1 'z) 'z2) 3026 (setf (slot-value instb2 'x) 'x3) 3027 (setf (slot-value instb2 'y) 'y3) 3028 (setf (slot-value instb2 'z) 'z3) 3029 (setf (slot-value insta2 'x) 'x4) 3030 (setf (slot-value insta2 'y) 'y4) 3031 (setf (slot-value insta2 'z) 'z4) 3032 (list (slot-value insta1 'x) (slot-value insta1 'y) (slot-value insta1 'z) 3033 (slot-value insta2 'x) (slot-value insta2 'y) (slot-value insta2 'z) 3034 (slot-value instb1 'x) (slot-value instb1 'y) (slot-value instb1 'z) 3035 (slot-value instb2 'x) (slot-value instb2 'y) (slot-value instb2 'z)))) 3036#+(or CLISP CMU SBCL LISPWORKS) 3037(x1 y4 z4 3038 x4 y4 z4 3039 x2 y3 z4 3040 x3 y3 z4) 3041 3042 3043(progn 3044 (load (merge-pathnames "mop-aux.lisp" *run-test-truename*)) 3045 (load (merge-pathnames "hash-classes.lisp" *run-test-truename*)) 3046 t) 3047t 3048 3049 3050;;; Application example: Virtual-dispatch generic functions 3051 3052;; There are two variants: 3053;; In C++, each instance contains a virtual function table at a fixed location. 3054;; In Java, the virtual function table is a member of the class. 3055;; Here we represent the virtual function table as a per-subclass shared slot. 3056;; TODO: Needs a little more work to deal with non-finalized classes. 3057 3058#+(or CLISP CMU SBCL) 3059(progn 3060 3061 ;; Every virtual generic function belongs to a particular "base class"; 3062 ;; it is only applicable to instances of this base class. Such a base class 3063 ;; must be of metaclass virtual-base-class. All subclasses of a class with 3064 ;; metaclass virtual-base-class must be of metaclass virtual-class (or 3065 ;; a subclass of it, such as virtual-base-class). 3066 3067 ;; The metaclass of all objects that can be subject to virtual dispatch. 3068 (defclass virtual-class (class-supporting-classof-slots standard-class) 3069 ()) 3070 ;; The metaclass of all classes that can be tied to a virtual generic 3071 ;; function. 3072 (defclass virtual-base-class (virtual-class) 3073 ((vt-functions ; vector of all virtual generic functions 3074 :type vector ; with this base class 3075 :accessor vtbase-vt-functions) 3076 (vt-slot-name ; name of virtual table slot in all subclasses 3077 :type symbol 3078 :accessor vtbase-vt-slot-name))) 3079 #-CLISP 3080 (defmethod clos:validate-superclass ((c1 virtual-base-class) (c2 standard-class)) 3081 t) 3082 (defmethod clos:validate-superclass ((c1 virtual-class) (c2 virtual-base-class)) 3083 t) 3084 3085 ;; Ensure every subclass is equipped with a virtual table. 3086 (defmethod initialize-instance ((class virtual-base-class) &rest initargs 3087 &key (direct-slots '())) 3088 (setf (vtbase-vt-functions class) (make-array 10 :adjustable t :fill-pointer 0)) 3089 (setf (vtbase-vt-slot-name class) (gensym "VTABLE")) 3090 (apply #'call-next-method class 3091 :direct-slots (cons (list ':name (vtbase-vt-slot-name class) 3092 ':allocation ':class ':per-subclass t 3093 ':base-class class) 3094 direct-slots) 3095 initargs)) 3096 3097 ;; The virtual table slot in all subclasses needs to have a pointer to the 3098 ;; base class where it comes from (for its initialization). Therefore we 3099 ;; need to pass the base-class pointer from the (inheritable) direct vt slot 3100 ;; to the (not inherited) effective vt slot. 3101 (defclass virtual-table-direct-slot-definition (clos:standard-direct-slot-definition classof-direct-slot-definition-mixin) 3102 ((base-class :initarg :base-class))) 3103 (defclass virtual-table-effective-slot-definition (clos:standard-effective-slot-definition classof-effective-slot-definition-mixin) 3104 ((base-class :initarg :base-class))) 3105 (defmethod clos:direct-slot-definition-class ((class virtual-base-class) &rest initargs) 3106 (if (getf initargs ':base-class) 3107 (find-class 'virtual-table-direct-slot-definition) 3108 (call-next-method))) 3109 (defmethod clos:compute-effective-slot-definition-initargs ((class virtual-class) #+LISPWORKS name direct-slot-definitions) 3110 (if (typep (first direct-slot-definitions) 'virtual-table-direct-slot-definition) 3111 (append (call-next-method) 3112 (list ':base-class (slot-value (first direct-slot-definitions) 'base-class))) 3113 (call-next-method))) 3114 (defmethod clos:effective-slot-definition-class ((class virtual-class) &rest initargs) 3115 (if (getf initargs ':base-class) 3116 (find-class 'virtual-table-effective-slot-definition) 3117 (call-next-method))) 3118 3119 ;; Computes the effective method (as a function) for executing gf (which 3120 ;; must be a virtual generic function) for _direct_ instances of the given 3121 ;; class. 3122 (defun compute-virtual-generic-function-effective-method (gf class) 3123 ;; This relies on the known method specializer format, verified by 3124 ;; add-method below. 3125 (multiple-value-bind (methods certain) 3126 (clos:compute-applicable-methods-using-classes gf 3127 (cons class 3128 (make-list (1- (length (clos:generic-function-argument-precedence-order gf))) 3129 :initial-element (find-class 't)))) 3130 (unless certain 3131 (error "Problem determining the applicable methods of ~S on ~S" gf class)) 3132 (clos::compute-effective-method-as-function gf methods 3133 (cons (clos:class-prototype class) 3134 (make-list (1- (length (clos:generic-function-argument-precedence-order gf))) 3135 :initial-element nil))))) 3136 3137 ;; Initialize the virtual table slot. 3138 (defmethod initialize-classof-slot ((class virtual-class) (slot virtual-table-effective-slot-definition)) 3139 (setf (slot-value (clos:class-prototype class) (clos:slot-definition-name slot)) 3140 (let* ((base-class (slot-value slot 'base-class)) 3141 (current-length (length (vtbase-vt-functions base-class))) 3142 (vtable (make-array current-length :adjustable t :fill-pointer current-length))) 3143 (dotimes (i current-length) 3144 (setf (aref vtable i) 3145 (compute-virtual-generic-function-effective-method 3146 (aref (vtbase-vt-functions base-class) i) 3147 class))) 3148 vtable))) 3149 3150 ;; Auxiliary function: Return a list of all subclasses of class, including 3151 ;; class itself, in an arbitrary order. 3152 (defun collect-all-subclasses (class) 3153 (let ((result '()) (todo (list class))) 3154 (loop 3155 (unless todo (return)) 3156 (let ((last-todo todo)) 3157 (setq todo '()) 3158 (dolist (c last-todo) 3159 (unless (member c result) 3160 (setq todo (revappend (clos:class-direct-subclasses c) todo)) 3161 (push c result))))) 3162 (nreverse result))) 3163 3164 ;; A virtual generic function is tied to a base-class. 3165 (defclass virtual-generic-function (standard-generic-function) 3166 ((base-class 3167 :type class 3168 :accessor vtgf-base-class) 3169 (vt-index ; index in (vtbase-vt-functions base-class) 3170 :type fixnum 3171 :accessor vtgf-vt-index)) 3172 (:metaclass clos:funcallable-standard-class)) 3173 3174 ;; When a new virtual generic function is created, it needs to be registered 3175 ;; in its base class. 3176 (defmethod shared-initialize ((gf virtual-generic-function) situation &rest args 3177 &key (base-class nil base-class-p)) 3178 (call-next-method) 3179 (when base-class-p 3180 (when (consp base-class) 3181 (setq base-class (car base-class))) 3182 (unless (typep base-class 'class) 3183 (setq base-class (find-class base-class))) 3184 ; base-class is now a class. 3185 (setf (vtgf-base-class gf) base-class) 3186 (setf (vtgf-vt-index gf) 3187 (or (position gf (vtbase-vt-functions base-class)) 3188 ; Add gf to the functions in the base-class. 3189 (let ((index 3190 (vector-push-extend gf (vtbase-vt-functions base-class))) 3191 (vt-slot-name (vtbase-vt-slot-name base-class))) 3192 (dolist (cl (collect-all-subclasses base-class)) 3193 (let ((cl-proto (clos:class-prototype cl))) 3194 #| 3195 (unless (slot-boundp cl-proto vt-slot-name) 3196 (setf (slot-value cl-proto vt-slot-name) (make-array 10 :adjustable t :fill-pointer 0))) 3197 |# 3198 (assert (= (fill-pointer (slot-value cl-proto vt-slot-name)) 3199 index)) 3200 ;; Preliminary initialization. 3201 (vector-push-extend '#:not-yet-updated (slot-value cl-proto vt-slot-name)))) 3202 index)))) 3203 gf) 3204 3205 ;; Updates the computed effective methods for the given virtual generic 3206 ;; functions, in the vtables of all subclasses of class (including class 3207 ;; itself). class may be the gf's base-class or a subclass of it. 3208 (defun update-virtual-generic-function (gf &optional (class (vtgf-base-class gf))) 3209 (let ((vt-slot-name (vtbase-vt-slot-name (vtgf-base-class gf))) 3210 (vt-index (vtgf-vt-index gf))) 3211 (dolist (cl (collect-all-subclasses class)) 3212 (setf (aref (slot-value (clos:class-prototype cl) vt-slot-name) vt-index) 3213 (compute-virtual-generic-function-effective-method gf cl))))) 3214 3215 ;; Notification: When methods are added or removed to a generic function, 3216 ;; the computed effective methods in the vtables must be updated. (But the 3217 ;; dispatch function remains the same.) 3218 (defclass virtual-generic-function-updater () 3219 ()) 3220 (defparameter *virtual-generic-function-updater* 3221 (make-instance 'virtual-generic-function-updater)) 3222 (defmethod clos:update-dependent ((gf virtual-generic-function) (dependent virtual-generic-function-updater) &rest details) 3223 (declare (ignore details)) 3224 ;; TODO: Exploit the details, to minimize the updates. 3225 (update-virtual-generic-function gf)) 3226 3227 ;; When a new virtual generic function is created, it needs to be call 3228 ;; update-virtual-generic-function now, and later when the method set changes. 3229 (defmethod initialize-instance :after ((gf virtual-generic-function) &rest args) 3230 (update-virtual-generic-function gf) 3231 (clos:add-dependent gf *virtual-generic-function-updater*)) 3232 3233 ;; Verify that only methods dispatching on the first argument are added. 3234 (defmethod add-method ((gf virtual-generic-function) (method method)) 3235 (let ((<t> (find-class 't))) 3236 (unless (every #'(lambda (specializer) (eq specializer <t>)) 3237 (rest (clos:method-specializers method))) 3238 (error "invalid method for ~S: ~S. May only dispatch on the first argument." 3239 gf method))) 3240 (unless (typep (first (clos:method-specializers method)) 'class) 3241 (error "invalid method for ~S: ~S. The specializer on the first argument must be a class." 3242 gf method)) 3243 (call-next-method)) 3244 3245 ;; Computes the dispatch for a virtual generic function. 3246 ;; This is the heart of the example. 3247 (defmethod clos:compute-discriminating-function ((gf virtual-generic-function)) 3248 (let ((vt-slot-name (vtbase-vt-slot-name (vtgf-base-class gf))) 3249 (vt-index (vtgf-vt-index gf))) 3250 (assert (eq (aref (vtbase-vt-functions (vtgf-base-class gf)) vt-index) gf)) 3251 #'(lambda (first-arg &rest other-args) 3252 (apply (aref (slot-value first-arg vt-slot-name) vt-index) 3253 first-arg other-args)))) 3254 3255 ;; Now an example. 3256 ;; 3257 ;; f,g - A C - h 3258 ;; | / 3259 ;; B / 3260 ;; \ / 3261 ;; D 3262 ;; 3263 (defclass testclass30a () 3264 () 3265 (:metaclass virtual-base-class)) 3266 (defclass testclass30b (testclass30a) 3267 () 3268 (:metaclass virtual-class)) 3269 (defclass testclass30c () 3270 () 3271 (:metaclass virtual-base-class)) 3272 (defgeneric testgf30f (x) 3273 (:method ((x testclass30a)) 3274 "f on A") 3275 (:generic-function-class virtual-generic-function) 3276 (:base-class testclass30a)) 3277 (defgeneric testgf30g (x y) 3278 (:method ((x testclass30a) y) 3279 (list "g on A" y)) 3280 (:method ((x testclass30b) y) 3281 (list "g on B" y)) 3282 (:generic-function-class virtual-generic-function) 3283 (:base-class testclass30a)) 3284 (defgeneric testgf30h (x y) 3285 (:method ((x testclass30c) y) 3286 (list "h on C" y)) 3287 (:generic-function-class virtual-generic-function) 3288 (:base-class testclass30c)) 3289 (defclass testclass30d (testclass30b testclass30c) 3290 () 3291 (:metaclass virtual-class)) 3292 (defmethod testgf30g ((x testclass30d) y) 3293 (list "g on D" y)) 3294 (defmethod testgf30h ((x testclass30d) y) 3295 (list "h on D" y)) 3296 (let ((insta (make-instance 'testclass30a)) 3297 (instc (make-instance 'testclass30c)) 3298 (instd (make-instance 'testclass30d))) 3299 (list (testgf30f insta) 3300 (testgf30f instd) 3301 (testgf30g insta 10) 3302 (testgf30g instd 20) 3303 (testgf30h instc 30) 3304 (testgf30h instd 40) 3305 (symbols-cleanup 3306 '(virtual-class virtual-base-class 3307 virtual-table-direct-slot-definition 3308 virtual-table-effective-slot-definition 3309 compute-virtual-generic-function-effective-method 3310 collect-all-subclasses virtual-generic-function 3311 update-virtual-generic-function virtual-generic-function-updater 3312 *virtual-generic-function-updater* testclass30a testclass30b 3313 testclass30c testclass30d testgf30f testgf30g testgf30h))))) 3314#+(or CLISP CMU SBCL) 3315("f on A" "f on A" ("g on A" 10) ("g on D" 20) ("h on C" 30) ("h on D" 40) ()) 3316 3317 3318;;; user-defined :allocation :hash 3319;; https://sourceforge.net/p/clisp/bugs/286/ 3320(progn 3321 (defclass person () 3322 ((name :initarg :name :allocation :hash :accessor person-name) 3323 (address :initarg :address :allocation :hash :accessor person-address)) 3324 (:metaclass hash-classes:hash-class)) 3325 (let ((dilbert (make-instance 'person :name "Dilbert"))) 3326 (list (string= (person-name dilbert) "Dilbert") 3327 (slot-boundp dilbert 'name) 3328 (slot-boundp dilbert 'address) 3329 (slot-exists-p dilbert 'foo) 3330 (string= (gethash 'name (slot-value dilbert 3331 'hash-classes::hash-slots)) 3332 "Dilbert") 3333 (progn 3334 (remhash 'name (slot-value dilbert 'hash-classes::hash-slots)) 3335 (slot-boundp dilbert 'name)) 3336 (symbols-cleanup '(person person-name person-address))))) 3337(T T NIL NIL T NIL ()) 3338 3339;; https://sourceforge.net/p/clisp/bugs/288/ 3340;; but the allocation must be defined! 3341(progn 3342 (defclass class-bad-slot () ((bad-slot :allocation :bad-allocation))) 3343 (make-instance 'class-bad-slot)) 3344ERROR 3345 3346;; mop.xml#mop-sa-funcallable 3347(let (constructor) 3348 (defclass constructor () 3349 ((name :initarg :name :accessor constructor-name) 3350 (fields :initarg :fields :accessor constructor-fields)) 3351 (:metaclass funcallable-standard-class)) 3352 (defmethod initialize-instance :after ((c constructor) &key) 3353 (with-slots (name fields) c 3354 (set-funcallable-instance-function 3355 c 3356 #'(lambda () 3357 (let ((new (make-array (1+ (length fields))))) 3358 (setf (aref new 0) name) 3359 new))))) 3360 (setq constructor (make-instance 'constructor :name 'position :fields '(x y))) 3361 (list (stringp (with-output-to-string (*standard-output*) 3362 (describe constructor))) 3363 (funcall constructor) 3364 (symbols-cleanup '(constructor constructor-name constructor-fields)))) 3365(T #(POSITION NIL NIL) ()) 3366 3367;; Ability to specify a default method-combination on the generic-function 3368;; class. https://sourceforge.net/p/clisp/bugs/316/ 3369(progn 3370 (defclass testgf38class (standard-generic-function) 3371 () 3372 (:metaclass clos:funcallable-standard-class) 3373 (:default-initargs 3374 :method-combination 3375 (clos:find-method-combination (clos:class-prototype (find-class 'testgf38class)) 3376 '+ '()))) 3377 (defgeneric testgf38 (x) 3378 (:generic-function-class testgf38class)) 3379 (defmethod testgf38 + (x) 0) 3380 (symbols-cleanup '(testgf38class testgf38))) 3381() 3382 3383;; http://clisp.org/impnotes/mop-clisp.html#mop-clisp-warn 3384#+CLISP 3385(defmacro with-collecting-mop-warnings (&body body) 3386 `(let ((already-called ()) (replacing-method ())) 3387 (flet ((warning-gf (w) 3388 (generic-function-name 3389 (car (last (simple-condition-format-arguments w)))))) 3390 (without-package-lock ("CL" "CLOS") 3391 (defmethod initialize-instance :after 3392 ((o clos:gf-already-called-warning) &rest opts) 3393 (push (warning-gf o) already-called)) 3394 (defmethod initialize-instance :after 3395 ((o clos:gf-replacing-method-warning) &rest opts) 3396 (push (warning-gf o) replacing-method))) 3397 (list 3398 (progn ,@body) 3399 (list already-called replacing-method))))) 3400#+CLISP WITH-COLLECTING-MOP-WARNINGS 3401 3402#+CLISP 3403(with-collecting-mop-warnings ; system classes --- do NOT warn! 3404 (defclass gray-test (fundamental-character-output-stream) ()) 3405 (defmethod stream-write-char ((s gray-test) ch) nil) 3406 (stream-write-char (make-instance 'gray-test) #\A) 3407 (symbol-cleanup 'gray-test)) 3408#+CLISP (T (() ())) 3409 3410#+CLISP 3411(let ((book-counter 0) (sale-stats (make-hash-table :test 'equal))) 3412 (with-collecting-mop-warnings ; user classes --- DO warn! 3413 (defclass ware () ((title :initarg :title :accessor title))) 3414 (defclass book (ware) ()) 3415 (defclass compact-disk (ware) ()) 3416 (defclass dvd (ware) ()) 3417 (defgeneric add-to-inventory (object)) 3418 (defmethod add-to-inventory ((object ware)) nil) 3419 (add-to-inventory (make-instance 'book :title "CLtL1")) 3420 (defmethod add-to-inventory ((object book)) (incf book-counter)) 3421 (add-to-inventory (make-instance 'book :title "CLtL2")) 3422 (defmethod add-to-inventory ((object book)) 3423 (setf (gethash (title object) sale-stats) (cons 0 0))) 3424 (add-to-inventory (make-instance 'book :title "AMOP")) 3425 (list book-counter (hash-table-count sale-stats) 3426 (symbols-cleanup '(ware book compact-disk dvd title add-to-inventory))))) 3427#+CLISP ((1 1 ()) ((add-to-inventory add-to-inventory) (add-to-inventory))) 3428 3429#+CLISP 3430(let ((book-counter 0) (sale-stats (make-hash-table :test 'equal))) 3431 (with-collecting-mop-warnings 3432 (defclass ware () ((title :initarg :title :accessor title))) 3433 (defclass book (ware) ()) 3434 (defclass compact-disk (ware) ()) 3435 (defclass dvd (ware) ()) 3436 (defgeneric add-to-inventory (object) 3437 (declare (dynamically-modifiable))) ; do NOT warn! 3438 (defmethod add-to-inventory ((object ware)) nil) 3439 (add-to-inventory (make-instance 'book :title "CLtL1")) 3440 (defmethod add-to-inventory ((object book)) (incf book-counter)) 3441 (add-to-inventory (make-instance 'book :title "CLtL2")) 3442 (defmethod add-to-inventory ((object book)) 3443 (setf (gethash (title object) sale-stats) (cons 0 0))) 3444 (add-to-inventory (make-instance 'book :title "AMOP")) 3445 (list book-counter (hash-table-count sale-stats) 3446 (symbols-cleanup '(ware book compact-disk dvd title add-to-inventory))))) 3447#+CLISP ((1 1 ()) (() (add-to-inventory))) 3448 3449#+CLISP 3450(let (bad) 3451 (do-all-symbols (s) 3452 (when (and (fboundp s) 3453 (typep (fdefinition s) 'generic-function) 3454 (not (member (clos::gf-dynamically-modifiable (fdefinition s)) 3455 '(t nil)))) 3456 (push s bad))) 3457 bad) 3458#+CLISP () 3459 3460;; cleanup 3461(symbols-cleanup 3462 '(as-string foo133 foo133a foo133b foo134 *forwardclass* foo134a foo134b 3463 my-gf-class dependent-methods *timestamp* prioritized-dependent 3464 prioritized-dispatcher uncallable-generic-function 3465 *sampclass* sampclass01 sampclass02 sampclass03 sampclass04 sampclass05 3466 sampclass06 sampclass07 sampclass08 sampclass09 sampclass10 sampclass11 3467 sampclass12 sampclass13 sampclass14 sampclass15 sampclass16 sampclass17 3468 sampclass18 sampclass19 sampclass20 3469 *sampgf* sampgf01 sampgf02 sampgf03 sampgf04 sampgf05 sampgf06 sampgf07 3470 sampgf08 sampgf09 sampgf10 sampgf11 sampgf12 sampgf13 sampgf14 sampgf15 3471 sampgf16 sampgf17 sampgf18 3472 *sampmethod* sampgf19 sampgf20 sampgf21 sampgf22 sampgf23 sampgf24 sampgf25 3473 sampgf26 sampclass21 sampclass21x sampclass22 sampclass22x 3474 *sampslot* sampclass23 sampclass24 sampclass25 sampclass26 sampclass27 3475 sampclass28 sampclass29 sampclass30 sampclass31 sampclass32 sampclass33 3476 sampclass34 sampclass35 sampclass36 3477 struct04 struct04ro struct04v struct04rov struct05 struct05v 3478 sampclass37 sampclass38 sampclass39 3479 class-supporting-classof-slots classof-direct-slot-definition-mixin 3480 add-classof-direct-mixin classof-effective-slot-definition-mixin 3481 add-classof-effective-mixin initialize-classof-slot testclass29a testclass29b 3482 class-bad-slot #+clisp with-collecting-mop-warnings)) 3483() 3484