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