Tcl Source Code

Changes On Branch tip-516
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes In Branch tip-516 Excluding Merge-Ins

This is equivalent to a diff from e891020c32 to 4c8cd0f799

2018-09-27
07:22
Implementation of TIP 516: More OO Slot Operations Closed-Leaf check-in: 28f8e4372e user: dkf tags: core-8-branch-timeline-fix
07:20
help Closed-Leaf check-in: 2d2e7d5f73 user: dkf tags: core-8-branch-timeline-fix
2018-09-11
15:39
merge 8.7 check-in: 0c62aa4c94 user: dgp tags: dgp-string-insert
07:44
Simplify the slot resolution protocol Closed-Leaf check-in: 4c8cd0f799 user: dkf tags: tip-516
2018-09-10
08:33
Tests and docs check-in: ede05afd63 user: dkf tags: tip-516
2018-09-08
21:18
Merge core-8-branch check-in: 4c53b5eb75 user: jan.nijtmans tags: tip-515
12:52
Implementation of TIP 516 check-in: 84cceab204 user: dkf tags: tip-516
2018-09-07
22:23
Merge 8.6 check-in: 4ccc3b6902 user: jan.nijtmans tags: core-8-branch
12:11
merge 8.7 check-in: 792948e482 user: dgp tags: trunk
12:11
merge 8.6 check-in: e891020c32 user: dgp tags: core-8-branch
12:04
Added test for [631b4c45df]. check-in: 036c01e552 user: dgp tags: core-8-6-branch
12:02
merge 8.6 (segfault fix) check-in: 0a8630528a user: sebres tags: core-8-branch

Changes to doc/define.n.

   422    422   \fBself call\fR).
   423    423   .VE TIP500
   424    424   .SH "SLOTTED DEFINITIONS"
   425    425   Some of the configurable definitions of a class or object are \fIslotted
   426    426   definitions\fR. This means that the configuration is implemented by a slot
   427    427   object, that is an instance of the class \fBoo::Slot\fR, which manages a list
   428    428   of values (class names, variable names, etc.) that comprises the contents of
   429         -the slot. The class defines three operations (as methods) that may be done on
          429  +the slot. The class defines five operations (as methods) that may be done on
   430    430   the slot:
   431    431   .TP
   432    432   \fIslot\fR \fB\-append\fR ?\fImember ...\fR?
   433    433   .
   434    434   This appends the given \fImember\fR elements to the slot definition.
   435    435   .TP
   436    436   \fIslot\fR \fB\-clear\fR
   437    437   .
   438    438   This sets the slot definition to the empty list.
          439  +.TP
          440  +\fIslot\fR \fB\-prepend\fR ?\fImember ...\fR?
          441  +.VS TIP516
          442  +This prepends the given \fImember\fR elements to the slot definition.
          443  +.VE TIP516
          444  +.TP
          445  +\fIslot\fR \fB\-remove\fR ?\fImember ...\fR?
          446  +.VS TIP516
          447  +This removes the given \fImember\fR elements from the slot definition.
          448  +.VE TIP516
   439    449   .TP
   440    450   \fIslot\fR \fB\-set\fR ?\fImember ...\fR?
   441    451   .
   442    452   This replaces the slot definition with the given \fImember\fR elements.
   443    453   .PP
   444    454   A consequence of this is that any use of a slot's default operation where the
   445    455   first member argument begins with a hyphen will be an error. One of the above
