Tcl Source Code

Check-in [b3c558369f]
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:Make the delegates work by moving their creation into C.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-478
Files: files | file ages | folders
SHA3-256: b3c558369f5d8fb1f4517a69b72a2702842633fa05bb4920a09279f013762acd
User & Date: dkf 2018-06-23 15:03:26
Context
2018-06-27
07:39
Add better error handling and make the delegation work with cloning. check-in: e9637e3ddc user: dkf tags: tip-478
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
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOOBasic.c.

79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95











96
97
98
99
100
101
102
...
124
125
126
127
128
129
130

131
132
133




134
135
136

137
138
139
140
141
142
143
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    Tcl_Obj **invoke;

    if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"?definitionScript?");
	return TCL_ERROR;
    } else if (objc == Tcl_ObjectContextSkippedArgs(context)) {
	return TCL_OK;
    }












    /*
     * Delegate to [oo::define] to do the work.
     */

    invoke = ckalloc(3 * sizeof(Tcl_Obj *));
    invoke[0] = oPtr->fPtr->defineName;
    invoke[1] = TclOOObjectName(interp, oPtr);
................................................................................
static int
DecrRefsPostClassConstructor(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj **invoke = data[0];


    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);




    TclDecrRefCount(invoke[2]);
    ckfree(invoke);
    return result;

}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Create --
 *






|









>
>
>
>
>
>
>
>
>
>
>







 







>


|
>
>
>
>
|

<
>







79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
...
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151

152
153
154
155
156
157
158
159
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    Tcl_Obj **invoke, *nameObj;

    if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"?definitionScript?");
	return TCL_ERROR;
    } else if (objc == Tcl_ObjectContextSkippedArgs(context)) {
	return TCL_OK;
    }

    /*
     * Make the class definition delegate. This is special; it doesn't reenter
     * here (and the class definition delegate doesn't run any constructors).
     */

    nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
    Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
    Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
	    TclGetString(nameObj), NULL, -1, NULL, -1);
    Tcl_DecrRefCount(nameObj);

    /*
     * Delegate to [oo::define] to do the work.
     */

    invoke = ckalloc(3 * sizeof(Tcl_Obj *));
    invoke[0] = oPtr->fPtr->defineName;
    invoke[1] = TclOOObjectName(interp, oPtr);
................................................................................
static int
DecrRefsPostClassConstructor(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj **invoke = data[0];
    Tcl_InterpState saved;

    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[2]);
    invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
    Tcl_IncrRefCount(invoke[0]);
    saved = Tcl_SaveInterpState(interp, result);
    Tcl_EvalObjv(interp, 2, invoke, 0);
    TclDecrRefCount(invoke[1]);
    ckfree(invoke);

    return Tcl_RestoreInterpState(interp, saved);
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Create --
 *

Changes to generic/tclOOScript.h.

1
2
3
4
5
6
7
8


9
10
11
12
13
14
15
..
46
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
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99




100
101
102
103
104
105
106
107
108
...
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
/*
 * tclOOScript.h --
 *
 *	This file contains support scripts for TclOO. They are defined here so
 *	that the code can be definitely run even in safe interpreters; TclOO's
 *	core setup is safe.
 *
 * Copyright (c) 2012-2018 by Donal K. Fellows


 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifndef TCL_OO_SCRIPT_H
#define TCL_OO_SCRIPT_H
................................................................................
"            lassign $link src\n"
"            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"
"            set name ${ns}::${name}\n"
"        }\n"
"        if {[string match *.Delegate $name]} {\n"
"            return [next $name {*}$args]\n"
"        }\n"
"        set delegate [oo::class create $name.Delegate]\n"
"        set cls [next $name {*}$args]\n"
"        set superdelegates [list $delegate]\n"
"        foreach c [info class superclass $cls] {\n"
"            set d $c.Delegate\n"
"            if {[info object isa object $d] && [info object isa class $d]} {\n"
"                lappend superdelegates $d\n"
"            }\n"
"        }\n"
"        oo::objdefine $cls mixin {*}$superdelegates\n"
"        return $cls\n"
"    }\n"




"}\n"
*/

"::oo::define ::oo::Slot {\n"
"    method Get {} {return -code error unimplemented}\n"
"    method Set list {return -code error unimplemented}\n"

"    method -set args {tailcall my Set $args}\n"
"    method -append args {\n"
................................................................................
"    unexport unknown destroy\n"
"}\n"
"\n"
"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"

/*
"::oo::define ::oo::class self mixin ::oo::class.Delegate\n"
*/

"::oo::class create ::oo::singleton {\n"
"    superclass ::oo::class\n"
"    variable object\n"
"    unexport create createWithNamespace\n"
"    method new args {\n"
"        if {![info exists object]} {\n"
"            set object [next {*}$args]\n"






|
>
>







 







>
>
>
>









<
<
<
<
<
<

|





<
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
<
<
|
<
<
|
>
>
>
>

