Improve script compilation. Prove that compilation works with safe interps.

1 files changed, 198 insertions, 218 deletions

diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index d89e81a..741a5c4 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -22,225 +22,205 @@
 
 static const char *tclOOSetupScript =
 /* !BEGIN!: Do not edit below this line. */
-"::namespace eval ::oo::Helpers {\n"
-"    ::namespace path {}\n"
-"\n"
-"    proc callback {method args} {\n"
-"        list [uplevel 1 {::namespace which my}] $method {*}$args\n"
-"    }\n"
-"\n"
-"    proc mymethod {method args} {\n"
-"        list [uplevel 1 {::namespace which my}] $method {*}$args\n"
-"    }\n"
-"\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"
-"        # Lastly, link the caller\'s local variables to the class\'s variables\n"
-"        tailcall namespace upvar $ns {*}$vs\n"
-"    }\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"
 "::namespace eval ::oo {\n"
-"    proc UnlinkLinkedCommand {cmd args} {\n"
-"        if {[namespace which $cmd] ne {}} {\n"
-"            rename $cmd {}\n"
-"        }\n"
-"    }\n"
-"\n"
-"    proc DelegateName {class} {\n"
-"        string cat [info object namespace $class] {:: oo ::delegate}\n"
-"    }\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"
-"\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"
-"    }\n"
-"}\n"
-"\n"
-"::namespace eval ::oo::define {\n"
-"    ::proc 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 [::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"
-"            ::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
-"        }\n"
-"        # Make the connection by forwarding\n"
-"        ::tailcall forward $name myclass $name\n"
-"    }\n"
-"\n"
-"    ::proc initialise {body} {\n"
-"        ::set clsns [::info object namespace [::uplevel 1 self]]\n"
-"        ::tailcall apply [::list {} $body $clsns]\n"
-"    }\n"
-"\n"
-"    # Make the initialise command appear with US spelling too\n"
-"    ::namespace export initialise\n"
-"    ::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
-"    ::rename ::oo::define::tmp::initialise initialize\n"
-"    ::namespace delete tmp\n"
-"    ::namespace export -clear\n"
-"}\n"
-"\n"
-"::oo::define ::oo::Slot {\n"
-"    method Get {} {return -code error unimplemented}\n"
-"    method Set list {return -code error unimplemented}\n"
-"\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"
-"\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"
-"\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"
-"\n"
-"::oo::define ::oo::object method <cloned> {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 <cloned> {originObject} {\n"
-"    next $originObject\n"
-"    # Rebuild the class inheritance delegation class\n"
-"    ::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
-"}\n"
-"\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] || ![info object isa object $object]} {\n"
-"            set object [next {*}$args]\n"
-"            ::oo::objdefine $object method destroy {} {\n"
-"                return -code error {may not destroy a singleton object}\n"
-"            }\n"
-"            ::oo::objdefine $object method <cloned> {originObject} {\n"
-"                return -code error {may not clone a singleton object}\n"
-"            }\n"
-"        }\n"
-"        return $object\n"
-"    }\n"
-"}\n"
-"\n"
-"::oo::class create ::oo::abstract {\n"
-"    superclass ::oo::class\n"
-"    unexport create createWithNamespace new\n"
+"\t::namespace path {}\n"
+"\tnamespace eval Helpers {\n"
+"\t\t::namespace path {}\n"
+"\t\tproc callback {method args} {\n"
+"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
+"\t\t}\n"
+"\t\tnamespace export callback\n"
+"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
+"\t\tnamespace export -clear\n"
+"\t\trename tmp::callback mymethod\n"
+"\t\tnamespace delete tmp\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"
+"\t\t\t}\n"
+"\t\t\ttailcall namespace upvar $ns {*}$vs\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 {TCLOO 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\t\t}\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc UnlinkLinkedCommand {cmd args} {\n"
+"\t\tif {[namespace which $cmd] ne {}} {\n"
+"\t\t\trename $cmd {}\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc DelegateName {class} {\n"
+"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n"
+"\t}\n"
+"\tproc MixinClassDelegates {class} {\n"
+"\t\tif {![info object isa class $class]} {\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\tset delegate [DelegateName $class]\n"
+"\t\tif {![info object isa class $delegate]} {\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\tforeach c [info class superclass $class] {\n"
+"\t\t\tset d [DelegateName $c]\n"
+"\t\t\tif {![info object isa class $d]} {\n"
+"\t\t\t\tcontinue\n"
+"\t\t\t}\n"
+"\t\t\tdefine $delegate superclass -append $d\n"
+"\t\t}\n"
+"\t\tobjdefine $class mixin -append $delegate\n"
+"\t}\n"
+"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
+"\t\tset originDelegate [DelegateName $originObject]\n"
+"\t\tset targetDelegate [DelegateName $targetObject]\n"
+"\t\tif {\n"
+"\t\t\t[info object isa class $originDelegate]\n"
+"\t\t\t&& ![info object isa class $targetDelegate]\n"
+"\t\t} then {\n"
+"\t\t\tcopy $originDelegate $targetDelegate\n"
+"\t\t\tobjdefine $targetObject mixin -set \\\n"
+"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
+"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
+"\t\t\t\t}]\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc define::classmethod {name {args {}} {body {}}} {\n"
+"\t\t::set argc [::llength [::info level 0]]\n"
+"\t\t::if {$argc == 3} {\n"
+"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n"
+"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n"
+"\t\t\t\t[::lindex [::info level 0] 0]]\n"
+"\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 $body\n"
+"\t\t}\n"
+"\t\t::tailcall forward $name myclass $name\n"
+"\t}\n"
+"\tproc define::initialise {body} {\n"
+"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n"
+"\t\t::tailcall apply [::list {} $body $clsns]\n"
+"\t}\n"
+"\tnamespace eval define {\n"
+"\t\t::namespace export initialise\n"
+"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
+"\t\t::namespace export -clear\n"
+"\t\t::rename tmp::initialise initialize\n"
+"\t\t::namespace delete tmp\n"
+"\t}\n"
+"\tdefine Slot {\n"
+"\t\tmethod Get {} {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod Set list {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod -set args {tailcall my Set $args}\n"
+"\t\tmethod -append args {\n"
+"\t\t\tset current [uplevel 1 [list [namespace which my] Get]]\n"
+"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
+"\t\t}\n"
+"\t\tmethod -clear {} {tailcall my Set {}}\n"
+"\t\tforward --default-operation my -append\n"
+"\t\tmethod unknown {args} {\n"
+"\t\t\tset def --default-operation\n"
+"\t\t\tif {[llength $args] == 0} {\n"
+"\t\t\t\ttailcall my $def\n"
+"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
+"\t\t\t\ttailcall my $def {*}$args\n"
+"\t\t\t}\n"
+"\t\t\tnext {*}$args\n"
+"\t\t}\n"
+"\t\texport -set -append -clear\n"
+"\t\tunexport unknown destroy\n"
+"\t}\n"
+"\tobjdefine define::superclass forward --default-operation my -set\n"
+"\tobjdefine define::mixin forward --default-operation my -set\n"
+"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
+"\tdefine object method <cloned> {originObject} {\n"
+"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
+"\t\t\tset args [info args $p]\n"
+"\t\t\tset idx -1\n"
+"\t\t\tforeach a $args {\n"
+"\t\t\t\tif {[info default $p $a d]} {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a]\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\tset b [info body $p]\n"
+"\t\t\tset p [namespace tail $p]\n"
+"\t\t\tproc $p $args $b\n"
+"\t\t}\n"
+"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n"
+"\t\t\tupvar 0 $v vOrigin\n"
+"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n"
+"\t\t\tif {[info exists vOrigin]} {\n"
+"\t\t\t\tif {[array exists vOrigin]} {\n"
+"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tset vNew $vOrigin\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t}\n"
+"\t}\n"
+"\tdefine class method <cloned> {originObject} {\n"
+"\t\tnext $originObject\n"
+"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
+"\t}\n"
+"\tclass create singleton {\n"
+"\t\tsuperclass class\n"
+"\t\tvariable object\n"
+"\t\tunexport create createWithNamespace\n"
+"\t\tmethod new args {\n"
+"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
+"\t\t\t\tset object [next {*}$args]\n"
+"\t\t\t\t::oo::objdefine $object {\n"
+"\t\t\t\t\tmethod destroy {} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
+"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\tmethod <cloned> {originObject} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
+"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\treturn $object\n"
+"\t\t}\n"
+"\t}\n"
+"\tclass create abstract {\n"
+"\t\tsuperclass class\n"
+"\t\tunexport create createWithNamespace new\n"
+"\t}\n"
 "}\n"
 /* !END!: Do not edit above this line. */
 ;