There are subtle cases where an append-if-new operation is really useful for a slot.

1 files changed, 26 insertions, 17 deletions

diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 2b61866..b3ff92f 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -98,9 +98,9 @@ static const char *tclOOSetupScript =
 "\t\t\tif {![info object isa class $d]} {\n"
 "\t\t\t\tcontinue\n"
 "\t\t\t}\n"
-"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n"
+"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n"
 "\t\t}\n"
-"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n"
+"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n"
 "\t}\n"
 "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
 "\t\tset originDelegate [DelegateName $originObject]\n"
@@ -141,34 +141,44 @@ static const char *tclOOSetupScript =
 "\t\t::namespace delete tmp\n"
 "\t}\n"
 "\tdefine Slot {\n"
-"\t\tmethod Get {} {\n"
+"\t\tmethod Get -unexport {} {\n"
 "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
 "\t\t}\n"
-"\t\tmethod Set list {\n"
+"\t\tmethod Set -unexport list {\n"
 "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
 "\t\t}\n"
-"\t\tmethod Resolve list {\n"
+"\t\tmethod Resolve -unexport list {\n"
 "\t\t\treturn $list\n"
 "\t\t}\n"
-"\t\tmethod -set args {\n"
+"\t\tmethod -set -export args {\n"
 "\t\t\tset my [namespace which my]\n"
 "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
 "\t\t\ttailcall my Set $args\n"
 "\t\t}\n"
-"\t\tmethod -append args {\n"
+"\t\tmethod -append -export args {\n"
 "\t\t\tset my [namespace which my]\n"
 "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
 "\t\t\tset current [uplevel 1 [list $my Get]]\n"
 "\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
 "\t\t}\n"
-"\t\tmethod -clear {} {tailcall my Set {}}\n"
-"\t\tmethod -prepend args {\n"
+"\t\tmethod -appendifnew -export args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset current [uplevel 1 [list $my Get]]\n"
+"\t\t\tset args [lmap a $args {\n"
+"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
+"\t\t\t\tif {$a in $current} continue\n"
+"\t\t\t\tset a\n"
+"\t\t\t}]\n"
+"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
+"\t\t}\n"
+"\t\tmethod -clear -export {} {tailcall my Set {}}\n"
+"\t\tmethod -prepend -export args {\n"
 "\t\t\tset my [namespace which my]\n"
 "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
 "\t\t\tset current [uplevel 1 [list $my Get]]\n"
 "\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
 "\t\t}\n"
-"\t\tmethod -remove args {\n"
+"\t\tmethod -remove -export args {\n"
 "\t\t\tset my [namespace which my]\n"
 "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
 "\t\t\tset current [uplevel 1 [list $my Get]]\n"
@@ -177,7 +187,7 @@ static const char *tclOOSetupScript =
 "\t\t\t}]\n"
 "\t\t}\n"
 "\t\tforward --default-operation my -append\n"
-"\t\tmethod unknown {args} {\n"
+"\t\tmethod unknown -unexport {args} {\n"
 "\t\t\tset def --default-operation\n"
 "\t\t\tif {[llength $args] == 0} {\n"
 "\t\t\t\ttailcall my $def\n"
@@ -186,13 +196,12 @@ static const char *tclOOSetupScript =
 "\t\t\t}\n"
 "\t\t\tnext {*}$args\n"
 "\t\t}\n"
-"\t\texport -set -append -clear -prepend -remove\n"
-"\t\tunexport unknown destroy\n"
+"\t\tunexport 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"
+"\tdefine object method <cloned> -unexport {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"
@@ -219,7 +228,7 @@ static const char *tclOOSetupScript =
 "\t\t\t}\n"
 "\t\t}\n"
 "\t}\n"
-"\tdefine class method <cloned> {originObject} {\n"
+"\tdefine class method <cloned> -unexport {originObject} {\n"
 "\t\tnext $originObject\n"
 "\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
 "\t}\n"
@@ -235,7 +244,7 @@ static const char *tclOOSetupScript =
 "\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\tmethod <cloned> -unexport {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"
@@ -439,7 +448,7 @@ static const char *tclOOSetupScript =
 "\t\t}\n"
 "\t\t::oo::class create configurable {\n"
 "\t\t\tprivate variable my\n"
-"\t\t\tmethod configure args {\n"
+"\t\t\tmethod configure -export args {\n"
 "\t\t\t\t::if {![::info exists my]} {\n"
 "\t\t\t\t\t::set my [::namespace which my]\n"
 "\t\t\t\t}\n"