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     (expect-fail "bad init-thunk"
 171                  (begin
 172                    (catch #t
 173                      (lambda ()
 174                        (eval '(define-class <foo> ()
 175                                 (x #:init-thunk (lambda (x) 1)))
 176                              (current-module))
 177                        #t)
 178                      (lambda args
 179                        #f))))
 180
 181     (pass-if "interaction with `struct-ref'"
 182        (eval '(define-class <class-struct> ()
 183                 (foo #:init-keyword #:foo)
 184                 (bar #:init-keyword #:bar))
 185              (current-module))
 186        (eval '(let ((x (make <class-struct>
 187                          #:foo 'hello
 188                          #:bar 'world)))
 189                 (and (struct? x)
 190                      (eq? (struct-ref x 0) 'hello)
 191                      (eq? (struct-ref x 1) 'world)))
 192              (current-module)))
 193
 194      (pass-if "interaction with `struct-set!'"
 195        (eval '(define-class <class-struct-2> ()
 196                 (foo) (bar))
 197              (current-module))
 198        (eval '(let ((x (make <class-struct-2>)))
 199                 (struct-set! x 0 'hello)
 200                 (struct-set! x 1 'world)
 201                 (and (struct? x)
 202                      (eq? (struct-ref x 0) 'hello)
 203                      (eq? (struct-ref x 1) 'world)))
 204              (current-module)))
 205
 206      (pass-if "with accessors"
 207               (eval '(define-class <qux> ()
 208                        (x #:accessor x #:init-value 123)
 209                        (z #:accessor z #:init-value 789))
 210                     (current-module))
 211               (eval '(equal? (x (make <qux>)) 123) (current-module)))
 212
 213      (pass-if-exception "cannot redefine fields of <class>"
 214        '(misc-error . "cannot be redefined")
 215        (eval '(begin
 216                 (define-class <test-class> (<class>)
 217                   name)
 218                 (make <test-class>))
 219              (current-module)))))
 220
 221 (with-test-prefix "defining generics"
 222
 223   (with-test-prefix "define-generic"
 224
 225     (pass-if "creating a new top-level binding"
 226       (if (eval '(defined? 'foo-0) (current-module))
 227           (throw 'unresolved))
 228       (eval '(define-generic foo-0) (current-module))
 229       (eval '(and (is-a? foo-0 <generic>)
 230                   (null? (generic-function-methods foo-0)))
 231             (current-module)))
 232
 233     (pass-if "overwriting a top-level binding to a non-generic"
 234       (eval '(define (foo) #f) (current-module))
 235       (eval '(define-generic foo) (current-module))
 236       (eval '(and (is-a? foo <generic>)
 237                   (= 1 (length (generic-function-methods foo))))
 238             (current-module)))
 239
 240     (pass-if "overwriting a top-level binding to a generic"
 241       (eval '(define (foo) #f) (current-module))
 242       (eval '(define-generic foo) (current-module))
 243       (eval '(define-generic foo) (current-module))
 244       (eval '(and (is-a? foo <generic>)
 245                   (null? (generic-function-methods foo)))
 246             (current-module)))
 247
 248     (pass-if-exception "getters do not have setters"
 249                        exception:wrong-type-arg
 250                        (eval '(setter foo) (current-module)))))
 251
 252 (with-test-prefix "defining methods"
 253
 254   (pass-if "define-method"
 255     (let ((m (current-module)))
 256       (eval '(define-method (my-plus (s1 <string>) (s2 <string>))
 257                (string-append s1 s2))
 258             m)
 259       (eval '(define-method (my-plus (i1 <integer>) (i2 <integer>))
 260                (+ i1 i2))
 261             m)
 262       (eval '(and (is-a? my-plus <generic>)
 263                   (= (length (generic-function-methods my-plus))
 264                      2))
 265             m)))
 266
 267   (pass-if "method-more-specific?"
 268     (eval '(let* ((m+        (generic-function-methods my-plus))
 269                   (m1        (car m+))
 270                   (m2        (cadr m+))
 271                   (arg-types (list <string> <string>)))
 272              (if (memq <string> (method-specializers m1))
 273                  (method-more-specific? m1 m2 arg-types)
 274                  (method-more-specific? m2 m1 arg-types)))
 275           (current-module)))
 276
 277   (pass-if-exception "method-more-specific? (failure)"
 278                      exception:wrong-type-arg
 279     (eval '(let* ((m+ (generic-function-methods my-plus))
 280                   (m1 (car m+))
 281                   (m2 (cadr m+)))
 282              (method-more-specific? m1 m2 '()))
 283           (current-module))))
 284
 285 (with-test-prefix "the method cache"
 286   (pass-if "defining a method with a rest arg"
 287     (let ((m (current-module)))
 288       (eval '(define-method (foo bar . baz)
 289                (cons bar baz))
 290             m)
 291       (eval '(foo 1)
 292             m)
 293       (eval '(foo 1 2)
 294             m)
 295       (eval '(equal? (foo 1 2) '(1 2))
 296             m))))
 297
 298 (with-test-prefix "defining accessors"
 299
 300   (with-test-prefix "define-accessor"
 301
 302     (pass-if "creating a new top-level binding"
 303       (if (eval '(defined? 'foo-1) (current-module))
 304           (throw 'unresolved))
 305       (eval '(define-accessor foo-1) (current-module))
 306       (eval '(and (is-a? foo-1 <generic-with-setter>)
 307                   (null? (generic-function-methods foo-1)))
 308             (current-module)))
 309
 310     (pass-if "accessors have setters"
 311       (procedure? (eval '(setter foo-1) (current-module))))
 312
 313     (pass-if "overwriting a top-level binding to a non-accessor"
 314       (eval '(define (foo) #f) (current-module))
 315       (eval '(define-accessor foo) (current-module))
 316       (eval '(and (is-a? foo <generic-with-setter>)
 317                   (= 1 (length (generic-function-methods foo))))
 318             (current-module)))
 319
 320     (pass-if "overwriting a top-level binding to an accessor"
 321       (eval '(define (foo) #f) (current-module))
 322       (eval '(define-accessor foo) (current-module))
 323       (eval '(define-accessor foo) (current-module))
 324       (eval '(and (is-a? foo <generic-with-setter>)
 325                   (null? (generic-function-methods foo)))
 326             (current-module)))))
 327
 328 (with-test-prefix "object update"
 329   (pass-if "defining class"
 330     (eval '(define-class <foo> ()
 331              (x #:accessor x #:init-value 123)
 332              (z #:accessor z #:init-value 789))
 333           (current-module))
 334     (eval '(is-a? <foo> <class>) (current-module)))
 335   (pass-if "making instance"
 336     (eval '(define foo (make <foo>)) (current-module))
 337     (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module)))
 338   (pass-if "redefining class"
 339     (eval '(define-class <foo> ()
 340              (x #:accessor x #:init-value 123)
 341              (y #:accessor y #:init-value 456)
 342              (z #:accessor z #:init-value 789))
 343           (current-module))
 344     (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))
 345
 346   (pass-if "changing class"
 347     (let* ((c1 (class () (the-slot #:init-keyword #:value)))
 348            (c2 (class () (the-slot #:init-keyword #:value)
 349                          (the-other-slot #:init-value 888)))
 350            (o1 (make c1 #:value 777)))
 351       (and (is-a? o1 c1)
 352            (not (is-a? o1 c2))
 353            (equal? (slot-ref o1 'the-slot) 777)
 354            (let ((o2 (change-class o1 c2)))
 355              (and (eq? o1 o2)
 356                   (is-a? o2 c2)
 357                   (not (is-a? o2 c1))
 358                   (equal? (slot-ref o2 'the-slot) 777))))))
 359
 360   (pass-if "`hell' in `goops.c' grows as expected"
 361     ;; This snippet yielded a segfault prior to the 2008-08-19 `goops.c'
 362     ;; fix (i.e., Guile 1.8.5 and earlier).  The root of the problem was
 363     ;; that `go_to_hell ()' would not reallocate enough room for the `hell'
 364     ;; array, leading to out-of-bounds accesses.
 365
 366     (let* ((parent-class (class ()
 367                            #:name '<class-that-will-be-redefined>))
 368            (classes
 369             (unfold (lambda (i) (>= i 20))
 370                     (lambda (i)
 371                       (make-class (list parent-class)
 372                                   '((the-slot #:init-value #:value)
 373                                     (the-other-slot))
 374                                   #:name (string->symbol
 375                                           (string-append "<foo-to-redefine-"
 376                                                          (number->string i)
 377                                                          ">"))))
 378                     (lambda (i)
 379                       (+ 1 i))
 380                     0))
 381            (objects
 382             (map (lambda (class)
 383                    (make class #:value 777))
 384                  classes)))
 385
 386       (define-method (change-class (foo parent-class)
 387                                    (new <class>))
 388         ;; Called by `scm_change_object_class ()', via `purgatory ()'.
 389         (if (null? classes)
 390             (next-method)
 391             (let ((class  (car classes))
 392                   (object (car objects)))
 393               (set! classes (cdr classes))
 394               (set! objects (cdr objects))
 395
 396               ;; Redefine the class so that its instances are eventually
 397               ;; passed to `scm_change_object_class ()'.  This leads to
 398               ;; nested `scm_change_object_class ()' calls, which increases
 399               ;; the size of HELL and increments N_HELL.
 400               (class-redefinition class
 401                                   (make-class '() (class-slots class)
 402                                               #:name (class-name class)))
 403
 404               ;; Use `slot-ref' to trigger the `scm_change_object_class ()'
 405               ;; and `go_to_hell ()' calls.
 406               (slot-ref object 'the-slot)
 407
 408               (next-method))))
 409
 410
 411       ;; Initiate the whole `change-class' chain.
 412       (let* ((class  (car classes))
 413              (object (change-class (car objects) class)))
 414         (is-a? object class)))))
 415
 416 (with-test-prefix "object comparison"
 417   (pass-if "default method"
 418            (eval '(begin
 419                     (define-class <c> ()
 420                       (x #:accessor x #:init-keyword #:x)
 421                       (y #:accessor y #:init-keyword #:y))
 422                     (define o1 (make <c> #:x '(1) #:y '(2)))
 423                     (define o2 (make <c> #:x '(1) #:y '(3)))
 424                     (define o3 (make <c> #:x '(4) #:y '(3)))
 425                     (define o4 (make <c> #:x '(4) #:y '(3)))
 426                     (not (eqv? o1 o2)))
 427                  (current-module)))
 428   (pass-if "equal?"
 429            (eval '(begin
 430                     (define-method (equal? (a <c>) (b <c>))
 431                       (equal? (y a) (y b)))
 432                     (equal? o2 o3))
 433                  (current-module)))
 434   (pass-if "not equal?"
 435            (eval '(not (equal? o1 o2))
 436                  (current-module)))
 437   (pass-if "="
 438            (eval '(begin
 439                     (define-method (= (a <c>) (b <c>))
 440                       (and (equal? (x a) (x b))
 441                            (equal? (y a) (y b))))
 442                     (= o3 o4))
 443                  (current-module)))
 444   (pass-if "not ="
 445            (eval '(not (= o1 o2))
 446                  (current-module)))
 447   )
 448
 449 (use-modules (oop goops active-slot))
 450
 451 (with-test-prefix "active-slot"
 452   (pass-if "defining class with active slot"
 453     (eval '(begin
 454              (define z '())
 455              (define-class <bar> ()
 456                (x #:accessor x
 457                   #:init-value 1
 458                   #:allocation #:active
 459                   #:before-slot-ref
 460                   (lambda (o)
 461                     (set! z (cons 'before-ref z))
 462                     #t)
 463                   #:after-slot-ref
 464                   (lambda (o)
 465                     (set! z (cons 'after-ref z)))
 466                   #:before-slot-set!
 467                   (lambda (o v)
 468                     (set! z (cons* v 'before-set! z)))
 469                   #:after-slot-set!
 470                   (lambda (o v)
 471                     (set! z (cons* v (x o) 'after-set! z))))
 472                #:metaclass <active-class>)
 473              (define bar (make <bar>))
 474              (x bar)
 475              (set! (x bar) 2)
 476              (equal? (reverse z)
 477                      '(before-set! 1 before-ref after-ref
 478                        after-set! 1 1 before-ref after-ref
 479                        before-set! 2 before-ref after-ref after-set! 2 2)))
 480           (current-module))))
 481
 482 (use-modules (oop goops composite-slot))
 483
 484 (with-test-prefix "composite-slot"
 485   (pass-if "creating instance with propagated slot"
 486     (eval '(begin
 487              (define-class <a> ()
 488                (x #:accessor x #:init-keyword #:x)
 489                (y #:accessor y #:init-keyword #:y))
 490              (define-class <c> ()
 491                (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2))
 492                (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4))
 493                (x #:accessor x
 494                   #:allocation #:propagated
 495                   #:propagate-to '(o1 (o2 y)))
 496                #:metaclass <composite-class>)
 497              (define o (make <c>))
 498              (is-a? o <c>))
 499           (current-module)))
 500   (pass-if "reading propagated slot"
 501            (eval '(= (x o) 1) (current-module)))
 502   (pass-if "writing propagated slot"
 503            (eval '(begin
 504                     (set! (x o) 5)
 505                     (and (= (x (o1 o)) 5)
 506                          (= (y (o1 o)) 2)
 507                          (= (x (o2 o)) 3)
 508                          (= (y (o2 o)) 5)))
 509                  (current-module))))
 510
 511 (with-test-prefix "no-applicable-method"
 512   (pass-if-exception "calling generic, no methods"
 513                      exception:no-applicable-method
 514     (eval '(begin
 515              (define-class <qux> ())
 516              (define-generic quxy)
 517              (quxy 1))
 518           (current-module)))
 519   (pass-if "calling generic, one method, applicable"
 520     (eval '(begin
 521              (define-method (quxy (q <qux>))
 522                #t)
 523              (define q (make <qux>))
 524              (quxy q))
 525           (current-module)))
 526   (pass-if-exception "calling generic, one method, not applicable"
 527                      exception:no-applicable-method
 528     (eval '(quxy 1)
 529           (current-module))))
 530
 531 (with-test-prefix "foreign slots"
 532   (define-class <foreign-test> ()
 533     (a #:init-keyword #:a #:class <foreign-slot>
 534        #:accessor test-a)
 535     (b #:init-keyword #:b #:init-form 3 #:class <foreign-slot>
 536        #:accessor test-b))
 537
 538   (pass-if-equal "constructing, no initargs"
 539       '(0 3)
 540     (let ((x (make <foreign-test>)))
 541       (list (slot-ref x 'a)
 542             (slot-ref x 'b))))
 543
 544   (pass-if-equal "constructing, initargs"
 545       '(1 2)
 546     (let ((x (make <foreign-test> #:a 1 #:b 2)))
 547       (list (slot-ref x 'a)
 548             (slot-ref x 'b))))
 549
 550   (pass-if-equal "getters"
 551       '(0 3)
 552     (let ((x (make <foreign-test>)))
 553       (list (test-a x) (test-b x))))
 554
 555   (pass-if-equal "setters"
 556       '(10 20)
 557     (let ((x (make <foreign-test>)))
 558       (set! (test-a x) 10)
 559       (set! (test-b x) 20)
 560       (list (test-a x) (test-b x))))
 561
 562   (pass-if-exception "out of range"
 563       exception:out-of-range
 564     (make <foreign-test> #:a (ash 1 64))))
 565
 566 (with-test-prefix "#:each-subclass"
 567   (let* ((<subclass-allocation-test>
 568           (class ()
 569             (test #:init-value '() #:allocation #:each-subclass)
 570             #:name '<subclass-allocation-test>))
 571          (a (make <subclass-allocation-test>)))
 572     (pass-if-equal '() (slot-ref a 'test))
 573     (let ((b (make <subclass-allocation-test>)))
 574       (pass-if-equal '() (slot-ref b 'test))
 575       (slot-set! a 'test 100)
 576       (pass-if-equal 100 (slot-ref a 'test))
 577       (pass-if-equal 100 (slot-ref b 'test))
 578
 579       ;; #:init-value of the class shouldn't reinitialize slot when
 580       ;; instances are allocated.
 581       (make <subclass-allocation-test>)
 582
 583       (pass-if-equal 100 (slot-ref a 'test))
 584       (pass-if-equal 100 (slot-ref b 'test))
 585
 586       (let ((<test-subclass>
 587              (class (<subclass-allocation-test>))))
 588         (pass-if-equal 100 (slot-ref a 'test))
 589         (pass-if-equal 100 (slot-ref b 'test))
 590         (let ((c (make <test-subclass>)))
 591           (pass-if-equal 100 (slot-ref a 'test))
 592           (pass-if-equal 100 (slot-ref b 'test))
 593           (pass-if-equal '() (slot-ref c 'test))
 594           (slot-set! c 'test 200)
 595           (pass-if-equal 200 (slot-ref c 'test))
 596
 597           (make <test-subclass>)
 598
 599           (pass-if-equal 100 (slot-ref a 'test))
 600           (pass-if-equal 100 (slot-ref b 'test))
 601           (pass-if-equal 200 (slot-ref c 'test)))))))
 602
 603 (with-test-prefix "accessor slots"
 604   (let* ((a-accessor (make-accessor 'a))
 605          (b-accessor (make-accessor 'b))
 606          (<a> (class ()
 607                 (a #:init-keyword #:a #:accessor a-accessor)
 608                 #:name '<a>))
 609          (<b> (class ()
 610                 (b #:init-keyword #:b #:accessor b-accessor)
 611                 #:name '<b>))
 612          (<ab> (class (<a> <b>) #:name '<ab>))
 613          (<ba> (class (<b> <a>) #:name '<ba>))
 614          (<cab> (class (<ab>)
 615                   (a #:init-keyword #:a)
 616                   #:name '<cab>))
 617          (<cba> (class (<ba>)
 618                   (a #:init-keyword #:a)
 619                   #:name '<cba>))
 620          (a (make <a> #:a 'a))
 621          (b (make <b> #:b 'b))
 622          (ab (make <ab> #:a 'a #:b 'b))
 623          (ba (make <ba> #:a 'a #:b 'b))
 624          (cab (make <cab> #:a 'a #:b 'b))
 625          (cba (make <cba> #:a 'a #:b 'b)))
 626     (pass-if-equal "a accessor on a" 'a (a-accessor a))
 627     (pass-if-equal "a accessor on ab" 'a (a-accessor ab))
 628     (pass-if-equal "a accessor on ba" 'a (a-accessor ba))
 629     (pass-if-equal "a accessor on cab" 'a (a-accessor cab))
 630     (pass-if-equal "a accessor on cba" 'a (a-accessor cba))
 631     (pass-if-equal "b accessor on a" 'b (b-accessor b))
 632     (pass-if-equal "b accessor on ab" 'b (b-accessor ab))
 633     (pass-if-equal "b accessor on ba" 'b (b-accessor ba))
 634     (pass-if-equal "b accessor on cab" 'b (b-accessor cab))
 635     (pass-if-equal "b accessor on cba" 'b (b-accessor cba))))