Index: xotcl/ChangeLog =================================================================== diff -u -r225b8b992e16760eca2a7fa7bf51533499c7cc84 -r47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf --- xotcl/ChangeLog (.../ChangeLog) (revision 225b8b992e16760eca2a7fa7bf51533499c7cc84) +++ xotcl/ChangeLog (.../ChangeLog) (revision 47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf) @@ -1,3 +1,13 @@ +2004-07-27 Gustaf.Neumann@wu-wien.ac.at + * fixed bug in filters in connection with instmixin; + inactive tcl callstack frame was dereferenced. This fixed as well + a potential uplevel bug + * fixed access to freed memory (thanks to Zoran for his help with Purify ) + +2004-07-23 Gustaf.Neumann@wu-wien.ac.at + * implemented expermental next method for delegating same-named procs + to different objects + 2004-07-20 Gustaf.Neumann@wu-wien.ac.at * fixed a potential crash when a instmixin was registered on itself Index: xotcl/generic/aol-xotcl.tcl =================================================================== diff -u -rf7894d9be99a8da3a04218abcdb9bd46b6d625c8 -r47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf --- xotcl/generic/aol-xotcl.tcl (.../aol-xotcl.tcl) (revision f7894d9be99a8da3a04218abcdb9bd46b6d625c8) +++ xotcl/generic/aol-xotcl.tcl (.../aol-xotcl.tcl) (revision 47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf) @@ -1,4 +1,4 @@ -# $Id: aol-xotcl.tcl,v 1.1 2004/05/23 22:50:39 neumann Exp $ +# $Id: aol-xotcl.tcl,v 1.2 2004/07/27 09:35:18 neumann Exp $ # # Load XOTcl library and some related packages. @@ -40,7 +40,8 @@ set objects "" ns_log notice "XOTcl extension not loaded; will not copy objects." } - ns_ictl save [append script \n $objects \n $import] + #ns_ictl save [append script \n $objects \n $import] + ns_ictl save [append script \n $import \n $objects] if {0} { set f [open /tmp/__aolserver-blueprint.tcl w] puts $f $script Index: xotcl/generic/xotcl.c =================================================================== diff -u -ra2493e3f5a35557b565be910ee1bf0327cfda563 -r47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf --- xotcl/generic/xotcl.c (.../xotcl.c) (revision a2493e3f5a35557b565be910ee1bf0327cfda563) +++ xotcl/generic/xotcl.c (.../xotcl.c) (revision 47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf) @@ -1,4 +1,4 @@ -/* $Id: xotcl.c,v 1.13 2004/07/23 09:40:16 neumann Exp $ +/* $Id: xotcl.c,v 1.14 2004/07/27 09:35:18 neumann Exp $ * * XOTcl - Extended OTcl * @@ -1948,13 +1948,14 @@ /* static void -CmdListPrint(char *title, XOTclCmdList* cmdList) { +CmdListPrint(Tcl_Interp *in, char *title, XOTclCmdList* cmdList) { if (cmdList) fprintf(stderr,title); while (cmdList) { - fprintf(stderr, " CL=%p, cmdPtr=%p, clientData=%p\n", + fprintf(stderr, " CL=%p, cmdPtr=%p %s, clientData=%p\n", cmdList, cmdList->cmdPtr, + in ? Tcl_GetCommandName(in, cmdList->cmdPtr) : "", cmdList->clientData); cmdList = cmdList->next; } @@ -2511,7 +2512,7 @@ /*noDuplicates*/ 0); /* in the client data of the order list, we require the first - matiching guard ... scan the full list for it. */ + matching guard ... scan the full list for it. */ for (guardChecker = fullList; guardChecker; guardChecker = guardChecker->next) { if (guardChecker->cl == mixinClasses->cl) { new->clientData = guardChecker->clientData; @@ -2532,7 +2533,7 @@ FREE(XOTclClasses, fullList); fullList = nextCl; } - /*CmdListPrint("mixin order\n", obj->mixinOrder);*/ + /*CmdListPrint(in,"mixin order\n", obj->mixinOrder);*/ } @@ -2632,12 +2633,26 @@ currentCmdPtr = obj->mixinStack->currentCmdPtr; *cmdList = obj->mixinOrder; - + /* + fprintf(stderr, "->1 mixin seek current = %p next = %p %s\n", + currentCmdPtr, + (*cmdList)->next, + (*cmdList)->next ? Tcl_GetCommandName(in, (*cmdList)->next->cmdPtr) : ""); + */ +#if defined(ACTIVEMIXIN) + /*RUNTIME_STATE(in)->cmdPtr = (*cmdList)->next ? (*cmdList)->next->cmdPtr : NULL;*/ + RUNTIME_STATE(in)->cmdPtr = (*cmdList)->cmdPtr; +#endif /* go forward to current class */ while (*cmdList && currentCmdPtr) { + /* fprintf(stderr, "->2 mixin seek current = %p next = %p\n", currentCmdPtr, (*cmdList)->next);*/ if ((*cmdList)->cmdPtr == currentCmdPtr) currentCmdPtr = 0; *cmdList = (*cmdList)->next; +#if defined(ACTIVEMIXIN) + /*RUNTIME_STATE(in)->cmdPtr = (*cmdList)->next ? (*cmdList)->next->cmdPtr : NULL;*/ + RUNTIME_STATE(in)->cmdPtr = (*cmdList)->cmdPtr; +#endif } } @@ -2660,7 +2675,7 @@ /* fprintf(stderr, "MixinSearch searching for '%s' %p\n", methodName, cmdList); - CmdListPrint("MixinSearch CL = \n", cmdList); + CmdListPrint(in,"MixinSearch CL = \n", cmdList); */ while (cmdList) { @@ -3753,7 +3768,7 @@ RUNTIME_STATE(in)->callIsDestroy = 0; - /* + /* fprintf(stderr,"*** callProcCheck: cmd = %p\n",cmd); fprintf(stderr, "cp=%p, isTclProc=%d %p %s, dispatch=%d %p, eval=%d %p, ov[0]=%p oc=%d\n", @@ -3770,7 +3785,8 @@ ); */ - if (isTclProc || (Tcl_Command_objProc(cmd) == XOTclObjDispatch) + if (isTclProc + || (Tcl_Command_objProc(cmd) == XOTclObjDispatch) || (Tcl_Command_objProc(cmd) == XOTclForwardMethod) #if defined(TCLCMD) || (Tcl_Command_objProc(cmd) == XOTclOEvalMethod) @@ -3849,8 +3865,8 @@ * we may not be in a method, thus there may be wrong or * no callstackobjs */ - /*fprintf(stderr, "... calling nextmethod\n"); - XOTclCallStackDump(in);*/ + /*fprintf(stderr, "... calling nextmethod\n"); XOTclCallStackDump(in);*/ + rc = XOTclNextMethod(obj, in, cl, methodName, objc, objv, /*useCallStackObjs*/ 0); /*fprintf(stderr, "... after nextmethod\n"); @@ -3984,7 +4000,8 @@ Tcl_ObjCmdProc *proc = 0; Tcl_Command cmd = 0; Tcl_Obj *cmdName = obj->cmdName; - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; + XOTclRuntimeState *rst = RUNTIME_STATE(in); + XOTclCallStack *cs = &rst->cs; #ifdef AUTOVARS int isNext; #endif @@ -4038,7 +4055,7 @@ frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; cl = GetClassFromFullName(in, NSCmdFullName(cmd)); callMethod = (char*) Tcl_GetCommandName(in, cmd); - /* RUNTIME_STATE(in)->filterCalls++; */ + /* rst->filterCalls++; */ } else { FilterStackPop(obj); filterStackPushed = 0; @@ -4094,7 +4111,7 @@ callMethod, frameType, 0 /* fromNext */)) != XOTCL_UNKNOWN)) { if (result == TCL_ERROR) - XOTclErrInProc(in, cmdName, cl?cl->object.cmdName:NULL, callMethod); + XOTclErrInProc(in, cmdName, cl ? cl->object.cmdName : NULL, callMethod); } else if (XOTclObjectIsClass(obj) && (flags & XOTCL_CM_NO_UNKNOWN)) { Tcl_AppendResult(in, ObjStr(objv[0]), ": unable to dispatch method '", @@ -4132,8 +4149,15 @@ fprintf(stderr,"obj %p mixinStackPushed %d mixinStack %p\n", obj, mixinStackPushed, obj->mixinStack); #endif - - if (obj && !(obj->flags & XOTCL_DESTROY_CALLED)/* !isDestroyed*/) { + /* + fprintf(stderr, "obj freed? %p destroy %p self %p %s %d %d\n",obj, + cs->top->destroyedCmd, cs->top->self, ObjStr(objv[1]), + rst->callIsDestroy, + (obj->flags & XOTCL_DESTROY_CALLED)!=0 + ); + */ + if (obj && !rst->callIsDestroy && + !(obj->flags & XOTCL_DESTROY_CALLED)) { if (mixinStackPushed && obj->mixinStack) MixinStackPop(obj); @@ -5014,6 +5038,9 @@ obj->filterStack && obj->filterStack->currentCmdPtr) { *cmd = FilterSearchProc(in, obj, proc, cp, currentCmd); + /*fprintf(stderr,"EndOfChain? proc=%p, cmd=%p\n",*proc,*cmd);*/ + /* XOTclCallStackDump(in); XOTclStackDump(in);*/ + if (*proc == 0) { if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { /* reset the information to the values of method, cl @@ -5022,6 +5049,7 @@ endOfChain = 1; *endOfFilterChain = 1; *cl = 0; + /*fprintf(stderr,"EndOfChain resetting cl\n");*/ } } else { *method = (char*) Tcl_GetCommandName(in, *cmd); @@ -5077,6 +5105,7 @@ * search for a further class method */ *cl = SearchPLMethod(pl, *method, cmd); + /*fprintf(stderr, "no cmd, cl = %p %s\n",*cl, ObjStr((*cl)->object.cmdName));*/ } else { *cl = 0; } @@ -5105,15 +5134,11 @@ XOTclClass **cl = &givenCl; char **method = &givenMethod; -#if 1 +#if !defined(NDEBUG) /***** TO FIX *******/ /*fprintf(stderr,"NextMethod BEGIN varFramePtr=%p current=%p\n", ((Tcl_CallFrame *)Tcl_Interp_varFramePtr(in)), csc->currentFramePtr);*/ -#if 0 - XOTclCallStackDump(in); /*GN*/ - XOTclStackDump(in); /*GN*/ -#endif if (useCallstackObjs) { Tcl_CallFrame *cf = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(in); @@ -5129,8 +5154,10 @@ } cf = (Tcl_CallFrame *)((CallFrame *)cf)->callerPtr; } - /*fprintf(stderr,"found = %d\n", found);*/ + if (!found) { + fprintf(stderr,"found (csc->currentFramePtr %p)= %d cur level=%d\n", + csc->currentFramePtr,found,Tcl_CallFrame_level(Tcl_Interp_varFramePtr(in))); return TCL_OK; } } @@ -5152,7 +5179,8 @@ &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); /* - fprintf(stderr, "NextSearchMethod -- RETURN: method=%s", *method); + fprintf(stderr, "NextSearchMethod -- RETURN: method=%s eoffc=%d,", + *method, endOfFilterChain); if (obj) fprintf(stderr, " obj=%s,", ObjStr(obj->cmdName)); if ((*cl)) @@ -5372,7 +5400,21 @@ if (!strcmp(option, "activelevel")) { Tcl_SetObjResult(in, computeLevelObj(in, ACTIVE_LEVEL)); return TCL_OK; + } +#if defined(ACTIVEMIXIN) + else { + XOTclObject *o = NULL; + csc = CallStackGetTopFrame(in); + CmdListPrint(in,"self a....\n", obj->mixinOrder); + fprintf(stderr,"current cmdPtr = %p cl = %p, mo=%p %p\n", csc->cmdPtr, csc->cl, + obj->mixinOrder, RUNTIME_STATE(in)->cmdPtr); + if (RUNTIME_STATE(in)->cmdPtr) { + o = XOTclGetObjectFromCmdPtr(RUNTIME_STATE(in)->cmdPtr); + } + Tcl_SetObjResult(in, o ? o->cmdName : XOTclGlobalObjects[EMPTY]); + return TCL_OK; } +#endif case 'c': if (!strcmp(option, "calledproc")) { if (!(csc = CallStackFindActiveFilter(in))) @@ -9505,8 +9547,15 @@ XOTclCallStackDump(in); #endif - - RUNTIME_STATE(in)->cs.top->currentFramePtr = varFramePtr; + if (RUNTIME_STATE(in)->cs.top->currentFramePtr == 0) { + RUNTIME_STATE(in)->cs.top->currentFramePtr = varFramePtr; + } else { + /* + fprintf(stderr,"not overwriting currentFramePtr in %p from %p to %p\n", + RUNTIME_STATE(in)->cs.top, + RUNTIME_STATE(in)->cs.top->currentFramePtr, varFramePtr); + */ + } #if !defined(NAMESPACEINSTPROCS) if (varFramePtr) { varFramePtr->nsPtr = GetCallerVarFrame(in,varFramePtr); @@ -9700,7 +9749,7 @@ for (j=0; j < checkc; j++) { r1 = Tcl_ListObjGetElements(in, checkv[j], &checkArgc, &checkArgv); if (r1 == TCL_OK && checkArgc > 1) { - if (isCheckObjectString((ObjStr(checkArgv[0]))) && checkArgc == 2) { + if (isCheckObjString((ObjStr(checkArgv[0]))) && checkArgc == 2) { checkObj = checkArgv[1]; continue; } Index: xotcl/generic/xotclInt.h =================================================================== diff -u -r225b8b992e16760eca2a7fa7bf51533499c7cc84 -r47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf --- xotcl/generic/xotclInt.h (.../xotclInt.h) (revision 225b8b992e16760eca2a7fa7bf51533499c7cc84) +++ xotcl/generic/xotclInt.h (.../xotclInt.h) (revision 47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf) @@ -1,5 +1,5 @@ /* -*- Mode: c++ -*- - * $Id: xotclInt.h,v 1.2 2004/07/20 12:57:59 neumann Exp $ + * $Id: xotclInt.h,v 1.3 2004/07/27 09:35:18 neumann Exp $ * Extended Object Tcl (XOTcl) * * Copyright (C) 1999-2002 Gustaf Neumann, Uwe Zdun @@ -115,7 +115,7 @@ #define isCheckString(m) (\ *m == 'c' && m[1] == 'h' && m[2] == 'e' && m[3] == 'c' && \ m[4] == 'k' && m[5] == '\0') -#define isCheckObjectString(m) (\ +#define isCheckObjString(m) (\ *m == 'c' && m[1] == 'h' && m[2] == 'e' && m[3] == 'c' && \ m[4] == 'k' && m[5] == 'o' && m[6] == 'b' && m[7] == 'j' && \ m[8] == '\0') @@ -138,9 +138,11 @@ #define isInfoString(m) (\ *m == 'i' && m[1] == 'n' && m[2] == 'f' && m[3] == 'o' && \ m[4] == '\0') +#ifdef AUTOVARS #define isNextString(m) (\ *m == 'n' && m[1] == 'e' && m[2] == 'x' && m[3] == 't' && \ m[4] == '\0') +#endif #define isInstinvarString(m) (\ *m == 'i' && m[1] == 'n' && m[2] == 's' && m[3] == 't' && \ m[4] == 'i' && m[5] == 'n' && m[6] == 'v' && m[7] == 'a' && \ @@ -612,6 +614,7 @@ Tcl_Namespace *fakeNS; XotclStubs *xotclStubs; Tcl_CallFrame *varFramePtr; + Command *cmdPtr; #if defined(PROFILE) XOTclProfile profile; #endif Index: xotcl/generic/xotclTrace.c =================================================================== diff -u -ra2493e3f5a35557b565be910ee1bf0327cfda563 -r47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf --- xotcl/generic/xotclTrace.c (.../xotclTrace.c) (revision a2493e3f5a35557b565be910ee1bf0327cfda563) +++ xotcl/generic/xotclTrace.c (.../xotclTrace.c) (revision 47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf) @@ -1,5 +1,5 @@ /* -*- Mode: c++ -*- - * $Id: xotclTrace.c,v 1.3 2004/07/23 09:40:16 neumann Exp $ + * $Id: xotclTrace.c,v 1.4 2004/07/27 09:35:18 neumann Exp $ * * Extended Object Tcl (XOTcl) * @@ -22,24 +22,23 @@ Tcl_Obj *varCmdObj; XOTclNewObj(varCmdObj); - fprintf (stderr, " TCL STACK: "); + fprintf (stderr, " TCL STACK:\n"); if (f == 0) fprintf(stderr, "- "); while (f) { Tcl_Obj *cmdObj; XOTclNewObj(cmdObj); + fprintf(stderr, "\tFrame=%p ", f); if (f && f->isProcCallFrame && f->procPtr && f->procPtr->cmdPtr) { Tcl_GetCommandFullName(in, (Tcl_Command) f->procPtr->cmdPtr, cmdObj); - if (cmdObj) { - fprintf(stderr, " %s (%p) lvl=%d", ObjStr(cmdObj), f->procPtr->cmdPtr, f->level); - } + fprintf(stderr, " %s (%p) lvl=%d\n", ObjStr(cmdObj), f->procPtr->cmdPtr, f->level); DECR_REF_COUNT(cmdObj); - } else fprintf(stderr, "- "); + } else fprintf(stderr, "- \n"); f = f->callerPtr; - if (f) fprintf(stderr, ","); } - fprintf (stderr, " VARFRAME: "); + fprintf (stderr, " VARFRAME:\n"); + fprintf(stderr, "\tFrame=%p ", v); if (v && v->isProcCallFrame && v->procPtr && v->procPtr->cmdPtr) { Tcl_GetCommandFullName(in, (Tcl_Command) v->procPtr->cmdPtr, varCmdObj); if (varCmdObj) { Index: xotcl/library/lib/trace.xotcl =================================================================== diff -u -rf7894d9be99a8da3a04218abcdb9bd46b6d625c8 -r47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf --- xotcl/library/lib/trace.xotcl (.../trace.xotcl) (revision f7894d9be99a8da3a04218abcdb9bd46b6d625c8) +++ xotcl/library/lib/trace.xotcl (.../trace.xotcl) (revision 47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf) @@ -1,4 +1,4 @@ -# -*- Tcl -*- $Id: trace.xotcl,v 1.1 2004/05/23 22:50:39 neumann Exp $ +# -*- Tcl -*- $Id: trace.xotcl,v 1.2 2004/07/27 09:35:18 neumann Exp $ package provide xotcl::trace 0.91 @ @File {description { Various tracing tools for the XOTcl language. @@ -126,7 +126,8 @@ instproc {set dargs [list [lindex $args 0] [lindex $args 1] ...] } default {set dargs $args } } - Trace::puts "CALL $context> [self]->$method $dargs" + my showStack + Trace::puts "CALL $context> [self]->$method $dargs (next=[self next])" set result [next] Trace::puts "EXIT $context> [self]->$method ($result)" return $result Index: xotcl/tests/testx.xotcl =================================================================== diff -u -ra2493e3f5a35557b565be910ee1bf0327cfda563 -r47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf --- xotcl/tests/testx.xotcl (.../testx.xotcl) (revision a2493e3f5a35557b565be910ee1bf0327cfda563) +++ xotcl/tests/testx.xotcl (.../testx.xotcl) (revision 47c4c8f68826b6e7b4b9fa38e65bd77f281d7dbf) @@ -1,4 +1,4 @@ -#$Id: testx.xotcl,v 1.12 2004/07/23 09:40:16 neumann Exp $ +#$Id: testx.xotcl,v 1.13 2004/07/27 09:35:18 neumann Exp $ package require XOTcl namespace import -force xotcl::* @@ -3234,7 +3234,7 @@ o3 m } ::errorCheck [o4 m] \ - "{self=::o1 up1=::o2 up2=::o3 up3=::o4} {self=::o1 up1=::o2 up2=::o2 up3=::o3}" \ + "{self=::o1 up1=::o2 up2=::o3 up3=::o4} {self=::o1 up1=::o1 up2=::o2 up3=::o3}" \ "[self]: uplevel self" o4 m