Tcl Source Code

Check-in [f1433a4120]
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:Split scripted parts of TclOO into their own file.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-478
Files: files | file ages | folders
SHA3-256: f1433a4120de1de83bd570b7428b4a72de87d1059402e4cd3dd13f54e10c5d26
User & Date: dkf 2018-06-17 15:42:58
Context
2018-06-17
16:47
Most of the implementation ported over. [classmethod] is trickier... check-in: c919d1df55 user: dkf tags: tip-478
15:42
Split scripted parts of TclOO into their own file. check-in: f1433a4120 user: dkf tags: tip-478
2018-06-16
22:57
Add tests/tcltests.tcl as a place to store common code for tests. check-in: 535977ae7d user: pooryorick tags: core-8-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOO.c.

148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
...
487
488
489
490
491
492
493





494
495
496
497
498
499
500
501
"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
"namespace eval ::oo { variable version " TCLOO_VERSION " };"
"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
/* "tcl_findLibrary tcloo $oo::version $oo::version" */
/* " tcloo.tcl OO_LIBRARY oo::library;"; */

/*
 * The scripted part of the definitions of slots.
 */

static const char *slotScript =
"::oo::define ::oo::Slot {\n"
"    method Get {} {error unimplemented}\n"
"    method Set list {error unimplemented}\n"
"    method -set args {\n"
"        uplevel 1 [list [namespace which my] Set $args]\n"
"    }\n"
"    method -append args {\n"
"        uplevel 1 [list [namespace which my] Set [list"
"                {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
"    }\n"
"    method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
"    forward --default-operation my -append\n"
"    method unknown {args} {\n"
"        set def --default-operation\n"
"        if {[llength $args] == 0} {\n"
"            return [uplevel 1 [list [namespace which my] $def]]\n"
"        } elseif {![string match -* [lindex $args 0]]} {\n"
"            return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
"        }\n"
"        next {*}$args\n"
"    }\n"
"    export -set -append -clear\n"
"    unexport unknown destroy\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";

/*
 * The body of the <cloned> method of oo::object.
 */

static const char *clonedBody =
"foreach p [info procs [info object namespace $originObject]::*] {"
"    set args [info args $p];"
"    set idx -1;"
"    foreach a $args {"
"        lset args [incr idx] "
"            [if {[info default $p $a d]} {list $a $d} {list $a}]"
"    };"
"    set b [info body $p];"
"    set p [namespace tail $p];"
"    proc $p $args $b;"
"};"
"foreach v [info vars [info object namespace $originObject]::*] {"
"    upvar 0 $v vOrigin;"
"    namespace upvar [namespace current] [namespace tail $v] vNew;"
"    if {[info exists vOrigin]} {"
"        if {[array exists vOrigin]} {"
"            array set vNew [array get vOrigin];"
"        } else {"
"            set vNew $vOrigin;"
"        }"
"    }"
"}";

/*
 * The actual definition of the variable holding the TclOO stub table.
 */

MODULE_SCOPE const TclOOStubs tclOOStubs;

................................................................................
    /*
     * Now make the class of slots.
     */

    if (TclOODefineSlots(fPtr) != TCL_OK) {
	return TCL_ERROR;
    }





    return Tcl_EvalEx(interp, slotScript, -1, 0);
}

/*
 * ----------------------------------------------------------------------
 *
 * InitClassSystemRoots --
 *






|


|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







>
>
>
>
>
|







148
149
150
151
152
153
154
155
156
157
158























































159
160
161
162
163
164
165
...
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
"namespace eval ::oo { variable version " TCLOO_VERSION " };"
"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
/* "tcl_findLibrary tcloo $oo::version $oo::version" */
/* " tcloo.tcl OO_LIBRARY oo::library;"; */

/*
 * The scripted part of the definitions of TclOO.
 */

#include "tclOOScript.h"
























































/*
 * The actual definition of the variable holding the TclOO stub table.
 */

MODULE_SCOPE const TclOOStubs tclOOStubs;

................................................................................
    /*
     * Now make the class of slots.
     */

    if (TclOODefineSlots(fPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Evaluate the remaining definitions, which are a compiled-in Tcl script.
     */

    return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0);
}

/*
 * ----------------------------------------------------------------------
 *
 * InitClassSystemRoots --
 *

Added generic/tclOOScript.h.










































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
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
/*
 * 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
 
/*
 * The scripted part of the definitions of TclOO.
 */

static const char *tclOOSetupScript =
"::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"
"        set current [uplevel 1 [list [namespace which my] Get]]\n"
"        tailcall my Set [list {*}$current {*}$args]\n"
"    }\n"
"    method -clear {} {tailcall my Set {}}\n"
"    forward --default-operation my -append\n"
"    method unknown {args} {\n"
"        set def --default-operation\n"
"        if {[llength $args] == 0} {\n"
"            tailcall my $def\n"
"        } elseif {![string match -* [lindex $args 0]]} {\n"
"            tailcall my $def {*}$args\n"
"        }\n"
"        next {*}$args\n"
"    }\n"
"    export -set -append -clear\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";

/*
 * The body of the <cloned> method of oo::object.
 */

static const char *clonedBody =
"foreach p [info procs [info object namespace $originObject]::*] {\n"
"    set args [info args $p]\n"
"    set idx -1\n"
"    foreach a $args {\n"
"        lset args [incr idx]"
"            [if {[info default $p $a d]} {list $a $d} {list $a}]\n"
"    }\n"
"    set b [info body $p]\n"
"    set p [namespace tail $p]\n"
"    proc $p $args $b\n"
"}\n"
"foreach v [info vars [info object namespace $originObject]::*] {\n"
"    upvar 0 $v vOrigin\n"
"    namespace upvar [namespace current] [namespace tail $v] vNew\n"
"    if {[info exists vOrigin]} {\n"
"        if {[array exists vOrigin]} {\n"
"            array set vNew [array get vOrigin]\n"
"        } else {\n"
"            set vNew $vOrigin\n"
"        }\n"
"    }\n"
"}\n";
 
#endif /* TCL_OO_SCRIPT_H */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to unix/Makefile.in.

1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR)
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c

tclNotify.o: $(GENERIC_DIR)/tclNotify.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c

tclOO.o: $(GENERIC_DIR)/tclOO.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c

tclOOBasic.o: $(GENERIC_DIR)/tclOOBasic.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOBasic.c

tclOOCall.o: $(GENERIC_DIR)/tclOOCall.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOCall.c






|







1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR)
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c

tclNotify.o: $(GENERIC_DIR)/tclNotify.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c

tclOO.o: $(GENERIC_DIR)/tclOO.c $(GENERIC_DIR)/tclOOScript.h
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c

tclOOBasic.o: $(GENERIC_DIR)/tclOOBasic.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOBasic.c

tclOOCall.o: $(GENERIC_DIR)/tclOOCall.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOCall.c