................................................................................
   450    460   .QW \fBvariable\fR
   451    461   slot, this is forwarded to
   452    462   .QW "\fBmy \-append\fR" ),
   453    463   and these methods which provide the implementation interface:
   454    464   .TP
   455    465   \fIslot\fR \fBGet\fR
   456    466   .
   457         -Returns a list that is the current contents of the slot. This method must
   458         -always be called from a stack frame created by a call to \fBoo::define\fR or
   459         -\fBoo::objdefine\fR.
          467  +Returns a list that is the current contents of the slot, but does not modify
          468  +the slot. This method must always be called from a stack frame created by a
          469  +call to \fBoo::define\fR or \fBoo::objdefine\fR. This method \fIshould not\fR
          470  +return an error unless it is called from outside a definition context or with
          471  +the wrong number of arguments.
          472  +.RS
          473  +.PP
          474  +.VS TIP516
          475  +The elements of the list should be fully resolved, if that is a meaningful
          476  +concept to the slot.
          477  +.VE TIP516
          478  +.RE
          479  +.TP
          480  +\fIslot\fR \fBResolve\fR \fIslotElement\fR
          481  +.VS TIP516
          482  +Returns \fIslotElement\fR with a resolution operation applied to it, but does
          483  +not modify the slot. For slots of simple strings, this is an operation that
          484  +does nothing, whereas for slots of classes, this maps a class name to its
          485  +fully-qualified class name.  This method must always be called from a stack
          486  +frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR.  This
          487  +method \fIshould not\fR return an error unless it is called from outside a
          488  +definition context or with the wrong number of arguments; unresolvable
          489  +arguments should be returned as is (as not all slot operations strictly
          490  +require that values are resolvable to work).
          491  +.RS
          492  +.PP
          493  +Implementations \fIshould not\fR enforce uniqueness and ordering constraints
          494  +in this method; that is the responsibility of the \fBSet\fR method.
          495  +.RE
          496  +.VE TIP516
   460    497   .TP
   461    498   \fIslot\fR \fBSet \fIelementList\fR
   462    499   .
   463    500   Sets the contents of the slot to the list \fIelementList\fR and returns the
   464    501   empty string. This method must always be called from a stack frame created by
   465         -a call to \fBoo::define\fR or \fBoo::objdefine\fR.
          502  +a call to \fBoo::define\fR or \fBoo::objdefine\fR. This method may return an
          503  +error if it rejects the change to the slot contents (e.g., because of invalid
          504  +values) as well as if it is called from outside a definition context or with
          505  +the wrong number of arguments.
          506  +.RS
          507  +.PP
          508  +This method \fImay\fR reorder and filter the elements if this is necessary in
          509  +order to satisfy the underlying constraints of the slot. (For example, slots
          510  +of classes enforce a uniqueness constraint that places each element in the
          511  +earliest location in the slot that it can.)
          512  +.RE
   466    513   .PP
   467    514   The implementation of these methods is slot-dependent (and responsible for
   468    515   accessing the correct part of the class or object definition). Slots also have
   469    516   an unknown method handler to tie all these pieces together, and they hide
   470    517   their \fBdestroy\fR method so that it is not invoked inadvertently. It is
   471    518   \fIrecommended\fR that any user changes to the slot mechanism be restricted to
   472    519   defining new operations whose names start with a hyphen.
          520  +.PP
          521  +.VS TIP516
          522  +Most slot operations will initially \fBResolve\fR their argument list, combine
          523  +it with the results of the \fBGet\fR method, and then \fBSet\fR the result.
          524  +Some operations omit one or both of the first two steps; omitting the third
          525  +would result in an idempotent read-only operation (but the standard mechanism
          526  +for reading from slots is via \fBinfo class\fR and \fBinfo object\fR).
          527  +.VE TIP516
   473    528   .SH EXAMPLES
   474    529   This example demonstrates how to use both forms of the \fBoo::define\fR and
   475    530   \fBoo::objdefine\fR commands (they work in the same way), as well as
   476    531   illustrating four of the subcommands of them.
   477    532   .PP
   478    533   .CS
   479    534   oo::class create c

Changes to generic/tclOODefineCmds.c.

    33     33    * Some things that make it easier to declare a slot.
    34     34    */
    35     35   
    36     36   struct DeclaredSlot {
    37     37       const char *name;
    38     38       const Tcl_MethodType getterType;
    39     39       const Tcl_MethodType setterType;
           40  +    const Tcl_MethodType resolverType;
    40     41   };
    41     42   
    42         -#define SLOT(name,getter,setter)					\
           43  +#define SLOT(name,getter,setter,resolver)				\
    43     44       {"::oo::" name,							\
    44     45   	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
    45     46   		    getter, NULL, NULL},				\
    46     47   	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
    47         -		    setter, NULL, NULL}}
           48  +		    setter, NULL, NULL},				\
           49  +	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
           50  +		    resolver, NULL, NULL}}
    48     51   
    49     52   /*
    50     53    * Forward declarations.
    51     54    */
    52     55   
    53     56   static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
    54     57   static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
