Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Accelerate definition of [oo::define initialise]. (backport) |
|---|---|
| Timelines: | family | ancestors | descendants | both | oo-accelerate-90 |
| Files: | files | file ages | folders |
| SHA3-256: |
486acd76fbe583c632d6e9bf31190aa8 |
| User & Date: | dkf 2025-08-22 17:15:48.338 |
Context
|
2025-08-22
| ||
| 17:17 | Slightly chisel down the execution time of the oo init script (backport) check-in: b8dd6bd10e user: dkf tags: oo-accelerate-90 | |
| 17:15 | Accelerate definition of [oo::define initialise]. (backport) check-in: 486acd76fb user: dkf tags: oo-accelerate-90 | |
| 15:02 | Start making TclOO faster to initialise (backport) check-in: 096119c82d user: dkf tags: oo-accelerate-90 | |
Changes
Changes to generic/tclOO.c.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
} defineCmds[] = {
{"constructor", TclOODefineConstructorObjCmd, 0},
{"definitionnamespace", TclOODefineDefnNsObjCmd, 0},
{"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
{"destructor", TclOODefineDestructorObjCmd, 0},
{"export", TclOODefineExportObjCmd, 0},
{"forward", TclOODefineForwardObjCmd, 0},
{"method", TclOODefineMethodObjCmd, 0},
{"private", TclOODefinePrivateObjCmd, 0},
{"renamemethod", TclOODefineRenameMethodObjCmd, 0},
{"self", TclOODefineSelfObjCmd, 0},
{"unexport", TclOODefineUnexportObjCmd, 0},
{NULL, NULL, 0}
}, objdefCmds[] = {
| > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
} defineCmds[] = {
{"constructor", TclOODefineConstructorObjCmd, 0},
{"definitionnamespace", TclOODefineDefnNsObjCmd, 0},
{"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
{"destructor", TclOODefineDestructorObjCmd, 0},
{"export", TclOODefineExportObjCmd, 0},
{"forward", TclOODefineForwardObjCmd, 0},
{"initialise", TclOODefineInitialiseObjCmd, 0},
{"initialize", TclOODefineInitialiseObjCmd, 0},
{"method", TclOODefineMethodObjCmd, 0},
{"private", TclOODefinePrivateObjCmd, 0},
{"renamemethod", TclOODefineRenameMethodObjCmd, 0},
{"self", TclOODefineSelfObjCmd, 0},
{"unexport", TclOODefineUnexportObjCmd, 0},
{NULL, NULL, 0}
}, objdefCmds[] = {
|
| ︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
| ︙ | ︙ | |||
2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 |
}
if (mPtr == NULL) {
Tcl_DecrRefCount(prefixObj);
return TCL_ERROR;
}
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOODefineMethodObjCmd --
*
* Implementation of the "method" subcommand of the "oo::define" and
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 |
}
if (mPtr == NULL) {
Tcl_DecrRefCount(prefixObj);
return TCL_ERROR;
}
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOODefineInitialiseObjCmd --
*
* Implementation of the "initialise" subcommand of the "oo::define"
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineInitialiseObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Object object;
Tcl_Obj *lambdaWords[3], *applyArgs[2];
int result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "body");
return TCL_ERROR;
}
// Build the lambda
object = TclOOGetDefineCmdContext(interp);
if (object == NULL) {
return TCL_ERROR;
}
lambdaWords[0] = Tcl_NewObj();
lambdaWords[1] = objv[1];
lambdaWords[2] = TclNewNamespaceObj(Tcl_GetObjectNamespace(object));
// Delegate to [apply] to run it
applyArgs[0] = Tcl_NewStringObj("apply", -1);
applyArgs[1] = Tcl_NewListObj(3, lambdaWords);
Tcl_IncrRefCount(applyArgs[0]);
Tcl_IncrRefCount(applyArgs[1]);
result = Tcl_ApplyObjCmd(NULL, interp, 2, applyArgs);
Tcl_DecrRefCount(applyArgs[0]);
Tcl_DecrRefCount(applyArgs[1]);
return result;
}
/*
* ----------------------------------------------------------------------
*
* TclOODefineMethodObjCmd --
*
* Implementation of the "method" subcommand of the "oo::define" and
|
| ︙ | ︙ |
Changes to generic/tclOOInt.h.
| ︙ | ︙ | |||
500 501 502 503 504 505 506 507 508 509 510 511 512 513 | MODULE_SCOPE Tcl_ObjCmdProc TclOOObjDefObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineConstructorObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDefnNsObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDeleteMethodObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDestructorObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineExportObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineForwardObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineMethodObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineRenameMethodObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineUnexportObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineSelfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjSelfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd; | > | 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 | MODULE_SCOPE Tcl_ObjCmdProc TclOOObjDefObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineConstructorObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDefnNsObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDeleteMethodObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDestructorObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineExportObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineForwardObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineInitialiseObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineMethodObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineRenameMethodObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineUnexportObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineSelfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjSelfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd; |
| ︙ | ︙ |
Changes to generic/tclOOScript.h.
| ︙ | ︙ | |||
117 118 119 120 121 122 123 |
"\t\t}\n"
"\t\t::set cls [::uplevel 1 self]\n"
"\t\t::if {$argc == 4} {\n"
"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n"
"\t\t}\n"
"\t\t::tailcall forward $name myclass $name\n"
"\t}\n"
| < < < < < < < < < < < | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
"\t\t}\n"
"\t\t::set cls [::uplevel 1 self]\n"
"\t\t::if {$argc == 4} {\n"
"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n"
"\t\t}\n"
"\t\t::tailcall forward $name myclass $name\n"
"\t}\n"
"\tdefine Slot {\n"
"\t\tmethod Get -unexport {} {\n"
"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Set -unexport list {\n"
"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
|
| ︙ | ︙ |
Changes to tests/ooUtil.test.
| ︙ | ︙ | |||
362 363 364 365 366 367 368 |
lappend ::result {*}$args
}
set result {}
} -body {
trace add execution oo::define::initialise enter appendToResultVar
oo::class create ::cls {
superclass parent
| | | < < < < < < | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 |
lappend ::result {*}$args
}
set result {}
} -body {
trace add execution oo::define::initialise enter appendToResultVar
oo::class create ::cls {
superclass parent
initialise {proc xyzzy {} {}}
}
return $result
} -cleanup {
catch {
trace remove execution oo::define::initialise enter appendToResultVar
}
rename ::appendToResultVar {}
parent destroy
} -result {{initialise {proc xyzzy {} {}}} enter}
test ooUtil-4.1 {TIP 478: singleton} -setup {
oo::class create parent
} -body {
oo::singleton create xyz {
superclass parent
}
|
| ︙ | ︙ |
Changes to tools/tclOOScript.tcl.
| ︙ | ︙ | |||
187 188 189 190 191 192 193 |
::if {$argc == 4} {
::oo::define [::oo::DelegateName $cls] method $name {*}$args
}
# Make the connection by forwarding
::tailcall forward $name myclass $name
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
::if {$argc == 4} {
::oo::define [::oo::DelegateName $cls] method $name {*}$args
}
# Make the connection by forwarding
::tailcall forward $name myclass $name
}
# ----------------------------------------------------------------------
#
# Slot --
#
# The class of slot operations, which are basically lists at the low
# level of TclOO; this provides a more consistent interface to them.
#
|
| ︙ | ︙ |