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