From ed3e9c60bac115e7ad38b1169dacc8bf974e99d2 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 5 Aug 2018 20:14:04 +0000 Subject: Combine the two bits of scripted code inside TclOO's definition into one. --- generic/tclOO.c | 14 +--- generic/tclOOScript.h | 215 +++++++++++++++++++++++++++--------------------- generic/tclOOScript.tcl | 188 +++++++++++++++++++++++++++--------------- tools/makeHeader.tcl | 2 +- 4 files changed, 244 insertions(+), 175 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 630e977..7702b2b 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -312,7 +312,7 @@ InitFoundation( ThreadLocalData *tsdPtr = Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); Foundation *fPtr = ckalloc(sizeof(Foundation)); - Tcl_Obj *namePtr, *argsPtr, *bodyPtr; + Tcl_Obj *namePtr; Tcl_DString buffer; Command *cmdPtr; int i; @@ -392,18 +392,6 @@ InitFoundation( } /* - * Create the default method implementation, used when 'oo::copy' - * is called to finish the copying of one object to another. - */ - - TclNewLiteralStringObj(argsPtr, "originObject"); - Tcl_IncrRefCount(argsPtr); - bodyPtr = Tcl_NewStringObj(clonedBody, -1); - TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr, - bodyPtr, NULL); - TclDecrRefCount(argsPtr); - - /* * Finish setting up the class of classes by marking the 'new' method as * private; classes, unlike general objects, must have explicit names. We * also need to create the constructor for classes. diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 1f345fb..d89e81a 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -22,74 +22,103 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ -"::proc ::oo::Helpers::callback {method args} {\n" -" list [uplevel 1 {namespace which my}] $method {*}$args\n" -"}\n" +"::namespace eval ::oo::Helpers {\n" +" ::namespace path {}\n" "\n" -"::proc ::oo::Helpers::mymethod {method args} {\n" -" list [uplevel 1 {namespace which my}] $method {*}$args\n" -"}\n" +" proc callback {method args} {\n" +" list [uplevel 1 {::namespace which my}] $method {*}$args\n" +" }\n" "\n" -"::proc ::oo::Helpers::classvariable {name args} {\n" -" # Get a reference to the class\'s namespace\n" -" set ns [info object namespace [uplevel 1 {self class}]]\n" -" # Double up the list of variable names\n" -" foreach v [list $name {*}$args] {\n" -" if {[string match *(*) $v]} {\n" -" return -code error [string cat {bad variable name \"} $v {\": can\'t create a scalar variable that looks like an array element}]\n" -" }\n" -" if {[string match *::* $v]} {\n" -" return -code error [string cat {bad variable name \"} $v {\": can\'t create a local variable with a namespace separator in it}]\n" -" }\n" -" lappend vs $v $v\n" +" proc mymethod {method args} {\n" +" list [uplevel 1 {::namespace which my}] $method {*}$args\n" " }\n" -" # Lastly, link the caller\'s local variables to the class\'s variables\n" -" tailcall namespace upvar $ns {*}$vs\n" -"}\n" "\n" -"::proc ::oo::Helpers::link {args} {\n" -" set ns [uplevel 1 {namespace current}]\n" -" foreach link $args {\n" -" if {[llength $link] == 2} {\n" -" lassign $link src dst\n" -" } else {\n" -" lassign $link src\n" -" set dst $src\n" -" }\n" -" if {![string match ::* $src]} {\n" -" set src [string cat $ns :: $src]\n" +" proc classvariable {name args} {\n" +" # Get a reference to the class\'s namespace\n" +" set ns [info object namespace [uplevel 1 {self class}]]\n" +" # Double up the list of variable names\n" +" foreach v [list $name {*}$args] {\n" +" if {[string match *(*) $v]} {\n" +" variable \n" +" return -code error [format \\\n" +" {bad variable name \"%s\": can\'t create a scalar variable that looks like an array element} \\\n" +" $v]\n" +" }\n" +" if {[string match *::* $v]} {\n" +" return -code error [format \\\n" +" {bad variable name \"%s\": can\'t create a local variable with a namespace separator in it} \\\n" +" $v]\n" +" }\n" +" lappend vs $v $v\n" " }\n" -" interp alias {} $src {} ${ns}::my $dst\n" -" trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src]\n" +" # Lastly, link the caller\'s local variables to the class\'s variables\n" +" tailcall namespace upvar $ns {*}$vs\n" " }\n" -" return\n" -"}\n" -"::proc ::oo::Helpers::Unlink {cmd args} {\n" -" if {[namespace which $cmd] ne {}} {\n" -" rename $cmd {}\n" +"\n" +" proc link {args} {\n" +" set ns [uplevel 1 {::namespace current}]\n" +" foreach link $args {\n" +" if {[llength $link] == 2} {\n" +" lassign $link src dst\n" +" } else {\n" +" lassign $link src\n" +" set dst $src\n" +" }\n" +" if {![string match ::* $src]} {\n" +" set src [string cat $ns :: $src]\n" +" }\n" +" interp alias {} $src {} ${ns}::my $dst\n" +" trace add command ${ns}::my delete [list \\\n" +" ::oo::UnlinkLinkedCommand $src]\n" +" }\n" +" return\n" " }\n" "}\n" "\n" -"::proc ::oo::DelegateName {class} {\n" -" string cat [info object namespace $class] {:: oo ::delegate}\n" -"}\n" +"::namespace eval ::oo {\n" +" proc UnlinkLinkedCommand {cmd args} {\n" +" if {[namespace which $cmd] ne {}} {\n" +" rename $cmd {}\n" +" }\n" +" }\n" "\n" -"proc ::oo::MixinClassDelegates {class} {\n" -" if {![info object isa class $class]} {\n" -" return\n" +" proc DelegateName {class} {\n" +" string cat [info object namespace $class] {:: oo ::delegate}\n" " }\n" -" set delegate [::oo::DelegateName $class]\n" -" if {![info object isa class $delegate]} {\n" -" return\n" +"\n" +" proc MixinClassDelegates {class} {\n" +" if {![info object isa class $class]} {\n" +" return\n" +" }\n" +" set delegate [DelegateName $class]\n" +" if {![info object isa class $delegate]} {\n" +" return\n" +" }\n" +" foreach c [info class superclass $class] {\n" +" set d [DelegateName $c]\n" +" if {![info object isa class $d]} {\n" +" continue\n" +" }\n" +" define $delegate superclass -append $d\n" +" }\n" +" objdefine $class mixin -append $delegate\n" " }\n" -" foreach c [info class superclass $class] {\n" -" set d [::oo::DelegateName $c]\n" -" if {![info object isa class $d]} {\n" -" continue\n" +"\n" +" proc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" +" # Rebuild the class inheritance delegation class\n" +" set originDelegate [DelegateName $originObject]\n" +" set targetDelegate [DelegateName $targetObject]\n" +" if {\n" +" [info object isa class $originDelegate]\n" +" && ![info object isa class $targetDelegate]\n" +" } then {\n" +" copy $originDelegate $targetDelegate\n" +" objdefine $targetObject mixin -set \\\n" +" {*}[lmap c [info object mixin $targetObject] {\n" +" if {$c eq $originDelegate} {set targetDelegate} {set c}\n" +" }]\n" " }\n" -" ::oo::define $delegate superclass -append $d\n" " }\n" -" ::oo::objdefine $class mixin -append $delegate\n" "}\n" "\n" "::namespace eval ::oo::define {\n" @@ -97,8 +126,9 @@ static const char *tclOOSetupScript = " # 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 \"} \\\n" -" [::lindex [::info level 0] 0] { name \?args body\?\"}]\n" +" ::return -code error [::format \\\n" +" {wrong # args: should be \"%s name \?args body\?\"} \\\n" +" [::lindex [::info level 0] 0]]\n" " }\n" " ::set cls [::uplevel 1 self]\n" " ::if {$argc == 4} {\n" @@ -151,17 +181,43 @@ static const char *tclOOSetupScript = "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" "::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n" "\n" +"::oo::define ::oo::object method {originObject} {\n" +" # Copy over the procedures from the original namespace\n" +" foreach p [info procs [info object namespace $originObject]::*] {\n" +" set args [info args $p]\n" +" set idx -1\n" +" foreach a $args {\n" +" if {[info default $p $a d]} {\n" +" lset args [incr idx] [list $a $d]\n" +" } else {\n" +" lset args [incr idx] [list $a]\n" +" }\n" +" }\n" +" set b [info body $p]\n" +" set p [namespace tail $p]\n" +" proc $p $args $b\n" +" }\n" +" # Copy over the variables from the original namespace\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" +" # General commands, sub-namespaces and advancd variable config (traces,\n" +" # etc) are *not* copied over. Classes that want that should do it\n" +" # themselves.\n" +"}\n" +"\n" "::oo::define ::oo::class method {originObject} {\n" " next $originObject\n" " # Rebuild the class inheritance delegation class\n" -" set originDelegate [::oo::DelegateName $originObject]\n" -" set targetDelegate [::oo::DelegateName [self]]\n" -" if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} {\n" -" ::oo::copy $originDelegate $targetDelegate\n" -" ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] {\n" -" if {$c eq $originDelegate} {set targetDelegate} {set c}\n" -" }]\n" -" }\n" +" ::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" "}\n" "\n" "::oo::class create ::oo::singleton {\n" @@ -188,37 +244,6 @@ static const char *tclOOSetupScript = "}\n" /* !END!: Do not edit above this line. */ ; - -/* - * The body of the method of oo::object. - */ - -static const char *clonedBody = -"# Copy over the procedures from the original namespace\n" -"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" -"# Copy over the variables from the original namespace\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 */ diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl index e0af23f..c0b4d1f 100644 --- a/generic/tclOOScript.tcl +++ b/generic/tclOOScript.tcl @@ -11,74 +11,103 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -::proc ::oo::Helpers::callback {method args} { - list [uplevel 1 {namespace which my}] $method {*}$args -} +::namespace eval ::oo::Helpers { + ::namespace path {} -::proc ::oo::Helpers::mymethod {method args} { - list [uplevel 1 {namespace which my}] $method {*}$args -} + proc callback {method args} { + list [uplevel 1 {::namespace which my}] $method {*}$args + } -::proc ::oo::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]} { - return -code error [string cat {bad variable name "} $v {": can't create a scalar variable that looks like an array element}] - } - if {[string match *::* $v]} { - return -code error [string cat {bad variable name "} $v {": can't create a local variable with a namespace separator in it}] - } - lappend vs $v $v + proc mymethod {method args} { + list [uplevel 1 {::namespace which my}] $method {*}$args } - # Lastly, link the caller's local variables to the class's variables - tailcall namespace upvar $ns {*}$vs -} -::proc ::oo::Helpers::link {args} { - set ns [uplevel 1 {namespace current}] - foreach link $args { - if {[llength $link] == 2} { - lassign $link src dst - } else { - lassign $link src - set dst $src - } - if {![string match ::* $src]} { - set src [string cat $ns :: $src] - } - interp alias {} $src {} ${ns}::my $dst - trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src] + 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]} { + variable + return -code error [format \ + {bad variable name "%s": can't create a scalar variable that looks like an array element} \ + $v] + } + if {[string match *::* $v]} { + return -code error [format \ + {bad variable name "%s": can't create a local variable with a namespace separator in it} \ + $v] + } + lappend vs $v $v + } + # Lastly, link the caller's local variables to the class's variables + tailcall namespace upvar $ns {*}$vs } - return -} -::proc ::oo::Helpers::Unlink {cmd args} { - if {[namespace which $cmd] ne {}} { - rename $cmd {} + + proc link {args} { + set ns [uplevel 1 {::namespace current}] + foreach link $args { + if {[llength $link] == 2} { + lassign $link src dst + } else { + lassign $link src + set dst $src + } + 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] + } + return } } -::proc ::oo::DelegateName {class} { - string cat [info object namespace $class] {:: oo ::delegate} -} +::namespace eval ::oo { + proc UnlinkLinkedCommand {cmd args} { + if {[namespace which $cmd] ne {}} { + rename $cmd {} + } + } -proc ::oo::MixinClassDelegates {class} { - if {![info object isa class $class]} { - return + proc DelegateName {class} { + string cat [info object namespace $class] {:: oo ::delegate} } - set delegate [::oo::DelegateName $class] - if {![info object isa class $delegate]} { - return + + proc MixinClassDelegates {class} { + if {![info object isa class $class]} { + return + } + set delegate [DelegateName $class] + if {![info object isa class $delegate]} { + return + } + foreach c [info class superclass $class] { + set d [DelegateName $c] + if {![info object isa class $d]} { + continue + } + define $delegate superclass -append $d + } + objdefine $class mixin -append $delegate } - foreach c [info class superclass $class] { - set d [::oo::DelegateName $c] - if {![info object isa class $d]} { - continue - } - ::oo::define $delegate superclass -append $d + + proc UpdateClassDelegatesAfterClone {originObject targetObject} { + # Rebuild the class inheritance delegation class + set originDelegate [DelegateName $originObject] + set targetDelegate [DelegateName $targetObject] + if { + [info object isa class $originDelegate] + && ![info object isa class $targetDelegate] + } then { + copy $originDelegate $targetDelegate + objdefine $targetObject mixin -set \ + {*}[lmap c [info object mixin $targetObject] { + if {$c eq $originDelegate} {set targetDelegate} {set c} + }] + } } - ::oo::objdefine $class mixin -append $delegate } ::namespace eval ::oo::define { @@ -86,8 +115,9 @@ proc ::oo::MixinClassDelegates {class} { # Create the method on the class if the caller gave arguments and body ::set argc [::llength [::info level 0]] ::if {$argc == 3} { - ::return -code error [::string cat {wrong # args: should be "} \ - [::lindex [::info level 0] 0] { name ?args body?"}] + ::return -code error [::format \ + {wrong # args: should be "%s name ?args body?"} \ + [::lindex [::info level 0] 0]] } ::set cls [::uplevel 1 self] ::if {$argc == 4} { @@ -140,17 +170,43 @@ proc ::oo::MixinClassDelegates {class} { ::oo::objdefine ::oo::define::mixin forward --default-operation my -set ::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set +::oo::define ::oo::object method {originObject} { + # Copy over the procedures from the original namespace + foreach p [info procs [info object namespace $originObject]::*] { + set args [info args $p] + set idx -1 + foreach a $args { + if {[info default $p $a d]} { + lset args [incr idx] [list $a $d] + } else { + lset args [incr idx] [list $a] + } + } + set b [info body $p] + set p [namespace tail $p] + proc $p $args $b + } + # Copy over the variables from the original namespace + 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 + } + } + } + # General commands, sub-namespaces and advancd variable config (traces, + # etc) are *not* copied over. Classes that want that should do it + # themselves. +} + ::oo::define ::oo::class method {originObject} { next $originObject # Rebuild the class inheritance delegation class - set originDelegate [::oo::DelegateName $originObject] - set targetDelegate [::oo::DelegateName [self]] - if {[info object isa class $originDelegate] && ![info object isa class $targetDelegate]} { - ::oo::copy $originDelegate $targetDelegate - ::oo::objdefine [self] mixin -set {*}[lmap c [info object mixin [self]] { - if {$c eq $originDelegate} {set targetDelegate} {set c} - }] - } + ::oo::UpdateClassDelegatesAfterClone $originObject [self] } ::oo::class create ::oo::singleton { diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl index 8af35fc..5197da6 100644 --- a/tools/makeHeader.tcl +++ b/tools/makeHeader.tcl @@ -21,7 +21,7 @@ namespace eval makeHeader { # All Tcl metacharacters and key C backslash sequences set MAP { \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\? - \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v + \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t { } \v \\\\v } set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]} -- cgit v0.12