................................................................................
   105    108   			    int objc, Tcl_Obj *const *objv);
   106    109   static int		ObjVarsGet(ClientData clientData,
   107    110   			    Tcl_Interp *interp, Tcl_ObjectContext context,
   108    111   			    int objc, Tcl_Obj *const *objv);
   109    112   static int		ObjVarsSet(ClientData clientData,
   110    113   			    Tcl_Interp *interp, Tcl_ObjectContext context,
   111    114   			    int objc, Tcl_Obj *const *objv);
          115  +static int		ResolveClass(ClientData clientData,
          116  +			    Tcl_Interp *interp, Tcl_ObjectContext context,
          117  +			    int objc, Tcl_Obj *const *objv);
   112    118   
   113    119   /*
   114    120    * Now define the slots used in declarations.
   115    121    */
   116    122   
   117    123   static const struct DeclaredSlot slots[] = {
   118         -    SLOT("define::filter",      ClassFilterGet, ClassFilterSet),
   119         -    SLOT("define::mixin",       ClassMixinGet,  ClassMixinSet),
   120         -    SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet),
   121         -    SLOT("define::variable",    ClassVarsGet,   ClassVarsSet),
   122         -    SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet),
   123         -    SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet),
   124         -    SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet),
   125         -    {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
          124  +    SLOT("define::filter",      ClassFilterGet, ClassFilterSet, NULL),
          125  +    SLOT("define::mixin",       ClassMixinGet,  ClassMixinSet, ResolveClass),
          126  +    SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet, ResolveClass),
          127  +    SLOT("define::variable",    ClassVarsGet,   ClassVarsSet, NULL),
          128  +    SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet, NULL),
          129  +    SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet, ResolveClass),
          130  +    SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet, NULL),
          131  +    {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
   126    132   };
   127    133   
   128    134   /*
   129    135    * How to build the in-namespace name of a private variable. This is a pattern
   130    136    * used with Tcl_ObjPrintf().
   131    137    */
   132    138   
................................................................................
  2059   2065   int
  2060   2066   TclOODefineSlots(
  2061   2067       Foundation *fPtr)
  2062   2068   {
  2063   2069       const struct DeclaredSlot *slotInfoPtr;
  2064   2070       Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
  2065   2071       Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
         2072  +    Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1);
  2066   2073       Class *slotCls;
  2067   2074   
  2068   2075       slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
  2069   2076   	    fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr;
  2070   2077       if (slotCls == NULL) {
  2071   2078   	return TCL_ERROR;
  2072   2079       }
  2073   2080       Tcl_IncrRefCount(getName);
  2074   2081       Tcl_IncrRefCount(setName);
         2082  +    Tcl_IncrRefCount(resolveName);
  2075   2083       for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
  2076   2084   	Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
  2077         -		(Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0);
         2085  +		(Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0);
  2078   2086   
  2079   2087   	if (slotObject == NULL) {
  2080   2088   	    continue;
  2081   2089   	}
  2082   2090   	Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0,
  2083   2091   		&slotInfoPtr->getterType, NULL);
  2084   2092   	Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
  2085   2093   		&slotInfoPtr->setterType, NULL);
         2094  +	if (slotInfoPtr->resolverType.callProc) {
         2095  +	    Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
         2096  +		    &slotInfoPtr->resolverType, NULL);
         2097  +	}
  2086   2098       }
  2087   2099       Tcl_DecrRefCount(getName);
  2088   2100       Tcl_DecrRefCount(setName);
         2101  +    Tcl_DecrRefCount(resolveName);
  2089   2102       return TCL_OK;
  2090   2103   }
  2091   2104   
  2092   2105   /*
  2093   2106    * ----------------------------------------------------------------------
  2094   2107    *
  2095   2108    * ClassFilterGet, ClassFilterSet --
................................................................................
  2807   2820   
  2808   2821       if (IsPrivateDefine(interp)) {
  2809   2822   	InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv,
  2810   2823   		oPtr->creationEpoch);
  2811   2824       } else {
  2812   2825   	InstallStandardVariableMapping(&oPtr->variables, varc, varv);
  2813   2826       }
         2827  +    return TCL_OK;
         2828  +}
         2829  +
         2830  +/*
         2831  + * ----------------------------------------------------------------------
         2832  + *
         2833  + * ResolveClass --
         2834  + *
         2835  + *	Implementation of the "Resolve" support method for some slots (those
         2836  + *	that are slots around a list of classes). This resolves possible class
         2837  + *	names to their fully-qualified names if possible.
         2838  + *
         2839  + * ----------------------------------------------------------------------
         2840  + */
         2841  +
         2842  +static int
         2843  +ResolveClass(
         2844  +    ClientData clientData,
         2845  +    Tcl_Interp *interp,
         2846  +    Tcl_ObjectContext context,
         2847  +    int objc,
         2848  +    Tcl_Obj *const *objv)
         2849  +{
         2850  +    int idx = Tcl_ObjectContextSkippedArgs(context);
         2851  +    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
         2852  +    Class *clsPtr;
         2853  +
         2854  +    /*
         2855  +     * Check if were called wrongly. The definition context isn't used...
         2856  +     * except that GetClassInOuterContext() assumes that it is there.
         2857  +     */
         2858  +
         2859  +    if (oPtr == NULL) {
         2860  +	return TCL_ERROR;
         2861  +    } else if (objc != idx + 1) {
         2862  +	Tcl_WrongNumArgs(interp, idx, objv, "slotElement");
         2863  +	return TCL_ERROR;
         2864  +    }
         2865  +
         2866  +    /*
         2867  +     * Resolve the class if possible. If not, remove any resolution error and
         2868  +     * return what we've got anyway as the failure might not be fatal overall.
         2869  +     */
         2870  +
         2871  +    clsPtr = GetClassInOuterContext(interp, objv[idx],
         2872  +	    "USER SHOULD NOT SEE THIS MESSAGE");
         2873  +    if (clsPtr == NULL) {
         2874  +	Tcl_ResetResult(interp);
         2875  +	Tcl_SetObjResult(interp, objv[idx]);
         2876  +    } else {
         2877  +	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
         2878  +    }
         2879  +
  2814   2880       return TCL_OK;
  2815   2881   }
  2816   2882   
  2817   2883   /*
  2818   2884    * Local Variables:
  2819   2885    * mode: c
  2820   2886    * c-basic-offset: 4
  2821   2887    * fill-column: 78
  2822   2888    * End:
  2823   2889    */

