test-suite/tests/goops.test

   1 ;;;; goops.test --- test suite for GOOPS                      -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2001, 2003 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., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19
  20 (use-modules (test-suite lib))
  21
  22 (pass-if "GOOPS loads"
  23          (false-if-exception
  24           (begin (resolve-module '(oop goops))
  25                  #t)))
  26
  27 (use-modules (oop goops))
  28
  29 ;;; more tests here...
  30
  31 (with-test-prefix "basic classes"
  32
  33   (with-test-prefix "<top>"
  34
  35     (pass-if "instance?"
  36       (instance? <top>))
  37
  38     (pass-if "class-of"
  39       (eq? (class-of <top>) <class>))
  40
  41     (pass-if "is a class?"
  42       (is-a? <top> <class>))
  43
  44     (pass-if "class-name"
  45       (eq? (class-name <top>) '<top>))
  46
  47     (pass-if "direct superclasses"
  48       (equal? (class-direct-supers <top>) '()))
  49
  50     (pass-if "superclasses"
  51       (equal? (class-precedence-list <top>) (list <top>)))
  52
  53     (pass-if "direct slots"
  54       (equal? (class-direct-slots <top>) '()))
  55
  56     (pass-if "slots"
  57       (equal? (class-slots <top>) '())))
  58
  59   (with-test-prefix "<object>"
  60
  61     (pass-if "instance?"
  62       (instance? <object>))
  63
  64     (pass-if "class-of"
  65       (eq? (class-of <object>) <class>))
  66
  67     (pass-if "is a class?"
  68       (is-a? <object> <class>))
  69
  70     (pass-if "class-name"
  71       (eq? (class-name <object>) '<object>))
  72
  73     (pass-if "direct superclasses"
  74       (equal? (class-direct-supers <object>) (list <top>)))
  75
  76     (pass-if "superclasses"
  77       (equal? (class-precedence-list <object>) (list <object> <top>)))
  78
  79     (pass-if "direct slots"
  80       (equal? (class-direct-slots <object>) '()))
  81
  82     (pass-if "slots"
  83       (equal? (class-slots <object>) '())))
  84
  85   (with-test-prefix "<class>"
  86
  87     (pass-if "instance?"
  88       (instance? <class>))
  89
  90     (pass-if "class-of"
  91       (eq? (class-of <class>) <class>))
  92
  93     (pass-if "is a class?"
  94       (is-a? <class> <class>))
  95
  96     (pass-if "class-name"
  97       (eq? (class-name <class>) '<class>))
  98
  99     (pass-if "direct superclass"
 100       (equal? (class-direct-supers <class>) (list <object>))))
 101
 102   (with-test-prefix "class-precedence-list"
 103     (for-each (lambda (class)
 104                 (run-test (if (slot-bound? class 'name)
 105                               (class-name class)
 106                               (with-output-to-string
 107                                 (lambda ()
 108                                   (display class))))
 109                           #t
 110                           (lambda ()
 111                             (catch #t
 112                                    (lambda ()
 113                                      (equal? (class-precedence-list class)
 114                                              (compute-cpl class)))
 115                                    (lambda args #t)))))
 116               (let ((table (make-hash-table)))
 117                 (let rec ((class <top>))
 118                   (hash-create-handle! table class #f)
 119                   (for-each rec (class-direct-subclasses class)))
 120                 (hash-fold (lambda (class ignore classes)
 121                              (cons class classes))
 122                            '()
 123                            table))))
 124   )
 125
 126 (with-test-prefix "defining classes"
 127
 128   (with-test-prefix "define-class"
 129
 130     (pass-if "creating a new binding"
 131       (eval '(define <foo> #f) (current-module))
 132       (eval '(undefine <foo>) (current-module))
 133       (eval '(define-class <foo> ()) (current-module))
 134       (eval '(is-a? <foo> <class>) (current-module)))
 135
 136     (pass-if "overwriting a binding to a non-class"
 137       (eval '(define <foo> #f) (current-module))
 138       (eval '(define-class <foo> ()) (current-module))
 139       (eval '(is-a? <foo> <class>) (current-module)))))
 140
 141 (with-test-prefix "defining generics"
 142
 143   (with-test-prefix "define-generic"
 144
 145     (pass-if "creating a new top-level binding"
 146       (eval '(define foo #f) (current-module))
 147       (eval '(undefine foo) (current-module))
 148       (eval '(define-generic foo) (current-module))
 149       (eval '(and (is-a? foo <generic>)
 150                   (null? (generic-function-methods foo)))
 151             (current-module)))
 152
 153     (pass-if "overwriting a top-level binding to a non-generic"
 154       (eval '(define (foo) #f) (current-module))
 155       (eval '(define-generic foo) (current-module))
 156       (eval '(and (is-a? foo <generic>)
 157                   (= 1 (length (generic-function-methods foo))))
 158             (current-module)))
 159
 160     (pass-if "overwriting a top-level binding to a generic"
 161       (eval '(define (foo) #f) (current-module))
 162       (eval '(define-generic foo) (current-module))
 163       (eval '(define-generic foo) (current-module))
 164       (eval '(and (is-a? foo <generic>)
 165                   (null? (generic-function-methods foo)))
 166             (current-module)))))
 167
 168 (with-test-prefix "defining accessors"
 169
 170   (with-test-prefix "define-accessor"
 171
 172     (pass-if "creating a new top-level binding"
 173       (eval '(define foo #f) (current-module))
 174       (eval '(undefine foo) (current-module))
 175       (eval '(define-accessor foo) (current-module))
 176       (eval '(and (is-a? foo <generic-with-setter>)
 177                   (null? (generic-function-methods foo)))
 178             (current-module)))
 179
 180     (pass-if "overwriting a top-level binding to a non-accessor"
 181       (eval '(define (foo) #f) (current-module))
 182       (eval '(define-accessor foo) (current-module))
 183       (eval '(and (is-a? foo <generic-with-setter>)
 184                   (= 1 (length (generic-function-methods foo))))
 185             (current-module)))
 186
 187     (pass-if "overwriting a top-level binding to an accessor"
 188       (eval '(define (foo) #f) (current-module))
 189       (eval '(define-accessor foo) (current-module))
 190       (eval '(define-accessor foo) (current-module))
 191       (eval '(and (is-a? foo <generic-with-setter>)
 192                   (null? (generic-function-methods foo)))
 193             (current-module)))))
 194
 195 (with-test-prefix "object update"
 196   (pass-if "defining class"
 197     (eval '(define-class <foo> ()
 198              (x #:accessor x #:init-value 123)
 199              (z #:accessor z #:init-value 789))
 200           (current-module))
 201     (eval '(is-a? <foo> <class>) (current-module)))
 202   (pass-if "making instance"
 203     (eval '(define foo (make <foo>)) (current-module))
 204     (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module)))
 205   (pass-if "redefining class"
 206     (eval '(define-class <foo> ()
 207              (x #:accessor x #:init-value 123)
 208              (y #:accessor y #:init-value 456)
 209              (z #:accessor z #:init-value 789))
 210           (current-module))
 211     (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))))
 212
 213 (with-test-prefix "equal?"
 214   (pass-if "equal"
 215            (eval '(begin
 216                     (define-class <c> ()
 217                       (x #:accessor x #:init-keyword #:x)
 218                       (y #:accessor y #:init-keyword #:y))
 219                     (define-method (equal? (a <c>) (b <c>))
 220                       (equal? (y a) (y b)))
 221                     (define o1 (make <c> #:x '(1) #:y '(3)))
 222                     (define o2 (make <c> #:x '(2) #:y '(3)))
 223                     (define o3 (make <c> #:x '(2) #:y '(4)))
 224                     (equal? o1 o2))
 225                  (current-module)))
 226   (pass-if "not equal"
 227            (eval '(not (equal? o2 o3))
 228                  (current-module))))
 229
 230 (use-modules (oop goops active-slot))
 231
 232 (with-test-prefix "active-slot"
 233   (pass-if "defining class with active slot"
 234     (eval '(begin
 235              (define z '())
 236              (define-class <bar> ()
 237                (x #:accessor x
 238                   #:init-value 1
 239                   #:allocation #:active
 240                   #:before-slot-ref
 241                   (lambda (o)
 242                     (set! z (cons 'before-ref z))
 243                     #t)
 244                   #:after-slot-ref
 245                   (lambda (o)
 246                     (set! z (cons 'after-ref z)))
 247                   #:before-slot-set!
 248                   (lambda (o v)
 249                     (set! z (cons* v 'before-set! z)))
 250                   #:after-slot-set!
 251                   (lambda (o v)
 252                     (set! z (cons* v (x o) 'after-set! z))))
 253                #:metaclass <active-class>)
 254              (define bar (make <bar>))
 255              (x bar)
 256              (set! (x bar) 2)
 257              (equal? (reverse z)
 258                      '(before-ref before-set! 1 before-ref after-ref
 259                        after-set! 1 1 before-ref after-ref
 260                        before-set! 2 before-ref after-ref after-set! 2 2)))
 261           (current-module))))
 262