1# This file contains a collection of tests for Tcl's built-in object system. 2# Sourcing this file into Tcl runs the tests and generates output for errors. 3# No output means no errors were found. 4# 5# Copyright © 2006-2011 Donal K. Fellows 6# 7# See the file "license.terms" for information on usage and redistribution of 8# this file, and for a DISCLAIMER OF ALL WARRANTIES. 9 10package require tcl::oo 1.0.3 11if {"::tcltest" ni [namespace children]} { 12 package require tcltest 2.5 13 namespace import -force ::tcltest::* 14} 15 16testConstraint memory [llength [info commands memory]] 17if {[testConstraint memory]} { 18 proc getbytes {} { 19 set lines [split [memory info] \n] 20 return [lindex $lines 3 3] 21 } 22 proc leaktest {script {iterations 3}} { 23 set end [getbytes] 24 for {set i 0} {$i < $iterations} {incr i} { 25 uplevel 1 $script 26 set tmp $end 27 set end [getbytes] 28 } 29 return [expr {$end - $tmp}] 30 } 31} 32 33test oo-nextto-1.1 {basic nextto functionality} -setup { 34 oo::class create root 35} -body { 36 oo::class create A { 37 superclass root 38 method x args { 39 lappend ::result ==A== $args 40 } 41 } 42 oo::class create B { 43 superclass A 44 method x args { 45 lappend ::result ==B== $args 46 nextto A B -> A {*}$args 47 } 48 } 49 oo::class create C { 50 superclass A 51 method x args { 52 lappend ::result ==C== $args 53 nextto A C -> A {*}$args 54 } 55 } 56 oo::class create D { 57 superclass B C 58 method x args { 59 lappend ::result ==D== $args 60 next foo 61 nextto C bar 62 } 63 } 64 set ::result {} 65 [D new] x 66 return $::result 67} -cleanup { 68 root destroy 69} -result {==D== {} ==B== foo ==A== {B -> A foo} ==C== bar ==A== {C -> A bar}} 70test oo-nextto-1.2 {basic nextto functionality} -setup { 71 oo::class create root 72} -body { 73 oo::class create A { 74 superclass root 75 method x args { 76 lappend ::result ==A== $args 77 } 78 } 79 oo::class create B { 80 superclass A 81 method x args { 82 lappend ::result ==B== $args 83 nextto A B -> A {*}$args 84 } 85 } 86 oo::class create C { 87 superclass A 88 method x args { 89 lappend ::result ==C== $args 90 nextto A C -> A {*}$args 91 } 92 } 93 oo::class create D { 94 superclass B C 95 method x args { 96 lappend ::result ==D== $args 97 nextto B foo {*}$args 98 nextto C bar {*}$args 99 } 100 } 101 set ::result {} 102 [D new] x 123 103 return $::result 104} -cleanup { 105 root destroy 106} -result {==D== 123 ==B== {foo 123} ==A== {B -> A foo 123} ==C== {bar 123} ==A== {C -> A bar 123}} 107test oo-nextto-1.3 {basic nextto functionality: constructors} -setup { 108 oo::class create root 109} -body { 110 oo::class create A { 111 superclass root 112 variable result 113 constructor {a c} { 114 lappend result ==A== a=$a,c=$c 115 } 116 } 117 oo::class create B { 118 superclass root 119 variable result 120 constructor {b} { 121 lappend result ==B== b=$b 122 } 123 } 124 oo::class create C { 125 superclass A B 126 variable result 127 constructor {p q r} { 128 lappend result ==C== p=$p,q=$q,r=$r 129 # Route arguments to superclasses, in non-trival pattern 130 nextto B $q 131 nextto A $p $r 132 } 133 method result {} {return $result} 134 } 135 [C new x y z] result 136} -cleanup { 137 root destroy 138} -result {==C== p=x,q=y,r=z ==B== b=y ==A== a=x,c=z} 139test oo-nextto-1.4 {basic nextto functionality: destructors} -setup { 140 oo::class create root {destructor return} 141} -body { 142 oo::class create A { 143 superclass root 144 destructor { 145 lappend ::result ==A== 146 next 147 } 148 } 149 oo::class create B { 150 superclass root 151 destructor { 152 lappend ::result ==B== 153 next 154 } 155 } 156 oo::class create C { 157 superclass A B 158 destructor { 159 lappend ::result ==C== 160 lappend ::result | 161 nextto B 162 lappend ::result | 163 nextto A 164 lappend ::result | 165 next 166 } 167 } 168 set ::result "" 169 [C new] destroy 170 return $::result 171} -cleanup { 172 root destroy 173} -result {==C== | ==B== | ==A== ==B== | ==A== ==B==} 174 175test oo-nextto-2.1 {errors in nextto} -setup { 176 oo::class create root 177} -body { 178 oo::class create A { 179 superclass root 180 method x y {error $y} 181 } 182 oo::class create B { 183 superclass A 184 method x y {nextto A $y} 185 } 186 [B new] x boom 187} -cleanup { 188 root destroy 189} -result boom -returnCodes error 190test oo-nextto-2.2 {errors in nextto} -setup { 191 oo::class create root 192} -body { 193 oo::class create A { 194 superclass root 195 method x y {error $y} 196 } 197 oo::class create B { 198 superclass root 199 method x y {nextto A $y} 200 } 201 [B new] x boom 202} -returnCodes error -cleanup { 203 root destroy 204} -result {method has no non-filter implementation by "A"} 205test oo-nextto-2.3 {errors in nextto} -setup { 206 oo::class create root 207} -body { 208 oo::class create A { 209 superclass root 210 method x y {nextto $y} 211 } 212 oo::class create B { 213 superclass A 214 method x y {nextto A $y} 215 } 216 [B new] x B 217} -returnCodes error -cleanup { 218 root destroy 219} -result {method implementation by "B" not reachable from here} 220test oo-nextto-2.4 {errors in nextto} -setup { 221 oo::class create root 222} -body { 223 oo::class create A { 224 superclass root 225 method x y {nextto $y} 226 } 227 oo::class create B { 228 superclass A 229 method x y {nextto} 230 } 231 [B new] x B 232} -returnCodes error -cleanup { 233 root destroy 234} -result {wrong # args: should be "nextto class ?arg...?"} 235test oo-nextto-2.5 {errors in nextto} -setup { 236 oo::class create root 237} -body { 238 oo::class create A { 239 superclass root 240 method x y {nextto $y} 241 } 242 oo::class create B { 243 superclass A 244 method x y {nextto $y $y $y} 245 } 246 [B new] x A 247} -cleanup { 248 root destroy 249} -result {wrong # args: should be "nextto A y"} -returnCodes error 250test oo-nextto-2.6 {errors in nextto} -setup { 251 oo::class create root 252} -body { 253 oo::class create A { 254 superclass root 255 method x y {nextto $y} 256 } 257 oo::class create B { 258 superclass A 259 method x y {nextto $y $y $y} 260 } 261 [B new] x [root create notAClass] 262} -cleanup { 263 root destroy 264} -result {"::notAClass" is not a class} -returnCodes error 265test oo-nextto-2.7 {errors in nextto} -setup { 266 oo::class create root 267} -body { 268 oo::class create A { 269 superclass root 270 method x y {nextto $y} 271 } 272 oo::class create B { 273 superclass A 274 filter Y 275 method Y args {next {*}$args} 276 } 277 oo::class create C { 278 superclass B 279 method x y {nextto $y $y $y} 280 } 281 [C new] x B 282} -returnCodes error -cleanup { 283 root destroy 284} -result {method has no non-filter implementation by "B"} 285 286test oo-call-1.1 {object call introspection} -setup { 287 oo::class create root 288} -body { 289 oo::class create ::A { 290 superclass root 291 method x {} {} 292 } 293 A create y 294 info object call y x 295} -cleanup { 296 root destroy 297} -result {{method x ::A method}} 298test oo-call-1.2 {object call introspection} -setup { 299 oo::class create root 300} -body { 301 oo::class create ::A { 302 superclass root 303 method x {} {} 304 } 305 oo::class create ::B { 306 superclass A 307 method x {} {} 308 } 309 B create y 310 info object call y x 311} -cleanup { 312 root destroy 313} -result {{method x ::B method} {method x ::A method}} 314test oo-call-1.3 {object call introspection} -setup { 315 oo::class create root 316} -body { 317 oo::class create ::A { 318 superclass root 319 method x {} {} 320 } 321 A create y 322 oo::objdefine y method x {} {} 323 info object call y x 324} -cleanup { 325 root destroy 326} -result {{method x object method} {method x ::A method}} 327test oo-call-1.4 {object object call introspection - unknown} -setup { 328 oo::class create root 329} -body { 330 oo::class create ::A { 331 superclass root 332 method x {} {} 333 } 334 A create y 335 info object call y z 336} -cleanup { 337 root destroy 338} -result {{unknown unknown ::oo::object {core method: "unknown"}}} 339test oo-call-1.5 {object call introspection - filters} -setup { 340 oo::class create root 341} -body { 342 oo::class create ::A { 343 superclass root 344 method x {} {} 345 method y {} {} 346 filter y 347 } 348 A create y 349 info object call y x 350} -cleanup { 351 root destroy 352} -result {{filter y ::A method} {method x ::A method}} 353test oo-call-1.6 {object call introspection - filters} -setup { 354 oo::class create root 355} -body { 356 oo::class create ::A { 357 superclass root 358 method x {} {} 359 method y {} {} 360 filter y 361 } 362 oo::class create ::B { 363 superclass A 364 method x {} {} 365 } 366 B create y 367 info object call y x 368} -cleanup { 369 root destroy 370} -result {{filter y ::A method} {method x ::B method} {method x ::A method}} 371test oo-call-1.7 {object call introspection - filters} -setup { 372 oo::class create root 373} -body { 374 oo::class create ::A { 375 superclass root 376 method x {} {} 377 method y {} {} 378 filter y 379 } 380 oo::class create ::B { 381 superclass A 382 method x {} {} 383 method y {} {} 384 } 385 B create y 386 info object call y x 387} -cleanup { 388 root destroy 389} -result {{filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}} 390test oo-call-1.8 {object call introspection - filters} -setup { 391 oo::class create root 392} -body { 393 oo::class create ::A { 394 superclass root 395 method x {} {} 396 method y {} {} 397 filter y 398 } 399 oo::class create ::B { 400 superclass A 401 method x {} {} 402 method y {} {} 403 method z {} {} 404 filter z 405 } 406 B create y 407 info object call y x 408} -cleanup { 409 root destroy 410} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}} 411test oo-call-1.9 {object call introspection - filters} -setup { 412 oo::class create root 413} -body { 414 oo::class create ::A { 415 superclass root 416 method x {} {} 417 method y {} {} 418 filter y 419 } 420 oo::class create ::B { 421 superclass A 422 method x {} {} 423 method y {} {} 424 method z {} {} 425 filter z 426 } 427 B create y 428 info object call y y 429} -cleanup { 430 root destroy 431} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method y ::B method} {method y ::A method}} 432test oo-call-1.10 {object call introspection - filters + unknown} -setup { 433 oo::class create root 434} -body { 435 oo::class create ::A { 436 superclass root 437 method y {} {} 438 filter y 439 } 440 oo::class create ::B { 441 superclass A 442 method y {} {} 443 method unknown {} {} 444 } 445 B create y 446 info object call y x 447} -cleanup { 448 root destroy 449} -result {{filter y ::B method} {filter y ::A method} {unknown unknown ::B method} {unknown unknown ::oo::object {core method: "unknown"}}} 450test oo-call-1.11 {object call introspection - filters + unknown} -setup { 451 oo::class create root 452} -body { 453 oo::class create ::A { 454 superclass root 455 method y {} {} 456 filter y 457 } 458 A create y 459 oo::objdefine y method unknown {} {} 460 info object call y x 461} -cleanup { 462 root destroy 463} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}} 464test oo-call-1.12 {object call introspection - filters + unknown} -setup { 465 oo::class create root 466} -body { 467 oo::class create ::A { 468 superclass root 469 method y {} {} 470 } 471 A create y 472 oo::objdefine y { 473 method unknown {} {} 474 filter y 475 } 476 info object call y x 477} -cleanup { 478 root destroy 479} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}} 480test oo-call-1.13 {object call introspection - filters + unknown} -setup { 481 oo::class create root 482} -body { 483 oo::class create ::A { 484 superclass root 485 method y {} {} 486 } 487 A create y 488 oo::objdefine y { 489 method unknown {} {} 490 method x {} {} 491 filter y 492 } 493 info object call y x 494} -cleanup { 495 root destroy 496} -result {{filter y ::A method} {method x object method}} 497test oo-call-1.14 {object call introspection - errors} -body { 498 info object call 499} -returnCodes error -result {wrong # args: should be "info object call objName methodName"} 500test oo-call-1.15 {object call introspection - errors} -body { 501 info object call a 502} -returnCodes error -result {wrong # args: should be "info object call objName methodName"} 503test oo-call-1.16 {object call introspection - errors} -body { 504 info object call a b c 505} -returnCodes error -result {wrong # args: should be "info object call objName methodName"} 506test oo-call-1.17 {object call introspection - errors} -body { 507 info object call notanobject x 508} -returnCodes error -result {notanobject does not refer to an object} 509test oo-call-1.18 {object call introspection - memory leaks} -body { 510 leaktest { 511 info object call oo::object destroy 512 } 513} -constraints memory -result 0 514test oo-call-1.19 {object call introspection - memory leaks} -setup { 515 oo::class create leaktester { method foo {} {dummy} } 516} -body { 517 leaktest { 518 set lt [leaktester new] 519 oo::objdefine $lt method foobar {} {dummy} 520 list [info object call $lt destroy] \ 521 [info object call $lt foo] \ 522 [info object call $lt bar] \ 523 [info object call $lt foobar] \ 524 [$lt destroy] 525 } 526} -cleanup { 527 leaktester destroy 528} -constraints memory -result 0 529test oo-call-1.20 {object call introspection - complex case} -setup { 530 oo::class create root 531} -body { 532 oo::class create ::A { 533 superclass root 534 method x {} {} 535 } 536 oo::class create ::B { 537 superclass A 538 method x {} {} 539 } 540 oo::class create ::C { 541 superclass root 542 method x {} {} 543 mixin B 544 } 545 oo::class create ::D { 546 superclass C 547 method x {} {} 548 } 549 oo::class create ::E { 550 superclass root 551 method x {} {} 552 } 553 oo::class create ::F { 554 superclass E 555 method x {} {} 556 } 557 oo::class create ::G { 558 superclass root 559 method x {} {} 560 } 561 oo::class create ::H { 562 superclass G 563 method x {} {} 564 } 565 oo::define F mixin H 566 F create y 567 oo::objdefine y { 568 method x {} {} 569 mixin D 570 } 571 info object call y x 572} -cleanup { 573 root destroy 574} -result {{method x ::D method} {method x ::B method} {method x ::A method} {method x ::C method} {method x ::H method} {method x ::G method} {method x object method} {method x ::F method} {method x ::E method}} 575test oo-call-1.21 {object call introspection - complex case} -setup { 576 oo::class create root 577} -body { 578 oo::class create ::A { 579 superclass root 580 method y {} {} 581 filter y 582 } 583 oo::class create ::B { 584 superclass A 585 method y {} {} 586 } 587 oo::class create ::C { 588 superclass root 589 method x {} {} 590 mixin B 591 } 592 oo::class create ::D { 593 superclass C 594 filter x 595 } 596 oo::class create ::E { 597 superclass root 598 method y {} {} 599 method x {} {} 600 } 601 oo::class create ::F { 602 superclass E 603 method z {} {} 604 method q {} {} 605 } 606 F create y 607 oo::objdefine y { 608 method unknown {} {} 609 mixin D 610 filter q 611 } 612 info object call y z 613} -cleanup { 614 root destroy 615} -result {{filter x ::C method} {filter x ::E method} {filter y ::B method} {filter y ::A method} {filter y ::E method} {filter q ::F method} {method z ::F method}} 616 617test oo-call-2.1 {class call introspection} -setup { 618 oo::class create root 619} -body { 620 oo::class create ::A { 621 superclass root 622 method x {} {} 623 } 624 info class call A x 625} -cleanup { 626 root destroy 627} -result {{method x ::A method}} 628test oo-call-2.2 {class call introspection} -setup { 629 oo::class create root 630} -body { 631 oo::class create ::A { 632 superclass root 633 method x {} {} 634 } 635 oo::class create ::B { 636 superclass A 637 method x {} {} 638 } 639 list [info class call A x] [info class call B x] 640} -cleanup { 641 root destroy 642} -result {{{method x ::A method}} {{method x ::B method} {method x ::A method}}} 643test oo-call-2.3 {class call introspection} -setup { 644 oo::class create root 645} -body { 646 oo::class create ::A { 647 superclass root 648 method x {} {} 649 } 650 oo::class create ::B { 651 superclass A 652 method x {} {} 653 } 654 oo::class create ::C { 655 superclass A 656 method x {} {} 657 } 658 oo::class create ::D { 659 superclass C B 660 method x {} {} 661 } 662 info class call D x 663} -cleanup { 664 root destroy 665} -result {{method x ::D method} {method x ::C method} {method x ::B method} {method x ::A method}} 666test oo-call-2.4 {class call introspection - mixin} -setup { 667 oo::class create root 668} -body { 669 oo::class create ::A { 670 superclass root 671 method x {} {} 672 } 673 oo::class create ::B { 674 superclass A 675 method x {} {} 676 } 677 oo::class create ::C { 678 superclass A 679 method x {} {} 680 } 681 oo::class create ::D { 682 superclass C 683 mixin B 684 method x {} {} 685 } 686 info class call D x 687} -cleanup { 688 root destroy 689} -result {{method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}} 690test oo-call-2.5 {class call introspection - mixin + filter} -setup { 691 oo::class create root 692} -body { 693 oo::class create ::A { 694 superclass root 695 method x {} {} 696 } 697 oo::class create ::B { 698 superclass A 699 method x {} {} 700 method y {} {} 701 filter y 702 } 703 oo::class create ::C { 704 superclass A 705 method x {} {} 706 method y {} {} 707 } 708 oo::class create ::D { 709 superclass C 710 mixin B 711 method x {} {} 712 } 713 info class call D x 714} -cleanup { 715 root destroy 716} -result {{filter y ::B method} {filter y ::C method} {method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}} 717test oo-call-2.6 {class call introspection - mixin + filter + unknown} -setup { 718 oo::class create root 719} -body { 720 oo::class create ::A { 721 superclass root 722 method x {} {} 723 method unknown {} {} 724 } 725 oo::class create ::B { 726 superclass A 727 method x {} {} 728 method y {} {} 729 filter y 730 } 731 oo::class create ::C { 732 superclass A 733 method x {} {} 734 method y {} {} 735 } 736 oo::class create ::D { 737 superclass C 738 mixin B 739 method x {} {} 740 method unknown {} {} 741 } 742 info class call D z 743} -cleanup { 744 root destroy 745} -result {{filter y ::B method} {filter y ::C method} {unknown unknown ::D method} {unknown unknown ::A method} {unknown unknown ::oo::object {core method: "unknown"}}} 746test oo-call-2.7 {class call introspection - mixin + filter + unknown} -setup { 747 oo::class create root 748} -body { 749 oo::class create ::A { 750 superclass root 751 method x {} {} 752 } 753 oo::class create ::B { 754 superclass A 755 method x {} {} 756 filter x 757 } 758 info class call B x 759} -cleanup { 760 root destroy 761} -result {{filter x ::B method} {filter x ::A method} {method x ::B method} {method x ::A method}} 762test oo-call-2.8 {class call introspection - errors} -body { 763 info class call 764} -returnCodes error -result {wrong # args: should be "info class call className methodName"} 765test oo-call-2.9 {class call introspection - errors} -body { 766 info class call a 767} -returnCodes error -result {wrong # args: should be "info class call className methodName"} 768test oo-call-2.10 {class call introspection - errors} -body { 769 info class call a b c 770} -returnCodes error -result {wrong # args: should be "info class call className methodName"} 771test oo-call-2.11 {class call introspection - errors} -body { 772 info class call notaclass x 773} -returnCodes error -result {notaclass does not refer to an object} 774test oo-call-2.12 {class call introspection - errors} -setup { 775 oo::class create root 776} -body { 777 root create notaclass 778 info class call notaclass x 779} -returnCodes error -cleanup { 780 root destroy 781} -result {"notaclass" is not a class} 782test oo-call-2.13 {class call introspection - memory leaks} -body { 783 leaktest { 784 info class call oo::class destroy 785 } 786} -constraints memory -result 0 787test oo-call-2.14 {class call introspection - memory leaks} -body { 788 leaktest { 789 oo::class create leaktester { method foo {} {dummy} } 790 [leaktester new] destroy 791 list [info class call leaktester destroy] \ 792 [info class call leaktester foo] \ 793 [info class call leaktester bar] \ 794 [leaktester destroy] 795 } 796} -constraints memory -result 0 797 798test oo-call-3.1 {current call introspection} -setup { 799 oo::class create root 800} -body { 801 oo::class create A { 802 superclass root 803 method x {} {lappend ::result [self call]} 804 } 805 oo::class create B { 806 superclass A 807 method x {} {lappend ::result [self call];next} 808 } 809 B create y 810 oo::objdefine y method x {} {lappend ::result [self call];next} 811 set ::result {} 812 y x 813} -cleanup { 814 root destroy 815} -result {{{{method x object method} {method x ::B method} {method x ::A method}} 0} {{{method x object method} {method x ::B method} {method x ::A method}} 1} {{{method x object method} {method x ::B method} {method x ::A method}} 2}} 816test oo-call-3.2 {current call introspection} -setup { 817 oo::class create root 818} -constraints memory -body { 819 oo::class create A { 820 superclass root 821 method x {} {self call} 822 } 823 oo::class create B { 824 superclass A 825 method x {} {self call;next} 826 } 827 B create y 828 oo::objdefine y method x {} {self call;next} 829 leaktest { 830 y x 831 } 832} -cleanup { 833 root destroy 834} -result 0 835test oo-call-3.3 {current call introspection: in constructors} -setup { 836 oo::class create root 837} -body { 838 oo::class create A { 839 superclass root 840 constructor {} {lappend ::result [self call]} 841 } 842 oo::class create B { 843 superclass A 844 constructor {} {lappend ::result [self call]; next} 845 } 846 set ::result {} 847 [B new] destroy 848 return $::result 849} -cleanup { 850 root destroy 851} -result {{{{method <constructor> ::B method} {method <constructor> ::A method}} 0} {{{method <constructor> ::B method} {method <constructor> ::A method}} 1}} 852test oo-call-3.4 {current call introspection: in destructors} -setup { 853 oo::class create root 854} -body { 855 oo::class create A { 856 superclass root 857 destructor {lappend ::result [self call]} 858 } 859 oo::class create B { 860 superclass A 861 destructor {lappend ::result [self call]; next} 862 } 863 set ::result {} 864 [B new] destroy 865 return $::result 866} -cleanup { 867 root destroy 868} -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}} 869 870# Contributed tests from aspect, related to [0f42ff7871] 871# 872# dkf's "Principles Leading to a Fix" 873# 874# A method ought to work "the same" whether or not it has been overridden by 875# a subclass. A tailcalled command ought to have as parent stack the same 876# thing you'd get with uplevel 1. A subclass will often expect the 877# superclass's result to be the result that would be returned if the 878# subclass was not there. 879 880# Common setup: 881# any invocation of bar should emit "abc\nhi\n" then return to its 882# caller 883set testopts { 884 -setup { 885 oo::class create Parent 886 oo::class create Foo { 887 superclass Parent 888 method bar {} { 889 puts abc 890 tailcall puts hi 891 puts xyz 892 } 893 } 894 oo::class create Foo2 { 895 superclass Parent 896 } 897 } 898 -cleanup { 899 Parent destroy 900 } 901} 902 903# these succeed, showing that without [next] the bug doesn't fire 904test next-tailcall-simple-1 "trivial case with one method" {*}$testopts -body { 905 [Foo create foo] bar 906} -output [join {abc hi} \n]\n 907test next-tailcall-simple-2 "my bar" {*}$testopts -body { 908 oo::define Foo method baz {} { 909 puts a 910 my bar 911 puts b 912 } 913 [Foo create foo] baz 914} -output [join {a abc hi b} \n]\n 915test next-tailcall-simple-3 "\[self\] bar" {*}$testopts -body { 916 oo::define Foo method baz {} { 917 puts a 918 [self] bar 919 puts b 920 } 921 [Foo create foo] baz 922} -output [join {a abc hi b} \n]\n 923test next-tailcall-simple-4 "foo bar" {*}$testopts -body { 924 oo::define Foo method baz {} { 925 puts a 926 foo bar 927 puts b 928 } 929 [Foo create foo] baz 930} -output [join {a abc hi b} \n]\n 931 932# everything from here on uses [next], and fails on 8.6.4 with compilation 933test next-tailcall-superclass-1 "next superclass" {*}$testopts -body { 934 oo::define Foo2 { 935 superclass Foo 936 method bar {} { 937 puts a 938 next 939 puts b 940 } 941 } 942 [Foo2 create foo] bar 943} -output [join {a abc hi b} \n]\n 944test next-tailcall-superclass-2 "nextto superclass" {*}$testopts -body { 945 oo::define Foo2 { 946 superclass Foo 947 method bar {} { 948 puts a 949 nextto Foo 950 puts b 951 } 952 } 953 [Foo2 create foo] bar 954} -output [join {a abc hi b} \n]\n 955 956test next-tailcall-mixin-1 "class mixin" {*}$testopts -body { 957 oo::define Foo2 { 958 method Bar {} { 959 puts a 960 next 961 puts b 962 } 963 filter Bar 964 } 965 oo::define Foo mixin Foo2 966 Foo create foo 967 foo bar 968} -output [join {a abc hi b} \n]\n 969 970test next-tailcall-objmixin-1 "object mixin" {*}$testopts -body { 971 oo::define Foo2 { 972 method Bar {} { 973 puts a 974 next 975 puts b 976 } 977 filter Bar 978 } 979 Foo create foo 980 oo::objdefine foo mixin Foo2 981 foo bar 982} -output [join {a abc hi b} \n]\n 983 984test next-tailcall-filter-1 "filter method" {*}$testopts -body { 985 oo::define Foo method Filter {} { 986 puts a 987 next 988 puts b 989 } 990 oo::define Foo filter Filter 991 [Foo new] bar 992} -output [join {a abc hi b} \n]\n 993 994test next-tailcall-forward-1 "forward method" {*}$testopts -body { 995 proc foobar {} { 996 puts "abc" 997 tailcall puts "hi" 998 puts "xyz" 999 } 1000 oo::define Foo forward foobar foobar 1001 oo::define Foo2 { 1002 superclass Foo 1003 method foobar {} { 1004 puts a 1005 next 1006 puts b 1007 } 1008 } 1009 [Foo2 new] foobar 1010} -output [join {a abc hi b} \n]\n 1011 1012test next-tailcall-constructor-1 "next in constructor" -body { 1013 oo::class create Foo { 1014 constructor {} { 1015 puts abc 1016 tailcall puts hi 1017 puts xyz 1018 } 1019 } 1020 oo::class create Foo2 { 1021 superclass Foo 1022 constructor {} { 1023 puts a 1024 next 1025 puts b 1026 } 1027 } 1028 list [Foo new] [Foo2 new] 1029 return "" 1030} -cleanup { 1031 Foo destroy 1032} -output [join {abc hi a abc hi b} \n]\n 1033 1034test next-tailcall-destructor-1 "next in destructor" -body { 1035 oo::class create Foo { 1036 destructor { 1037 puts abc 1038 tailcall puts hi 1039 puts xyz 1040 } 1041 } 1042 oo::class create Foo2 { 1043 superclass Foo 1044 destructor { 1045 puts a 1046 next 1047 puts b 1048 } 1049 } 1050 Foo create foo 1051 Foo2 create foo2 1052 foo destroy 1053 foo2 destroy 1054} -output [join {abc hi a abc hi b} \n]\n -cleanup { 1055 Foo destroy 1056} 1057 1058unset testopts 1059 1060cleanupTests 1061return 1062 1063# Local Variables: 1064# mode: tcl 1065# End: 1066