Changes to generic/tclOOScript.h.

   143    143   "\tdefine Slot {\n"
   144    144   "\t\tmethod Get {} {\n"
   145    145   "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
   146    146   "\t\t}\n"
   147    147   "\t\tmethod Set list {\n"
   148    148   "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
   149    149   "\t\t}\n"
   150         -"\t\tmethod -set args {tailcall my Set $args}\n"
          150  +"\t\tmethod Resolve list {\n"
          151  +"\t\t\treturn $list\n"
          152  +"\t\t}\n"
          153  +"\t\tmethod -set args {\n"
          154  +"\t\t\tset my [namespace which my]\n"
          155  +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
          156  +"\t\t\ttailcall my Set $args\n"
          157  +"\t\t}\n"
   151    158   "\t\tmethod -append args {\n"
   152         -"\t\t\tset current [uplevel 1 [list [namespace which my] Get]]\n"
          159  +"\t\t\tset my [namespace which my]\n"
          160  +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
          161  +"\t\t\tset current [uplevel 1 [list $my Get]]\n"
   153    162   "\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
   154    163   "\t\t}\n"
   155    164   "\t\tmethod -clear {} {tailcall my Set {}}\n"
          165  +"\t\tmethod -prepend args {\n"
          166  +"\t\t\tset my [namespace which my]\n"
          167  +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
          168  +"\t\t\tset current [uplevel 1 [list $my Get]]\n"
          169  +"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
          170  +"\t\t}\n"
          171  +"\t\tmethod -remove args {\n"
          172  +"\t\t\tset my [namespace which my]\n"
          173  +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
          174  +"\t\t\tset current [uplevel 1 [list $my Get]]\n"
          175  +"\t\t\ttailcall my Set [lmap val $current {\n"
          176  +"\t\t\t\tif {$val in $args} continue else {set val}\n"
          177  +"\t\t\t}]\n"
          178  +"\t\t}\n"
   156    179   "\t\tforward --default-operation my -append\n"
   157    180   "\t\tmethod unknown {args} {\n"
   158    181   "\t\t\tset def --default-operation\n"
   159    182   "\t\t\tif {[llength $args] == 0} {\n"
   160    183   "\t\t\t\ttailcall my $def\n"
   161    184   "\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
   162    185   "\t\t\t\ttailcall my $def {*}$args\n"
   163    186   "\t\t\t}\n"
   164    187   "\t\t\tnext {*}$args\n"
   165    188   "\t\t}\n"
   166         -"\t\texport -set -append -clear\n"
          189  +"\t\texport -set -append -clear -prepend -remove\n"
   167    190   "\t\tunexport unknown destroy\n"
   168    191   "\t}\n"
   169    192   "\tobjdefine define::superclass forward --default-operation my -set\n"
   170    193   "\tobjdefine define::mixin forward --default-operation my -set\n"
   171    194   "\tobjdefine objdefine::mixin forward --default-operation my -set\n"
   172    195   "\tdefine object method <cloned> {originObject} {\n"
   173    196   "\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"

