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

1 files changed, 315 insertions, 132 deletions

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: