test-suite/tests/goops.test

   1 ;;;; goops.test --- test suite for GOOPS                      -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 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-vtable "prprpr" 0)) <class>)))
 151
 152
 153 (with-test-prefix "defining classes"
 154
 155   (with-test-prefix "define-class"
 156
 157     (pass-if "creating a new binding"
 158       (if (eval '(defined? '<foo-0>) (current-module))
 159           (throw 'unresolved))
 160       (eval '(define-class <foo-0> ()) (current-module))
 161       (eval '(is-a? <foo-0> <class>) (current-module)))
 162
 163     (pass-if "overwriting a binding to a non-class"
 164       (eval '(define <foo> #f) (current-module))
 165       (eval '(define-class <foo> ()) (current-module))
 166       (eval '(is-a? <foo> <class>) (current-module)))
 167
 168     (expect-fail "bad init-thunk"
 169                  (catch #t
 170                         (lambda ()
 171                           (eval '(define-class <foo> ()
 172                                    (x #:init-thunk (lambda (x) 1)))
 173                                 (current-module))
 174                           #t)
 175                         (lambda args
 176                           #f)))
 177
 178     (pass-if "interaction with `struct-ref'"
 179        (eval '(define-class <class-struct> ()
 180                 (foo #:init-keyword #:foo)
 181                 (bar #:init-keyword #:bar))
 182              (current-module))
 183        (eval '(let ((x (make <class-struct>
 184                          #:foo 'hello
 185                          #:bar 'world)))
 186                 (and (struct? x)
 187                      (eq? (struct-ref x 0) 'hello)
 188                      (eq? (struct-ref x 1) 'world)))
 189              (current-module)))
 190
 191      (pass-if "interaction with `struct-set!'"
 192        (eval '(define-class <class-struct-2> ()
 193                 (foo) (bar))
 194              (current-module))
 195        (eval '(let ((x (make <class-struct-2>)))
 196                 (struct-set! x 0 'hello)
 197                 (struct-set! x 1 'world)
 198                 (and (struct? x)
 199                      (eq? (struct-ref x 0) 'hello)
 200                      (eq? (struct-ref x 1) 'world)))
 201              (current-module)))
 202
 203      (pass-if "with accessors"
 204               (eval '(define-class <qux> ()
 205                        (x #:accessor x #:init-value 123)
 206                        (z #:accessor z #:init-value 789))
 207                     (current-module))
 208               (eval '(equal? (x (make <qux>)) 123) (current-module)))))
 209
 210
 211 (with-test-prefix "defining generics"
 212
 213   (with-test-prefix "define-generic"
 214
 215     (pass-if "creating a new top-level binding"
 216       (if (eval '(defined? 'foo-0) (current-module))
 217           (throw 'unresolved))
 218       (eval '(define-generic foo-0) (current-module))
 219       (eval '(and (is-a? foo-0 <generic>)
 220                   (null? (generic-function-methods foo-0)))
 221             (current-module)))
 222
 223     (pass-if "overwriting a top-level binding to a non-generic"
 224       (eval '(define (foo) #f) (current-module))
 225       (eval '(define-generic foo) (current-module))
 226       (eval '(and (is-a? foo <generic>)
 227                   (= 1 (length (generic-function-methods foo))))
 228             (current-module)))
 229
 230     (pass-if "overwriting a top-level binding to a generic"
 231       (eval '(define (foo) #f) (current-module))
 232       (eval '(define-generic foo) (current-module))
 233       (eval '(define-generic foo) (current-module))
 234       (eval '(and (is-a? foo <generic>)
 235                   (null? (generic-function-methods foo)))
 236             (current-module)))))
 237
 238 (with-test-prefix "defining methods"
 239
 240   (pass-if "define-method"
 241     (let ((m (current-module)))
 242       (eval '(define-method (my-plus (s1 <string>) (s2 <string>))
 243                (string-append s1 s2))
 244             m)
 245       (eval '(define-method (my-plus (i1 <integer>) (i2 <integer>))
 246                (+ i1 i2))
 247             m)
 248       (eval '(and (is-a? my-plus <generic>)
 249                   (= (length (generic-function-methods my-plus))
 250                      2))
 251             m)))
 252
 253   (pass-if "method-more-specific?"
 254     (eval '(let* ((m+        (generic-function-methods my-plus))
 255                   (m1        (car m+))
 256                   (m2        (cadr m+))
 257                   (arg-types (list <string> <string>)))
 258              (if (memq <string> (method-specializers m1))
 259                  (method-more-specific? m1 m2 arg-types)
 260                  (method-more-specific? m2 m1 arg-types)))
 261           (current-module)))
 262
 263   (pass-if-exception "method-more-specific? (failure)"
 264                      exception:wrong-type-arg
 265     (eval '(let* ((m+ (generic-function-methods my-plus))
 266                   (m1 (car m+))
 267                   (m2 (cadr m+)))
 268              (method-more-specific? m1 m2 '()))
 269           (current-module))))
 270
 271 (with-test-prefix "the method cache"
 272   (pass-if "defining a method with a rest arg"
 273     (let ((m (current-module)))
 274       (eval '(define-method (foo bar . baz)
 275                (cons bar baz))
 276             m)
 277       (eval '(foo 1)
 278             m)
 279       (eval '(foo 1 2)
 280             m)
 281       (eval '(equal? (foo 1 2) '(1 2))
 282             m))))
 283
 284 (with-test-prefix "defining accessors"
 285
 286   (with-test-prefix "define-accessor"
 287
 288     (pass-if "creating a new top-level binding"
 289       (if (eval '(defined? 'foo-1) (current-module))
 290           (throw 'unresolved))
 291       (eval '(define-accessor foo-1) (current-module))
 292       (eval '(and (is-a? foo-1 <generic-with-setter>)
 293                   (null? (generic-function-methods foo-1)))
 294             (current-module)))
 295
 296     (pass-if "overwriting a top-level binding to a non-accessor"
 297       (eval '(define (foo) #f) (current-module))
 298       (eval '(define-accessor foo) (current-module))
 299       (eval '(and (is-a? foo <generic-with-setter>)
 300                   (= 1 (length (generic-function-methods foo))))
 301             (current-module)))
 302
 303     (pass-if "overwriting a top-level binding to an accessor"
 304       (eval '(define (foo) #f) (current-module))
 305       (eval '(define-accessor foo) (current-module))
 306       (eval '(define-accessor foo) (current-module))
 307       (eval '(and (is-a? foo <generic-with-setter>)
 308                   (null? (generic-function-methods foo)))
 309             (current-module)))))
 310
 311 (with-test-prefix "object update"
 312   (pass-if "defining class"
 313     (eval '(define-class <foo> ()
 314              (x #:accessor x #:init-value 123)
 315              (z #:accessor z #:init-value 789))
 316           (current-module))
 317     (eval '(is-a? <foo> <class>) (current-module)))
 318   (pass-if "making instance"
 319     (eval '(define foo (make <foo>)) (current-module))
 320     (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module)))
 321   (pass-if "redefining class"
 322     (eval '(define-class <foo> ()
 323              (x #:accessor x #:init-value 123)
 324              (y #:accessor y #:init-value 456)
 325              (z #:accessor z #:init-value 789))
 326           (current-module))
 327     (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))
 328
 329   (pass-if "changing class"
 330     (let* ((c1 (class () (the-slot #:init-keyword #:value)))
 331            (c2 (class () (the-slot #:init-keyword #:value)
 332                          (the-other-slot #:init-value 888)))
 333            (o1 (make c1 #:value 777)))
 334       (and (is-a? o1 c1)
 335            (not (is-a? o1 c2))
 336            (equal? (slot-ref o1 'the-slot) 777)
 337            (let ((o2 (change-class o1 c2)))
 338              (and (eq? o1 o2)
 339                   (is-a? o2 c2)
 340                   (not (is-a? o2 c1))
 341                   (equal? (slot-ref o2 'the-slot) 777))))))
 342
 343   (pass-if "`hell' in `goops.c' grows as expected"
 344     ;; This snippet yielded a segfault prior to the 2008-08-19 `goops.c'
 345     ;; fix (i.e., Guile 1.8.5 and earlier).  The root of the problem was
 346     ;; that `go_to_hell ()' would not reallocate enough room for the `hell'
 347     ;; array, leading to out-of-bounds accesses.
 348
 349     (let* ((parent-class (class ()
 350                            #:name '<class-that-will-be-redefined>))
 351            (classes
 352             (unfold (lambda (i) (>= i 20))
 353                     (lambda (i)
 354                       (make-class (list parent-class)
 355                                   '((the-slot #:init-value #:value)
 356                                     (the-other-slot))
 357                                   #:name (string->symbol
 358                                           (string-append "<foo-to-redefine-"
 359                                                          (number->string i)
 360                                                          ">"))))
 361                     (lambda (i)
 362                       (+ 1 i))
 363                     0))
 364            (objects
 365             (map (lambda (class)
 366                    (make class #:value 777))
 367                  classes)))
 368
 369       (define-method (change-class (foo parent-class)
 370                                    (new <class>))
 371         ;; Called by `scm_change_object_class ()', via `purgatory ()'.
 372         (if (null? classes)
 373             (next-method)
 374             (let ((class  (car classes))
 375                   (object (car objects)))
 376               (set! classes (cdr classes))
 377               (set! objects (cdr objects))
 378
 379               ;; Redefine the class so that its instances are eventually
 380               ;; passed to `scm_change_object_class ()'.  This leads to
 381               ;; nested `scm_change_object_class ()' calls, which increases
 382               ;; the size of HELL and increments N_HELL.
 383               (class-redefinition class
 384                                   (make-class '() (class-slots class)
 385                                               #:name (class-name class)))
 386
 387               ;; Use `slot-ref' to trigger the `scm_change_object_class ()'
 388               ;; and `go_to_hell ()' calls.
 389               (slot-ref object 'the-slot)
 390
 391               (next-method))))
 392
 393
 394       ;; Initiate the whole `change-class' chain.
 395       (let* ((class  (car classes))
 396              (object (change-class (car objects) class)))
 397         (is-a? object class)))))
 398
 399 (with-test-prefix "object comparison"
 400   (pass-if "default method"
 401            (eval '(begin
 402                     (define-class <c> ()
 403                       (x #:accessor x #:init-keyword #:x)
 404                       (y #:accessor y #:init-keyword #:y))
 405                     (define o1 (make <c> #:x '(1) #:y '(2)))
 406                     (define o2 (make <c> #:x '(1) #:y '(3)))
 407                     (define o3 (make <c> #:x '(4) #:y '(3)))
 408                     (define o4 (make <c> #:x '(4) #:y '(3)))
 409                     (not (eqv? o1 o2)))
 410                  (current-module)))
 411   (pass-if "equal?"
 412            (eval '(begin
 413                     (define-method (equal? (a <c>) (b <c>))
 414                       (equal? (y a) (y b)))
 415                     (equal? o2 o3))
 416                  (current-module)))
 417   (pass-if "not equal?"
 418            (eval '(not (equal? o1 o2))
 419                  (current-module)))
 420   (pass-if "="
 421            (eval '(begin
 422                     (define-method (= (a <c>) (b <c>))
 423                       (and (equal? (x a) (x b))
 424                            (equal? (y a) (y b))))
 425                     (= o3 o4))
 426                  (current-module)))
 427   (pass-if "not ="
 428            (eval '(not (= o1 o2))
 429                  (current-module)))
 430   )
 431
 432 (use-modules (oop goops active-slot))
 433
 434 (with-test-prefix "active-slot"
 435   (pass-if "defining class with active slot"
 436     (eval '(begin
 437              (define z '())
 438              (define-class <bar> ()
 439                (x #:accessor x
 440                   #:init-value 1
 441                   #:allocation #:active
 442                   #:before-slot-ref
 443                   (lambda (o)
 444                     (set! z (cons 'before-ref z))
 445                     #t)
 446                   #:after-slot-ref
 447                   (lambda (o)
 448                     (set! z (cons 'after-ref z)))
 449                   #:before-slot-set!
 450                   (lambda (o v)
 451                     (set! z (cons* v 'before-set! z)))
 452                   #:after-slot-set!
 453                   (lambda (o v)
 454                     (set! z (cons* v (x o) 'after-set! z))))
 455                #:metaclass <active-class>)
 456              (define bar (make <bar>))
 457              (x bar)
 458              (set! (x bar) 2)
 459              (equal? (reverse z)
 460                      '(before-ref before-set! 1 before-ref after-ref
 461                        after-set! 1 1 before-ref after-ref
 462                        before-set! 2 before-ref after-ref after-set! 2 2)))
 463           (current-module))))
 464
 465 (use-modules (oop goops composite-slot))
 466
 467 (with-test-prefix "composite-slot"
 468   (pass-if "creating instance with propagated slot"
 469     (eval '(begin
 470              (define-class <a> ()
 471                (x #:accessor x #:init-keyword #:x)
 472                (y #:accessor y #:init-keyword #:y))
 473              (define-class <c> ()
 474                (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2))
 475                (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4))
 476                (x #:accessor x
 477                   #:allocation #:propagated
 478                   #:propagate-to '(o1 (o2 y)))
 479                #:metaclass <composite-class>)
 480              (define o (make <c>))
 481              (is-a? o <c>))
 482           (current-module)))
 483   (pass-if "reading propagated slot"
 484            (eval '(= (x o) 1) (current-module)))
 485   (pass-if "writing propagated slot"
 486            (eval '(begin
 487                     (set! (x o) 5)
 488                     (and (= (x (o1 o)) 5)
 489                          (= (y (o1 o)) 2)
 490                          (= (x (o2 o)) 3)
 491                          (= (y (o2 o)) 5)))
 492                  (current-module))))
 493
 494 (with-test-prefix "no-applicable-method"
 495   (pass-if-exception "calling generic, no methods"
 496                      exception:no-applicable-method
 497     (eval '(begin
 498              (define-class <qux> ())
 499              (define-generic quxy)
 500              (quxy 1))
 501           (current-module)))
 502   (pass-if "calling generic, one method, applicable"
 503     (eval '(begin
 504              (define-method (quxy (q <qux>))
 505                #t)
 506              (define q (make <qux>))
 507              (quxy q))
 508           (current-module)))
 509   (pass-if-exception "calling generic, one method, not applicable"
 510                      exception:no-applicable-method
 511     (eval '(quxy 1)
 512           (current-module))))