<







 







<
<
<
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
..
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
83
84
85

86
87
88
89
90
91
92
...
110
111
112
113
114
115
116




117
118
119
120
121
122
123
/*
 * tclOOScript.h --
 *
 *	This file contains support scripts for TclOO. They are defined here so
 *	that the code can be definitely run even in safe interpreters; TclOO's
 *	core setup is safe.
 *
 * Copyright (c) 2012-2018 Donal K. Fellows
 * Copyright (c) 2013 Andreas Kupries
 * Copyright (c) 2017 Gerald Lester
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifndef TCL_OO_SCRIPT_H
#define TCL_OO_SCRIPT_H
................................................................................
"            lassign $link src\n"
"            set dst $src\n"
"        }\n"
"        interp alias {} ${ns}::$src {} ${ns}::my $dst\n"
"    }\n"
"    return\n"
"}\n"

"proc ::oo::DelegateName {class} {\n"
"    string cat [info object namespace $class] {:: oo ::delegate}\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"






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


"proc ::oo::MixinClassDelegates {class} {\n"
"    ::oo::objdefine $class mixin -append {*}[lmap c [info class superclass $class] {\n"















"        set d [::oo::DelegateName $c]\n"
"        if {![info object isa class $d]} continue; set d\n"


"    }]\n"


"}\n"

"::proc ::oo::define::initialise {body} {\n"
"    set clsns [info object namespace [uplevel 1 self]]\n"
"    tailcall apply [list {} $body $clsns]\n"
"}\n"


"::oo::define ::oo::Slot {\n"
"    method Get {} {return -code error unimplemented}\n"
"    method Set list {return -code error unimplemented}\n"

"    method -set args {tailcall my Set $args}\n"
"    method -append args {\n"
................................................................................
"    unexport unknown destroy\n"
"}\n"
"\n"
"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"





"::oo::class create ::oo::singleton {\n"
"    superclass ::oo::class\n"
"    variable object\n"
"    unexport create createWithNamespace\n"
"    method new args {\n"
"        if {![info exists object]} {\n"
"            set object [next {*}$args]\n"

Changes to tests/oo.test.

336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
....
4841
4842
4843
4844
4845
4846
4847











































4848
4849
4850
4851
4852
4853
4854
		lappend x [info class $cmd ::oo::$initial]
	    }
	}
	foreach initial {object class Slot} {
	    lappend x [info object class ::oo::$initial]
	}
	return $x
    }] {lsort $x}
} -cleanup {
    interp delete $fresh
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}

test oo-2.1 {basic test of OO functionality: constructor} -setup {
    # This is a bit complex because it needs to run in a sub-interp as
    # we're modifying the root object class's constructor
................................................................................
	unexport foo
    }
    lappend result {*}[lmap s {public unexported private} {
	info class methods cls -scope $s}]
} -cleanup {
    cls destroy
} -result {{} {} foo {} foo {}}











































 
cleanupTests
return

# Local Variables:
# mode: tcl
# End:






|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
....
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
		lappend x [info class $cmd ::oo::$initial]
	    }
	}
	foreach initial {object class Slot} {
	    lappend x [info object class ::oo::$initial]
	}
	return $x
    }] {lsort [lmap y $x {if {[string match *::delegate $y]} continue; set y}]}
} -cleanup {
    interp delete $fresh
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}

test oo-2.1 {basic test of OO functionality: constructor} -setup {
    # This is a bit complex because it needs to run in a sub-interp as
    # we're modifying the root object class's constructor
................................................................................
	unexport foo
    }
    lappend result {*}[lmap s {public unexported private} {
	info class methods cls -scope $s}]
} -cleanup {
    cls destroy
} -result {{} {} foo {} foo {}}

test oo-41.1 {TIP 478: classmethod} -setup {
    oo::class create parent
} -body {
    oo::class create ActiveRecord {
	superclass parent
        classmethod find args { puts "[self] called with arguments: $args" }
    }
    oo::class create Table {
        superclass ActiveRecord
    }
    Table find foo bar
} -cleanup {
    parent destroy
} -output "::Table called with arguments: foo bar\n"
test oo-41.2 {TIP 478: classmethod in namespace} -setup {
    namespace eval ::testns {}
} -body {
    namespace eval ::testns {
	oo::class create ActiveRecord {
	    classmethod find args { puts "[self] called with arguments: $args" }
	}
	oo::class create Table {
	    superclass ActiveRecord
	}
    }
    testns::Table find foo bar
} -cleanup {
    namespace delete ::testns
} -output "::testns::Table called with arguments: foo bar\n"
test oo-41.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup {
    oo::class create parent
} -body {
    oo::class create TestClass {
        superclass oo::class parent
        self method create {name ignore body} {
            next $name $body
        }
    }
    TestClass create okay {} {}
} -cleanup {
    parent destroy
} -result {::okay}
 
cleanupTests
return

# Local Variables:
# mode: tcl
# End: