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

4 files changed, 572 insertions, 352 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. */
 ;
diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl
index c0b4d1f..d3706ce 100644
--- a/generic/tclOOScript.tcl
+++ b/generic/tclOOScript.tcl
@@ -11,70 +11,135 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
-::namespace eval ::oo::Helpers {
+::namespace eval ::oo {
     ::namespace path {}
 
-    proc callback {method args} {
-	list [uplevel 1 {::namespace which my}] $method {*}$args
-    }
+    #
+    # Commands that are made available to objects by default.
+    #
+    namespace eval Helpers {
+	::namespace path {}
 
-    proc mymethod {method args} {
-	list [uplevel 1 {::namespace which my}] $method {*}$args
-    }
+	# ------------------------------------------------------------------
+	#
+	# callback, mymethod --
+	#
+	#	Create a script prefix that calls a method on the current
+	#	object. Same operation, two names.
+	#
+	# ------------------------------------------------------------------
 
-    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
+	proc callback {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 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
+	# Make the [callback] command appear as [mymethod] too.
+	namespace export callback
+	namespace eval tmp {namespace import ::oo::Helpers::callback}
+	namespace export -clear
+	rename tmp::callback mymethod
+	namespace delete tmp
+
+	# ------------------------------------------------------------------
+	#
+	# 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
 	    }
-	    if {![string match ::* $src]} {
-		set src [string cat $ns :: $src]
+	    # 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.
+	#
+	# ------------------------------------------------------------------
+
+	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 {TCLOO 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]
 	    }
-	    interp alias {} $src {} ${ns}::my $dst
-	    trace add command ${ns}::my delete [list \
-		::oo::UnlinkLinkedCommand $src]
+	    return
 	}
-	return
     }
-}
 
-::namespace eval ::oo {
+    # ----------------------------------------------------------------------
+    #
+    # UnlinkLinkedCommand --
+    #
+    #	Callback used to remove linked command when the underlying mechanism
+    #	that supports it is deleted.
+    #
+    # ----------------------------------------------------------------------
+
     proc UnlinkLinkedCommand {cmd args} {
 	if {[namespace which $cmd] ne {}} {
 	    rename $cmd {}
 	}
     }
 
+    # ----------------------------------------------------------------------
+    #
+    # DelegateName --
+    #
+    #	Utility that gets the name of the class delegate for a class. It's
+    #	trivial, but makes working with them much easier as delegate names are
+    #	intentionally hard to create by accident.
+    #
+    # ----------------------------------------------------------------------
+
     proc DelegateName {class} {
 	string cat [info object namespace $class] {:: oo ::delegate}
     }
 
+    # ----------------------------------------------------------------------
+    #
+    # MixinClassDelegates --
+    #
+    #	Support code called *after* [oo::define] inside the constructor of a
+    #	class that patches in the appropriate class delegates.
+    #
+    # ----------------------------------------------------------------------
+
     proc MixinClassDelegates {class} {
 	if {![info object isa class $class]} {
 	    return
@@ -93,6 +158,15 @@
 	objdefine $class mixin -append $delegate
     }
 
+    # ----------------------------------------------------------------------
+    #
+    # UpdateClassDelegatesAfterClone --
+    #
+    #	Support code that is like [MixinClassDelegates] except for when a
+    #	class is cloned.
+    #
+    # ----------------------------------------------------------------------
+
     proc UpdateClassDelegatesAfterClone {originObject targetObject} {
 	# Rebuild the class inheritance delegation class
 	set originDelegate [DelegateName $originObject]
@@ -108,14 +182,24 @@
 		}]
 	}
     }
-}
 
