1: ;;
    2: ;; Test object system
    3: ;;
    4: 
    5: ;; $Id: object.scm,v 1.39 2007/01/14 09:22:59 shirok Exp $
    6: 
    7: (use gauche.test)
    8: 
    9: (test-start "object system")
   10: 
   11: ;;----------------------------------------------------------------
   12: (test-section "class definition")
   13: 
   14: (define-class <x> () (a b c))
   15: (test* "define-class <x>" '<x> (class-name <x>))
   16: (test* "define-class <x>" 3 (slot-ref <x> 'num-instance-slots))
   17: (test* "define-class <x>" <class> (class-of <x>))
   18: (test* "define-class <x>" '(<x> <object> <top>)
   19:        (map class-name (class-precedence-list <x>)))
   20: 
   21: (define-class <y> (<x>) (c d e))
   22: (test* "define-class <y>" 5 (slot-ref <y> 'num-instance-slots))
   23: (test* "define-class <y>" <class> (class-of <y>))
   24: (test* "define-class <y>" '(<y> <x> <object> <top>)
   25:        (map class-name (class-precedence-list <y>)))
   26: 
   27: (define-class <z> (<object>) ())
   28: (test* "define-class <z>" 0 (slot-ref <z> 'num-instance-slots))
   29: (test* "define-class <z>" <class> (class-of <z>))
   30: (test* "define-class <z>" '(<z> <object> <top>)
   31:        (map class-name (class-precedence-list <z>)))
   32: 
   33: (define-class <w> (<z> <y>) (e f))
   34: (test* "define-class <w>" 6 (slot-ref <w> 'num-instance-slots))
   35: (test* "define-class <w>" <class> (class-of <w>))
   36: (test* "define-class <w>" '(<w> <z> <y> <x> <object> <top>)
   37:        (map class-name (class-precedence-list <w>)))
   38: 
   39: (define-class <w2> (<y> <z>) (e f))
   40: (test* "define-class <w2>" '(<w2> <y> <x> <z> <object> <top>)
   41:        (map class-name (class-precedence-list <w2>)))
   42: 
   43: ;;----------------------------------------------------------------
   44: (test-section "instancing")
   45: 
   46: (define x1 (make <x>))
   47: (define x2 (make <x>))
   48: 
   49: (test* "make <x>" <x> (class-of x1))
   50: (test* "make <x>" <x> (class-of x2))
   51: 
   52: (slot-set! x1 'a 4)
   53: (slot-set! x1 'b 5)
   54: (slot-set! x1 'c 6)
   55: (slot-set! x2 'a 7)
   56: (slot-set! x2 'b 8)
   57: (slot-set! x2 'c 9)
   58: 
   59: (test* "slot-ref" '(4 5 6) (map (lambda (slot) (slot-ref x1 slot)) '(a b c)))
   60: (test* "slot-ref" '(7 8 9) (map (lambda (slot) (slot-ref x2 slot)) '(a b c)))
   61: 
   62: (test* "slot-ref-using-class" '(4 5 6)
   63:        (map (lambda (slot) (slot-ref-using-class <x> x1 slot)) '(a b c)))
   64: (test* "slot-ref-using-class" *test-error*
   65:        (slot-ref-using-class <y> x1 'a))
   66: 
   67: (test* "slot-ref-using-accessor" '(7 8 9)
   68:        (map (lambda (slot)
   69:               (let ((sa (class-slot-accessor <x> slot)))
   70:                 (and sa (slot-ref-using-accessor x2 sa))))
   71:             '(a b c)))
   72: (test* "slot-ref-using-accessor" *test-error*
   73:        (let ((sa (class-slot-accessor <y> slot)))
   74:          (and sa (slot-ref-using-accessor x2 sa))))
   75: 
   76: (test* "slot-set-using-class!" '(-4 -5 -6)
   77:        (map (lambda (slot)
   78:               (slot-set-using-class! <x> x1 slot
   79:                                      (- (slot-ref x1 slot)))
   80:               (slot-ref x1 slot))
   81:             '(a b c)))
   82: (test* "slot-set-using-class!" *test-error*
   83:        (slot-set-using-class! <y> x1 'a 3))
   84: 
   85: (test* "slot-set-using-accessor!" '(-7 -8 -9)
   86:        (map (lambda (slot)
   87:               (let ((sa (class-slot-accessor <x> slot)))
   88:                 (and sa
   89:                      (slot-set-using-accessor! x2 sa (- (slot-ref x2 slot)))))
   90:               (slot-ref x2 slot))
   91:             '(a b c)))
   92: (test* "slot-ref-using-accessor!" *test-error*
   93:        (let ((sa (class-slot-accessor <y> slot)))
   94:          (and sa (slot-set-using-accessor! x2 sa -1))))
   95: 
   96: ;;----------------------------------------------------------------
   97: (test-section "slot initialization")
   98: 
   99: (define-class <r> ()
  100:   ((a :init-keyword :a :initform 4)
  101:    (b :init-keyword :b :init-value 5)))
  102: 
  103: (define r1 (make <r>))
  104: (define r2 (make <r> :a 9))
  105: (define r3 (make <r> :b 100 :a 20))
  106: 
  107: (define-method slot-values ((obj <r>))
  108:   (map (lambda (s) (slot-ref obj s)) '(a b)))
  109: 
  110: (test* "make <r>" '(4 5) (slot-values r1))
  111: (test* "make <r> :a" '(9 5) (slot-values r2))
  112: (test* "make <r> :a :b" '(20 100) (slot-values r3))
  113: 
  114: ;;----------------------------------------------------------------
  115: (test-section "slot allocations")
  116: 
  117: (define-class <s> ()
  118:   ((i :allocation :instance      :init-keyword :i :init-value #\i)
  119:    (c :allocation :class         :init-keyword :c :init-value #\c)
  120:    (s :allocation :each-subclass :init-keyword :s :init-value #\s)
  121:    (v :allocation :virtual       :init-keyword :v
  122:       :slot-ref (lambda (o) (cons (slot-ref o 'i) (slot-ref o 'c)))
  123:       :slot-set! (lambda (o v)
  124:                    (slot-set! o 'i (car v))
  125:                    (slot-set! o 'c (cdr v))))
  126:    ))
  127: 
  128: (define-method slot-values ((obj <s>))
  129:   (map (lambda (s) (slot-ref obj s)) '(i c s v)))
  130: 
  131: (define s1 (make <s>))
  132: (define s2 (make <s>))
  133: 
  134: (test* "make <s>" '(#\i #\c #\s (#\i . #\c)) (slot-values s1))
  135: (test* "slot-set! :instance"
  136:        '((#\I #\c #\s (#\I . #\c)) (#\i #\c #\s (#\i . #\c)))
  137:        (begin
  138:          (slot-set! s1 'i #\I)
  139:          (list (slot-values s1) (slot-values s2))))
  140: (test* "slot-set! :class"
  141:        '((#\I #\C #\s (#\I . #\C)) (#\i #\C #\s (#\i . #\C)))
  142:        (begin
  143:          (slot-set! s1 'c #\C)
  144:          (list (slot-values s1) (slot-values s2))))
  145: (test* "slot-set! :each-subclass"
  146:        '((#\I #\C #\S (#\I . #\C)) (#\i #\C #\S (#\i . #\C)))
  147:        (begin
  148:          (slot-set! s1 's #\S)
  149:          (list (slot-values s1) (slot-values s2))))
  150: (test* "slot-set! :virtual"
  151:        '((i c #\S (i . c)) (#\i c #\S (#\i . c)))
  152:        (begin
  153:          (slot-set! s1 'v '(i . c))
  154:          (list (slot-values s1) (slot-values s2))))
  155: 
  156: (define-class <ss> (<s>)
  157:   ())
  158: 
  159: (define s3 (make <ss> :i "i" :c "c" :s "s"))
  160: 
  161: (test* "make <ss>"
  162:        '(("i" "c" "s" ("i" . "c")) (i "c" #\S (i . "c")))
  163:        (list (slot-values s3) (slot-values s1)))
  164: (test* "slot-set! :class"
  165:        '(("i" "C" "s" ("i" . "C")) (i "C" #\S (i . "C")))
  166:        (begin
  167:          (slot-set! s3 'c "C")
  168:          (list (slot-values s3) (slot-values s1))))
  169: (test* "slot-set! :each-subclass"
  170:        '(("i" "C" "s" ("i" . "C")) (i "C" "S" (i . "C")))
  171:        (begin
  172:          (slot-set! s1 's "S")
  173:          (list (slot-values s3) (slot-values s1))))
  174: (test* "slot-set! :each-subclass"
  175:        '(("i" "C" 5 ("i" . "C")) (i "C" "S" (i . "C")))
  176:        (begin
  177:          (slot-set! s3 's 5)
  178:          (list (slot-values s3) (slot-values s1))))
  179: 
  180: (define s4 (make <ss> :v '(1 . 0)))
  181: 
  182: (test* "make <ss> :v"
  183:        '((1 0 5 (1 . 0)) ("i" 0 5 ("i" . 0)))
  184:        (list (slot-values s4) (slot-values s3)))
  185: 
  186: (test* "class-slot-ref"
  187:        '(0 "S" 0 5)
  188:        (list (class-slot-ref <s> 'c)  (class-slot-ref <s> 's)
  189:              (class-slot-ref <ss> 'c) (class-slot-ref <ss> 's)))
  190: (test* "class-slot-set!"
  191:        '(100 99 100 5)
  192:        (begin
  193:          (class-slot-set! <s> 'c 100)
  194:          (class-slot-set! <s> 's 99)
  195:          (list (class-slot-ref <s> 'c)  (class-slot-ref <s> 's)
  196:                (class-slot-ref <ss> 'c) (class-slot-ref <ss> 's))))
  197: (test* "class-slot-set!"
  198:        '(101 99 101 55)
  199:        (begin
  200:          (class-slot-set! <ss> 'c 101)
  201:          (class-slot-set! <ss> 's 55)
  202:          (list (class-slot-ref <s> 'c)  (class-slot-ref <s> 's)
  203:                (class-slot-ref <ss> 'c) (class-slot-ref <ss> 's))))
  204: 
  205: (define-class <sss> ()
  206:   ((v :allocation :virtual
  207:       :slot-ref  (lambda (o) (slot-ref o 'vv))
  208:       :slot-set! (lambda (o v) (slot-set! o 'vv v))
  209:       :slot-bound? (lambda (o) (slot-bound? o 'vv)))
  210:    vv))
  211: 
  212: (define s5 (make <sss>))
  213: 
  214: (test* "slot-bound? protocol" #f
  215:        (slot-bound? s5 'v))
  216: 
  217: (test* "slot-bound? protocol" '(#t 8)
  218:        (begin (slot-set! s5 'v 8)
  219:               (list (slot-bound? s5 'v)
  220:                     (slot-ref s5 'v))))
  221: 
  222: ;;----------------------------------------------------------------
  223: (test-section "next method")
  224: 
  225: (define (nm obj) 'fallback)
  226: 
  227: (define-method nm ((obj <x>))  (list 'x-in (next-method) 'x-out))
  228: (define-method nm ((obj <y>))  (list 'y-in (next-method) 'y-out))
  229: (define-method nm ((obj <z>))  (list 'z-in (next-method) 'z-out))
  230: (define-method nm ((obj <w>))  (list 'w-in (next-method) 'w-out))
  231: (define-method nm ((obj <w2>))  (list 'w2-in (next-method) 'w2-out))
  232: 
  233: (test* "next method"
  234:        '(y-in (x-in fallback x-out) y-out)
  235:        (nm (make <y>)))
  236: (test* "next-method"
  237:        '(w-in (z-in (y-in (x-in fallback x-out) y-out) z-out) w-out)
  238:        (nm (make <w>)))
  239: (test* "next-method"
  240:        '(w2-in (y-in (x-in (z-in fallback z-out) x-out) y-out) w2-out)
  241:        (nm (make <w2>)))
  242: 
  243: (define-method nm (obj . a)
  244:   (if (null? a) (list 't*-in (next-method) 't*-out) 't*))
  245: (define-method nm ((obj <y>) a) (list 'y1-in (next-method) 'y1-out))
  246: (define-method nm ((obj <y>) . a) (list 'y*-in (next-method) 'y*-out))
  247: 
  248: (test* "next-method"
  249:        '(y1-in (y*-in t* y*-out) y1-out)
  250:        (nm (make <y>) 3))
  251: (test* "next-method"
  252:        '(y-in (y*-in (x-in (t*-in fallback t*-out) x-out) y*-out) y-out)
  253:        (nm (make <y>)))
  254: 
  255: ;;----------------------------------------------------------------
  256: (test-section "method sorting")
  257: 
  258: ;; Corner cases of method sorting.
  259: 
  260: ;; 0.8.6 and before had a bug in method-more-specific? when both methods
  261: ;; had optional arg.
  262: (define-method ms-1 ((x <string>) . rest) 1)
  263: (define-method ms-1 rest 0)
  264: (define-method ms-1 ((x <string>) (y <string>) . rest) 2)
  265: 
  266: (test* "method sorting" 2 (ms-1 "a" "a"))
  267: (test* "method sorting" 1 (ms-1 "a"))
  268: 
  269: 
  270: ;;----------------------------------------------------------------
  271: (test-section "setter method definition")
  272: 
  273: (define-method s-get-i ((self <s>)) (slot-ref self 'i))
  274: (define-method (setter s-get-i) ((self <s>) v) (slot-set! self 'i v))
  275: (define-method (setter s-get-i) ((self <ss>) v) (slot-set! self 'i (cons v v)))
  276: 
  277: (test* "setter of s-get-i(<s>)" '("i" "j")
  278:        (let* ((s (make <s> :i "i"))
  279:               (i (s-get-i s))
  280:               (j (begin (set! (s-get-i s) "j") (s-get-i s))))
  281:          (list i j)))
  282: (test* "setter of s-get-i(<ss>)" '("i" ("j" . "j"))
  283:        (let* ((s (make <ss> :i "i"))
  284:               (i (s-get-i s))
  285:               (j (begin (set! (s-get-i s) "j") (s-get-i s))))
  286:          (list i j)))
  287: 
  288: ;;----------------------------------------------------------------
  289: (test-section "module and accessor")
  290: 
  291: ;; This test is a contrived example of the case where the
  292: ;; superclass has a slot with a getter method whose name isn't
  293: ;; exported.  Gauche 0.8.5 and before doesn't handle
  294: ;; this correctly, since the implicit accessor method of slot a
  295: ;; of <ma-class-2> defined in MA doesn't share the generic function
  296: ;; with MA.inner#ma-get.  Thus, in MA.inner#ma-method, (ma-get <ma-class-1>)
  297: ;; is called even when the passed object is <ma-class-2>.
  298: ;;
  299: ;; The root of the problem is the undesired interaction between
  300: ;; module system and generic functions.  In 0.8.6, we haven't still
  301: ;; solved the root problem, but we fixed this particular problem by
  302: ;; adding extra check in accessor methods.
  303: (define-module MA.inner
  304:   (export <ma-class-1> ma-getter ma-setter)
  305:   (define-class <ma-class-1> ()
  306:     ((a :accessor ma-get :init-value 'a)))
  307:   (define-method ma-getter ((o <ma-class-1>))
  308:     (ma-get o))
  309:   (define-method ma-setter ((o <ma-class-1>) val)
  310:     (set! (ma-get o) val)))
  311: 
  312: (define-module MA
  313:   (import MA.inner)
  314:   (export <ma-class-2> ma-g ma-s)
  315:   (define-class <ma-class-2> (<ma-class-1>)
  316:     ((b :init-value 'b)))
  317:   (define (ma-g o) (ma-getter o))
  318:   (define (ma-s o v) (ma-setter o v)))
  319: 
  320: (define-module MA.user
  321:   (import MA))
  322: 
  323: (test* "module and accessor" 'a
  324:        (with-module MA.user
  325:          (ma-g (make <ma-class-2>))))
  326: 
  327: (test* "module and accessor" 'ei
  328:        (with-module MA.user
  329:          (let1 m (make <ma-class-2>)
  330:            (ma-s m 'ei)
  331:            (slot-ref m 'a))))
  332: 
  333: ;;----------------------------------------------------------------
  334: (test-section "class redefinition (part 1)")
  335: 
  336: ;; save original <x> and <y> defined above
  337: (define <x>-orig <x>)
  338: (define <y>-orig <y>)
  339: (define <w>-orig <w>)
  340: (define <w2>-orig <w2>)
  341: 
  342: ;; create some more instances
  343: (define y1 (let ((o (make <y>)))
  344:              (for-each (lambda (s v) (slot-set! o s v))
  345:                        '(a b c d e)
  346:                        '(0 1 2 3 4))
  347:              o))
  348: (define y2 (let ((o (make <y>)))
  349:              (for-each (lambda (s v) (slot-set! o s v))
  350:                        '(a b c d e)
  351:                        '(5 6 7 8 9))
  352:              o))
  353: (define w1 (let ((o (make <w>)))
  354:              (for-each (lambda (s v) (slot-set! o s v))
  355:                        '(a b c d e f)
  356:                        '(100 101 102 103 104 105))
  357:              o))
  358: (define w2 (make <w>))
  359: 
  360: ;; set several methods
  361: (define-method redef-test1 ((x <x>)) 'x)
  362: (define-method redef-test1 ((y <y>)) 'y)
  363: (define-method redef-test1 ((w <w>)) 'w)
  364: (define-method redef-test1 ((w2 <w2>)) 'w2)
  365: 
  366: (define-method redef-test2 ((x <x>) (y <y>)) 'xyz)
  367: (define-method redef-test2 ((z <z>) (w <w>)) 'yw)
  368: 
  369: (test* "simple redefinition of <x>" #f
  370:        (begin
  371:          (eval '(define-class <x> () (a b c x)) (current-module))
  372:          (eval '(eq? <x> <x>-orig) (current-module))))
  373: 
  374: (test* "simple redefinition of <x>" '(#t #f #t #f)
  375:        (list (eq? (ref <x>-orig 'redefined) <x>)
  376:              (ref <x> 'redefined)
  377:              (eq? (ref <y>-orig 'redefined) <y>)
  378:              (ref <y> 'redefined)))
  379: 
  380: (test* "subclass redefinition <y> (links)"
  381:        '(#f #f #f #f #f)
  382:        (list (eq? <y> <y>-orig)
  383:              (not (memq <y> (ref <x> 'direct-subclasses)))
  384:              (not (memq <y>-orig (ref <x>-orig 'direct-subclasses)))
  385:              (not (memq <x> (ref <y> 'direct-supers)))
  386:              (not (memq <x>-orig (ref <y>-orig 'direct-supers)))))
  387: 
  388: (test* "subclass redefinition <y> (slots)"
  389:        '((a b c) (a b c x) (c d e a b) (c d e a b x))
  390:        (map (lambda (c) (map (lambda (s) (car s)) (class-slots c)))
  391:             (list <x>-orig <x> <y>-orig <y>)))
  392: 
  393: (test* "subclass redefinition <w> (links)"
  394:        '(#f #f #f #f #f)
  395:        (list (eq? <w> <w>-orig)
  396:              (not (memq <w> (ref <y> 'direct-subclasses)))
  397:              (not (memq <w>-orig (ref <y>-orig 'direct-subclasses)))
  398:              (not (memq <y> (ref <w> 'direct-supers)))
  399:              (not (memq <y>-orig (ref <w>-orig 'direct-supers)))))
  400: 
  401: (test* "subclass redefinition <w> (slots)"
  402:        '((e f c d a b) (e f c d a b x) (e f c d a b) (e f c d a b x))
  403:        (map (lambda (c) (map (lambda (s) (car s)) (class-slots c)))
  404:             (list <w>-orig <w> <w2>-orig <w2>)))
  405: 
  406: (test* "subclass redefinition (hierarchy)"
  407:        (list (list <x> <object> <top>)
  408:              (list <y> <x> <object> <top>)
  409:              (list <w> <z> <y> <x> <object> <top>)
  410:              (list <w2> <y> <x> <z> <object> <top>))
  411:        (map class-precedence-list (list <x> <y> <w> <w2>)))
  412: 
  413: (test* "subclass redefinition (hierarchy, orig)"
  414:        (list (list <x>-orig <object> <top>)
  415:              (list <y>-orig <x>-orig <object> <top>)
  416:              (list <w>-orig <z> <y>-orig <x>-orig <object> <top>)
  417:              (list <w2>-orig <y>-orig <x>-orig <z> <object> <top>))
  418:        (map class-precedence-list
  419:             (list <x>-orig <y>-orig <w>-orig <w2>-orig)))
  420: 
  421: ;; check link consistency between class-direct-methods and method-specializer.x
  422: (define (method-link-check gf class)
  423:   (and (not (null? (class-direct-methods class)))
  424:        (let loop ((dmeths (class-direct-methods class)))
  425:          (cond ((null? dmeths) #t)
  426:                ((memq (car dmeths) (slot-ref gf 'methods))
  427:                 => (lambda (meth)
  428:                      (and (memq class (slot-ref (car meth) 'specializers))
  429:                           (loop (cdr dmeths)))))
  430:                (else (loop (cdr dmeths)))))))
  431: 
  432: (test* "method link fix"
  433:        '(#t #t #t #t #t #t #t)
  434:        (list (method-link-check redef-test1 <x>)
  435:              (method-link-check redef-test1 <y>)
  436:              (method-link-check redef-test1 <w>)
  437:              (method-link-check redef-test1 <w2>)
  438:              (method-link-check redef-test2 <x>)
  439:              (method-link-check redef-test2 <y>)
  440:              (method-link-check redef-test2 <w>)))
  441: 
  442: (test* "instance update (x1)" '(#t -4 -5 -6 #f)
  443:        (list (is-a? x1 <x>)
  444:              (slot-ref x1 'a)
  445:              (slot-ref x1 'b)
  446:              (slot-ref x1 'c)
  447:              (slot-bound? x1 'x)))
  448: 
  449: (test* "instance update (y1)" '(#f 0 1 2 3 4)
  450:        (list (slot-bound? y1 'x)
  451:              (slot-ref y1 'a)
  452:              (slot-ref y1 'b)
  453:              (slot-ref y1 'c)
  454:              (slot-ref y1 'd)
  455:              (slot-ref y1 'e)))
  456: 
  457: (test* "redefine <x> again" '(a c x)
  458:        (begin
  459:          (eval '(define-class <x> () (a c (x :init-value 3))) (current-module))
  460:          (eval '(map car (class-slots <x>)) (current-module))))
  461: 
  462: (test* "instance update (x1)" '(1 #f -6 3)
  463:        (begin
  464:          (slot-set! x1 'a 1)
  465:          (list (slot-ref x1 'a)
  466:                (slot-exists? x1 'b)
  467:                (slot-ref x1 'c)
  468:                (slot-ref x1 'x))))
  469: 
  470: (test* "instance update (x2) - cascade" '(#t -7 #f -9 3)
  471:        (list (is-a? x2 <x>)
  472:              (slot-ref x2 'a)
  473:              (