Changes to generic/tclOOScript.tcl.

   272    272   
   273    273   	method Set list {
   274    274   	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
   275    275   	}
   276    276   
   277    277   	# ------------------------------------------------------------------
   278    278   	#
          279  +	# Slot Resolve --
          280  +	#
          281  +	#	Helper that lets a slot convert a list of arguments of a
          282  +	#	particular type to their canonical forms. Defaults to doing
          283  +	#	nothing (suitable for simple strings).
          284  +	#
          285  +	# ------------------------------------------------------------------
          286  +
          287  +	method Resolve list {
          288  +	    return $list
          289  +	}
          290  +
          291  +	# ------------------------------------------------------------------
          292  +	#
   279    293   	# Slot -set, -append, -clear, --default-operation --
   280    294   	#
   281    295   	#	Standard public slot operations. If a slot can't figure out
   282    296   	#	what method to call directly, it uses --default-operation.
   283    297   	#
   284    298   	# ------------------------------------------------------------------
   285    299   
   286         -	method -set args {tailcall my Set $args}
          300  +	method -set args {
          301  +	    set my [namespace which my]
          302  +	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
          303  +	    tailcall my Set $args
          304  +	}
   287    305   	method -append args {
   288         -	    set current [uplevel 1 [list [namespace which my] Get]]
          306  +	    set my [namespace which my]
          307  +	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
          308  +	    set current [uplevel 1 [list $my Get]]
   289    309   	    tailcall my Set [list {*}$current {*}$args]
   290    310   	}
   291    311   	method -clear {} {tailcall my Set {}}
          312  +	method -prepend args {
          313  +	    set my [namespace which my]
          314  +	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
          315  +	    set current [uplevel 1 [list $my Get]]
          316  +	    tailcall my Set [list {*}$args {*}$current]
          317  +	}
          318  +	method -remove args {
          319  +	    set my [namespace which my]
          320  +	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
          321  +	    set current [uplevel 1 [list $my Get]]
          322  +	    tailcall my Set [lmap val $current {
          323  +		if {$val in $args} continue else {set val}
          324  +	    }]
          325  +	}
   292    326   
   293    327   	# Default handling
   294    328   	forward --default-operation my -append
   295    329   	method unknown {args} {
   296    330   	    set def --default-operation
   297    331   	    if {[llength $args] == 0} {
   298    332   		tailcall my $def
................................................................................
   299    333   	    } elseif {![string match -* [lindex $args 0]]} {
   300    334   		tailcall my $def {*}$args
   301    335   	    }
   302    336   	    next {*}$args
   303    337   	}
   304    338   
   305    339   	# Set up what is exported and what isn't
   306         -	export -set -append -clear
          340  +	export -set -append -clear -prepend -remove
   307    341   	unexport unknown destroy
   308    342       }
   309    343   
   310    344       # Set the default operation differently for these slots
   311    345       objdefine define::superclass forward --default-operation my -set
   312    346       objdefine define::mixin forward --default-operation my -set
   313    347       objdefine objdefine::mixin forward --default-operation my -set

