Tcl Source Code

Check-in [faf87d4008]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Leaving out the weird delegates stops the test failures.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-478
Files: files | file ages | folders
SHA3-256: faf87d400822f33f4993867416be2a2fd42696f61c8fef1b02d612ce6c6758b3
User & Date: dkf 2018-06-17 17:27:41
Context
2018-06-23
15:03
Make the delegates work by moving their creation into C. check-in: b3c558369f user: dkf tags: tip-478
2018-06-17
17:27
Leaving out the weird delegates stops the test failures. check-in: faf87d4008 user: dkf tags: tip-478
16:47
Most of the implementation ported over. [classmethod] is trickier... check-in: c919d1df55 user: dkf tags: tip-478
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOOScript.h.

47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63

64
65
66
67

68
69
70
71
72
73
74

75
76
77
78
79
80
81
"            set dst $src\n"
"        }\n"
"        interp alias {} ${ns}::$src {} ${ns}::my $dst\n"
"    }\n"
"    return\n"
"}\n"

/*
"proc ::oo::define::classmethod {name {args {}} {body {}}} {\n"
"    # Create the method on the class if the caller gave arguments and body\n"
"    set argc [llength [info level 0]]\n"
"    if {$argc == 3} {\n"
"        return -code error [string cat {wrong # args: should be \"}"
"                [lindex [info level 0] 0] { name ?args body?\"}]\n"
"    }\n"
"    # Get the name of the current class or class delegate\n"
"    set cls [uplevel 1 self]\n"

"    set d $cls.Delegate\n"
"    if {[info object isa object $d] && [info object isa class $d]} {\n"
"        set cls $d\n"
"    }\n"

"    if {$argc == 4} {\n"
"        ::oo::define $cls method $name $args $body\n"
"    }\n"
"    # Make the connection by forwarding\n"
"    tailcall forward $name [info object namespace $cls]::my $name\n"
"}\n"


"# Build this *almost* like a class method, but with extra care to avoid\n"
"# nuking the existing method.\n"
"::oo::class create ::oo::class.Delegate {\n"
"    method create {name args} {\n"
"        if {![string match ::* $name]} {\n"
"            set ns [uplevel 1 {namespace current}]\n"
"            if {$ns eq {::}} {set ns {}}\n"






<







<

>




>







>







47
48
49
50
51
52
53

54
55
56
57
58
59
60

61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
"            set dst $src\n"
"        }\n"
"        interp alias {} ${ns}::$src {} ${ns}::my $dst\n"
"    }\n"
"    return\n"
"}\n"


"proc ::oo::define::classmethod {name {args {}} {body {}}} {\n"
"    # Create the method on the class if the caller gave arguments and body\n"
"    set argc [llength [info level 0]]\n"
"    if {$argc == 3} {\n"
"        return -code error [string cat {wrong # args: should be \"}"
"                [lindex [info level 0] 0] { name ?args body?\"}]\n"
"    }\n"

"    set cls [uplevel 1 self]\n"
/*
"    set d $cls.Delegate\n"
"    if {[info object isa object $d] && [info object isa class $d]} {\n"
"        set cls $d\n"
"    }\n"
*/
"    if {$argc == 4} {\n"
"        ::oo::define $cls method $name $args $body\n"
"    }\n"
"    # Make the connection by forwarding\n"
"    tailcall forward $name [info object namespace $cls]::my $name\n"
"}\n"

/*
"# Build this *almost* like a class method, but with extra care to avoid\n"
"# nuking the existing method.\n"
"::oo::class create ::oo::class.Delegate {\n"
"    method create {name args} {\n"
"        if {![string match ::* $name]} {\n"
"            set ns [uplevel 1 {namespace current}]\n"
"            if {$ns eq {::}} {set ns {}}\n"