-::namespace eval ::oo::define {
-    ::proc classmethod {name {args {}} {body {}}} {
+    # ----------------------------------------------------------------------
+    #
+    # oo::define::classmethod --
+    #
+    #	Defines a class method. See define(n) for details.
+    #
+    # Note that the ::oo::define namespace is semi-public and a bit weird
+    # anyway, so we don't regard the namespace path as being under control:
+    # fully qualified names are used for everything.
+    #
+    # ----------------------------------------------------------------------
+
+    proc define::classmethod {name {args {}} {body {}}} {
         # 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 [::format \
+            ::return -code error -errorcode {TCL WRONGARGS} [::format \
 		{wrong # args: should be "%s name ?args body?"} \
                 [::lindex [::info level 0] 0]]
         }
@@ -127,109 +211,208 @@
         ::tailcall forward $name myclass $name
     }
 
-    ::proc initialise {body} {
+    # ----------------------------------------------------------------------
+    #
+    # oo::define::initialise, oo::define::initialize --
+    #
+    #	Do specific initialisation for a class. See define(n) for details.
+    #
+    # Note that the ::oo::define namespace is semi-public and a bit weird
+    # anyway, so we don't regard the namespace path as being under control:
+    # fully qualified names are used for everything.
+    #
+    # ----------------------------------------------------------------------
+
+    proc define::initialise {body} {
         ::set clsns [::info object namespace [::uplevel 1 self]]
         ::tailcall apply [::list {} $body $clsns]
     }
 
-    # Make the initialise command appear with US spelling too
-    ::namespace export initialise
-    ::namespace eval tmp {::namespace import ::oo::define::initialise}
-    ::rename ::oo::define::tmp::initialise initialize
-    ::namespace delete tmp
-    ::namespace export -clear
-}
+    # Make the [initialise] definition appear as [initialize] too
+    namespace eval define {
+	::namespace export initialise
+	::namespace eval tmp {::namespace import ::oo::define::initialise}
+	::namespace export -clear
+	::rename tmp::initialise initialize
+	::namespace delete tmp
+    }
 
-::oo::define ::oo::Slot {
-    method Get {} {return -code error unimplemented}
-    method Set list {return -code error unimplemented}
+    # ----------------------------------------------------------------------
+    #
+    # Slot --
+    #
+    #	The class of slot operations, which are basically lists at the low
+    #	level of TclOO; this provides a more consistent interface to them.
+    #
+    # ----------------------------------------------------------------------
 
-    method -set args {tailcall my Set $args}
-    method -append args {
-        set current [uplevel 1 [list [namespace which my] Get]]
-        tailcall my Set [list {*}$current {*}$args]
-    }
-    method -clear {} {tailcall my Set {}}
-    forward --default-operation my -append
-
-    method unknown {args} {
-        set def --default-operation
-        if {[llength $args] == 0} {
-            tailcall my $def
-        } elseif {![string match -* [lindex $args 0]]} {
-            tailcall my $def {*}$args
-        }
-        next {*}$args
-    }
+    define Slot {
+	# ------------------------------------------------------------------
+	#
+	# Slot Get --
+	#
+	#	Basic slot getter. Retrieves the contents of the slot.
+	#	Particular slots must provide concrete non-erroring
+	#	implementation.
+	#
+	# ------------------------------------------------------------------
 
-    export -set -append -clear
-    unexport unknown destroy
-}
+	method Get {} {
+	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
+	}
 
-::oo::objdefine ::oo::define::superclass forward --default-operation my -set
-::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 <cloned> {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]
+	# ------------------------------------------------------------------
+	#
+	# Slot Set --
+	#
+	#	Basic slot setter. Sets the contents of the slot.  Particular
+	#	slots must provide concrete non-erroring implementation.
+	#
+	# ------------------------------------------------------------------
+
+	method Set list {
+	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
+	}
+
+	# ------------------------------------------------------------------
+	#
+	# Slot -set, -append, -clear, --default-operation --
+	#
+	#	Standard public slot operations. If a slot can't figure out
+	#	what method to call directly, it uses --default-operation.
+	#
+	# ------------------------------------------------------------------
+
+	method -set args {tailcall my Set $args}
+	method -append args {
+	    set current [uplevel 1 [list [namespace which my] Get]]
+	    tailcall my Set [list {*}$current {*}$args]
+	}
+	method -clear {} {tailcall my Set {}}
+
+	# Default handling
+	forward --default-operation my -append
+	method unknown {args} {
+	    set def --default-operation
+	    if {[llength $args] == 0} {
+		tailcall my $def
+	    } elseif {![string match -* [lindex $args 0]]} {
+		tailcall my $def {*}$args
 	    }
+	    next {*}$args
 	}
-	set b [info body $p]
-	set p [namespace tail $p]
-	proc $p $args $b
+
+	# Set up what is exported and what isn't
+	export -set -append -clear
+	unexport unknown destroy
     }
-    # 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
+
+    # Set the default operation differently for these slots
+    objdefine define::superclass forward --default-operation my -set
+    objdefine define::mixin forward --default-operation my -set
+    objdefine objdefine::mixin forward --default-operation my -set
+
+    # ----------------------------------------------------------------------
+    #
+    # oo::object <cloned> --
+    #
+    #	Handler for cloning objects that clones basic bits (only!) of the
+    #	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
+    #	more complex (and class-specific) handling.
+    #
+    # ----------------------------------------------------------------------
+
+    define object method <cloned> {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.
     }
-    # 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 <cloned> {originObject} {
-    next $originObject
-    # Rebuild the class inheritance delegation class
-    ::oo::UpdateClassDelegatesAfterClone $originObject [self]
-}
+    # ----------------------------------------------------------------------
+    #
+    # oo::class <cloned> --
+    #
+    #	Handler for cloning classes, which fixes up the delegates.
+    #
+    # ----------------------------------------------------------------------
 
-::oo::class create ::oo::singleton {
-    superclass ::oo::class
-    variable object
-    unexport create createWithNamespace
-    method new args {
-        if {![info exists object] || ![info object isa object $object]} {
-            set object [next {*}$args]
-            ::oo::objdefine $object method destroy {} {
-                return -code error {may not destroy a singleton object}
-            }
-            ::oo::objdefine $object method <cloned> {originObject} {
-                return -code error {may not clone a singleton object}
-            }
-        }
-        return $object
+    define class method <cloned> {originObject} {
+	next $originObject
+	# Rebuild the class inheritance delegation class
+	::oo::UpdateClassDelegatesAfterClone $originObject [self]
     }
-}
 
-::oo::class create ::oo::abstract {
-    superclass ::oo::class
-    unexport create createWithNamespace new
+    # ----------------------------------------------------------------------
+    #
+    # oo::singleton --
+    #
+    #	A metaclass that is used to make classes that only permit one instance
+    #	of them to exist. See singleton(n).
+    #
+    # ----------------------------------------------------------------------
+
+    class create singleton {
+	superclass class
+	variable object
+	unexport create createWithNamespace
+	method new args {
+	    if {![info exists object] || ![info object isa object $object]} {
+		set object [next {*}$args]
+		::oo::objdefine $object {
+		    method destroy {} {
+			::return -code error -errorcode {TCLOO SINGLETON} \
+			    "may not destroy a singleton object"
+		    }
+		    method <cloned> {originObject} {
+			::return -code error -errorcode {TCLOO SINGLETON} \
+			    "may not clone a singleton object"
+		    }
+		}
+	    }
+	    return $object
+	}
+    }
+
+    # ----------------------------------------------------------------------
+    #
+    # oo::abstract --
+    #
+    #	A metaclass that is used to make classes that can't be directly
+    #	instantiated. See abstract(n).
+    #
+    # ----------------------------------------------------------------------
+
+    class create abstract {
+	superclass class
+	unexport create createWithNamespace new
+    }
 }
 
 # Local Variables:
diff --git a/tests/ooUtil.test b/tests/ooUtil.test
index e796637..ff7093f 100644
--- a/tests/ooUtil.test
+++ b/tests/ooUtil.test
@@ -138,6 +138,45 @@ test ooUtil-1.7 {} -setup {
 } -cleanup {
     parent destroy
 } -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n"
+# Two tests to confirm that we correctly initialise the scripted part of TclOO
+# in child interpreters. This is slightly tricky at the implementation level
+# because we cannot count on either [source] or [open] being available.
+test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup {
+    set childinterp [interp create]
+} -body {
+    $childinterp eval {
+	oo::class create ActiveRecord {
+	    classmethod find args {
+		return "[self] called with arguments: $args"
+	    }
+	}
+	oo::class create Table {
+	    superclass ActiveRecord
+	}
+	# This is confirming that this is not the master interpreter
+	list [Table find foo bar] [info globals childinterp]
+    }
+} -cleanup {
+    interp delete $childinterp
+} -result {{::Table called with arguments: foo bar} {}}
+test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup {
+    set safeinterp [interp create -safe]
+} -body {
+    $safeinterp eval {
+	oo::class create ActiveRecord {
+	    classmethod find args {
+		return "[self] called with arguments: $args"
+	    }
+	}
+	oo::class create Table {
+	    superclass ActiveRecord
+	}
+	# This is confirming that this is a (basic) safe interpreter
+	list [Table find foo bar] [info commands source]
+    }
+} -cleanup {
+    interp delete $safeinterp
+} -result {{::Table called with arguments: foo bar} {}}
 
 test ooUtil-2.1 {TIP 478: callback generation} -setup {
     oo::class create parent
diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl
index 5197da6..e9b7ed1 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 {        } \v \\\\v
+	    \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v
 	}
 	set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]}
 
@@ -30,12 +30,30 @@ namespace eval makeHeader {
 
     ####################################################################
     #
+    # compactLeadingSpaces --
+    #	Converts the leading whitespace on a line into a more compact form.
+    #
+    proc compactLeadingSpaces {line} {
+	set line [string map {\t {        }} [string trimright $line]]
+	if {[regexp {^[ ]+} $line spaces]} {
+	    regsub -all {[ ]{4}} $spaces \t replace
+	    set len [expr {[string length $spaces] - 1}]
+	    set line [string replace $line 0 $len $replace]
+	}
+	return $line
+    }
+
+    ####################################################################
+    #
     # processScript --
     #	Transform a whole sequence of lines with [mapSpecial].
     #
     proc processScript {scriptLines} {
 	lmap line $scriptLines {
-	    format {"%s"} [mapSpecial $line\n]
+	    # Skip blank and comment lines; they're there in the original
+	    # sources so we don't need to copy them over.
+	    if {[regexp {^\s*(?:#|$)} $line]} continue
+	    format {"%s"} [mapSpecial [compactLeadingSpaces $line]\n]
 	}
     }