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 (pass-if "GOOPS loads"
  24          (false-if-exception
  25           (begin (resolve-module '(oop goops))
  26                  #t)))
  27
  28 (use-modules (oop goops))
  29
  30 ;;; more tests here...
  31
  32 (with-test-prefix "basic classes"
  33
  34   (with-test-prefix "<top>"
  35
  36     (pass-if "instance?"
  37       (instance? <top>))
  38
  39     (pass-if "class-of"
  40       (eq? (class-of <top>) <class>))
  41
  42     (pass-if "is a class?"
  43       (is-a? <top> <class>))
  44
  45     (pass-if "class-name"
  46       (eq? (class-name <top>) '<top>))
  47
  48     (pass-if "direct superclasses"
  49       (equal? (class-direct-supers <top>) '()))
  50
  51     (pass-if "superclasses"
  52       (equal? (class-precedence-list <top>) (list <top>)))
  53
  54     (pass-if "direct slots"
  55       (equal? (class-direct-slots <top>) '()))
  56
  57     (pass-if "slots"
  58       (equal? (class-slots <top>) '())))
  59
  60   (with-test-prefix "<object>"
  61
  62     (pass-if "instance?"
  63       (instance? <object>))
  64
  65     (pass-if "class-of"
  66       (eq? (class-of <object>) <class>))
  67
  68     (pass-if "is a class?"
  69       (is-a? <object> <class>))
  70
  71     (pass-if "class-name"
  72       (eq? (class-name <object>) '<object>))
  73
  74     (pass-if "direct superclasses"
  75       (equal? (class-direct-supers <object>) (list <top>)))
  76
  77     (pass-if "superclasses"
  78       (equal? (class-precedence-list <object>) (list <object> <top>)))
  79
  80     (pass-if "direct slots"
  81       (equal? (class-direct-slots <object>) '()))
  82
  83     (pass-if "slots"
  84       (equal? (class-slots <object>) '())))
  85
  86   (with-test-prefix "<class>"
  87
  88     (pass-if "instance?"
  89       (instance? <class>))
  90
  91     (pass-if "class-of"
  92       (eq? (class-of <class>) <class>))
  93
  94     (pass-if "is a class?"
  95       (is-a? <class> <class>))
  96
  97     (pass-if "class-name"
  98       (eq? (class-name <class>) '<class>))
  99
 100     (pass-if "direct superclass"
 101       (equal? (class-direct-supers <class>) (list <object>))))
 102
 103   (with-test-prefix "class-precedence-list"
 104     (for-each (lambda (class)
 105                 (run-test (if (slot-bound? class 'name)
 106                               (class-name class)
 107                               (with-output-to-string
 108                                 (lambda ()
 109                                   (display class))))
 110                           #t
 111                           (lambda ()
 112                             (catch #t
 113                                    (lambda ()
 114                                      (equal? (class-precedence-list class)
 115                                              (compute-cpl class)))
 116                                    (lambda args #t)))))
 117               (let ((table (make-hash-table)))
 118                 (let rec ((class <top>))
 119                   (hash-create-handle! table class #f)
 120                   (for-each rec (class-direct-subclasses class)))
 121                 (hash-fold (lambda (class ignore classes)
 122                              (cons class classes))
 123                            '()
 124                            table))))
 125   )
 126
 127 (with-test-prefix "classes for built-in types"
 128
 129   (pass-if "subr"
 130     (eq? (class-of fluid-ref) <procedure>))
 131
 132   (pass-if "gsubr"
 133     (eq? (class-of hashq-ref) <procedure>))
 134
 135   (pass-if "car"
 136     (eq? (class-of car) <procedure>))
 137
 138   (pass-if "string"
 139     (eq? (class-of "foo") <string>))
 140
 141   (pass-if "port"
 142     (is-a? (%make-void-port "w") <port>)))
 143
 144
 145 (with-test-prefix "defining classes"
 146
 147   (with-test-prefix "define-class"
 148
 149     (pass-if "creating a new binding"
 150       (if (eval '(defined? '<foo-0>) (current-module))
 151           (throw 'unresolved))
 152       (eval '(define-class <foo-0> ()) (current-module))
 153       (eval '(is-a? <foo-0> <class>) (current-module)))
 154
 155     (pass-if "overwriting a binding to a non-class"
 156       (eval '(define <foo> #f) (current-module))
 157       (eval '(define-class <foo> ()) (current-module))
 158       (eval '(is-a? <foo> <class>) (current-module)))
 159
 160     (expect-fail "bad init-thunk"
 161                  (catch #t
 162                         (lambda ()
 163                           (eval '(define-class <foo> ()
 164                                    (x #:init-thunk (lambda (x) 1)))
 165                                 (current-module))
 166                           #t)
 167                         (lambda args
 168                           #f)))
 169
 170     (pass-if "interaction with `struct-ref'"
 171        (eval '(define-class <class-struct> ()
 172                 (foo #:init-keyword #:foo)
 173                 (bar #:init-keyword #:bar))
 174              (current-module))
 175        (eval '(let ((x (make <class-struct>
 176                          #:foo 'hello
 177                          #:bar 'world)))
 178                 (and (struct? x)
 179                      (eq? (struct-ref x 0) 'hello)
 180                      (eq? (struct-ref x 1) 'world)))
 181              (current-module)))
 182
 183      (pass-if "interaction with `struct-set!'"
 184        (eval '(define-class <class-struct-2> ()
 185                 (foo) (bar))
 186              (current-module))
 187        (eval '(let ((x (make <class-struct-2>)))
 188                 (struct-set! x 0 'hello)
 189                 (struct-set! x 1 'world)
 190                 (and (struct? x)
 191                      (eq? (struct-ref x 0) 'hello)
 192                      (eq? (struct-ref x 1) 'world)))
 193              (current-module)))
 194
 195      (pass-if "with accessors"
 196               (eval '(define-class <qux> ()
 197                        (x #:accessor x #:init-value 123)
 198                        (z #:accessor z #:init-value 789))
 199                     (current-module))
 200               (eval '(equal? (x (make <qux>)) 123) (current-module)))))
 201
 202
 203 (with-test-prefix "defining generics"
 204
 205   (with-test-prefix "define-generic"
 206
 207     (pass-if "creating a new top-level binding"
 208       (if (eval '(defined? 'foo-0) (current-module))
 209           (throw 'unresolved))
 210       (eval '(define-generic foo-0) (current-module))
 211       (eval '(and (is-a? foo-0 <generic>)
 212                   (null? (generic-function-methods foo-0)))
 213             (current-module)))
 214
 215     (pass-if "overwriting a top-level binding to a non-generic"
 216       (eval '(define (foo) #f) (current-module))
 217       (eval '(define-generic foo) (current-module))
 218       (eval '(and (is-a? foo <generic>)
 219                   (= 1 (length (generic-function-methods foo))))
 220             (current-module)))
 221
 222     (pass-if "overwriting a top-level binding to a generic"
 223       (eval '(define (foo) #f) (current-module))
 224       (eval '(define-generic foo) (current-module))
 225       (eval '(define-generic foo) (current-module))
 226       (eval '(and (is-a? foo <generic>)
 227                   (null? (generic-function-methods foo)))
 228             (current-module)))))
 229
 230 (with-test-prefix "defining methods"
 231
 232   (pass-if "define-method"
 233     (let ((m (current-module)))
 234       (eval '(define-method (my-plus (s1 <string>) (s2 <string>))
 235                (string-append s1 s2))
 236             m)
 237       (eval '(define-method (my-plus (i1 <integer>) (i2 <integer>))
 238                (+ i1 i2))
 239             m)
 240       (eval '(and (is-a? my-plus <generic>)
 241                   (= (length (generic-function-methods my-plus))
 242                      2))
 243             m)))
 244
 245   (pass-if "method-more-specific?"
 246     (eval '(let* ((m+        (generic-function-methods my-plus))
 247                   (m1        (car m+))
 248                   (m2        (cadr m+))
 249                   (arg-types (list <string> <string>)))
 250              (if (memq <string> (method-specializers m1))
 251                  (method-more-specific? m1 m2 arg-types)
 252                  (method-more-specific? m2 m1 arg-types)))
 253           (current-module)))
 254
 255   (pass-if-exception "method-more-specific? (failure)"
 256                      exception:wrong-type-arg
 257     (eval '(let* ((m+ (generic-function-methods my-plus))
 258                   (m1 (car m+))
 259                   (m2 (cadr m+)))
 260              (method-more-specific? m1 m2 '()))
 261           (current-module))))
 262
 263 (with-test-prefix "the method cache"
 264   (pass-if "defining a method with a rest arg"
 265     (let ((m (current-module)))
 266       (eval '(define-method (foo bar . baz)
 267                (cons bar baz))
 268             m)
 269       (eval '(foo 1)
 270             m)
 271       (eval '(foo 1 2)
 272             m)
 273       (eval '(equal? (foo 1 2) '(1 2))
 274             m))))
 275
 276 (with-test-prefix "defining accessors"
 277
 278   (with-test-prefix "define-accessor"
 279
 280     (pass-if "creating a new top-level binding"
 281       (if (eval '(defined? 'foo-1) (current-module))
 282           (throw 'unresolved))
 283       (eval '(define-accessor foo-1) (current-module))
 284       (eval '(and (is-a? foo-1 <generic-with-setter>)
 285                   (null? (generic-function-methods foo-1)))
 286             (current-module)))
 287
 288     (pass-if "overwriting a top-level binding to a non-accessor"
 289       (eval '(define (foo) #f) (current-module))
 290       (eval '(define-accessor foo) (current-module))
 291       (eval '(and (is-a? foo <generic-with-setter>)
 292                   (= 1 (length (generic-function-methods foo))))
 293             (current-module)))
 294
 295     (pass-if "overwriting a top-level binding to an accessor"
 296       (eval '(define (foo) #f) (current-module))
 297       (eval '(define-accessor foo) (current-module))
 298       (eval '(define-accessor foo) (current-module))
 299       (eval '(and (is-a? foo <generic-with-setter>)
 300                   (null? (generic-function-methods foo)))
 301             (current-module)))))
 302
 303 (with-test-prefix "object update"
 304   (pass-if "defining class"
 305     (eval '(define-class <foo> ()
 306              (x #:accessor x #:init-value 123)
 307              (z #:accessor z #:init-value 789))
 308           (current-module))
 309     (eval '(is-a? <foo> <class>) (current-module)))
 310   (pass-if "making instance"
 311     (eval '(define foo (make <foo>)) (current-module))
 312     (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module)))
 313   (pass-if "redefining class"
 314     (eval '(define-class <foo> ()
 315              (x #:accessor x #:init-value 123)
 316              (y #:accessor y #:init-value 456)
 317              (z #:accessor z #:init-value 789))
 318           (current-module))
 319     (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))
 320
 321   (pass-if "changing class"
 322     (let* ((c1 (class () (the-slot #:init-keyword #:value)))
 323            (c2 (class () (the-slot #:init-keyword #:value)
 324                          (the-other-slot #:init-value 888)))
 325            (o1 (make c1 #:value 777)))
 326       (and (is-a? o1 c1)
 327            (not (is-a? o1 c2))
 328            (equal? (slot-ref o1 'the-slot) 777)
 329            (let ((o2 (change-class o1 c2)))
 330              (and (eq? o1 o2)
 331                   (is-a? o2 c2)
 332                   (not (is-a? o2 c1))
 333                   (equal? (slot-ref o2 'the-slot) 777))))))
 334
 335   (pass-if "`hell' in `goops.c' grows as expected"
 336     ;; This snippet yielded a segfault prior to the 2008-08-19 `goops.c'
 337     ;; fix (i.e., Guile 1.8.5 and earlier).  The root of the problem was
 338     ;; that `go_to_hell ()' would not reallocate enough room for the `hell'
 339     ;; array, leading to out-of-bounds accesses.
 340
 341     (let* ((parent-class (class ()
 342                            #:name '<class-that-will-be-redefined>))
 343            (classes
 344             (unfold (lambda (i) (>= i 20))
 345                     (lambda (i)
 346                       (make-class (list parent-class)
 347                                   '((the-slot #:init-value #:value)
 348                                     (the-other-slot))
 349                                   #:name (string->symbol
 350                                           (string-append "<foo-to-redefine-"
 351                                                          (number->string i)
 352                                                          ">"))))
 353                     (lambda (i)
 354                       (+ 1 i))
 355                     0))
 356            (objects
 357             (map (lambda (class)
 358                    (make class #:value 777))
 359                  classes)))
 360
 361       (define-method (change-class (foo parent-class)
 362                                    (new <class>))
 363         ;; Called by `scm_change_object_class ()', via `purgatory ()'.
 364         (if (null? classes)
 365             (next-method)
 366             (let ((class  (car classes))
 367                   (object (car objects)))
 368               (set! classes (cdr classes))
 369               (set! objects (cdr objects))
 370
 371               ;; Redefine the class so that its instances are eventually
 372               ;; passed to `scm_change_object_class ()'.  This leads to
 373               ;; nested `scm_change_object_class ()' calls, which increases
 374               ;; the size of HELL and increments N_HELL.
 375               (class-redefinition class
 376                                   (make-class '() (class-slots class)
 377                                               #:name (class-name class)))
 378
 379               ;; Use `slot-ref' to trigger the `scm_change_object_class ()'
 380               ;; and `go_to_hell ()' calls.
 381               (slot-ref object 'the-slot)
 382
 383               (next-method))))
 384
 385
 386       ;; Initiate the whole `change-class' chain.
 387       (let* ((class  (car classes))
 388              (object (change-class (car objects) class)))
 389         (is-a? object class)))))
 390
 391 (with-test-prefix "object comparison"
 392   (pass-if "default method"
 393            (eval '(begin
 394                     (define-class <c> ()
 395                       (x #:accessor x #:init-keyword #:x)
 396                       (y #:accessor y #:init-keyword #:y))
 397                     (define o1 (make <c> #:x '(1) #:y '(2)))
 398                     (define o2 (make <c> #:x '(1) #:y '(3)))
 399                     (define o3 (make <c> #:x '(4) #:y '(3)))
 400                     (define o4 (make <c> #:x '(4) #:y '(3)))
 401                     (not (eqv? o1 o2)))
 402                  (current-module)))
 403   (pass-if "eqv?"
 404            (eval '(begin
 405                     (define-method (eqv? (a <c>) (b <c>))
 406                       (equal? (x a) (x b)))
 407                     (eqv? o1 o2))
 408                  (current-module)))
 409   (pass-if "not eqv?"
 410            (eval '(not (eqv? o2 o3))
 411                  (current-module)))
 412   (pass-if "transfer eqv? => equal?"
 413            (eval '(equal? o1 o2)
 414                  (current-module)))
 415   (pass-if "equal?"
 416            (eval '(begin
 417                     (define-method (equal? (a <c>) (b <c>))
 418                       (equal? (y a) (y b)))
 419                     (equal? o2 o3))
 420                  (current-module)))
 421   (pass-if "not equal?"
 422            (eval '(not (equal? o1 o2))
 423                  (current-module)))
 424   (pass-if "="
 425            (eval '(begin
 426                     (define-method (= (a <c>) (b <c>))
 427                       (and (equal? (x a) (x b))
 428                            (equal? (y a) (y b))))
 429                     (= o3 o4))
 430                  (current-module)))
 431   (pass-if "not ="
 432            (eval '(not (= o1 o2))
 433                  (current-module)))
 434   )
 435
 436 (use-modules (oop goops active-slot))
 437
 438 (with-test-prefix "active-slot"
 439   (pass-if "defining class with active slot"
 440     (eval '(begin
 441              (define z '())
 442              (define-class <bar> ()
 443                (x #:accessor x
 444                   #:init-value 1
 445                   #:allocation #:active
 446                   #:before-slot-ref
 447                   (lambda (o)
 448                     (set! z (cons 'before-ref z))
 449                     #t)
 450                   #:after-slot-ref
 451                   (lambda (o)
 452                     (set! z (cons 'after-ref z)))
 453                   #:before-slot-set!
 454                   (lambda (o v)
 455                     (set! z (cons* v 'before-set! z)))
 456                   #:after-slot-set!
 457                   (lambda (o v)
 458                     (set! z (cons* v (x o) 'after-set! z))))
 459                #:metaclass <active-class>)
 460              (define bar (make <bar>))
 461              (x bar)
 462              (set! (x bar) 2)
 463              (equal? (reverse z)
 464                      '(before-ref before-set! 1 before-ref after-ref
 465                        after-set! 1 1 before-ref after-ref
 466                        before-set! 2 before-ref after-ref after-set! 2 2)))
 467           (current-module))))
 468
 469 (use-modules (oop goops composite-slot))
 470
 471 (with-test-prefix "composite-slot"
 472   (pass-if "creating instance with propagated slot"
 473     (eval '(begin
 474              (define-class <a> ()
 475                (x #:accessor x #:init-keyword #:x)
 476                (y #:accessor y #:init-keyword #:y))
 477              (define-class <c> ()
 478                (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2))
 479                (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4))
 480                (x #:accessor x
 481                   #:allocation #:propagated
 482                   #:propagate-to '(o1 (o2 y)))
 483                #:metaclass <composite-class>)
 484              (define o (make <c>))
 485              (is-a? o <c>))
 486           (current-module)))
 487   (pass-if "reading propagated slot"
 488            (eval '(= (x o) 1) (current-module)))
 489   (pass-if "writing propagated slot"
 490            (eval '(begin
 491                     (set! (x o) 5)
 492                     (and (= (x (o1 o)) 5)
 493                          (= (y (o1 o)) 2)
 494                          (= (x (o2 o)) 3)
 495                          (= (y (o2 o)) 5)))
 496                  (current-module))))