test-suite/tests/goops.test

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