Index: generic/xotcl.c =================================================================== diff -u -rccc949c8c4ddea8f3a33006780a0c393a437bc52 -r5f087239098764c1e78b666b8e1708e0b076d28b --- generic/xotcl.c (.../xotcl.c) (revision ccc949c8c4ddea8f3a33006780a0c393a437bc52) +++ generic/xotcl.c (.../xotcl.c) (revision 5f087239098764c1e78b666b8e1708e0b076d28b) @@ -653,8 +653,7 @@ #if !defined(PRE85) || FORWARD_COMPATIBLE static XOTCLINLINE Var * -VarHashCreateVar85(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr) -{ +VarHashCreateVar85(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr) { Var *varPtr = NULL; Tcl_HashEntry *hPtr; hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr, @@ -1574,31 +1573,61 @@ static Tcl_Var xotclObjectVarResolver(Tcl_Interp *interp, xotclResolvedVarInfo *resVarInfo) { - XOTclObject *obj = GetSelfObj(interp); - TclVarHashTable *varTable = obj->nsPtr ? Tcl_Namespace_varTable(obj->nsPtr) : obj->varTable; + XOTclCallStackContent *cscPtr = CallStackGetFrame(interp, NULL); + XOTclObject *obj = cscPtr ? cscPtr->self : NULL; + TclVarHashTable *varTablePtr; Tcl_Var var; int new; - if (obj == resVarInfo->lastObj) { + /* + * We cache lookups based on obj; we have to care about cases, where + * variables are deleted in recreates or on single deletes. In these + * cases, the var flags are reset. + */ + + if (obj == resVarInfo->lastObj && ((Var*)(resVarInfo->var))->flags & VAR_IN_HASHTABLE) { + /*Var *v = (Var*)(resVarInfo->var); + fprintf(stderr,".... var flags = %.6x\n",v->flags);*/ return resVarInfo->var; } - /*fprintf(stderr, "Object Var Resolver, name=%s, obj %p, nsPtr %p\n",resVarInfo->buffer, obj, obj->nsPtr);*/ - var = (Tcl_Var)LookupVarFromTable(varTable, resVarInfo->buffer, NULL); + varTablePtr = obj->nsPtr ? Tcl_Namespace_varTable(obj->nsPtr) : obj->varTable; + if (varTablePtr == NULL) { + /* + * The variable table does not exist. This seems to be is the + * first access to a variable on this object. We create the and + * initialize the variable hash table and update the object + */ + varTablePtr = (TclVarHashTable *) ckalloc(varHashTableSize); + InitVarHashTable(varTablePtr, NULL); + assert(obj->varTable == 0); /* the nsVarPtr should always be initialized */ + if (obj->varTable == NULL) { + obj->varTable = varTablePtr; + } + } + + /* fprintf(stderr, "Object Var Resolver, name=%s, obj %p, nsPtr %p, varTable %p\n", + resVarInfo->buffer, obj, obj->nsPtr, varTablePtr); */ + var = (Tcl_Var)LookupVarFromTable(varTablePtr, resVarInfo->buffer, NULL); + if (var == NULL) { - /* We failed to find the variable so far, therefore we create it - * here in the namespace. Note that the cases (1), (2) and (3) - * TCL_CONTINUE care for variable creation if necessary. + /* We failed to find the variable, therefore we create it in the + * vartable. */ Tcl_Obj *key = Tcl_NewStringObj(resVarInfo->buffer, -1); /*fprintf(stderr, "create %s in ns\n", resVarInfo->buffer);*/ INCR_REF_COUNT(key); - var = (Tcl_Var)VarHashCreateVar(varTable, key, &new); + var = (Tcl_Var)VarHashCreateVar(varTablePtr, key, &new); DECR_REF_COUNT(key); } resVarInfo->lastObj = obj; resVarInfo->var = var; + + /*{ + Var *v = (Var*)(resVarInfo->var); + fprintf(stderr,"==== looked up var %s flags = %.6x\n",resVarInfo->buffer, v->flags); + }*/ return var; } @@ -1612,8 +1641,9 @@ if (obj && *name == '.') { xotclResolvedVarInfo *vInfoPtr = (xotclResolvedVarInfo *) ckalloc(sizeof(xotclResolvedVarInfo)); vInfoPtr->vInfo.fetchProc = xotclObjectVarResolver; - vInfoPtr->vInfo.deleteProc = NULL; + vInfoPtr->vInfo.deleteProc = NULL; /* if NULL, tcl does a ckfree on proc clean up */ vInfoPtr->lastObj = NULL; + vInfoPtr->var = NULL; memcpy(vInfoPtr->buffer,name+1,length-1); vInfoPtr->buffer[length-1] = 0; *rPtr = (Tcl_ResolvedVarInfo *)vInfoPtr; @@ -7121,7 +7151,7 @@ */ static void CleanupDestroyObject(Tcl_Interp *interp, XOTclObject *obj, int softrecreate) { - /*fprintf(stderr, "CleanupDestroyObject obj %p\n", obj);*/ + /*fprintf(stderr, "CleanupDestroyObject obj %p softrecreate %d\n", obj, softrecreate);*/ /* remove the instance, but not for ::Class/::Object */ if ((obj->flags & XOTCL_IS_ROOT_CLASS) == 0 && Index: tests/varresolutiontest.xotcl =================================================================== diff -u -r2111020b49da8ce57758e51accf0b6073037f0d2 -r5f087239098764c1e78b666b8e1708e0b076d28b --- tests/varresolutiontest.xotcl (.../varresolutiontest.xotcl) (revision 2111020b49da8ce57758e51accf0b6073037f0d2) +++ tests/varresolutiontest.xotcl (.../varresolutiontest.xotcl) (revision 5f087239098764c1e78b666b8e1708e0b076d28b) @@ -4,14 +4,18 @@ package require xotcl::test namespace import -force xotcl::* -proc ? {cmd expected {iterations 1000}} { - set t [Test new \ - -cmd $cmd \ - -expected $expected \ - -count $iterations] +proc ? {cmd expected {msg ""}} { + set count 1 + if {$msg ne ""} { + set t [Test new -cmd $cmd -count $count -msg $msg] + } else { + set t [Test new -cmd $cmd -count $count] + } + $t expected $expected $t run } + ########################################### # Basic tests for var resolution under # per-object namespaces ... @@ -77,7 +81,7 @@ ? {namespace eval ::o info exists x} 0 o lappend y 3 ? {namespace eval ::o llength y} 1 -? {namespace eval ::o unset y} "" 1 +? {namespace eval ::o unset y} "" ? {::o exists y} 0 o destroy @@ -98,7 +102,7 @@ ? {namespace eval ::o array get a 1} {1 7} ? {namespace eval ::o set a(1) 2} 2 ? {o array get a 1} {1 2} -? {::o unset a} "" 1 +? {::o unset a} "" ? {::o array unset a} "" ? {o array exists a} 0 ? {namespace eval ::o array exists a} 0 @@ -114,19 +118,19 @@ ? {::o set ::x 1} 1 ? {info exists ::x} [set ::x] -? {catch {unset ::x}} 0 1 +? {catch {unset ::x}} 0 ? {::o set ::o::x 1} 1 ? {o exists x} [::o set ::o::x] -? {namespace eval ::o unset x} "" 1 +? {namespace eval ::o unset x} "" ? {o exists x} 0 # Note, relatively qualified var names (not prefixed with ::*) # are always resolved relative to the per-object namespace ? {catch {::o set o::x 1} msg} 1 ? {::o set oo::x 1} 1 ? {o::oo exists x} [::o set oo::x] -? {o unset oo::x} "" 1 +? {o unset oo::x} "" ? {o::oo exists x} 0 o destroy @@ -141,12 +145,101 @@ Object o #? {::o set ::o::x 1} 1 #? {o exists x} [::o set ::o::x] -#? {namespace eval ::o unset x} "" 1 +#? {namespace eval ::o unset x} "" #? {o exists x} 0 #? {::o set o::x 1} 1 #? {o exists x} [::o set o::x] -#? {namespace eval ::o unset x} "" 1 +#? {namespace eval ::o unset x} "" #? {o exists x} 0 -o destroy \ No newline at end of file +o destroy + +############################################### +# tests for the compiled var resolver on Object +############################################### + +Object o +o method foo {x} {set .y 2; return ${.x},${.y}} +o method bar {} {return ${.x},${.y}} +o set x 1 +? {o foo 1} "1,2" "create var y and fetch var x" +? {o bar} "1,2" "fetch two instance variables" +? {o info vars} "x y" +# recreate object, check var caching; +# we have to recreate bar, so no problem +Object o +o set x 1 +o method bar {} {return ${.x},${.y}} +? {catch {o bar}} "1" "compiled var y should not exist" +o destroy + +############################################### +# tests for the compiled var resolver on Class +############################################### + +Class create C -parameter {{x 1}} +C create c1 +C method foo {x} {set .y 2; return ${.x},${.y}} +C method bar {} {return ${.x},${.y}} +? {c1 info vars} "x" +? {c1 foo 1} "1,2" "create var y and fetch var x" +? {c1 bar} "1,2" "fetch two instance variables" +? {c1 info vars} "x y" +# recreate object, check var caching; +# we do not have to recreate bar, compiled var persists, +# change must be detected +C create c1 +puts stderr "after recreate" +? {catch {c1 bar}} "1" "compiled var y should not exist" +? {c1 info vars} "x" +c1 destroy +C destroy + +############################################### +# tests for the compiled var resolver with eval +############################################### +Class create C -parameter {{x 1}} +C create c1 +C method foo {x} { + set .y 2; + eval "set .z 3" + return ${.x},${.y},${.z} +} +? {c1 info vars} "x" +? {c1 foo 1} "1,2,3" +? {c1 info vars} "x y z" +C create c1 +? {c1 info vars} "x" +C method foo {x} { + set cmd set + lappend cmd .y + lappend cmd 100 + eval $cmd + return $x,${.y} +} +C method bar {} {puts ${.x};return [info exists .x],[info exists .y]} +C method bar2 {} {if {[info exists .x]} {set .x 1000}; return [info exists .x],[info exists .y]} +? {c1 foo 1} "1,100" +? {c1 bar} "1,0" +? {c1 bar2} "1,0" +c1 unset x +? {c1 bar2} "0,0" +c1 destroy +C destroy + +############################################### +# tests for the compiled var resolver with eval +############################################### +puts "array tests" +Class create C +C create c1 +C method foo {} { + array set .a {a 1 b 2 c 3} + set .z 100 +} +? {c1 info vars} "" +puts call-foo +c1 foo +puts call-foo-done +#? {c1 info vars} "a" \ No newline at end of file