test-suite/tests/goops.test

   1 ;;;; goops.test --- test suite for GOOPS                      -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014, 2015 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-suite test-goops)
  20   #:use-module (test-suite lib)
  21   #:autoload   (srfi srfi-1)    (unfold))
  22
  23 (define exception:no-applicable-method
  24   '(goops-error . "^No applicable method"))
  25
  26 (pass-if "GOOPS loads"
  27          (false-if-exception
  28           (begin (resolve-module '(oop goops))
  29                  #t)))
  30
  31 (use-modules (oop goops))
  32
  33 ;;; more tests here...
  34
  35 (with-test-prefix "basic classes"
  36
  37   (with-test-prefix "<top>"
  38
  39     (pass-if "instance?"
  40       (instance? <top>))
  41
  42     (pass-if "class-of"
  43       (eq? (class-of <top>) <class>))
  44
  45     (pass-if "is a class?"
  46       (is-a? <top> <class>))
  47
  48     (pass-if "class-name"
  49       (eq? (class-name <top>) '<top>))
  50
  51     (pass-if "direct superclasses"
  52       (equal? (class-direct-supers <top>) '()))
  53
  54     (pass-if "superclasses"
  55       (equal? (class-precedence-list <top>) (list <top>)))
  56
  57     (pass-if "direct slots"
  58       (equal? (class-direct-slots <top>) '()))
  59
  60     (pass-if "slots"
  61       (equal? (class-slots <top>) '())))
  62
  63   (with-test-prefix "<object>"
  64
  65     (pass-if "instance?"
  66       (instance? <object>))
  67
  68     (pass-if "class-of"
  69       (eq? (class-of <object>) <class>))
  70
  71     (pass-if "is a class?"
  72       (is-a? <object> <class>))
  73
  74     (pass-if "class-name"
  75       (eq? (class-name <object>) '<object>))
  76
  77     (pass-if "direct superclasses"
  78       (equal? (class-direct-supers <object>) (list <top>)))
  79
  80     (pass-if "superclasses"
  81       (equal? (class-precedence-list <object>) (list <object> <top>)))
  82
  83     (pass-if "direct slots"
  84       (equal? (class-direct-slots <object>) '()))
  85
  86     (pass-if "slots"
  87       (equal? (class-slots <object>) '())))
  88
  89   (with-test-prefix "<class>"
  90
  91     (pass-if "instance?"
  92       (instance? <class>))
  93
  94     (pass-if "class-of"
  95       (eq? (class-of <class>) <class>))
  96
  97     (pass-if "is a class?"
  98       (is-a? <class> <class>))
  99
 100     (pass-if "class-name"
 101       (eq? (class-name <class>) '<class>))
 102
 103     (pass-if "direct superclass"
 104       (equal? (class-direct-supers <class>) (list <object>))))
 105
 106   (with-test-prefix "class-precedence-list"
 107     (for-each (lambda (class)
 108                 (run-test (if (slot-bound? class 'name)
 109                               (class-name class)
 110                               (with-output-to-string
 111                                 (lambda ()
 112                                   (display class))))
 113                           #t
 114                           (lambda ()
 115                             (catch #t
 116                                    (lambda ()
 117                                      (equal? (class-precedence-list class)
 118                                              (compute-cpl class)))
 119                                    (lambda args #t)))))
 120               (let ((table (make-hash-table)))
 121                 (let rec ((class <top>))
 122                   (hash-create-handle! table class #f)
 123                   (for-each rec (class-direct-subclasses class)))
 124                 (hash-fold (lambda (class ignore classes)
 125                              (cons class classes))
 126                            '()
 127                            table))))
 128   )
 129
 130 (with-test-prefix "classes for built-in types"
 131
 132   (pass-if "subr"
 133     (eq? (class-of fluid-ref) <procedure>))
 134
 135   (pass-if "gsubr"
 136     (eq? (class-of hashq-ref) <procedure>))
 137
 138   (pass-if "car"
 139     (eq? (class-of car) <procedure>))
 140
 141   (pass-if "string"
 142     (eq? (class-of "foo") <string>))
 143
 144   (pass-if "port"
 145     (is-a? (%make-void-port "w") <port>))
 146
 147   (pass-if "struct vtable"
 148     ;; Previously, `class-of' would fail for nameless structs, i.e., structs
 149     ;; for which `struct-vtable-name' is #f.
 150     (is-a? (class-of (make-vtable
 151                       (string-append standard-vtable-fields "prprpr")))
 152            <class>)))
 153
 154
 155 (with-test-prefix "defining classes"
 156
 157   (with-test-prefix "define-class"
 158
 159     (pass-if "creating a new binding"
 160       (if (eval '(defined? '<foo-0>) (current-module))
 161           (throw 'unresolved))
 162       (eval '(define-class <foo-0> ()) (current-module))
 163       (eval '(is-a? <foo-0> <class>) (current-module)))
 164
 165     (pass-if "overwriting a binding to a non-class"
 166       (eval '(define <foo> #f) (current-module))
 167       (eval '(define-class <foo> ()) (current-module))
 168       (eval '(is-a? <foo> <class>) (current-module)))
 169
 170     (pass-if "bad init-thunk"
 171       (catch #t
 172         (lambda ()
 173           (eval '(define-class <foo> ()
 174                    (x #:init-thunk (lambda (x) 1)))
 175                 (current-module))
 176           #f)
 177         (lambda args
 178           #t)))
 179
 180     (pass-if "interaction with `struct-ref'"
 181        (eval '(define-class <class-struct> ()
 182                 (foo #:init-keyword #:foo)
 183                 (bar #:init-keyword #:bar))
 184              (current-module))
 185        (eval '(let ((x (make <class-struct>
 186                          #:foo 'hello
 187                          #:bar 'world)))
 188                 (and (struct? x)
 189                      (eq? (struct-ref x 0) 'hello)
 190                      (eq? (struct-ref x 1) 'world)))
 191              (current-module)))
 192
 193      (pass-if "interaction with `struct-set!'"
 194        (eval '(define-class <class-struct-2> ()
 195                 (foo) (bar))
 196              (current-module))
 197        (eval '(let ((x (make <class-struct-2>)))
 198                 (struct-set! x 0 'hello)
 199                 (struct-set! x 1 'world)
 200                 (and (struct? x)
 201                      (eq? (struct-ref x 0) 'hello)
 202                      (eq? (struct-ref x 1) 'world)))
 203              (current-module)))
 204
 205      (pass-if "with accessors"
 206               (eval '(define-class <qux> ()
 207                        (x #:accessor x #:init-value 123)
 208                        (z #:accessor z #:init-value 789))
 209                     (current-module))
 210               (eval '(equal? (x (make <qux>)) 123) (current-module)))
 211
 212      (pass-if-exception "cannot redefine fields of <class>"
 213        '(misc-error . "cannot be redefined")
 214        (eval '(begin
 215                 (define-class <test-class> (<class>)
 216                   name)
 217                 (make <test-class>))
 218              (current-module)))))
 219
 220 (with-test-prefix "defining generics"
 221
 222   (with-test-prefix "define-generic"
 223
 224     (pass-if "creating a new top-level binding"
 225       (if (eval '(defined? 'foo-0) (current-module))
 226           (throw 'unresolved))
 227       (eval '(define-generic foo-0) (current-module))
 228       (eval '(and (is-a? foo-0 <generic>)
 229                   (null? (generic-function-methods foo-0)))
 230             (current-module)))
 231
 232     (pass-if "overwriting a top-level binding to a non-generic"
 233       (eval '(define (foo) #f) (current-module))
 234       (eval '(define-generic foo) (current-module))
 235       (eval '(and (is-a? foo <generic>)
 236                   (= 1 (length (generic-function-methods foo))))
 237             (current-module)))
 238
 239     (pass-if "overwriting a top-level binding to a generic"
 240       (eval '(define (foo) #f) (current-module))
 241       (eval '(define-generic foo) (current-module))
 242       (eval '(define-generic foo) (current-module))
 243       (eval '(and (is-a? foo <generic>)
 244                   (null? (generic-function-methods foo)))
 245             (current-module)))
 246
 247     (pass-if-exception "getters do not have setters"
 248                        exception:wrong-type-arg
 249                        (eval '(setter foo) (current-module)))))
 250
 251 (with-test-prefix "defining methods"
 252
 253   (pass-if "define-method"
 254     (let ((m (current-module)))
 255       (eval '(define-method (my-plus (s1 <string>) (s2 <string>))
 256                (string-append s1 s2))
 257             m)
 258       (eval '(define-method (my-plus (i1 <integer>) (i2 <integer>))
 259                (+ i1 i2))
 260             m)
 261       (eval '(and (is-a? my-plus <generic>)
 262                   (= (length (generic-function-methods my-plus))
 263                      2))
 264             m)))
 265
 266   (pass-if "method-more-specific?"
 267     (eval '(let* ((m+        (generic-function-methods my-plus))
 268                   (m1        (car m+))
 269                   (m2        (cadr m+))
 270                   (arg-types (list <string> <string>)))
 271              (if (memq <string> (method-specializers m1))
 272                  (method-more-specific? m1 m2 arg-types)
 273                  (method-more-specific? m2 m1 arg-types)))
 274           (current-module)))
 275
 276   (pass-if-exception "method-more-specific? (failure)"
 277                      exception:wrong-type-arg
 278     (eval '(let* ((m+ (generic-function-methods my-plus))
 279                   (m1 (car m+))
 280                   (m2 (cadr m+)))
 281              (method-more-specific? m1 m2 '()))
 282           (current-module))))
 283
 284 (with-test-prefix "the method cache"
 285   (pass-if "defining a method with a rest arg"
 286     (let ((m (current-module)))
 287       (eval '(define-method (foo bar . baz)
 288                (cons bar baz))
 289             m)
 290       (eval '(foo 1)
 291             m)
 292       (eval '(foo 1 2)
 293             m)
 294       (eval '(equal? (foo 1 2) '(1 2))
 295             m))))
 296
 297 (with-test-prefix "defining accessors"
 298
 299   (with-test-prefix "define-accessor"
 300
 301     (pass-if "creating a new top-level binding"
 302       (if (eval '(defined? 'foo-1) (current-module))
 303           (throw 'unresolved))
 304       (eval '(define-accessor foo-1) (current-module))
 305       (eval '(and (is-a? foo-1 <generic-with-setter>)
 306                   (null? (generic-function-methods foo-1)))
 307             (current-module)))
 308
 309     (pass-if "accessors have setters"
 310       (procedure? (eval '(setter foo-1) (current-module))))
 311
 312     (pass-if "overwriting a top-level binding to a non-accessor"
 313       (eval '(define (foo) #f) (current-module))
 314       (eval '(define-accessor foo) (current-module))
 315       (eval '(and (is-a? foo <generic-with-setter>)
 316                   (= 1 (length (generic-function-methods foo))))
 317             (current-module)))
 318
 319     (pass-if "overwriting a top-level binding to an accessor"
 320       (eval '(define (foo) #f) (current-module))
 321       (eval '(define-accessor foo) (current-module))
 322       (eval '(define-accessor foo) (current-module))
 323       (eval '(and (is-a? foo <generic-with-setter>)
 324                   (null? (generic-function-methods foo)))
 325             (current-module)))))
 326
 327 (with-test-prefix "object update"
 328   (pass-if "defining class"
 329     (eval '(define-class <foo> ()
 330              (x #:accessor x #:init-value 123)
 331              (z #:accessor z #:init-value 789))
 332           (current-module))
 333     (eval '(is-a? <foo> <class>) (current-module)))
 334   (pass-if "making instance"
 335     (eval '(define foo (make <foo>)) (current-module))
 336     (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module)))
 337   (pass-if "redefining class"
 338     (eval '(define-class <foo> ()
 339              (x #:accessor x #:init-value 123)
 340              (y #:accessor y #:init-value 456)
 341              (z #:accessor z #:init-value 789))
 342           (current-module))
 343     (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))
 344
 345   (pass-if "changing class"
 346     (let* ((c1 (class () (the-slot #:init-keyword #:value)))
 347            (c2 (class () (the-slot #:init-keyword #:value)
 348                          (the-other-slot #:init-value 888)))
 349            (o1 (make c1 #:value 777)))
 350       (and (is-a? o1 c1)
 351            (not (is-a? o1 c2))
 352            (equal? (slot-ref o1 'the-slot) 777)
 353            (let ((o2 (change-class o1 c2)))
 354              (and (eq? o1 o2)
 355                   (is-a? o2 c2)
 356                   (not (is-a? o2 c1))
 357                   (equal? (slot-ref o2 'the-slot) 777))))))
 358
 359   (pass-if "`hell' in `goops.c' grows as expected"
 360     ;; This snippet yielded a segfault prior to the 2008-08-19 `goops.c'
 361     ;; fix (i.e., Guile 1.8.5 and earlier).  The root of the problem was
 362     ;; that `go_to_hell ()' would not reallocate enough room for the `hell'
 363     ;; array, leading to out-of-bounds accesses.
 364
 365     (let* ((parent-class (class ()
 366                            #:name '<class-that-will-be-redefined>))
 367            (classes
 368             (unfold (lambda (i) (>= i 20))
 369                     (lambda (i)
 370                       (make-class (list parent-class)
 371                                   '((the-slot #:init-value #:value)
 372                                     (the-other-slot))
 373                                   #:name (string->symbol
 374                                           (string-append "<foo-to-redefine-"
 375                                                          (number->string i)
 376                                                          ">"))))
 377                     (lambda (i)
 378                       (+ 1 i))
 379                     0))
 380            (objects
 381             (map (lambda (class)
 382                    (make class #:value 777))
 383                  classes)))
 384
 385       (define-method (change-class (foo parent-class)
 386                                    (new <class>))
 387         ;; Called by `scm_change_object_class ()', via `purgatory ()'.
 388         (if (null? classes)
 389             (next-method)
 390             (let ((class  (car classes))
 391                   (object (car objects)))
 392               (set! classes (cdr classes))
 393               (set! objects (cdr objects))
 394
 395               ;; Redefine the class so that its instances are eventually
 396               ;; passed to `scm_change_object_class ()'.  This leads to
 397               ;; nested `scm_change_object_class ()' calls, which increases
 398               ;; the size of HELL and increments N_HELL.
 399               (class-redefinition class
 400                                   (make-class '() (class-slots class)
 401                                               #:name (class-name class)))
 402
 403               ;; Use `slot-ref' to trigger the `scm_change_object_class ()'
 404               ;; and `go_to_hell ()' calls.
 405               (slot-ref object 'the-slot)
 406
 407               (next-method))))
 408
 409
 410       ;; Initiate the whole `change-class' chain.
 411       (let* ((class  (car classes))
 412              (object (change-class (car objects) class)))
 413         (is-a? object class)))))
 414
 415 (with-test-prefix "object comparison"
 416   (pass-if "default method"
 417            (eval '(begin
 418                     (define-class <c> ()
 419                       (x #:accessor x #:init-keyword #:x)
 420                       (y #:accessor y #:init-keyword #:y))
 421                     (define o1 (make <c> #:x '(1) #:y '(2)))
 422                     (define o2 (make <c> #:x '(1) #:y '(3)))
 423                     (define o3 (make <c> #:x '(4) #:y '(3)))
 424                     (define o4 (make <c> #:x '(4) #:y '(3)))
 425                     (not (eqv? o1 o2)))
 426                  (current-module)))
 427   (pass-if "equal?"
 428            (eval '(begin
 429                     (define-method (equal? (a <c>) (b <c>))
 430                       (equal? (y a) (y b)))
 431                     (equal? o2 o3))
 432                  (current-module)))
 433   (pass-if "not equal?"
 434            (eval '(not (equal? o1 o2))
 435                  (current-module)))
 436   (pass-if "="
 437            (eval '(begin
 438                     (define-method (= (a <c>) (b <c>))
 439                       (and (equal? (x a) (x b))
 440                            (equal? (y a) (y b))))
 441                     (= o3 o4))
 442                  (current-module)))
 443   (pass-if "not ="
 444            (eval '(not (= o1 o2))
 445                  (current-module)))
 446   )
 447
 448 (use-modules (oop goops active-slot))
 449
 450 (with-test-prefix "active-slot"
 451   (pass-if "defining class with active slot"
 452     (eval '(begin
 453              (define z '())
 454              (define-class <bar> ()
 455                (x #:accessor x
 456                   #:init-value 1
 457                   #:allocation #:active
 458                   #:before-slot-ref
 459                   (lambda (o)
 460                     (set! z (cons 'before-ref z))
 461                     #t)
 462                   #:after-slot-ref
 463                   (lambda (o)
 464                     (set! z (cons 'after-ref z)))
 465                   #:before-slot-set!
 466                   (lambda (o v)
 467                     (set! z (cons* v 'before-set! z)))
 468                   #:after-slot-set!
 469                   (lambda (o v)
 470                     (set! z (cons* v (x o) 'after-set! z))))
 471                #:metaclass <active-class>)
 472              (define bar (make <bar>))
 473              (x bar)
 474              (set! (x bar) 2)
 475              (equal? (reverse z)
 476                      '(before-set! 1 before-ref after-ref
 477                        after-set! 1 1 before-ref after-ref
 478                        before-set! 2 before-ref after-ref after-set! 2 2)))
 479           (current-module))))
 480
 481 (use-modules (oop goops composite-slot))
 482
 483 (with-test-prefix "composite-slot"
 484   (pass-if "creating instance with propagated slot"
 485     (eval '(begin
 486              (define-class <a> ()
 487                (x #:accessor x #:init-keyword #:x)
 488                (y #:accessor y #:init-keyword #:y))
 489              (define-class <c> ()
 490                (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2))
 491                (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4))
 492                (x #:accessor x
 493                   #:allocation #:propagated
 494                   #:propagate-to '(o1 (o2 y)))
 495                #:metaclass <composite-class>)
 496              (define o (make <c>))
 497              (is-a? o <c>))
 498           (current-module)))
 499   (pass-if "reading propagated slot"
 500            (eval '(= (x o) 1) (current-module)))
 501   (pass-if "writing propagated slot"
 502            (eval '(begin
 503                     (set! (x o) 5)
 504                     (and (= (x (o1 o)) 5)
 505                          (= (y (o1 o)) 2)
 506                          (= (x (o2 o)) 3)
 507                          (= (y (o2 o)) 5)))
 508                  (current-module))))
 509
 510 (with-test-prefix "no-applicable-method"
 511   (pass-if-exception "calling generic, no methods"
 512                      exception:no-applicable-method
 513     (eval '(begin
 514              (define-class <qux> ())
 515              (define-generic quxy)
 516              (quxy 1))
 517           (current-module)))
 518   (pass-if "calling generic, one method, applicable"
 519     (eval '(begin
 520              (define-method (quxy (q <qux>))
 521                #t)
 522              (define q (make <qux>))
 523              (quxy q))
 524           (current-module)))
 525   (pass-if-exception "calling generic, one method, not applicable"
 526                      exception:no-applicable-method
 527     (eval '(quxy 1)
 528           (current-module))))
 529
 530 (with-test-prefix "foreign slots"
 531   (define-class <foreign-test> ()
 532     (a #:init-keyword #:a #:class <foreign-slot>
 533        #:accessor test-a)
 534     (b #:init-keyword #:b #:init-form 3 #:class <foreign-slot>
 535        #:accessor test-b))
 536
 537   (pass-if-equal "constructing, no initargs"
 538       '(0 3)
 539     (let ((x (make <foreign-test>)))
 540       (list (slot-ref x 'a)
 541             (slot-ref x 'b))))
 542
 543   (pass-if-equal "constructing, initargs"
 544       '(1 2)
 545     (let ((x (make <foreign-test> #:a 1 #:b 2)))
 546       (list (slot-ref x 'a)
 547             (slot-ref x 'b))))
 548
 549   (pass-if-equal "getters"
 550       '(0 3)
 551     (let ((x (make <foreign-test>)))
 552       (list (test-a x) (test-b x))))
 553
 554   (pass-if-equal "setters"
 555       '(10 20)
 556     (let ((x (make <foreign-test>)))
 557       (set! (test-a x) 10)
 558       (set! (test-b x) 20)
 559       (list (test-a x) (test-b x))))
 560
 561   (pass-if-exception "out of range"
 562       exception:out-of-range
 563     (make <foreign-test> #:a (ash 1 64))))
 564
 565 (with-test-prefix "#:each-subclass"
 566   (let* ((<subclass-allocation-test>
 567           (class ()
 568             (test #:init-value '() #:allocation #:each-subclass)
 569             #:name '<subclass-allocation-test>))
 570          (a (make <subclass-allocation-test>)))
 571     (pass-if-equal '() (slot-ref a 'test))
 572     (let ((b (make <subclass-allocation-test>)))
 573       (pass-if-equal '() (slot-ref b 'test))
 574       (slot-set! a 'test 100)
 575       (pass-if-equal 100 (slot-ref a 'test))
 576       (pass-if-equal 100 (slot-ref b 'test))
 577
 578       ;; #:init-value of the class shouldn't reinitialize slot when
 579       ;; instances are allocated.
 580       (make <subclass-allocation-test>)
 581
 582       (pass-if-equal 100 (slot-ref a 'test))
 583       (pass-if-equal 100 (slot-ref b 'test))
 584
 585       (let ((<test-subclass>
 586              (class (<subclass-allocation-test>))))
 587         (pass-if-equal 100 (slot-ref a 'test))
 588         (pass-if-equal 100 (slot-ref b 'test))
 589         (let ((c (make <test-subclass>)))
 590           (pass-if-equal 100 (slot-ref a 'test))
 591           (pass-if-equal 100 (slot-ref b 'test))
 592           (pass-if-equal '() (slot-ref c 'test))
 593           (slot-set! c 'test 200)
 594           (pass-if-equal 200 (slot-ref c 'test))
 595
 596           (make <test-subclass>)
 597
 598           (pass-if-equal 100 (slot-ref a 'test))
 599           (pass-if-equal 100 (slot-ref b 'test))
 600           (pass-if-equal 200 (slot-ref c 'test)))))))
 601
 602 (define-class <food> ())
 603 (define-class <fruit> (<food>))
 604 (define-class <spice> (<food>))
 605 (define-class <apple> (<fruit>))
 606 (define-class <cinnamon> (<spice>))
 607 (define-class <pie> (<apple> <cinnamon>))
 608
 609 (define-class <d> ())
 610 (define-class <e> ())
 611 (define-class <f> ())
 612 (define-class <b> (<d> <e>))
 613 (define-class <c> (<e> <f>))
 614 (define-class <a> (<b> <c>))
 615
 616 (with-test-prefix "compute-cpl"
 617   (pass-if-equal "<pie>"
 618       (list <pie> <apple> <fruit> <cinnamon> <spice> <food> <object> <top>)
 619     (compute-cpl <pie>))
 620
 621   (pass-if-equal "<a>"
 622       (list <a> <b> <d> <c> <e> <f> <object> <top>)
 623     (compute-cpl <a>)))
 624
 625 (with-test-prefix "accessor slots"
 626   (let* ((a-accessor (make-accessor 'a))
 627          (b-accessor (make-accessor 'b))
 628          (<a> (class ()
 629                 (a #:init-keyword #:a #:accessor a-accessor)
 630                 #:name '<a>))
 631          (<b> (class ()
 632                 (b #:init-keyword #:b #:accessor b-accessor)
 633                 #:name '<b>))
 634          (<ab> (class (<a> <b>) #:name '<ab>))
 635          (<ba> (class (<b> <a>) #:name '<ba>))
 636          (<cab> (class (<ab>)
 637                   (a #:init-keyword #:a)
 638                   #:name '<cab>))
 639          (<cba> (class (<ba>)
 640                   (a #:init-keyword #:a)
 641                   #:name '<cba>))
 642          (a (make <a> #:a 'a))
 643          (b (make <b> #:b 'b))
 644          (ab (make <ab> #:a 'a #:b 'b))
 645          (ba (make <ba> #:a 'a #:b 'b))
 646          (cab (make <cab> #:a 'a #:b 'b))
 647          (cba (make <cba> #:a 'a #:b 'b)))
 648     (pass-if-equal "a accessor on a" 'a (a-accessor a))
 649     (pass-if-equal "a accessor on ab" 'a (a-accessor ab))
 650     (pass-if-equal "a accessor on ba" 'a (a-accessor ba))
 651     (pass-if-exception "a accessor on cab" exception:no-applicable-method
 652       (a-accessor cab))
 653     (pass-if-exception "a accessor on cba" exception:no-applicable-method
 654       (a-accessor cba))
 655     (pass-if-equal "b accessor on a" 'b (b-accessor b))
 656     (pass-if-equal "b accessor on ab" 'b (b-accessor ab))
 657     (pass-if-equal "b accessor on ba" 'b (b-accessor ba))
 658     (pass-if-equal "b accessor on cab" 'b (b-accessor cab))
 659     (pass-if-equal "b accessor on cba" 'b (b-accessor cba))))