From a83fb66df9efd409bf5b52860e816152d1443f8f Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 17:17:22 +0000 Subject: Slightly chisel down the execution time of the oo init script (backport) --- generic/tclOOScript.h | 97 +++++++++++++-------------- tools/tclOOScript.tcl | 179 ++++++++++++++++++++++++-------------------------- 2 files changed, 131 insertions(+), 145 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index ff29535..7b8a69d 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -27,46 +27,41 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ "::namespace eval ::oo {\n" -"\t::namespace path {}\n" -"\tnamespace eval Helpers {\n" -"\t\tnamespace path {}\n" -"\t\tproc classvariable {name args} {\n" -"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" -"\t\t\tforeach v [list $name {*}$args] {\n" -"\t\t\t\tif {[string match *(*) $v]} {\n" -"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n" -"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n" -"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" -"\t\t\t\t}\n" -"\t\t\t\tif {[string match *::* $v]} {\n" -"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n" -"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n" -"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" -"\t\t\t\t}\n" -"\t\t\t\tlappend vs $v $v\n" +"\tproc Helpers::classvariable {name args} {\n" +"\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" +"\t\tforeach v [list $name {*}$args] {\n" +"\t\t\tif {[string match *(*) $v]} {\n" +"\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n" +"\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n" +"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" "\t\t\t}\n" -"\t\t\ttailcall namespace upvar $ns {*}$vs\n" +"\t\t\tif {[string match *::* $v]} {\n" +"\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n" +"\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n" +"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" +"\t\t\t}\n" +"\t\t\tlappend vs $v $v\n" "\t\t}\n" -"\t\tproc link {args} {\n" -"\t\t\tset ns [uplevel 1 {::namespace current}]\n" -"\t\t\tforeach link $args {\n" -"\t\t\t\tif {[llength $link] == 2} {\n" -"\t\t\t\t\tlassign $link src dst\n" -"\t\t\t\t} elseif {[llength $link] == 1} {\n" -"\t\t\t\t\tlassign $link src\n" -"\t\t\t\t\tset dst $src\n" -"\t\t\t\t} else {\n" -"\t\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n" -"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" -"\t\t\t\t}\n" -"\t\t\t\tif {![string match ::* $src]} {\n" -"\t\t\t\t\tset src [string cat $ns :: $src]\n" -"\t\t\t\t}\n" -"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" -"\t\t\t\ttrace add command ${ns}::my delete [list \\\n" -"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" +"\t\ttailcall namespace upvar $ns {*}$vs\n" +"\t}\n" +"\tproc Helpers::link {args} {\n" +"\t\tset ns [uplevel 1 {::namespace current}]\n" +"\t\tforeach link $args {\n" +"\t\t\tif {[llength $link] == 2} {\n" +"\t\t\t\tlassign $link src dst\n" +"\t\t\t} elseif {[llength $link] == 1} {\n" +"\t\t\t\tlassign $link src\n" +"\t\t\t\tset dst $src\n" +"\t\t\t} else {\n" +"\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n" +"\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" "\t\t\t}\n" -"\t\t\treturn\n" +"\t\t\tif {![string match ::* $src]} {\n" +"\t\t\t\tset src [string cat $ns :: $src]\n" +"\t\t\t}\n" +"\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" +"\t\t\ttrace add command ${ns}::my delete [list \\\n" +"\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" "\t\t}\n" "\t}\n" "\tproc UnlinkLinkedCommand {cmd args} {\n" @@ -239,21 +234,19 @@ static const char *tclOOSetupScript = "\t\tsuperclass class\n" "\t\tunexport create createWithNamespace new\n" "\t}\n" -"\tnamespace eval configuresupport {\n" -"\t\t::namespace eval configurableclass {\n" -"\t\t\t::proc properties args {::tailcall property {*}$args}\n" -"\t\t\t::namespace path ::oo::define\n" -"\t\t\t::namespace export property\n" -"\t\t}\n" -"\t\t::namespace eval configurableobject {\n" -"\t\t\t::proc properties args {::tailcall property {*}$args}\n" -"\t\t\t::namespace path ::oo::objdefine\n" -"\t\t\t::namespace export property\n" -"\t\t}\n" -"\t\t::oo::define configurable {\n" -"\t\t\tdefinitionnamespace -instance configurableobject\n" -"\t\t\tdefinitionnamespace -class configurableclass\n" -"\t\t}\n" +"\tnamespace eval configuresupport::configurableclass {\n" +"\t\t::proc properties args {::tailcall property {*}$args}\n" +"\t\t::namespace path ::oo::define\n" +"\t\t::namespace export property\n" +"\t}\n" +"\tnamespace eval configuresupport::configurableobject {\n" +"\t\t::proc properties args {::tailcall property {*}$args}\n" +"\t\t::namespace path ::oo::objdefine\n" +"\t\t::namespace export property\n" +"\t}\n" +"\tdefine configuresupport::configurable {\n" +"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" +"\t\tdefinitionnamespace -class configuresupport::configurableclass\n" "\t}\n" "\tclass create configurable {\n" "\t\tsuperclass class\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index b60542f..442756d 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -12,73 +12,68 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. ::namespace eval ::oo { - ::namespace path {} # # Commands that are made available to objects by default. # - namespace eval Helpers { - namespace path {} - # ------------------------------------------------------------------ - # - # classvariable -- - # - # Link to a variable in the class of the current object. - # - # ------------------------------------------------------------------ + # ------------------------------------------------------------------ + # + # classvariable -- + # + # Link to a variable in the class of the current object. + # + # ------------------------------------------------------------------ - proc classvariable {name args} { - # Get a reference to the class's namespace - set ns [info object namespace [uplevel 1 {self class}]] - # Double up the list of variable names - foreach v [list $name {*}$args] { - if {[string match *(*) $v]} { - set reason "can't create a scalar variable that looks like an array element" - return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \ - [format {bad variable name "%s": %s} $v $reason] - } - if {[string match *::* $v]} { - set reason "can't create a local variable with a namespace separator in it" - return -code error -errorcode {TCL UPVAR INVERTED} \ - [format {bad variable name "%s": %s} $v $reason] - } - lappend vs $v $v + proc Helpers::classvariable {name args} { + # Get a reference to the class's namespace + set ns [info object namespace [uplevel 1 {self class}]] + # Double up the list of variable names + foreach v [list $name {*}$args] { + if {[string match *(*) $v]} { + set reason "can't create a scalar variable that looks like an array element" + return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \ + [format {bad variable name "%s": %s} $v $reason] + } + if {[string match *::* $v]} { + set reason "can't create a local variable with a namespace separator in it" + return -code error -errorcode {TCL UPVAR INVERTED} \ + [format {bad variable name "%s": %s} $v $reason] } - # Lastly, link the caller's local variables to the class's variables - tailcall namespace upvar $ns {*}$vs + lappend vs $v $v } + # Lastly, link the caller's local variables to the class's variables + tailcall namespace upvar $ns {*}$vs + } - # ------------------------------------------------------------------ - # - # link -- - # - # Make a command that invokes a method on the current object. - # The name of the command and the name of the method match by - # default. - # - # ------------------------------------------------------------------ + # ------------------------------------------------------------------ + # + # link -- + # + # Make a command that invokes a method on the current object. + # The name of the command and the name of the method match by + # default. + # + # ------------------------------------------------------------------ - proc link {args} { - set ns [uplevel 1 {::namespace current}] - foreach link $args { - if {[llength $link] == 2} { - lassign $link src dst - } elseif {[llength $link] == 1} { - lassign $link src - set dst $src - } else { - return -code error -errorcode {TCL OO CMDLINK_FORMAT} \ - "bad link description; must only have one or two elements" - } - if {![string match ::* $src]} { - set src [string cat $ns :: $src] - } - interp alias {} $src {} ${ns}::my $dst - trace add command ${ns}::my delete [list \ - ::oo::UnlinkLinkedCommand $src] + proc Helpers::link {args} { + set ns [uplevel 1 {::namespace current}] + foreach link $args { + if {[llength $link] == 2} { + lassign $link src dst + } elseif {[llength $link] == 1} { + lassign $link src + set dst $src + } else { + return -code error -errorcode {TCL OO CMDLINK_FORMAT} \ + "bad link description; must only have one or two elements" } - return + if {![string match ::* $src]} { + set src [string cat $ns :: $src] + } + interp alias {} $src {} ${ns}::my $dst + trace add command ${ns}::my delete [list \ + ::oo::UnlinkLinkedCommand $src] } } @@ -437,47 +432,45 @@ # # ---------------------------------------------------------------------- - namespace eval configuresupport { - # ------------------------------------------------------------------ - # - # oo::configuresupport::configurableclass, - # oo::configuresupport::configurableobject -- - # - # Namespaces used as implementation vectors for oo::define and - # oo::objdefine when the class/instance is configurable. - # Note that these also contain commands implemented in C, - # especially the [property] definition command. - # - # ------------------------------------------------------------------ + # ------------------------------------------------------------------ + # + # oo::configuresupport::configurableclass, + # oo::configuresupport::configurableobject -- + # + # Namespaces used as implementation vectors for oo::define and + # oo::objdefine when the class/instance is configurable. + # Note that these also contain commands implemented in C, + # especially the [property] definition command. + # + # ------------------------------------------------------------------ - ::namespace eval configurableclass { - # Plural alias just in case; deliberately NOT documented! - ::proc properties args {::tailcall property {*}$args} - ::namespace path ::oo::define - ::namespace export property - } + namespace eval configuresupport::configurableclass { + # Plural alias just in case; deliberately NOT documented! + ::proc properties args {::tailcall property {*}$args} + ::namespace path ::oo::define + ::namespace export property + } - ::namespace eval configurableobject { - # Plural alias just in case; deliberately NOT documented! - ::proc properties args {::tailcall property {*}$args} - ::namespace path ::oo::objdefine - ::namespace export property - } + namespace eval configuresupport::configurableobject { + # Plural alias just in case; deliberately NOT documented! + ::proc properties args {::tailcall property {*}$args} + ::namespace path ::oo::objdefine + ::namespace export property + } - # ------------------------------------------------------------------ - # - # oo::configuresupport::configurable -- - # - # The class that contains the implementation of the actual - # 'configure' method (mixed into actually configurable classes). - # The 'configure' method is in tclOOBasic.c. - # - # ------------------------------------------------------------------ + # ------------------------------------------------------------------ + # + # oo::configuresupport::configurable -- + # + # The class that contains the implementation of the actual + # 'configure' method (mixed into actually configurable classes). + # The 'configure' method is in tclOOBasic.c. + # + # ------------------------------------------------------------------ - ::oo::define configurable { - definitionnamespace -instance configurableobject - definitionnamespace -class configurableclass - } + define configuresupport::configurable { + definitionnamespace -instance configuresupport::configurableobject + definitionnamespace -class configuresupport::configurableclass } # ---------------------------------------------------------------------- -- cgit v0.12