Changes to tests/oo.test.

     9      9   
    10     10   package require TclOO 1.0.3
    11     11   package require tcltest 2
    12     12   if {"::tcltest" in [namespace children]} {
    13     13       namespace import -force ::tcltest::*
    14     14   }
    15     15   
    16         -
    17     16   # The foundational objects oo::object and oo::class are sensitive to reference
    18     17   # counting errors and are deallocated only when an interp is deleted, so in
    19     18   # this test suite, interp creation and interp deletion are often used in
    20     19   # leaktests in order to leverage this sensitivity.
    21         -
    22     20   
    23     21   testConstraint memory [llength [info commands memory]]
    24     22   if {[testConstraint memory]} {
    25     23       proc getbytes {} {
    26     24   	set lines [split [memory info] \n]
    27     25   	return [lindex $lines 3 3]
    28     26       }
................................................................................
  3834   3832   	    }
  3835   3833   	    method Set {lst} {
  3836   3834   		variable contents $lst
  3837   3835   		variable ops
  3838   3836   		lappend ops [info level] Set $lst
  3839   3837   		return
  3840   3838   	    }
         3839  +	    method Resolve {lst} {
         3840  +		variable ops
         3841  +		lappend ops [info level] Resolve $lst
         3842  +		return $lst
         3843  +	    }
  3841   3844   	}
  3842   3845       }
  3843   3846       append script0 \n$script
  3844   3847   }
  3845   3848   
  3846   3849   proc SampleSlotCleanup script {
  3847   3850       set script0 {
................................................................................
  3868   3871   test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
  3869   3872       SampleSlot create sampleSlot
  3870   3873   }] -body {
  3871   3874       list [info level] [sampleSlot -append g h i] \
  3872   3875   	[sampleSlot contents] [sampleSlot ops]
  3873   3876   } -cleanup [SampleSlotCleanup {
  3874   3877       rename sampleSlot {}
  3875         -}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
         3878  +}] -result {0 {} {a b c g h i} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {a b c g h i}}}
  3876   3879   test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
  3877   3880       SampleSlot create sampleSlot
  3878   3881   }] -body {
  3879   3882       list [info level] [sampleSlot -set d e f] \
  3880   3883   	[sampleSlot contents] [sampleSlot ops]
  3881   3884   } -cleanup [SampleSlotCleanup {
  3882   3885       rename sampleSlot {}
  3883         -}] -result {0 {} {d e f} {1 Set {d e f}}}
         3886  +}] -result {0 {} {d e f} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f}}}
  3884   3887   test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
  3885   3888       SampleSlot create sampleSlot
  3886   3889   }] -body {
  3887   3890       list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
  3888   3891   	[sampleSlot contents] [sampleSlot ops]
  3889   3892   } -cleanup [SampleSlotCleanup {
  3890   3893       rename sampleSlot {}
  3891         -}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
         3894  +}] -result {0 {} {} {d e f g h i} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f} 1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {d e f g h i}}}
         3895  +test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup {
         3896  +    SampleSlot create sampleSlot
         3897  +}] -body {
         3898  +    list [info level] [sampleSlot -prepend g h i] \
         3899  +	[sampleSlot contents] [sampleSlot ops]
         3900  +} -cleanup [SampleSlotCleanup {
         3901  +    rename sampleSlot {}
         3902  +}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}}
         3903  +test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup {
         3904  +    SampleSlot create sampleSlot
         3905  +}] -body {
         3906  +    list [info level] [sampleSlot -remove c a] \
         3907  +	[sampleSlot contents] [sampleSlot ops]
         3908  +} -cleanup [SampleSlotCleanup {
         3909  +    rename sampleSlot {}
         3910  +}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}}
  3892   3911   
  3893   3912   test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
  3894   3913       set s [SampleSlot new]
  3895   3914   }] -body {
  3896   3915       list [$s x y] [$s contents]
  3897   3916   } -cleanup [SampleSlotCleanup {
  3898   3917       rename $s {}
................................................................................
  3907   3926   test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
  3908   3927       set s [SampleSlot new]
  3909   3928   }] -body {
  3910   3929       oo::objdefine $s forward --default-operation  my -set
  3911   3930       list [$s destroy; $s unknown] [$s contents] [$s ops]
  3912   3931   } -cleanup [SampleSlotCleanup {
  3913   3932       rename $s {}
  3914         -}] -result {{} unknown {1 Set destroy 1 Set unknown}}
         3933  +}] -result {{} unknown {1 Resolve destroy 1 Set destroy 1 Resolve unknown 1 Set unknown}}
  3915   3934   test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
  3916   3935       set s [SampleSlot new]
  3917   3936   }] -body {
  3918   3937       # Method names beginning with "-" are special to slots
  3919   3938       $s -grill q
  3920   3939   } -returnCodes error -cleanup [SampleSlotCleanup {
  3921   3940       rename $s {}
  3922   3941   }] -result \
  3923         -    {unknown method "-grill": must be -append, -clear, -set, contents or ops}
         3942  +    {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops}
  3924   3943   
  3925   3944   test oo-34.1 {TIP 380: slots - presence} -setup {
  3926   3945       set obj [oo::object new]
  3927   3946       set result {}
  3928   3947   } -body {
  3929   3948       oo::define oo::object {
  3930   3949   	::lappend ::result [::info object class filter]
................................................................................
  3946   3965   } {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
  3947   3966   proc getMethods obj {
  3948   3967       list [lsort [info object methods $obj -all]] \
  3949   3968   	[lsort [info object methods $obj -private]]
  3950   3969   }
  3951   3970   test oo-34.3 {TIP 380: slots - presence} {
  3952   3971       getMethods oo::define::filter
  3953         -} {{-append -clear -set} {Get Set}}
         3972  +} {{-append -clear -prepend -remove -set} {Get Set}}
  3954   3973   test oo-34.4 {TIP 380: slots - presence} {
  3955   3974       getMethods oo::define::mixin
  3956         -} {{-append -clear -set} {--default-operation Get Set}}
         3975  +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
  3957   3976   test oo-34.5 {TIP 380: slots - presence} {
  3958   3977       getMethods oo::define::superclass
  3959         -} {{-append -clear -set} {--default-operation Get Set}}
         3978  +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
  3960   3979   test oo-34.6 {TIP 380: slots - presence} {
  3961   3980       getMethods oo::define::variable
  3962         -} {{-append -clear -set} {Get Set}}
         3981  +} {{-append -clear -prepend -remove -set} {Get Set}}
  3963   3982   test oo-34.7 {TIP 380: slots - presence} {
  3964   3983       getMethods oo::objdefine::filter
  3965         -} {{-append -clear -set} {Get Set}}
         3984  +} {{-append -clear -prepend -remove -set} {Get Set}}
  3966   3985   test oo-34.8 {TIP 380: slots - presence} {
  3967   3986       getMethods oo::objdefine::mixin
  3968         -} {{-append -clear -set} {--default-operation Get Set}}
         3987  +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
  3969   3988   test oo-34.9 {TIP 380: slots - presence} {
  3970   3989       getMethods oo::objdefine::variable
  3971         -} {{-append -clear -set} {Get Set}}
         3990  +} {{-append -clear -prepend -remove -set} {Get Set}}
         3991  +test oo-34.10 {TIP 516: slots - resolution} -setup {
         3992  +    oo::class create parent
         3993  +    set result {}
         3994  +    oo::class create 516a { superclass parent }
         3995  +    oo::class create 516b { superclass parent }
         3996  +    oo::class create 516c { superclass parent }
         3997  +    namespace eval 516test {
         3998  +	oo::class create 516a { superclass parent }
         3999  +	oo::class create 516b { superclass parent }
         4000  +	oo::class create 516c { superclass parent }
         4001  +    }
         4002  +} -body {
         4003  +    # Must find the right classes when making the mixin
         4004  +    namespace eval 516test {
         4005  +	oo::define 516a {
         4006  +	    mixin 516b 516c
         4007  +	}
         4008  +    }
         4009  +    lappend result [info class mixin 516test::516a]
         4010  +    # Must not remove class with just simple name match 
         4011  +    oo::define 516test::516a {
         4012  +	mixin -remove 516b
         4013  +    }
         4014  +    lappend result [info class mixin 516test::516a]
         4015  +    # Must remove class with resolved name match
         4016  +    oo::define 516test::516a {
         4017  +	mixin -remove 516test::516c
         4018  +    }
         4019  +    lappend result [info class mixin 516test::516a]
         4020  +    # Must remove class with resolved name match even after renaming, but only
         4021  +    # with the renamed name; it is a slot of classes, not strings!
         4022  +    rename 516test::516b 516test::516d
         4023  +    oo::define 516test::516a {
         4024  +	mixin -remove 516test::516b
         4025  +    }
         4026  +    lappend result [info class mixin 516test::516a]
         4027  +    oo::define 516test::516a {
         4028  +	mixin -remove 516test::516d
         4029  +    }
         4030  +    lappend result [info class mixin 516test::516a]
         4031  +} -cleanup {
         4032  +    parent destroy
         4033  +} -result {{::516test::516b ::516test::516c} {::516test::516b ::516test::516c} ::516test::516b ::516test::516d {}}
  3972   4034   
  3973   4035   test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
  3974   4036       oo::class create fruit {
  3975   4037   	method eat {} {}
  3976   4038       }
  3977   4039       set result {}
  3978   4040   } -body {