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
  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 "defining classes"
 128
 129   (with-test-prefix "define-class"
 130
 131     (pass-if "creating a new binding"
 132       (if (eval '(defined? '<foo-0>) (current-module))
 133           (throw 'unresolved))
 134       (eval '(define-class <foo-0> ()) (current-module))
 135       (eval '(is-a? <foo-0> <class>) (current-module)))
 136
 137     (pass-if "overwriting a binding to a non-class"
 138       (eval '(define <foo> #f) (current-module))
 139       (eval '(define-class <foo> ()) (current-module))
 140       (eval '(is-a? <foo> <class>) (current-module)))
 141
 142     (expect-fail "bad init-thunk"
 143                  (catch #t
 144                         (lambda ()
 145                           (eval '(define-class <foo> ()
 146                                    (x #:init-thunk (lambda (x) 1)))
 147                                 (current-module))
 148                           #t)
 149                         (lambda args
 150                           #f)))
 151
 152     (pass-if "interaction with `struct-ref'"
 153        (eval '(define-class <class-struct> ()
 154                 (foo #:init-keyword #:foo)
 155                 (bar #:init-keyword #:bar))
 156              (current-module))
 157        (eval '(let ((x (make <class-struct>
 158                          #:foo 'hello
 159                          #:bar 'world)))
 160                 (and (struct? x)
 161                      (eq? (struct-ref x 0) 'hello)
 162                      (eq? (struct-ref x 1) 'world)))
 163              (current-module)))
 164
 165      (pass-if "interaction with `struct-set!'"
 166        (eval '(define-class <class-struct-2> ()
 167                 (foo) (bar))
 168              (current-module))
 169        (eval '(let ((x (make <class-struct-2>)))
 170                 (struct-set! x 0 'hello)
 171                 (struct-set! x 1 'world)
 172                 (and (struct? x)
 173                      (eq? (struct-ref x 0) 'hello)
 174                      (eq? (struct-ref x 1) 'world)))
 175              (current-module)))))
 176
 177 (with-test-prefix "defining generics"
 178
 179   (with-test-prefix "define-generic"
 180
 181     (pass-if "creating a new top-level binding"
 182       (if (eval '(defined? 'foo-0) (current-module))
 183           (throw 'unresolved))
 184       (eval '(define-generic foo-0) (current-module))
 185       (eval '(and (is-a? foo-0 <generic>)
 186                   (null? (generic-function-methods foo-0)))
 187             (current-module)))
 188
 189     (pass-if "overwriting a top-level binding to a non-generic"
 190       (eval '(define (foo) #f) (current-module))
 191       (eval '(define-generic foo) (current-module))
 192       (eval '(and (is-a? foo <generic>)
 193                   (= 1 (length (generic-function-methods foo))))
 194             (current-module)))
 195
 196     (pass-if "overwriting a top-level binding to a generic"
 197       (eval '(define (foo) #f) (current-module))
 198       (eval '(define-generic foo) (current-module))
 199       (eval '(define-generic foo) (current-module))
 200       (eval '(and (is-a? foo <generic>)
 201                   (null? (generic-function-methods foo)))
 202             (current-module)))))
 203
 204 (with-test-prefix "defining methods"
 205
 206   (pass-if "define-method"
 207     (let ((m (current-module)))
 208       (eval '(define-method (my-plus (s1 <string>) (s2 <string>))
 209                (string-append s1 s2))
 210             m)
 211       (eval '(define-method (my-plus (i1 <integer>) (i2 <integer>))
 212                (+ i1 i2))
 213             m)
 214       (eval '(and (is-a? my-plus <generic>)
 215                   (= (length (generic-function-methods my-plus))
 216                      2))
 217             m)))
 218
 219   (pass-if "method-more-specific?"
 220     (eval '(let* ((m+        (generic-function-methods my-plus))
 221                   (m1        (car m+))
 222                   (m2        (cadr m+))
 223                   (arg-types (list <string> <string>)))
 224              (if (memq <string> (method-specializers m1))
 225                  (method-more-specific? m1 m2 arg-types)
 226                  (method-more-specific? m2 m1 arg-types)))
 227           (current-module)))
 228
 229   (pass-if-exception "method-more-specific? (failure)"
 230                      exception:wrong-type-arg
 231     (eval '(let* ((m+ (generic-function-methods my-plus))
 232                   (m1 (car m+))
 233                   (m2 (cadr m+)))
 234              (method-more-specific? m1 m2 '()))
 235           (current-module))))
 236
 237 (with-test-prefix "defining accessors"
 238
 239   (with-test-prefix "define-accessor"
 240
 241     (pass-if "creating a new top-level binding"
 242       (if (eval '(defined? 'foo-1) (current-module))
 243           (throw 'unresolved))
 244       (eval '(define-accessor foo-1) (current-module))
 245       (eval '(and (is-a? foo-1 <generic-with-setter>)
 246                   (null? (generic-function-methods foo-1)))
 247             (current-module)))
 248
 249     (pass-if "overwriting a top-level binding to a non-accessor"
 250       (eval '(define (foo) #f) (current-module))
 251       (eval '(define-accessor foo) (current-module))
 252       (eval '(and (is-a? foo <generic-with-setter>)
 253                   (= 1 (length (generic-function-methods foo))))
 254             (current-module)))
 255
 256     (pass-if "overwriting a top-level binding to an accessor"
 257       (eval '(define (foo) #f) (current-module))
 258       (eval '(define-accessor foo) (current-module))
 259       (eval '(define-accessor foo) (current-module))
 260       (eval '(and (is-a? foo <generic-with-setter>)
 261                   (null? (generic-function-methods foo)))
 262             (current-module)))))
 263
 264 (with-test-prefix "object update"
 265   (pass-if "defining class"
 266     (eval '(define-class <foo> ()
 267              (x #:accessor x #:init-value 123)
 268              (z #:accessor z #:init-value 789))
 269           (current-module))
 270     (eval '(is-a? <foo> <class>) (current-module)))
 271   (pass-if "making instance"
 272     (eval '(define foo (make <foo>)) (current-module))
 273     (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module)))
 274   (pass-if "redefining class"
 275     (eval '(define-class <foo> ()
 276              (x #:accessor x #:init-value 123)
 277              (y #:accessor y #:init-value 456)
 278              (z #:accessor z #:init-value 789))
 279           (current-module))
 280     (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))))
 281
 282 (with-test-prefix "object comparison"
 283   (pass-if "default method"
 284            (eval '(begin
 285                     (define-class <c> ()
 286                       (x #:accessor x #:init-keyword #:x)
 287                       (y #:accessor y #:init-keyword #:y))
 288                     (define o1 (make <c> #:x '(1) #:y '(2)))
 289                     (define o2 (make <c> #:x '(1) #:y '(3)))
 290                     (define o3 (make <c> #:x '(4) #:y '(3)))
 291                     (define o4 (make <c> #:x '(4) #:y '(3)))
 292                     (not (eqv? o1 o2)))
 293                  (current-module)))
 294   (pass-if "eqv?"
 295            (eval '(begin
 296                     (define-method (eqv? (a <c>) (b <c>))
 297                       (equal? (x a) (x b)))
 298                     (eqv? o1 o2))
 299                  (current-module)))
 300   (pass-if "not eqv?"
 301            (eval '(not (eqv? o2 o3))
 302                  (current-module)))
 303   (pass-if "transfer eqv? => equal?"
 304            (eval '(equal? o1 o2)
 305                  (current-module)))
 306   (pass-if "equal?"
 307            (eval '(begin
 308                     (define-method (equal? (a <c>) (b <c>))
 309                       (equal? (y a) (y b)))
 310                     (equal? o2 o3))
 311                  (current-module)))
 312   (pass-if "not equal?"
 313            (eval '(not (equal? o1 o2))
 314                  (current-module)))
 315   (pass-if "="
 316            (eval '(begin
 317                     (define-method (= (a <c>) (b <c>))
 318                       (and (equal? (x a) (x b))
 319                            (equal? (y a) (y b))))
 320                     (= o3 o4))
 321                  (current-module)))
 322   (pass-if "not ="
 323            (eval '(not (= o1 o2))
 324                  (current-module)))
 325   )
 326
 327 (use-modules (oop goops active-slot))
 328
 329 (with-test-prefix "active-slot"
 330   (pass-if "defining class with active slot"
 331     (eval '(begin
 332              (define z '())
 333              (define-class <bar> ()
 334                (x #:accessor x
 335                   #:init-value 1
 336                   #:allocation #:active
 337                   #:before-slot-ref
 338                   (lambda (o)
 339                     (set! z (cons 'before-ref z))
 340                     #t)
 341                   #:after-slot-ref
 342                   (lambda (o)
 343                     (set! z (cons 'after-ref z)))
 344                   #:before-slot-set!
 345                   (lambda (o v)
 346                     (set! z (cons* v 'before-set! z)))
 347                   #:after-slot-set!
 348                   (lambda (o v)
 349                     (set! z (cons* v (x o) 'after-set! z))))
 350                #:metaclass <active-class>)
 351              (define bar (make <bar>))
 352              (x bar)
 353              (set! (x bar) 2)
 354              (equal? (reverse z)
 355                      '(before-ref before-set! 1 before-ref after-ref
 356                        after-set! 1 1 before-ref after-ref
 357                        before-set! 2 before-ref after-ref after-set! 2 2)))
 358           (current-module))))
 359
 360 (use-modules (oop goops composite-slot))
 361
 362 (with-test-prefix "composite-slot"
 363   (pass-if "creating instance with propagated slot"
 364     (eval '(begin
 365              (define-class <a> ()
 366                (x #:accessor x #:init-keyword #:x)
 367                (y #:accessor y #:init-keyword #:y))
 368              (define-class <c> ()
 369                (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2))
 370                (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4))
 371                (x #:accessor x
 372                   #:allocation #:propagated
 373                   #:propagate-to '(o1 (o2 y)))
 374                #:metaclass <composite-class>)
 375              (define o (make <c>))
 376              (is-a? o <c>))
 377           (current-module)))
 378   (pass-if "reading propagated slot"
 379            (eval '(= (x o) 1) (current-module)))
 380   (pass-if "writing propagated slot"
 381            (eval '(begin
 382                     (set! (x o) 5)
 383                     (and (= (x (o1 o)) 5)
 384                          (= (y (o1 o)) 2)
 385                          (= (x (o2 o)) 3)
 386                          (= (y (o2 o)) 5)))
 387                  (current-module))))