Index: generic/xotcl.c =================================================================== diff -u -r2c0baf4a8ccba0820da0b4f318be18d2051e00ae -r66262bd1e7460129305d3764339457398b2998d6 --- generic/xotcl.c (.../xotcl.c) (revision 2c0baf4a8ccba0820da0b4f318be18d2051e00ae) +++ generic/xotcl.c (.../xotcl.c) (revision 66262bd1e7460129305d3764339457398b2998d6) @@ -1448,7 +1448,11 @@ #endif hPtr->tablePtr = varHashTable; } - + fprintf(stderr, "+++ makeObjNamespace freeing varTable %p, new VarTable now in %p\n", object->varTable, varHashTable); + /*tcl85showStack(interp);*/ + + CallStackReplaceVarTableReferences(interp, object->varTable, (TclVarHashTable *)varHashTable); + ckfree((char *) object->varTable); object->varTable = NULL; } @@ -1861,8 +1865,10 @@ static Tcl_Namespace * requireObjNamespace(Tcl_Interp *interp, XOTclObject *object) { - if (!object->nsPtr) makeObjNamespace(interp, object); + if (!object->nsPtr) { + makeObjNamespace(interp, object); + } /* This puts a per-object namespace resolver into position upon * acquiring the namespace. Works for object-scoped commands/procs * and object-only ones (set, unset, ...) @@ -5579,9 +5585,9 @@ } # if defined(TCL85STACK_TRACE) fprintf(stderr, "POP OBJECT_FRAME (implicit) frame %p cscPtr %p obj %s obj refcount %d %d\n", NULL, cscPtr, - objectName(obj), - obj->id ? Tcl_Command_refCount(obj->id) : -100, - obj->refCount + objectName(object), + object->id ? Tcl_Command_refCount(object->id) : -100, + object->refCount ); # endif #else /* BEFORE TCL85 */ Index: generic/xotclStack85.c =================================================================== diff -u -rdf9b12b3347ec6d0aaab6a080619734cd4c45f34 -r66262bd1e7460129305d3764339457398b2998d6 --- generic/xotclStack85.c (.../xotclStack85.c) (revision df9b12b3347ec6d0aaab6a080619734cd4c45f34) +++ generic/xotclStack85.c (.../xotclStack85.c) (revision 66262bd1e7460129305d3764339457398b2998d6) @@ -65,11 +65,11 @@ static void XOTcl_PushFrameObj2(Tcl_Interp *interp, XOTclObject *object, Tcl_CallFrame *framePtr) { /*fprintf(stderr,"PUSH OBJECT_FRAME (XOTcl_PushFrame) frame %p\n",framePtr);*/ if (object->nsPtr) { - /*fprintf(stderr,"XOTcl_PushFrame frame %p\n",framePtr);*/ + /*fprintf(stderr,"XOTcl_PushFrame frame %p with object->nsPtr %p\n", framePtr, object->nsPtr);*/ Tcl_PushCallFrame(interp, framePtr, object->nsPtr, 0|FRAME_IS_XOTCL_OBJECT); } else { - /*fprintf(stderr,"XOTcl_PushFrame frame %p (with fakeProc)\n",framePtr);*/ + /*fprintf(stderr,"XOTcl_PushFrame frame %p (with fakeProc)\n",framePtr);*/ Tcl_PushCallFrame(interp, framePtr, Tcl_CallFrame_nsPtr(Tcl_Interp_varFramePtr(interp)), 1|FRAME_IS_XOTCL_OBJECT); @@ -80,6 +80,7 @@ object->varTable, object, framePtr);*/ } Tcl_CallFrame_varTablePtr(framePtr) = object->varTable; + /*fprintf(stderr,"+++ setting varTable %p in varFrame %p\n",object->varTable,framePtr);*/ } XOTcl_PushFrameSetCd(framePtr, object); } @@ -105,6 +106,7 @@ } static void XOTcl_PopFrameCsc2(Tcl_Interp *interp, Tcl_CallFrame *framePtr) { + /*fprintf(stderr,"POP CMETHOD_FRAME (XOTcl_PopFrame) frame %p\n",framePtr);*/ Tcl_PopCallFrame(interp); } @@ -337,6 +339,23 @@ } static void +CallStackReplaceVarTableReferences(Tcl_Interp *interp, TclVarHashTable *oldVarTablePtr, TclVarHashTable *newVarTablePtr) { + Tcl_CallFrame *framePtr; + + for (framePtr = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp); framePtr; + framePtr = Tcl_CallFrame_callerPtr(framePtr)) { + int frameFlags = Tcl_CallFrame_isProcCallFrame(framePtr); + + if (!(frameFlags & FRAME_IS_XOTCL_OBJECT)) continue; + if (!(Tcl_CallFrame_varTablePtr(framePtr) == oldVarTablePtr)) continue; + + fprintf(stderr, "+++ makeObjNamespace replacing vartable %p with %p in frame %p\n", + oldVarTablePtr, newVarTablePtr, framePtr); + Tcl_CallFrame_varTablePtr(framePtr) = newVarTablePtr; + } +} + +static void CallStackClearCmdReferences(Tcl_Interp *interp, Tcl_Command cmd) { register Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); @@ -429,7 +448,7 @@ XOTclObject *object = cscPtr->self; #if defined(TCL85STACK_TRACE) - fprintf(stderr, "POP csc=%p, obj %s method %s (%d)\n", cscPtr, objectName(object), + fprintf(stderr, "POP csc=%p, obj %s method %s\n", cscPtr, objectName(object), Tcl_GetCommandName(interp, cscPtr->cmdPtr)); #endif object->activationCount --; Index: tests/varresolutiontest.xotcl =================================================================== diff -u -rb3b84471d612c5883ec44ee884b6e03fd6574a32 -r66262bd1e7460129305d3764339457398b2998d6 --- tests/varresolutiontest.xotcl (.../varresolutiontest.xotcl) (revision b3b84471d612c5883ec44ee884b6e03fd6574a32) +++ tests/varresolutiontest.xotcl (.../varresolutiontest.xotcl) (revision 66262bd1e7460129305d3764339457398b2998d6) @@ -17,6 +17,7 @@ # Basic tests for var resolution under # per-object namespaces ... ########################################### +Test case globals set ::globalVar 1 Object create o o requireNamespace @@ -38,56 +39,102 @@ ########################################### # scopes ########################################### +Test case scopes + Object create o -o requireNamespace +Object create o2 {set :i 1} o objeval { - # TODO: the next three lines don't seem to work as expected - #my requireNamespace - #global z - #::xotcl::importvar [self] y + # require an namespace within an objscoped frame; it is necessary to replace + # vartables on the stack + my requireNamespace + global g + ::xotcl::importvar o2 i set x 1 set :y 2 set ::z 3 set [self]::X 4 + set g 1 } set ::o::Y 5 +? {info vars ::x} "" ? {info exists ::z} 1 ? {set ::z} 3 -? {lsort [o info vars]} {X Y x y} +? {lsort [o info vars]} {X Y g i x y} ? {o exists x} 1 ? {o exists y} 1 ? {o exists z} 0 ? {o exists X} 1 ? {o exists Y} 1 -? {o set y} 2 +? {o set y} 2 +? {set ::g} 1 o destroy +o2 destroy unset ::z +unset ::g +# like the example above, but with the non-leaf initcmd + +Object create o2 {set :i 1} +Object create o { + my requireNamespace + global g + ::xotcl::importvar o2 i + set x 1 + set :y 2 + set ::z 3 + set [self]::X 4 + set g 1 +} +set ::o::Y 5 +? {info vars ::x} ::x + +? {info exists ::z} 1 +? {set ::z} 3 +? {lsort [o info vars]} {X Y y} +? {o exists x} 0 +? {o exists y} 1 +? {o exists z} 0 +? {o exists X} 1 +? {o exists Y} 1 +? {o set y} 2 +? {set ::g} 1 + +o destroy +o2 destroy +unset ::z +unset ::g +unset ::x + ########################################### # mix & match namespace and object interfaces ########################################### +Test case namespaces Object create o o requireNamespace o set x 1 -? {namespace eval ::o set x} 1 +? {namespace eval ::o {set x}} 1 ? {::o set x} 1 -? {namespace eval ::o set x 3} 3 +? {namespace eval ::o {set x 3}} 3 ? {::o set x} 3 -? {namespace eval ::o info exists x} 1 -? {::o unset x} "" 1 -? {namespace eval ::o info exists x} 0 +? {namespace eval ::o {info exists x}} 1 +? {::o unset x} "" +? {::xotcl::existsvar o x} 0 +? {o exists x} 0 +? {info vars ::x} "" +? {namespace eval ::o {info exists x}} 0 o lappend y 3 -? {namespace eval ::o llength y} 1 -? {namespace eval ::o unset y} "" +? {namespace eval ::o {llength y}} 1 +? {namespace eval ::o {unset y}} "" ? {::o exists y} 0 o destroy ########################################### # array-specific tests ########################################### +Test case namespaces-array Object create o o requireNamespace @@ -113,7 +160,7 @@ ########################################### # tests on namespace-qualified var names ########################################### - +Test case namespaced-var-names Object create o o requireNamespace Object create o::oo @@ -145,7 +192,7 @@ # the tests below fail. We could consider # to require namespaces on the fly in the future -Object create o +#Object create o #? {::o set ::o::x 1} 1 #? {o exists x} [::o set ::o::x] #? {namespace eval ::o unset x} "" @@ -156,12 +203,12 @@ #? {namespace eval ::o unset x} "" #? {o exists x} 0 -o destroy +#o destroy ############################################### # tests for the compiled var resolver on Object ############################################### - +Test case var-resolver-object Object create o o method foo {x} {set :y 2; return ${:x},${:y}} o method bar {} {return ${:x},${:y}} @@ -180,7 +227,7 @@ ############################################### # tests for the compiled var resolver on Class ############################################### - +Test case var-resolver-class Class create C -parameter {{x 1}} C create c1 C method foo {x} {set :y 2; return ${:x},${:y}} @@ -204,6 +251,7 @@ ############################################### # tests for the compiled var resolver with eval ############################################### +Test case compiled-var-resolver Class create C -parameter {{x 1}} C create c1 C method foo {x} { @@ -223,7 +271,7 @@ eval $cmd return $x,${:y} } -C method bar {} {puts ${:x};return [info exists :x],[info exists :y]} +C method bar {} {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,1" @@ -234,9 +282,9 @@ C destroy ############################################### -# tests for the compiled var resolver with eval +# tests with array ############################################### -puts "array tests" + Class create C C create c1 C method foo {} { @@ -251,6 +299,7 @@ ############################################### # tests for the var resolver ############################################### +Test case var-resolver Class create C C method bar0 {} {return ${:x}} C method bar1 {} {set a ${:x}; return [info exists :x],[info exists :y]} @@ -336,54 +385,74 @@ ::xotcl::alias ::xotcl2::Object softeval -nonleaf ::eval ::xotcl::alias ::xotcl2::Object softeval2 ::eval +set G 1 + Object create o { set xxx 1 set :x 1 + ? {info exists G} 1 } ? {o exists x} 1 ? {o exists xxx} 0 -# eval does an objcope, all vars are instance variables +? {info exists ::xxx} 1 +unset -nocomplain ::xxx + +# eval does an objcope, all vars are instance variables; can access preexisting global vars o objeval { set aaa 1 set :a 1 + ? {info exists G} 1 } ? {o exists a} 1 ? {o exists aaa} 1 -# softeval should behave like the creation initcmd (just set dot vars) +? {info exists ::aaa} 0 +unset -nocomplain ::aaa + +# softeval (with -nonleaf) behaves like the initcmd and sets just +# instance variables via resolver. + o softeval { set bbb 1 set :b 1 + ? {info exists G} 1 } ? {o exists b} 1 ? {o exists bbb} 0 -# softeval2 never sets variables +? {info vars ::bbb} ::bbb +unset -nocomplain ::bbb + +# softeval2 never sets instance variables o softeval2 { set zzz 1 set :z 1 + ? {info exists G} 1 } ? {o exists z} 0 ? {o exists zzz} 0 +? {info vars ::zzz} ::zzz +unset -nocomplain ::zzz + ? {lsort [o info vars]} "a aaa b x" o destroy -# now with namespace +# now with an object namespace Object create o o requireNamespace -# eval does an objcope, all vars are instance variables +# objeval does an objcope, all vars are instance variables o objeval { set ccc 1 set :c 1 } ? {o exists c} 1 ? {o exists ccc} 1 -# softeval2 should behave like the creation initcmd (just set dot vars) +# softeval behaves like the creation initcmd (just set dot vars) o softeval { set ddd 1 set :d 1 @@ -401,10 +470,10 @@ ? {lsort [o info vars]} "c ccc d" o destroy -################################################## -# The same as above, but with some global vars. -# The global vars should not influence the behavior. -################################################## +################################################################# +# The same as above, but with some global vars. The global vars +# should not influence the behavior on instance variables +################################################################# Test case with-global-vars foreach var {.x x xxx :a a aaa :b b bbb :c c ccc :d d ddd :z z zzz} {set $var 1} @@ -415,7 +484,7 @@ ? {o exists x} 1 ? {o exists xxx} 0 -# eval does an objcope, all vars are instance variables +# objeval does an objcope, all vars are instance variables o objeval { set aaa 1 set :a 1 @@ -431,7 +500,7 @@ ? {o exists b} 1 ? {o exists bbb} 0 -# softeval2 never sets variables +# softeval2 never sets instance variables o softeval2 { set zzz 1 set :z 1 @@ -472,7 +541,63 @@ ? {lsort [o info vars]} "c ccc d" o destroy +################################################## +# Test with proc scopes +################################################## +Test case proc-scopes +::xotcl::alias ::xotcl2::Object objscoped-eval -objscope ::eval +::xotcl::alias ::xotcl2::Object nonleaf-eval -nonleaf ::eval +::xotcl::alias ::xotcl2::Object plain-eval ::eval +proc foo-via-initcmd {} { + foreach v {x xxx} {unset -nocomplain ::$v} + set p 1 + Object create o { + set xxx 1 + set :x 1 + set ::result G=[info exists G],p=[info exists p] + } + return [o exists x]-[o exists xxx]-[info exists x]-[info exists xxx]-[info exists ::x]-[info exists ::xxx]-$::result +} + +proc foo {type} { + foreach v {x xxx} {unset -nocomplain ::$v} + set p 1 + Object create o + o $type { + set xxx 1 + set :x 1 + set ::result G=[info exists G],p=[info exists p] + } + return [o exists x]-[o exists xxx]-[info exists x]-[info exists xxx]-[info exists ::x]-[info exists ::xxx]-$::result +} + +proc foo-tcl {what} { + foreach v {x xxx} {unset -nocomplain ::$v} + set p 1 + set body { + set xxx 1 + set :x 1 + set ::result G=[info exists G],p=[info exists p] + } + switch $what { + eval {eval $body} + ns-eval {namespace eval [namespace current] $body} + } + return [o exists x]-[o exists xxx]-[info exists x]-[info exists xxx]-[info exists ::x]-[info exists ::xxx]-$::result +} + +set G 1 + + +? {foo-via-initcmd} 1-0-0-0-0-1-G=1,p=0 +? {foo nonleaf-eval} 1-0-0-0-0-1-G=1,p=0 +? {foo objscoped-eval} 1-1-0-0-0-0-G=0,p=0 +? {foo plain-eval} 0-0-0-1-0-0-G=0,p=1 +? {foo-tcl eval} 0-0-0-1-0-0-G=0,p=1 +? {foo-tcl ns-eval} 0-0-0-0-0-1-G=1,p=0 + + ################################################## # dotCmd tests ################################################## @@ -520,7 +645,7 @@ C mixin M1 ? {::xotcl::relation C class-mixin} "::module::M1" - puts stderr "mixin add M" + C mixin add M2 ? {::xotcl::relation C class-mixin} "::module::M2 ::module::M1" } @@ -550,16 +675,16 @@ # dot-resolver/ dot-dispatcher used in aliased proc Test case alias-dot-resolver { - puts stderr HU + Class create V { set :Z 1 set ZZZ 1 :method bar {z} { return $z } - :object method bar {z} { return $z } - :create v { - set :z 2 - set zzz 2 - } + :object method bar {z} { return $z } + :create v { + set :z 2 + set zzz 2 + } } ? {lsort [V info vars]} {Z} ? {lsort [v info vars]} {z}