;;;; goops.test --- test suite for GOOPS -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014, 2015 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:use-module (test-suite lib)
#:autoload (srfi srfi-1) (unfold))
+(define exception:no-applicable-method
+ '(goops-error . "^No applicable method"))
+
(pass-if "GOOPS loads"
(false-if-exception
(begin (resolve-module '(oop goops))
(pass-if "struct vtable"
;; Previously, `class-of' would fail for nameless structs, i.e., structs
;; for which `struct-vtable-name' is #f.
- (is-a? (class-of (make-vtable-vtable "prprpr" 0)) <class>)))
+ (is-a? (class-of (make-vtable
+ (string-append standard-vtable-fields "prprpr")))
+ <class>)))
(with-test-prefix "defining classes"
(eval '(define-class <foo> ()) (current-module))
(eval '(is-a? <foo> <class>) (current-module)))
- (expect-fail "bad init-thunk"
- (catch #t
- (lambda ()
- (eval '(define-class <foo> ()
- (x #:init-thunk (lambda (x) 1)))
- (current-module))
- #t)
- (lambda args
- #f)))
+ (pass-if "bad init-thunk"
+ (catch #t
+ (lambda ()
+ (eval '(define-class <foo> ()
+ (x #:init-thunk (lambda (x) 1)))
+ (current-module))
+ #f)
+ (lambda args
+ #t)))
(pass-if "interaction with `struct-ref'"
(eval '(define-class <class-struct> ()
(x #:accessor x #:init-value 123)
(z #:accessor z #:init-value 789))
(current-module))
- (eval '(equal? (x (make <qux>)) 123) (current-module)))))
-
+ (eval '(equal? (x (make <qux>)) 123) (current-module)))
+
+ (pass-if-exception "cannot redefine fields of <class>"
+ '(misc-error . "cannot be redefined")
+ (eval '(begin
+ (define-class <test-class> (<class>)
+ name)
+ (make <test-class>))
+ (current-module)))))
(with-test-prefix "defining generics"
(eval '(define-generic foo) (current-module))
(eval '(and (is-a? foo <generic>)
(null? (generic-function-methods foo)))
- (current-module)))))
+ (current-module)))
+
+ (pass-if-exception "getters do not have setters"
+ exception:wrong-type-arg
+ (eval '(setter foo) (current-module)))))
(with-test-prefix "defining methods"
(null? (generic-function-methods foo-1)))
(current-module)))
+ (pass-if "accessors have setters"
+ (procedure? (eval '(setter foo-1) (current-module))))
+
(pass-if "overwriting a top-level binding to a non-accessor"
(eval '(define (foo) #f) (current-module))
(eval '(define-accessor foo) (current-module))
(define o4 (make <c> #:x '(4) #:y '(3)))
(not (eqv? o1 o2)))
(current-module)))
- (pass-if "eqv?"
- (eval '(begin
- (define-method (eqv? (a <c>) (b <c>))
- (equal? (x a) (x b)))
- (eqv? o1 o2))
- (current-module)))
- (pass-if "not eqv?"
- (eval '(not (eqv? o2 o3))
- (current-module)))
- (pass-if "transfer eqv? => equal?"
- (eval '(equal? o1 o2)
- (current-module)))
(pass-if "equal?"
(eval '(begin
(define-method (equal? (a <c>) (b <c>))
(x bar)
(set! (x bar) 2)
(equal? (reverse z)
- '(before-ref before-set! 1 before-ref after-ref
- after-set! 1 1 before-ref after-ref
- before-set! 2 before-ref after-ref after-set! 2 2)))
+ '(before-set! 1 before-ref after-ref
+ after-set! 1 1 before-ref after-ref
+ before-set! 2 before-ref after-ref after-set! 2 2)))
(current-module))))
(use-modules (oop goops composite-slot))
(= (x (o2 o)) 3)
(= (y (o2 o)) 5)))
(current-module))))
+
+(with-test-prefix "no-applicable-method"
+ (pass-if-exception "calling generic, no methods"
+ exception:no-applicable-method
+ (eval '(begin
+ (define-class <qux> ())
+ (define-generic quxy)
+ (quxy 1))
+ (current-module)))
+ (pass-if "calling generic, one method, applicable"
+ (eval '(begin
+ (define-method (quxy (q <qux>))
+ #t)
+ (define q (make <qux>))
+ (quxy q))
+ (current-module)))
+ (pass-if-exception "calling generic, one method, not applicable"
+ exception:no-applicable-method
+ (eval '(quxy 1)
+ (current-module))))
+
+(with-test-prefix "foreign slots"
+ (define-class <foreign-test> ()
+ (a #:init-keyword #:a #:class <foreign-slot>
+ #:accessor test-a)
+ (b #:init-keyword #:b #:init-form 3 #:class <foreign-slot>
+ #:accessor test-b))
+
+ (pass-if-equal "constructing, no initargs"
+ '(0 3)
+ (let ((x (make <foreign-test>)))
+ (list (slot-ref x 'a)
+ (slot-ref x 'b))))
+
+ (pass-if-equal "constructing, initargs"
+ '(1 2)
+ (let ((x (make <foreign-test> #:a 1 #:b 2)))
+ (list (slot-ref x 'a)
+ (slot-ref x 'b))))
+
+ (pass-if-equal "getters"
+ '(0 3)
+ (let ((x (make <foreign-test>)))
+ (list (test-a x) (test-b x))))
+
+ (pass-if-equal "setters"
+ '(10 20)
+ (let ((x (make <foreign-test>)))
+ (set! (test-a x) 10)
+ (set! (test-b x) 20)
+ (list (test-a x) (test-b x))))
+
+ (pass-if-exception "out of range"
+ exception:out-of-range
+ (make <foreign-test> #:a (ash 1 64))))
+
+(with-test-prefix "#:each-subclass"
+ (let* ((<subclass-allocation-test>
+ (class ()
+ (test #:init-value '() #:allocation #:each-subclass)
+ #:name '<subclass-allocation-test>))
+ (a (make <subclass-allocation-test>)))
+ (pass-if-equal '() (slot-ref a 'test))
+ (let ((b (make <subclass-allocation-test>)))
+ (pass-if-equal '() (slot-ref b 'test))
+ (slot-set! a 'test 100)
+ (pass-if-equal 100 (slot-ref a 'test))
+ (pass-if-equal 100 (slot-ref b 'test))
+
+ ;; #:init-value of the class shouldn't reinitialize slot when
+ ;; instances are allocated.
+ (make <subclass-allocation-test>)
+
+ (pass-if-equal 100 (slot-ref a 'test))
+ (pass-if-equal 100 (slot-ref b 'test))
+
+ (let ((<test-subclass>
+ (class (<subclass-allocation-test>))))
+ (pass-if-equal 100 (slot-ref a 'test))
+ (pass-if-equal 100 (slot-ref b 'test))
+ (let ((c (make <test-subclass>)))
+ (pass-if-equal 100 (slot-ref a 'test))
+ (pass-if-equal 100 (slot-ref b 'test))
+ (pass-if-equal '() (slot-ref c 'test))
+ (slot-set! c 'test 200)
+ (pass-if-equal 200 (slot-ref c 'test))
+
+ (make <test-subclass>)
+
+ (pass-if-equal 100 (slot-ref a 'test))
+ (pass-if-equal 100 (slot-ref b 'test))
+ (pass-if-equal 200 (slot-ref c 'test)))))))
+
+(define-class <food> ())
+(define-class <fruit> (<food>))
+(define-class <spice> (<food>))
+(define-class <apple> (<fruit>))
+(define-class <cinnamon> (<spice>))
+(define-class <pie> (<apple> <cinnamon>))
+
+(define-class <d> ())
+(define-class <e> ())
+(define-class <f> ())
+(define-class <b> (<d> <e>))
+(define-class <c> (<e> <f>))
+(define-class <a> (<b> <c>))
+
+(with-test-prefix "compute-cpl"
+ (pass-if-equal "<pie>"
+ (list <pie> <apple> <fruit> <cinnamon> <spice> <food> <object> <top>)
+ (compute-cpl <pie>))
+
+ (pass-if-equal "<a>"
+ (list <a> <b> <d> <c> <e> <f> <object> <top>)
+ (compute-cpl <a>)))
+
+(with-test-prefix "accessor slots"
+ (let* ((a-accessor (make-accessor 'a))
+ (b-accessor (make-accessor 'b))
+ (<a> (class ()
+ (a #:init-keyword #:a #:accessor a-accessor)
+ #:name '<a>))
+ (<b> (class ()
+ (b #:init-keyword #:b #:accessor b-accessor)
+ #:name '<b>))
+ (<ab> (class (<a> <b>) #:name '<ab>))
+ (<ba> (class (<b> <a>) #:name '<ba>))
+ (<cab> (class (<ab>)
+ (a #:init-keyword #:a)
+ #:name '<cab>))
+ (<cba> (class (<ba>)
+ (a #:init-keyword #:a)
+ #:name '<cba>))
+ (a (make <a> #:a 'a))
+ (b (make <b> #:b 'b))
+ (ab (make <ab> #:a 'a #:b 'b))
+ (ba (make <ba> #:a 'a #:b 'b))
+ (cab (make <cab> #:a 'a #:b 'b))
+ (cba (make <cba> #:a 'a #:b 'b)))
+ (pass-if-equal "a accessor on a" 'a (a-accessor a))
+ (pass-if-equal "a accessor on ab" 'a (a-accessor ab))
+ (pass-if-equal "a accessor on ba" 'a (a-accessor ba))
+ (pass-if-exception "a accessor on cab" exception:no-applicable-method
+ (a-accessor cab))
+ (pass-if-exception "a accessor on cba" exception:no-applicable-method
+ (a-accessor cba))
+ (pass-if-equal "b accessor on a" 'b (b-accessor b))
+ (pass-if-equal "b accessor on ab" 'b (b-accessor ab))
+ (pass-if-equal "b accessor on ba" 'b (b-accessor ba))
+ (pass-if-equal "b accessor on cab" 'b (b-accessor cab))
+ (pass-if-equal "b accessor on cba" 'b (b-accessor cba))))
HCoop / bpt / guile.git / blobdiff