Index: generic/xotcl.c =================================================================== diff -u -rc72f9f638677608fab1502cd696c8f2d6b2952f9 -r46f02e4868e118466d888b35d6b281b3f2ba31ac --- generic/xotcl.c (.../xotcl.c) (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ generic/xotcl.c (.../xotcl.c) (revision 46f02e4868e118466d888b35d6b281b3f2ba31ac) @@ -1,4 +1,4 @@ -/* $Id: xotcl.c,v 1.51 2007/10/12 19:53:32 neumann Exp $ +/* $Id: xotcl.c,v 1.43 2006/10/04 20:40:23 neumann Exp $ * * XOTcl - Extended Object Tcl * @@ -41,6 +41,7 @@ * the suitability of this software for any purpose. It is * provided "as is" without express or implied warranty." * */ +#define OO 1 #define XOTCL_C 1 #include "xotclInt.h" @@ -64,99 +65,103 @@ */ #ifdef USE_TCL_STUBS -# define XOTcl_ExprObjCmd(cd,in,objc,objv) \ - XOTclCallCommand(in, XOTE_EXPR, objc, objv) -# define XOTcl_SubstObjCmd(cd,in,objc,objv) \ - XOTclCallCommand(in, XOTE_SUBST, objc, objv) +# define XOTcl_ExprObjCmd(clientData,interp,objc,objv) \ + XOTclCallCommand(interp, XOTE_EXPR, objc, objv) +# define XOTcl_SubstObjCmd(clientData,interp,objc,objv) \ + XOTclCallCommand(interp, XOTE_SUBST, objc, objv) #else -# define XOTcl_ExprObjCmd(cd,in,objc,objv) \ - Tcl_ExprObjCmd(cd, in, objc, objv) -# define XOTcl_SubstObjCmd(cd,in,objc,objv) \ - Tcl_SubstObjCmd(cd, in, objc, objv) +# define XOTcl_ExprObjCmd(clientData,interp,objc,objv) \ + Tcl_ExprObjCmd(clientData, interp, objc, objv) +# define XOTcl_SubstObjCmd(clientData,interp,objc,objv) \ + Tcl_SubstObjCmd(clientData, interp, objc, objv) #endif - -static int SetXOTclObjectFromAny(Tcl_Interp *in, Tcl_Obj *objPtr); +static int createMethod(Tcl_Interp *interp, XOTclClass *cl, ClientData clientData, + int objc, Tcl_Obj *CONST objv[]); +static int SetXOTclObjectFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfXOTclObject(Tcl_Obj *objPtr); static void FreeXOTclObjectInternalRep(Tcl_Obj *objPtr); static void DupXOTclObjectInternalRep(Tcl_Obj *src, Tcl_Obj *cpy); -static Tcl_Obj*NameInNamespaceObj(Tcl_Interp *in, char *name, Tcl_Namespace *ns); -static Tcl_Namespace *callingNameSpace(Tcl_Interp *in); -XOTCLINLINE static Tcl_Command NSFindCommand(Tcl_Interp *in, char *name, Tcl_Namespace *ns); +static Tcl_Obj *NameInNamespaceObj(Tcl_Interp *interp, char *name, Tcl_Namespace *ns); +static Tcl_Namespace *callingNameSpace(Tcl_Interp *interp); +XOTCLINLINE static Tcl_Command NSFindCommand(Tcl_Interp *interp, char *name, Tcl_Namespace *ns); -XOTCLINLINE static void GuardAdd(Tcl_Interp *in, XOTclCmdList* filterCL, Tcl_Obj *guard); -static int GuardCheck(Tcl_Interp *in, ClientData guards); -static int GuardCall(XOTclObject *obj, XOTclClass* cl, Tcl_Command cmd, Tcl_Interp *in, ClientData clientData, int push); -static void GuardDel(XOTclCmdList* filterCL); -static int IsMetaClass(Tcl_Interp *in, XOTclClass *cl); -static int hasMixin(Tcl_Interp *in, XOTclObject *obj, XOTclClass *cl); +XOTCLINLINE static void GuardAdd(Tcl_Interp *interp, XOTclCmdList *filterCL, Tcl_Obj *guard); +static int GuardCheck(Tcl_Interp *interp, Tcl_Obj *guards); +static int GuardCall(XOTclObject *obj, XOTclClass *cl, Tcl_Command cmd, Tcl_Interp *interp, Tcl_Obj *guard, int push); +static void GuardDel(XOTclCmdList *filterCL); +static int IsMetaClass(Tcl_Interp *interp, XOTclClass *cl); +static int hasMixin(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl); static int isSubType(XOTclClass *subcl, XOTclClass *cl); +static int setInstVar(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *name, Tcl_Obj *value); +static void MixinComputeDefined(Tcl_Interp *interp, XOTclObject *obj); static Tcl_ObjType XOTclObjectType = { - "XOTclObject", - FreeXOTclObjectInternalRep, - DupXOTclObjectInternalRep, - UpdateStringOfXOTclObject, - SetXOTclObjectFromAny + "XOTclObject", + FreeXOTclObjectInternalRep, + DupXOTclObjectInternalRep, + UpdateStringOfXOTclObject, + SetXOTclObjectFromAny }; typedef enum { CALLING_LEVEL, ACTIVE_LEVEL } CallStackLevel; typedef struct callFrameContext { - int framesSaved; - Tcl_CallFrame *framePtr; - Tcl_CallFrame *varFramePtr; + int framesSaved; + Tcl_CallFrame *framePtr; + Tcl_CallFrame *varFramePtr; } callFrameContext; typedef struct tclCmdClientData { - XOTclObject *obj; - Tcl_Obj *cmdName; + XOTclObject *obj; + Tcl_Obj *cmdName; } tclCmdClientData; typedef struct forwardCmdClientData { - XOTclObject *obj; - Tcl_Obj *cmdName; - Tcl_ObjCmdProc *objProc; - int passthrough; - int needobjmap; - int verbose; - ClientData cd; - int nr_args; - Tcl_Obj *args; - int objscope; - Tcl_Obj *prefix; - int nr_subcommands; - Tcl_Obj *subcommands; + XOTclObject *obj; + Tcl_Obj *cmdName; + Tcl_ObjCmdProc *objProc; + int passthrough; + int needobjmap; + int verbose; + ClientData clientData; + int nr_args; + Tcl_Obj *args; + int objscope; + Tcl_Obj *onerror; + Tcl_Obj *prefix; + int nr_subcommands; + Tcl_Obj *subcommands; } forwardCmdClientData; typedef struct aliasCmdClientData { - XOTclObject *obj; - Tcl_Obj *cmdName; - Tcl_ObjCmdProc *objProc; - ClientData cd; + XOTclObject *obj; + Tcl_Obj *cmdName; + Tcl_ObjCmdProc *objProc; + ClientData clientData; } aliasCmdClientData; -static int ObjDispatch(ClientData cd, Tcl_Interp *in, int objc, +static int ObjDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags); -XOTCLINLINE static int DoDispatch(ClientData cd, Tcl_Interp *in, int objc, +XOTCLINLINE static int DoDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags); -static int XOTclNextMethod(XOTclObject *obj, Tcl_Interp *in, XOTclClass *givenCl, +static int XOTclNextMethod(XOTclObject *obj, Tcl_Interp *interp, XOTclClass *givenCl, char *givenMethod, int objc, Tcl_Obj *CONST objv[], int useCSObjs); -static int XOTclForwardMethod(ClientData cd, Tcl_Interp *in, int objc, +static int XOTclForwardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -static int XOTclObjscopedMethod(ClientData cd, Tcl_Interp *in, int objc, +static int XOTclObjscopedMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -static int XOTclSetterMethod(ClientData cd, Tcl_Interp *in, int objc, +static int XOTclSetterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -static int callDestroyMethod(ClientData cd, Tcl_Interp *in, XOTclObject *obj, int flags); +static int callDestroyMethod(ClientData clientData, Tcl_Interp *interp, XOTclObject *obj, int flags); +static int XOTclObjConvertObject(Tcl_Interp *interp, register Tcl_Obj *objPtr, XOTclObject **obj); -static int XOTclObjConvertObject(Tcl_Interp *in, register Tcl_Obj *objPtr, XOTclObject **obj); -static XOTclObject *XOTclpGetObject(Tcl_Interp *in, char *name); -static XOTclClass *XOTclpGetClass(Tcl_Interp *in, char *name); -static XOTclCallStackContent* CallStackGetFrame(Tcl_Interp *in); +static XOTclObject *XOTclpGetObject(Tcl_Interp *interp, char *name); +static XOTclClass *XOTclpGetClass(Tcl_Interp *interp, char *name); +static XOTclCallStackContent *CallStackGetFrame(Tcl_Interp *interp); #if !defined(NDEBUG) -static void checkAllInstances(Tcl_Interp *in, XOTclClass *startCl, int lvl); +static void checkAllInstances(Tcl_Interp *interp, XOTclClass *startCl, int lvl); #endif @@ -166,34 +171,34 @@ #ifdef PRE81 /* for backward compatibility only -*/ + */ static int -Tcl_EvalObjv(Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[], int flags) { - int i, result; - Tcl_DString ds, *dsp = &ds; +Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags) { + int i, result; + Tcl_DString ds, *dsp = &ds; - assert(flags == 0); - DSTRING_INIT(dsp); - for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(dsp, ObjStr(objv[i])); - } - result = Tcl_Eval(in, Tcl_DStringValue(dsp)); - DSTRING_FREE(dsp); - return result; + assert(flags == 0); + DSTRING_INIT(dsp); + for (i = 0; i < objc; i++) { + Tcl_DStringAppendElement(dsp, ObjStr(objv[i])); + } + result = Tcl_Eval(interp, Tcl_DStringValue(dsp)); + DSTRING_FREE(dsp); + return result; } static int -Tcl_EvalEx(Tcl_Interp *in, char *cmd, int len, int flags) { - return Tcl_Eval(in, cmd); +Tcl_EvalEx(Tcl_Interp *interp, char *cmd, int len, int flags) { + return Tcl_Eval(interp, cmd); } static int -Tcl_SubstObjCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - char *ov[20]; - int i; - assert(objc<19); - for (i=0; icmdName; - tov[1] = method; + tov[0] = obj->cmdName; + tov[1] = method; - if (objc>2) - memcpy(tov+2, objv, sizeof(Tcl_Obj *)*(objc-2)); + if (objc>2) + memcpy(tov+2, objv, sizeof(Tcl_Obj *)*(objc-2)); - /*fprintf(stderr, "%%%% callMethod cmdname=%s, method=%s, objc=%d\n", - ObjStr(tov[0]),ObjStr(tov[1]),objc);*/ - result = DoDispatch(cd, in, objc, tov, flags); - /*fprintf(stderr, " callMethod returns %d\n", result);*/ - FREE_ON_STACK(tov); - return result; + /*fprintf(stderr, "%%%% callMethod cmdname=%s, method=%s, objc=%d\n", + ObjStr(tov[0]),ObjStr(tov[1]),objc); + {int i; fprintf(stderr, "\t CALL: %s ",ObjStr(method));for(i=0; i1); - tov[0] = obj->cmdName; - tov[1] = method; - if (objc>2) { - tov[2] = arg; - } - if (objc>3) - memcpy(tov+3, objv, sizeof(Tcl_Obj *)*(objc-3)); + assert(objc>1); + tov[0] = obj->cmdName; + tov[1] = method; + if (objc>2) { + tov[2] = arg; + } + if (objc>3) + memcpy(tov+3, objv, sizeof(Tcl_Obj *)*(objc-3)); - result = DoDispatch(cd, in, objc, tov, flags); + /*fprintf(stderr, "%%%% callMethodWithArg cmdname=%s, method=%s, objc=%d\n", + ObjStr(tov[0]),ObjStr(tov[1]),objc);*/ + result = DoDispatch(clientData, interp, objc, tov, flags); - FREE_ON_STACK(tov); - return result; + FREE_ON_STACK(tov); + return result; } /* * realize self, class, proc through the [self] command */ XOTCLINLINE static CONST84 char * -GetSelfProc(Tcl_Interp *in) { - /*return Tcl_GetCommandName(in, RUNTIME_STATE(in)->cs.top->cmdPtr);*/ - return Tcl_GetCommandName(in, CallStackGetFrame(in)->cmdPtr); +GetSelfProc(Tcl_Interp *interp) { + /*return Tcl_GetCommandName(interp, RUNTIME_STATE(interp)->cs.top->cmdPtr);*/ + return Tcl_GetCommandName(interp, CallStackGetFrame(interp)->cmdPtr); } XOTCLINLINE static XOTclClass* -GetSelfClass(Tcl_Interp *in) { - /*return RUNTIME_STATE(in)->cs.top->cl;*/ - return CallStackGetFrame(in)->cl; +GetSelfClass(Tcl_Interp *interp) { + /*return RUNTIME_STATE(interp)->cs.top->cl;*/ + return CallStackGetFrame(interp)->cl; } XOTCLINLINE static XOTclObject* -GetSelfObj(Tcl_Interp *in) { - return CallStackGetFrame(in)->self; +GetSelfObj(Tcl_Interp *interp) { + return CallStackGetFrame(interp)->self; } /* extern callable GetSelfObj */ XOTcl_Object* -XOTclGetSelfObj(Tcl_Interp *in) { - return (XOTcl_Object*)GetSelfObj(in); +XOTclGetSelfObj(Tcl_Interp *interp) { + return (XOTcl_Object*)GetSelfObj(interp); } XOTCLINLINE static Tcl_Command -GetSelfProcCmdPtr(Tcl_Interp *in) { - /*return RUNTIME_STATE(in)->cs.top->cmdPtr;*/ - return CallStackGetFrame(in)->cmdPtr; +GetSelfProcCmdPtr(Tcl_Interp *interp) { + /*return RUNTIME_STATE(interp)->cs.top->cmdPtr;*/ + return CallStackGetFrame(interp)->cmdPtr; } /* @@ -686,43 +697,44 @@ */ extern void XOTclDeprecatedMsg(char *oldCmd, char *newCmd) { - fprintf(stderr, "**\n**\n** The command/method <%s> is deprecated.\n", oldCmd); - if (newCmd) - fprintf(stderr, "** Use <%s> instead.\n", newCmd); - fprintf(stderr, "**\n"); + fprintf(stderr, "**\n**\n** The command/method <%s> is deprecated.\n", oldCmd); + if (newCmd) + fprintf(stderr, "** Use <%s> instead.\n", newCmd); + fprintf(stderr, "**\n"); } static int -XOTcl_DeprecatedCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - char *new; - if (objc == 2) - new = 0; - else if (objc == 3) - new = ObjStr(objv[2]); - else - return XOTclObjErrArgCnt(in, NULL, "deprecated oldcmd ?newcmd?"); - XOTclDeprecatedMsg(ObjStr(objv[1]), new); - return TCL_OK; +XOTcl_DeprecatedCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + char *new; + if (objc == 2) + new = 0; + else if (objc == 3) + new = ObjStr(objv[2]); + else + return XOTclObjErrArgCnt(interp, NULL, NULL, "deprecated oldcmd ?newcmd?"); + XOTclDeprecatedMsg(ObjStr(objv[1]), new); + return TCL_OK; } #ifdef DISPATCH_TRACE static void printObjv(int objc, Tcl_Obj *CONST objv[]) { - int i, j; - if (objc <= 3) j = objc; else j = 3; - for (i=0;i 3) fprintf(stderr," ..."); - fprintf(stderr," (objc=%d)",objc); + int i, j; + fprintf(stderr, "(%d)", objc); + if (objc <= 3) j = objc; else j = 3; + for (i=0;i 3) fprintf(stderr," ..."); + fprintf(stderr," (objc=%d)",objc); } -static void printCall(Tcl_Interp *in, char *string, int objc, Tcl_Obj *CONST objv[]) { - fprintf(stderr, " (%d) >%s: ", Tcl_Interp_numLevels(in), string); - printObjv(objc, objv); - fprintf(stderr, "\n"); +static void printCall(Tcl_Interp *interp, char *string, int objc, Tcl_Obj *CONST objv[]) { + fprintf(stderr, " (%d) >%s: ", Tcl_Interp_numLevels(interp), string); + printObjv(objc, objv); + fprintf(stderr, "\n"); } -static void printExit(Tcl_Interp *in, char *string, +static void printExit(Tcl_Interp *interp, char *string, int objc, Tcl_Obj *CONST objv[], int result) { - fprintf(stderr, " (%d) <%s: ", Tcl_Interp_numLevels(in), string); - /*printObjv(objc, objv);*/ - fprintf(stderr, " result=%d\n", result); + fprintf(stderr, " (%d) <%s: ", Tcl_Interp_numLevels(interp), string); + /*printObjv(objc, objv);*/ + fprintf(stderr, " result=%d '%s'\n", result, ObjStr(Tcl_GetObjResult(interp))); } #endif @@ -731,32 +743,30 @@ * XOTclObject Reference Accounting */ #if defined(XOTCLOBJ_TRACE) -# define XOTclObjectRefCountIncr(obj) \ - obj->refCount++; \ - fprintf(stderr, "RefCountIncr %p count=%d %s\n", obj, obj->refCount,obj->cmdName?ObjStr(obj->cmdName):"no name"); \ - MEM_COUNT_ALLOC("XOTclObject RefCount",obj) -# define XOTclObjectRefCountDecr(obj) \ - obj->refCount--; \ - fprintf(stderr, "RefCountDecr %p count=%d\n", obj, obj->refCount); \ - MEM_COUNT_FREE("XOTclObject RefCount", obj) +# define XOTclObjectRefCountIncr(obj) \ + obj->refCount++; \ + fprintf(stderr, "RefCountIncr %p count=%d %s\n", obj, obj->refCount,obj->cmdName?ObjStr(obj->cmdName):"no name"); \ + MEM_COUNT_ALLOC("XOTclObject RefCount",obj) +# define XOTclObjectRefCountDecr(obj) \ + obj->refCount--; \ + fprintf(stderr, "RefCountDecr %p count=%d\n", obj, obj->refCount); \ + MEM_COUNT_FREE("XOTclObject RefCount", obj) #else -# define XOTclObjectRefCountIncr(obj) \ - obj->refCount++; \ - MEM_COUNT_ALLOC("XOTclObject RefCount",obj) -# define XOTclObjectRefCountDecr(obj) \ - obj->refCount--; \ - MEM_COUNT_FREE("XOTclObject RefCount",obj) +# define XOTclObjectRefCountIncr(obj) \ + obj->refCount++; \ + MEM_COUNT_ALLOC("XOTclObject RefCount",obj) +# define XOTclObjectRefCountDecr(obj) \ + obj->refCount--; \ + MEM_COUNT_FREE("XOTclObject RefCount",obj) #endif #if defined(XOTCLOBJ_TRACE) void objTrace(char *string, XOTclObject *obj) { - if (obj) - fprintf(stderr,"--- %s tcl %p %s (%d %p) xotcl %p (%d) %s \n", string, - obj->cmdName, obj->cmdName->typePtr ? obj->cmdName->typePtr->name : "NULL", - obj->cmdName->refCount, obj->cmdName->internalRep.twoPtrValue.ptr1, - obj, obj->refCount, ObjStr(obj->cmdName)); - else - fprintf(stderr,"--- No object: %s\n",string); + if(obj) + fprintf(stderr,"--- %s tcl %p (%d) xotcl %p (%d) %s \n", string, + obj->cmdName, obj->cmdName->refCount, obj, obj->refCount, ObjStr(obj->cmdName)); + else + fprintf(stderr,"--- No object: %s\n",string); } #else # define objTrace(a,b) @@ -766,60 +776,60 @@ /* search for tail of name */ static char * NSTail(char *string) { - register char *p = string+strlen(string); - while (p > string) { - if (*p == ':' && *(p-1) == ':') return p+1; - p--; - } - return string; + register char *p = string + strlen(string); + while (p > string) { + if (*p == ':' && *(p-1) == ':') return p+1; + p--; + } + return string; } XOTCLINLINE static int isClassName(char *string) { - return (strncmp((string), "::xotcl::classes", 16) == 0); + return (strncmp((string), "::xotcl::classes", 16) == 0); } /* removes preceding ::xotcl::classes from a string */ XOTCLINLINE static char * NSCutXOTclClasses(char *string) { - assert(strncmp((string), "::xotcl::classes", 16) == 0); - return string+16; + assert(strncmp((string), "::xotcl::classes", 16) == 0); + return string+16; } XOTCLINLINE static char * NSCmdFullName(Tcl_Command cmd) { - Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(cmd); - return nsPtr ? nsPtr->fullName : ""; + Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(cmd); + return nsPtr ? nsPtr->fullName : ""; } static void XOTclCleanupObject(XOTclObject *obj) { - XOTclObjectRefCountDecr(obj); + XOTclObjectRefCountDecr(obj); #if REFCOUNT_TRACE - fprintf(stderr,"###CLNO %p refcount = %d\n", obj, obj->refCount); + fprintf(stderr,"###CLNO %p refcount = %d\n", obj, obj->refCount); #endif - if (obj->refCount <= 0) { - assert(obj->refCount == 0); - assert(obj->flags & XOTCL_DESTROYED); + if (obj->refCount <= 0) { + assert(obj->refCount == 0); + assert(obj->flags & XOTCL_DESTROYED); #if REFCOUNT_TRACE - fprintf(stderr,"###CLNO %p flags %x rc %d destr %d dc %d\n", - obj, obj->flags, - (obj->flags & XOTCL_REFCOUNTED) != 0, - (obj->flags & XOTCL_DESTROYED) != 0, - (obj->flags & XOTCL_DESTROY_CALLED) != 0 - ); + fprintf(stderr,"###CLNO %p flags %x rc %d destr %d dc %d\n", + obj, obj->flags, + (obj->flags & XOTCL_REFCOUNTED) != 0, + (obj->flags & XOTCL_DESTROYED) != 0, + (obj->flags & XOTCL_DESTROY_CALLED) != 0 + ); #endif - MEM_COUNT_FREE("XOTclObject/XOTclClass",obj); + MEM_COUNT_FREE("XOTclObject/XOTclClass",obj); #if defined(XOTCLOBJ_TRACE) || defined(REFCOUNT_TRACE) - fprintf(stderr, "CKFREE Object %p refcount=%d\n", obj, obj->refCount); + fprintf(stderr, "CKFREE Object %p refcount=%d\n", obj, obj->refCount); #endif #if !defined(NDEBUG) - memset(obj, 0, sizeof(XOTclObject)); + memset(obj, 0, sizeof(XOTclObject)); #endif - /* fprintf(stderr,"CKFREE obj %p\n",obj);*/ - ckfree((char *) obj); - } + /* fprintf(stderr,"CKFREE obj %p\n",obj);*/ + ckfree((char *) obj); + } } @@ -829,172 +839,172 @@ */ static void RegisterObjTypes() { - Tcl_RegisterObjType(&XOTclObjectType); + Tcl_RegisterObjType(&XOTclObjectType); } static void FreeXOTclObjectInternalRep(register Tcl_Obj *objPtr) { - XOTclObject *obj = (XOTclObject*) objPtr->internalRep.otherValuePtr; + XOTclObject *obj = (XOTclObject*) objPtr->internalRep.otherValuePtr; - /* fprintf(stderr,"FIP objPtr %p obj %p obj->cmd %p '%s', bytes='%s'\n", - objPtr,obj, obj->cmdName, ObjStr(obj->cmdName), objPtr->bytes); - */ + /* fprintf(stderr,"FIP objPtr %p obj %p obj->cmd %p '%s', bytes='%s'\n", + objPtr,obj, obj->cmdName, ObjStr(obj->cmdName), objPtr->bytes); + */ #if defined(XOTCLOBJ_TRACE) - if (obj) - fprintf(stderr,"FIP --- tcl %p (%d)\n",objPtr,objPtr->refCount); + if (obj) + fprintf(stderr,"FIP --- tcl %p (%d)\n",objPtr,objPtr->refCount); #endif #if !defined(REFCOUNTED) - if (obj != NULL) { - XOTclCleanupObject(obj); - } + if (obj != NULL) { + XOTclCleanupObject(obj); + } #else - if (obj != NULL) { + if (obj != NULL) { #if REFCOUNT_TRACE - fprintf(stderr, "FIP in %p\n", obj->teardown); - fprintf(stderr, "FIP call is destroy %d\n", RUNTIME_STATE(obj->teardown)->callIsDestroy); - fprintf(stderr,"FIP %p flags %x rc %d destr %d dc %d refcount = %d\n", - obj, obj->flags, - (obj->flags & XOTCL_REFCOUNTED) != 0, - (obj->flags & XOTCL_DESTROYED) != 0, - (obj->flags & XOTCL_DESTROY_CALLED) != 0, - obj->refCount - ); + fprintf(stderr, "FIP in %p\n", obj->teardown); + fprintf(stderr, "FIP call is destroy %d\n", RUNTIME_STATE(obj->teardown)->callIsDestroy); + fprintf(stderr,"FIP %p flags %x rc %d destr %d dc %d refcount = %d\n", + obj, obj->flags, + (obj->flags & XOTCL_REFCOUNTED) != 0, + (obj->flags & XOTCL_DESTROYED) != 0, + (obj->flags & XOTCL_DESTROY_CALLED) != 0, + obj->refCount + ); #endif - if (obj->flags & XOTCL_REFCOUNTED && - !(obj->flags & XOTCL_DESTROY_CALLED)) { - Tcl_Interp *in = obj->teardown; - INCR_REF_COUNT(obj->cmdName); - callDestroyMethod((ClientData)obj, in, obj, 0); - /* the call to cleanup is the counterpart of the - INCR_REF_COUNT(obj->cmdName) above */ - XOTclCleanupObject(obj); - } else { - fprintf(stderr, "BEFORE CLEANUPOBJ %x\n", (obj->flags & XOTCL_REFCOUNTED)); - XOTclCleanupObject(obj); - fprintf(stderr, "AFTER CLEANUPOBJ\n"); + if (obj->flags & XOTCL_REFCOUNTED && + !(obj->flags & XOTCL_DESTROY_CALLED)) { + Tcl_Interp *interp = obj->teardown; + INCR_REF_COUNT(obj->cmdName); + callDestroyMethod((ClientData)obj, interp, obj, 0); + /* the call to cleanup is the counterpart of the + INCR_REF_COUNT(obj->cmdName) above */ + XOTclCleanupObject(obj); + } else { + fprintf(stderr, "BEFORE CLEANUPOBJ %x\n", (obj->flags & XOTCL_REFCOUNTED)); + XOTclCleanupObject(obj); + fprintf(stderr, "AFTER CLEANUPOBJ\n"); + } } - } #endif - objPtr->internalRep.otherValuePtr = NULL; - objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; + objPtr->typePtr = NULL; } static void DupXOTclObjectInternalRep(Tcl_Obj *src, Tcl_Obj *cpy) { - XOTclObject *obj = (XOTclObject*)src->internalRep.otherValuePtr; + XOTclObject *obj = (XOTclObject*)src->internalRep.otherValuePtr; #if defined(XOTCLOBJ_TRACE) - if (obj) fprintf(stderr,"DIP --- tcl %p (%d)\n", src, src->refCount); + if (obj) fprintf(stderr,"DIP --- tcl %p (%d)\n", src, src->refCount); #endif - XOTclObjectRefCountIncr(obj); - cpy->internalRep.otherValuePtr = src->internalRep.otherValuePtr; - cpy->typePtr = src->typePtr; + XOTclObjectRefCountIncr(obj); + cpy->internalRep.otherValuePtr = src->internalRep.otherValuePtr; + cpy->typePtr = src->typePtr; } static int -SetXOTclObjectFromAny(Tcl_Interp *in, register Tcl_Obj *objPtr) { - Tcl_ObjType *oldTypePtr = objPtr->typePtr; - char *string = ObjStr(objPtr); - XOTclObject *obj; - Tcl_Obj *tmpName = NULL; - int result = TCL_OK; +SetXOTclObjectFromAny(Tcl_Interp *interp, register Tcl_Obj *objPtr) { + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string = ObjStr(objPtr); + XOTclObject *obj; + Tcl_Obj *tmpName = NULL; + int result = TCL_OK; #ifdef XOTCLOBJ_TRACE - fprintf(stderr,"SetXOTclObjectFromAny %p '%s' %p\n", - objPtr,string,objPtr->typePtr); - if (oldTypePtr) - fprintf(stderr," convert %s to XOTclObject\n", oldTypePtr->name); + fprintf(stderr,"SetXOTclObjectFromAny %p '%s' %p\n", + objPtr,string,objPtr->typePtr); + if (oldTypePtr) + fprintf(stderr," convert %s to XOTclObject\n", oldTypePtr->name); #endif - if (!isAbsolutePath(string)) { - char *nsString; - tmpName = NameInNamespaceObj(in,string,callingNameSpace(in)); + if (!isAbsolutePath(string)) { + char *nsString; + tmpName = NameInNamespaceObj(interp,string,callingNameSpace(interp)); - nsString = ObjStr(tmpName); - INCR_REF_COUNT(tmpName); - obj = XOTclpGetObject(in, nsString); - DECR_REF_COUNT(tmpName); - if (!obj) { - /* retry with global namespace */ - tmpName = Tcl_NewStringObj("::",2); - Tcl_AppendToObj(tmpName,string,-1); - INCR_REF_COUNT(tmpName); - obj = XOTclpGetObject(in, ObjStr(tmpName)); - DECR_REF_COUNT(tmpName); + nsString = ObjStr(tmpName); + INCR_REF_COUNT(tmpName); + obj = XOTclpGetObject(interp, nsString); + DECR_REF_COUNT(tmpName); + if (!obj) { + /* retry with global namespace */ + tmpName = Tcl_NewStringObj("::",2); + Tcl_AppendToObj(tmpName,string,-1); + INCR_REF_COUNT(tmpName); + obj = XOTclpGetObject(interp, ObjStr(tmpName)); + DECR_REF_COUNT(tmpName); + } + } else { + obj = XOTclpGetObject(interp, string); } - } else { - obj = XOTclpGetObject(in, string); - } #if 0 - obj = XOTclpGetObject(in, string); + obj = XOTclpGetObject(interp, string); #endif - if (obj) { - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + if (obj) { + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { #ifdef XOTCLOBJ_TRACE - fprintf(stderr," freeing type=%p, type=%s\n", - objPtr->typePtr, objPtr->typePtr ? objPtr->typePtr->name : ""); + fprintf(stderr," freeing type=%p, type=%s\n", + objPtr->typePtr, objPtr->typePtr ? objPtr->typePtr->name : ""); #endif - oldTypePtr->freeIntRepProc(objPtr); - } - XOTclObjectRefCountIncr(obj); + oldTypePtr->freeIntRepProc(objPtr); + } + XOTclObjectRefCountIncr(obj); #if defined(XOTCLOBJ_TRACE) - fprintf(stderr, "SetXOTclObjectFromAny tcl %p (%d) xotcl %p (%d)\n", - objPtr, objPtr->refCount, obj, obj->refCount); + fprintf(stderr, "SetXOTclObjectFromAny tcl %p (%d) xotcl %p (%d)\n", + objPtr, objPtr->refCount, obj, obj->refCount); #endif - objPtr->internalRep.otherValuePtr = (XOTclObject*) obj; - objPtr->typePtr = &XOTclObjectType; - } else - result = TCL_ERROR; + objPtr->internalRep.otherValuePtr = (XOTclObject*) obj; + objPtr->typePtr = &XOTclObjectType; + } else + result = TCL_ERROR; - return result; + return result; } static void UpdateStringOfXOTclObject(register Tcl_Obj *objPtr) { - XOTclObject *obj = (XOTclObject *)objPtr->internalRep.otherValuePtr; - char *nsFullName = NULL; + XOTclObject *obj = (XOTclObject *)objPtr->internalRep.otherValuePtr; + char *nsFullName = NULL; #ifdef XOTCLOBJ_TRACE - fprintf(stderr,"UpdateStringOfXOTclObject %p refCount %d\n", - objPtr,objPtr->refCount); - fprintf(stderr," teardown %p id %p destroyCalled %d\n", - obj->teardown, obj->id, (obj->flags & XOTCL_DESTROY_CALLED)); + fprintf(stderr,"UpdateStringOfXOTclObject %p refCount %d\n", + objPtr,objPtr->refCount); + fprintf(stderr," teardown %p id %p destroyCalled %d\n", + obj->teardown, obj->id, (obj->flags & XOTCL_DESTROY_CALLED)); #endif - /* Here we use GetCommandName, because it doesnt need - Interp*, but Tcl_GetCommandFullName(in,obj->id,ObjName); does*/ - if (obj && !(obj->flags & XOTCL_DESTROY_CALLED)) { - Tcl_DString ds, *dsp = &ds; - unsigned l; - DSTRING_INIT(dsp); - nsFullName = NSCmdFullName(obj->id); - if (!(*nsFullName==':' && *(nsFullName+1)==':' && - *(nsFullName+2)=='\0')) { - Tcl_DStringAppend(dsp, nsFullName, -1); - } - Tcl_DStringAppend(dsp, "::", 2); - Tcl_DStringAppend(dsp, Tcl_GetCommandName(NULL, obj->id), -1); + /* Here we use GetCommandName, because it doesnt need + Interp*, but Tcl_GetCommandFullName(interp,obj->id,ObjName); does*/ + if (obj && !(obj->flags & XOTCL_DESTROY_CALLED)) { + Tcl_DString ds, *dsp = &ds; + unsigned l; + DSTRING_INIT(dsp); + nsFullName = NSCmdFullName(obj->id); + if (!(*nsFullName==':' && *(nsFullName+1)==':' && + *(nsFullName+2)=='\0')) { + Tcl_DStringAppend(dsp, nsFullName, -1); + } + Tcl_DStringAppend(dsp, "::", 2); + Tcl_DStringAppend(dsp, Tcl_GetCommandName(NULL, obj->id), -1); - l = (unsigned) Tcl_DStringLength(dsp)+1; - objPtr->bytes = (char *) ckalloc(l); - memcpy(objPtr->bytes, Tcl_DStringValue(dsp), l); - objPtr->length = Tcl_DStringLength(dsp); - DSTRING_FREE(dsp); - } else if (obj) { - fprintf(stderr,"try to read string of deleted command\n"); - FreeXOTclObjectInternalRep(objPtr); - objPtr->bytes = NULL; - objPtr->length = 0; - } else { - objPtr->bytes = NULL; - objPtr->length = 0; - } - /* - fprintf(stderr, "+++UpdateStringOfXOTclObject bytes='%s',length=%d\n", - objPtr->bytes,objPtr->length); - */ + l = (unsigned) Tcl_DStringLength(dsp)+1; + objPtr->bytes = (char *) ckalloc(l); + memcpy(objPtr->bytes, Tcl_DStringValue(dsp), l); + objPtr->length = Tcl_DStringLength(dsp); + DSTRING_FREE(dsp); + } else if (obj) { + fprintf(stderr,"try to read string of deleted command\n"); + FreeXOTclObjectInternalRep(objPtr); + objPtr->bytes = NULL; + objPtr->length = 0; + } else { + objPtr->bytes = NULL; + objPtr->length = 0; + } + /* + fprintf(stderr, "+++UpdateStringOfXOTclObject bytes='%s',length=%d\n", + objPtr->bytes,objPtr->length); + */ } #ifdef NOTUSED @@ -1006,33 +1016,33 @@ objPtr->internalRep.otherValuePtr = obj; objPtr->typePtr = &XOTclObjectType; #ifdef XOTCLOBJ_TRACE - fprintf(stderr,"NewXOTclObjectObj %p\n",objPtr); + fprintf(stderr,"NewXOTclObjectObj %p\n",objPtr); #endif - return objPtr; + return objPtr; } #endif static Tcl_Obj * NewXOTclObjectObjName(register XOTclObject *obj, char *name, unsigned l) { - register Tcl_Obj *objPtr = 0; + register Tcl_Obj *objPtr = 0; - XOTclNewObj(objPtr); + XOTclNewObj(objPtr); - objPtr->length = l; - objPtr->bytes = ckalloc(l+1); - memcpy(objPtr->bytes, name, l); - *(objPtr->bytes+l) = 0; - objPtr->internalRep.otherValuePtr = obj; - objPtr->typePtr = &XOTclObjectType; + objPtr->length = l; + objPtr->bytes = ckalloc(l+1); + memcpy(objPtr->bytes, name, l); + *(objPtr->bytes+l) = 0; + objPtr->internalRep.otherValuePtr = obj; + objPtr->typePtr = &XOTclObjectType; #ifdef XOTCLOBJ_TRACE fprintf(stderr,"NewXOTclObjectObjName tcl %p (%d) xotcl %p (%d) %s\n", objPtr, objPtr->refCount, obj, obj->refCount, objPtr->bytes); #endif - XOTclObjectRefCountIncr(obj); + XOTclObjectRefCountIncr(obj); - return objPtr; + return objPtr; } #ifdef KEEP_TCL_CMD_TYPE @@ -1045,23 +1055,23 @@ if (cmdType && cmdType != &XOTclObjectType && !strcmp(cmdType->name,"cmdName")) { - tclCmdNameType = cmdType; - } + tclCmdNameType = cmdType; + } # else - static XOTclMutex initMutex = 0; - XOTclMutexLock(&initMutex); - if (tclCmdNameType == NULL) - tclCmdNameType = Tcl_GetObjType("cmdName"); - XOTclMutexUnlock(&initMutex); + static XOTclMutex initMutex = 0; + XOTclMutexLock(&initMutex); + if (tclCmdNameType == NULL) + tclCmdNameType = Tcl_GetObjType("cmdName"); + XOTclMutexUnlock(&initMutex); # endif - } + } return tclCmdNameType; } #endif #if NOTUSED static int -XOTclObjGetObject(Tcl_Interp *in, register Tcl_Obj *objPtr, XOTclObject **obj) { +XOTclObjGetObject(Tcl_Interp *interp, register Tcl_Obj *objPtr, XOTclObject **obj) { int result; register Tcl_ObjType *cmdType = objPtr->typePtr; XOTclObject *o; @@ -1075,7 +1085,7 @@ } if (cmdType == GetCmdNameType(cmdType)) { - Tcl_Command cmd = Tcl_GetCommandFromObj(in, objPtr); + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr); /*fprintf(stderr,"obj is of type tclCmd\n");*/ if (cmd) { o = XOTclGetObjectFromCmdPtr(cmd); @@ -1086,7 +1096,7 @@ } } - o = XOTclpGetObject(in, ObjStr(objPtr)); + o = XOTclpGetObject(interp, ObjStr(objPtr)); if (o) { *obj = o; return TCL_OK; @@ -1096,318 +1106,342 @@ #endif static int -XOTclObjConvertObject(Tcl_Interp *in, Tcl_Obj *objPtr, XOTclObject **obj) { +XOTclObjConvertObject(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclObject **obj) { int result; register Tcl_ObjType *cmdType = objPtr->typePtr; - /* * Only really share the "::x" Tcl_Objs but not "x" because we so not have * references upon object kills and then will get dangling * internalRep references to killed XOTclObjects */ if (cmdType == &XOTclObjectType) { - /*fprintf(stderr,"obj is of type XOTclObjectType\n");*/ - if (obj) { - XOTclObject *o = (XOTclObject*) objPtr->internalRep.otherValuePtr; - int refetch = 0; - if (o->flags & XOTCL_DESTROYED) { - /* fprintf(stderr,"????? calling free by hand\n"); */ - FreeXOTclObjectInternalRep(objPtr); - refetch = 1; - result = SetXOTclObjectFromAny(in, objPtr); - if (result == TCL_OK) { - o = (XOTclObject*) objPtr->internalRep.otherValuePtr; - assert(o && !(o->flags & XOTCL_DESTROYED)); - } - } else { - result = TCL_OK; - } + /*fprintf(stderr,"obj is of type XOTclObjectType\n");*/ + if (obj) { + XOTclObject *o = (XOTclObject*) objPtr->internalRep.otherValuePtr; + int refetch = 0; + if (o->flags & XOTCL_DESTROYED) { + /* fprintf(stderr,"????? calling free by hand\n"); */ + FreeXOTclObjectInternalRep(objPtr); + refetch = 1; + result = SetXOTclObjectFromAny(interp, objPtr); + if (result == TCL_OK) { + o = (XOTclObject*) objPtr->internalRep.otherValuePtr; + assert(o && !(o->flags & XOTCL_DESTROYED)); + } + } else { + result = TCL_OK; + } - *obj = o; + *obj = o; #ifdef XOTCLOBJ_TRACE - if (result == TCL_OK) - fprintf(stderr,"XOTclObjConvertObject tcl %p (%d) xotcl %p (%d) r=%d %s\n", - objPtr, objPtr->refCount, o, o->refCount, refetch, objPtr->bytes); - else - fprintf(stderr,"XOTclObjConvertObject tcl %p (%d) **** rc=%d r=%d %s\n", - objPtr, objPtr->refCount, result, refetch, objPtr->bytes); + if (result == TCL_OK) + fprintf(stderr,"XOTclObjConvertObject tcl %p (%d) xotcl %p (%d) r=%d %s\n", + objPtr, objPtr->refCount, o, o->refCount, refetch, objPtr->bytes); + else + fprintf(stderr,"XOTclObjConvertObject tcl %p (%d) **** rc=%d r=%d %s\n", + objPtr, objPtr->refCount, result, refetch, objPtr->bytes); #endif - } else { - result = TCL_OK; - } + } else { + result = TCL_OK; + } #ifdef KEEP_TCL_CMD_TYPE - } else if (cmdType == GetCmdNameType(cmdType)) { - Tcl_Command cmd = Tcl_GetCommandFromObj(in, objPtr); - /*fprintf(stderr,"obj %s is of type tclCmd, cmd=%p\n",ObjStr(objPtr),cmd);*/ - if (cmd) { - XOTclObject *o = XOTclGetObjectFromCmdPtr(cmd); - /* - fprintf(stderr,"Got Object from '%s' %p\n",objPtr->bytes,o); - fprintf(stderr,"cmd->objProc %p == %p, proc=%p\n", + } else if (cmdType == GetCmdNameType(cmdType)) { + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr); + /*fprintf(stderr,"obj %s is of type tclCmd, cmd=%p\n",ObjStr(objPtr),cmd);*/ + if (cmd) { + XOTclObject *o = XOTclGetObjectFromCmdPtr(cmd); + + /*fprintf(stderr,"Got Object from '%s' %p\n",objPtr->bytes,o); + fprintf(stderr,"cmd->objProc %p == %p, proc=%p\n", Tcl_Command_objProc(cmd), XOTclObjDispatch, - Tcl_Command_proc(cmd) ); - */ - if (o) { - if (obj) *obj = o; - result = TCL_OK; - } else { - goto convert_to_xotcl_object; - } - } else goto convert_to_xotcl_object; + Tcl_Command_proc(cmd) );*/ + + if (o) { + if (obj) *obj = o; + result = TCL_OK; + } else { + goto convert_to_xotcl_object; + } + } else goto convert_to_xotcl_object; #endif - } else { + } else { #ifdef KEEP_TCL_CMD_TYPE - convert_to_xotcl_object: + convert_to_xotcl_object: #endif - result = SetXOTclObjectFromAny(in, objPtr); - if (result == TCL_OK && obj) { - *obj = (XOTclObject*) objPtr->internalRep.otherValuePtr; + result = SetXOTclObjectFromAny(interp, objPtr); + if (result == TCL_OK && obj) { + *obj = (XOTclObject*) objPtr->internalRep.otherValuePtr; + } } - } - return result; + return result; } #ifndef NAMESPACEINSTPROCS static Tcl_Namespace * -GetCallerVarFrame(Tcl_Interp *in, Tcl_CallFrame *varFramePtr) { - Tcl_Namespace *nsPtr = NULL; - if (varFramePtr) { - Tcl_CallFrame *callerVarPtr = Tcl_CallFrame_callerVarPtr(varFramePtr); - if (callerVarPtr) { - nsPtr = (Tcl_Namespace *)callerVarPtr->nsPtr; +GetCallerVarFrame(Tcl_Interp *interp, Tcl_CallFrame *varFramePtr) { + Tcl_Namespace *nsPtr = NULL; + if (varFramePtr) { + Tcl_CallFrame *callerVarPtr = Tcl_CallFrame_callerVarPtr(varFramePtr); + if (callerVarPtr) { + nsPtr = (Tcl_Namespace *)callerVarPtr->nsPtr; + } } - } - if (nsPtr == NULL) - nsPtr = Tcl_Interp_globalNsPtr(in); + if (nsPtr == NULL) + nsPtr = Tcl_Interp_globalNsPtr(interp); - return nsPtr; + return nsPtr; } #endif -static Tcl_Obj* -NameInNamespaceObj(Tcl_Interp *in, char *name, Tcl_Namespace *ns) { - Tcl_Obj *objName; - int len; - char *p; +static Tcl_Obj * +NameInNamespaceObj(Tcl_Interp *interp, char *name, Tcl_Namespace *ns) { + Tcl_Obj *objName; + int len; + char *p; - /*fprintf(stderr,"NameInNamespaceObj %s (%p) ",name,ns);*/ - if (!ns) - ns = Tcl_GetCurrentNamespace(in); - objName = Tcl_NewStringObj(ns->fullName,-1); - len = Tcl_GetCharLength(objName); - p = ObjStr(objName); - if (len == 2 && p[0] == ':' && p[1] == ':') { - } else { - Tcl_AppendToObj(objName,"::",2); - } - Tcl_AppendToObj(objName, name, -1); + /*fprintf(stderr,"NameInNamespaceObj %s (%p) ",name,ns);*/ + if (!ns) + ns = Tcl_GetCurrentNamespace(interp); + objName = Tcl_NewStringObj(ns->fullName,-1); + len = Tcl_GetCharLength(objName); + p = ObjStr(objName); + if (len == 2 && p[0] == ':' && p[1] == ':') { + } else { + Tcl_AppendToObj(objName,"::",2); + } + Tcl_AppendToObj(objName, name, -1); - /*fprintf(stderr,"returns %s\n",ObjStr(objName));*/ - return objName; + /*fprintf(stderr,"returns %s\n",ObjStr(objName));*/ + return objName; } static int -GetXOTclClassFromObj(Tcl_Interp *in, register Tcl_Obj *objPtr, - XOTclClass **cl, int retry) { - XOTclObject *obj; - XOTclClass *cls = NULL; - int result = TCL_OK; - char *objName = ObjStr(objPtr); +GetXOTclClassFromObj(Tcl_Interp *interp, register Tcl_Obj *objPtr, + XOTclClass **cl, XOTclClass *base) { + XOTclObject *obj; + XOTclClass *cls = NULL; + int result = TCL_OK; + char *objName = ObjStr(objPtr); - /*fprintf(stderr, "GetXOTclClassFromObj %s retry %d\n", objName, retry);*/ + /*fprintf(stderr, "GetXOTclClassFromObj %s base %p\n", objName, base);*/ - if (retry) { - /* we refer to an existing object; use command resolver */ - if (!isAbsolutePath(objName)) { - Tcl_Command cmd = NSFindCommand(in, objName, callingNameSpace(in)); + if (base) { + /* we refer to an existing object; use command resolver */ + if (!isAbsolutePath(objName)) { + Tcl_Command cmd = NSFindCommand(interp, objName, callingNameSpace(interp)); - /*fprintf(stderr, "GetXOTclClassFromObj %s cmd = %p cl=%p retry=%d\n", - objName, cmd, cmd ? XOTclGetClassFromCmdPtr(cmd) : NULL, retry);*/ - if (cmd) { - cls = XOTclGetClassFromCmdPtr(cmd); - if (cl) *cl = cls; - } + /*fprintf(stderr, "GetXOTclClassFromObj %s cmd = %p cl=%p base=%p\n", + objName, cmd, cmd ? XOTclGetClassFromCmdPtr(cmd) : NULL, base);*/ + if (cmd) { + cls = XOTclGetClassFromCmdPtr(cmd); + if (cl) *cl = cls; + } + } } - } - if (!cls) { - result = XOTclObjConvertObject(in, objPtr, &obj); - if (result == TCL_OK) { - cls = XOTclObjectToClass(obj); - if (cls) { - if (cl) *cl = cls; - } else { - /* we have an object, but no class */ - result = TCL_ERROR; - } + if (!cls) { + result = XOTclObjConvertObject(interp, objPtr, &obj); + if (result == TCL_OK) { + cls = XOTclObjectToClass(obj); + if (cls) { + if (cl) *cl = cls; + } else { + /* we have an object, but no class */ + result = TCL_ERROR; + } + } } - } - if (!cls && retry) { - Tcl_Obj *ov[3]; - ov[0] = RUNTIME_STATE(in)->theClass->object.cmdName; - ov[1] = XOTclGlobalObjects[XOTE___UNKNOWN]; - if (isAbsolutePath(objName)) { - ov[2] = objPtr; - } else { - ov[2] = NameInNamespaceObj(in,objName,callingNameSpace(in)); - } - INCR_REF_COUNT(ov[2]); - /*fprintf(stderr,"+++ calling %s __unknown for %s, objPtr=%s\n", - ObjStr(ov[0]), ObjStr(ov[2]), ObjStr(objPtr)); */ + if (!cls && base) { + Tcl_Obj *ov[3]; + ov[0] = base->object.cmdName; + ov[1] = XOTclGlobalObjects[XOTE___UNKNOWN]; + if (isAbsolutePath(objName)) { + ov[2] = objPtr; + } else { + ov[2] = NameInNamespaceObj(interp,objName,callingNameSpace(interp)); + } + INCR_REF_COUNT(ov[2]); + /*fprintf(stderr,"+++ calling %s __unknown for %s, objPtr=%s\n", + ObjStr(ov[0]), ObjStr(ov[2]), ObjStr(objPtr)); */ - result = Tcl_EvalObjv(in, 3, ov, 0); - if (result == TCL_OK) { - result = GetXOTclClassFromObj(in, objPtr, cl, 0); + result = Tcl_EvalObjv(interp, 3, ov, 0); + if (result == TCL_OK) { + result = GetXOTclClassFromObj(interp, objPtr, cl, 0); + } + DECR_REF_COUNT(ov[2]); } - DECR_REF_COUNT(ov[2]); - } - /*fprintf(stderr, "GetXOTclClassFromObj %s returns %d cls = %p *cl = %p\n", - objName, result, cls, cl?*cl:NULL);*/ - return result; + /*fprintf(stderr, "GetXOTclClassFromObj %s returns %d cls = %p *cl = %p\n", + objName, result, cls, cl?*cl:NULL);*/ + return result; } extern void -XOTclFreeClasses(XOTclClasses* sl) { - XOTclClasses *n; - for (; sl; sl = n) { - n = sl->next; - FREE(XOTclClasses,sl); - } +XOTclClassListFree(XOTclClasses *sl) { + XOTclClasses *n; + for (; sl; sl = n) { + n = sl->nextPtr; + FREE(XOTclClasses,sl); + } } extern XOTclClasses** -XOTclAddClass(XOTclClasses **cList, XOTclClass *cl, ClientData cd) { - XOTclClasses *l = *cList, *element = NEW(XOTclClasses); - element->cl = cl; - element->clientData = cd; - element->next = NULL; - if (l) { - while (l->next) l = l->next; - l->next = element; - } else - *cList = element; - return &(element->next); +XOTclClassListAdd(XOTclClasses **cList, XOTclClass *cl, ClientData clientData) { + XOTclClasses *l = *cList, *element = NEW(XOTclClasses); + element->cl = cl; + element->clientData = clientData; + element->nextPtr = NULL; + + if (l) { + while (l->nextPtr) l = l->nextPtr; + l->nextPtr = element; + } else + *cList = element; + return &(element->nextPtr); } +void +XOTclObjectListFree(XOTclObjects *sl) { + XOTclObjects *n; + for (; sl; sl = n) { + n = sl->nextPtr; + FREE(XOTclObjects,sl); + } +} + +XOTclObjects** +XOTclObjectListAdd(XOTclObjects **cList, XOTclObject *obj) { + XOTclObjects *l = *cList, *element = NEW(XOTclObjects); + element->obj = obj; + element->nextPtr = NULL; + + if (l) { + while (l->nextPtr) l = l->nextPtr; + l->nextPtr = element; + } else + *cList = element; + return &(element->nextPtr); +} + + /* * precedence ordering functions */ enum colors { WHITE, GRAY, BLACK }; -static XOTclClasses* Super(XOTclClass *cl) { return cl->super; } -static XOTclClasses* Sub(XOTclClass *cl) { return cl->sub; } +static XOTclClasses *Super(XOTclClass *cl) { return cl->super; } +static XOTclClasses *Sub(XOTclClass *cl) { return cl->sub; } static int -TopoSort(XOTclClass *cl, XOTclClass *base, XOTclClasses* (*next)(XOTclClass*)) { - /*XOTclClasses* sl = (*next)(cl);*/ - XOTclClasses* sl = next == Super ? cl->super : cl->sub; - XOTclClasses* pl; +TopoSort(XOTclClass *cl, XOTclClass *base, XOTclClasses *(*next)(XOTclClass*)) { + /*XOTclClasses *sl = (*next)(cl);*/ + XOTclClasses *sl = next == Super ? cl->super : cl->sub; + XOTclClasses *pl; - /* - * careful to reset the color of unreported classes to - * white in case we unwind with error, and on final exit - * reset color of reported classes to white - */ + /* + * careful to reset the color of unreported classes to + * white in case we unwind with error, and on final exit + * reset color of reported classes to white + */ - cl->color = GRAY; - for (; sl != 0; sl = sl->next) { - XOTclClass *sc = sl->cl; - if (sc->color == GRAY) { cl->color = WHITE; return 0; } - if (sc->color == WHITE && !TopoSort(sc, base, next)) { - cl->color = WHITE; - if (cl == base) { - XOTclClasses* pc = cl->order; - while (pc != 0) { pc->cl->color = WHITE; pc = pc->next; } - } - return 0; + cl->color = GRAY; + for (; sl != 0; sl = sl->nextPtr) { + XOTclClass *sc = sl->cl; + if (sc->color == GRAY) { cl->color = WHITE; return 0; } + if (sc->color == WHITE && !TopoSort(sc, base, next)) { + cl->color = WHITE; + if (cl == base) { + XOTclClasses *pc = cl->order; + while (pc != 0) { pc->cl->color = WHITE; pc = pc->nextPtr; } + } + return 0; + } } - } - cl->color = BLACK; - pl = NEW(XOTclClasses); - pl->cl = cl; - pl->next = base->order; - base->order = pl; - if (cl == base) { - XOTclClasses* pc = cl->order; - while (pc != 0) { pc->cl->color = WHITE; pc = pc->next; } - } - return 1; + cl->color = BLACK; + pl = NEW(XOTclClasses); + pl->cl = cl; + pl->nextPtr = base->order; + base->order = pl; + if (cl == base) { + XOTclClasses *pc = cl->order; + while (pc != 0) { pc->cl->color = WHITE; pc = pc->nextPtr; } + } + return 1; } static XOTclClasses* -TopoOrder(XOTclClass *cl, XOTclClasses* (*next)(XOTclClass*)) { - if (TopoSort(cl, cl, next)) - return cl->order; - XOTclFreeClasses(cl->order); - cl->order = 0; - return 0; +TopoOrder(XOTclClass *cl, XOTclClasses *(*next)(XOTclClass*)) { + if (TopoSort(cl, cl, next)) + return cl->order; + XOTclClassListFree(cl->order); + cl->order = 0; + return 0; } static XOTclClasses* -ComputeOrder(XOTclClass *cl, XOTclClasses *order, XOTclClasses* (*direction)(XOTclClass*)) { - if (order) - return order; - return (cl->order = TopoOrder(cl, direction)); +ComputeOrder(XOTclClass *cl, XOTclClasses *order, XOTclClasses *(*direction)(XOTclClass*)) { + if (order) + return order; + return (cl->order = TopoOrder(cl, direction)); } extern XOTclClasses* XOTclComputePrecedence(XOTclClass *cl) { - return ComputeOrder(cl, cl->order, Super); + return ComputeOrder(cl, cl->order, Super); } extern XOTclClasses* XOTclComputeDependents(XOTclClass *cl) { - return ComputeOrder(cl, cl->order, Sub); + return ComputeOrder(cl, cl->order, Sub); } static void FlushPrecedences(XOTclClass *cl) { - XOTclClasses* pc; - XOTclFreeClasses(cl->order); - cl->order = 0; - pc = ComputeOrder(cl, cl->order, Sub); + XOTclClasses *pc; + XOTclClassListFree(cl->order); + cl->order = 0; + pc = ComputeOrder(cl, cl->order, Sub); - /* - * ordering doesn't matter here - we're just using toposort - * to find all lower classes so we can flush their caches - */ + /* + * ordering doesn't matter here - we're just using toposort + * to find all lower classes so we can flush their caches + */ - if (pc) pc = pc->next; - for (; pc; pc = pc->next) { - XOTclFreeClasses(pc->cl->order); - pc->cl->order = 0; - } - XOTclFreeClasses(cl->order); - cl->order = 0; + if (pc) pc = pc->nextPtr; + for (; pc; pc = pc->nextPtr) { + XOTclClassListFree(pc->cl->order); + pc->cl->order = 0; + } + XOTclClassListFree(cl->order); + cl->order = 0; } static void AddInstance(XOTclObject *obj, XOTclClass *cl) { - obj->cl = cl; - if (cl != 0) { - int nw; - (void) Tcl_CreateHashEntry(&cl->instances, (char *)obj, &nw); - } + obj->cl = cl; + if (cl != 0) { + int nw; + (void) Tcl_CreateHashEntry(&cl->instances, (char *)obj, &nw); + } } static int RemoveInstance(XOTclObject *obj, XOTclClass *cl) { - if (cl) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&cl->instances, (char *)obj); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - return 1; + if (cl) { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&cl->instances, (char *)obj); + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + return 1; + } } - } - return 0; + return 0; } /* @@ -1416,175 +1450,163 @@ static void AS(XOTclClass *cl, XOTclClass *s, XOTclClasses **sl) { - register XOTclClasses* l = *sl; - while (l && l->cl != s) l = l->next; - if (!l) { - XOTclClasses* sc = NEW(XOTclClasses); - sc->cl = s; - sc->next = *sl; - *sl = sc; - } + register XOTclClasses *l = *sl; + while (l && l->cl != s) l = l->nextPtr; + if (!l) { + XOTclClasses *sc = NEW(XOTclClasses); + sc->cl = s; + sc->nextPtr = *sl; + *sl = sc; + } } static void AddSuper(XOTclClass *cl, XOTclClass *super) { - if (cl && super) { - /* - * keep corresponding sub in step with super - */ - AS(cl, super, &cl->super); - AS(super, cl, &super->sub); - } + if (cl && super) { + /* + * keep corresponding sub in step with super + */ + AS(cl, super, &cl->super); + AS(super, cl, &super->sub); + } } static int RemoveSuper1(XOTclClass *cl, XOTclClass *s, XOTclClasses **sl) { - XOTclClasses* l = *sl; - if (!l) return 0; - if (l->cl == s) { - *sl = l->next; - FREE(XOTclClasses,l); - return 1; - } - while (l->next && l->next->cl != s) l = l->next; - if (l->next) { - XOTclClasses* n = l->next->next; - FREE(XOTclClasses,l->next); - l->next = n; - return 1; - } - return 0; + XOTclClasses *l = *sl; + if (!l) return 0; + if (l->cl == s) { + *sl = l->nextPtr; + FREE(XOTclClasses,l); + return 1; + } + while (l->nextPtr && l->nextPtr->cl != s) l = l->nextPtr; + if (l->nextPtr) { + XOTclClasses *n = l->nextPtr->nextPtr; + FREE(XOTclClasses,l->nextPtr); + l->nextPtr = n; + return 1; + } + return 0; } static int RemoveSuper(XOTclClass *cl, XOTclClass *super) { - /* - * keep corresponding sub in step with super - */ - int sp = RemoveSuper1(cl, super, &cl->super); - int sb = RemoveSuper1(super, cl, &super->sub); + /* + * keep corresponding sub in step with super + */ + int sp = RemoveSuper1(cl, super, &cl->super); + int sb = RemoveSuper1(super, cl, &super->sub); - return sp && sb; + return sp && sb; } /* * internal type checking */ extern XOTcl_Class* -XOTclIsClass(Tcl_Interp *in, ClientData cd) { - if (cd && XOTclObjectIsClass((XOTclObject *)cd)) - return (XOTcl_Class*) cd; - return 0; +XOTclIsClass(Tcl_Interp *interp, ClientData clientData) { + if (clientData && XOTclObjectIsClass((XOTclObject *)clientData)) + return (XOTcl_Class*) clientData; + return 0; } /* * methods lookup */ /*XOTCLINLINE*/ static Tcl_Command -FindMethod(char *methodName, Tcl_Namespace* nsPtr) { - Tcl_HashEntry *entryPtr; -#if 0 - Tcl_HashTable *cmdTable; - /* if somebody messes around with the deleteProc, we conclude that the - entries of the cmdTable are not ours ... */ - cmdTable = Tcl_Namespace_deleteProc(nsPtr) ? Tcl_Namespace_cmdTable(nsPtr) : NULL ; - if (cmdTable== NULL) { - fprintf(stderr,"********************** FindMethod %s cmdTable = %p\n",methodName, cmdTable); - } - /*fprintf(stderr,"FindMethod '%s', cmdTable %p ns=%p \n",methodName,cmdTable,nsPtr);*/ - - if (cmdTable && (entryPtr = Tcl_FindHashEntry(cmdTable, methodName))) { - return (Tcl_Command) Tcl_GetHashValue(entryPtr); - } - /*fprintf(stderr, "find %s in %p returns %p\n",methodName,cmdTable,cmd);*/ - return NULL; -#endif - if ((entryPtr = Tcl_FindHashEntry(Tcl_Namespace_cmdTable(nsPtr), methodName))) { - return (Tcl_Command) Tcl_GetHashValue(entryPtr); - } - /*fprintf(stderr, "find %s in %p returns %p\n",methodName,cmdTable,cmd);*/ - return NULL; +FindMethod(char *methodName, Tcl_Namespace *nsPtr) { + Tcl_HashEntry *entryPtr; + + /* if somebody messes around with the deleteProc, we could conclude that the + entries of the cmdTable are not ours ... we did that in earlier versions */ + /*fprintf(stderr,"FindMethod '%s', ns=%p \n",methodName,nsPtr);*/ + + if ((entryPtr = Tcl_FindHashEntry(Tcl_Namespace_cmdTable(nsPtr), methodName))) { + return (Tcl_Command) Tcl_GetHashValue(entryPtr); + } + return NULL; } static XOTclClass* -SearchPLMethod(register XOTclClasses* pl, char *nm, Tcl_Command *cmd) { - /* Search the class hierarchy */ - for (; pl; pl = pl->next) { - Tcl_Command pi = FindMethod(nm, pl->cl->nsPtr); - if (pi) { - *cmd = pi; - return pl->cl; +SearchPLMethod(register XOTclClasses *pl, char *nm, Tcl_Command *cmd) { + /* Search the class hierarchy */ + for (; pl; pl = pl->nextPtr) { + Tcl_Command pi = FindMethod(nm, pl->cl->nsPtr); + if (pi) { + *cmd = pi; + return pl->cl; + } } - } - return NULL; + return NULL; } static XOTclClass* SearchCMethod(XOTclClass *cl, char *nm, Tcl_Command *cmd) { - assert(cl); - return SearchPLMethod(ComputeOrder(cl, cl->order, Super), nm, cmd); + assert(cl); + return SearchPLMethod(ComputeOrder(cl, cl->order, Super), nm, cmd); } static int -callDestroyMethod(ClientData cd, Tcl_Interp *in, XOTclObject *obj, int flags) { - int result; +callDestroyMethod(ClientData clientData, Tcl_Interp *interp, XOTclObject *obj, int flags) { + int result; - /* don't call destroy after exit handler started physical - destruction */ - if (RUNTIME_STATE(in)->exitHandlerDestroyRound == - XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) - return TCL_OK; + /* don't call destroy after exit handler started physical + destruction */ + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == + XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) + return TCL_OK; - /* fprintf(stderr," obj %p flags %.4x %d\n",obj, obj->flags, - RUNTIME_STATE(in)->callDestroy);*/ - /* we don't call destroy, if we're in the exit handler - during destruction of Object and Class */ - if (!RUNTIME_STATE(in)->callDestroy) { - obj->flags |= XOTCL_DESTROY_CALLED; - /* return TCL_ERROR so that clients know we haven't deleted the - associated command yet */ - return TCL_ERROR; - } - /*fprintf(stderr, "+++ calldestroy flags=%d\n",flags);*/ - if (obj->flags & XOTCL_DESTROY_CALLED) - return TCL_OK; + /* fprintf(stderr," obj %p flags %.4x %d\n",obj, obj->flags, + RUNTIME_STATE(interp)->callDestroy);*/ + /* we don't call destroy, if we're in the exit handler + during destruction of Object and Class */ + if (!RUNTIME_STATE(interp)->callDestroy) { + obj->flags |= XOTCL_DESTROY_CALLED; + /* return TCL_ERROR so that clients know we haven't deleted the + associated command yet */ + return TCL_ERROR; + } + /*fprintf(stderr, "+++ calldestroy flags=%d\n",flags);*/ + if (obj->flags & XOTCL_DESTROY_CALLED) + return TCL_OK; #if !defined(NDEBUG) - {char *cmdName = ObjStr(obj->cmdName); - assert(cmdName != NULL); - /*fprintf(stderr,"findCommand %s -> %p obj->id %p\n",cmdName, - Tcl_FindCommand(in, cmdName, NULL, 0),obj->id);*/ - /*assert(Tcl_FindCommand(in, cmdName, NULL, 0) != NULL);*/ - /*fprintf(stderr,"callDestroyMethod: %p command to be destroyed '%s' does not exist\n", - obj, cmdName);*/ - } + {char *cmdName = ObjStr(obj->cmdName); + assert(cmdName != NULL); + /*fprintf(stderr,"findCommand %s -> %p obj->id %p\n",cmdName, + Tcl_FindCommand(interp, cmdName, NULL, 0),obj->id);*/ + /*assert(Tcl_FindCommand(interp, cmdName, NULL, 0) != NULL);*/ + /*fprintf(stderr,"callDestroyMethod: %p command to be destroyed '%s' does not exist\n", + obj, cmdName);*/ + } #endif #ifdef OBJDELETION_TRACE - fprintf(stderr, " command found\n"); - PRINTOBJ("callDestroy", obj); + fprintf(stderr, " command found\n"); + PRINTOBJ("callDestroy", obj); #endif - result = callMethod(cd, in, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, flags); - if (result != TCL_OK) { - static char cmd[] = - "puts stderr \"[self]: Error in instproc destroy\n\ + result = callMethod(clientData, interp, XOTclGlobalObjects[XOTE_DESTROY], 2, 0, flags); + if (result != TCL_OK) { + static char cmd[] = + "puts stderr \"[self]: Error in method destroy\n\ $::errorCode $::errorInfo\""; - Tcl_EvalEx(in, cmd, -1, 0); - if (++RUNTIME_STATE(in)->errorCount > 20) - panic("too many destroy errors occured. Endless loop?", NULL); - } else { - if (RUNTIME_STATE(in)->errorCount > 0) - RUNTIME_STATE(in)->errorCount--; - } + Tcl_EvalEx(interp, cmd, -1, 0); + if (++RUNTIME_STATE(interp)->errorCount > 20) + panic("too many destroy errors occured. Endless loop?", NULL); + } else { + if (RUNTIME_STATE(interp)->errorCount > 0) + RUNTIME_STATE(interp)->errorCount--; + } #ifdef OBJDELETION_TRACE - fprintf(stderr, "callDestroyMethod for %p exit\n", obj); + fprintf(stderr, "callDestroyMethod for %p exit\n", obj); #endif - return result; + return result; } /* @@ -1593,105 +1615,104 @@ extern XOTclObjectOpt * XOTclRequireObjectOpt(XOTclObject *obj) { - if (!obj->opt) { - obj->opt = NEW(XOTclObjectOpt); - memset(obj->opt, 0, sizeof(XOTclObjectOpt)); - } - return obj->opt; + if (!obj->opt) { + obj->opt = NEW(XOTclObjectOpt); + memset(obj->opt, 0, sizeof(XOTclObjectOpt)); + } + return obj->opt; } extern XOTclClassOpt* XOTclRequireClassOpt(XOTclClass *cl) { - assert(cl); - if (!cl->opt) { - cl->opt = NEW(XOTclClassOpt); - memset(cl->opt, 0, sizeof(XOTclClassOpt)); - } - return cl->opt; + assert(cl); + if (!cl->opt) { + cl->opt = NEW(XOTclClassOpt); + memset(cl->opt, 0, sizeof(XOTclClassOpt)); + } + return cl->opt; } static Tcl_Namespace* -NSGetFreshNamespace(Tcl_Interp *in, ClientData cd, char *name); +NSGetFreshNamespace(Tcl_Interp *interp, ClientData clientData, char *name); static void -makeObjNamespace(Tcl_Interp *in, XOTclObject *obj) { +makeObjNamespace(Tcl_Interp *interp, XOTclObject *obj) { #ifdef NAMESPACE_TRACE - fprintf(stderr, "+++ Make Namespace for %s\n", ObjStr(obj->cmdName)); + fprintf(stderr, "+++ Make Namespace for %s\n", ObjStr(obj->cmdName)); #endif - if (!obj->nsPtr) { - Tcl_Namespace* nsPtr; - char *cmdName = ObjStr(obj->cmdName); - obj->nsPtr = NSGetFreshNamespace(in, (ClientData)obj, cmdName); - if (!obj->nsPtr) - panic("makeObjNamespace: Unable to make namespace",0); - nsPtr = obj->nsPtr; + if (!obj->nsPtr) { + Tcl_Namespace *nsPtr; + char *cmdName = ObjStr(obj->cmdName); + obj->nsPtr = NSGetFreshNamespace(interp, (ClientData)obj, cmdName); + if (!obj->nsPtr) + panic("makeObjNamespace: Unable to make namespace",0); + nsPtr = obj->nsPtr; - /* - * Copy all obj variables to the newly created namespace - */ - - if (obj->varTable) { - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - TclVarHashTable *varTable = Tcl_Namespace_varTable(nsPtr); - Tcl_HashTable *varHashTable = VarHashTable(varTable); - Tcl_HashTable *objHashTable = VarHashTable(obj->varTable); - - *varHashTable = *objHashTable; /* copy the table */ - - if (objHashTable->buckets == objHashTable->staticBuckets) { - varHashTable->buckets = varHashTable->staticBuckets; - } - for (hPtr = Tcl_FirstHashEntry(varHashTable, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { + /* + * Copy all obj variables to the newly created namespace + */ + if (obj->varTable) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + TclVarHashTable *varTable = Tcl_Namespace_varTable(nsPtr); + Tcl_HashTable *varHashTable = VarHashTable(varTable); + Tcl_HashTable *objHashTable = VarHashTable(obj->varTable); + + *varHashTable = *objHashTable; /* copy the table */ + + if (objHashTable->buckets == objHashTable->staticBuckets) { + varHashTable->buckets = varHashTable->staticBuckets; + } + for (hPtr = Tcl_FirstHashEntry(varHashTable, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { #if defined(PRE85) - Var *varPtr; + Var *varPtr; # if FORWARD_COMPATIBLE - if (!forwardCompatibleMode) { + if (!forwardCompatibleMode) { varPtr = (Var *) Tcl_GetHashValue(hPtr); varPtr->nsPtr = (Namespace *)nsPtr; - } + } # else - varPtr = (Var *) Tcl_GetHashValue(hPtr); - varPtr->nsPtr = (Namespace *)nsPtr; + varPtr = (Var *) Tcl_GetHashValue(hPtr); + varPtr->nsPtr = (Namespace *)nsPtr; # endif #endif - hPtr->tablePtr = varHashTable; - } - - ckfree((char *) obj->varTable); - obj->varTable = 0; + hPtr->tablePtr = varHashTable; + } + + ckfree((char *) obj->varTable); + obj->varTable = 0; + } } - } } /* typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( - * Tcl_Interp* in, CONST char * name, Tcl_Namespace *context, - * int flags, Tcl_Var *rPtr)); - */ + * Tcl_Interp *interp, CONST char *name, Tcl_Namespace *context, + * int flags, Tcl_Var *rPtr)); + */ int -varResolver(Tcl_Interp *in, CONST char *name, Tcl_Namespace *ns, int flags, Tcl_Var *varPtr) { +varResolver(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *ns, int flags, Tcl_Var *varPtr) { *varPtr = (Tcl_Var)LookupVarFromTable(Tcl_Namespace_varTable(ns), name,NULL); /*fprintf(stderr,"lookup '%s' successful %d\n",name, *varPtr != NULL);*/ return *varPtr ? TCL_OK : TCL_ERROR; } - -static void -requireObjNamespace(Tcl_Interp *in, XOTclObject *obj) { - if (!obj->nsPtr) makeObjNamespace(in,obj); - /* - Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, - varResolver, (Tcl_ResolveCompiledVarProc*)NULL); - */ - +static Tcl_Namespace * +requireObjNamespace(Tcl_Interp *interp, XOTclObject *obj) { + if (!obj->nsPtr) makeObjNamespace(interp,obj); + /* + Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, + varResolver, (Tcl_ResolveCompiledVarProc*)NULL); + */ + return obj->nsPtr; } + extern void -XOTclRequireObjNamespace(Tcl_Interp *in, XOTcl_Object *obj) { - requireObjNamespace(in,(XOTclObject*) obj); +XOTclRequireObjNamespace(Tcl_Interp *interp, XOTcl_Object *obj) { + requireObjNamespace(interp,(XOTclObject*) obj); } @@ -1700,218 +1721,218 @@ */ static int -NSDeleteCmd(Tcl_Interp *in, Tcl_Namespace* ns, char *name) { - /* a simple deletion would delete a global command with - the same name, if the command is not existing, so - we use the CmdToken */ - Tcl_Command token; - assert(ns); - if ((token = FindMethod(name, ns))) { - return Tcl_DeleteCommandFromToken(in, token); - } - return -1; +NSDeleteCmd(Tcl_Interp *interp, Tcl_Namespace *ns, char *name) { + /* a simple deletion would delete a global command with + the same name, if the command is not existing, so + we use the CmdToken */ + Tcl_Command token; + assert(ns); + if ((token = FindMethod(name, ns))) { + return Tcl_DeleteCommandFromToken(interp, token); + } + return -1; } static void -CallStackDestroyObject(Tcl_Interp *in, XOTclObject *obj); +CallStackDestroyObject(Tcl_Interp *interp, XOTclObject *obj); static void -PrimitiveCDestroy(ClientData cd); +PrimitiveCDestroy(ClientData clientData); static void -PrimitiveODestroy(ClientData cd); +PrimitiveODestroy(ClientData clientData); static void -NSDeleteChildren(Tcl_Interp *in, Tcl_Namespace* ns) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr; +NSDeleteChildren(Tcl_Interp *interp, Tcl_Namespace *ns) { + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; #ifdef OBJDELETION_TRACE - fprintf(stderr, "NSDeleteChildren %s\n", ns->fullName); + fprintf(stderr, "NSDeleteChildren %s\n", ns->fullName); #endif - Tcl_ForgetImport(in, ns, "*"); /* don't destroy namespace imported objects */ + Tcl_ForgetImport(interp, ns, "*"); /* don't destroy namespace imported objects */ - for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr != 0; - hPtr = Tcl_NextHashEntry(&hSrch)) { - Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - if (!Tcl_Command_cmdEpoch(cmd)) { - char *oname = Tcl_GetHashKey(cmdTable, hPtr); - Tcl_DString name; - XOTclObject *obj; - /* fprintf(stderr, " ... child %s\n", oname); */ + for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr != 0; + hPtr = Tcl_NextHashEntry(&hSrch)) { + Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); + if (!Tcl_Command_cmdEpoch(cmd)) { + char *oname = Tcl_GetHashKey(cmdTable, hPtr); + Tcl_DString name; + XOTclObject *obj; + /* fprintf(stderr, " ... child %s\n", oname); */ - ALLOC_NAME_NS(&name, ns->fullName, oname); - obj = XOTclpGetObject(in, Tcl_DStringValue(&name)); + ALLOC_NAME_NS(&name, ns->fullName, oname); + obj = XOTclpGetObject(interp, Tcl_DStringValue(&name)); - if (obj) { - /* fprintf(stderr, " ... obj= %s\n", ObjStr(obj->cmdName));*/ + if (obj) { + /* fprintf(stderr, " ... obj= %s\n", ObjStr(obj->cmdName));*/ - /* in the exit handler physical destroy --> directly call destroy */ - if (RUNTIME_STATE(in)->exitHandlerDestroyRound - == XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) { - if (XOTclObjectIsClass(obj)) - PrimitiveCDestroy((ClientData) obj); - else - PrimitiveODestroy((ClientData) obj); - } else { - if (obj->teardown != 0 && obj->id && - !(obj->flags & XOTCL_DESTROY_CALLED)) { - if (callDestroyMethod((ClientData)obj, in, obj, 0) != TCL_OK) { - /* destroy method failed, but we have to remove the command - anyway. */ - obj->flags |= XOTCL_DESTROY_CALLED; + /* in the exit handler physical destroy --> directly call destroy */ + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound + == XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY) { + if (XOTclObjectIsClass(obj)) + PrimitiveCDestroy((ClientData) obj); + else + PrimitiveODestroy((ClientData) obj); + } else { + if (obj->teardown != 0 && obj->id && + !(obj->flags & XOTCL_DESTROY_CALLED)) { + if (callDestroyMethod((ClientData)obj, interp, obj, 0) != TCL_OK) { + /* destroy method failed, but we have to remove the command + anyway. */ + obj->flags |= XOTCL_DESTROY_CALLED; - if (obj->teardown) { - CallStackDestroyObject(in, obj); - } - /*(void*) Tcl_DeleteCommandFromToken(in, oid);*/ - } - } - } - } - DSTRING_FREE(&name); + if (obj->teardown) { + CallStackDestroyObject(interp, obj); + } + /*(void*) Tcl_DeleteCommandFromToken(interp, oid);*/ + } + } + } + } + DSTRING_FREE(&name); + } } - } } /* * ensure that a variable exists on object varTable or nsPtr->varTable, - * if necessary create it. Return Var * if successful, otherwise 0 + * if necessary create it. Return Var* if successful, otherwise 0 */ static Var * -NSRequireVariableOnObj(Tcl_Interp *in, XOTclObject *obj, char *name, int flgs) { - XOTcl_FrameDecls; - Var *varPtr, *arrayPtr; +NSRequireVariableOnObj(Tcl_Interp *interp, XOTclObject *obj, char *name, int flgs) { + XOTcl_FrameDecls; + Var *varPtr, *arrayPtr; - XOTcl_PushFrame(in, obj); - varPtr = TclLookupVar(in, name, 0, flgs, "obj vwait", - /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); - XOTcl_PopFrame(in, obj); - return varPtr; + XOTcl_PushFrame(interp, obj); + varPtr = TclLookupVar(interp, name, 0, flgs, "obj vwait", + /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); + XOTcl_PopFrame(interp, obj); + return varPtr; } /* delete a namespace recursively, but check whether the namespace is an object or not */ static void -NSDeleteNamespace(Tcl_Interp *in, Tcl_Namespace* ns) { - Tcl_HashTable *childTable = Tcl_Namespace_childTable(ns); - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr; +NSDeleteNamespace(Tcl_Interp *interp, Tcl_Namespace *ns) { + Tcl_HashTable *childTable = Tcl_Namespace_childTable(ns); + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; - NSDeleteChildren(in, ns); - for (hPtr = Tcl_FirstHashEntry(childTable, &hSrch); hPtr != 0; - hPtr = Tcl_NextHashEntry(&hSrch)) { - Tcl_Namespace *child = ((Tcl_Namespace*)Tcl_GetHashValue(hPtr)); - NSDeleteNamespace(in, child); - } - /* - fprintf(stderr, "NSDeleteNamespace deleting %s\n", ns->fullName); - */ - MEM_COUNT_FREE("TclNamespace",ns); - Tcl_DeleteNamespace(ns); + NSDeleteChildren(interp, ns); + for (hPtr = Tcl_FirstHashEntry(childTable, &hSrch); hPtr != 0; + hPtr = Tcl_NextHashEntry(&hSrch)) { + Tcl_Namespace *child = ((Tcl_Namespace*)Tcl_GetHashValue(hPtr)); + NSDeleteNamespace(interp, child); + } + /* + fprintf(stderr, "NSDeleteNamespace deleting %s\n", ns->fullName); + */ + MEM_COUNT_FREE("TclNamespace",ns); + Tcl_DeleteNamespace(ns); } static int -XOTcl_DeleteCommandFromToken(Tcl_Interp *in, Tcl_Command cmd) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - XOTclCallStackContent *csc = cs->top; +XOTcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command cmd) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc = cs->top; - for (; csc > cs->content; csc--) { - if (csc->cmdPtr == cmd) { - csc->cmdPtr = NULL; + for (; csc > cs->content; csc--) { + if (csc->cmdPtr == cmd) { + csc->cmdPtr = NULL; + } } - } - return Tcl_DeleteCommandFromToken(in, cmd); + return Tcl_DeleteCommandFromToken(interp, cmd); } /* * delete all vars & procs in a namespace */ static void -NSCleanupNamespace(Tcl_Interp *in, Tcl_Namespace* ns) { - TclVarHashTable *varTable = Tcl_Namespace_varTable(ns); - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr; - Tcl_Command cmd; - /* - * Delete all variables and initialize var table again - * (deleteVars frees the vartable) - */ - TclDeleteVars((Interp *)in, varTable); - InitVarHashTable(varTable, (Namespace *)ns); +NSCleanupNamespace(Tcl_Interp *interp, Tcl_Namespace *ns) { + TclVarHashTable *varTable = Tcl_Namespace_varTable(ns); + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + Tcl_Command cmd; + /* + * Delete all variables and initialize var table again + * (DeleteVars frees the vartable) + */ + TclDeleteVars((Interp *)interp, varTable); + InitVarHashTable(varTable, (Namespace *)ns); - /* - * Delete all user-defined procs in the namespace - */ - for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr != 0; - hPtr = Tcl_NextHashEntry(&hSrch)) { - cmd = (Tcl_Command) Tcl_GetHashValue(hPtr); - /* objects should not be deleted here to preseve children deletion order*/ - if (!XOTclGetObjectFromCmdPtr(cmd)) { - /*fprintf(stderr,"NSCleanupNamespace deleting %s %p\n", - Tcl_Command_nsPtr(cmd)->fullName, cmd);*/ - XOTcl_DeleteCommandFromToken(in, cmd); + /* + * Delete all user-defined procs in the namespace + */ + for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr != 0; + hPtr = Tcl_NextHashEntry(&hSrch)) { + cmd = (Tcl_Command) Tcl_GetHashValue(hPtr); + /* objects should not be deleted here to preseve children deletion order*/ + if (!XOTclGetObjectFromCmdPtr(cmd)) { + /*fprintf(stderr,"NSCleanupNamespace deleting %s %p\n", + Tcl_Command_nsPtr(cmd)->fullName, cmd);*/ + XOTcl_DeleteCommandFromToken(interp, cmd); + } } - } } static void NSNamespaceDeleteProc(ClientData clientData) { - /* dummy for ns identification by pointer comparison */ - XOTclObject *obj = (XOTclObject*) clientData; - /*fprintf(stderr,"namespacedeleteproc obj=%p\n",clientData);*/ - if (obj) { - obj->flags |= XOTCL_NS_DESTROYED; - obj->nsPtr = NULL; - } + /* dummy for ns identification by pointer comparison */ + XOTclObject *obj = (XOTclObject*) clientData; + /* fprintf(stderr,"namespacedeleteproc obj=%p\n",clientData);*/ + if (obj) { + obj->flags |= XOTCL_NS_DESTROYED; + obj->nsPtr = NULL; + } } void -XOTcl_DeleteNamespace(Tcl_Interp *in, Tcl_Namespace *nsPtr) { - int activationCount = 0; - Tcl_CallFrame *f = (Tcl_CallFrame *)Tcl_Interp_framePtr(in); +XOTcl_DeleteNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr) { + int activationCount = 0; + Tcl_CallFrame *f = (Tcl_CallFrame *)Tcl_Interp_framePtr(interp); - /* - fprintf(stderr, " ... correcting ActivationCount for %s was %d ", - nsPtr->fullName, nsp->activationCount); - */ - while (f) { - if (f->nsPtr == nsPtr) - activationCount++; - f = Tcl_CallFrame_callerPtr(f); - } + /* + fprintf(stderr, " ... correcting ActivationCount for %s was %d ", + nsPtr->fullName, nsp->activationCount); + */ + while (f) { + if (f->nsPtr == nsPtr) + activationCount++; + f = Tcl_CallFrame_callerPtr(f); + } - Tcl_Namespace_activationCount(nsPtr) = activationCount; + Tcl_Namespace_activationCount(nsPtr) = activationCount; - /* - fprintf(stderr, "to %d. \n", nsp->activationCount); - */ - MEM_COUNT_FREE("TclNamespace",nsPtr); - if (Tcl_Namespace_deleteProc(nsPtr) != NULL) { - /*fprintf(stderr,"calling deteteNamespace\n");*/ - Tcl_DeleteNamespace(nsPtr); - } + /* + fprintf(stderr, "to %d. \n", nsp->activationCount); + */ + MEM_COUNT_FREE("TclNamespace",nsPtr); + if (Tcl_Namespace_deleteProc(nsPtr) != NULL) { + /*fprintf(stderr,"calling deteteNamespace\n");*/ + Tcl_DeleteNamespace(nsPtr); + } } static Tcl_Namespace* -NSGetFreshNamespace(Tcl_Interp *in, ClientData cd, char *name) { - Tcl_Namespace *ns = Tcl_FindNamespace(in, name, NULL, 0); +NSGetFreshNamespace(Tcl_Interp *interp, ClientData clientData, char *name) { + Tcl_Namespace *ns = Tcl_FindNamespace(interp, name, NULL, 0); - if (ns) { - if (ns->deleteProc != NULL || ns->clientData != NULL) { - panic("Namespace '%s' exists already with delProc %p and clientData %p; Can only convert a plain Tcl namespace into an XOTcl namespace", - name, ns->deleteProc, ns->clientData); + if (ns) { + if (ns->deleteProc != NULL || ns->clientData != NULL) { + panic("Namespace '%s' exists already with delProc %p and clientData %p; Can only convert a plain Tcl namespace into an XOTcl namespace", + name, ns->deleteProc, ns->clientData); + } + ns->clientData = clientData; + ns->deleteProc = (Tcl_NamespaceDeleteProc*) NSNamespaceDeleteProc; + } else { + ns = Tcl_CreateNamespace(interp, name, clientData, + (Tcl_NamespaceDeleteProc*) NSNamespaceDeleteProc); } - ns->clientData = cd; - ns->deleteProc = (Tcl_NamespaceDeleteProc*) NSNamespaceDeleteProc; - } else { - ns = Tcl_CreateNamespace(in, name, cd, - (Tcl_NamespaceDeleteProc*) NSNamespaceDeleteProc); - } - MEM_COUNT_ALLOC("TclNamespace",ns); - return ns; + MEM_COUNT_ALLOC("TclNamespace",ns); + return ns; } @@ -1920,75 +1941,74 @@ */ XOTCLINLINE static int NSCheckColons(char *name, unsigned l) { - register char *n = name; - if (*n == '\0') return 0; /* empty name */ - if (l==0) l=strlen(name); - if (*(n+l-1) == ':') return 0; /* name ends with : */ - if (*n == ':' && *(n+1) != ':') return 0; /* name begins with single : */ - for (; *n != '\0'; n++) { - if (*n == ':' && *(n+1) == ':' && *(n+2) == ':') - return 0; /* more than 2 colons in series in a name */ - } - return 1; + register char *n = name; + if (*n == '\0') return 0; /* empty name */ + if (l==0) l=strlen(name); + if (*(n+l-1) == ':') return 0; /* name ends with : */ + if (*n == ':' && *(n+1) != ':') return 0; /* name begins with single : */ + for (; *n != '\0'; n++) { + if (*n == ':' && *(n+1) == ':' && *(n+2) == ':') + return 0; /* more than 2 colons in series in a name */ + } + return 1; } /* * check for parent namespace existance (used before commands are created) */ - XOTCLINLINE static int -NSCheckForParent(Tcl_Interp *in, char *name, unsigned l) { - register char *n = name+l; - int result = 1; +NSCheckForParent(Tcl_Interp *interp, char *name, unsigned l) { + register char *n = name+l; + int result = 1; - /*search for last '::'*/ - while ((*n != ':' || *(n-1) != ':') && n-1 > name) {n--; } - if (*n == ':' && n > name && *(n-1) == ':') {n--;} + /*search for last '::'*/ + while ((*n != ':' || *(n-1) != ':') && n-1 > name) {n--; } + if (*n == ':' && n > name && *(n-1) == ':') {n--;} - if ((n-name)>0) { - Tcl_DString parentNSName, *dsp = &parentNSName; - char *parentName; - DSTRING_INIT(dsp); + if ((n-name)>0) { + Tcl_DString parentNSName, *dsp = &parentNSName; + char *parentName; + DSTRING_INIT(dsp); - Tcl_DStringAppend(dsp, name, (n-name)); - parentName = Tcl_DStringValue(dsp); + Tcl_DStringAppend(dsp, name, (n-name)); + parentName = Tcl_DStringValue(dsp); - if (Tcl_FindNamespace(in, parentName, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) == 0) { - XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(in, parentName); - if (parentObj) { - /* this is for classes */ - requireObjNamespace(in, parentObj); - } else { - /* call unknown and try again */ - Tcl_Obj *ov[3]; - int rc; - ov[0] = RUNTIME_STATE(in)->theClass->object.cmdName; - ov[1] = XOTclGlobalObjects[XOTE___UNKNOWN]; - ov[2] = Tcl_NewStringObj(parentName,-1); - INCR_REF_COUNT(ov[2]); - /*fprintf(stderr,"+++ parent... calling __unknown for %s\n", ObjStr(ov[2]));*/ - rc = Tcl_EvalObjv(in, 3, ov, 0); - if (rc == TCL_OK) { - XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(in, parentName); - if (parentObj) { - requireObjNamespace(in, parentObj); - } - result = (Tcl_FindNamespace(in, parentName, - (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) != 0); - } else { - result = 0; - } - DECR_REF_COUNT(ov[2]); - } - } else { - XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(in, parentName); - if (parentObj) { - requireObjNamespace(in, parentObj); - } + if (Tcl_FindNamespace(interp, parentName, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) == 0) { + XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); + if (parentObj) { + /* this is for classes */ + requireObjNamespace(interp, parentObj); + } else { + /* call unknown and try again */ + Tcl_Obj *ov[3]; + int rc; + ov[0] = RUNTIME_STATE(interp)->theClass->object.cmdName; + ov[1] = XOTclGlobalObjects[XOTE___UNKNOWN]; + ov[2] = Tcl_NewStringObj(parentName,-1); + INCR_REF_COUNT(ov[2]); + /*fprintf(stderr,"+++ parent... calling __unknown for %s\n", ObjStr(ov[2]));*/ + rc = Tcl_EvalObjv(interp, 3, ov, 0); + if (rc == TCL_OK) { + XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); + if (parentObj) { + requireObjNamespace(interp, parentObj); + } + result = (Tcl_FindNamespace(interp, parentName, + (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY) != 0); + } else { + result = 0; + } + DECR_REF_COUNT(ov[2]); + } + } else { + XOTclObject *parentObj = (XOTclObject*) XOTclpGetObject(interp, parentName); + if (parentObj) { + requireObjNamespace(interp, parentObj); + } + } + DSTRING_FREE(dsp); } - DSTRING_FREE(dsp); - } - return result; + return result; } /* @@ -1997,14 +2017,14 @@ * to which they point. */ XOTCLINLINE static Tcl_Command -NSFindCommand(Tcl_Interp *in, char *name, Tcl_Namespace *ns) { - Tcl_Command cmd; - if ((cmd = Tcl_FindCommand(in, name, ns, 0))) { - Tcl_Command importedCmd; - if ((importedCmd = TclGetOriginalCommand(cmd))) - cmd = importedCmd; - } - return cmd; +NSFindCommand(Tcl_Interp *interp, char *name, Tcl_Namespace *ns) { + Tcl_Command cmd; + if ((cmd = Tcl_FindCommand(interp, name, ns, 0))) { + Tcl_Command importedCmd; + if ((importedCmd = TclGetOriginalCommand(cmd))) + cmd = importedCmd; + } + return cmd; } @@ -2015,467 +2035,510 @@ extern XOTcl_Object* -XOTclGetObject(Tcl_Interp *in, char *name) { - return (XOTcl_Object*) XOTclpGetObject(in, name); +XOTclGetObject(Tcl_Interp *interp, char *name) { + return (XOTcl_Object*) XOTclpGetObject(interp, name); } /* * Find an object using a char *name */ static XOTclObject* -XOTclpGetObject(Tcl_Interp *in, char *name) { - register Tcl_Command cmd; - assert(name); - cmd = NSFindCommand(in, name, NULL); +XOTclpGetObject(Tcl_Interp *interp, char *name) { + register Tcl_Command cmd; + assert(name); + cmd = NSFindCommand(interp, name, NULL); - /*if (cmd) { - fprintf(stderr,"+++ XOTclGetObject from %s -> objProc=%p, dispatch=%p\n", - name, Tcl_Command_objProc(cmd), XOTclObjDispatch); - }*/ + /*if (cmd) { + fprintf(stderr,"+++ XOTclGetObject from %s -> objProc=%p, dispatch=%p\n", + name, Tcl_Command_objProc(cmd), XOTclObjDispatch); + }*/ - if (cmd && Tcl_Command_objProc(cmd) == XOTclObjDispatch) { - return (XOTclObject*)Tcl_Command_objClientData(cmd); - } - return 0; + if (cmd && Tcl_Command_objProc(cmd) == XOTclObjDispatch) { + return (XOTclObject*)Tcl_Command_objClientData(cmd); + } + return 0; } /* * Find a class using a char *name */ extern XOTcl_Class* -XOTclGetClass(Tcl_Interp *in, char *name) { - return (XOTcl_Class*)XOTclpGetClass(in, name); +XOTclGetClass(Tcl_Interp *interp, char *name) { + return (XOTcl_Class*)XOTclpGetClass(interp, name); } static XOTclClass* -XOTclpGetClass(Tcl_Interp *in, char *name) { - XOTclObject *obj = XOTclpGetObject(in, name); - return (obj && XOTclObjectIsClass(obj)) ? (XOTclClass*)obj : NULL; +XOTclpGetClass(Tcl_Interp *interp, char *name) { + XOTclObject *obj = XOTclpGetObject(interp, name); + return (obj && XOTclObjectIsClass(obj)) ? (XOTclClass*)obj : NULL; } -void -XOTclAddPMethod(Tcl_Interp *in, XOTcl_Object *obji, char *nm, Tcl_ObjCmdProc* proc, - ClientData cd, Tcl_CmdDeleteProc* dp) { - XOTclObject *obj = (XOTclObject*) obji; - Tcl_DString newCmd, *cptr = &newCmd; - requireObjNamespace(in, obj); - ALLOC_NAME_NS(cptr, obj->nsPtr->fullName, nm); - Tcl_CreateObjCommand(in, Tcl_DStringValue(cptr), proc, cd, dp); - DSTRING_FREE(cptr); + + +Tcl_Command +XOTclAddObjectMethod(Tcl_Interp *interp, XOTcl_Object *object, char *methodName, + Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp, + int flags) { + XOTclObject *obj = (XOTclObject *)object; + Tcl_DString newCmdName, *dsPtr = &newCmdName; + Tcl_Command newCmd; + Tcl_Namespace *ns = requireObjNamespace(interp, obj); + ALLOC_NAME_NS(dsPtr, ns->fullName, methodName); + newCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), proc, clientData, dp); + if (flags) { + ((Command *) newCmd)->flags |= flags; + } + DSTRING_FREE(dsPtr); + return newCmd; } -void -XOTclAddIMethod(Tcl_Interp *in, XOTcl_Class *cli, char *nm, - Tcl_ObjCmdProc* proc, ClientData cd, Tcl_CmdDeleteProc* dp) { - XOTclClass *cl = (XOTclClass*) cli; - Tcl_DString newCmd, *cptr = &newCmd; - ALLOC_NAME_NS(cptr, cl->nsPtr->fullName, nm); - Tcl_CreateObjCommand(in, Tcl_DStringValue(cptr), proc, cd, dp); - DSTRING_FREE(cptr); +Tcl_Command +XOTclAddPMethod(Tcl_Interp *interp, XOTcl_Object *object, char *methodName, + Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp) { + int flags = 0; + if (clientData == (ClientData) XOTCL_NONLEAF_METHOD) { + fprintf(stderr, "XOTclAddPMethod(,,,, XOTCL_NONLEAF_METHOD,) deprecated.\n" + "Use XOTclAddObjectMethod(,,,,,, XOTCL_NONLEAF_METHOD) instead.\n"); + flags = XOTCL_NONLEAF_METHOD; + clientData = NULL; + } + return XOTclAddObjectMethod(interp, object, methodName, proc, clientData, dp, flags); } +Tcl_Command +XOTclAddInstanceMethod(Tcl_Interp *interp, XOTcl_Class *class, char *methodName, + Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp, + int flags) { + XOTclClass *cl = (XOTclClass*) class; + Tcl_DString newCmdName, *dsPtr = &newCmdName; + Tcl_Command newCmd; + ALLOC_NAME_NS(dsPtr, cl->nsPtr->fullName, methodName); + newCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), proc, clientData, dp); + if (flags) { + ((Command *) newCmd)->flags |= flags; + } + DSTRING_FREE(dsPtr); + return newCmd; +} +Tcl_Command +XOTclAddIMethod(Tcl_Interp *interp, XOTcl_Class *class, char *methodName, + Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *dp) { + int flags = 0; + if (clientData == (ClientData) XOTCL_NONLEAF_METHOD) { + fprintf(stderr, "XOTclAddIMethod(,,,, XOTCL_NONLEAF_METHOD,) deprecated.\n" + "Use XOTclAddInstanceMethod(,,,,,, XOTCL_NONLEAF_METHOD) instead.\n"); + flags = XOTCL_NONLEAF_METHOD; + clientData = NULL; + } + return XOTclAddInstanceMethod(interp, class, methodName, proc, clientData, dp, flags); +} + + + /* * Generic Tcl_Obj List */ static void -TclObjListFreeList(XOTclTclObjList* list) { - XOTclTclObjList* del; - while (list) { - del = list; - list = list->next; - DECR_REF_COUNT(del->content); - FREE(XOTclTclObjList, del); - } +TclObjListFreeList(XOTclTclObjList *list) { + XOTclTclObjList *del; + while (list) { + del = list; + list = list->nextPtr; + DECR_REF_COUNT(del->content); + FREE(XOTclTclObjList, del); + } } -static Tcl_Obj* +static Tcl_Obj * TclObjListNewElement(XOTclTclObjList **list, Tcl_Obj *ov) { - XOTclTclObjList* elt = NEW(XOTclTclObjList); - INCR_REF_COUNT(ov); - elt->content = ov; - elt->next = *list; - *list = elt; - return ov; + XOTclTclObjList *elt = NEW(XOTclTclObjList); + INCR_REF_COUNT(ov); + elt->content = ov; + elt->nextPtr = *list; + *list = elt; + return ov; } /* * Autonaming */ -static Tcl_Obj* -AutonameIncr(Tcl_Interp *in, Tcl_Obj *name, XOTclObject *obj, +static Tcl_Obj * +AutonameIncr(Tcl_Interp *interp, Tcl_Obj *name, XOTclObject *obj, int instanceOpt, int resetOpt) { - int valueLength, mustCopy = 1, format = 0; - char *valueString, *c; - Tcl_Obj *valueObject, *result = NULL, *savedResult = NULL; + int valueLength, mustCopy = 1, format = 0; + char *valueString, *c; + Tcl_Obj *valueObject, *result = NULL, *savedResult = NULL; #ifdef PRE83 - int flgs = 0; + int flgs = 0; #else - int flgs = TCL_LEAVE_ERR_MSG; + int flgs = TCL_LEAVE_ERR_MSG; #endif - XOTcl_FrameDecls; + XOTcl_FrameDecls; - XOTcl_PushFrame(in, obj); - if (obj->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; + XOTcl_PushFrame(interp, obj); + if (obj->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; - valueObject = Tcl_ObjGetVar2(in, XOTclGlobalObjects[XOTE_AUTONAMES],name, flgs); - if (valueObject != NULL ) { - long autoname_counter; - /* should probably do an overflow check here */ - Tcl_GetLongFromObj(in, valueObject,&autoname_counter); - autoname_counter++; - if (Tcl_IsShared(valueObject)) { - valueObject = Tcl_DuplicateObj(valueObject); + valueObject = Tcl_ObjGetVar2(interp, XOTclGlobalObjects[XOTE_AUTONAMES],name, flgs); + if (valueObject != NULL ) { + long autoname_counter; + /* should probably do an overflow check here */ + Tcl_GetLongFromObj(interp, valueObject,&autoname_counter); + autoname_counter++; + if (Tcl_IsShared(valueObject)) { + valueObject = Tcl_DuplicateObj(valueObject); + } + Tcl_SetLongObj(valueObject,autoname_counter); } - Tcl_SetLongObj(valueObject,autoname_counter); - } - Tcl_ObjSetVar2(in, XOTclGlobalObjects[XOTE_AUTONAMES], name, - valueObject, flgs); + Tcl_ObjSetVar2(interp, XOTclGlobalObjects[XOTE_AUTONAMES], name, + valueObject, flgs); - if (resetOpt) { - if (valueObject != NULL) { /* we have an entry */ - Tcl_UnsetVar2(in, XOTclGlobalStrings[XOTE_AUTONAMES], ObjStr(name), flgs); - } - result = XOTclGlobalObjects[XOTE_EMPTY]; - INCR_REF_COUNT(result); - } else { - if (valueObject == NULL) { - valueObject = Tcl_ObjSetVar2(in, XOTclGlobalObjects[XOTE_AUTONAMES], - name, XOTclGlobalObjects[XOTE_ONE], flgs); - } - if (instanceOpt) { - char buffer[1], firstChar, *nextChars; - nextChars = ObjStr(name); - firstChar = *(nextChars ++); - if (isupper((int)firstChar)) { - buffer[0] = tolower((int)firstChar); - result = Tcl_NewStringObj(buffer,1); - INCR_REF_COUNT(result); - Tcl_AppendToObj(result, nextChars, -1); - mustCopy = 0; - } - } - if (mustCopy) { - result = Tcl_DuplicateObj(name); - INCR_REF_COUNT(result); - /* - fprintf(stderr,"*** copy %p %s = %p\n", name,ObjStr(name),result); - */ - } - /* if we find a % in the autoname -> We use Tcl_FormatObjCmd - to let the autoname string be formated, like Tcl "format" - command, with the value. E.g.: - autoname a%06d --> a000000, a000001, a000002, ... - */ - for (c = ObjStr(result); *c != '\0'; c++) { - if (*c == '%') { - if (*(c+1) != '%') { - format = 1; - break; - } else { - /* when we find a %% we format and then append autoname, e.g. - autoname a%% --> a%1, a%2, ... */ - c++; - } - } - } - if (format) { - ALLOC_ON_STACK(Tcl_Obj*,3, ov); - savedResult = Tcl_GetObjResult(in); - INCR_REF_COUNT(savedResult); - ov[0] = XOTclGlobalObjects[XOTE_FORMAT]; - ov[1] = result; - ov[2] = valueObject; - if (Tcl_EvalObjv(in, 3, ov, 0) != TCL_OK) { - XOTcl_PopFrame(in, obj); - DECR_REF_COUNT(savedResult); - FREE_ON_STACK(ov); - return 0; - } - DECR_REF_COUNT(result); - result = Tcl_DuplicateObj(Tcl_GetObjResult(in)); - INCR_REF_COUNT(result); - Tcl_SetObjResult(in, savedResult); - DECR_REF_COUNT(savedResult); - FREE_ON_STACK(ov); + if (resetOpt) { + if (valueObject != NULL) { /* we have an entry */ + Tcl_UnsetVar2(interp, XOTclGlobalStrings[XOTE_AUTONAMES], ObjStr(name), flgs); + } + result = XOTclGlobalObjects[XOTE_EMPTY]; + INCR_REF_COUNT(result); } else { - valueString = Tcl_GetStringFromObj(valueObject,&valueLength); - Tcl_AppendToObj(result, valueString, valueLength); - /*fprintf(stderr,"+++ append to obj done\n");*/ + if (valueObject == NULL) { + valueObject = Tcl_ObjSetVar2(interp, XOTclGlobalObjects[XOTE_AUTONAMES], + name, XOTclGlobalObjects[XOTE_ONE], flgs); + } + if (instanceOpt) { + char buffer[1], firstChar, *nextChars; + nextChars = ObjStr(name); + firstChar = *(nextChars ++); + if (isupper((int)firstChar)) { + buffer[0] = tolower((int)firstChar); + result = Tcl_NewStringObj(buffer,1); + INCR_REF_COUNT(result); + Tcl_AppendToObj(result, nextChars, -1); + mustCopy = 0; + } + } + if (mustCopy) { + result = Tcl_DuplicateObj(name); + INCR_REF_COUNT(result); + /* + fprintf(stderr,"*** copy %p %s = %p\n", name,ObjStr(name),result); + */ + } + /* if we find a % in the autoname -> We use Tcl_FormatObjCmd + to let the autoname string be formated, like Tcl "format" + command, with the value. E.g.: + autoname a%06d --> a000000, a000001, a000002, ... + */ + for (c = ObjStr(result); *c != '\0'; c++) { + if (*c == '%') { + if (*(c+1) != '%') { + format = 1; + break; + } else { + /* when we find a %% we format and then append autoname, e.g. + autoname a%% --> a%1, a%2, ... */ + c++; + } + } + } + if (format) { + ALLOC_ON_STACK(Tcl_Obj *,3, ov); + savedResult = Tcl_GetObjResult(interp); + INCR_REF_COUNT(savedResult); + ov[0] = XOTclGlobalObjects[XOTE_FORMAT]; + ov[1] = result; + ov[2] = valueObject; + if (Tcl_EvalObjv(interp, 3, ov, 0) != TCL_OK) { + XOTcl_PopFrame(interp, obj); + DECR_REF_COUNT(savedResult); + FREE_ON_STACK(ov); + return 0; + } + DECR_REF_COUNT(result); + result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + INCR_REF_COUNT(result); + Tcl_SetObjResult(interp, savedResult); + DECR_REF_COUNT(savedResult); + FREE_ON_STACK(ov); + } else { + valueString = Tcl_GetStringFromObj(valueObject,&valueLength); + Tcl_AppendToObj(result, valueString, valueLength); + /*fprintf(stderr,"+++ append to obj done\n");*/ + } } - } - XOTcl_PopFrame(in, obj); - assert((resetOpt && result->refCount>=1) || (result->refCount == 1)); - return result; + XOTcl_PopFrame(interp, obj); + assert((resetOpt && result->refCount>=1) || (result->refCount == 1)); + return result; } /* * XOTcl CallStack */ XOTclCallStackContent * -XOTclCallStackFindLastInvocation(Tcl_Interp *in, int offset) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - register XOTclCallStackContent *csc = cs->top; - int topLevel = csc->currentFramePtr ? Tcl_CallFrame_level(csc->currentFramePtr) :0; - int deeper = offset; +XOTclCallStackFindLastInvocation(Tcl_Interp *interp, int offset) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + register XOTclCallStackContent *csc = cs->top; + int topLevel = csc->currentFramePtr ? Tcl_CallFrame_level(csc->currentFramePtr) :0; + int deeper = offset; - /* skip through toplevel inactive filters, do this offset times */ - for (csc=cs->top; csc > cs->content; csc--) { - if ((csc->callType & XOTCL_CSC_CALL_IS_NEXT) || - (csc->frameType & XOTCL_CSC_TYPE_INACTIVE)) - continue; - if (offset) - offset--; - else { - if (!deeper) { - return csc; - } - if (csc->currentFramePtr && Tcl_CallFrame_level(csc->currentFramePtr) < topLevel) { - return csc; - } + /* skip through toplevel inactive filters, do this offset times */ + for (csc=cs->top; csc > cs->content; csc--) { + if ((csc->callType & XOTCL_CSC_CALL_IS_NEXT) || + (csc->frameType & XOTCL_CSC_TYPE_INACTIVE)) + continue; + if (offset) + offset--; + else { + if (!deeper) { + return csc; + } + if (csc->currentFramePtr && Tcl_CallFrame_level(csc->currentFramePtr) < topLevel) { + return csc; + } + } } - } - /* for some reasons, we could not find invocation (topLevel, destroy) */ - return NULL; + /* for some reasons, we could not find invocation (topLevel, destroy) */ + return NULL; } static XOTclCallStackContent * -CallStackFindActiveFilter(Tcl_Interp *in) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - register XOTclCallStackContent *csc; +CallStackFindActiveFilter(Tcl_Interp *interp) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + register XOTclCallStackContent *csc; - /* search for first active frame and set tcl frame pointers */ - for (csc=cs->top; csc > cs->content; csc --) { - if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) return csc; - } - /* for some reasons, we could not find invocation (topLevel, destroy) */ - return NULL; + /* search for first active frame and set tcl frame pointers */ + for (csc=cs->top; csc > cs->content; csc --) { + if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) return csc; + } + /* for some reasons, we could not find invocation (topLevel, destroy) */ + return NULL; } XOTclCallStackContent * -XOTclCallStackFindActiveFrame(Tcl_Interp *in, int offset) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - register XOTclCallStackContent *csc; +XOTclCallStackFindActiveFrame(Tcl_Interp *interp, int offset) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + register XOTclCallStackContent *csc; - /* search for first active frame and set tcl frame pointers */ - for (csc=cs->top-offset; csc > cs->content; csc --) { - if (!(csc->frameType & XOTCL_CSC_TYPE_INACTIVE)) { - /* we found the highest active frame */ - return csc; + /* search for first active frame and set tcl frame pointers */ + for (csc=cs->top-offset; csc > cs->content; csc --) { + if (!(csc->frameType & XOTCL_CSC_TYPE_INACTIVE)) { + /* we found the highest active frame */ + return csc; + } } - } - /* we could not find an active frame; called from toplevel? */ - return NULL; + /* we could not find an active frame; called from toplevel? */ + return NULL; } static void -CallStackUseActiveFrames(Tcl_Interp *in, callFrameContext *ctx) { - XOTclCallStackContent *active, *top = RUNTIME_STATE(in)->cs.top; - Tcl_CallFrame *inFramePtr = (Tcl_CallFrame *) Tcl_Interp_varFramePtr(in); +CallStackUseActiveFrames(Tcl_Interp *interp, callFrameContext *ctx) { + XOTclCallStackContent *active, *top = RUNTIME_STATE(interp)->cs.top; + Tcl_CallFrame *inFramePtr = (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp); - active = XOTclCallStackFindActiveFrame(in, 0); - /*fprintf(stderr,"active %p, varFrame(in) %p, topVarFrame %p, active->curr %p\n", - active, inFramePtr, top->currentFramePtr, - active? active->currentFramePtr : NULL);*/ + active = XOTclCallStackFindActiveFrame(interp, 0); + /*fprintf(stderr,"active %p, varFrame(interp) %p, topVarFrame %p, active->curr %p\n", + active, inFramePtr, top->currentFramePtr, + active? active->currentFramePtr : NULL);*/ - if (active == top || inFramePtr == NULL || Tcl_CallFrame_level(inFramePtr) == 0) { - /* top frame is a active frame, or we could not find a calling - frame, call frame pointers are fine */ - ctx->framesSaved = 0; - } else if (active == NULL) { - Tcl_CallFrame *cf = inFramePtr; - /*fprintf(stderr,"active == NULL\n"); */ - /* find a proc frame, which is not equal the top level cmd */ - /* XOTclStackDump(in);*/ - for (; cf && Tcl_CallFrame_level(cf); cf = Tcl_CallFrame_callerPtr(cf)) { - if (Tcl_CallFrame_isProcCallFrame(cf) && cf != top->currentFramePtr) - break; + if (active == top || inFramePtr == NULL || Tcl_CallFrame_level(inFramePtr) == 0) { + /* top frame is a active frame, or we could not find a calling + frame, call frame pointers are fine */ + ctx->framesSaved = 0; + } else if (active == NULL) { + Tcl_CallFrame *cf = inFramePtr; + /*fprintf(stderr,"active == NULL\n"); */ + /* find a proc frame, which is not equal the top level cmd */ + /* XOTclStackDump(interp);*/ + for (; cf && Tcl_CallFrame_level(cf); cf = Tcl_CallFrame_callerPtr(cf)) { + if (Tcl_CallFrame_isProcCallFrame(cf) && cf != top->currentFramePtr) + break; + } + ctx->varFramePtr = inFramePtr; + Tcl_Interp_varFramePtr(interp) = (CallFrame *) cf; + ctx->framesSaved = 1; + } else { + Tcl_CallFrame *framePtr; + /*fprintf(stderr,"active == deeper active=%p frame %p, active+1 %p frame %p\n", + active, active->currentFramePtr, + active+1, (active+1)->currentFramePtr);*/ + /* search returned a deeper pointer, use stored tcl frame pointers; + If Tcl is mixed with XOTcl it is needed to use instead of + active->currentFrame the callerPtr of the last inactive frame + unless the last inactive is NULL */ + if ((framePtr = (active+1)->currentFramePtr)) + framePtr = Tcl_CallFrame_callerPtr(framePtr); + else + framePtr = active->currentFramePtr; + ctx->varFramePtr = inFramePtr; + Tcl_Interp_varFramePtr(interp) = (CallFrame *) framePtr; + ctx->framesSaved = 1; } - ctx->varFramePtr = inFramePtr; - Tcl_Interp_varFramePtr(in) = (CallFrame *) cf; - ctx->framesSaved = 1; - } else { - Tcl_CallFrame *framePtr; - /*fprintf(stderr,"active == deeper active=%p frame %p, active+1 %p frame %p\n", - active, active->currentFramePtr, - active+1, (active+1)->currentFramePtr);*/ - /* search returned a deeper pointer, use stored tcl frame pointers; - If Tcl is mixed with XOTcl it is needed to use instead of - active->currentFrame the callerPtr of the last inactive frame - unless the last inactive is NULL */ - if ((framePtr = (active+1)->currentFramePtr)) - framePtr = Tcl_CallFrame_callerPtr(framePtr); - else - framePtr = active->currentFramePtr; - ctx->varFramePtr = inFramePtr; - Tcl_Interp_varFramePtr(in) = (CallFrame *) framePtr; - ctx->framesSaved = 1; - } } static void -CallStackRestoreSavedFrames(Tcl_Interp *in, callFrameContext *ctx) { - if (ctx->framesSaved) { - Tcl_Interp_varFramePtr(in) = (CallFrame *)ctx->varFramePtr; - /*RUNTIME_STATE(in)->varFramePtr = ctx->varFramePtr;*/ +CallStackRestoreSavedFrames(Tcl_Interp *interp, callFrameContext *ctx) { + if (ctx->framesSaved) { + Tcl_Interp_varFramePtr(interp) = (CallFrame *)ctx->varFramePtr; + /*RUNTIME_STATE(interp)->varFramePtr = ctx->varFramePtr;*/ - } + } } XOTCLINLINE static int -CallStackPush(Tcl_Interp *in, XOTclObject *obj, XOTclClass *cl, +CallStackPush(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl, Tcl_Command cmd, int objc, Tcl_Obj *CONST objv[], int frameType) { - XOTclCallStack *cs; - register XOTclCallStackContent *csc; + XOTclCallStack *cs; + register XOTclCallStackContent *csc; - cs = &RUNTIME_STATE(in)->cs; - if (cs->top >= &cs->content[MAX_NESTING_DEPTH-1]) { - Tcl_SetResult(in, "too many nested calls to Tcl_EvalObj (infinite loop?)", - TCL_STATIC); - return TCL_ERROR; - } - /*fprintf(stderr, "CallStackPush sets self\n");*/ - csc = ++cs->top; - csc->self = obj; - csc->cl = cl; - csc->cmdPtr = cmd; - csc->destroyedCmd = 0; - csc->frameType = frameType; - csc->callType = 0; - csc->currentFramePtr = NULL; /* this will be set by InitProcNSCmd */ + cs = &RUNTIME_STATE(interp)->cs; + if (cs->top >= &cs->content[MAX_NESTING_DEPTH-1]) { + Tcl_SetResult(interp, "too many nested calls to Tcl_EvalObj (infinite loop?)", + TCL_STATIC); + return TCL_ERROR; + } + /*fprintf(stderr, "CallStackPush sets self\n");*/ + csc = ++cs->top; + csc->self = obj; + csc->cl = cl; + csc->cmdPtr = cmd; + csc->destroyedCmd = 0; + csc->frameType = frameType; + csc->callType = 0; + csc->currentFramePtr = NULL; /* this will be set by InitProcNSCmd */ - if (frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) - csc->filterStackEntry = obj->filterStack; - else - csc->filterStackEntry = 0; + if (frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) + csc->filterStackEntry = obj->filterStack; + else + csc->filterStackEntry = 0; - /*fprintf(stderr, "PUSH obj %s, self=%p cmd=%p (%s) id=%p (%s) frame=%p\n", - ObjStr(obj->cmdName), obj, - cmd, (char *) Tcl_GetCommandName(in, cmd), - obj->id, Tcl_GetCommandName(in, obj->id), csc);*/ + /*fprintf(stderr, "PUSH obj %s, self=%p cmd=%p (%s) id=%p (%s) frame=%p\n", + ObjStr(obj->cmdName), obj, + cmd, (char *) Tcl_GetCommandName(interp, cmd), + obj->id, Tcl_GetCommandName(interp, obj->id), csc);*/ - MEM_COUNT_ALLOC("CallStack",NULL); - return TCL_OK; + MEM_COUNT_ALLOC("CallStack",NULL); + return TCL_OK; } XOTCLINLINE static void -CallStackDoDestroy(Tcl_Interp *in, XOTclObject *obj) { - Tcl_Command oid; +CallStackDoDestroy(Tcl_Interp *interp, XOTclObject *obj) { + Tcl_Command oid; - PRINTOBJ("CallStackDoDestroy", obj); - oid = obj->id; - obj->id = 0; - if (obj->teardown && oid) { - Tcl_DeleteCommandFromToken(in, oid); - } + PRINTOBJ("CallStackDoDestroy", obj); + oid = obj->id; + obj->id = 0; + if (obj->teardown && oid) { + Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); + INCR_REF_COUNT(savedObjResult); + Tcl_DeleteCommandFromToken(interp, oid); /* this can change the result */ + Tcl_SetObjResult(interp, savedObjResult); + DECR_REF_COUNT(savedObjResult); + } } static void -CallStackDestroyObject(Tcl_Interp *in, XOTclObject *obj) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - XOTclCallStackContent *csc; - int countSelfs = 0; - Tcl_Command oid = obj->id; +CallStackDestroyObject(Tcl_Interp *interp, XOTclObject *obj) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc; + int countSelfs = 0; + Tcl_Command oid = obj->id; - for (csc = &cs->content[1]; csc <= cs->top; csc++) { - if (csc->self == obj) { - csc->destroyedCmd = oid; - csc->callType |= XOTCL_CSC_CALL_IS_DESTROY; - /*fprintf(stderr,"setting destroy on frame %p for obj %p\n",csc,obj);*/ - if (csc->destroyedCmd) { - Tcl_Command_refCount(csc->destroyedCmd)++; - MEM_COUNT_ALLOC("command refCount",csc->destroyedCmd); - } - countSelfs++; + for (csc = &cs->content[1]; csc <= cs->top; csc++) { + if (csc->self == obj) { + csc->destroyedCmd = oid; + csc->callType |= XOTCL_CSC_CALL_IS_DESTROY; + /*fprintf(stderr,"setting destroy on frame %p for obj %p\n",csc,obj);*/ + if (csc->destroyedCmd) { + Tcl_Command_refCount(csc->destroyedCmd)++; + MEM_COUNT_ALLOC("command refCount",csc->destroyedCmd); + } + countSelfs++; + } } - } - /* if the object is not referenced at the callstack anymore - we have to directly destroy it, because CallStackPop won't - find the object destroy */ - if (countSelfs == 0) { - /*fprintf(stderr,"directdestroy %p\n",obj);*/ - CallStackDoDestroy(in, obj); - } else { - /*fprintf(stderr,"selfcount for %p = %d\n",obj,countSelfs);*/ - /* to prevail the deletion order call delete children now - -> children destructors are called before parent's - destructor */ - if (obj->teardown && obj->nsPtr) { - NSDeleteChildren(in, obj->nsPtr); + /* if the object is not referenced at the callstack anymore + we have to directly destroy it, because CallStackPop won't + find the object destroy */ + if (countSelfs == 0) { + /*fprintf(stderr,"directdestroy %p\n",obj);*/ + CallStackDoDestroy(interp, obj); + } else { + /*fprintf(stderr,"selfcount for %p = %d\n",obj,countSelfs);*/ + /* to prevail the deletion order call delete children now + -> children destructors are called before parent's + destructor */ + if (obj->teardown && obj->nsPtr) { + NSDeleteChildren(interp, obj->nsPtr); + } } - } } XOTCLINLINE static int -CallStackIsDestroyed(Tcl_Interp *in) { - return (RUNTIME_STATE(in)->cs.top->destroyedCmd == NULL) ? 0 : 1; +CallStackIsDestroyed(Tcl_Interp *interp) { + return (RUNTIME_STATE(interp)->cs.top->destroyedCmd == NULL) ? 0 : 1; } XOTCLINLINE static void -CallStackPop(Tcl_Interp *in) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - XOTclCallStackContent *csc; - XOTclCallStackContent *h = cs->top; +CallStackPop(Tcl_Interp *interp) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc; + XOTclCallStackContent *h = cs->top; - assert(cs->top > cs->content); - csc = cs->top; + assert(cs->top > cs->content); + csc = cs->top; - /*fprintf(stderr, "POP frame=%p\n",csc);*/ + /*fprintf(stderr, "POP frame=%p\n",csc);*/ - if (csc->destroyedCmd != 0) { - int destroy = 1; - TclCleanupCommand((Command *)csc->destroyedCmd); - MEM_COUNT_FREE("command refCount", csc->destroyedCmd); - /* do not physically destroy, when callstack still contains "self" - entries of the object */ - while (--h > cs->content) { - if (h->self == csc->self) { - destroy = 0; - break; - } + if (csc->destroyedCmd != 0) { + int destroy = 1; + TclCleanupCommand((Command *)csc->destroyedCmd); + MEM_COUNT_FREE("command refCount", csc->destroyedCmd); + /* do not physically destroy, when callstack still contains "self" + entries of the object */ + while (--h > cs->content) { + if (h->self == csc->self) { + destroy = 0; + break; + } + } + if (destroy) { + CallStackDoDestroy(interp, csc->self); + } } - if (destroy) { - CallStackDoDestroy(in, csc->self); - } - } - cs->top--; - MEM_COUNT_FREE("CallStack",NULL); + cs->top--; + MEM_COUNT_FREE("CallStack",NULL); } XOTCLINLINE static XOTclCallStackContent* -CallStackGetTopFrame(Tcl_Interp *in) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - return cs->top; +CallStackGetTopFrame(Tcl_Interp *interp) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + return cs->top; } static XOTclCallStackContent* -CallStackGetFrame(Tcl_Interp *in) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - register XOTclCallStackContent *top = cs->top; - Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(in); +CallStackGetFrame(Tcl_Interp *interp) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + register XOTclCallStackContent *top = cs->top; + Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - /* fprintf(stderr, "Tcl_Interp_framePtr(in) %p != varFramePtr %p && top->currentFramePtr %p\n", Tcl_Interp_framePtr(in), varFramePtr, top->currentFramePtr);*/ + if (Tcl_Interp_framePtr(interp) != varFramePtr && top->currentFramePtr) { + XOTclCallStackContent *bot = cs->content + 1; - if (Tcl_Interp_framePtr(in) != varFramePtr && top->currentFramePtr) { - XOTclCallStackContent *bot = cs->content + 1; - /*fprintf(stderr, "uplevel\n");*/ - /* we are in a uplevel */ - while (varFramePtr != top->currentFramePtr && top>bot) { - top--; + /* we are in a uplevel */ + while (varFramePtr != top->currentFramePtr && top>bot) { + top--; + } } - } - return top; + return top; } /* @@ -2487,127 +2550,127 @@ */ static XOTclCmdList* CmdListAdd(XOTclCmdList **cList, Tcl_Command c, XOTclClass *clorobj, int noDuplicates) { - XOTclCmdList *l = *cList, *new; + XOTclCmdList *l = *cList, *new; - /* - * check for duplicates, if necessary - */ - if (noDuplicates) { - XOTclCmdList *h = l, **end = NULL; - while (h) { - if (h->cmdPtr == c) - return h; - end = &(h->next); - h = h->next; + /* + * check for duplicates, if necessary + */ + if (noDuplicates) { + XOTclCmdList *h = l, **end = NULL; + while (h) { + if (h->cmdPtr == c) + return h; + end = &(h->nextPtr); + h = h->nextPtr; + } + if (end) { + /* no duplicates, no need to search below, we are at the end of the list */ + cList = end; + l = NULL; + } } - if (end) { - /* no duplicates, no need to search below, we are at the end of the list */ - cList = end; - l = NULL; - } - } - /* - * ok, we have no duplicates -> append "new" - * to the end of the list - */ - new = NEW(XOTclCmdList); - new->cmdPtr = c; - Tcl_Command_refCount(new->cmdPtr)++; - MEM_COUNT_ALLOC("command refCount",new->cmdPtr); - new->clientData = NULL; - new->clorobj = clorobj; - new->next = NULL; + /* + * ok, we have no duplicates -> append "new" + * to the end of the list + */ + new = NEW(XOTclCmdList); + new->cmdPtr = c; + Tcl_Command_refCount(new->cmdPtr)++; + MEM_COUNT_ALLOC("command refCount",new->cmdPtr); + new->clientData = NULL; + new->clorobj = clorobj; + new->nextPtr = NULL; - if (l) { - while (l->next) - l = l->next; - l->next = new; - } else - *cList = new; - return new; + if (l) { + while (l->nextPtr) + l = l->nextPtr; + l->nextPtr = new; + } else + *cList = new; + return new; } static void CmdListReplaceCmd(XOTclCmdList *replace, Tcl_Command cmd, XOTclClass *clorobj) { - Tcl_Command del = replace->cmdPtr; - replace->cmdPtr = cmd; - replace->clorobj = clorobj; - Tcl_Command_refCount(cmd)++; - MEM_COUNT_ALLOC("command refCount", cmd); - TclCleanupCommand((Command *)del); - MEM_COUNT_FREE("command refCount",cmd); + Tcl_Command del = replace->cmdPtr; + replace->cmdPtr = cmd; + replace->clorobj = clorobj; + Tcl_Command_refCount(cmd)++; + MEM_COUNT_ALLOC("command refCount", cmd); + TclCleanupCommand((Command *)del); + MEM_COUNT_FREE("command refCount",cmd); } #if 0 /** for debug purposes only */ static void -CmdListPrint(Tcl_Interp *in, char *title, XOTclCmdList *cmdList) { - if (cmdList) - fprintf(stderr,title); - while (cmdList) { - fprintf(stderr, " CL=%p, cmdPtr=%p %s, clorobj %p, clientData=%p\n", - cmdList, - cmdList->cmdPtr, - in ? Tcl_GetCommandName(in, cmdList->cmdPtr) : "", - cmdList->clorobj, - cmdList->clientData); - cmdList = cmdList->next; - } +CmdListPrint(Tcl_Interp *interp, char *title, XOTclCmdList *cmdList) { + if (cmdList) + fprintf(stderr,title); + while (cmdList) { + fprintf(stderr, " CL=%p, cmdPtr=%p %s, clorobj %p, clientData=%p\n", + cmdList, + cmdList->cmdPtr, + in ? Tcl_GetCommandName(interp, cmdList->cmdPtr) : "", + cmdList->clorobj, + cmdList->clientData); + cmdList = cmdList->nextPtr; + } } #endif /* * physically delete an entry 'del' */ static void -CmdListDeleteCmdListEntry(XOTclCmdList* del, XOTclFreeCmdListClientData* freeFct) { - if (freeFct) - (*freeFct)(del); - MEM_COUNT_FREE("command refCount",del->cmdPtr); - TclCleanupCommand((Command *)del->cmdPtr); - FREE(XOTclCmdList, del); +CmdListDeleteCmdListEntry(XOTclCmdList *del, XOTclFreeCmdListClientData *freeFct) { + if (freeFct) + (*freeFct)(del); + MEM_COUNT_FREE("command refCount",del->cmdPtr); + TclCleanupCommand((Command *)del->cmdPtr); + FREE(XOTclCmdList, del); } /* * remove a command 'delCL' from a command list, but do not * free it ... returns the removed XOTclCmdList* */ static XOTclCmdList* -CmdListRemoveFromList(XOTclCmdList **cmdList, XOTclCmdList* delCL) { - register XOTclCmdList* c = *cmdList, *del = 0; - if (c == 0) - return NULL; - if (c == delCL) { - *cmdList = c->next; - del = c; - } else { - while (c->next && c->next != delCL) { - c = c->next; +CmdListRemoveFromList(XOTclCmdList **cmdList, XOTclCmdList *delCL) { + register XOTclCmdList *c = *cmdList, *del = 0; + if (c == 0) + return NULL; + if (c == delCL) { + *cmdList = c->nextPtr; + del = c; + } else { + while (c->nextPtr && c->nextPtr != delCL) { + c = c->nextPtr; + } + if (c->nextPtr == delCL) { + del = delCL; + c->nextPtr = delCL->nextPtr; + } } - if (c->next == delCL) { - del = delCL; - c->next = delCL->next; - } - } - return del; + return del; } /* * remove all command pointers from a list that have a bumped epoch */ static void CmdListRemoveEpoched(XOTclCmdList **cmdList, XOTclFreeCmdListClientData *freeFct) { - XOTclCmdList *f = *cmdList, *del; - while (f) { - if (Tcl_Command_cmdEpoch(f->cmdPtr)) { - del = f; - f = f->next; - del = CmdListRemoveFromList(cmdList, del); - CmdListDeleteCmdListEntry(del, freeFct); - } else - f = f->next; - } + XOTclCmdList *f = *cmdList, *del; + while (f) { + if (Tcl_Command_cmdEpoch(f->cmdPtr)) { + del = f; + f = f->nextPtr; + del = CmdListRemoveFromList(cmdList, del); + CmdListDeleteCmdListEntry(del, freeFct); + } else + f = f->nextPtr; + } } @@ -2616,379 +2679,370 @@ */ static void CmdListRemoveContextClassFromList(XOTclCmdList **cmdList, XOTclClass *clorobj, - XOTclFreeCmdListClientData* freeFct) { - XOTclCmdList* c, *del = 0; - /* - CmdListRemoveEpoched(cmdList, freeFct); - */ - c = *cmdList; - while (c && c->clorobj == clorobj) { - del = c; - *cmdList = c->next; - CmdListDeleteCmdListEntry(del, freeFct); + XOTclFreeCmdListClientData *freeFct) { + XOTclCmdList *c, *del = 0; + /* + CmdListRemoveEpoched(cmdList, freeFct); + */ c = *cmdList; - } - while (c) { - if (c->clorobj == clorobj) { - del = c; - c = *cmdList; - while (c->next && c->next != del) - c = c->next; - if (c->next == del) - c->next = del->next; - CmdListDeleteCmdListEntry(del, freeFct); + while (c && c->clorobj == clorobj) { + del = c; + *cmdList = c->nextPtr; + CmdListDeleteCmdListEntry(del, freeFct); + c = *cmdList; } - c = c->next; - } + while (c) { + if (c->clorobj == clorobj) { + del = c; + c = *cmdList; + while (c->nextPtr && c->nextPtr != del) + c = c->nextPtr; + if (c->nextPtr == del) + c->nextPtr = del->nextPtr; + CmdListDeleteCmdListEntry(del, freeFct); + } + c = c->nextPtr; + } } /* * free the memory of a whole 'cmdList' */ static void -CmdListRemoveList(XOTclCmdList **cmdList, XOTclFreeCmdListClientData* freeFct) { - XOTclCmdList *del; - while (*cmdList) { - del = *cmdList; - *cmdList = (*cmdList)->next; - CmdListDeleteCmdListEntry(del, freeFct); - } +CmdListRemoveList(XOTclCmdList **cmdList, XOTclFreeCmdListClientData *freeFct) { + XOTclCmdList *del; + while (*cmdList) { + del = *cmdList; + *cmdList = (*cmdList)->nextPtr; + CmdListDeleteCmdListEntry(del, freeFct); + } } /* * simple list search proc to search a list of cmds * for a command ptr */ static XOTclCmdList* -CmdListFindCmdInList(Tcl_Command cmd, XOTclCmdList* l) { - register XOTclCmdList* h = l; - while (h != 0) { - if (h->cmdPtr == cmd) - return h; - h = h->next; - } - return 0; +CmdListFindCmdInList(Tcl_Command cmd, XOTclCmdList *l) { + register XOTclCmdList *h = l; + while (h != 0) { + if (h->cmdPtr == cmd) + return h; + h = h->nextPtr; + } + return 0; } /* * simple list search proc to search a list of cmds * for a simple Name */ static XOTclCmdList* -CmdListFindNameInList(Tcl_Interp *in, char *name, XOTclCmdList* l) { - register XOTclCmdList* h = l; - while (h != 0) { - CONST84 char *cmdName = Tcl_GetCommandName(in, h->cmdPtr); - if (cmdName[0] == name[0] && !strcmp(cmdName, name)) - return h; - h = h->next; - } - return 0; +CmdListFindNameInList(Tcl_Interp *interp, char *name, XOTclCmdList *l) { + register XOTclCmdList *h = l; + while (h != 0) { + CONST84 char *cmdName = Tcl_GetCommandName(interp, h->cmdPtr); + if (cmdName[0] == name[0] && !strcmp(cmdName, name)) + return h; + h = h->nextPtr; + } + return 0; } /* * Assertions */ static XOTclTclObjList* -AssertionNewList(Tcl_Interp *in, Tcl_Obj *aObj) { - Tcl_Obj **ov; int oc; - XOTclTclObjList *last = NULL; +AssertionNewList(Tcl_Interp *interp, Tcl_Obj *aObj) { + Tcl_Obj **ov; int oc; + XOTclTclObjList *last = NULL; - if (Tcl_ListObjGetElements(in, aObj, &oc, &ov) == TCL_OK) { - if (oc > 0) { - int i; - for (i=oc-1; i>=0; i--) { - TclObjListNewElement(&last, ov[i]); - } + if (Tcl_ListObjGetElements(interp, aObj, &oc, &ov) == TCL_OK) { + if (oc > 0) { + int i; + for (i=oc-1; i>=0; i--) { + TclObjListNewElement(&last, ov[i]); + } + } } - } - return last; + return last; } -static Tcl_Obj* -AssertionList(Tcl_Interp *in, XOTclTclObjList* alist) { - Tcl_Obj *newAssStr = Tcl_NewStringObj("",0); - for (; alist!=NULL; alist = alist->next) { - Tcl_AppendStringsToObj(newAssStr, "{", ObjStr(alist->content), - "}", (char *) NULL); - if (alist->next != NULL) - Tcl_AppendStringsToObj(newAssStr, " ", (char *) NULL); - } - return newAssStr; +static Tcl_Obj * +AssertionList(Tcl_Interp *interp, XOTclTclObjList *alist) { + Tcl_Obj *newAssStr = Tcl_NewStringObj("",0); + for (; alist!=NULL; alist = alist->nextPtr) { + Tcl_AppendStringsToObj(newAssStr, "{", ObjStr(alist->content), + "}", (char *) NULL); + if (alist->nextPtr != NULL) + Tcl_AppendStringsToObj(newAssStr, " ", (char *) NULL); + } + return newAssStr; } /* append a string of pre and post assertions to a proc or instproc body */ static void -AssertionAppendPrePost(Tcl_Interp *in, Tcl_DString *dsPtr, XOTclProcAssertion *procs) { - if (procs) { - Tcl_Obj *preAss = AssertionList(in, procs->pre); - Tcl_Obj *postAss = AssertionList(in, procs->post); - INCR_REF_COUNT(preAss); INCR_REF_COUNT(postAss); - Tcl_DStringAppendElement(dsPtr, ObjStr(preAss)); - Tcl_DStringAppendElement(dsPtr, ObjStr(postAss)); - DECR_REF_COUNT(preAss); DECR_REF_COUNT(postAss); - } +AssertionAppendPrePost(Tcl_Interp *interp, Tcl_DString *dsPtr, XOTclProcAssertion *procs) { + if (procs) { + Tcl_Obj *preAss = AssertionList(interp, procs->pre); + Tcl_Obj *postAss = AssertionList(interp, procs->post); + INCR_REF_COUNT(preAss); INCR_REF_COUNT(postAss); + Tcl_DStringAppendElement(dsPtr, ObjStr(preAss)); + Tcl_DStringAppendElement(dsPtr, ObjStr(postAss)); + DECR_REF_COUNT(preAss); DECR_REF_COUNT(postAss); + } } static int -AssertionListCheckOption(Tcl_Interp *in, XOTclObject *obj) { - XOTclObjectOpt *opt = obj->opt; - if (!opt) +AssertionListCheckOption(Tcl_Interp *interp, XOTclObject *obj) { + XOTclObjectOpt *opt = obj->opt; + if (!opt) + return TCL_OK; + if (opt->checkoptions & CHECK_OBJINVAR) + Tcl_AppendElement(interp, "invar"); + if (opt->checkoptions & CHECK_CLINVAR) + Tcl_AppendElement(interp, "instinvar"); + if (opt->checkoptions & CHECK_PRE) + Tcl_AppendElement(interp, "pre"); + if (opt->checkoptions & CHECK_POST) + Tcl_AppendElement(interp, "post"); return TCL_OK; - if (opt->checkoptions & CHECK_OBJINVAR) - Tcl_AppendElement(in, "invar"); - if (opt->checkoptions & CHECK_CLINVAR) - Tcl_AppendElement(in, "instinvar"); - if (opt->checkoptions & CHECK_PRE) - Tcl_AppendElement(in, "pre"); - if (opt->checkoptions & CHECK_POST) - Tcl_AppendElement(in, "post"); - return TCL_OK; } static XOTclProcAssertion* -AssertionFindProcs(XOTclAssertionStore* aStore, char *name) { - Tcl_HashEntry *hPtr; - if (aStore == NULL) return NULL; - hPtr = Tcl_FindHashEntry(&aStore->procs, name); - if (hPtr == NULL) return NULL; - return (XOTclProcAssertion*) Tcl_GetHashValue(hPtr); +AssertionFindProcs(XOTclAssertionStore *aStore, char *name) { + Tcl_HashEntry *hPtr; + if (aStore == NULL) return NULL; + hPtr = Tcl_FindHashEntry(&aStore->procs, name); + if (hPtr == NULL) return NULL; + return (XOTclProcAssertion*) Tcl_GetHashValue(hPtr); } static void -AssertionRemoveProc(XOTclAssertionStore* aStore, char *name) { - Tcl_HashEntry *hPtr; - if (aStore) { - hPtr = Tcl_FindHashEntry(&aStore->procs, name); - if (hPtr) { - XOTclProcAssertion* procAss = - (XOTclProcAssertion*) Tcl_GetHashValue(hPtr); - TclObjListFreeList(procAss->pre); - TclObjListFreeList(procAss->post); - FREE(XOTclProcAssertion, procAss); - Tcl_DeleteHashEntry(hPtr); +AssertionRemoveProc(XOTclAssertionStore *aStore, char *name) { + Tcl_HashEntry *hPtr; + if (aStore) { + hPtr = Tcl_FindHashEntry(&aStore->procs, name); + if (hPtr) { + XOTclProcAssertion *procAss = + (XOTclProcAssertion*) Tcl_GetHashValue(hPtr); + TclObjListFreeList(procAss->pre); + TclObjListFreeList(procAss->post); + FREE(XOTclProcAssertion, procAss); + Tcl_DeleteHashEntry(hPtr); + } } - } } static void -AssertionAddProc(Tcl_Interp *in, char *name, XOTclAssertionStore* aStore, +AssertionAddProc(Tcl_Interp *interp, char *name, XOTclAssertionStore *aStore, Tcl_Obj *pre, Tcl_Obj *post) { - int nw = 0; - Tcl_HashEntry* hPtr = NULL; - XOTclProcAssertion *procs = NEW(XOTclProcAssertion); + int nw = 0; + Tcl_HashEntry *hPtr = NULL; + XOTclProcAssertion *procs = NEW(XOTclProcAssertion); - AssertionRemoveProc(aStore, name); - procs->pre = AssertionNewList(in, pre); - procs->post = AssertionNewList(in, post); - hPtr = Tcl_CreateHashEntry(&aStore->procs, name, &nw); - if (nw) Tcl_SetHashValue(hPtr, (ClientData)procs); + AssertionRemoveProc(aStore, name); + procs->pre = AssertionNewList(interp, pre); + procs->post = AssertionNewList(interp, post); + hPtr = Tcl_CreateHashEntry(&aStore->procs, name, &nw); + if (nw) Tcl_SetHashValue(hPtr, (ClientData)procs); } static XOTclAssertionStore* AssertionCreateStore() { - XOTclAssertionStore* aStore = NEW(XOTclAssertionStore); - aStore->invariants = NULL; - Tcl_InitHashTable(&aStore->procs, TCL_STRING_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable",&aStore->procs); - return aStore; + XOTclAssertionStore *aStore = NEW(XOTclAssertionStore); + aStore->invariants = NULL; + Tcl_InitHashTable(&aStore->procs, TCL_STRING_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable",&aStore->procs); + return aStore; } static void -AssertionRemoveStore(XOTclAssertionStore* aStore) { - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr; +AssertionRemoveStore(XOTclAssertionStore *aStore) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; - if (aStore) { - hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch); - while (hPtr) { - /* - * AssertionRemoveProc calls Tcl_DeleteHashEntry(hPtr), thus - * we get the FirstHashEntry afterwards again to proceed - */ - AssertionRemoveProc(aStore, Tcl_GetHashKey(&aStore->procs, hPtr)); - hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch); + if (aStore) { + hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch); + while (hPtr) { + /* + * AssertionRemoveProc calls Tcl_DeleteHashEntry(hPtr), thus + * we get the FirstHashEntry afterwards again to proceed + */ + AssertionRemoveProc(aStore, Tcl_GetHashKey(&aStore->procs, hPtr)); + hPtr = Tcl_FirstHashEntry(&aStore->procs, &hSrch); + } + Tcl_DeleteHashTable(&aStore->procs); + MEM_COUNT_FREE("Tcl_InitHashTable",&aStore->procs); + TclObjListFreeList(aStore->invariants); + FREE(XOTclAssertionStore, aStore); } - Tcl_DeleteHashTable(&aStore->procs); - MEM_COUNT_FREE("Tcl_InitHashTable",&aStore->procs); - TclObjListFreeList(aStore->invariants); - FREE(XOTclAssertionStore, aStore); - } } /* * check a given condition in the current callframe's scope * it's the responsiblity of the caller to push the intended callframe */ static int -checkConditionInScope(Tcl_Interp *in, Tcl_Obj *condition) { - int result, success; - Tcl_Obj *ov[2]; - ov [1] = condition; - INCR_REF_COUNT(condition); - /* - fprintf(stderr, "----- evaluating condition '%s'\n", ObjStr(condition)); - */ - result = XOTcl_ExprObjCmd(NULL, in, 2, ov); - DECR_REF_COUNT(condition); - /* - fprintf(stderr, "----- running condition '%s', result=%d '%s'\n", - ObjStr(condition), result, - ObjStr(Tcl_GetObjResult(in))); - */ - if (result == TCL_OK) { - result = Tcl_GetIntFromObj(in,Tcl_GetObjResult(in),&success); - /* - fprintf(stderr, " success=%d\n", success); - */ - if (result == TCL_OK && success == 0) - result = XOTCL_CHECK_FAILED; - } - return result; +checkConditionInScope(Tcl_Interp *interp, Tcl_Obj *condition) { + int result, success; + Tcl_Obj *ov[2] = {NULL, condition}; + + INCR_REF_COUNT(condition); + result = XOTcl_ExprObjCmd(NULL, interp, 2, ov); + DECR_REF_COUNT(condition); + + if (result == TCL_OK) { + result = Tcl_GetIntFromObj(interp,Tcl_GetObjResult(interp),&success); + if (result == TCL_OK && success == 0) + result = XOTCL_CHECK_FAILED; + } + return result; } static int -AssertionCheckList(Tcl_Interp *in, XOTclObject *obj, - XOTclTclObjList* alist, char *methodName) { - XOTclTclObjList* checkFailed = NULL; - Tcl_Obj *savedObjResult = Tcl_GetObjResult(in); - int savedCheckoptions, acResult = TCL_OK; +AssertionCheckList(Tcl_Interp *interp, XOTclObject *obj, + XOTclTclObjList *alist, char *methodName) { + XOTclTclObjList *checkFailed = NULL; + Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); + int savedCheckoptions, acResult = TCL_OK; - /* - * no obj->opt -> checkoption == CHECK_NONE - */ - if (!obj->opt) - return TCL_OK; + /* + * no obj->opt -> checkoption == CHECK_NONE + */ + if (!obj->opt) + return TCL_OK; - /* we do not check assertion modifying methods, otherwise - we can not react in catch on a runtime assertion check failure */ - if (isCheckString(methodName) || isInfoString(methodName) || - isInvarString(methodName) || isInstinvarString(methodName) || - isProcString(methodName) || isInstprocString(methodName)) - return TCL_OK; + /* we do not check assertion modifying methods, otherwise + we can not react in catch on a runtime assertion check failure */ + if (isCheckString(methodName) || isInfoString(methodName) || + isInvarString(methodName) || isInstinvarString(methodName) || + isProcString(methodName) || isInstprocString(methodName)) + return TCL_OK; - INCR_REF_COUNT(savedObjResult); + INCR_REF_COUNT(savedObjResult); - Tcl_ResetResult(in); + Tcl_ResetResult(interp); - while (alist != NULL) { - /* Eval instead of IfObjCmd => the substitutions in the - conditions will be done by Tcl */ - char *assStr = ObjStr(alist->content), *c = assStr; - int comment = 0; + while (alist != NULL) { + /* Eval instead of IfObjCmd => the substitutions in the + conditions will be done by Tcl */ + char *assStr = ObjStr(alist->content), *c = assStr; + int comment = 0; - while (c != 0 && *c != '\0') { - if (*c == '#') { - comment = 1; break; - } - c++; - } - if (!comment) { - XOTcl_FrameDecls; - XOTcl_PushFrame(in, obj); - CallStackPush(in, obj, 0, 0, 0, 0, XOTCL_CSC_TYPE_PLAIN); + while (c != 0 && *c != '\0') { + if (*c == '#') { + comment = 1; break; + } + c++; + } + if (!comment) { + XOTcl_FrameDecls; + XOTcl_PushFrame(interp, obj); + CallStackPush(interp, obj, 0, 0, 0, 0, XOTCL_CSC_TYPE_PLAIN); - /* don't check assertion during assertion check */ - savedCheckoptions = obj->opt->checkoptions; - obj->opt->checkoptions = CHECK_NONE; + /* don't check assertion during assertion check */ + savedCheckoptions = obj->opt->checkoptions; + obj->opt->checkoptions = CHECK_NONE; - /*fprintf(stderr, "Checking Assertion %s ", assStr);*/ + /*fprintf(stderr, "Checking Assertion %s ", assStr);*/ - /* - * now check the assertion in the pushed callframe's scope - */ - acResult = checkConditionInScope(in, alist->content); - if (acResult != TCL_OK) - checkFailed = alist; + /* + * now check the assertion in the pushed callframe's scope + */ + acResult = checkConditionInScope(interp, alist->content); + if (acResult != TCL_OK) + checkFailed = alist; - obj->opt->checkoptions = savedCheckoptions; + obj->opt->checkoptions = savedCheckoptions; - /*fprintf(stderr, "...%s\n", checkFailed ? "failed" : "ok");*/ + /*fprintf(stderr, "...%s\n", checkFailed ? "failed" : "ok");*/ - CallStackPop(in); - XOTcl_PopFrame(in,obj); + CallStackPop(interp); + XOTcl_PopFrame(interp,obj); + } + if (checkFailed) + break; + alist = alist->nextPtr; } - if (checkFailed) - break; - alist = alist->next; - } - if (checkFailed != NULL) { - DECR_REF_COUNT(savedObjResult); - if (acResult == TCL_ERROR) { - Tcl_Obj *sr = Tcl_GetObjResult(in); - INCR_REF_COUNT(sr); - XOTclVarErrMsg(in, "Error in Assertion: {", - ObjStr(checkFailed->content), "} in proc '", - GetSelfProc(in), "'\n\n", ObjStr(sr), (char *) NULL); - DECR_REF_COUNT(sr); - return TCL_ERROR; - } - return XOTclVarErrMsg(in, "Assertion failed check: {", - ObjStr(checkFailed->content), "} in proc '", - GetSelfProc(in), "'", (char *) NULL); - } + if (checkFailed != NULL) { + DECR_REF_COUNT(savedObjResult); + if (acResult == TCL_ERROR) { + Tcl_Obj *sr = Tcl_GetObjResult(interp); + INCR_REF_COUNT(sr); + XOTclVarErrMsg(interp, "Error in Assertion: {", + ObjStr(checkFailed->content), "} in proc '", + GetSelfProc(interp), "'\n\n", ObjStr(sr), (char *) NULL); + DECR_REF_COUNT(sr); + return TCL_ERROR; + } - Tcl_SetObjResult(in, savedObjResult); - DECR_REF_COUNT(savedObjResult); - return TCL_OK; + return XOTclVarErrMsg(interp, "Assertion failed check: {", + ObjStr(checkFailed->content), "} in proc '", + GetSelfProc(interp), "'", (char *) NULL); + } + + Tcl_SetObjResult(interp, savedObjResult); + DECR_REF_COUNT(savedObjResult); + return TCL_OK; } static int -AssertionCheckInvars(Tcl_Interp *in, XOTclObject *obj, char *method, +AssertionCheckInvars(Tcl_Interp *interp, XOTclObject *obj, char *method, CheckOptions checkoptions) { - int result = TCL_OK; + int result = TCL_OK; - if (checkoptions & CHECK_OBJINVAR && obj->opt->assertions) { - result = AssertionCheckList(in, obj, obj->opt->assertions->invariants, - method); - } + if (checkoptions & CHECK_OBJINVAR && obj->opt->assertions) { + result = AssertionCheckList(interp, obj, obj->opt->assertions->invariants, + method); + } - if (result != TCL_ERROR && checkoptions & CHECK_CLINVAR) { - XOTclClasses* clPtr; - clPtr = ComputeOrder(obj->cl, obj->cl->order, Super); - while (clPtr != 0 && result != TCL_ERROR) { - XOTclAssertionStore* aStore = (clPtr->cl->opt) ? clPtr->cl->opt->assertions : 0; - if (aStore) { - result = AssertionCheckList(in, obj, aStore->invariants, method); - } - clPtr = clPtr->next; + if (result != TCL_ERROR && checkoptions & CHECK_CLINVAR) { + XOTclClasses *clPtr; + clPtr = ComputeOrder(obj->cl, obj->cl->order, Super); + while (clPtr != 0 && result != TCL_ERROR) { + XOTclAssertionStore *aStore = (clPtr->cl->opt) ? clPtr->cl->opt->assertions : 0; + if (aStore) { + result = AssertionCheckList(interp, obj, aStore->invariants, method); + } + clPtr = clPtr->nextPtr; + } } - } - return result; + return result; } static int -AssertionCheck(Tcl_Interp *in, XOTclObject *obj, XOTclClass *cl, +AssertionCheck(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl, char *method, int checkOption) { - XOTclProcAssertion* procs; - int result = TCL_OK; - XOTclAssertionStore* aStore; + XOTclProcAssertion *procs; + int result = TCL_OK; + XOTclAssertionStore *aStore; - if (cl) - aStore = cl->opt ? cl->opt->assertions : 0; - else - aStore = obj->opt ? obj->opt->assertions : 0; + if (cl) + aStore = cl->opt ? cl->opt->assertions : 0; + else + aStore = obj->opt ? obj->opt->assertions : 0; - assert(obj->opt); + assert(obj->opt); - if (checkOption & obj->opt->checkoptions) { - procs = AssertionFindProcs(aStore, method); - if (procs) { - switch (checkOption) { - case CHECK_PRE: - result = AssertionCheckList(in, obj, procs->pre, method); - break; - case CHECK_POST: - result = AssertionCheckList(in, obj, procs->post, method); - break; - } + if (checkOption & obj->opt->checkoptions) { + procs = AssertionFindProcs(aStore, method); + if (procs) { + switch (checkOption) { + case CHECK_PRE: + result = AssertionCheckList(interp, obj, procs->pre, method); + break; + case CHECK_POST: + result = AssertionCheckList(interp, obj, procs->post, method); + break; + } + } + if (result != TCL_ERROR) + result = AssertionCheckInvars(interp, obj, method, obj->opt->checkoptions); } - if (result != TCL_ERROR) - result = AssertionCheckInvars(in, obj, method, obj->opt->checkoptions); - } - return result; + return result; } @@ -3003,85 +3057,85 @@ */ static int MixinStackPush(XOTclObject *obj) { - register XOTclMixinStack* h = NEW(XOTclMixinStack); - h->currentCmdPtr = 0; - h->next = obj->mixinStack; - obj->mixinStack = h; - return 1; + register XOTclMixinStack *h = NEW(XOTclMixinStack); + h->currentCmdPtr = 0; + h->nextPtr = obj->mixinStack; + obj->mixinStack = h; + return 1; } /* * pop a mixin stack information on this object */ static void MixinStackPop(XOTclObject *obj) { - register XOTclMixinStack *h = obj->mixinStack; - obj->mixinStack = h->next; - FREE(XOTclMixinStack,h); + register XOTclMixinStack *h = obj->mixinStack; + obj->mixinStack = h->nextPtr; + FREE(XOTclMixinStack,h); } /* * Appends XOTclClasses* containing the mixin classes and their * superclasses to 'mixinClasses' list from a given mixinList */ static void -MixinComputeOrderFullList(Tcl_Interp *in, XOTclCmdList **mixinList, +MixinComputeOrderFullList(Tcl_Interp *interp, XOTclCmdList **mixinList, XOTclClasses **mixinClasses, XOTclClasses **checkList, int level) { - XOTclCmdList *m; - XOTclClasses *pl, **clPtr = mixinClasses; + XOTclCmdList *m; + XOTclClasses *pl, **clPtr = mixinClasses; - CmdListRemoveEpoched(mixinList, GuardDel); - m = *mixinList; + CmdListRemoveEpoched(mixinList, GuardDel); + m = *mixinList; - while (m) { - XOTclClass *mCl = XOTclGetClassFromCmdPtr(m->cmdPtr); - if (mCl) { - for (pl = ComputeOrder(mCl, mCl->order, Super); pl; pl = pl->next) { - /*fprintf(stderr, " %s, ", ObjStr(pl->cl->object.cmdName));*/ - if (!(pl->cl == RUNTIME_STATE(in)->theObject)) { - XOTclClassOpt* opt = pl->cl->opt; - if (opt && opt->instmixins != 0) { - /* compute transitively the instmixin classes of this added - class */ - XOTclClasses *cls; - int i, found=0; - for (i=0, cls = *checkList; cls; i++,cls = cls->next) { - /* fprintf(stderr,"+++ c%d: %s\n",i, - ObjStr(cls->cl->object.cmdName));*/ - if (pl->cl == cls->cl) { - found = 1; - break; - } - } - if (!found) { - XOTclAddClass(checkList, pl->cl, NULL); - /*fprintf(stderr, "+++ transitive %s\n", - ObjStr(pl->cl->object.cmdName));*/ + while (m) { + XOTclClass *mCl = XOTclGetClassFromCmdPtr(m->cmdPtr); + if (mCl) { + for (pl = ComputeOrder(mCl, mCl->order, Super); pl; pl = pl->nextPtr) { + /*fprintf(stderr, " %s, ", ObjStr(pl->cl->object.cmdName));*/ + if (!(pl->cl == RUNTIME_STATE(interp)->theObject)) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->instmixins != 0) { + /* compute transitively the instmixin classes of this added + class */ + XOTclClasses *cls; + int i, found=0; + for (i=0, cls = *checkList; cls; i++,cls = cls->nextPtr) { + /* fprintf(stderr,"+++ c%d: %s\n",i, + ObjStr(cls->cl->object.cmdName));*/ + if (pl->cl == cls->cl) { + found = 1; + break; + } + } + if (!found) { + XOTclClassListAdd(checkList, pl->cl, NULL); + /*fprintf(stderr, "+++ transitive %s\n", + ObjStr(pl->cl->object.cmdName));*/ - MixinComputeOrderFullList(in, &opt->instmixins, mixinClasses, - checkList, level+1); - } - } - /* fprintf(stderr,"+++ add to mixinClasses %p path: %s clPtr %p\n", - mixinClasses, ObjStr(pl->cl->object.cmdName), clPtr);*/ - clPtr = XOTclAddClass(clPtr, pl->cl, m->clientData); - } - } + MixinComputeOrderFullList(interp, &opt->instmixins, mixinClasses, + checkList, level+1); + } + } + /* fprintf(stderr,"+++ add to mixinClasses %p path: %s clPtr %p\n", + mixinClasses, ObjStr(pl->cl->object.cmdName), clPtr);*/ + clPtr = XOTclClassListAdd(clPtr, pl->cl, m->clientData); + } + } + } + m = m->nextPtr; } - m = m->next; - } - if (level == 0 && *checkList) { - XOTclFreeClasses(*checkList); - *checkList = NULL; - } + if (level == 0 && *checkList) { + XOTclClassListFree(*checkList); + *checkList = NULL; + } } static void MixinResetOrder(XOTclObject *obj) { - /*fprintf(stderr,"removeList %s \n",ObjStr(obj->cmdName));*/ - CmdListRemoveList(&obj->mixinOrder, NULL /*GuardDel*/); - obj->mixinOrder = 0; + /*fprintf(stderr,"removeList %s \n",ObjStr(obj->cmdName));*/ + CmdListRemoveList(&obj->mixinOrder, NULL /*GuardDel*/); + obj->mixinOrder = 0; } /* @@ -3092,208 +3146,237 @@ * final list. */ static void -MixinComputeOrder(Tcl_Interp *in, XOTclObject *obj) { - XOTclClasses *fullList, *checkList=0, *mixinClasses = 0, *nextCl, *pl, - *checker, *guardChecker; +MixinComputeOrder(Tcl_Interp *interp, XOTclObject *obj) { + XOTclClasses *fullList, *checkList=0, *mixinClasses = 0, *nextCl, *pl, + *checker, *guardChecker; - if (obj->mixinOrder) MixinResetOrder(obj); - /*fprintf(stderr, "Mixin Order:\n First List: ");*/ + if (obj->mixinOrder) MixinResetOrder(obj); + /*fprintf(stderr, "Mixin Order:\n First List: ");*/ - /* append per-obj mixins */ - if (obj->opt) { - MixinComputeOrderFullList(in, &obj->opt->mixins, &mixinClasses, - &checkList, 0); - } + /* append per-obj mixins */ + if (obj->opt) { + MixinComputeOrderFullList(interp, &obj->opt->mixins, &mixinClasses, + &checkList, 0); + } - /* append per-class mixins */ - for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->next) { - XOTclClassOpt* opt = pl->cl->opt; - if (opt && opt->instmixins) { - MixinComputeOrderFullList(in, &opt->instmixins, &mixinClasses, - &checkList, 0); + /* append per-class mixins */ + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->instmixins) { + MixinComputeOrderFullList(interp, &opt->instmixins, &mixinClasses, + &checkList, 0); + } } - } - fullList = mixinClasses; + fullList = mixinClasses; - /* use no duplicates & no classes of the precedence order - on the resulting list */ - while (mixinClasses) { - checker = nextCl = mixinClasses->next; - /* fprintf(stderr,"--- checking %s\n", - ObjStr(mixinClasses->cl->object.cmdName));*/ + /* use no duplicates & no classes of the precedence order + on the resulting list */ + while (mixinClasses) { + checker = nextCl = mixinClasses->nextPtr; + /* fprintf(stderr,"--- checking %s\n", + ObjStr(mixinClasses->cl->object.cmdName));*/ - while (checker) { - if (checker->cl == mixinClasses->cl) break; - checker = checker->next; - } - /* if checker is set, it is a duplicate and ignored */ + while (checker) { + if (checker->cl == mixinClasses->cl) break; + checker = checker->nextPtr; + } + /* if checker is set, it is a duplicate and ignored */ - if (checker == 0) { - /* check obj->cl hierachy */ - for (checker = ComputeOrder(obj->cl, obj->cl->order, Super); checker; checker = checker->next) { - if (checker->cl == mixinClasses->cl) - break; - } - /* if checker is set, it was found in the class hierarchy - and it is ignored */ - } - if (checker == 0) { - /* add the class to the mixinOrder list */ - XOTclCmdList* new; - /* fprintf(stderr,"--- adding to mixinlist %s\n", - ObjStr(mixinClasses->cl->object.cmdName));*/ - new = CmdListAdd(&obj->mixinOrder, mixinClasses->cl->object.id,NULL, - /*noDuplicates*/ 0); + if (checker == 0) { + /* check obj->cl hierachy */ + for (checker = ComputeOrder(obj->cl, obj->cl->order, Super); checker; checker = checker->nextPtr) { + if (checker->cl == mixinClasses->cl) + break; + } + /* if checker is set, it was found in the class hierarchy + and it is ignored */ + } + if (checker == 0) { + /* add the class to the mixinOrder list */ + XOTclCmdList *new; + /* fprintf(stderr,"--- adding to mixinlist %s\n", + ObjStr(mixinClasses->cl->object.cmdName));*/ + new = CmdListAdd(&obj->mixinOrder, mixinClasses->cl->object.id,NULL, + /*noDuplicates*/ 0); - /* in the client data of the order list, we require the first - matching guard ... scan the full list for it. */ - for (guardChecker = fullList; guardChecker; guardChecker = guardChecker->next) { - if (guardChecker->cl == mixinClasses->cl) { - new->clientData = guardChecker->clientData; - break; - } - } + /* in the client data of the order list, we require the first + matching guard ... scan the full list for it. */ + for (guardChecker = fullList; guardChecker; guardChecker = guardChecker->nextPtr) { + if (guardChecker->cl == mixinClasses->cl) { + new->clientData = guardChecker->clientData; + break; + } + } + } + mixinClasses = nextCl; } - mixinClasses = nextCl; - } - /* ... and free the memory of the full list */ - XOTclFreeClasses(fullList); + /* ... and free the memory of the full list */ + XOTclClassListFree(fullList); - /*CmdListPrint(in,"mixin order\n", obj->mixinOrder);*/ + /*CmdListPrint(interp,"mixin order\n", obj->mixinOrder);*/ } /* * add a mixin class to 'mixinList' by appending it */ static int -MixinAdd(Tcl_Interp *in, XOTclCmdList **mixinList, Tcl_Obj *name) { - XOTclClass *mixin; - Tcl_Obj *guard = NULL; - int ocName; Tcl_Obj **ovName; - XOTclCmdList* new; +MixinAdd(Tcl_Interp *interp, XOTclCmdList **mixinList, Tcl_Obj *name, XOTclClass *base) { + XOTclClass *mixin; + Tcl_Obj *guard = NULL; + int ocName; Tcl_Obj **ovName; + XOTclCmdList *new; - if (Tcl_ListObjGetElements(in, name, &ocName, &ovName) == TCL_OK && ocName > 1) { - if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) { - name = ovName[0]; - guard = ovName[2]; - /*fprintf(stderr,"mixinadd name = '%s', guard = '%s'\n", ObjStr(name), ObjStr(guard));*/ - } /*else return XOTclVarErrMsg(in, "mixin registration '", ObjStr(name), - "' has too many elements.", (char *) NULL);*/ - } + if (Tcl_ListObjGetElements(interp, name, &ocName, &ovName) == TCL_OK && ocName > 1) { + if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) { + name = ovName[0]; + guard = ovName[2]; + /*fprintf(stderr,"mixinadd name = '%s', guard = '%s'\n", ObjStr(name), ObjStr(guard));*/ + } /*else return XOTclVarErrMsg(interp, "mixin registration '", ObjStr(name), + "' has too many elements.", (char *) NULL);*/ + } - if (GetXOTclClassFromObj(in, name, &mixin, 1) != TCL_OK) - return XOTclErrBadVal(in, "mixin", "a class as mixin", ObjStr(name)); + if (GetXOTclClassFromObj(interp, name, &mixin, base) != TCL_OK) + return XOTclErrBadVal(interp, "mixin", "a class as mixin", ObjStr(name)); - new = CmdListAdd(mixinList, mixin->object.id, NULL, /*noDuplicates*/ 1); + new = CmdListAdd(mixinList, mixin->object.id, NULL, /*noDuplicates*/ 1); - if (guard) { - GuardAdd(in, new, guard); - } else { - if (new->clientData) - GuardDel(new); - } + if (guard) { + GuardAdd(interp, new, guard); + } else { + if (new->clientData) + GuardDel(new); + } - return TCL_OK; + return TCL_OK; } /* * get all instances of a class recursively to an initialized * String key hashtable */ static void -getAllInstances(Tcl_HashTable *destTable, XOTclClass *startCl) { - Tcl_HashTable *table = &startCl->instances; - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; +getAllInstances(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, int onlyWithMixins) { + Tcl_HashTable *table = &startCl->instances; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + int collect = 1; - for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(table, hPtr); - Tcl_HashEntry *hPtrDest; - int new; - hPtrDest = Tcl_CreateHashEntry(destTable, ObjStr(inst->cmdName), &new); - /* - fprintf (stderr, " -- %s (%s)\n", ObjStr(inst->cmdName), ObjStr(startCl->object.cmdName)); - */ - if (new && XOTclObjectIsClass(inst)) { - getAllInstances(destTable, (XOTclClass*) inst); + for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(table, hPtr); + Tcl_HashEntry *hPtrDest; + int new = 0; + + if (onlyWithMixins) { + if (! (collect = XOTclObjectIsClass(inst))) { + if (!(inst->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, inst); + if ((inst->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { + collect = (inst->mixinOrder != NULL); + } + } + } + if (collect) { + hPtrDest = Tcl_CreateHashEntry(destTable, ObjStr(inst->cmdName), &new); + + /*fprintf (stderr, " -- %s (%s) opt %d instopt %d\n", + ObjStr(inst->cmdName), ObjStr(startCl->object.cmdName), + inst->opt != NULL, (XOTclObjectIsClass(inst) && ((XOTclClass*)inst)->opt));*/ + } + + if (new) { + if (XOTclObjectIsClass(inst)) { + XOTclClasses *sl = ((XOTclClass*)inst)->sub, *sc; + getAllInstances(interp, destTable, (XOTclClass*) inst, onlyWithMixins); + for (sc = sl; sc != 0; sc = sc->nextPtr) + getAllInstances(interp, destTable, sc->cl, onlyWithMixins); + } + } } - } } /* * if the class hierarchy or class mixins have changed -> * invalidate mixin entries in all dependent instances */ static void -MixinInvalidateObjOrders(Tcl_Interp *in, XOTclClass *cl) { - XOTclClasses *saved = cl->order, *clPtr; - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - Tcl_HashTable objTable, *commandTable = &objTable; - XOTclObject *obj; +MixinInvalidateObjOrders(Tcl_Interp *interp, XOTclClass *cl) { + XOTclClasses *saved = cl->order, *clPtr; + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + Tcl_HashTable objTable, *commandTable = &objTable; + XOTclObject *obj; - cl->order = 0; + cl->order = 0; - for (clPtr = ComputeOrder(cl, cl->order, Sub); clPtr; clPtr = clPtr->next) { - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr = &clPtr->cl->instances ? - Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0; + for (clPtr = ComputeOrder(cl, cl->order, Sub); clPtr; clPtr = clPtr->nextPtr) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = &clPtr->cl->instances ? + Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0; - /*fprintf(stderr,"invalidating instances of class %s\n", - ObjStr(clPtr->cl->object.cmdName));*/ + /*fprintf(stderr,"invalidating instances of class %s\n", + ObjStr(clPtr->cl->object.cmdName));*/ - /* here we should check, whether this class is used as - a mixin / instmixin somewhere else and invalidate - the objects of these as well -- */ + /* here we should check, whether this class is used as + a mixin / instmixin somewhere else and invalidate + the objects of these as well -- */ - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *obj = (XOTclObject*) - Tcl_GetHashKey(&clPtr->cl->instances, hPtr); - MixinResetOrder(obj); - obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *obj = (XOTclObject*) + Tcl_GetHashKey(&clPtr->cl->instances, hPtr); + MixinResetOrder(obj); + obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + } } - } - XOTclFreeClasses(cl->order); - cl->order = saved; + XOTclClassListFree(cl->order); + cl->order = saved; #if 1 - /* TODO: Uwe, this slows down superclass by a factor of 5! - */ + /*fprintf(stderr,"invalidate order brute force %d\n", + (RUNTIME_STATE(interp)->exitHandlerDestroyRound == XOTCL_EXITHANDLER_OFF));*/ - /* invalidate the mixins on all instances that have this mixin (cl) - at the moment */ - Tcl_InitHashTable(commandTable, TCL_STRING_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable",commandTable); - getAllInstances(commandTable, RUNTIME_STATE(in)->theClass); - hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); - while (hPtr) { - char *key = Tcl_GetHashKey(commandTable, hPtr); - obj = XOTclpGetObject(in, key); + /* TODO: Uwe, this slows down superclass by a factor of 5! + maybe we can use a mixin epoch? + */ + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == XOTCL_EXITHANDLER_OFF) { + /* invalidate the mixins on all instances that have this mixin (cl) + at the moment */ + Tcl_InitHashTable(commandTable, TCL_STRING_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable",commandTable); + + getAllInstances(interp, commandTable, RUNTIME_STATE(interp)->theClass, 0); + hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); + while (hPtr) { + char *key = Tcl_GetHashKey(commandTable, hPtr); - if (obj && !XOTclObjectIsClass(obj) - && !(obj->flags & XOTCL_DESTROY_CALLED) - && (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { - XOTclCmdList *ml; - for (ml = obj->mixinOrder; ml; ml = ml->next) { - XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (mixin == cl) { - MixinResetOrder(obj); - obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; - break; - } - } + obj = XOTclpGetObject(interp, key); + /*fprintf(stderr,"invalidate order brute force check %s\n",key);*/ + if (obj && !XOTclObjectIsClass(obj) + && !(obj->flags & XOTCL_DESTROY_CALLED) + && (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { + XOTclCmdList *ml; + for (ml = obj->mixinOrder; ml; ml = ml->nextPtr) { + XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (mixin == cl) { + /*fprintf(stderr,"invalidate order brute force reset %s\n",ObjStr(obj->cmdName));*/ + MixinResetOrder(obj); + obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + break; + } + } + } + hPtr = Tcl_NextHashEntry(&hSrch); + } + MEM_COUNT_FREE("Tcl_InitHashTable",commandTable); + Tcl_DeleteHashTable(commandTable); } - hPtr = Tcl_NextHashEntry(&hSrch); - } - MEM_COUNT_FREE("Tcl_InitHashTable",commandTable); - Tcl_DeleteHashTable(commandTable); #endif } - static int MixinInfo(Tcl_Interp *in, XOTclCmdList* m, char *pattern, int withGuards); + +static int MixinInfo(Tcl_Interp *interp, XOTclCmdList *m, char *pattern, int withGuards); /* * the mixin order is either * DEFINED (there are mixins on the instance), @@ -3304,13 +3387,13 @@ * and set the instance to DEFINE or NONE */ static void -MixinComputeDefined(Tcl_Interp *in, XOTclObject *obj) { - MixinComputeOrder(in, obj); - obj->flags |= XOTCL_MIXIN_ORDER_VALID; - if (obj->mixinOrder) - obj->flags |= XOTCL_MIXIN_ORDER_DEFINED; - else - obj->flags &= ~XOTCL_MIXIN_ORDER_DEFINED; +MixinComputeDefined(Tcl_Interp *interp, XOTclObject *obj) { + MixinComputeOrder(interp, obj); + obj->flags |= XOTCL_MIXIN_ORDER_VALID; + if (obj->mixinOrder) + obj->flags |= XOTCL_MIXIN_ORDER_DEFINED; + else + obj->flags &= ~XOTCL_MIXIN_ORDER_DEFINED; } /* @@ -3320,163 +3403,164 @@ * precondition: obj->mixinStack is not NULL */ static void -MixinSeekCurrent(Tcl_Interp *in, XOTclObject *obj, XOTclCmdList **cmdList) { - Tcl_Command currentCmdPtr; +MixinSeekCurrent(Tcl_Interp *interp, XOTclObject *obj, XOTclCmdList **cmdList) { + Tcl_Command currentCmdPtr; - /* ensure that the mixin order is not invalid, otherwise compute order */ - assert(obj->flags & XOTCL_MIXIN_ORDER_VALID); - /*MixinComputeDefined(in, obj);*/ - currentCmdPtr = obj->mixinStack->currentCmdPtr; + /* ensure that the mixin order is not invalid, otherwise compute order */ + assert(obj->flags & XOTCL_MIXIN_ORDER_VALID); + /*MixinComputeDefined(interp, obj);*/ + currentCmdPtr = obj->mixinStack->currentCmdPtr; - /* - { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - XOTclCallStackContent *csc = cs->top; - fprintf(stderr, "%p == %p ==> %d \n", csc->cl, currentCmdPtr, - csc->cmdPtr == currentCmdPtr); - } - */ + /* + { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc = cs->top; + fprintf(stderr, "%p == %p ==> %d \n", csc->cl, currentCmdPtr, + csc->cmdPtr == currentCmdPtr); + } + */ - /*** - { Tcl_Obj *sr; + /*** + { Tcl_Obj *sr; - MixinInfo(in, obj->mixinOrder, NULL,0); - sr = Tcl_GetObjResult(in); - fprintf(stderr,"INFO->%s order %p next %p\n",ObjStr(sr), obj->mixinOrder, obj->mixinOrder->next); - } - ***/ + MixinInfo(interp, obj->mixinOrder, NULL,0); + sr = Tcl_GetObjResult(interp); + fprintf(stderr,"INFO->%s order %p next %p\n",ObjStr(sr), obj->mixinOrder, obj->mixinOrder->nextPtr); + } + ***/ - *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) : ""); - */ + *cmdList = obj->mixinOrder; + /* + fprintf(stderr, "->1 mixin seek current = %p next = %p %s\n", + currentCmdPtr, + (*cmdList)->nextPtr, + (*cmdList)->nextPtr ? Tcl_GetCommandName(interp, (*cmdList)->nextPtr->cmdPtr) : ""); + */ #if defined(ACTIVEMIXIN) - /*RUNTIME_STATE(in)->cmdPtr = (*cmdList)->next ? (*cmdList)->next->cmdPtr : NULL;*/ - RUNTIME_STATE(in)->cmdPtr = (*cmdList)->cmdPtr; + /*RUNTIME_STATE(interp)->cmdPtr = (*cmdList)->nextPtr ? (*cmdList)->nextPtr->cmdPtr : NULL;*/ + RUNTIME_STATE(interp)->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; + /* go forward to current class */ + while (*cmdList && currentCmdPtr) { + /* fprintf(stderr, "->2 mixin seek current = %p next = %p\n", currentCmdPtr, (*cmdList)->nextPtr);*/ + if ((*cmdList)->cmdPtr == currentCmdPtr) + currentCmdPtr = 0; + *cmdList = (*cmdList)->nextPtr; #if defined(ACTIVEMIXIN) - /*RUNTIME_STATE(in)->cmdPtr = (*cmdList)->next ? (*cmdList)->next->cmdPtr : NULL;*/ - RUNTIME_STATE(in)->cmdPtr = (*cmdList)->cmdPtr; + /*RUNTIME_STATE(interp)->cmdPtr = (*cmdList)->nextPtr ? (*cmdList)->nextPtr->cmdPtr : NULL;*/ + RUNTIME_STATE(interp)->cmdPtr = (*cmdList)->cmdPtr; #endif - } + } } /* * before we can perform a mixin dispatch, MixinSearchProc seeks the * current mixin and the relevant calling information */ static Tcl_Command -MixinSearchProc(Tcl_Interp *in, XOTclObject *obj, char *methodName, - XOTclClass **cl, Tcl_ObjCmdProc **proc, ClientData* cp, - Tcl_Command* currentCmdPtr) { - Tcl_Command cmd = NULL; - XOTclCmdList *cmdList; - XOTclClass *cls; +MixinSearchProc(Tcl_Interp *interp, XOTclObject *obj, char *methodName, + XOTclClass **cl, Tcl_ObjCmdProc **proc, ClientData *cp, + Tcl_Command *currentCmdPtr) { + Tcl_Command cmd = NULL; + XOTclCmdList *cmdList; + XOTclClass *cls; - assert(obj); - assert(obj->mixinStack); + assert(obj); + assert(obj->mixinStack); - MixinSeekCurrent(in, obj, &cmdList); + MixinSeekCurrent(interp, obj, &cmdList); - /* - fprintf(stderr, "MixinSearch searching for '%s' %p\n", methodName,cmdList); - */ - /*CmdListPrint(in,"MixinSearch CL = \n", cmdList);*/ + /* + fprintf(stderr, "MixinSearch searching for '%s' %p\n", methodName,cmdList); + */ + /*CmdListPrint(interp,"MixinSearch CL = \n", cmdList);*/ - while (cmdList) { - if (Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { - cmdList = cmdList->next; - } else { - cls = XOTclGetClassFromCmdPtr(cmdList->cmdPtr); - /* - fprintf(stderr,"+++ MixinSearch %s->%s in %p cmdPtr %p clientData %p\n", + while (cmdList) { + if(Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { + cmdList = cmdList->nextPtr; + } else { + cls = XOTclGetClassFromCmdPtr(cmdList->cmdPtr); + /* + fprintf(stderr,"+++ MixinSearch %s->%s in %p cmdPtr %p clientData %p\n", ObjStr(obj->cmdName),methodName, cmdList, cmdList->cmdPtr, cmdList->clientData); - */ - if (cls) { - int guardOk = TCL_OK; - cmd = FindMethod(methodName, cls->nsPtr); - if (cmd && cmdList->clientData) { - if (!RUNTIME_STATE(in)->cs.guardCount) { - guardOk = GuardCall(obj, cls, (Tcl_Command) cmd, in, cmdList->clientData, 1); - } - } - if (cmd && guardOk == TCL_OK) { - /* - * on success: compute mixin call data - */ - *cl = cls; - *proc = Tcl_Command_objProc(cmd); - *cp = Tcl_Command_objClientData(cmd); - *currentCmdPtr = cmdList->cmdPtr; - break; - } else { - cmd = NULL; - cmdList = cmdList->next; - } - } + */ + if (cls) { + int guardOk = TCL_OK; + cmd = FindMethod(methodName, cls->nsPtr); + if (cmd && cmdList->clientData) { + if (!RUNTIME_STATE(interp)->cs.guardCount) { + guardOk = GuardCall(obj, cls, (Tcl_Command) cmd, interp, + (Tcl_Obj*)cmdList->clientData, 1); + } + } + if (cmd && guardOk == TCL_OK) { + /* + * on success: compute mixin call data + */ + *cl = cls; + *proc = Tcl_Command_objProc(cmd); + *cp = Tcl_Command_objClientData(cmd); + *currentCmdPtr = cmdList->cmdPtr; + break; + } else { + cmd = NULL; + cmdList = cmdList->nextPtr; + } + } + } } - } - return cmd; + return cmd; } /* * info option for mixins and instmixins */ static int -MixinInfo(Tcl_Interp *in, XOTclCmdList* m, char *pattern, int withGuards) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - XOTclClass *mixinClass; - while (m) { - /* fprintf(stderr," mixin info m=%p, next=%p\n",m,m->next); */ - mixinClass = XOTclGetClassFromCmdPtr(m->cmdPtr); - if (mixinClass && - (!pattern || - Tcl_StringMatch(ObjStr(mixinClass->object.cmdName), pattern))) { - if (withGuards && m->clientData) { - Tcl_Obj *l = Tcl_NewListObj(0, NULL); - Tcl_Obj *g = (Tcl_Obj*) m->clientData; - Tcl_ListObjAppendElement(in, l, mixinClass->object.cmdName); - Tcl_ListObjAppendElement(in, l, XOTclGlobalObjects[XOTE_GUARD_OPTION]); - Tcl_ListObjAppendElement(in, l, g); - Tcl_ListObjAppendElement(in, list, l); - } else - Tcl_ListObjAppendElement(in, list, mixinClass->object.cmdName); +MixinInfo(Tcl_Interp *interp, XOTclCmdList *m, char *pattern, int withGuards) { + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + XOTclClass *mixinClass; + while (m) { + /* fprintf(stderr," mixin info m=%p, next=%p\n",m,m->nextPtr); */ + mixinClass = XOTclGetClassFromCmdPtr(m->cmdPtr); + if (mixinClass && + (!pattern || + Tcl_StringMatch(ObjStr(mixinClass->object.cmdName), pattern))) { + if (withGuards && m->clientData) { + Tcl_Obj *l = Tcl_NewListObj(0, NULL); + Tcl_Obj *g = (Tcl_Obj *) m->clientData; + Tcl_ListObjAppendElement(interp, l, mixinClass->object.cmdName); + Tcl_ListObjAppendElement(interp, l, XOTclGlobalObjects[XOTE_GUARD_OPTION]); + Tcl_ListObjAppendElement(interp, l, g); + Tcl_ListObjAppendElement(interp, list, l); + } else + Tcl_ListObjAppendElement(interp, list, mixinClass->object.cmdName); + } + m = m->nextPtr; } - m = m->next; - } - Tcl_SetObjResult(in, list); - return TCL_OK; + Tcl_SetObjResult(interp, list); + return TCL_OK; } static Tcl_Command -MixinSearchMethodByName(Tcl_Interp *in, XOTclCmdList* mixinList, char *name, XOTclClass **cl) { - Tcl_Command cmd; - while (mixinList) { - XOTclClass *mcl = - XOTclpGetClass(in, (char *) Tcl_GetCommandName(in, mixinList->cmdPtr)); - if (mcl && SearchCMethod(mcl, name, &cmd)) { - if (cl) *cl = mcl; - return cmd; - } +MixinSearchMethodByName(Tcl_Interp *interp, XOTclCmdList *mixinList, char *name, XOTclClass **cl) { + Tcl_Command cmd; + while (mixinList) { + XOTclClass *foundCl, *mcl = + XOTclpGetClass(interp, (char *) Tcl_GetCommandName(interp, mixinList->cmdPtr)); + if (mcl && (foundCl = SearchCMethod(mcl, name, &cmd))) { + if (cl) *cl = foundCl; + return cmd; + } - mixinList = mixinList->next; - } - return 0; + mixinList = mixinList->nextPtr; + } + return 0; } @@ -3494,64 +3578,64 @@ */ static Tcl_Command -FilterSearch(Tcl_Interp *in, char *name, XOTclObject *startingObj, +FilterSearch(Tcl_Interp *interp, char *name, XOTclObject *startingObj, XOTclClass *startingCl, XOTclClass **cl) { - Tcl_Command cmd = NULL; + Tcl_Command cmd = NULL; - if (startingObj) { - XOTclObjectOpt *opt = startingObj->opt; + if (startingObj) { + XOTclObjectOpt *opt = startingObj->opt; + /* + * the object-specific filter can also be defined on the object's + * class, its hierarchy, or the respective instmixins; thus use the + * object's class as start point for the class-specific search then ... + */ + startingCl = startingObj->cl; + + /* + * search for filters on object mixins + */ + if (opt && opt->mixins) { + if ((cmd = MixinSearchMethodByName(interp, opt->mixins, name, cl))) { + return cmd; + } + } + } + /* - * the object-specific filter can also be defined on the object's - * class, its hierarchy, or the respective instmixins; thus use the - * object's class as start point for the class-specific search then ... + * search for instfilters on instmixins */ - startingCl = startingObj->cl; + if (startingCl) { + XOTclClassOpt *opt = startingCl->opt; + if (opt && opt->instmixins) { + if ((cmd = MixinSearchMethodByName(interp, opt->instmixins, name, cl))) { + return cmd; + } + } + } /* - * search for filters on object mixins + * seach for object procs that are used as filters */ - if (opt && opt->mixins) { - if ((cmd = MixinSearchMethodByName(in, opt->mixins, name, cl))) { - return cmd; - } + if (startingObj && startingObj->nsPtr) { + if ((cmd = FindMethod(name, startingObj->nsPtr))) { + *cl = (XOTclClass*)startingObj; + return cmd; + } } - } - /* - * search for instfilters on instmixins - */ - if (startingCl) { - XOTclClassOpt* opt = startingCl->opt; - if (opt && opt->instmixins) { - if ((cmd = MixinSearchMethodByName(in, opt->instmixins, name, cl))) { - return cmd; - } + /* + * ok, no filter on obj or mixins -> search class + */ + if (startingCl) { + *cl = SearchCMethod(startingCl, name, &cmd); + if (!*cl) { + /* + * If no filter is found yet -> search the meta-class + */ + *cl = SearchCMethod(startingCl->object.cl, name, &cmd); + } } - } - - /* - * seach for object procs that are used as filters - */ - if (startingObj && startingObj->nsPtr) { - if ((cmd = FindMethod(name, startingObj->nsPtr))) { - *cl = (XOTclClass*)startingObj; - return cmd; - } - } - - /* - * ok, no filter on obj or mixins -> search class - */ - if (startingCl) { - *cl = SearchCMethod(startingCl, name, &cmd); - if (!*cl) { - /* - * If no filter is found yet -> search the meta-class - */ - *cl = SearchCMethod(startingCl->object.cl, name, &cmd); - } - } - return cmd; + return cmd; } /* @@ -3560,281 +3644,271 @@ /* check a filter guard, return 1 if ok */ static int -GuardCheck(Tcl_Interp *in, ClientData clientData) { - Tcl_Obj *guard = (Tcl_Obj*) clientData; - int rc; - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; +GuardCheck(Tcl_Interp *interp, Tcl_Obj *guard) { + int rc; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - if (guard) { - /* - * if there are more than one filter guard for this filter - * (i.e. they are inherited), then they are OR combined - * -> if one check succeeds => return 1 - */ + if (guard) { + /* + * if there are more than one filter guard for this filter + * (i.e. they are inherited), then they are OR combined + * -> if one check succeeds => return 1 + */ - /*fprintf(stderr, "checking guard **%s**\n", ObjStr(guard));*/ + /*fprintf(stderr, "checking guard **%s**\n", ObjStr(guard));*/ - cs->guardCount++; - rc = checkConditionInScope(in, guard); - cs->guardCount--; + cs->guardCount++; + rc = checkConditionInScope(interp, guard); + cs->guardCount--; - /*fprintf(stderr, "checking guard **%s** returned rc=%d\n", - ObjStr(fr->content), rc);*/ + /*fprintf(stderr, "checking guard **%s** returned rc=%d\n", + ObjStr(fr->content), rc);*/ - if (rc == TCL_OK) { - /* fprintf(stderr, " +++ OK\n"); */ - return TCL_OK; - } else if (rc == TCL_ERROR) { - Tcl_Obj *sr = Tcl_GetObjResult(in); - INCR_REF_COUNT(sr); + if (rc == TCL_OK) { + /* fprintf(stderr, " +++ OK\n"); */ + return TCL_OK; + } else if (rc == TCL_ERROR) { + Tcl_Obj *sr = Tcl_GetObjResult(interp); + INCR_REF_COUNT(sr); - /* fprintf(stderr, " +++ ERROR\n");*/ + /* fprintf(stderr, " +++ ERROR\n");*/ - XOTclVarErrMsg(in, "Guard Error: '", ObjStr(guard), "'\n\n", - ObjStr(sr), (char *) NULL); - DECR_REF_COUNT(sr); - return TCL_ERROR; + XOTclVarErrMsg(interp, "Guard Error: '", ObjStr(guard), "'\n\n", + ObjStr(sr), (char *) NULL); + DECR_REF_COUNT(sr); + return TCL_ERROR; + } } - } - /* - fprintf(stderr, " +++ FAILED\n"); - */ - return XOTCL_CHECK_FAILED; + /* + fprintf(stderr, " +++ FAILED\n"); + */ + return XOTCL_CHECK_FAILED; } /* -static void -GuardPrint(Tcl_Interp *in, ClientData clientData) { + static void + GuardPrint(Tcl_Interp *interp, ClientData clientData) { Tcl_Obj *guard = (TclObj*) clientData; fprintf(stderr, " +++ \n"); if (guard) { - fprintf(stderr, " * %s \n", ObjStr(guard)); + fprintf(stderr, " * %s \n", ObjStr(guard)); } fprintf(stderr, " +++ \n"); -} + } */ static void -GuardDel(XOTclCmdList* CL) { - /*fprintf(stderr, "GuardDel %p cd = %p\n", - CL, CL? CL->clientData : NULL);*/ - if (CL && CL->clientData) { - DECR_REF_COUNT((Tcl_Obj*)CL->clientData); - CL->clientData = NULL; - } +GuardDel(XOTclCmdList *CL) { + /*fprintf(stderr, "GuardDel %p clientData = %p\n", + CL, CL? CL->clientData : NULL);*/ + if (CL && CL->clientData) { + DECR_REF_COUNT((Tcl_Obj *)CL->clientData); + CL->clientData = NULL; + } } XOTCLINLINE static void -GuardAdd(Tcl_Interp *in, XOTclCmdList* CL, Tcl_Obj *guard) { - if (guard) { - GuardDel(CL); - if (strlen(ObjStr(guard)) != 0) { - INCR_REF_COUNT(guard); - CL->clientData = (ClientData) guard; - /*fprintf(stderr,"guard added to %p cmdPtr=%p, clientData= %p\n", - CL, CL->cmdPtr, CL->clientData); - */ +GuardAdd(Tcl_Interp *interp, XOTclCmdList *CL, Tcl_Obj *guard) { + if (guard) { + GuardDel(CL); + if (strlen(ObjStr(guard)) != 0) { + INCR_REF_COUNT(guard); + CL->clientData = (ClientData) guard; + /*fprintf(stderr,"guard added to %p cmdPtr=%p, clientData= %p\n", + CL, CL->cmdPtr, CL->clientData); + */ + } } - } } -/* -static void -GuardAddList(Tcl_Interp *in, XOTclCmdList* dest, ClientData source) { - XOTclTclObjList* s = (XOTclTclObjList*) source; - while (s) { - GuardAdd(in, dest, (Tcl_Obj*) s->content); - s = s->next; - } -} */ static int GuardCall(XOTclObject *obj, XOTclClass *cl, Tcl_Command cmd, - Tcl_Interp *in, ClientData clientData, int push) { - int rc = TCL_OK; + Tcl_Interp *interp, Tcl_Obj *guard, int push) { + int rc = TCL_OK; - if (clientData) { - Tcl_Obj *res = Tcl_GetObjResult(in); /* save the result */ - INCR_REF_COUNT(res); + if (guard) { + Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */ + INCR_REF_COUNT(res); - /* GuardPrint(in, cmdList->clientData); */ - /* - * ok, there is a guard ... we have to push a - * fake callframe on the tcl stack so that uplevel - * is in sync with the XOTcl callstack, and we can uplevel - * into the above pushed CallStack entry - */ - if (push) { - CallStackPush(in, obj, cl, cmd, 0, 0, XOTCL_CSC_TYPE_GUARD); - rc = GuardCheck(in, clientData); - CallStackPop(in); - } else { - rc = GuardCheck(in, clientData); + /* GuardPrint(interp, cmdList->clientData); */ + /* + * ok, there is a guard ... we have to push a + * fake callframe on the tcl stack so that uplevel + * is in sync with the XOTcl callstack, and we can uplevel + * into the above pushed CallStack entry + */ + if (push) { + CallStackPush(interp, obj, cl, cmd, 0, 0, XOTCL_CSC_TYPE_GUARD); + rc = GuardCheck(interp, guard); + CallStackPop(interp); + } else { + rc = GuardCheck(interp, guard); + } + Tcl_SetObjResult(interp, res); /* restore the result */ + DECR_REF_COUNT(res); } - Tcl_SetObjResult(in, res); /* restore the result */ - DECR_REF_COUNT(res); - } - return rc; + return rc; } static int -GuardAddFromDefinitionList(Tcl_Interp *in, XOTclCmdList* dest, +GuardAddFromDefinitionList(Tcl_Interp *interp, XOTclCmdList *dest, XOTclObject *obj, Tcl_Command interceptorCmd, - XOTclCmdList* interceptorDefList) { - XOTclCmdList* h; - if (interceptorDefList != 0) { - h = CmdListFindCmdInList(interceptorCmd, interceptorDefList); - if (h) { - GuardAdd(in, dest, (Tcl_Obj*) h->clientData); - /* - * 1 means we have added a guard successfully "interceptorCmd" - */ - return 1; + XOTclCmdList *interceptorDefList) { + XOTclCmdList *h; + if (interceptorDefList != 0) { + h = CmdListFindCmdInList(interceptorCmd, interceptorDefList); + if (h) { + GuardAdd(interp, dest, (Tcl_Obj *) h->clientData); + /* + * 1 means we have added a guard successfully "interceptorCmd" + */ + return 1; + } } - } - /* - * 0 means we have not added a guard successfully "interceptorCmd" - */ - return 0; + /* + * 0 means we have not added a guard successfully "interceptorCmd" + */ + return 0; } static void -GuardAddInheritedGuards(Tcl_Interp *in, XOTclCmdList* dest, - XOTclObject *obj, Tcl_Command filterCmd) { - XOTclClasses* pl; - int guardAdded = 0; - XOTclObjectOpt *opt; +GuardAddInheritedGuards(Tcl_Interp *interp, XOTclCmdList *dest, + XOTclObject *obj, Tcl_Command filterCmd) { + XOTclClasses *pl; + int guardAdded = 0; + XOTclObjectOpt *opt; - /* search guards for instfilters registered on mixins */ - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(in, obj); - if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *ml = obj->mixinOrder; - XOTclClass *mixin; - while (ml && ! guardAdded) { - mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (mixin && mixin->opt) { - guardAdded = GuardAddFromDefinitionList(in, dest, obj, filterCmd, - mixin->opt->instfilters); - } - ml = ml->next; + /* search guards for instfilters registered on mixins */ + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); + if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *ml = obj->mixinOrder; + XOTclClass *mixin; + while (ml && ! guardAdded) { + mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (mixin && mixin->opt) { + guardAdded = GuardAddFromDefinitionList(interp, dest, obj, filterCmd, + mixin->opt->instfilters); + } + ml = ml->nextPtr; + } } - } - /* search per-object filters */ - opt = obj->opt; - if (!guardAdded && opt && opt->filters) { - guardAdded = GuardAddFromDefinitionList(in, dest, obj, filterCmd, opt->filters); - } - - if (!guardAdded) { - /* search per-class filters */ - for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); !guardAdded && pl; pl = pl->next) { - XOTclClassOpt* opt = pl->cl->opt; - if (opt) { - guardAdded = GuardAddFromDefinitionList(in, dest, obj, filterCmd, - opt->instfilters); - } + /* search per-object filters */ + opt = obj->opt; + if (!guardAdded && opt && opt->filters) { + guardAdded = GuardAddFromDefinitionList(interp, dest, obj, filterCmd, opt->filters); } - - /* - * if this is not a registered filter, it is an inherited filter, like: - * Class A - * A instproc f ... - * Class B -superclass A - * B instproc {{f {}}} - * B instfilter f - * -> get the guard from the filter that inherits it (here B->f) - */ if (!guardAdded) { - XOTclCmdList* registeredFilter = - CmdListFindNameInList(in,(char *) Tcl_GetCommandName(in, filterCmd), - obj->filterOrder); - if (registeredFilter) { - GuardAdd(in, dest, (Tcl_Obj*) registeredFilter->clientData); - } + /* search per-class filters */ + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); !guardAdded && pl; pl = pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt) { + guardAdded = GuardAddFromDefinitionList(interp, dest, obj, filterCmd, + opt->instfilters); + } + } + + + /* + * if this is not a registered filter, it is an inherited filter, like: + * Class A + * A instproc f ... + * Class B -superclass A + * B instproc {{f {}}} + * B instfilter f + * -> get the guard from the filter that inherits it (here B->f) + */ + if (!guardAdded) { + XOTclCmdList *registeredFilter = + CmdListFindNameInList(interp,(char *) Tcl_GetCommandName(interp, filterCmd), + obj->filterOrder); + if (registeredFilter) { + GuardAdd(interp, dest, (Tcl_Obj *) registeredFilter->clientData); + } + } } - } } static int -GuardList(Tcl_Interp *in, XOTclCmdList* frl, char *interceptorName) { - XOTclCmdList* h; - if (frl) { - /* try to find simple name first */ - h = CmdListFindNameInList(in, interceptorName, frl); - if (!h) { - /* maybe it is a qualified name */ - Tcl_Command cmd = NSFindCommand(in, interceptorName, NULL); - if (cmd) { - h = CmdListFindCmdInList(cmd, frl); - } +GuardList(Tcl_Interp *interp, XOTclCmdList *frl, char *interceptorName) { + XOTclCmdList *h; + if (frl) { + /* try to find simple name first */ + h = CmdListFindNameInList(interp, interceptorName, frl); + if (!h) { + /* maybe it is a qualified name */ + Tcl_Command cmd = NSFindCommand(interp, interceptorName, NULL); + if (cmd) { + h = CmdListFindCmdInList(cmd, frl); + } + } + if (h) { + Tcl_ResetResult(interp); + if (h->clientData) { + Tcl_Obj *g = (Tcl_Obj *) h->clientData; + Tcl_SetObjResult(interp, g); + } + return TCL_OK; + } } - if (h) { - Tcl_ResetResult(in); - if (h->clientData) { - Tcl_Obj *g = (Tcl_Obj*) h->clientData; - Tcl_SetObjResult(in, g); - } - return TCL_OK; - } - } - return XOTclVarErrMsg(in, "info (*)guard: can't find filter/mixin ", - interceptorName, (char *) NULL); + return XOTclVarErrMsg(interp, "info (*)guard: can't find filter/mixin ", + interceptorName, (char *) NULL); } /* * append a filter command to the 'filterList' of an obj/class */ static int -FilterAdd(Tcl_Interp *in, XOTclCmdList **filterList, Tcl_Obj *name, +FilterAdd(Tcl_Interp *interp, XOTclCmdList **filterList, Tcl_Obj *name, XOTclObject *startingObj, XOTclClass *startingCl) { - Tcl_Command cmd; - int ocName; Tcl_Obj **ovName; - Tcl_Obj *guard = NULL; - XOTclCmdList *new; - XOTclClass *cl; + Tcl_Command cmd; + int ocName; Tcl_Obj **ovName; + Tcl_Obj *guard = NULL; + XOTclCmdList *new; + XOTclClass *cl; - if (Tcl_ListObjGetElements(in, name, &ocName, &ovName) == TCL_OK && ocName > 1) { - if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) { - name = ovName[0]; - guard = ovName[2]; + if (Tcl_ListObjGetElements(interp, name, &ocName, &ovName) == TCL_OK && ocName > 1) { + if (ocName == 3 && !strcmp(ObjStr(ovName[1]), XOTclGlobalStrings[XOTE_GUARD_OPTION])) { + name = ovName[0]; + guard = ovName[2]; + } } - } - if (!(cmd = FilterSearch(in, ObjStr(name), startingObj, startingCl, &cl))) { - if (startingObj) - return XOTclVarErrMsg(in, "filter: can't find filterproc on: ", - ObjStr(startingObj->cmdName), " - proc: ", - ObjStr(name), (char *) NULL); - else - return XOTclVarErrMsg(in, "instfilter: can't find filterproc on: ", - ObjStr(startingCl->object.cmdName), " - proc: ", - ObjStr(name), (char *) NULL); - } + if (!(cmd = FilterSearch(interp, ObjStr(name), startingObj, startingCl, &cl))) { + if (startingObj) + return XOTclVarErrMsg(interp, "filter: can't find filterproc on: ", + ObjStr(startingObj->cmdName), " - proc: ", + ObjStr(name), (char *) NULL); + else + return XOTclVarErrMsg(interp, "instfilter: can't find filterproc on: ", + ObjStr(startingCl->object.cmdName), " - proc: ", + ObjStr(name), (char *) NULL); + } - /*fprintf(stderr, " +++ adding filter %s cl %p\n", ObjStr(name),cl);*/ + /*fprintf(stderr, " +++ adding filter %s cl %p\n", ObjStr(name),cl);*/ - new = CmdListAdd(filterList, cmd, cl, /*noDuplicates*/ 1); + new = CmdListAdd(filterList, cmd, cl, /*noDuplicates*/ 1); - if (guard) { - GuardAdd(in, new, guard); - } else { - if (new->clientData) - GuardDel(new); - } + if (guard) { + GuardAdd(interp, new, guard); + } else { + if (new->clientData) + GuardDel(new); + } - return TCL_OK; + return TCL_OK; } /* * reset the filter order cached in obj->filterOrder */ static void FilterResetOrder(XOTclObject *obj) { - CmdListRemoveList(&obj->filterOrder, GuardDel); - obj->filterOrder = 0; + CmdListRemoveList(&obj->filterOrder, GuardDel); + obj->filterOrder = 0; } /* @@ -3843,33 +3917,33 @@ * command, so that we can be sure it is still reachable. */ static void -FilterSearchAgain(Tcl_Interp *in, XOTclCmdList **filters, +FilterSearchAgain(Tcl_Interp *interp, XOTclCmdList **filters, XOTclObject *startingObj, XOTclClass *startingCl) { - char *simpleName; - Tcl_Command cmd; - XOTclCmdList *cmdList, *del; - XOTclClass *cl = NULL; + char *simpleName; + Tcl_Command cmd; + XOTclCmdList *cmdList, *del; + XOTclClass *cl = NULL; - CmdListRemoveEpoched(filters, GuardDel); - cmdList = *filters; - while (cmdList) { - simpleName = (char *) Tcl_GetCommandName(in, cmdList->cmdPtr); - cmd = FilterSearch(in, simpleName, startingObj, startingCl, &cl); - if (cmd == NULL) { - del = cmdList; - cmdList = cmdList->next; - del = CmdListRemoveFromList(filters, del); - CmdListDeleteCmdListEntry(del, GuardDel); - } else { - if (cmd != cmdList->cmdPtr) - CmdListReplaceCmd(cmdList, cmd, cl); - cmdList = cmdList->next; + CmdListRemoveEpoched(filters, GuardDel); + cmdList = *filters; + while (cmdList) { + simpleName = (char *) Tcl_GetCommandName(interp, cmdList->cmdPtr); + cmd = FilterSearch(interp, simpleName, startingObj, startingCl, &cl); + if (cmd == NULL) { + del = cmdList; + cmdList = cmdList->nextPtr; + del = CmdListRemoveFromList(filters, del); + CmdListDeleteCmdListEntry(del, GuardDel); + } else { + if (cmd != cmdList->cmdPtr) + CmdListReplaceCmd(cmdList, cmd, cl); + cmdList = cmdList->nextPtr; + } } - } - /* some entries might be NULL now, if they are not found anymore - -> delete those - CmdListRemoveNulledEntries(filters, GuardDel); - */ + /* some entries might be NULL now, if they are not found anymore + -> delete those + CmdListRemoveNulledEntries(filters, GuardDel); + */ } @@ -3879,35 +3953,35 @@ * */ static void -FilterInvalidateObjOrders(Tcl_Interp *in, XOTclClass *cl) { - XOTclClasses *saved = cl->order, *clPtr, *savePtr; +FilterInvalidateObjOrders(Tcl_Interp *interp, XOTclClass *cl) { + XOTclClasses *saved = cl->order, *clPtr, *savePtr; - cl->order = 0; - savePtr = clPtr = ComputeOrder(cl, cl->order, Sub); - cl->order = saved; + cl->order = 0; + savePtr = clPtr = ComputeOrder(cl, cl->order, Sub); + cl->order = saved; - while (clPtr != 0) { - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr = &clPtr->cl->instances ? - Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0; + while (clPtr != 0) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = &clPtr->cl->instances ? + Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0; - /* recalculate the commands of all instfilter registrations */ - if (clPtr->cl->opt) { - FilterSearchAgain(in, &clPtr->cl->opt->instfilters, 0, clPtr->cl); - } - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *obj = (XOTclObject*) Tcl_GetHashKey(&clPtr->cl->instances, hPtr); - FilterResetOrder(obj); - obj->flags &= ~XOTCL_FILTER_ORDER_VALID; + /* recalculate the commands of all instfilter registrations */ + if (clPtr->cl->opt) { + FilterSearchAgain(interp, &clPtr->cl->opt->instfilters, 0, clPtr->cl); + } + for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *obj = (XOTclObject *)Tcl_GetHashKey(&clPtr->cl->instances, hPtr); + FilterResetOrder(obj); + obj->flags &= ~XOTCL_FILTER_ORDER_VALID; - /* recalculate the commands of all object filter registrations */ - if (obj->opt) { - FilterSearchAgain(in, &obj->opt->filters, obj, 0); - } + /* recalculate the commands of all object filter registrations */ + if (obj->opt) { + FilterSearchAgain(interp, &obj->opt->filters, obj, 0); + } + } + clPtr = clPtr->nextPtr; } - clPtr = clPtr->next; - } - XOTclFreeClasses(savePtr); + XOTclClassListFree(savePtr); } /* @@ -3918,74 +3992,74 @@ */ static void FilterRemoveDependentFilterCmds(XOTclClass *cl, XOTclClass *removeClass) { - XOTclClasses *saved = cl->order, *clPtr; - cl->order = 0; + XOTclClasses *saved = cl->order, *clPtr; + cl->order = 0; - /*fprintf(stderr, "FilterRemoveDependentFilterCmds cl %p %s, removeClass %p %s\n", - cl,ObjStr(cl->object.cmdName), - removeClass,ObjStr(removeClass->object.cmdName));*/ + /*fprintf(stderr, "FilterRemoveDependentFilterCmds cl %p %s, removeClass %p %s\n", + cl,ObjStr(cl->object.cmdName), + removeClass,ObjStr(removeClass->object.cmdName));*/ - for (clPtr = ComputeOrder(cl, cl->order, Sub); clPtr; clPtr = clPtr->next) { - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr = &clPtr->cl->instances ? - Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0; - XOTclClassOpt* opt = clPtr->cl->opt; - if (opt) { - CmdListRemoveContextClassFromList(&opt->instfilters,removeClass, GuardDel); + for (clPtr = ComputeOrder(cl, cl->order, Sub); clPtr; clPtr = clPtr->nextPtr) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = &clPtr->cl->instances ? + Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : 0; + XOTclClassOpt *opt = clPtr->cl->opt; + if (opt) { + CmdListRemoveContextClassFromList(&opt->instfilters,removeClass, GuardDel); + } + for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *obj = (XOTclObject*) Tcl_GetHashKey(&clPtr->cl->instances, hPtr); + if (obj->opt) { + CmdListRemoveContextClassFromList(&obj->opt->filters,removeClass, GuardDel); + } + } } - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *obj = (XOTclObject*) Tcl_GetHashKey(&clPtr->cl->instances, hPtr); - if (obj->opt) { - CmdListRemoveContextClassFromList(&obj->opt->filters,removeClass, GuardDel); - } - } - } - XOTclFreeClasses(cl->order); - cl->order = saved; + XOTclClassListFree(cl->order); + cl->order = saved; } /* * build up a qualifier of the form proc/instproc * if cl is not NULL, we build an instproc identifier for cl, else a proc * with obj */ -static Tcl_Obj* -getFullProcQualifier(Tcl_Interp *in, CONST84 char *cmdName, +static Tcl_Obj * +getFullProcQualifier(Tcl_Interp *interp, CONST84 char *cmdName, XOTclObject *obj, XOTclClass *cl, Tcl_Command cmd) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - Tcl_Obj *procObj = Tcl_NewStringObj(cmdName, -1); - Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); - int isTcl = (TclIsProc((Command *)cmd) != NULL); + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + Tcl_Obj *procObj = Tcl_NewStringObj(cmdName, -1); + Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); + int isTcl = (TclIsProc((Command *)cmd) != NULL); - if (cl) { - Tcl_ListObjAppendElement(in, list, cl->object.cmdName); - /*fprintf(stderr,"current %p, dispatch %p, forward %p, parametermcd %p, is tcl %p\n", - objProc, XOTclObjDispatch, XOTclForwardMethod, - XOTclSetterMethod, TclIsProc((Command *)cmd)); */ - if (isTcl) { - Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_INSTPROC]); - } else if (objProc == XOTclForwardMethod) { - Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_INSTFORWARD]); - } else if (objProc == XOTclSetterMethod) { - Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_INSTPARAMETERCMD]); + if (cl) { + Tcl_ListObjAppendElement(interp, list, cl->object.cmdName); + /*fprintf(stderr,"current %p, dispatch %p, forward %p, parametermcd %p, is tcl %p\n", + objProc, XOTclObjDispatch, XOTclForwardMethod, + XOTclSetterMethod, TclIsProc((Command *)cmd)); */ + if (isTcl) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTPROC]); + } else if (objProc == XOTclForwardMethod) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTFORWARD]); + } else if (objProc == XOTclSetterMethod) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTPARAMETERCMD]); + } else { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTCMD]); + } } else { - Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_INSTCMD]); + Tcl_ListObjAppendElement(interp, list, obj->cmdName); + if (isTcl) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_PROC]); + } else if (objProc == XOTclForwardMethod) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_FORWARD]); + } else if (objProc == XOTclSetterMethod) { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_PARAMETERCMD]); + } else { + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_CMD]); + } } - } else { - Tcl_ListObjAppendElement(in, list, obj->cmdName); - if (isTcl) { - Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_PROC]); - } else if (objProc == XOTclForwardMethod) { - Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_FORWARD]); - } else if (objProc == XOTclSetterMethod) { - Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_PARAMETERCMD]); - } else { - Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_CMD]); - } - } - Tcl_ListObjAppendElement(in, list, procObj); - return list; + Tcl_ListObjAppendElement(interp, list, procObj); + return list; } /* @@ -3994,103 +4068,105 @@ * fullProcQualifiers -> if not 0 => full names with obj/class proc/instproc */ static int -FilterInfo(Tcl_Interp *in, XOTclCmdList* f, char *pattern, +FilterInfo(Tcl_Interp *interp, XOTclCmdList *f, char *pattern, int withGuards, int fullProcQualifiers) { - CONST84 char *simpleName; - Tcl_Obj *list = Tcl_NewListObj(0, NULL); + CONST84 char *simpleName; + Tcl_Obj *list = Tcl_NewListObj(0, NULL); - /* guard lists should only have unqualified filter lists - when withGuards is activated, fullProcQualifiers has not - effect */ - if (withGuards) { - fullProcQualifiers = 0; - } + /*fprintf(stderr,"FilterInfo %p %s %d %d\n", pattern, pattern, withGuards, fullProcQualifiers);*/ - while (f) { - simpleName = Tcl_GetCommandName(in, f->cmdPtr); - if (!pattern || Tcl_StringMatch(simpleName, pattern)) { - if (withGuards && f->clientData) { - Tcl_Obj *innerList = Tcl_NewListObj(0, NULL); - Tcl_Obj *g = (Tcl_Obj*) f->clientData; - Tcl_ListObjAppendElement(in, innerList, - Tcl_NewStringObj(simpleName, -1)); - Tcl_ListObjAppendElement(in, innerList, XOTclGlobalObjects[XOTE_GUARD_OPTION]); - Tcl_ListObjAppendElement(in, innerList, g); - Tcl_ListObjAppendElement(in, list, innerList); - } else { - if (fullProcQualifiers) { - XOTclClass *fcl; - XOTclObject *fobj; - if (f->clorobj && !XOTclObjectIsClass(&f->clorobj->object)) { - fobj = (XOTclObject *)f->clorobj; - fcl = NULL; - } else { - fobj = NULL; - fcl = f->clorobj; - } - Tcl_ListObjAppendElement(in, list, - getFullProcQualifier(in, simpleName, - fobj, fcl, f->cmdPtr)); - } else { - Tcl_ListObjAppendElement(in, list, Tcl_NewStringObj(simpleName, -1)); - } - } + /* guard lists should only have unqualified filter lists + when withGuards is activated, fullProcQualifiers has not + effect */ + if (withGuards) { + fullProcQualifiers = 0; } - f = f->next; - } - Tcl_SetObjResult(in, list); - return TCL_OK; + + while (f) { + simpleName = Tcl_GetCommandName(interp, f->cmdPtr); + if (!pattern || Tcl_StringMatch(simpleName, pattern)) { + if (withGuards && f->clientData) { + Tcl_Obj *innerList = Tcl_NewListObj(0, NULL); + Tcl_Obj *g = (Tcl_Obj *) f->clientData; + Tcl_ListObjAppendElement(interp, innerList, + Tcl_NewStringObj(simpleName, -1)); + Tcl_ListObjAppendElement(interp, innerList, XOTclGlobalObjects[XOTE_GUARD_OPTION]); + Tcl_ListObjAppendElement(interp, innerList, g); + Tcl_ListObjAppendElement(interp, list, innerList); + } else { + if (fullProcQualifiers) { + XOTclClass *fcl; + XOTclObject *fobj; + if (f->clorobj && !XOTclObjectIsClass(&f->clorobj->object)) { + fobj = (XOTclObject *)f->clorobj; + fcl = NULL; + } else { + fobj = NULL; + fcl = f->clorobj; + } + Tcl_ListObjAppendElement(interp, list, + getFullProcQualifier(interp, simpleName, + fobj, fcl, f->cmdPtr)); + } else { + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(simpleName, -1)); + } + } + } + f = f->nextPtr; + } + Tcl_SetObjResult(interp, list); + return TCL_OK; } /* * Appends XOTclCmdPtr* containing the filter cmds and their * superclass specializations to 'filterList' */ static void -FilterComputeOrderFullList(Tcl_Interp *in, XOTclCmdList **filters, +FilterComputeOrderFullList(Tcl_Interp *interp, XOTclCmdList **filters, XOTclCmdList **filterList) { - XOTclCmdList *f ; - char *simpleName; - XOTclClass *fcl; - XOTclClasses *pl; + XOTclCmdList *f ; + char *simpleName; + XOTclClass *fcl; + XOTclClasses *pl; - /* - * ensure that no epoched command is in the filters list - */ - CmdListRemoveEpoched(filters, GuardDel); + /* + * ensure that no epoched command is in the filters list + */ + CmdListRemoveEpoched(filters, GuardDel); - for (f = *filters; f; f = f->next) { - simpleName = (char *) Tcl_GetCommandName(in, f->cmdPtr); - fcl = f->clorobj; - CmdListAdd(filterList, f->cmdPtr, fcl, /*noDuplicates*/ 0); + for (f = *filters; f; f = f->nextPtr) { + simpleName = (char *) Tcl_GetCommandName(interp, f->cmdPtr); + fcl = f->clorobj; + CmdListAdd(filterList, f->cmdPtr, fcl, /*noDuplicates*/ 0); - if (fcl && !XOTclObjectIsClass(&fcl->object)) { - /* get the object for per-object filter */ - XOTclObject *fObj = (XOTclObject *)fcl; - /* and then get class */ - fcl = fObj->cl; - } + if (fcl && !XOTclObjectIsClass(&fcl->object)) { + /* get the object for per-object filter */ + XOTclObject *fObj = (XOTclObject *)fcl; + /* and then get class */ + fcl = fObj->cl; + } - /* if we have a filter class -> search up the inheritance hierarchy*/ - if (fcl) { - pl = ComputeOrder(fcl, fcl->order, Super); - if (pl && pl->next) { - /* don't search on the start class again */ - pl = pl->next; - /* now go up the hierarchy */ - for(; pl; pl = pl->next) { - Tcl_Command pi = FindMethod(simpleName, pl->cl->nsPtr); - if (pi) { - CmdListAdd(filterList, pi, pl->cl, /*noDuplicates*/ 0); - /* - fprintf(stderr, " %s::%s, ", ObjStr(pl->cl->object.cmdName), simpleName); - */ - } - } - } + /* if we have a filter class -> search up the inheritance hierarchy*/ + if (fcl) { + pl = ComputeOrder(fcl, fcl->order, Super); + if (pl && pl->nextPtr) { + /* don't search on the start class again */ + pl = pl->nextPtr; + /* now go up the hierarchy */ + for(; pl; pl = pl->nextPtr) { + Tcl_Command pi = FindMethod(simpleName, pl->cl->nsPtr); + if (pi) { + CmdListAdd(filterList, pi, pl->cl, /*noDuplicates*/ 0); + /* + fprintf(stderr, " %s::%s, ", ObjStr(pl->cl->object.cmdName), simpleName); + */ + } + } + } + } } - } - /*CmdListPrint(in,"FilterComputeOrderFullList....\n", *filterList);*/ + /*CmdListPrint(interp,"FilterComputeOrderFullList....\n", *filterList);*/ } /* @@ -4101,73 +4177,73 @@ * final list. */ static void -FilterComputeOrder(Tcl_Interp *in, XOTclObject *obj) { - XOTclCmdList *filterList = 0, *next, *checker, *newlist; - XOTclClasses *pl; +FilterComputeOrder(Tcl_Interp *interp, XOTclObject *obj) { + XOTclCmdList *filterList = 0, *next, *checker, *newlist; + XOTclClasses *pl; - if (obj->filterOrder) FilterResetOrder(obj); - /* - fprintf(stderr, " List: ", ObjStr(obj->cmdName)); - */ + if (obj->filterOrder) FilterResetOrder(obj); + /* + fprintf(stderr, " List: ", ObjStr(obj->cmdName)); + */ - /* append instfilters registered for mixins */ - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(in, obj); + /* append instfilters registered for mixins */ + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); - if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *ml = obj->mixinOrder; - XOTclClass *mixin; - while (ml) { - mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (mixin && mixin->opt && mixin->opt->instfilters) - FilterComputeOrderFullList(in, &mixin->opt->instfilters, &filterList); - ml = ml->next; + if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *ml = obj->mixinOrder; + XOTclClass *mixin; + while (ml) { + mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (mixin && mixin->opt && mixin->opt->instfilters) + FilterComputeOrderFullList(interp, &mixin->opt->instfilters, &filterList); + ml = ml->nextPtr; + } } - } - /* append per-obj filters */ - if (obj->opt) - FilterComputeOrderFullList(in, &obj->opt->filters, &filterList); + /* append per-obj filters */ + if (obj->opt) + FilterComputeOrderFullList(interp, &obj->opt->filters, &filterList); - /* append per-class filters */ - for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl=pl->next) { - XOTclClassOpt* opt = pl->cl->opt; - if (opt && opt->instfilters) { - FilterComputeOrderFullList(in, &opt->instfilters, &filterList); + /* append per-class filters */ + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl=pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->instfilters) { + FilterComputeOrderFullList(interp, &opt->instfilters, &filterList); + } } - } - /* - fprintf(stderr, "\n"); - */ - /* use no duplicates & no classes of the precedence order - on the resulting list */ - while (filterList) { - checker = next = filterList->next; - while (checker) { - if (checker->cmdPtr == filterList->cmdPtr) break; - checker = checker->next; - } - if (checker == 0) { - newlist = CmdListAdd(&obj->filterOrder, filterList->cmdPtr, filterList->clorobj, - /*noDuplicates*/ 0); - GuardAddInheritedGuards(in, newlist, obj, filterList->cmdPtr); - /* - fprintf(stderr, " Adding %s::%s,\n", filterList->cmdPtr->nsPtr->fullName, Tcl_GetCommandName(in, filterList->cmdPtr)); - */ - /* - GuardPrint(in, newlist->clientData); - */ + /* + fprintf(stderr, "\n"); + */ + /* use no duplicates & no classes of the precedence order + on the resulting list */ + while (filterList) { + checker = next = filterList->nextPtr; + while (checker) { + if (checker->cmdPtr == filterList->cmdPtr) break; + checker = checker->nextPtr; + } + if (checker == 0) { + newlist = CmdListAdd(&obj->filterOrder, filterList->cmdPtr, filterList->clorobj, + /*noDuplicates*/ 0); + GuardAddInheritedGuards(interp, newlist, obj, filterList->cmdPtr); + /* + fprintf(stderr, " Adding %s::%s,\n", filterList->cmdPtr->nsPtr->fullName, Tcl_GetCommandName(interp, filterList->cmdPtr)); + */ + /* + GuardPrint(interp, newlist->clientData); + */ - } + } - CmdListDeleteCmdListEntry(filterList, GuardDel); + CmdListDeleteCmdListEntry(filterList, GuardDel); - filterList = next; - } - /* - fprintf(stderr, "\n"); - */ + filterList = next; + } + /* + fprintf(stderr, "\n"); + */ } /* @@ -4180,41 +4256,41 @@ * and set the instance to DEFINE or NONE */ static void -FilterComputeDefined(Tcl_Interp *in, XOTclObject *obj) { - FilterComputeOrder(in, obj); - obj->flags |= XOTCL_FILTER_ORDER_VALID; - if (obj->filterOrder) - obj->flags |= XOTCL_FILTER_ORDER_DEFINED; - else - obj->flags &= ~XOTCL_FILTER_ORDER_DEFINED; +FilterComputeDefined(Tcl_Interp *interp, XOTclObject *obj) { + FilterComputeOrder(interp, obj); + obj->flags |= XOTCL_FILTER_ORDER_VALID; + if (obj->filterOrder) + obj->flags |= XOTCL_FILTER_ORDER_DEFINED; + else + obj->flags &= ~XOTCL_FILTER_ORDER_DEFINED; } /* * push a filter stack information on this object */ static int -FilterStackPush(Tcl_Interp *in, XOTclObject *obj, Tcl_Obj *calledProc) { - register XOTclFilterStack* h = NEW(XOTclFilterStack); +FilterStackPush(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *calledProc) { + register XOTclFilterStack *h = NEW(XOTclFilterStack); - h->currentCmdPtr = 0; - h->calledProc = calledProc; - INCR_REF_COUNT(h->calledProc); - h->next = obj->filterStack; - obj->filterStack = h; - return 1; + h->currentCmdPtr = 0; + h->calledProc = calledProc; + INCR_REF_COUNT(h->calledProc); + h->nextPtr = obj->filterStack; + obj->filterStack = h; + return 1; } /* * pop a filter stack information on this object */ static void FilterStackPop(XOTclObject *obj) { - register XOTclFilterStack *h = obj->filterStack; - obj->filterStack = h->next; + register XOTclFilterStack *h = obj->filterStack; + obj->filterStack = h->nextPtr; - /* free stack entry */ - DECR_REF_COUNT(h->calledProc); - FREE(XOTclFilterStack, h); + /* free stack entry */ + DECR_REF_COUNT(h->calledProc); + FREE(XOTclFilterStack, h); } /* @@ -4224,43 +4300,43 @@ * precondition: obj->filterStack is not NULL */ static void -FilterSeekCurrent(Tcl_Interp *in, XOTclObject *obj, XOTclCmdList **cmdList) { - Tcl_Command currentCmd = obj->filterStack->currentCmdPtr; +FilterSeekCurrent(Tcl_Interp *interp, XOTclObject *obj, XOTclCmdList **cmdList) { + Tcl_Command currentCmd = obj->filterStack->currentCmdPtr; - assert(obj->flags & XOTCL_FILTER_ORDER_VALID); - /* ensure that the filter order is not invalid, otherwise compute order - FilterComputeDefined(in, obj); - */ + assert(obj->flags & XOTCL_FILTER_ORDER_VALID); + /* ensure that the filter order is not invalid, otherwise compute order + FilterComputeDefined(interp, obj); + */ - *cmdList = obj->filterOrder; + *cmdList = obj->filterOrder; - /* go forward to current class */ - while (*cmdList && currentCmd) { - if ((*cmdList)->cmdPtr == currentCmd) - currentCmd = 0; - *cmdList = (*cmdList)->next; - } + /* go forward to current class */ + while (*cmdList && currentCmd) { + if ((*cmdList)->cmdPtr == currentCmd) + currentCmd = 0; + *cmdList = (*cmdList)->nextPtr; + } } /* * seek through the filters active for "obj" and check whether cmdPtr * is among them */ XOTCLINLINE static int -FilterActiveOnObj(Tcl_Interp *in, XOTclObject *obj, Tcl_Command cmd) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - XOTclCallStackContent *bot = cs->content; - register XOTclCallStackContent *csc = cs->top; - while (csc > bot) { - /* only check the callstack entries for this object && - only check the callstack entries for the given cmd */ - if (obj == csc->self && cmd == csc->cmdPtr && - csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { - return 1; +FilterActiveOnObj(Tcl_Interp *interp, XOTclObject *obj, Tcl_Command cmd) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *bot = cs->content; + register XOTclCallStackContent *csc = cs->top; + while (csc > bot) { + /* only check the callstack entries for this object && + only check the callstack entries for the given cmd */ + if (obj == csc->self && cmd == csc->cmdPtr && + csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + return 1; + } + csc--; } - csc--; - } - return 0; + return 0; } /* @@ -4272,1368 +4348,1456 @@ * " instfilter , * or an empty list, if not registered */ -static Tcl_Obj* -FilterFindReg(Tcl_Interp *in, XOTclObject *obj, Tcl_Command cmd) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - XOTclClasses* pl; +static Tcl_Obj * +FilterFindReg(Tcl_Interp *interp, XOTclObject *obj, Tcl_Command cmd) { + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + XOTclClasses *pl; - /* search per-object filters */ - if (obj->opt && CmdListFindCmdInList(cmd, obj->opt->filters)) { - Tcl_ListObjAppendElement(in, list, obj->cmdName); - Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_FILTER]); - Tcl_ListObjAppendElement(in, list, - Tcl_NewStringObj(Tcl_GetCommandName(in, cmd), -1)); - return list; - } + /* search per-object filters */ + if (obj->opt && CmdListFindCmdInList(cmd, obj->opt->filters)) { + Tcl_ListObjAppendElement(interp, list, obj->cmdName); + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_FILTER]); + Tcl_ListObjAppendElement(interp, list, + Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1)); + return list; + } - /* search per-class filters */ - for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->next) { - XOTclClassOpt* opt = pl->cl->opt; - if (opt && opt->instfilters) { - if (CmdListFindCmdInList(cmd, opt->instfilters)) { - Tcl_ListObjAppendElement(in, list, pl->cl->object.cmdName); - Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_INSTFILTER]); - Tcl_ListObjAppendElement(in, list, - Tcl_NewStringObj(Tcl_GetCommandName(in, cmd), -1)); - return list; - } + /* search per-class filters */ + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->instfilters) { + if (CmdListFindCmdInList(cmd, opt->instfilters)) { + Tcl_ListObjAppendElement(interp, list, pl->cl->object.cmdName); + Tcl_ListObjAppendElement(interp, list, XOTclGlobalObjects[XOTE_INSTFILTER]); + Tcl_ListObjAppendElement(interp, list, + Tcl_NewStringObj(Tcl_GetCommandName(interp, cmd), -1)); + return list; + } + } } - } - return list; + return list; } /* * before we can perform a filter dispatch, FilterSearchProc seeks the * current filter and the relevant calling information */ static Tcl_Command -FilterSearchProc(Tcl_Interp *in, XOTclObject *obj, Tcl_ObjCmdProc **proc, ClientData* cp, - Tcl_Command* currentCmd, XOTclClass **cl) { - XOTclCmdList *cmdList; +FilterSearchProc(Tcl_Interp *interp, XOTclObject *obj, Tcl_ObjCmdProc **proc, ClientData *cp, + Tcl_Command *currentCmd, XOTclClass **cl) { + XOTclCmdList *cmdList; - assert(obj); - assert(obj->filterStack); + assert(obj); + assert(obj->filterStack); - *currentCmd = 0; - *proc = 0; - *cp = 0; + *currentCmd = 0; + *proc = 0; + *cp = 0; - FilterSeekCurrent(in, obj, &cmdList); - while (cmdList) { - if (Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { - cmdList = cmdList->next; - } else if (FilterActiveOnObj(in, obj, cmdList->cmdPtr)) { - /* fprintf(stderr, "Filter <%s> -- Active on: %s\n", - Tcl_GetCommandName(in, (Tcl_Command)cmdList->cmdPtr), ObjStr(obj->cmdName)); - */ - obj->filterStack->currentCmdPtr = cmdList->cmdPtr; - FilterSeekCurrent(in, obj, &cmdList); - } else { - /* ok. we' ve found it */ - *proc = Tcl_Command_objProc(cmdList->cmdPtr); - *cp = Tcl_Command_objClientData(cmdList->cmdPtr); - if (cmdList->clorobj && !XOTclObjectIsClass(&cmdList->clorobj->object)) { - *cl = NULL; - } else { - *cl = cmdList->clorobj; - } - *currentCmd = cmdList->cmdPtr; - /* fprintf(stderr, "FilterSearchProc - found: %s, %p\n", - Tcl_GetCommandName(in, (Tcl_Command)cmdList->cmdPtr), cmdList->cmdPtr); - */ - return cmdList->cmdPtr; + FilterSeekCurrent(interp, obj, &cmdList); + while (cmdList) { + if(Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { + cmdList = cmdList->nextPtr; + } else if (FilterActiveOnObj(interp, obj, cmdList->cmdPtr)) { + /* fprintf(stderr, "Filter <%s> -- Active on: %s\n", + Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr), ObjStr(obj->cmdName)); + */ + obj->filterStack->currentCmdPtr = cmdList->cmdPtr; + FilterSeekCurrent(interp, obj, &cmdList); + } else { + /* ok. we found it */ + *proc = Tcl_Command_objProc(cmdList->cmdPtr); + *cp = Tcl_Command_objClientData(cmdList->cmdPtr); + if (cmdList->clorobj && !XOTclObjectIsClass(&cmdList->clorobj->object)) { + *cl = NULL; + } else { + *cl = cmdList->clorobj; + } + *currentCmd = cmdList->cmdPtr; + /* fprintf(stderr, "FilterSearchProc - found: %s, %p\n", + Tcl_GetCommandName(interp, (Tcl_Command)cmdList->cmdPtr), cmdList->cmdPtr); + */ + return cmdList->cmdPtr; + } } - } - return 0; + return 0; } static int -SuperclassAdd(Tcl_Interp *in, XOTclClass *cl, int oc, Tcl_Obj **ov, Tcl_Obj *arg) { - XOTclClasses *filterCheck, *osl = 0; - XOTclClass **scl = 0; - int reversed = 0; - int i, j; +SuperclassAdd(Tcl_Interp *interp, XOTclClass *cl, int oc, Tcl_Obj **ov, Tcl_Obj *arg, XOTclClass *base) { + XOTclClasses *filterCheck, *osl = 0; + XOTclClass **scl = 0; + int reversed = 0; + int i, j; - filterCheck = ComputeOrder(cl, cl->order, Super); - /* - * we have to remove all dependent superclass filter referenced - * by class or one of its subclasses - * - * do not check the class "cl" itself (first entry in - * filterCheck class list) - */ - if (filterCheck) - filterCheck = filterCheck->next; - while (filterCheck) { - FilterRemoveDependentFilterCmds(cl, filterCheck->cl); - filterCheck = filterCheck->next; - } + filterCheck = ComputeOrder(cl, cl->order, Super); + /* + * we have to remove all dependent superclass filter referenced + * by class or one of its subclasses + * + * do not check the class "cl" itself (first entry in + * filterCheck class list) + */ + if (filterCheck) + filterCheck = filterCheck->nextPtr; + while (filterCheck) { + FilterRemoveDependentFilterCmds(cl, filterCheck->cl); + filterCheck = filterCheck->nextPtr; + } - /* invalidate all interceptors orders of instances of this - and of all depended classes */ - MixinInvalidateObjOrders(in, cl); - FilterInvalidateObjOrders(in, cl); + /* invalidate all interceptors orders of instances of this + and of all depended classes */ + MixinInvalidateObjOrders(interp, cl); + FilterInvalidateObjOrders(interp, cl); - scl = NEW_ARRAY(XOTclClass*,oc); - for (i = 0; i < oc; i++) { - if (GetXOTclClassFromObj(in, ov[i], &scl[i], 1) != TCL_OK) { - FREE(XOTclClass**, scl); - return XOTclErrBadVal(in, "superclass", "a list of classes", - ObjStr(arg)); + scl = NEW_ARRAY(XOTclClass*,oc); + for (i = 0; i < oc; i++) { + if (GetXOTclClassFromObj(interp, ov[i], &scl[i], base) != TCL_OK) { + FREE(XOTclClass**, scl); + return XOTclErrBadVal(interp, "superclass", "a list of classes", + ObjStr(arg)); + } } - } - /* - * check that superclasses don't precede their classes - */ + /* + * check that superclasses don't precede their classes + */ - for (i = 0; i < oc; i++) { - if (reversed != 0) break; - for (j = i+1; j < oc; j++) { - XOTclClasses* dl = ComputeOrder(scl[j], scl[j]->order, Super); - if (reversed != 0) break; - while (dl != 0) { - if (dl->cl == scl[i]) break; - dl = dl->next; - } - if (dl != 0) reversed = 1; + for (i = 0; i < oc; i++) { + if (reversed != 0) break; + for (j = i+1; j < oc; j++) { + XOTclClasses *dl = ComputeOrder(scl[j], scl[j]->order, Super); + if (reversed != 0) break; + while (dl != 0) { + if (dl->cl == scl[i]) break; + dl = dl->nextPtr; + } + if (dl != 0) reversed = 1; + } } - } - if (reversed != 0) { - return XOTclErrBadVal(in, "superclass", "classes in dependence order", - ObjStr(arg)); - } + if (reversed != 0) { + return XOTclErrBadVal(interp, "superclass", "classes in dependence order", + ObjStr(arg)); + } - while (cl->super != 0) { + while (cl->super != 0) { - /* - * build up an old superclass list in case we need to revert - */ + /* + * build up an old superclass list in case we need to revert + */ - XOTclClass *sc = cl->super->cl; - XOTclClasses* l = osl; - osl = NEW(XOTclClasses); - osl->cl = sc; - osl->next = l; - (void)RemoveSuper(cl, cl->super->cl); - } - for (i = 0; i < oc; i++) - AddSuper(cl, scl[i]); - FREE(XOTclClass**,scl); - FlushPrecedences(cl); + XOTclClass *sc = cl->super->cl; + XOTclClasses *l = osl; + osl = NEW(XOTclClasses); + osl->cl = sc; + osl->nextPtr = l; + (void)RemoveSuper(cl, cl->super->cl); + } + for (i = 0; i < oc; i++) + AddSuper(cl, scl[i]); + FREE(XOTclClass**,scl); + FlushPrecedences(cl); - if (!ComputeOrder(cl, cl->order, Super)) { + if (!ComputeOrder(cl, cl->order, Super)) { - /* - * cycle in the superclass graph, backtrack - */ + /* + * cycle in the superclass graph, backtrack + */ - XOTclClasses* l; - while (cl->super != 0) (void)RemoveSuper(cl, cl->super->cl); - for (l = osl; l != 0; l = l->next) AddSuper(cl, l->cl); - XOTclFreeClasses(osl); - return XOTclErrBadVal(in, "superclass", "a cycle-free graph", ObjStr(arg)); - } - XOTclFreeClasses(osl); + XOTclClasses *l; + while (cl->super != 0) (void)RemoveSuper(cl, cl->super->cl); + for (l = osl; l != 0; l = l->nextPtr) AddSuper(cl, l->cl); + XOTclClassListFree(osl); + return XOTclErrBadVal(interp, "superclass", "a cycle-free graph", ObjStr(arg)); + } + XOTclClassListFree(osl); - /* if there are no more super classes add the Object - class as superclasses */ - if (cl->super == 0) - AddSuper(cl, RUNTIME_STATE(in)->theObject); + /* if there are no more super classes add the Object + class as superclasses */ + if (cl->super == 0) + AddSuper(cl, RUNTIME_STATE(interp)->theObject); - Tcl_ResetResult(in); - return TCL_OK; + Tcl_ResetResult(interp); + return TCL_OK; } +extern Tcl_Obj * +XOTcl_ObjSetVar2(XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2, + Tcl_Obj *value, int flgs) { + Tcl_Obj *result; + XOTcl_FrameDecls; + XOTcl_PushFrame(interp, (XOTclObject*)obj); + if (((XOTclObject*)obj)->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; -static int -varExists(Tcl_Interp *in, XOTclObject *obj, char *varName, char *index, - int triggerTrace, int requireDefined) { - XOTcl_FrameDecls; - Var *varPtr, *arrayPtr; - int result; - int flags; - - flags = (index == NULL) ? TCL_PARSE_PART1 : 0; - - if (obj->nsPtr) { - Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, - varResolver, (Tcl_ResolveCompiledVarProc*)NULL); - } + result = Tcl_ObjSetVar2(interp, name1, name2, value, flgs); + XOTcl_PopFrame(interp, (XOTclObject*)obj); + return result; +} - XOTcl_PushFrame(in, obj); +extern Tcl_Obj * +XOTcl_SetVar2Ex(XOTcl_Object *obj, Tcl_Interp *interp, CONST char *name1, CONST char *name2, + Tcl_Obj *value, int flgs) { + Tcl_Obj *result; + XOTcl_FrameDecls; -#if defined(PRE83) - varPtr = TclLookupVar(in, varName, index, flags, "access", - /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); -#else - if (triggerTrace) - varPtr = TclVarTraceExists(in, varName); - else - varPtr = TclLookupVar(in, varName, index, flags, "access", - /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); -#endif - result = ((varPtr != NULL) && - (!requireDefined || !TclIsVarUndefined(varPtr))); + XOTcl_PushFrame(interp, (XOTclObject*)obj); + if (((XOTclObject*)obj)->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; - XOTcl_PopFrame(in, obj); - - if (obj->nsPtr) { - Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, - (Tcl_ResolveVarProc *)NULL, - (Tcl_ResolveCompiledVarProc*)NULL); - } - return result; + result = Tcl_SetVar2Ex(interp, name1, name2, value, flgs); + XOTcl_PopFrame(interp, (XOTclObject*)obj); + return result; } -static void -getVarAndNameFromHash(Tcl_HashEntry *hPtr, Var **val, Tcl_Obj **varNameObj) { - *val = VarHashGetValue(hPtr); -#if defined(PRE85) -# if FORWARD_COMPATIBLE - if (forwardCompatibleMode) { - *varNameObj = VarHashGetKey(*val); - } else { - *varNameObj = Tcl_NewStringObj(Tcl_GetHashKey(hPtr->tablePtr, hPtr),-1); - } -# else - *varNameObj = Tcl_NewStringObj(Tcl_GetHashKey(hPtr->tablePtr, hPtr),-1); -# endif -#else - *varNameObj = VarHashGetKey(*val); -#endif + +Tcl_Obj * +XOTclOSetInstVar(XOTcl_Object *obj, Tcl_Interp *interp, + Tcl_Obj *name, Tcl_Obj *value, int flgs) { + return XOTcl_ObjSetVar2(obj, interp, name, (Tcl_Obj *)NULL, value, (flgs|TCL_PARSE_PART1)); } -/* - * Search default values specified through 'parameter' on one class - */ -static int -SearchDefaultValuesOnClass(Tcl_Interp *in, XOTclObject *obj, - XOTclClass *cmdCl, XOTclClass *targetClass) { - int result = TCL_OK; - Var *defaults, *initcmds; - Tcl_Namespace *ns = targetClass->object.nsPtr; - TclVarHashTable *varTable = ns ? Tcl_Namespace_varTable(ns) : targetClass->object.varTable; +extern Tcl_Obj * +XOTcl_ObjGetVar2(XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name1, Tcl_Obj *name2, + int flgs) { + Tcl_Obj *result; + XOTcl_FrameDecls; - defaults = LookupVarFromTable(varTable, "__defaults",(XOTclObject*)targetClass); - initcmds = LookupVarFromTable(varTable, "__initcmds",(XOTclObject*)targetClass); + XOTcl_PushFrame(interp, (XOTclObject*)obj); + if (((XOTclObject*)obj)->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; - if (defaults && TclIsVarArray(defaults)) { - TclVarHashTable *tablePtr = valueOfVar(TclVarHashTable,defaults,tablePtr); - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr = tablePtr ? Tcl_FirstHashEntry(VarHashTable(tablePtr), &hSrch) : 0; - - /*fprintf(stderr, "+++ we have defaults for %s in <%s>\n", - ObjStr(obj->cmdName),className(targetClass));*/ - - /* iterate over all elements of the defaults array */ - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - Var *val; - Tcl_Obj *varNameObj; + result = Tcl_ObjGetVar2(interp, name1, name2, flgs); + XOTcl_PopFrame(interp, (XOTclObject*)obj); - getVarAndNameFromHash(hPtr, &val, &varNameObj); - INCR_REF_COUNT(varNameObj); + return result; +} - if (TclIsVarScalar(val)) { - Tcl_Obj *oldValue = XOTclOGetInstVar2((XOTcl_Object*) obj, - in, varNameObj, NULL, - TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); - /** we check whether the variable is already set. - if so, we do not set it again */ - if (oldValue == NULL) { - Tcl_Obj *valueObj = valueOfVar(Tcl_Obj,val,objPtr); - char *value = ObjStr(valueObj), *v; - int doSubst = 0; - for (v=value; *v; v++) { - if (*v == '[' && doSubst == 0) - doSubst = 1; - else if ((doSubst == 1 && *v == ']') || *v == '$') { - doSubst = 2; - break; - } - } - if (doSubst == 2) { /* we have to subst */ - Tcl_Obj *ov[2]; - int rc = CallStackPush(in, obj, cmdCl, 0, 1, - &varNameObj, XOTCL_CSC_TYPE_PLAIN); - if (rc != TCL_OK) { - DECR_REF_COUNT(varNameObj); - return rc; - } - ov[1] = valueObj; - Tcl_ResetResult(in); - rc = XOTcl_SubstObjCmd(NULL, in, 2, ov); - CallStackPop(in); - if (rc == TCL_OK) { - valueObj = Tcl_GetObjResult(in); - } else { - DECR_REF_COUNT(varNameObj); - return rc; - } - } - /*fprintf(stderr,"calling %s value='%s'\n", - ObjStr(varNameObj),ObjStr(valueObj));*/ - INCR_REF_COUNT(valueObj); - result = XOTclCallMethodWithArgs((ClientData)obj, in, - varNameObj, valueObj, 1, 0, 0); - DECR_REF_COUNT(valueObj); - - if (result != TCL_OK) { - DECR_REF_COUNT(varNameObj); - return result; - } - } - } - DECR_REF_COUNT(varNameObj); - } - } - - if (initcmds && TclIsVarArray(initcmds)) { - TclVarHashTable *tablePtr = valueOfVar(TclVarHashTable,initcmds,tablePtr); - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr = tablePtr ? Tcl_FirstHashEntry(VarHashTable(tablePtr), &hSrch) : 0; +extern Tcl_Obj * +XOTcl_GetVar2Ex(XOTcl_Object *obj, Tcl_Interp *interp, CONST char *name1, CONST char *name2, + int flgs) { + Tcl_Obj *result; + XOTcl_FrameDecls; - /*fprintf(stderr, "+++ we have initcmds for <%s>\n", className(targetClass));*/ - /* iterate over the elements of initcmds */ - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - Var *val; - Tcl_Obj *varNameObj; + XOTcl_PushFrame(interp, (XOTclObject*)obj); + if (((XOTclObject*)obj)->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; - getVarAndNameFromHash(hPtr, &val, &varNameObj); + result = Tcl_GetVar2Ex(interp, name1, name2, flgs); + XOTcl_PopFrame(interp, (XOTclObject*)obj); + return result; +} - INCR_REF_COUNT(varNameObj); - /*fprintf(stderr,"varexists(%s->%s) = %d\n", - ObjStr(obj->cmdName), - ObjStr(varNameObj), varExists(in, obj, ObjStr(varNameObj), NULL, 0, 0));*/ - if (TclIsVarScalar(val) && - (!varExists(in, obj, ObjStr(varNameObj), NULL, 0, 0) || - varExists(in, &targetClass->object, "__defaults", ObjStr(varNameObj), 0,0) - )) { - Tcl_Obj *valueObj = valueOfVar(Tcl_Obj,val,objPtr); - char *string = ObjStr(valueObj); - int rc; - XOTcl_FrameDecls; - if (*string) { - XOTcl_PushFrame(in, obj); /* make instvars accessible */ - CallStackPush(in, obj, cmdCl, 0, 1, - &varNameObj, XOTCL_CSC_TYPE_PLAIN); /*allow to call self*/ - - /*fprintf(stderr,"evaluating '%s' obj=%s\n\n",ObjStr(valueObj),ObjStr(obj->cmdName)); - XOTclCallStackDump(in);*/ +Tcl_Obj * +XOTclOGetInstVar(XOTcl_Object *obj, Tcl_Interp *interp, Tcl_Obj *name, int flgs) { + return XOTcl_ObjGetVar2(obj, interp, name, (Tcl_Obj *)NULL, (flgs|TCL_PARSE_PART1)); +} - rc = Tcl_EvalObjEx(in, valueObj, TCL_EVAL_DIRECT); - CallStackPop(in); - XOTcl_PopFrame(in, obj); - if (rc != TCL_OK) { - DECR_REF_COUNT(varNameObj); - return rc; - } - /* fprintf(stderr,"... varexists(%s->%s) = %d\n", - ObjStr(obj->cmdName), - varName, varExists(in, obj, varName, NULL, 0, 0)); */ - } - } - DECR_REF_COUNT(varNameObj); - } - } - return result; +int +XOTclUnsetInstVar(XOTcl_Object *obj, Tcl_Interp *interp, char *name, int flgs) { + return XOTclUnsetInstVar2 (obj, interp, name,(char *)NULL, flgs); } -/* - * Search default values specified through 'parameter' on - * mixin and class hierarchy - */ -static int -SearchDefaultValues(Tcl_Interp *in, XOTclObject *obj, XOTclClass *cmdCl) { - XOTcl_FrameDecls; - XOTclClass *cl = obj->cl, *mixin; - XOTclClasses *pl = 0; - XOTclCmdList *ml = 0; - int result = TCL_OK; - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(in, obj); - if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) - ml = obj->mixinOrder; - assert(cl); +static int +varExists(Tcl_Interp *interp, XOTclObject *obj, CONST char *varName, char *index, + int triggerTrace, int requireDefined) { + XOTcl_FrameDecls; + Var *varPtr, *arrayPtr; + int result; + int flags; + + flags = (index == NULL) ? TCL_PARSE_PART1 : 0; + + if (obj->nsPtr) { + Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, + varResolver, (Tcl_ResolveCompiledVarProc*)NULL); + } - XOTcl_PushFrame(in, obj); + XOTcl_PushFrame(interp, obj); - while (ml) { - mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - result = SearchDefaultValuesOnClass(in, obj, cmdCl, mixin); - if (result != TCL_OK) - break; - ml = ml->next; - } +#if defined(PRE83) + varPtr = TclLookupVar(interp, varName, index, flags, "access", + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); +#else + if (triggerTrace) + varPtr = TclVarTraceExists(interp, varName); + else + varPtr = TclLookupVar(interp, varName, index, flags, "access", + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); +#endif + result = ((varPtr != NULL) && + (!requireDefined || !TclIsVarUndefined(varPtr))); - for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->next) { - result = SearchDefaultValuesOnClass(in, obj, cmdCl, pl->cl); - if (result != TCL_OK) - break; - } + XOTcl_PopFrame(interp, obj); - XOTcl_PopFrame(in,obj); - return result; + if (obj->nsPtr) { + Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, + (Tcl_ResolveVarProc *)NULL, + (Tcl_ResolveCompiledVarProc*)NULL); + } + return result; } static int -ParameterSearchDefaultsMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - XOTclObject *defaultObj; +evalValueIfNeeded(Tcl_Interp *interp, XOTclObject *obj, CONST char *varName, Tcl_Obj **newValue) { + int rc = TCL_OK; + int doSubst = 0; + char *value = ObjStr(*newValue), *v; + /*fprintf(stderr,"+++++ %s.%s got '%s''\n", ObjStr(obj->cmdName),varName,ObjStr(newValue));*/ - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc != 2) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "searchDefaults obj"); - if (XOTclObjConvertObject(in, objv[1], &defaultObj) != TCL_OK) - return XOTclVarErrMsg(in, "Can't find default object ", - ObjStr(objv[1]), (char *) NULL); + /* TODO: maybe we can do this more elegantely without the need to parse the vars */ + for (v=value; *v; v++) { + if (*v == '[' && doSubst == 0) + doSubst = 1; + else if ((doSubst == 1 && *v == ']') || *v == '$') { + doSubst = 2; + break; + } + } + + if (doSubst == 2) { /* we have to subst, we overwrite newValue */ + Tcl_Obj *ov[2]; + ov[1] = *newValue; + Tcl_ResetResult(interp); - /* - * Search for default values for vars on superclasses - */ - return SearchDefaultValues(in, defaultObj, defaultObj->cl); + CallStackPush(interp, obj, NULL, 0, 0, 0, XOTCL_CSC_TYPE_PLAIN); + rc = XOTcl_SubstObjCmd(NULL, interp, 2, ov); + CallStackPop(interp); + + /*fprintf(stderr,"+++++ %s.%s subst returned %d OK %d\n", + ObjStr(obj->cmdName),varName,rc, TCL_OK);*/ + + if (rc == TCL_OK) { + *newValue = Tcl_GetObjResult(interp); + } + } + return rc; } static int -callParameterMethodWithArg(XOTclObject *obj, Tcl_Interp *in, Tcl_Obj *method, - Tcl_Obj *arg, int objc, Tcl_Obj *CONST objv[], int flags) { - XOTclClassOpt* opt = obj->cl->opt; - Tcl_Obj *pcl = XOTclGlobalObjects[XOTE_PARAM_CL]; - XOTclClass *paramCl; - int result; +setDefaultValue(Tcl_Interp *interp, XOTclObject *obj, XOTclObject *slotObj) { + CONST char *varName = Tcl_GetCommandName(interp,slotObj->id); + Tcl_Obj *oldValue; + int rc = TCL_OK; - if (opt && opt->parameterClass) pcl = opt->parameterClass; + XOTcl_FrameDecls; + XOTcl_PushFrame(interp, obj); /* make instvars of obj accessible */ - if (GetXOTclClassFromObj(in,pcl,¶mCl, 1) == TCL_OK) { - result = XOTclCallMethodWithArgs((ClientData)paramCl, in, - method, arg, objc-2, objv, flags); - } - else - result = XOTclVarErrMsg(in, "create: can't find parameter class", - (char *) NULL); - return result; + /* + * caller did a XOTcl_PushFrame(interp, obj), + * so we have the instvars already accessible; + */ + oldValue = Tcl_GetVar2Ex(interp, varName, NULL, + TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + + /* Check whether the variable is already set. + * If yes, we do not set it again. + */ + if (oldValue == NULL) { + Tcl_Obj *newValue = XOTcl_GetVar2Ex((XOTcl_Object*)slotObj,interp, "default", NULL, + TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + /*fprintf(stderr,"+++++ %s.%s undefined'\n", ObjStr(obj->cmdName),varName);*/ + if (newValue) { + rc = evalValueIfNeeded(interp, obj, varName, &newValue); + if (rc != TCL_OK) { + goto leavesetdefaultvalue; + } + + /* + * just set the variable, checking is happening later + */ + /*fprintf(stderr,"+++++ %s.%s := '%s'\n", ObjStr(obj->cmdName), varName, ObjStr(newValue));*/ + + Tcl_SetVar2Ex(interp, varName, NULL, newValue, + TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + + } else { + /*fprintf(stderr, "----- we have no new value %s\n", varName);*/ + } + /* + * we set the initCmd for the time being unconditionally, if it is available + */ + { + /* try to get initcmd + */ + Tcl_Obj *initCmd = XOTcl_GetVar2Ex((XOTcl_Object*)slotObj,interp, "initcmd", NULL, + TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + if (initCmd) { + char *cmd = ObjStr(initCmd); + /*fprintf(stderr, "----- we have an initcmd %s\n", cmd);*/ + if (*cmd) { + CallStackPush(interp, obj, NULL, 0, 0, + 0, XOTCL_CSC_TYPE_PLAIN); /*allow to call self*/ + + /*fprintf(stderr,"!!!! evaluating '%s'\n",cmd); */ + rc = Tcl_EvalObjEx(interp, initCmd, TCL_EVAL_DIRECT); + CallStackPop(interp); + + if (rc != TCL_OK) { + goto leavesetdefaultvalue; + } + } + } + } + } else { + /* fprintf(stderr, "+++ value for %s.%s already set\n", ObjStr(obj->cmdName),varName);*/ + } + leavesetdefaultvalue: + XOTcl_PopFrame(interp,obj); + return rc; } +static int +checkRequiredValue(Tcl_Interp *interp, XOTclObject *obj, XOTclObject *slotObj) { + CONST char *varName = Tcl_GetCommandName(interp,slotObj->id); + int rc = TCL_OK, bool; + Tcl_Obj *requiredFlag = XOTcl_GetVar2Ex((XOTcl_Object*)slotObj,interp, "required", NULL, + TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); + if (requiredFlag) { + rc = Tcl_GetBooleanFromObj(interp, requiredFlag, &bool); + if (rc == TCL_OK && bool) { + /*fprintf(stderr,"+++++ %s.%s must check'\n", ObjStr(obj->cmdName),varName);*/ + if (!varExists(interp, obj, varName, NULL, 0, 1)) { + return XOTclVarErrMsg(interp, + "required parameter '", varName, "' missing", + (char *) NULL); + } + } + } + return rc; +} +static void +getVarAndNameFromHash(Tcl_HashEntry *hPtr, Var **val, Tcl_Obj **varNameObj) { + *val = VarHashGetValue(hPtr); +#if defined(PRE85) +# if FORWARD_COMPATIBLE + if (forwardCompatibleMode) { + *varNameObj = VarHashGetKey(*val); + } else { + *varNameObj = Tcl_NewStringObj(Tcl_GetHashKey(hPtr->tablePtr, hPtr),-1); + } +# else + *varNameObj = Tcl_NewStringObj(Tcl_GetHashKey(hPtr->tablePtr, hPtr),-1); +# endif +#else + *varNameObj = VarHashGetKey(*val); +#endif +} + /* * method dispatch */ /* actually call a method (with assertion checking) */ static int -callProcCheck(ClientData cp, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[], +callProcCheck(ClientData cp, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], Tcl_Command cmd, XOTclObject *obj, XOTclClass *cl, char *methodName, int frameType, int isTclProc) { - int result = TCL_OK; - XOTclRuntimeState *rst = RUNTIME_STATE(in); - CheckOptions co; + int result = TCL_OK; + XOTclRuntimeState *rst = RUNTIME_STATE(interp); + CheckOptions co; #if defined(PROFILE) - long int startUsec, startSec; - struct timeval trt; + long int startUsec, startSec; + struct timeval trt; - gettimeofday(&trt, NULL); - startSec = trt.tv_sec; - startUsec = trt.tv_usec; + gettimeofday(&trt, NULL); + startSec = trt.tv_sec; + startUsec = trt.tv_usec; #endif - assert(obj); + assert(obj); - rst->callIsDestroy = 0; - /*fprintf(stderr,"callProcCheck: setting callIsDestroy = 0, m=%s obj=%p (%s)\n", - methodName, obj, ObjStr(obj->cmdName));*/ - - /* - fprintf(stderr,"*** callProcCheck: cmd = %p\n",cmd); - fprintf(stderr, - "cp=%p, isTclProc=%d %p %s, dispatch=%d %p, forward=%d %p, scoped %p, ov[0]=%p oc=%d\n", - cp, - isTclProc, cmd, - Tcl_GetCommandName(in, cmd), - Tcl_Command_objProc(cmd) == XOTclObjDispatch, XOTclObjDispatch, - Tcl_Command_objProc(cmd) == XOTclForwardMethod, XOTclForwardMethod, - XOTclObjscopedMethod, - objv[0], objc - );*/ + rst->callIsDestroy = 0; + /*fprintf(stderr,"callProcCheck: setting callIsDestroy = 0, m=%s obj=%p (%s)\n", + methodName, obj, ObjStr(obj->cmdName));*/ + /*fprintf(stderr,"*** callProcCheck: cmd = %p objproc = %p\n",cmd, Tcl_Command_objProc(cmd)); + fprintf(stderr, + "cp=%p, isTclProc=%d %p %s, dispatch=%d %p, forward=%d %p, scoped %p, ov[0]=%p oc=%d\n", + cp, + isTclProc, cmd, + Tcl_GetCommandName(interp, cmd), + Tcl_Command_objProc(cmd) == XOTclObjDispatch, XOTclObjDispatch, + Tcl_Command_objProc(cmd) == XOTclForwardMethod, XOTclForwardMethod, + XOTclObjscopedMethod, + objv[0], objc + ); + {int i; fprintf(stderr, "\tCALL ");for(i=0; iteardown) { - co = 0; - if (obj->opt) co = obj->opt->checkoptions; - if ((co & CHECK_INVAR) && - ((result = AssertionCheckInvars(in, obj, methodName, co)) == TCL_ERROR)) { - goto finish; - } + if (!isTclProc && obj->teardown) { + co = 0; + if (obj->opt) co = obj->opt->checkoptions; + if ((co & CHECK_INVAR) && + ((result = AssertionCheckInvars(interp, obj, methodName, co)) == TCL_ERROR)) { + goto finish; + } #ifdef DISPATCH_TRACE - printCall(in,"callProcCheck cmd", objc,objv); - /*fprintf(stderr,"\tproc=%s\n",Tcl_GetCommandName(in,cmd));*/ + printCall(interp,"callProcCheck cmd", objc,objv); + /*fprintf(stderr,"\tproc=%s\n",Tcl_GetCommandName(interp,cmd));*/ #endif - result = (*Tcl_Command_objProc(cmd))(cp, in, objc, objv); - + result = (*Tcl_Command_objProc(cmd))(cp, interp, objc, objv); + #ifdef DISPATCH_TRACE - printExit(in,"callProcCheck cmd", objc,objv, result); - /*fprintf(stderr, " returnCode %d xotcl rc %d\n", - Tcl_Interp_returnCode(in), rst->returnCode);*/ + printExit(interp,"callProcCheck cmd", objc,objv, result); + /*fprintf(stderr, " returnCode %d xotcl rc %d\n", + Tcl_Interp_returnCode(interp), rst->returnCode);*/ #endif - /* - if (obj && obj->teardown && cl && !(obj->flags & XOTCL_DESTROY_CALLED)) { - fprintf(stderr, "Obj= %s ", ObjStr(obj->cmdName)); - fprintf(stderr, "CL= %s ", ObjStr(cl->object.cmdName)); - fprintf(stderr, "method=%s\n", methodName); - } - */ - co = 0; - if (!rst->callIsDestroy && obj->opt) co = obj->opt->checkoptions; - if ((co & CHECK_INVAR) && - ((result = AssertionCheckInvars(in, obj, methodName,co)) == TCL_ERROR)) { - goto finish; - } - } else { - /* isTclProc == 1 - * if this is a filter, check whether its guard applies, - * if not: just step forward to the next filter - */ - if (frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { - XOTclCmdList *cmdList; - /* - * seek cmd in obj's filterOrder - */ - assert(obj->flags & XOTCL_FILTER_ORDER_VALID); - /* otherwise: FilterComputeDefined(in, obj);*/ + /* + if (obj && obj->teardown && cl && !(obj->flags & XOTCL_DESTROY_CALLED)) { + fprintf(stderr, "Obj= %s ", ObjStr(obj->cmdName)); + fprintf(stderr, "CL= %s ", ObjStr(cl->object.cmdName)); + fprintf(stderr, "method=%s\n", methodName); + } + */ + co = 0; + if (!rst->callIsDestroy && obj->opt) co = obj->opt->checkoptions; + if ((co & CHECK_INVAR) && + ((result = AssertionCheckInvars(interp, obj, methodName,co)) == TCL_ERROR)) { + goto finish; + } + } else { + /* isTclProc == 1 + * if this is a filter, check whether its guard applies, + * if not: just step forward to the next filter + */ + if (frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + XOTclCmdList *cmdList; + /* + * seek cmd in obj's filterOrder + */ + assert(obj->flags & XOTCL_FILTER_ORDER_VALID); + /* otherwise: FilterComputeDefined(interp, obj);*/ - cmdList = obj->filterOrder; - while (cmdList && cmdList->cmdPtr != cmd) - cmdList = cmdList->next; + cmdList = obj->filterOrder; + while (cmdList && cmdList->cmdPtr != cmd) + cmdList = cmdList->nextPtr; - /* - * when it is found, check whether it has a filter guard - */ - if (cmdList) { - int rc = GuardCall(obj, cl, (Tcl_Command) cmdList->cmdPtr, in, - cmdList->clientData, 0); - if (rc != TCL_OK) { - if (rc != TCL_ERROR) { - /* - * call next, use the given objv's, not the callstack objv - * we may not be in a method, thus there may be wrong or - * no callstackobjs - */ - /*fprintf(stderr, "... calling nextmethod\n"); XOTclCallStackDump(in);*/ + /* + * when it is found, check whether it has a filter guard + */ + if (cmdList) { + int rc = GuardCall(obj, cl, (Tcl_Command) cmdList->cmdPtr, interp, + (Tcl_Obj*)cmdList->clientData, 0); + if (rc != TCL_OK) { + if (rc != TCL_ERROR) { + /* + * call next, use the given objv's, not the callstack objv + * we may not be in a method, thus there may be wrong or + * no callstackobjs + */ + /*fprintf(stderr, "... calling nextmethod\n"); XOTclCallStackDump(interp);*/ - rc = XOTclNextMethod(obj, in, cl, methodName, - objc, objv, /*useCallStackObjs*/ 0); - /*fprintf(stderr, "... after nextmethod\n"); - XOTclCallStackDump(in);*/ + rc = XOTclNextMethod(obj, interp, cl, methodName, + objc, objv, /*useCallStackObjs*/ 0); + /*fprintf(stderr, "... after nextmethod\n"); + XOTclCallStackDump(interp);*/ - } + } - return rc; - } - } - } + return rc; + } + } + } - if (!rst->callIsDestroy && obj->teardown - && !(obj->flags & XOTCL_DESTROY_CALLED)) { - if (obj->opt && - (obj->opt->checkoptions & CHECK_PRE) && - (result = AssertionCheck(in, obj, cl, methodName, CHECK_PRE)) == TCL_ERROR) { - goto finish; - } - } + if (!rst->callIsDestroy && obj->teardown + && !(obj->flags & XOTCL_DESTROY_CALLED)) { + if (obj->opt && + (obj->opt->checkoptions & CHECK_PRE) && + (result = AssertionCheck(interp, obj, cl, methodName, CHECK_PRE)) == TCL_ERROR) { + goto finish; + } + } - if (Tcl_Interp_numLevels(in) <= 2) - rst->returnCode = TCL_OK; + if (Tcl_Interp_numLevels(interp) <= 2) + rst->returnCode = TCL_OK; #ifdef DISPATCH_TRACE - printCall(in,"callProcCheck tclCmd", objc,objv); - fprintf(stderr,"\tproc=%s\n",Tcl_GetCommandName(in,cmd)); + printCall(interp,"callProcCheck tclCmd", objc,objv); + fprintf(stderr,"\tproc=%s\n",Tcl_GetCommandName(interp,cmd)); #endif - result = (*Tcl_Command_objProc(cmd))(cp, in, objc, objv); + result = (*Tcl_Command_objProc(cmd))(cp, interp, objc, objv); #ifdef DISPATCH_TRACE - printExit(in,"callProcCheck tclCmd", objc,objv, result); - /* fprintf(stderr, " returnCode %d xotcl rc %d\n", - Tcl_Interp_returnCode(in), rst->returnCode);*/ + printExit(interp,"callProcCheck tclCmd", objc,objv, result); + /* fprintf(stderr, " returnCode %d xotcl rc %d\n", + Tcl_Interp_returnCode(interp), rst->returnCode);*/ #endif - /*if (Tcl_Interp_numLevels(in) <= 2 && rst->returnCode == TCL_BREAK) - result = TCL_BREAK; - else*/ if (result == TCL_BREAK && rst->returnCode == TCL_OK) - rst->returnCode = result; + if (result == TCL_BREAK && rst->returnCode == TCL_OK) { + rst->returnCode = result; + } + + /* fprintf(stderr, "dispatch returned %d rst = %d\n",result,rst->returnCode);*/ - /* we give the information whether the call has destroyed the - object back to the caller, because after CallStackPop it - cannot be retrieved via the call stack */ - /* if the object is destroyed -> the assertion structs's are already - destroyed */ - if (rst->cs.top->callType & XOTCL_CSC_CALL_IS_DESTROY) { - rst->callIsDestroy = 1; - /*fprintf(stderr,"callProcCheck: setting callIsDestroy = 1\n");*/ - } + /* we give the information whether the call has destroyed the + object back to the caller, because after CallStackPop it + cannot be retrieved via the call stack */ + /* if the object is destroyed -> the assertion structs's are already + destroyed */ + if (rst->cs.top->callType & XOTCL_CSC_CALL_IS_DESTROY) { + rst->callIsDestroy = 1; + /*fprintf(stderr,"callProcCheck: setting callIsDestroy = 1 method = %s\n", + methodName);*/ + } - if (obj->opt && !rst->callIsDestroy && obj->teardown && - (obj->opt->checkoptions & CHECK_POST) && - (result = AssertionCheck(in, obj, cl, methodName, CHECK_POST) == TCL_ERROR)) { - goto finish; + if (obj->opt && !rst->callIsDestroy && obj->teardown && + (obj->opt->checkoptions & CHECK_POST) && + (result = AssertionCheck(interp, obj, cl, methodName, CHECK_POST) == TCL_ERROR)) { + goto finish; + } } - } finish: #if defined(PROFILE) - if (rst->callIsDestroy == 0) { - XOTclProfileEvaluateData(in, startSec, startUsec, obj, cl, methodName); - } + if (rst->callIsDestroy == 0) { + XOTclProfileEvaluateData(interp, startSec, startUsec, obj, cl, methodName); + } #endif - - return result; + return result; } static int -DoCallProcCheck(ClientData cp, ClientData cd, Tcl_Interp *in, +DoCallProcCheck(ClientData cp, ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], Tcl_Command cmd, XOTclObject *obj, XOTclClass *cl, char *methodName, - int frameType, int fromNext) { - int rc, push = 1, isTclProc = 0; + int frameType, int fromNext, int forcePush) { + int rc, push = 1, isTclProc = 0; - if (cp) { - Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); - if (proc == XOTclObjDispatch) { - assert((TclIsProc((Command *)cmd) == NULL)); - } else if (proc == XOTclForwardMethod || - proc == XOTclObjscopedMethod) { - tclCmdClientData *tcd = (tclCmdClientData *)cp; - tcd->obj = obj; - assert((TclIsProc((Command *)cmd) == NULL)); - } else if (cp == XOTCL_NONLEAF_METHOD) { - cp = cd; - assert((TclIsProc((Command *)cmd) == NULL)); + /*fprintf(stderr,"DoCallProcCheck %s cp %p cmd %p proc %p\n",methodName,cp,cmd,Tcl_Command_objProc(cmd));*/ + if (Tcl_Command_flags(cmd) & XOTCL_NONLEAF_METHOD) { + cp = clientData; + } else if (cp) { + Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); + if (proc == XOTclObjDispatch) { + assert((TclIsProc((Command *)cmd) == NULL)); + /*fprintf(stderr,"\t ObjDispatch\n");*/ + } else if (proc == XOTclForwardMethod || + proc == XOTclObjscopedMethod) { + tclCmdClientData *tcd = (tclCmdClientData *)cp; + tcd->obj = obj; + assert((TclIsProc((Command *)cmd) == NULL)); + /*fprintf(stderr,"\t forwarder\n");*/ + } else { + /*fprintf(stderr,"\t isproc\n");*/ + assert((TclIsProc((Command *)cmd) != NULL)); + isTclProc = 1; + } } else { - assert((TclIsProc((Command *)cmd) != NULL)); - isTclProc = 1; + push = forcePush; + assert((TclIsProc((Command *)cmd) == NULL)); + cp = clientData; } - } else { - push = 0; - assert((TclIsProc((Command *)cmd) == NULL)); - cp = cd; - } - if (!fromNext) { - objc--; - objv++; - } + if (!fromNext) { + objc--; + objv++; + } - if (push) { - /* push the xotcl info */ - if ((CallStackPush(in, obj, cl, cmd, objc, objv, frameType)) != TCL_OK) - return TCL_ERROR; - } - rc = callProcCheck(cp, in, objc, objv, cmd, obj, cl, - methodName, frameType, isTclProc); - if (push) { - CallStackPop(in); - } + /*fprintf(stderr,"DoCallProcCheck push=%d (%d), obj=%s fromNext %d\n", + push, forcePush, ObjStr(obj->cmdName), fromNext);*/ - return rc; + if (push) { + /* push the xotcl info */ + if ((CallStackPush(interp, obj, cl, cmd, objc, objv, frameType)) != TCL_OK) + return TCL_ERROR; + } + + /*{int i; fprintf(stderr, "\tCALL ");for(i=0; icmdName; - XOTclCallStack *cs = &rst->cs; - /*int isdestroy = (objv[1] == XOTclGlobalObjects[XOTE_DESTROY]); */ + char *methodName, *callMethod; + XOTclClass *cl = 0; + ClientData cp = 0; + Tcl_ObjCmdProc *proc = 0; + Tcl_Command cmd = 0; + XOTclRuntimeState *rst = RUNTIME_STATE(interp); + Tcl_Obj *cmdName = obj->cmdName; + XOTclCallStack *cs = &rst->cs; #ifdef AUTOVARS - int isNext; + int isNext; #endif - assert(objc>0); - methodName = ObjStr(objv[1]); + assert(objc>0); + methodName = ObjStr(objv[1]); + /*fprintf(stderr,"DoDispatch obj = %s objc = %d 0=%s\n", + ObjStr(obj->cmdName), objc, ObjStr(objv[0]));*/ + #ifdef AUTOVARS - isNext = isNextString(methodName); + isNext = isNextString(methodName); #endif #ifdef DISPATCH_TRACE - printCall(in,"DISPATCH", objc,objv); + printCall(interp,"DISPATCH", objc,objv); #endif #ifdef OBJDELETION_TRACE - method = objv[1]; - if (method == XOTclGlobalObjects[XOTE_CLEANUP] || - method == XOTclGlobalObjects[XOTE_DESTROY]) { - fprintf(stderr, "%s->%s id=%p destroyCalled=%d\n", - ObjStr(cmdName), methodName, obj, - (obj->flags & XOTCL_DESTROY_CALLED)); - } + method = objv[1]; + if (method == XOTclGlobalObjects[XOTE_CLEANUP] || + method == XOTclGlobalObjects[XOTE_DESTROY]) { + fprintf(stderr, "%s->%s id=%p destroyCalled=%d\n", + ObjStr(cmdName), methodName, obj, + (obj->flags & XOTCL_DESTROY_CALLED)); + } #endif - objflags = obj->flags; /* avoid stalling */ - INCR_REF_COUNT(cmdName); + objflags = obj->flags; /* avoid stalling */ + INCR_REF_COUNT(cmdName); - if (!(objflags & XOTCL_FILTER_ORDER_VALID)) - FilterComputeDefined(in, obj); + if (!(objflags & XOTCL_FILTER_ORDER_VALID)) + FilterComputeDefined(interp, obj); - if (!(objflags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(in, obj); + if (!(objflags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); - callMethod = methodName; + callMethod = methodName; #ifdef AUTOVARS - if (!isNext) { + if(!isNext) { #endif - /* Only start new filter chain, if - (a) filters are defined and - (b) the toplevel csc entry is not an filter on self - */ - if (RUNTIME_STATE(in)->doFilters && - !(flags & XOTCL_CM_NO_FILTERS) && !cs->guardCount && - ((obj->flags & XOTCL_FILTER_ORDER_DEFINED_AND_VALID) == - XOTCL_FILTER_ORDER_DEFINED_AND_VALID)) { - XOTclObject *self = GetSelfObj(in); - if (obj != self || - cs->top->frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER) { + /* Only start new filter chain, if + (a) filters are defined and + (b) the toplevel csc entry is not an filter on self + */ + if (RUNTIME_STATE(interp)->doFilters && + !(flags & XOTCL_CM_NO_FILTERS) && !cs->guardCount && + ((obj->flags & XOTCL_FILTER_ORDER_DEFINED_AND_VALID) == + XOTCL_FILTER_ORDER_DEFINED_AND_VALID)) { + XOTclObject *self = GetSelfObj(interp); + if (obj != self || + cs->top->frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER) { - filterStackPushed = FilterStackPush(in, obj, objv[1]); - cmd = FilterSearchProc(in, obj, &proc, &cp, - &obj->filterStack->currentCmdPtr,&cl); - if (cmd) { /* 'proc' and the other output vars are set as well */ - frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; - callMethod = (char *)Tcl_GetCommandName(in, cmd); - } else { - FilterStackPop(obj); - filterStackPushed = 0; - } - } - } + filterStackPushed = FilterStackPush(interp, obj, objv[1]); + cmd = FilterSearchProc(interp, obj, &proc, &cp, + &obj->filterStack->currentCmdPtr, &cl); + /*fprintf(stderr,"filterSearchProc returned cmd %p proc %p\n", cmd,proc);*/ + if (cmd) { /* 'proc' and the other output vars are set as well */ + frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; + callMethod = (char *) Tcl_GetCommandName(interp, cmd); + } else { + FilterStackPop(obj); + filterStackPushed = 0; + } + } + } - /* check if a mixin is to be called. - don't use mixins on next method calls, since normally it is not - intercepted (it is used as a primitive command). - don't use mixins on init calls, since init is invoked on mixins - during mixin registration (in XOTclOMixinMethod) - */ + /* check if a mixin is to be called. + don't use mixins on next method calls, since normally it is not + intercepted (it is used as a primitive command). + don't use mixins on init calls, since init is invoked on mixins + during mixin registration (in XOTclOMixinMethod) + */ - if ((obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) == - XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + if ((obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) == + XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - mixinStackPushed = MixinStackPush(obj); + mixinStackPushed = MixinStackPush(obj); - if (frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER) { - cmd = MixinSearchProc(in, obj, methodName, &cl, &proc, &cp, - &obj->mixinStack->currentCmdPtr); - if (cmd) { /* 'proc' and the other output vars are set as well */ - frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; - } else { /* the else branch could be deleted */ - MixinStackPop(obj); - mixinStackPushed = 0; - } - } - } + if (frameType != XOTCL_CSC_TYPE_ACTIVE_FILTER) { + cmd = MixinSearchProc(interp, obj, methodName, &cl, &proc, &cp, + &obj->mixinStack->currentCmdPtr); + if (cmd) { /* 'proc' and the other output vars are set as well */ + frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; + } else { /* the else branch could be deleted */ + MixinStackPop(obj); + mixinStackPushed = 0; + } + } + } #ifdef AUTOVARS } #endif /* if no filter/mixin is found => do ordinary method lookup */ if (proc == 0) { - /* - fprintf(stderr,"ordinary lookup for obj %p method %s nsPtr %p\n", - obj, methodName, obj->nsPtr);*/ - /*if (obj->nsPtr && !(obj->flags & XOTCL_NS_DESTROYED))*/ - if (obj->nsPtr) - cmd = FindMethod(methodName, obj->nsPtr); - /*fprintf(stderr,"findMethod for proc '%s' in %p returned %p\n",methodName, obj->nsPtr, cmd);*/ - if (cmd == NULL) - cl = SearchCMethod(obj->cl, methodName, &cmd); + /*fprintf(stderr,"ordinary lookup for obj %p method %s nsPtr %p\n", + obj, methodName, obj->nsPtr);*/ - if (cmd) { - proc = Tcl_Command_objProc(cmd); - cp = Tcl_Command_objClientData(cmd); - } else { - assert(cp == 0); - } + /*if (obj->nsPtr && !(obj->flags & XOTCL_NS_DESTROYED))*/ + if (obj->nsPtr) + cmd = FindMethod(methodName, obj->nsPtr); + /*fprintf(stderr,"findMethod for proc '%s' in %p returned %p\n",methodName, obj->nsPtr, cmd);*/ + + if (cmd == NULL) + cl = SearchCMethod(obj->cl, methodName, &cmd); + + if (cmd) { + proc = Tcl_Command_objProc(cmd); + cp = Tcl_Command_objClientData(cmd); + } else { + assert(cp == 0); + } } if (proc) { - result = TCL_OK; - if ((result = DoCallProcCheck(cp, cd, in, objc, objv, cmd, obj, cl, - callMethod, frameType, 0 /* fromNext */)) == TCL_ERROR) { - result = XOTclErrInProc(in, cmdName, cl ? cl->object.cmdName : NULL, callMethod); - } - unknown = RUNTIME_STATE(in)->unknown; + result = TCL_OK; + + /*fprintf(stderr,"cmd %p %s flags %x\n",cmd, methodName, + ((Command *) cmd)->flags && 0x00010000);*/ + + if ((Tcl_Command_flags(cmd) & XOTCL_PROTECTED_METHOD) && + (flags & XOTCL_CM_NO_UNKNOWN) == 0) { + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + XOTclObject *o = NULL; + XOTclObjConvertObject(interp, objv[0], &o); + /*XOTclCallStackDump(interp);*/ + /*fprintf(stderr,"+++ %s is protected, therefore maybe unknown %p %s self=%p o=%p\n", + methodName, objv[0], ObjStr(objv[0]), + csc->self, o);*/ + if (o != csc->self) { + /*fprintf(stderr,"+++ protected method %s is not invoked\n",methodName);*/ + unknown = 1; + } + } + if (!unknown) { + /*fprintf(stderr,"DoDispatch calls DoCallProcCheck with obj = %s frameType %d\n", + ObjStr(obj->cmdName), frameType);*/ + if ((result = DoCallProcCheck(cp, clientData, interp, objc, objv, cmd, obj, cl, + callMethod, frameType, + 0 /* fromNext */, 0)) == TCL_ERROR) { + result = XOTclErrInProc(interp, cmdName, + cl ? cl->object.cmdName : NULL, + callMethod); + } + unknown = RUNTIME_STATE(interp)->unknown; + } } else { - unknown = 1; + unknown = 1; } if (result == TCL_OK) { - /*fprintf(stderr,"after doCallProcCheck unknown == %d\n",unknown);*/ - if (unknown) { + /* fprintf(stderr,"after doCallProcCheck %s unknown == %d\n", methodName, unknown);*/ + if (unknown) { - if (XOTclObjectIsClass(obj) && (flags & XOTCL_CM_NO_UNKNOWN)) { - return XOTclVarErrMsg(in, ObjStr(objv[0]), - ": unable to dispatch method '", - callMethod, "'", (char *) NULL); - } else if (objv[1] != XOTclGlobalObjects[XOTE_UNKNOWN]) { - /* - * back off and try unknown; - */ - XOTclObject *obj = (XOTclObject*)cd; - ALLOC_ON_STACK(Tcl_Obj*,objc+1, tov); - /* - fprintf(stderr,"calling unknown for %s %s, flgs=%02x,%02x isClass=%d %p %s\n", - ObjStr(obj->cmdName), ObjStr(objv[1]), flags, XOTCL_CM_NO_UNKNOWN, - XOTclObjectIsClass(obj), obj, ObjStr(obj->cmdName)); - */ - tov[0] = obj->cmdName; - tov[1] = XOTclGlobalObjects[XOTE_UNKNOWN]; - if (objc>1) - memcpy(tov+2, objv+1, sizeof(Tcl_Obj *)*(objc-1)); - /* - fprintf(stderr,"?? %s unknown %s\n",ObjStr(obj->cmdName), ObjStr(tov[2])); - */ - result = DoDispatch(cd, in, objc+1, tov, flags | XOTCL_CM_NO_UNKNOWN); - FREE_ON_STACK(tov); + if (XOTclObjectIsClass(obj) && (flags & XOTCL_CM_NO_UNKNOWN)) { + return XOTclVarErrMsg(interp, ObjStr(objv[0]), + ": unable to dispatch method '", + callMethod, "'", (char *) NULL); + } else if (objv[1] != XOTclGlobalObjects[XOTE_UNKNOWN]) { + /* + * back off and try unknown; + */ + XOTclObject *obj = (XOTclObject*)clientData; + ALLOC_ON_STACK(Tcl_Obj *,objc+1, tov); + /* + fprintf(stderr,"calling unknown for %s %s, flgs=%02x,%02x isClass=%d %p %s\n", + ObjStr(obj->cmdName), ObjStr(objv[1]), flags, XOTCL_CM_NO_UNKNOWN, + XOTclObjectIsClass(obj), obj, ObjStr(obj->cmdName)); + */ + tov[0] = obj->cmdName; + tov[1] = XOTclGlobalObjects[XOTE_UNKNOWN]; + if (objc>1) + memcpy(tov+2, objv+1, sizeof(Tcl_Obj *)*(objc-1)); + /* + fprintf(stderr,"?? %s unknown %s\n",ObjStr(obj->cmdName), ObjStr(tov[2])); + */ + result = DoDispatch(clientData, interp, objc+1, tov, flags | XOTCL_CM_NO_UNKNOWN); + FREE_ON_STACK(tov); - } else { /* unknown failed */ - return XOTclVarErrMsg(in, ObjStr(objv[0]), - ": unable to dispatch method '", - ObjStr(objv[2]), "'", (char *) NULL); - } + } else { /* unknown failed */ + /*fprintf(stderr,"unknown fails\n");*/ + return XOTclVarErrMsg(interp, ObjStr(objv[0]), + ": unable to dispatch method '", + ObjStr(objv[2]), "'", (char *) NULL); + } - } + } } /* be sure to reset unknown flag */ if (unknown) - RUNTIME_STATE(in)->unknown = 0; + RUNTIME_STATE(interp)->unknown = 0; #ifdef DISPATCH_TRACE - printExit(in,"DISPATCH", objc,objv, result); + printExit(interp,"DISPATCH", objc,objv, result); fprintf(stderr,"obj %p mixinStackPushed %d mixinStack %p\n", obj, mixinStackPushed, obj->mixinStack); #endif /*if (!rst->callIsDestroy ) - fprintf(stderr, "obj freed? %p destroy %p self %p %s %d [%d] reference=%d,%d\n",obj, - cs->top->destroyedCmd, cs->top->self, ObjStr(objv[1]), - rst->callIsDestroy, - cs->top->callType & XOTCL_CSC_CALL_IS_DESTROY, - !rst->callIsDestroy, - isdestroy);*/ + fprintf(stderr, "obj freed? %p destroy %p self %p %s %d [%d] reference=%d,%d\n",obj, + cs->top->destroyedCmd, cs->top->self, ObjStr(objv[1]), + rst->callIsDestroy, + cs->top->callType & XOTCL_CSC_CALL_IS_DESTROY, + !rst->callIsDestroy, + isdestroy);*/ if (!rst->callIsDestroy) { - /*!(obj->flags & XOTCL_DESTROY_CALLED)) {*/ - if (mixinStackPushed && obj->mixinStack) - MixinStackPop(obj); + /*!(obj->flags & XOTCL_DESTROY_CALLED)) {*/ + if (mixinStackPushed && obj->mixinStack) + MixinStackPop(obj); - if (filterStackPushed && obj->filterStack) - FilterStackPop(obj); + if (filterStackPushed && obj->filterStack) + FilterStackPop(obj); } DECR_REF_COUNT(cmdName); /* must be after last dereferencing of obj */ return result; } static int -ObjDispatch(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[], +ObjDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags) { - int result; + int result; #ifdef STACK_TRACE - XOTclStackDump(in); + XOTclStackDump(interp); #endif #ifdef CALLSTACK_TRACE - XOTclCallStackDump(in); + XOTclCallStackDump(interp); #endif - if (objc == 1) { - Tcl_Obj *tov[2]; - tov[0] = objv[0]; - tov[1] = XOTclGlobalObjects[XOTE_DEFAULTMETHOD]; - result = DoDispatch(cd, in, 2, tov, flags); - } else { - /* normal dispatch */ - result = DoDispatch(cd, in, objc, objv, flags); - } + if (objc == 1) { + Tcl_Obj *tov[2]; + tov[0] = objv[0]; + tov[1] = XOTclGlobalObjects[XOTE_DEFAULTMETHOD]; + result = DoDispatch(clientData, interp, 2, tov, flags); + } else { + /* normal dispatch */ + result = DoDispatch(clientData, interp, objc, objv, flags); + } - return result; + return result; } #ifdef XOTCL_BYTECODE int -XOTclDirectSelfDispatch(ClientData cd, Tcl_Interp *in, +XOTclDirectSelfDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - int result; + int result; #ifdef XOTCLOBJ_TRACE - XOTclObject *obj; + XOTclObject *obj; #endif - objTrace("BEFORE SELF DISPATCH", obj); - result = ObjDispatch((ClientData)GetSelfObj(in), in, objc, objv, 0); - objTrace("AFTER SELF DISPATCH", obj); - return result; + objTrace("BEFORE SELF DISPATCH", obj); + result = ObjDispatch((ClientData)GetSelfObj(interp), interp, objc, objv, 0); + objTrace("AFTER SELF DISPATCH", obj); + return result; } #endif int -XOTclObjDispatch(ClientData cd, Tcl_Interp *in, +XOTclObjDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - return ObjDispatch(cd, in, objc, objv, 0); + return ObjDispatch(clientData, interp, objc, objv, 0); } /* * Non Positional Args */ static void -NonposArgsDeleteHashEntry(Tcl_HashEntry* hPtr) { - XOTclNonposArgs* nonposArg = (XOTclNonposArgs*) Tcl_GetHashValue(hPtr); - if (nonposArg) { - DECR_REF_COUNT(nonposArg->nonposArgs); - DECR_REF_COUNT(nonposArg->ordinaryArgs); - MEM_COUNT_FREE("nonposArg",nonposArg); - ckfree((char *) nonposArg); - Tcl_DeleteHashEntry(hPtr); - } +NonposArgsDeleteHashEntry(Tcl_HashEntry *hPtr) { + XOTclNonposArgs *nonposArg = (XOTclNonposArgs*) Tcl_GetHashValue(hPtr); + if (nonposArg) { + if (nonposArg->nonposArgs) { + DECR_REF_COUNT(nonposArg->nonposArgs); + } + if (nonposArg->ordinaryArgs) { + DECR_REF_COUNT(nonposArg->ordinaryArgs); + } + if (nonposArg->slotObj) { + DECR_REF_COUNT(nonposArg->slotObj); + } + MEM_COUNT_FREE("nonposArg",nonposArg); + ckfree((char *) nonposArg); + Tcl_DeleteHashEntry(hPtr); + } } static Tcl_HashTable* NonposArgsCreateTable() { - Tcl_HashTable* nonposArgsTable = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - MEM_COUNT_ALLOC("Tcl_HashTable",nonposArgsTable); - Tcl_InitHashTable(nonposArgsTable, TCL_STRING_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable",nonposArgsTable); - return nonposArgsTable; + Tcl_HashTable *nonposArgsTable = + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + MEM_COUNT_ALLOC("Tcl_HashTable",nonposArgsTable); + Tcl_InitHashTable(nonposArgsTable, TCL_STRING_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable",nonposArgsTable); + return nonposArgsTable; } static void -NonposArgsFreeTable(Tcl_HashTable* nonposArgsTable) { - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr = nonposArgsTable ? - Tcl_FirstHashEntry(nonposArgsTable, &hSrch) : 0; - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - NonposArgsDeleteHashEntry(hPtr); - } +NonposArgsFreeTable(Tcl_HashTable *nonposArgsTable) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = nonposArgsTable ? + Tcl_FirstHashEntry(nonposArgsTable, &hSrch) : 0; + for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { + NonposArgsDeleteHashEntry(hPtr); + } } static XOTclNonposArgs* -NonposArgsGet(Tcl_HashTable* nonposArgsTable, char * methodName) { - Tcl_HashEntry* hPtr; - if (nonposArgsTable && - ((hPtr = Tcl_FindHashEntry(nonposArgsTable, methodName)))) { - return (XOTclNonposArgs*) Tcl_GetHashValue(hPtr); - } - return NULL; +NonposArgsGet(Tcl_HashTable *nonposArgsTable, char *methodName) { + Tcl_HashEntry *hPtr; + if (nonposArgsTable && + ((hPtr = Tcl_FindHashEntry(nonposArgsTable, methodName)))) { + return (XOTclNonposArgs*) Tcl_GetHashValue(hPtr); + } + return NULL; } -static Tcl_Obj* -NonposArgsFormat(Tcl_Interp *in, Tcl_Obj* nonposArgsData) { - int r1, npalistc, npac, checkc, i, j, first; - Tcl_Obj **npalistv, **npav, **checkv, - *list = Tcl_NewListObj(0, NULL), *innerlist, - *nameStringObj; +static Tcl_Obj * +NonposArgsFormat(Tcl_Interp *interp, Tcl_Obj *nonposArgsData) { + int r1, npalistc, npac, checkc, i, j, first; + Tcl_Obj **npalistv, **npav, **checkv, + *list = Tcl_NewListObj(0, NULL), *innerlist, + *nameStringObj; - /*fprintf(stderr, "nonposargsformat '%s'\n", ObjStr(nonposArgsData));*/ + /*fprintf(stderr, "nonposargsformat '%s'\n", ObjStr(nonposArgsData));*/ - r1 = Tcl_ListObjGetElements(in, nonposArgsData, &npalistc, &npalistv); - if (r1 == TCL_OK) { - for (i=0; i < npalistc; i++) { - r1 = Tcl_ListObjGetElements(in, npalistv[i], &npac, &npav); - if (r1 == TCL_OK) { - nameStringObj = Tcl_NewStringObj("-", 1); - Tcl_AppendStringsToObj(nameStringObj, ObjStr(npav[0]), - (char *) NULL); - if (npac > 1 && *(ObjStr(npav[1])) != '\0') { - first = 1; - r1 = Tcl_ListObjGetElements(in, npav[1], &checkc, &checkv); - if (r1 == TCL_OK) { - for (j=0; j < checkc; j++) { - if (first) { - Tcl_AppendToObj(nameStringObj,":",1); - first = 0; - } else { - Tcl_AppendToObj(nameStringObj,",",1); - } - Tcl_AppendToObj(nameStringObj, ObjStr(checkv[j]), -1); - } - } - } - /* fprintf(stderr, "nonposargsformat namestring '%s'\n", - ObjStr(nameStringObj));*/ - + if (nonposArgsData) { + r1 = Tcl_ListObjGetElements(interp, nonposArgsData, &npalistc, &npalistv); + if (r1 == TCL_OK) { + for (i=0; i < npalistc; i++) { + r1 = Tcl_ListObjGetElements(interp, npalistv[i], &npac, &npav); + if (r1 == TCL_OK) { + nameStringObj = Tcl_NewStringObj("-", 1); + Tcl_AppendStringsToObj(nameStringObj, ObjStr(npav[0]), (char *) NULL); + if (npac > 1 && *(ObjStr(npav[1])) != '\0') { + first = 1; + r1 = Tcl_ListObjGetElements(interp, npav[1], &checkc, &checkv); + if (r1 == TCL_OK) { + for (j=0; j < checkc; j++) { + if (first) { + Tcl_AppendToObj(nameStringObj,":",1); + first = 0; + } else { + Tcl_AppendToObj(nameStringObj,",",1); + } + Tcl_AppendToObj(nameStringObj, ObjStr(checkv[j]), -1); + } + } + } + /* fprintf(stderr, "nonposargsformat namestring '%s'\n", + ObjStr(nameStringObj));*/ + #if 1 - innerlist = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(in, innerlist, nameStringObj); - if (npac > 2) { - Tcl_ListObjAppendElement(in, innerlist, npav[2]); - } + innerlist = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, innerlist, nameStringObj); + if (npac > 2) { + Tcl_ListObjAppendElement(interp, innerlist, npav[2]); + } #else - { - Tcl_DString ds, *dsPtr = &ds; - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, ObjStr(nameStringObj), -1); - if (npac > 2) { - Tcl_DStringAppendElement(dsPtr, ObjStr(npav[2])); - } - innerlist = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), - Tcl_DStringLength(dsPtr)); - DSTRING_FREE(dsPtr); - } + { + Tcl_DString ds, *dsPtr = &ds; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, ObjStr(nameStringObj), -1); + if (npac > 2) { + Tcl_DStringAppendElement(dsPtr, ObjStr(npav[2])); + } + innerlist = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), + Tcl_DStringLength(dsPtr)); + DSTRING_FREE(dsPtr); + } #endif - Tcl_ListObjAppendElement(in, list, innerlist); - } + Tcl_ListObjAppendElement(interp, list, innerlist); + } + } + } } - } - return list; + return list; } /* * Proc-Creation */ -static Tcl_Obj* addPrefixToBody(Tcl_Obj *body, int nonposArgs) { - Tcl_Obj* resultBody; - resultBody = Tcl_NewStringObj("", 0); - INCR_REF_COUNT(resultBody); - Tcl_AppendStringsToObj(resultBody, "::xotcl::initProcNS\n", (char *) NULL); - if (nonposArgs) { - Tcl_AppendStringsToObj(resultBody, - "::xotcl::interpretNonpositionalArgs $args\n", - (char *) NULL); - } - Tcl_AppendStringsToObj(resultBody, ObjStr(body), (char *) NULL); - return resultBody; +static Tcl_Obj *addPrefixToBody(Tcl_Obj *body, int nonposArgs) { + Tcl_Obj *resultBody; + resultBody = Tcl_NewStringObj("", 0); + INCR_REF_COUNT(resultBody); + Tcl_AppendStringsToObj(resultBody, "::xotcl::initProcNS\n", (char *) NULL); + if (nonposArgs) { + Tcl_AppendStringsToObj(resultBody, + "::xotcl::interpretNonpositionalArgs $args\n", + (char *) NULL); + } + Tcl_AppendStringsToObj(resultBody, ObjStr(body), (char *) NULL); + return resultBody; } +static Tcl_Obj* +nonposargType(char *start, int len) { + Tcl_Obj *result = Tcl_NewStringObj("type=", 5); + Tcl_AppendToObj(result, start, len); + fprintf(stderr, "TYPE = '%s'\n",ObjStr(result)); + return result; +} + static int -parseNonposArgs(Tcl_Interp *in, +parseNonposArgs(Tcl_Interp *interp, char *procName, Tcl_Obj *npArgs, Tcl_Obj *ordinaryArgs, Tcl_HashTable **nonposArgsTable, int *haveNonposArgs) { - int rc, nonposArgsDefc, npac; - Tcl_Obj **nonposArgsDefv; + int rc, nonposArgsDefc, npac; + Tcl_Obj **nonposArgsDefv; - rc = Tcl_ListObjGetElements(in, npArgs, &nonposArgsDefc, &nonposArgsDefv); - if (rc != TCL_OK) { - return XOTclVarErrMsg(in, "cannot break down non-positional args: ", - ObjStr(npArgs), (char *) NULL); - } - if (nonposArgsDefc > 0) { - int start, end, length, i, j, nw = 0; - char *arg; - Tcl_Obj *npaObj, **npav, *nonposArgsObj = Tcl_NewListObj(0, NULL); - Tcl_HashEntry *hPtr; + rc = Tcl_ListObjGetElements(interp, npArgs, &nonposArgsDefc, &nonposArgsDefv); + if (rc != TCL_OK) { + return XOTclVarErrMsg(interp, "cannot break down non-positional args: ", + ObjStr(npArgs), (char *) NULL); + } + if (nonposArgsDefc > 0) { + int start, end, length, i, j, nw = 0; + char *arg; + Tcl_Obj *npaObj, **npav, *nonposArgsObj = Tcl_NewListObj(0, NULL); + Tcl_HashEntry *hPtr; - INCR_REF_COUNT(nonposArgsObj); - for (i=0; i < nonposArgsDefc; i++) { - rc = Tcl_ListObjGetElements(in, nonposArgsDefv[i], &npac, &npav); - if (rc == TCL_ERROR || npac < 1 || npac > 2) { - DECR_REF_COUNT(nonposArgsObj); - return XOTclVarErrMsg(in, "wrong # of elements in non-positional args ", - "(should be 1 or 2 list elements): ", - ObjStr(npArgs), (char *) NULL); - } - npaObj = Tcl_NewListObj(0, NULL); - arg = ObjStr(npav[0]); - if (arg[0] != '-') { - DECR_REF_COUNT(npaObj); - DECR_REF_COUNT(nonposArgsObj); - return XOTclVarErrMsg(in, "non-positional args does not start with '-': ", - arg, " in: ", ObjStr(npArgs), (char *) NULL); - } + INCR_REF_COUNT(nonposArgsObj); + for (i=0; i < nonposArgsDefc; i++) { + rc = Tcl_ListObjGetElements(interp, nonposArgsDefv[i], &npac, &npav); + if (rc == TCL_ERROR || npac < 1 || npac > 2) { + DECR_REF_COUNT(nonposArgsObj); + return XOTclVarErrMsg(interp, "wrong # of elements in non-positional args ", + "(should be 1 or 2 list elements): ", + ObjStr(npArgs), (char *) NULL); + } + npaObj = Tcl_NewListObj(0, NULL); + arg = ObjStr(npav[0]); + if (arg[0] != '-') { + DECR_REF_COUNT(npaObj); + DECR_REF_COUNT(nonposArgsObj); + return XOTclVarErrMsg(interp, "non-positional args does not start with '-': ", + arg, " in: ", ObjStr(npArgs), (char *) NULL); + } - length = strlen(arg); - for (j=0; j0 && isspace((int)arg[end-1]); end--); - Tcl_ListObjAppendElement(in, list, - Tcl_NewStringObj(arg+start, end-start)); - l++; - start = l; - while(start0 && isspace((int)arg[end-1]); end--); - Tcl_ListObjAppendElement(in, list, - Tcl_NewStringObj(arg+start, end-start)); + start = j+1; + while(start0 && isspace((int)arg[end-1]); end--); - /* append the whole thing to the list */ - Tcl_ListObjAppendElement(in, npaObj, list); - } else { - Tcl_ListObjAppendElement(in, npaObj, Tcl_NewStringObj(arg+1, length)); - Tcl_ListObjAppendElement(in, npaObj, Tcl_NewStringObj("", 0)); - } - if (npac == 2) { - Tcl_ListObjAppendElement(in, npaObj, npav[1]); - } - Tcl_ListObjAppendElement(in, nonposArgsObj, npaObj); - *haveNonposArgs = 1; - } + Tcl_ListObjAppendElement(interp, list, + nonposargType(arg+start, end-start)); + l++; + start = l; + while(start0 && isspace((int)arg[end-1]); end--); + Tcl_ListObjAppendElement(interp, list, + nonposargType(arg+start, end-start)); + /* append the whole thing to the list */ + Tcl_ListObjAppendElement(interp, npaObj, list); + /* fprintf(stderr," appending list npa='%s'\n",ObjStr(npaObj));*/ + } else { + Tcl_ListObjAppendElement(interp, npaObj, Tcl_NewStringObj(arg+1, length)); + Tcl_ListObjAppendElement(interp, npaObj, Tcl_NewStringObj("", 0)); + /* fprintf(stderr," no colon npa='%s'\n",ObjStr(npaObj));*/ + } + if (npac == 2) { + Tcl_ListObjAppendElement(interp, npaObj, npav[1]); + /* fprintf(stderr," npac==2 ='%s'\n",ObjStr(npaObj)); */ + } + Tcl_ListObjAppendElement(interp, nonposArgsObj, npaObj); + *haveNonposArgs = 1; + } - if (*haveNonposArgs) { - XOTclNonposArgs* nonposArg; + if (*haveNonposArgs) { + XOTclNonposArgs *nonposArg; - if (*nonposArgsTable == 0) { - *nonposArgsTable = NonposArgsCreateTable(); - } + if (*nonposArgsTable == 0) { + *nonposArgsTable = NonposArgsCreateTable(); + } - hPtr = Tcl_CreateHashEntry(*nonposArgsTable, procName, &nw); - assert(nw); + hPtr = Tcl_CreateHashEntry(*nonposArgsTable, procName, &nw); + assert(nw); - MEM_COUNT_ALLOC("nonposArg",nonposArg); - nonposArg = (XOTclNonposArgs*)ckalloc(sizeof(XOTclNonposArgs)); - nonposArg->nonposArgs = nonposArgsObj; - nonposArg->ordinaryArgs = ordinaryArgs; - INCR_REF_COUNT(ordinaryArgs); - Tcl_SetHashValue(hPtr, (ClientData)nonposArg); - } else { - /* for strange reasons, we did not find nonpos-args, although we - have definitions */ - DECR_REF_COUNT(nonposArgsObj); + MEM_COUNT_ALLOC("nonposArg",nonposArg); + nonposArg = (XOTclNonposArgs*)ckalloc(sizeof(XOTclNonposArgs)); + nonposArg->slotObj = NULL; + nonposArg->nonposArgs = nonposArgsObj; + { /* FIX AND REMOVE ME */ + int i,r2, ordinaryArgsDefc; + Tcl_Obj **ordinaryArgsDefv; + + r2 = Tcl_ListObjGetElements(interp, ordinaryArgs, + &ordinaryArgsDefc, &ordinaryArgsDefv); + if (r2 == TCL_OK) { + Tcl_Obj *objv[ordinaryArgsDefc]; + for (i=0; i< ordinaryArgsDefc; i++) { + objv[i] = Tcl_DuplicateObj(ordinaryArgsDefv[i]); + } + nonposArg->ordinaryArgs = Tcl_NewListObj(ordinaryArgsDefc,objv); + INCR_REF_COUNT(nonposArg->ordinaryArgs); + } else { + fprintf(stderr, "could not split ordinaryArgs\n"); + } + } + Tcl_SetHashValue(hPtr, (ClientData)nonposArg); + } else { + /* for strange reasons, we did not find nonpos-args, although we + have definitions */ + DECR_REF_COUNT(nonposArgsObj); + } } - } - return TCL_OK; + return TCL_OK; } static int MakeProc(Tcl_Namespace *ns, XOTclAssertionStore *aStore, Tcl_HashTable **nonposArgsTable, - Tcl_Interp *in, int objc, Tcl_Obj *objv[], XOTclObject *obj) { - int result, incr, haveNonposArgs=0; - TclCallFrame frame, *framePtr = &frame; - Tcl_Obj *ov[4]; - Tcl_HashEntry* hPtr = NULL; - char *procName = ObjStr(objv[1]); + Tcl_Interp *interp, int objc, Tcl_Obj *objv[], XOTclObject *obj, int clsns) { + int result, incr, haveNonposArgs=0; + TclCallFrame frame, *framePtr = &frame; + Tcl_Obj *ov[4]; + Tcl_HashEntry *hPtr = NULL; + char *procName = ObjStr(objv[1]); - if (*nonposArgsTable && (hPtr = Tcl_FindHashEntry(*nonposArgsTable, procName))) { - NonposArgsDeleteHashEntry(hPtr); - } + if (*nonposArgsTable && (hPtr = Tcl_FindHashEntry(*nonposArgsTable, procName))) { + NonposArgsDeleteHashEntry(hPtr); + } - ov[0] = objv[0]; - ov[1] = objv[1]; + ov[0] = objv[0]; + ov[1] = objv[1]; - if (objc == 5 || objc == 7) { - if ((result = parseNonposArgs(in, procName, objv[2], objv[3], - nonposArgsTable, &haveNonposArgs)) != TCL_OK) - return result; + if (objc == 5 || objc == 7) { + if ((result = parseNonposArgs(interp, procName, objv[2], objv[3], + nonposArgsTable, &haveNonposArgs)) != TCL_OK) + return result; - if (haveNonposArgs) { - ov[2] = XOTclGlobalObjects[XOTE_ARGS]; - ov[3] = addPrefixToBody(objv[4], 1); - } else { /* no nonpos arguments */ - ov[2] = objv[3]; - ov[3] = addPrefixToBody(objv[4], 0); - } - } else { -#if !defined(XOTCL_DISJOINT_ARGLISTS) - int argsc, i; - Tcl_Obj **argsv; + if (haveNonposArgs) { + ov[2] = XOTclGlobalObjects[XOTE_ARGS]; + ov[3] = addPrefixToBody(objv[4], 1); + } else { /* no explicit nonpos arguments */ + ov[2] = objv[3]; + ov[3] = addPrefixToBody(objv[4], 0); + } + } else { + int argsc, i; + Tcl_Obj **argsv; - /* see, if we have nonposArgs in the ordinary argument list */ - result = Tcl_ListObjGetElements(in, objv[2], &argsc, &argsv); - if (result != TCL_OK) { - return XOTclVarErrMsg(in, "cannot break args into list: ", - ObjStr(objv[2]), (char *) NULL); - } - for (i=0; i 0) { - arg = ObjStr(npav[0]); - /* fprintf(stderr, "*** argparse1 arg='%s' rc=%d\n",arg,rc);*/ - if (*arg == '-') { - haveNonposArgs = 1; - continue; + /* see, if we have nonposArgs in the ordinary argument list */ + result = Tcl_ListObjGetElements(interp, objv[2], &argsc, &argsv); + if (result != TCL_OK) { + return XOTclVarErrMsg(interp, "cannot break args into list: ", + ObjStr(objv[2]), (char *) NULL); } - } - break; - } - if (haveNonposArgs) { - int nrOrdinaryArgs = argsc - i; - Tcl_Obj *ordinaryArgs = Tcl_NewListObj(nrOrdinaryArgs, &argsv[i]); - Tcl_Obj *nonposArgs = Tcl_NewListObj(i, &argsv[0]); - INCR_REF_COUNT(ordinaryArgs); - INCR_REF_COUNT(nonposArgs); - /* fprintf(stderr, "nonpos <%s> ordinary <%s>\n", - ObjStr(nonposArgs),ObjStr(ordinaryArgs));*/ - result = parseNonposArgs(in, procName, nonposArgs, ordinaryArgs, - nonposArgsTable, &haveNonposArgs); - DECR_REF_COUNT(ordinaryArgs); - DECR_REF_COUNT(nonposArgs); - if (result != TCL_OK) - return result; - } -#endif - if (haveNonposArgs) { - ov[2] = XOTclGlobalObjects[XOTE_ARGS]; - ov[3] = addPrefixToBody(objv[3], 1); - } else { /* no nonpos arguments */ - ov[2] = objv[2]; - ov[3] = addPrefixToBody(objv[3], 0); - } + for (i=0; i 0) { + arg = ObjStr(npav[0]); + /*fprintf(stderr, "*** argparse1 arg='%s' rc=%d\n",arg,rc);*/ + if (*arg == '-') { + haveNonposArgs = 1; + continue; + } + } + break; + } + if (haveNonposArgs) { + int nrOrdinaryArgs = argsc - i; + Tcl_Obj *ordinaryArgs = Tcl_NewListObj(nrOrdinaryArgs, &argsv[i]); + Tcl_Obj *nonposArgs = Tcl_NewListObj(i, &argsv[0]); + INCR_REF_COUNT(ordinaryArgs); + INCR_REF_COUNT(nonposArgs); + /*fprintf(stderr, "nonpos <%s> ordinary <%s>\n", + ObjStr(nonposArgs),ObjStr(ordinaryArgs));*/ + result = parseNonposArgs(interp, procName, nonposArgs, ordinaryArgs, + nonposArgsTable, &haveNonposArgs); + DECR_REF_COUNT(ordinaryArgs); + DECR_REF_COUNT(nonposArgs); + if (result != TCL_OK) + return result; + } + /**** end joined nonpos + pos argument list ***/ + + if (haveNonposArgs) { + ov[2] = XOTclGlobalObjects[XOTE_ARGS]; + ov[3] = addPrefixToBody(objv[3], 1); + } else { /* no nonpos arguments */ + ov[2] = objv[2]; + ov[3] = addPrefixToBody(objv[3], 0); + } + + } + #ifdef AUTOVARS - { char *p, *body; - body = ObjStr(ov[3]); - if ((p = strstr(body, "self")) && p != body && *(p-1) != '[') - Tcl_AppendStringsToObj(ov[3], "::set self [self]\n", (char *) NULL); - if (strstr(body, "proc")) - Tcl_AppendStringsToObj(ov[3], "::set proc [self proc]\n", (char *) NULL); - if (strstr(body, "class")) - Tcl_AppendStringsToObj(ov[3], "::set class [self class]\n", (char *) NULL); - } + { char *p, *body; + body = ObjStr(ov[3]); + if ((p = strstr(body, "self")) && p != body && *(p-1) != '[') + Tcl_AppendStringsToObj(ov[3], "::set self [self]\n", (char *) NULL); + if (strstr(body, "proc")) + Tcl_AppendStringsToObj(ov[3], "::set proc [self proc]\n", (char *) NULL); + if (strstr(body, "class")) + Tcl_AppendStringsToObj(ov[3], "::set class [self class]\n", (char *) NULL); + } #endif - Tcl_PushCallFrame(in,(Tcl_CallFrame *)framePtr,ns,0); + Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, ns, 0); - result = Tcl_ProcObjCmd(0, in, 4, ov) != TCL_OK; + result = Tcl_ProcObjCmd(0, interp, 4, ov) != TCL_OK; #if defined(NAMESPACEINSTPROCS) - { - Proc *procPtr = TclFindProc((Interp *)in, procName); - /*fprintf(stderr,"proc=%p cmd=%p ns='%s' objns=%s\n",procPtr,procPtr->cmdPtr, - procPtr->cmdPtr->nsPtr->fullName,cmd->nsPtr->fullName);*/ - /*** patch the command ****/ - if (procPtr) { - /* procPtr->cmdPtr = (Command *)obj->id; OLD*/ - procPtr->cmdPtr->nsPtr = ((Command *)obj->id)->nsPtr; + { + Proc *procPtr = TclFindProc((Interp *)interp, procName); + /* + fprintf(stderr,"proc=%p cmd=%p\n",procPtr,procPtr->cmdPtr); + fprintf(stderr,"proc=%p cmd=%p ns='%s' objns=%s clsns=%s\n",procPtr,procPtr->cmdPtr, + procPtr->cmdPtr->nsPtr->fullName,((Command*)obj->id)->nsPtr->fullName, + ((Command*)obj->cl->object.id)->nsPtr->fullName); + */ + /*** patch the command ****/ + if (procPtr) { + if (clsns) { + /* set the namespace of the method as inside of the class */ + if (!obj->nsPtr) { + makeObjNamespace(interp,obj); + } + /*fprintf(stderr,"obj %s\n", ObjStr(obj->cmdName)); + fprintf(stderr,"ns %p obj->ns %p\n", ns, obj->nsPtr); + fprintf(stderr,"ns %s obj->ns %s\n", ns->fullName, obj->nsPtr->fullName);*/ + procPtr->cmdPtr->nsPtr = (Namespace*) obj->nsPtr; + } else { + /* set the namespace of the method to the same namespace the class has */ + procPtr->cmdPtr->nsPtr = ((Command *)obj->id)->nsPtr; + } + } } - } #endif - Tcl_PopCallFrame(in); + Tcl_PopCallFrame(interp); - if (objc == 6 || objc == 7) { - incr = (objc == 6) ? 0:1; - AssertionAddProc(in, ObjStr(objv[1]), aStore, objv[4+incr], objv[5+incr]); - } + if (objc == 6 || objc == 7) { + incr = (objc == 6) ? 0:1; + AssertionAddProc(interp, ObjStr(objv[1]), aStore, objv[4+incr], objv[5+incr]); + } - DECR_REF_COUNT(ov[3]); + DECR_REF_COUNT(ov[3]); - return result; + return result; } /* * List-Functions for Info */ static int -ListInfo(Tcl_Interp *in, int isclass) { - Tcl_ResetResult(in); - Tcl_AppendElement(in, "vars"); Tcl_AppendElement(in, "body"); - Tcl_AppendElement(in, "default"); Tcl_AppendElement(in, "args"); - Tcl_AppendElement(in, "procs"); Tcl_AppendElement(in, "commands"); - Tcl_AppendElement(in, "class"); Tcl_AppendElement(in, "children"); - Tcl_AppendElement(in, "filter"); Tcl_AppendElement(in, "filterguard"); - Tcl_AppendElement(in, "forward"); - Tcl_AppendElement(in, "info"); - Tcl_AppendElement(in, "invar"); Tcl_AppendElement(in, "mixin"); - Tcl_AppendElement(in, "methods"); - Tcl_AppendElement(in, "parent"); - Tcl_AppendElement(in, "pre"); Tcl_AppendElement(in, "post"); - Tcl_AppendElement(in, "precedence"); - if (isclass) { - Tcl_AppendElement(in, "superclass"); Tcl_AppendElement(in, "subclass"); - Tcl_AppendElement(in, "heritage"); Tcl_AppendElement(in, "instances"); - Tcl_AppendElement(in, "instcommands"); Tcl_AppendElement(in, "instprocs"); - Tcl_AppendElement(in, "instdefault"); Tcl_AppendElement(in, "instbody"); - Tcl_AppendElement(in, "instmixin"); - Tcl_AppendElement(in, "instforward"); - Tcl_AppendElement(in, "classchildren"); Tcl_AppendElement(in, "classparent"); - Tcl_AppendElement(in, "instfilter"); Tcl_AppendElement(in, "instfilterguard"); - Tcl_AppendElement(in, "instinvar"); - Tcl_AppendElement(in, "instpre"); Tcl_AppendElement(in, "instpost"); - Tcl_AppendElement(in, "parameter"); - } - return TCL_OK; +ListInfo(Tcl_Interp *interp, int isclass) { + Tcl_ResetResult(interp); + Tcl_AppendElement(interp, "vars"); Tcl_AppendElement(interp, "body"); + Tcl_AppendElement(interp, "default"); Tcl_AppendElement(interp, "args"); + Tcl_AppendElement(interp, "procs"); Tcl_AppendElement(interp, "commands"); + Tcl_AppendElement(interp, "class"); Tcl_AppendElement(interp, "children"); + Tcl_AppendElement(interp, "filter"); Tcl_AppendElement(interp, "filterguard"); + Tcl_AppendElement(interp, "forward"); + Tcl_AppendElement(interp, "info"); + Tcl_AppendElement(interp, "invar"); Tcl_AppendElement(interp, "mixin"); + Tcl_AppendElement(interp, "methods"); + Tcl_AppendElement(interp, "parent"); + Tcl_AppendElement(interp, "pre"); Tcl_AppendElement(interp, "post"); + Tcl_AppendElement(interp, "precedence"); + if (isclass) { + Tcl_AppendElement(interp, "superclass"); Tcl_AppendElement(interp, "subclass"); + Tcl_AppendElement(interp, "heritage"); Tcl_AppendElement(interp, "instances"); + Tcl_AppendElement(interp, "instcommands"); Tcl_AppendElement(interp, "instprocs"); + Tcl_AppendElement(interp, "instdefault"); Tcl_AppendElement(interp, "instbody"); + Tcl_AppendElement(interp, "instmixin"); + Tcl_AppendElement(interp, "instforward"); + Tcl_AppendElement(interp, "classchildren"); Tcl_AppendElement(interp, "classparent"); + Tcl_AppendElement(interp, "instfilter"); Tcl_AppendElement(interp, "instfilterguard"); + Tcl_AppendElement(interp, "instinvar"); + Tcl_AppendElement(interp, "instpre"); Tcl_AppendElement(interp, "instpost"); + Tcl_AppendElement(interp, "parameter"); + } + return TCL_OK; } XOTCLINLINE static int noMetaChars(char *pattern) { - register char c, *p = pattern; - assert(pattern); - for (c=*p; c; c = *++p) { - if (c == '*' || c == '[') { - return 0; + register char c, *p = pattern; + assert(pattern); + for (c=*p; c; c = *++p) { + if (c == '*' || c == '?' || c == '[') { + return 0; + } } - } - return 1; + return 1; } static int -ListKeys(Tcl_Interp *in, Tcl_HashTable *table, char *pattern) { - Tcl_HashEntry* hPtr; - char *key; +ListKeys(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern) { + Tcl_HashEntry *hPtr; + char *key; - if (pattern && noMetaChars(pattern)) { - hPtr = table ? Tcl_FindHashEntry(table, pattern) : 0; - if (hPtr) { - key = Tcl_GetHashKey(table, hPtr); - Tcl_SetResult(in, key, TCL_VOLATILE); + if (pattern && noMetaChars(pattern)) { + hPtr = table ? Tcl_FindHashEntry(table, pattern) : 0; + if (hPtr) { + key = Tcl_GetHashKey(table, hPtr); + Tcl_SetResult(interp, key, TCL_VOLATILE); + } else { + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + } } else { - Tcl_SetObjResult(in, XOTclGlobalObjects[XOTE_EMPTY]); + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + Tcl_HashSearch hSrch; + hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + key = Tcl_GetHashKey(table, hPtr); + if (!pattern || Tcl_StringMatch(key, pattern)) { + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(key,-1)); + } + } + Tcl_SetObjResult(interp, list); } - } else { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - Tcl_HashSearch hSrch; - hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; - for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - key = Tcl_GetHashKey(table, hPtr); - if (!pattern || Tcl_StringMatch(key, pattern)) { - Tcl_ListObjAppendElement(in, list, Tcl_NewStringObj(key,-1)); - } - } - Tcl_SetObjResult(in, list); - } - return TCL_OK; + return TCL_OK; } #if !defined(PRE85) || FORWARD_COMPATIBLE static int -ListVarKeys(Tcl_Interp *in, Tcl_HashTable *tablePtr, char *pattern) { +ListVarKeys(Tcl_Interp *interp, Tcl_HashTable *tablePtr, char *pattern) { Tcl_HashEntry* hPtr; if (pattern && noMetaChars(pattern)) { @@ -5643,9 +5807,9 @@ hPtr = tablePtr ? Tcl_CreateHashEntry(tablePtr, (char *)patternObj, NULL) : 0; if (hPtr) { Var *val = VarHashGetValue(hPtr); - Tcl_SetObjResult(in, VarHashGetKey(val)); + Tcl_SetObjResult(interp, VarHashGetKey(val)); } else { - Tcl_SetObjResult(in, XOTclGlobalObjects[XOTE_EMPTY]); + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); } DECR_REF_COUNT(patternObj); } else { @@ -5656,491 +5820,534 @@ Var *val = VarHashGetValue(hPtr); Tcl_Obj *key = VarHashGetKey(val); if (!pattern || Tcl_StringMatch(ObjStr(key), pattern)) { - Tcl_ListObjAppendElement(in, list, key); + Tcl_ListObjAppendElement(interp, list, key); } } - Tcl_SetObjResult(in, list); + Tcl_SetObjResult(interp, list); } return TCL_OK; } #endif - static int -ListVars(Tcl_Interp *in, XOTclObject *obj, char *pattern) { - Tcl_Obj *varlist, *okList, *element; - int i, length; - TclVarHashTable *varTable = obj->nsPtr ? Tcl_Namespace_varTable(obj->nsPtr) : obj->varTable; - +ListVars(Tcl_Interp *interp, XOTclObject *obj, char *pattern) { + Tcl_Obj *varlist, *okList, *element; + int i, length; + TclVarHashTable *varTable = obj->nsPtr ? Tcl_Namespace_varTable(obj->nsPtr) : obj->varTable; + #if defined(PRE85) # if FORWARD_COMPATIBLE - if (forwardCompatibleMode) { - ListVarKeys(in, VarHashTable(varTable), pattern); - } else { - ListKeys(in, varTable, pattern); - } + if (forwardCompatibleMode) { + ListVarKeys(interp, VarHashTable(varTable), pattern); + } else { + ListKeys(interp, varTable, pattern); + } # else - ListKeys(in, varTable, pattern); + ListKeys(interp, varTable, pattern); # endif #else - ListVarKeys(in, VarHashTable(varTable), pattern); + ListVarKeys(interp, VarHashTable(varTable), pattern); #endif - varlist = Tcl_GetObjResult(in); + varlist = Tcl_GetObjResult(interp); - Tcl_ListObjLength(in, varlist, &length); - okList = Tcl_NewListObj(0, NULL); - for (i=0; icmdName); +ListObjPtrHashTable(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern) { + Tcl_HashEntry *hPtr; + if (pattern && noMetaChars(pattern)) { + XOTclObject *childobj = XOTclpGetObject(interp, pattern); + hPtr = Tcl_FindHashEntry(table, (char *)childobj); + if (hPtr) { + Tcl_SetObjResult(interp, childobj->cmdName); + } else { + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + } } else { - Tcl_SetObjResult(in, XOTclGlobalObjects[XOTE_EMPTY]); + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + Tcl_HashSearch hSrch; + hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; + for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *obj = (XOTclObject*)Tcl_GetHashKey(table, hPtr); + if (!pattern || Tcl_StringMatch(ObjStr(obj->cmdName), pattern)) { + Tcl_ListObjAppendElement(interp, list, obj->cmdName); + } + } + Tcl_SetObjResult(interp, list); } - } else { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - Tcl_HashSearch hSrch; - hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; - for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *obj = (XOTclObject*)Tcl_GetHashKey(table, hPtr); - if (!pattern || Tcl_StringMatch(ObjStr(obj->cmdName), pattern)) { - Tcl_ListObjAppendElement(in, list, obj->cmdName); - } - } - Tcl_SetObjResult(in, list); - } - return TCL_OK; + return TCL_OK; } static int -ListMethodKeys(Tcl_Interp *in, Tcl_HashTable *table, char *pattern, - int noProcs, int noCmds, int noDups, int onlyForwarder) { - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(table, hPtr); - Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - Tcl_ObjCmdProc* proc = Tcl_Command_objProc(cmd); +ListMethodKeys(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern, + int noProcs, int noCmds, Tcl_HashTable *dups, int onlyForwarder) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; - if (pattern && !Tcl_StringMatch(key, pattern)) continue; - if (noCmds && proc != RUNTIME_STATE(in)->objInterpProc) continue; - if (noProcs && proc == RUNTIME_STATE(in)->objInterpProc) continue; - if (onlyForwarder && proc != XOTclForwardMethod) continue; - /* XOTclObjscopedMethod ??? */ - if (noDups) { - int listc, i; - Tcl_Obj **listv; - int result = Tcl_ListObjGetElements(in, Tcl_GetObjResult(in), &listc, &listv); - size_t keylen = strlen(key); - if (result == TCL_OK) { - int found = 0; - for (i=0; iobjInterpProc) continue; + if (noProcs && proc == RUNTIME_STATE(interp)->objInterpProc) continue; + if (onlyForwarder && proc != XOTclForwardMethod) continue; + /* XOTclObjscopedMethod ??? */ + + if (dups) { + int new; + Tcl_HashEntry *duphPtr; + duphPtr = Tcl_CreateHashEntry(dups, key, &new); + if (!new) { + /*fprintf(stderr,"preexisting entry %s\n",key);*/ + continue; + } else { + /*fprintf(stderr,"new entry %s\n",key);*/ + } + } + + if (((Command *) cmd)->flags & XOTCL_PROTECTED_METHOD) { + /*fprintf(stderr, "--- dont list protected name '%s'\n",key);*/ + continue; + } + Tcl_AppendElement(interp, key); } - Tcl_AppendElement(in, key); - } - return TCL_OK; + /*fprintf(stderr, "listkeys returns '%s'\n", ObjStr(Tcl_GetObjResult(interp)));*/ + return TCL_OK; } static int -forwardList(Tcl_Interp *in, Tcl_HashTable *table, char *pattern, +forwardList(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern, int definition) { - int rc; - if (definition) { - Tcl_HashEntry* hPtr = table ? Tcl_FindHashEntry(table, pattern) : 0; - if (hPtr) { - Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - ClientData cd = cmd? Tcl_Command_objClientData(cmd) : NULL; - forwardCmdClientData *tcd = (forwardCmdClientData *)cd; - if (tcd) { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - if (tcd->prefix) { - Tcl_ListObjAppendElement(in, list, Tcl_NewStringObj("-methodprefix",-1)); - Tcl_ListObjAppendElement(in, list, tcd->prefix); - } - if (tcd->subcommands) { - Tcl_ListObjAppendElement(in, list, Tcl_NewStringObj("-default",-1)); - Tcl_ListObjAppendElement(in, list, tcd->subcommands); - } - if (tcd->objscope) { - Tcl_ListObjAppendElement(in, list, Tcl_NewStringObj("-objscope",-1)); - } - Tcl_ListObjAppendElement(in, list, tcd->cmdName); - if (tcd->args) { - Tcl_Obj **args; - int nrArgs, i; - Tcl_ListObjGetElements(in, tcd->args, &nrArgs, &args); - for (i=0; iprefix) { + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-methodprefix",-1)); + Tcl_ListObjAppendElement(interp, list, tcd->prefix); + } + if (tcd->subcommands) { + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-default",-1)); + Tcl_ListObjAppendElement(interp, list, tcd->subcommands); + } + if (tcd->objscope) { + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj("-objscope",-1)); + } + Tcl_ListObjAppendElement(interp, list, tcd->cmdName); + if (tcd->args) { + Tcl_Obj **args; + int nrArgs, i; + Tcl_ListObjGetElements(interp, tcd->args, &nrArgs, &args); + for (i=0; insPtr) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(obj->nsPtr); - ListMethodKeys(in, cmdTable, pattern, noProcs, noCmds, 0, 0); - } + XOTclClasses *pl; + Tcl_HashTable dupsTable, *dups = &dupsTable; + Tcl_InitHashTable(dups, TCL_STRING_KEYS); - if (!noMixins) { - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(in, obj); - if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *ml = obj->mixinOrder; - XOTclClass *mixin; - while (ml) { - int guardOk = TCL_OK; - mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (inContext) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - if (!cs->guardCount) { - guardOk = GuardCall(obj, 0, 0, in, ml->clientData, 1); - } - } - if (mixin && guardOk == TCL_OK) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(mixin->nsPtr); - ListMethodKeys(in, cmdTable, pattern, noProcs, noCmds, 1, 0); - } - ml = ml->next; - } + /*fprintf(stderr,"listMethods %s %d %d %d %d\n", pattern, noProcs, noCmds, noMixins, inContext);*/ + + if (obj->nsPtr) { + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(obj->nsPtr); + ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0); } - } - /* append per-class filters */ - for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->next) { - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(pl->cl->nsPtr); - ListMethodKeys(in, cmdTable, pattern, noProcs, noCmds, 1, 0); - } - return TCL_OK; + if (!noMixins) { + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); + if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *ml = obj->mixinOrder; + XOTclClass *mixin; + while (ml) { + int guardOk = TCL_OK; + mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (inContext) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + if (!cs->guardCount) { + guardOk = GuardCall(obj, 0, 0, interp, (Tcl_Obj*)ml->clientData, 1); + } + } + if (mixin && guardOk == TCL_OK) { + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(mixin->nsPtr); + ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0); + } + ml = ml->nextPtr; + } + } + } + + /* append per-class filters */ + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->nextPtr) { + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(pl->cl->nsPtr); + ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0); + } + Tcl_DeleteHashTable(dups); + return TCL_OK; } static int XOTclCInfoMethod(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST v[]); static int -ListClass(Tcl_Interp *in, XOTclObject *obj, char *pattern, +ListClass(Tcl_Interp *interp, XOTclObject *obj, char *pattern, int objc, Tcl_Obj *CONST objv[]) { - if (pattern == 0) { - Tcl_SetObjResult(in, obj->cl->object.cmdName); - return TCL_OK; - } else { - int result; - ALLOC_ON_STACK(Tcl_Obj*,objc, ov); + if (pattern == 0) { + Tcl_SetObjResult(interp, obj->cl->object.cmdName); + return TCL_OK; + } else { + int result; + ALLOC_ON_STACK(Tcl_Obj *,objc, ov); - memcpy(ov, objv, sizeof(Tcl_Obj *)*objc); - ov[1] = Tcl_NewStringObj("superclass", 10); - INCR_REF_COUNT(ov[1]); - result = XOTclCInfoMethod((ClientData)obj->cl, in, objc, ov); - DECR_REF_COUNT(ov[1]); - FREE_ON_STACK(ov); - return result; - } + memcpy(ov, objv, sizeof(Tcl_Obj *)*objc); + ov[1] = Tcl_NewStringObj("superclass", 10); + INCR_REF_COUNT(ov[1]); + result = XOTclCInfoMethod((ClientData)obj->cl, interp, objc, ov); + DECR_REF_COUNT(ov[1]); + FREE_ON_STACK(ov); + return result; + } } static int -ListSuperclasses(Tcl_Interp *in, XOTclClass *cl, char *pattern) { - if (pattern == 0) { - XOTclClasses* sl = cl->super; - XOTclClasses* sc = 0; +ListSuperclasses(Tcl_Interp *interp, XOTclClass *cl, char *pattern) { + XOTclClasses *sl = cl->super; + XOTclClasses *sc = 0; - /* - * reverse the list to obtain presentation order - */ + if (pattern == 0) { + /* + * reverse the list to obtain presentation order + */ - Tcl_ResetResult(in); - while (sc != sl) { - XOTclClasses* nl = sl; - while (nl->next != sc) nl = nl->next; - Tcl_AppendElement(in, className(nl->cl)); - sc = nl; - } - } else { - XOTclClass *isc = XOTclpGetClass(in, pattern); - XOTclClasses* pl; - if (isc == 0) - return XOTclErrBadVal(in, "info superclass", "a class", pattern); + Tcl_ResetResult(interp); + while (sc != sl) { + XOTclClasses *nl = sl; + while (nl->nextPtr != sc) nl = nl->nextPtr; + Tcl_AppendElement(interp, className(nl->cl)); + sc = nl; + } + } else if (!noMetaChars(pattern)) { + char *key; + Tcl_ResetResult(interp); + while (sc != sl) { + XOTclClasses *nl = sl; + while (nl->nextPtr != sc) nl = nl->nextPtr; + key = className(nl->cl); + if (Tcl_StringMatch(key, pattern)) { + Tcl_AppendElement(interp, key); + } + sc = nl; + } + } else { + XOTclClass *isc = XOTclpGetClass(interp, pattern); + XOTclClasses *pl; + if (isc == 0) + return XOTclErrBadVal(interp, "info superclass", "a class", pattern); - /* - * search precedence to see if we're related or not - */ - for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->next) { - if (pl->cl == isc) { - Tcl_SetIntObj(Tcl_GetObjResult(in), 1); - break; - } + /* + * search precedence to see if we're related or not + */ + for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { + if (pl->cl == isc) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + break; + } + } + if (pl == 0) + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); } - if (pl == 0) - Tcl_SetIntObj(Tcl_GetObjResult(in), 0); - } - return TCL_OK; + return TCL_OK; } static int -ListSubclasses(Tcl_Interp *in, XOTclClass *cl, char *pattern) { - if (pattern == 0) { - XOTclClasses* sl = cl->sub; - XOTclClasses* sc = 0; +ListSubclasses(Tcl_Interp *interp, XOTclClass *cl, char *pattern) { + XOTclClasses *sl = cl->sub; + XOTclClasses *sc = 0; - /* - * order unimportant - */ - Tcl_ResetResult(in); - for (sc = sl; sc != 0; sc = sc->next) - Tcl_AppendElement(in, className(sc->cl)); - } else { - XOTclClass *isc = XOTclpGetClass(in, pattern); - XOTclClasses* pl; - XOTclClasses* saved; + if (pattern == 0) { + /* + * order unimportant + */ + Tcl_ResetResult(interp); + for (sc = sl; sc != 0; sc = sc->nextPtr) + Tcl_AppendElement(interp, className(sc->cl)); + } else if (!noMetaChars(pattern)) { + Tcl_ResetResult(interp); + for (sc = sl; sc != 0; sc = sc->nextPtr) { + char *key = className(sc->cl); + if (Tcl_StringMatch(key, pattern)) { + Tcl_AppendElement(interp, key); + } + } + } else { + XOTclClass *isc = XOTclpGetClass(interp, pattern); + XOTclClasses *pl; + XOTclClasses *saved; - if (isc == 0) - return XOTclErrBadVal(in, "info subclass", "a class", pattern); - saved = cl->order; - cl->order = 0; + if (isc == 0) + return XOTclErrBadVal(interp, "info subclass", "a class", pattern); + saved = cl->order; + cl->order = 0; - /* - * search precedence to see if we're related or not - */ - for (pl = ComputeOrder(cl, cl->order, Sub); pl; pl = pl->next) { - if (pl->cl == isc) { - Tcl_SetIntObj(Tcl_GetObjResult(in), 1); - break; - } - } - if (pl == 0) - Tcl_SetIntObj(Tcl_GetObjResult(in), 0); + /* + * search precedence to see if we're related or not + */ + for (pl = ComputeOrder(cl, cl->order, Sub); pl; pl = pl->nextPtr) { + if (pl->cl == isc) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + break; + } + } + if (pl == 0) + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - XOTclFreeClasses(cl->order); - cl->order = saved; - } - return TCL_OK; + XOTclClassListFree(cl->order); + cl->order = saved; + } + return TCL_OK; } static int -ListHeritage(Tcl_Interp *in, XOTclClass *cl, char *pattern) { - XOTclClasses* pl = ComputeOrder(cl, cl->order, Super); - Tcl_ResetResult(in); - if (pl) pl=pl->next; - for (; pl != 0; pl = pl->next) { - char *name = className(pl->cl); - if (pattern && !Tcl_StringMatch(name, pattern)) continue; - Tcl_AppendElement(in, name); - } - return TCL_OK; +ListHeritage(Tcl_Interp *interp, XOTclClass *cl, char *pattern) { + XOTclClasses *pl = ComputeOrder(cl, cl->order, Super); + Tcl_ResetResult(interp); + if (pl) pl=pl->nextPtr; + for (; pl != 0; pl = pl->nextPtr) { + char *name = className(pl->cl); + if (pattern && !Tcl_StringMatch(name, pattern)) continue; + Tcl_AppendElement(interp, name); + } + return TCL_OK; } -static int -ListPrecedence(Tcl_Interp *in, XOTclObject *obj, char *pattern) { - XOTclClasses* pl; - Tcl_ResetResult(in); - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(in, obj); - if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *ml = obj->mixinOrder; +static XOTclClasses * +ComputePrecedenceWithMixins(Tcl_Interp *interp, XOTclObject *obj, char *pattern) { + XOTclClasses *precedenceList = NULL, *pcl, **npl = &precedenceList; - while (ml) { - XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - char *name = className(mixin); - if (pattern && !Tcl_StringMatch(name, pattern)) continue; - Tcl_AppendElement(in, name); - ml = ml->next; + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); + + if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *ml = obj->mixinOrder; + + while (ml) { + XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (pattern) { + char *name = className(mixin); + if (!Tcl_StringMatch(name, pattern)) continue; + } + npl = XOTclClassListAdd(npl, mixin, NULL); + ml = ml->nextPtr; + } } - } - pl = ComputeOrder(obj->cl, obj->cl->order, Super); - for (; pl != 0; pl = pl->next) { - char *name = className(pl->cl); - if (pattern && !Tcl_StringMatch(name, pattern)) continue; - Tcl_AppendElement(in, name); - } - return TCL_OK; + pcl = ComputeOrder(obj->cl, obj->cl->order, Super); + for (; pcl != 0; pcl = pcl->nextPtr) { + if (pattern) { + char *name = className(pcl->cl); + if (!Tcl_StringMatch(name, pattern)) continue; + } + npl = XOTclClassListAdd(npl, pcl->cl, NULL); + } + return precedenceList; } +static int +ListPrecedence(Tcl_Interp *interp, XOTclObject *obj, char *pattern) { + XOTclClasses *pl, *precedenceList; + Tcl_ResetResult(interp); + precedenceList = ComputePrecedenceWithMixins(interp, obj, pattern); + for (pl = precedenceList; pl != 0; pl = pl->nextPtr) { + char *name = className(pl->cl); + Tcl_AppendElement(interp, name); + } + XOTclClassListFree(pl); + return TCL_OK; +} + + static Proc* -FindProc(Tcl_Interp *in, Tcl_HashTable *table, char *name) { - Tcl_HashEntry* hPtr = table ? Tcl_FindHashEntry(table, name) : 0; - if (hPtr) { - Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); - if (proc == RUNTIME_STATE(in)->objInterpProc) - return (Proc*) Tcl_Command_objClientData(cmd); +FindProc(Tcl_Interp *interp, Tcl_HashTable *table, char *name) { + Tcl_HashEntry *hPtr = table ? Tcl_FindHashEntry(table, name) : 0; + if (hPtr) { + Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); + Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); + if (proc == RUNTIME_STATE(interp)->objInterpProc) + return (Proc*) Tcl_Command_objClientData(cmd); #if USE_INTERP_PROC - else if ((Tcl_CmdProc*)proc == RUNTIME_STATE(in)->interpProc) - return (Proc*) Tcl_Command_clientData(cmd); + else if ((Tcl_CmdProc*)proc == RUNTIME_STATE(interp)->interpProc) + return (Proc*) Tcl_Command_clientData(cmd); #endif - } - return 0; + } + return 0; } static int -ListProcArgs(Tcl_Interp *in, Tcl_HashTable *table, char *name) { - Proc* proc = FindProc(in, table, name); - if (proc) { - CompiledLocal *args = proc->firstLocalPtr; - Tcl_ResetResult(in); - for (;args != NULL; args = args->nextPtr) { - if (TclIsCompiledLocalArgument(args)) - Tcl_AppendElement(in, args->name); +ListProcArgs(Tcl_Interp *interp, Tcl_HashTable *table, char *name) { + Proc *proc = FindProc(interp, table, name); + if (proc) { + CompiledLocal *args = proc->firstLocalPtr; + Tcl_ResetResult(interp); + for (;args != NULL; args = args->nextPtr) { + if (TclIsCompiledLocalArgument(args)) + Tcl_AppendElement(interp, args->name); - } - return TCL_OK; - } - return XOTclErrBadVal(in, "info args", "a tcl method name", name); + } + return TCL_OK; + } + return XOTclErrBadVal(interp, "info args", "a tcl method name", name); } static int -ListArgsFromOrdinaryArgs(Tcl_Interp *in, XOTclNonposArgs* nonposArgs) { - int i, rc, ordinaryArgsDefc, defaultValueObjc; - Tcl_Obj **ordinaryArgsDefv, **defaultValueObjv, *ordinaryArg, - *argList = Tcl_NewListObj(0, NULL); - rc = Tcl_ListObjGetElements(in, nonposArgs->ordinaryArgs, - &ordinaryArgsDefc, &ordinaryArgsDefv); - if (rc != TCL_OK) - return TCL_ERROR; - - for (i=0; i < ordinaryArgsDefc; i++) { - ordinaryArg = ordinaryArgsDefv[i]; - rc = Tcl_ListObjGetElements(in, ordinaryArg, - &defaultValueObjc, &defaultValueObjv); - if (rc == TCL_OK && defaultValueObjc == 2) { - ordinaryArg = defaultValueObjv[0]; +ListArgsFromOrdinaryArgs(Tcl_Interp *interp, XOTclNonposArgs *nonposArgs) { + int i, rc, ordinaryArgsDefc, defaultValueObjc; + Tcl_Obj **ordinaryArgsDefv, **defaultValueObjv, *ordinaryArg, + *argList = Tcl_NewListObj(0, NULL); + rc = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs, + &ordinaryArgsDefc, &ordinaryArgsDefv); + if (rc == TCL_OK) { + for (i=0; i < ordinaryArgsDefc; i++) { + ordinaryArg = ordinaryArgsDefv[i]; + rc = Tcl_ListObjGetElements(interp, ordinaryArg, + &defaultValueObjc, &defaultValueObjv); + if (rc == TCL_OK && defaultValueObjc == 2) { + ordinaryArg = defaultValueObjv[0]; + } + Tcl_ListObjAppendElement(interp, argList, ordinaryArg); + } + Tcl_SetObjResult(interp, argList); } - Tcl_ListObjAppendElement(in, argList, ordinaryArg); - } - Tcl_SetObjResult(in, argList); - return TCL_OK; + return rc; } static int -GetProcDefault(Tcl_Interp *in, Tcl_HashTable *table, +GetProcDefault(Tcl_Interp *interp, Tcl_HashTable *table, char *name, char *arg, Tcl_Obj **resultObj) { - Proc* proc = FindProc(in, table, name); - *resultObj = 0; - if (proc) { - CompiledLocal *ap; - for (ap = proc->firstLocalPtr; ap != 0; ap = ap->nextPtr) { - if (!TclIsCompiledLocalArgument(ap)) continue; - if (strcmp(arg, ap->name) != 0) continue; + Proc *proc = FindProc(interp, table, name); + *resultObj = 0; + if (proc) { + CompiledLocal *ap; + for (ap = proc->firstLocalPtr; ap != 0; ap = ap->nextPtr) { + if (!TclIsCompiledLocalArgument(ap)) continue; + if (strcmp(arg, ap->name) != 0) continue; - if (ap->defValuePtr != NULL) { - *resultObj = ap->defValuePtr; - return TCL_OK; - } - return TCL_OK; + if (ap->defValuePtr != NULL) { + *resultObj = ap->defValuePtr; + return TCL_OK; + } + return TCL_OK; + } } - } - return TCL_ERROR; + return TCL_ERROR; } static int -SetProcDefault(Tcl_Interp *in, Tcl_Obj *var, Tcl_Obj* defVal) { - int result = TCL_OK; - callFrameContext ctx = {0}; - CallStackUseActiveFrames(in,&ctx); +SetProcDefault(Tcl_Interp *interp, Tcl_Obj *var, Tcl_Obj *defVal) { + int result = TCL_OK; + callFrameContext ctx = {0}; + CallStackUseActiveFrames(interp,&ctx); - if (defVal != 0) { - if (Tcl_ObjSetVar2(in, var, NULL, defVal, 0) != NULL) { - Tcl_SetIntObj(Tcl_GetObjResult(in), 1); + if (defVal != 0) { + if (Tcl_ObjSetVar2(interp, var, 0, defVal, 0) != NULL) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + result = TCL_ERROR; + } } else { - result = TCL_ERROR; + if (Tcl_ObjSetVar2(interp, var, 0, + XOTclGlobalObjects[XOTE_EMPTY], 0) != NULL) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } else { + result = TCL_ERROR; + } } - } else { - if (Tcl_ObjSetVar2(in, var, NULL, - XOTclGlobalObjects[XOTE_EMPTY], 0) != NULL) { - Tcl_SetIntObj(Tcl_GetObjResult(in), 0); - } else { - result = TCL_ERROR; - } - } - CallStackRestoreSavedFrames(in, &ctx); + CallStackRestoreSavedFrames(interp, &ctx); - if (result == TCL_ERROR) { - XOTclVarErrMsg(in, "couldn't store default value in variable '", - var, "'", (char *) NULL); - } - return result; + if (result == TCL_ERROR) { + XOTclVarErrMsg(interp, "couldn't store default value in variable '", + var, "'", (char *) NULL); + } + return result; } static int -ListProcDefault(Tcl_Interp *in, Tcl_HashTable *table, - char *name, char *arg, Tcl_Obj *var) { - Tcl_Obj *defVal; - int result; - if (GetProcDefault(in, table, name, arg, &defVal) == TCL_OK) { - result = SetProcDefault(in, var, defVal); - } else { - XOTclVarErrMsg(in, "method '", name, - "' doesn't exist or doesn't have an argument '", - arg, "'", (char *) NULL); - result = TCL_ERROR; - } - return result; +ListProcDefault(Tcl_Interp *interp, Tcl_HashTable *table, + char *name, char *arg, Tcl_Obj *var) { + Tcl_Obj *defVal; + int result; + if (GetProcDefault(interp, table, name, arg, &defVal) == TCL_OK) { + result = SetProcDefault(interp, var, defVal); + } else { + XOTclVarErrMsg(interp, "method '", name, + "' doesn't exist or doesn't have an argument '", + arg, "'", (char *) NULL); + result = TCL_ERROR; + } + return result; } static int -ListDefaultFromOrdinaryArgs(Tcl_Interp *in, char *procName, - XOTclNonposArgs* nonposArgs, char *arg, Tcl_Obj *var) { - int i, rc, ordinaryArgsDefc, defaultValueObjc; - Tcl_Obj **ordinaryArgsDefv, **defaultValueObjv, *ordinaryArg; +ListDefaultFromOrdinaryArgs(Tcl_Interp *interp, char *procName, + XOTclNonposArgs *nonposArgs, char *arg, Tcl_Obj *var) { + int i, rc, ordinaryArgsDefc, defaultValueObjc; + Tcl_Obj **ordinaryArgsDefv, **defaultValueObjv, *ordinaryArg; - rc = Tcl_ListObjGetElements(in, nonposArgs->ordinaryArgs, - &ordinaryArgsDefc, &ordinaryArgsDefv); - if (rc != TCL_OK) - return TCL_ERROR; + rc = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs, + &ordinaryArgsDefc, &ordinaryArgsDefv); + if (rc != TCL_OK) + return TCL_ERROR; - for (i=0; i < ordinaryArgsDefc; i++) { - ordinaryArg = ordinaryArgsDefv[i]; - rc = Tcl_ListObjGetElements(in, ordinaryArg, - &defaultValueObjc, &defaultValueObjv); - if (rc == TCL_OK && !strcmp(arg, ObjStr(defaultValueObjv[0]))) { - return SetProcDefault(in, var, defaultValueObjc == 2 ? - defaultValueObjv[1] : NULL); + for (i=0; i < ordinaryArgsDefc; i++) { + ordinaryArg = ordinaryArgsDefv[i]; + rc = Tcl_ListObjGetElements(interp, ordinaryArg, + &defaultValueObjc, &defaultValueObjv); + if (rc == TCL_OK && !strcmp(arg, ObjStr(defaultValueObjv[0]))) { + return SetProcDefault(interp, var, defaultValueObjc == 2 ? + defaultValueObjv[1] : NULL); + } } - } - XOTclVarErrMsg(in, "method '", procName, "' doesn't have an argument '", - arg, "'", (char *) NULL); - return TCL_ERROR; + XOTclVarErrMsg(interp, "method '", procName, "' doesn't have an argument '", + arg, "'", (char *) NULL); + return TCL_ERROR; } static char * @@ -6152,421 +6359,502 @@ return body; } + static int -ListProcBody(Tcl_Interp *in, Tcl_HashTable *table, char *name) { - Proc* proc = FindProc(in, table, name); - if (proc) { - char *body = ObjStr(proc->bodyPtr); - Tcl_SetObjResult(in, Tcl_NewStringObj(StripBodyPrefix(body), -1)); - return TCL_OK; - } - return XOTclErrBadVal(in, "info body", "a tcl method name", name); +ListProcBody(Tcl_Interp *interp, Tcl_HashTable *table, char *name) { + Proc *proc = FindProc(interp, table, name); + + if (proc) { + char *body = ObjStr(proc->bodyPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj(StripBodyPrefix(body), -1)); + return TCL_OK; + } + return XOTclErrBadVal(interp, "info body", "a tcl method name", name); } static int -ListChildren(Tcl_Interp *in, XOTclObject *obj, char *pattern, int classesOnly) { - XOTclObject *childobj; - Tcl_HashTable *cmdTable; - XOTcl_FrameDecls; +ListChildren(Tcl_Interp *interp, XOTclObject *obj, char *pattern, int classesOnly) { + XOTclObject *childobj; + Tcl_HashTable *cmdTable; + XOTcl_FrameDecls; - if (!obj->nsPtr) return TCL_OK; + if (!obj->nsPtr) return TCL_OK; - cmdTable = Tcl_Namespace_cmdTable(obj->nsPtr); - if (pattern && noMetaChars(pattern)) { - XOTcl_PushFrame(in, obj); - if ((childobj = XOTclpGetObject(in, pattern)) && - (!classesOnly || XOTclObjectIsClass(childobj)) && - (childobj->id && Tcl_Command_nsPtr(childobj->id) == obj->nsPtr) /* true children */ - ) { - Tcl_SetObjResult(in, childobj->cmdName); + cmdTable = Tcl_Namespace_cmdTable(obj->nsPtr); + if (pattern && noMetaChars(pattern)) { + XOTcl_PushFrame(interp, obj); + if ((childobj = XOTclpGetObject(interp, pattern)) && + (!classesOnly || XOTclObjectIsClass(childobj)) && + (childobj->id && Tcl_Command_nsPtr(childobj->id) == obj->nsPtr) /* true children */ + ) { + Tcl_SetObjResult(interp, childobj->cmdName); + } else { + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + } + XOTcl_PopFrame(interp,obj); } else { - Tcl_SetObjResult(in, XOTclGlobalObjects[XOTE_EMPTY]); + Tcl_Obj *list = Tcl_NewListObj(0, NULL); + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); + char *key; + XOTcl_PushFrame(interp, obj); + for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { + key = Tcl_GetHashKey(cmdTable, hPtr); + if (!pattern || Tcl_StringMatch(key, pattern)) { + if ((childobj = XOTclpGetObject(interp, key)) && + (!classesOnly || XOTclObjectIsClass(childobj)) && + (childobj->id && Tcl_Command_nsPtr(childobj->id) == obj->nsPtr) /* true children */ + ) { + Tcl_ListObjAppendElement(interp, list, childobj->cmdName); + } + } + } + XOTcl_PopFrame(interp,obj); + Tcl_SetObjResult(interp, list); } - XOTcl_PopFrame(in,obj); - } else { + return TCL_OK; +} + +static XOTclObjects * +computeSlotObjects(Tcl_Interp *interp, XOTclObject *obj, char *pattern) { + XOTclObjects *slotObjects = NULL, **npl = &slotObjects; + XOTclClasses *pl; + XOTclObject *childobj, *o; + Tcl_HashTable slotTable; + + assert(obj); + + Tcl_InitHashTable(&slotTable, TCL_STRING_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable",slotTable); + + pl = ComputePrecedenceWithMixins(interp, obj, NULL /* pattern*/ ); + for (; pl != 0; pl = pl->nextPtr) { + Tcl_DString ds, *dsPtr = &ds; + + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(pl->cl), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (o) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr, *slotEntry; + /*fprintf(stderr,"we have slots %s\n",Tcl_DStringValue(dsPtr));*/ + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(o->nsPtr); + Tcl_Command cmd; + int new; + hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); + for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(cmdTable, hPtr); + slotEntry = Tcl_CreateHashEntry(&slotTable, key, &new); + if (!new) continue; + cmd = (Tcl_Command) Tcl_GetHashValue(hPtr); + childobj = XOTclGetObjectFromCmdPtr(cmd); + /* (childobj->id && Tcl_Command_nsPtr(childobj->id) == obj->nsPtr) true children */ + /*fprintf(stderr,"we have true child obj %s\n", ObjStr(childobj->cmdName));*/ + npl = XOTclObjectListAdd(npl, childobj); + } + } + DSTRING_FREE(dsPtr); + } + + Tcl_DeleteHashTable(&slotTable); + MEM_COUNT_FREE("Tcl_InitHashTable",slotTable); + + XOTclClassListFree(pl); + + return slotObjects; +} + +static int +ListSlotObjects(Tcl_Interp *interp, XOTclObject *obj, char *pattern) { + XOTclObjects *pl; Tcl_Obj *list = Tcl_NewListObj(0, NULL); - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); - char *key; - XOTcl_PushFrame(in, obj); - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - key = Tcl_GetHashKey(cmdTable, hPtr); - if (!pattern || Tcl_StringMatch(key, pattern)) { - if ((childobj = XOTclpGetObject(in, key)) && - (!classesOnly || XOTclObjectIsClass(childobj)) && - (childobj->id && Tcl_Command_nsPtr(childobj->id) == obj->nsPtr) /* true children */ - ) { - Tcl_ListObjAppendElement(in, list, childobj->cmdName); - } - } + + assert(obj); + + pl = computeSlotObjects(interp, obj, pattern /* not used */ ); + for (; pl != 0; pl = pl->nextPtr) { + Tcl_ListObjAppendElement(interp, list, pl->obj->cmdName); } - XOTcl_PopFrame(in,obj); - Tcl_SetObjResult(in, list); - } - return TCL_OK; + + XOTclObjectListFree(pl); + Tcl_SetObjResult(interp, list); + + return TCL_OK; } + + static int -ListParent(Tcl_Interp *in, XOTclObject *obj) { - if (obj->id) { - Tcl_SetResult(in, NSCmdFullName(obj->id), TCL_VOLATILE); - } - return TCL_OK; +ListParent(Tcl_Interp *interp, XOTclObject *obj) { + if (obj->id) { + Tcl_SetResult(interp, NSCmdFullName(obj->id), TCL_VOLATILE); + } + return TCL_OK; } static XOTclClass* -FindCalledClass(Tcl_Interp *in, XOTclObject *obj) { - char *methodName = 0; - XOTclClass *cl; - Tcl_Command cmd = NULL; - XOTclCallStackContent *csc = CallStackGetTopFrame(in); +FindCalledClass(Tcl_Interp *interp, XOTclObject *obj) { + char *methodName = 0; + XOTclClass *cl; + Tcl_Command cmd = NULL; + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); - if (csc->frameType == XOTCL_CSC_TYPE_PLAIN) - return GetSelfClass(in); + if (csc->frameType == XOTCL_CSC_TYPE_PLAIN) + return GetSelfClass(interp); - if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) - methodName = ObjStr(csc->filterStackEntry->calledProc); - else if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN && obj->mixinStack) - methodName = (char *) GetSelfProc(in); + if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) + methodName = ObjStr(csc->filterStackEntry->calledProc); + else if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN && obj->mixinStack) + methodName = (char *) GetSelfProc(interp); - if (!methodName) methodName = ""; + if (!methodName) methodName = ""; - if (obj->nsPtr) - cmd = FindMethod(methodName, obj->nsPtr); + if (obj->nsPtr) + cmd = FindMethod(methodName, obj->nsPtr); - if (cmd) { - cl = 0; - } else { - cl = SearchCMethod(obj->cl, methodName, &cmd); - } - return cl; + if (cmd) { + cl = 0; + } else { + cl = SearchCMethod(obj->cl, methodName, &cmd); + } + return cl; } /* * Next Primitive Handling */ XOTCLINLINE static void -NextSearchMethod(XOTclObject *obj, Tcl_Interp *in, XOTclCallStackContent *csc, +NextSearchMethod(XOTclObject *obj, Tcl_Interp *interp, XOTclCallStackContent *csc, XOTclClass **cl, char **method, Tcl_ObjCmdProc **proc, Tcl_Command *cmd, - ClientData *cp, int* isMixinEntry, int* isFilterEntry, - int* endOfFilterChain, Tcl_Command* currentCmd) { - XOTclClasses *pl = 0; - int endOfChain = 0; - *endOfFilterChain = 0; + ClientData *cp, int *isMixinEntry, int *isFilterEntry, + int *endOfFilterChain, Tcl_Command *currentCmd) { + XOTclClasses *pl = 0; + int endOfChain = 0; + *endOfFilterChain = 0; - /* - * Next in filters - */ - /*assert(obj->flags & XOTCL_FILTER_ORDER_VALID); *** strange, worked before ****/ + /* + * Next in filters + */ + /*assert(obj->flags & XOTCL_FILTER_ORDER_VALID); *** strange, worked before ****/ - FilterComputeDefined(in, obj); + FilterComputeDefined(interp, obj); - if ((obj->flags & XOTCL_FILTER_ORDER_VALID) && - obj->filterStack && - obj->filterStack->currentCmdPtr) { - *cmd = FilterSearchProc(in, obj, proc, cp, currentCmd,cl); - /*fprintf(stderr,"EndOfChain? proc=%p, cmd=%p\n",*proc,*cmd);*/ - /* XOTclCallStackDump(in); XOTclStackDump(in);*/ + if ((obj->flags & XOTCL_FILTER_ORDER_VALID) && + obj->filterStack && + obj->filterStack->currentCmdPtr) { + *cmd = FilterSearchProc(interp, obj, proc, cp, currentCmd, cl); + /*fprintf(stderr,"EndOfChain? proc=%p, cmd=%p\n",*proc,*cmd);*/ + /* XOTclCallStackDump(interp); XOTclStackDump(interp);*/ - if (*proc == 0) { - if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { - /* reset the information to the values of method, cl - to the values they had before calling the filters */ - *method = ObjStr(obj->filterStack->calledProc); - endOfChain = 1; - *endOfFilterChain = 1; - *cl = 0; - /*fprintf(stderr,"EndOfChain resetting cl\n");*/ - } - } else { - *method = (char *) Tcl_GetCommandName(in, *cmd); - *isFilterEntry = 1; - return; + if (*proc == 0) { + if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + /* reset the information to the values of method, cl + to the values they had before calling the filters */ + *method = ObjStr(obj->filterStack->calledProc); + endOfChain = 1; + *endOfFilterChain = 1; + *cl = 0; + /*fprintf(stderr,"EndOfChain resetting cl\n");*/ + } + } else { + *method = (char *) Tcl_GetCommandName(interp, *cmd); + *isFilterEntry = 1; + return; + } } - } - /* - * Next in Mixins - */ - assert(obj->flags & XOTCL_MIXIN_ORDER_VALID); - /* otherwise: MixinComputeDefined(in, obj); */ + /* + * Next in Mixins + */ + assert(obj->flags & XOTCL_MIXIN_ORDER_VALID); + /* otherwise: MixinComputeDefined(interp, obj); */ - /*fprintf(stderr,"nextsearch: mixinorder valid %d stack=%p\n", - obj->flags & XOTCL_MIXIN_ORDER_VALID, obj->mixinStack);*/ + /*fprintf(stderr,"nextsearch: mixinorder valid %d stack=%p\n", + obj->flags & XOTCL_MIXIN_ORDER_VALID, obj->mixinStack);*/ - if ((obj->flags & XOTCL_MIXIN_ORDER_VALID) && obj->mixinStack) { - *cmd = MixinSearchProc(in, obj, *method, cl, proc, cp, currentCmd); - /*fprintf(stderr,"nextsearch: mixinsearch cmd %p, proc=%p\n",*cmd,*proc);*/ - if (*proc == 0) { - if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) { - endOfChain = 1; - *cl = 0; - } - } else { - *isMixinEntry = 1; - return; + if ((obj->flags & XOTCL_MIXIN_ORDER_VALID) && obj->mixinStack) { + *cmd = MixinSearchProc(interp, obj, *method, cl, proc, cp, currentCmd); + /*fprintf(stderr,"nextsearch: mixinsearch cmd %p, proc=%p\n",*cmd,*proc);*/ + if (*proc == 0) { + if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) { + endOfChain = 1; + *cl = 0; + } + } else { + *isMixinEntry = 1; + return; + } } - } - /* - * otherwise: normal method dispatch - * - * if we are already in the precedence ordering, then advance - * past our last point; otherwise (if cl==0) begin from the start - */ + /* + * otherwise: normal method dispatch + * + * if we are already in the precedence ordering, then advance + * past our last point; otherwise (if cl==0) begin from the start + */ - /* if a mixin or filter chain has ended -> we have to search - the obj-specific methods as well */ + /* if a mixin or filter chain has ended -> we have to search + the obj-specific methods as well */ - if (obj->nsPtr && endOfChain) { - *cmd = FindMethod(*method, obj->nsPtr); - } else { - *cmd = 0; - } + if (obj->nsPtr && endOfChain) { + *cmd = FindMethod(*method, obj->nsPtr); + } else { + *cmd = 0; + } - if (!*cmd) { - for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl && *cl; pl = pl->next) { - if (pl->cl == *cl) - *cl = 0; + if (!*cmd) { + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl && *cl; pl = pl->nextPtr) { + if (pl->cl == *cl) + *cl = 0; + } + + /* + * 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; } - /* - * 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; - } + if (*cmd) { + *proc = Tcl_Command_objProc(*cmd); + *cp = Tcl_Command_objClientData(*cmd); + } - if (*cmd) { - *proc = Tcl_Command_objProc(*cmd); - *cp = Tcl_Command_objClientData(*cmd); - } - - return; + return; } static int -XOTclNextMethod(XOTclObject *obj, Tcl_Interp *in, XOTclClass *givenCl, +XOTclNextMethod(XOTclObject *obj, Tcl_Interp *interp, XOTclClass *givenCl, char *givenMethod, int objc, Tcl_Obj *CONST objv[], int useCallstackObjs) { - XOTclCallStackContent *csc = CallStackGetTopFrame(in); - Tcl_ObjCmdProc *proc = 0; - Tcl_Command cmd, currentCmd = NULL; - ClientData cp = 0; - int result = TCL_OK, - frameType = XOTCL_CSC_TYPE_PLAIN, - isMixinEntry = 0, isFilterEntry = 0, - endOfFilterChain = 0; - int nobjc; Tcl_Obj **nobjv; - XOTclClass **cl = &givenCl; - char **method = &givenMethod; + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + Tcl_ObjCmdProc *proc = 0; + Tcl_Command cmd, currentCmd = NULL; + ClientData cp = 0; + int result = TCL_OK, + frameType = XOTCL_CSC_TYPE_PLAIN, + isMixinEntry = 0, isFilterEntry = 0, + endOfFilterChain = 0; + int nobjc; Tcl_Obj **nobjv; + XOTclClass **cl = &givenCl; + char **method = &givenMethod; #if !defined(NDEBUG) - if (useCallstackObjs) { - Tcl_CallFrame *cf = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(in); - int found = 0; - while (cf) { - /* fprintf(stderr, " ... compare fp = %p and cfp %p procFrame %p oc=%d\n", - cf, csc->currentFramePtr, - Tcl_Interp_framePtr(in), Tcl_CallFrame_objc(Tcl_Interp_framePtr(in)) - );*/ - if (cf == csc->currentFramePtr) { - found = 1; - break; - } - cf = (Tcl_CallFrame *)((CallFrame *)cf)->callerPtr; + if (useCallstackObjs) { + Tcl_CallFrame *cf = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + int found = 0; + while (cf) { + /* fprintf(stderr, " ... compare fp = %p and cfp %p procFrame %p oc=%d\n", + cf, csc->currentFramePtr, + Tcl_Interp_framePtr(interp), Tcl_CallFrame_objc(Tcl_Interp_framePtr(interp)) + );*/ + if (cf == csc->currentFramePtr) { + found = 1; + break; + } + cf = (Tcl_CallFrame *)((CallFrame *)cf)->callerPtr; + } + /* + if (!found) { + if (Tcl_Interp_varFramePtr(interp)) { + fprintf(stderr,"found (csc->currentFramePtr %p)= %d cur level=%d\n", + csc->currentFramePtr,found, + Tcl_CallFrame_level(Tcl_Interp_varFramePtr(interp))); + } else { + fprintf(stderr,"no varFramePtr\n"); + } + return TCL_OK; + } + */ } - /* - if (!found) { - if (Tcl_Interp_varFramePtr(in)) { - fprintf(stderr,"found (csc->currentFramePtr %p)= %d cur level=%d\n", - csc->currentFramePtr,found, - Tcl_CallFrame_level(Tcl_Interp_varFramePtr(in))); - } else { - fprintf(stderr,"no varFramePtr\n"); - } - return TCL_OK; - } - */ - } #endif - /* - fprintf(stderr,"givenMethod = %s, csc = %p, useCallstackObj %d, objc %d\n", - givenMethod, csc, useCallstackObjs, objc); - */ + + /*fprintf(stderr,"Next givenMethod = %s, csc = %p, useCallstackObj %d, objc %d\n", + givenMethod, csc, useCallstackObjs, objc);*/ - /* if no args are given => use args from stack */ - if (objc < 2 && useCallstackObjs && csc->currentFramePtr) { - nobjc = Tcl_CallFrame_objc(csc->currentFramePtr); - nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr); - } else { - nobjc = objc; - nobjv = (Tcl_Obj **)objv; - } + /* if no args are given => use args from stack */ + if (objc < 2 && useCallstackObjs && csc->currentFramePtr) { + nobjc = Tcl_CallFrame_objc(csc->currentFramePtr); + nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr); + } else { + nobjc = objc; + nobjv = (Tcl_Obj **)objv; + } - /* - * Search the next method & compute its method data - */ - NextSearchMethod(obj, in, csc, cl, method, &proc, &cmd, &cp, - &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); + /* + * Search the next method & compute its method data + */ + NextSearchMethod(obj, interp, csc, cl, method, &proc, &cmd, &cp, + &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); - /* - fprintf(stderr, "NextSearchMethod -- RETURN: method=%s eoffc=%d,", + + /*fprintf(stderr, "NextSearchMethod -- RETURN: method=%s eoffc=%d,", *method, endOfFilterChain); - if (obj) - fprintf(stderr, " obj=%s,", ObjStr(obj->cmdName)); - if ((*cl)) - fprintf(stderr, " cl=%s,", (*cl)->nsPtr->fullName); - fprintf(stderr, " mixin=%d, filter=%d, proc=%p\n", - isMixinEntry, isFilterEntry, proc); - */ - Tcl_ResetResult(in); /* needed for bytecode support */ + if (obj) + fprintf(stderr, " obj=%s,", ObjStr(obj->cmdName)); + if ((*cl)) + fprintf(stderr, " cl=%s,", (*cl)->nsPtr->fullName); + fprintf(stderr, " mixin=%d, filter=%d, proc=%p\n", + isMixinEntry, isFilterEntry, proc); + */ - if (proc != 0) { - /* - * change mixin state - */ - if (obj->mixinStack) { - if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) - csc->frameType = XOTCL_CSC_TYPE_INACTIVE_MIXIN; + Tcl_ResetResult(interp); /* needed for bytecode support */ + + if (proc != 0) { + /* + * change mixin state + */ + if (obj->mixinStack) { + if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_MIXIN) + csc->frameType = XOTCL_CSC_TYPE_INACTIVE_MIXIN; - /* otherwise move the command pointer forward */ - if (isMixinEntry) { - frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; - obj->mixinStack->currentCmdPtr = currentCmd; - } - } - /* - * change filter state - */ - if (obj->filterStack) { - if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) - csc->frameType = XOTCL_CSC_TYPE_INACTIVE_FILTER; + /* otherwise move the command pointer forward */ + if (isMixinEntry) { + frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; + obj->mixinStack->currentCmdPtr = currentCmd; + } + } + /* + * change filter state + */ + if (obj->filterStack) { + if (csc->frameType == XOTCL_CSC_TYPE_ACTIVE_FILTER) { + /*fprintf(stderr,"next changes filter state\n");*/ + csc->frameType = XOTCL_CSC_TYPE_INACTIVE_FILTER; + } - /* otherwise move the command pointer forward */ - if (isFilterEntry) { - frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; - obj->filterStack->currentCmdPtr = currentCmd; - } - } + /* otherwise move the command pointer forward */ + if (isFilterEntry) { + /*fprintf(stderr,"next moves filter forward\n");*/ + frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; + obj->filterStack->currentCmdPtr = currentCmd; + } + } - /* - * now actually call the "next" method - */ + /* + * now actually call the "next" method + */ - /* cut the flag, that no stdargs should be used, if it is there */ - if (nobjc > 1) { - char *nobjv1 = ObjStr(nobjv[1]); - if (nobjv1[0] == '-' && !strcmp(nobjv1, "--noArgs")) - nobjc = 1; - } - csc->callType |= XOTCL_CSC_CALL_IS_NEXT; - RUNTIME_STATE(in)->unknown = 0; + /* cut the flag, that no stdargs should be used, if it is there */ + if (nobjc > 1) { + char *nobjv1 = ObjStr(nobjv[1]); + if (nobjv1[0] == '-' && !strcmp(nobjv1, "--noArgs")) + nobjc = 1; + } + csc->callType |= XOTCL_CSC_CALL_IS_NEXT; + RUNTIME_STATE(interp)->unknown = 0; - - result = DoCallProcCheck(cp, (ClientData)obj, in, nobjc, nobjv, cmd, - obj, *cl, *method, frameType, 1/*fromNext*/); + /*{int i; fprintf(stderr, "N\tCALL ");for(i=0; icallType &= ~XOTCL_CSC_CALL_IS_NEXT; + csc->callType &= ~XOTCL_CSC_CALL_IS_NEXT; - if (csc->frameType == XOTCL_CSC_TYPE_INACTIVE_FILTER) - csc->frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; - else if (csc->frameType == XOTCL_CSC_TYPE_INACTIVE_MIXIN) - csc->frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; - } else if (result == TCL_OK && endOfFilterChain) { - /*fprintf(stderr,"setting unknown to 1\n");*/ - RUNTIME_STATE(in)->unknown = 1; - } + if (csc->frameType == XOTCL_CSC_TYPE_INACTIVE_FILTER) + csc->frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; + else if (csc->frameType == XOTCL_CSC_TYPE_INACTIVE_MIXIN) + csc->frameType = XOTCL_CSC_TYPE_ACTIVE_MIXIN; + } else if (result == TCL_OK && endOfFilterChain) { + /*fprintf(stderr,"setting unknown to 1\n");*/ + RUNTIME_STATE(interp)->unknown = 1; + } - return result; + return result; } int -XOTclNextObjCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclCallStackContent *csc = CallStackGetTopFrame(in); +XOTclNextObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); - if (!csc->self) - return XOTclVarErrMsg(in, "next: can't find self", (char *) NULL); + if (!csc->self) + return XOTclVarErrMsg(interp, "next: can't find self", (char *) NULL); - if (!csc->cmdPtr) - return XOTclErrMsg(in, "next: no executing proc", TCL_STATIC); + if (!csc->cmdPtr) + return XOTclErrMsg(interp, "next: no executing proc", TCL_STATIC); - return XOTclNextMethod(csc->self, in, csc->cl, - (char *)Tcl_GetCommandName(in, csc->cmdPtr), - objc, objv, 1); + if (!csc->destroyedCmd && !Tcl_Command_cmdEpoch(csc->cmdPtr)) { + return XOTclNextMethod(csc->self, interp, csc->cl, + (char *)Tcl_GetCommandName(interp, csc->cmdPtr), + objc, objv, 1); + } else { + /* also TCL_ERROR would be defensible, but next is as well silent on the "last" next*/ + return TCL_OK; + } } int -XOTclQualifyObjCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - char *string; - if (objc != 2) - return XOTclVarErrMsg(in, "wrong # of args for __qualify", (char *) NULL); +XOTclQualifyObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + char *string; + if (objc != 2) + return XOTclVarErrMsg(interp, "wrong # of args for __qualify", (char *) NULL); - string = ObjStr(objv[1]); - if (!isAbsolutePath(string)) { - Tcl_SetObjResult(in, NameInNamespaceObj(in,string,callingNameSpace(in))); - } else { - Tcl_SetObjResult(in, objv[1]); - } - return TCL_OK; + string = ObjStr(objv[1]); + if (!isAbsolutePath(string)) { + Tcl_SetObjResult(interp, NameInNamespaceObj(interp,string,callingNameSpace(interp))); + } else { + Tcl_SetObjResult(interp, objv[1]); + } + return TCL_OK; } /* method for calling e.g. $obj __next */ static int -XOTclONextMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - XOTclCallStackContent *csc = CallStackGetTopFrame(in); - char *methodName; +XOTclONextMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + char *methodName; - for (; csc >= cs->content; csc--) { - if (csc->self == obj) break; - } - if (csccontent) - return XOTclVarErrMsg(in, "__next: can't find object", - ObjStr(obj->cmdName), (char *) NULL); - methodName = (char *)Tcl_GetCommandName(in, csc->cmdPtr); - /*fprintf(stderr,"******* next for proc %s\n", methodName);*/ - return XOTclNextMethod(obj, in, csc->cl, methodName, objc-1, &objv[1], 0); + for (; csc >= cs->content; csc--) { + if (csc->self == obj) break; + } + if (csccontent) + return XOTclVarErrMsg(interp, "__next: can't find object", + ObjStr(obj->cmdName), (char *) NULL); + methodName = (char *)Tcl_GetCommandName(interp, csc->cmdPtr); + /*fprintf(stderr,"******* next for proc %s\n", methodName);*/ + return XOTclNextMethod(obj, interp, csc->cl, methodName, objc-1, &objv[1], 0); } #if 0 /* method next for calling e.g. $obj next */ static int -XOTclONextMethod2(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - int result, nobjc; - /*XOTclCallStack *cs = &RUNTIME_STATE(in)->cs;*/ - XOTclCallStackContent *csc = CallStackGetTopFrame(in); - Tcl_Obj **nobjv; +XOTclONextMethod2(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + int result, nobjc; + /*XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs;*/ + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + Tcl_Obj **nobjv; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - /* if no args are given => use args from stack */ - if (objc < 2) { - nobjc = Tcl_CallFrame_objc(csc->currentFramePtr); - nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr); - } else { - nobjc = objc; - nobjv = (Tcl_Obj **)objv; - } - { - ALLOC_ON_STACK(Tcl_Obj*,nobjc + 1, ov); - memcpy(ov+1, nobjv, sizeof(Tcl_Obj *)*nobjc); - ov[0] = obj->cmdName; - result = ObjDispatch(cd, in, nobjc+1, ov, 0); - FREE_ON_STACK(ov); - } - /*fprintf(stderr,"******* next for proc %s\n", methodName);*/ - /*result = Tcl_EvalObjv(in, objc, ov, 0);*/ - return result; + /* if no args are given => use args from stack */ + if (objc < 2) { + nobjc = Tcl_CallFrame_objc(csc->currentFramePtr); + nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr); + } else { + nobjc = objc; + nobjv = (Tcl_Obj **)objv; + } + { + ALLOC_ON_STACK(Tcl_Obj *,nobjc + 1, ov); + memcpy(ov+1, nobjv, sizeof(Tcl_Obj *)*nobjc); + ov[0] = obj->cmdName; + result = ObjDispatch(clientData, interp, nobjc+1, ov, 0); + FREE_ON_STACK(ov); + } + /*fprintf(stderr,"******* next for proc %s\n", methodName);*/ + /*result = Tcl_EvalObjv(interp, objc, ov, 0);*/ + return result; } #endif @@ -6575,923 +6863,884 @@ */ static int -FindSelfNext(Tcl_Interp *in, XOTclObject *obj) { - XOTclCallStackContent *csc = CallStackGetTopFrame(in); - Tcl_ObjCmdProc *proc = 0; - Tcl_Command cmd, currentCmd = 0; - ClientData cp = 0; - int isMixinEntry = 0, - isFilterEntry = 0, - endOfFilterChain = 0; - XOTclClass *cl = csc->cl; - XOTclObject *o = csc->self; - char *methodName; +FindSelfNext(Tcl_Interp *interp, XOTclObject *obj) { + XOTclCallStackContent *csc = CallStackGetTopFrame(interp); + Tcl_ObjCmdProc *proc = 0; + Tcl_Command cmd, currentCmd = 0; + ClientData cp = 0; + int isMixinEntry = 0, + isFilterEntry = 0, + endOfFilterChain = 0; + XOTclClass *cl = csc->cl; + XOTclObject *o = csc->self; + char *methodName; - Tcl_ResetResult(in); + Tcl_ResetResult(interp); - methodName = (char *) GetSelfProc(in); - if (!methodName) - return TCL_OK; + methodName = (char *) GetSelfProc(interp); + if (!methodName) + return TCL_OK; - NextSearchMethod(o, in, csc, &cl, &methodName, &proc, &cmd, &cp, - &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); + NextSearchMethod(o, interp, csc, &cl, &methodName, &proc, &cmd, &cp, + &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); - if (cmd) { - Tcl_SetObjResult(in, getFullProcQualifier(in, Tcl_GetCommandName(in, cmd), - o, cl, cmd)); - } - return TCL_OK; + if (cmd) { + Tcl_SetObjResult(interp, getFullProcQualifier(interp, Tcl_GetCommandName(interp, cmd), + o, cl, cmd)); + } + return TCL_OK; } static Tcl_Obj * -computeLevelObj(Tcl_Interp *in, CallStackLevel level) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - XOTclCallStackContent *csc; - Tcl_Obj *resultObj; +computeLevelObj(Tcl_Interp *interp, CallStackLevel level) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc; + Tcl_Obj *resultObj; - switch (level) { - case CALLING_LEVEL: csc = XOTclCallStackFindLastInvocation(in, 1); break; - case ACTIVE_LEVEL: csc = XOTclCallStackFindActiveFrame(in, 1); break; - default: csc = NULL; - } + switch (level) { + case CALLING_LEVEL: csc = XOTclCallStackFindLastInvocation(interp, 1); break; + case ACTIVE_LEVEL: csc = XOTclCallStackFindActiveFrame(interp, 1); break; + default: csc = NULL; + } - if (cs->top->currentFramePtr == ((Tcl_CallFrame *)Tcl_Interp_varFramePtr(in)) - && csc && csc < cs->top && csc->currentFramePtr) { - /* this was from an xotcl frame, return absolute frame number */ - char buffer[LONG_AS_STRING]; - int l; - buffer[0] = '#'; - /* fprintf(stderr,"*** csc=%p\n",csc);*/ - XOTcl_ltoa(buffer+1,(long)Tcl_CallFrame_level(csc->currentFramePtr),&l); - resultObj = Tcl_NewStringObj(buffer,l+1); - } else { - /* If not called from an xotcl frame, return 1 as default */ - resultObj = Tcl_NewIntObj(1); - } - /*XOTclStackDump(in);XOTclCallStackDump(in);*/ + if (cs->top->currentFramePtr == ((Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp)) + && csc && csc < cs->top && csc->currentFramePtr) { + /* this was from an xotcl frame, return absolute frame number */ + char buffer[LONG_AS_STRING]; + int l; + buffer[0] = '#'; + /* fprintf(stderr,"*** csc=%p\n",csc);*/ + XOTcl_ltoa(buffer+1,(long)Tcl_CallFrame_level(csc->currentFramePtr),&l); + resultObj = Tcl_NewStringObj(buffer,l+1); + } else { + /* If not called from an xotcl frame, return 1 as default */ + resultObj = Tcl_NewIntObj(1); + } + /*XOTclStackDump(interp);XOTclCallStackDump(interp);*/ - return resultObj; + return resultObj; } static int -XOTclSelfSubCommand(Tcl_Interp *in, XOTclObject *obj, char *option) { - assert(option); +XOTclSelfSubCommand(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *option) { + int rc = TCL_OK; + int opt; + XOTclCallStackContent *csc = NULL; - if (isProcString(option)) { /* proc subcommand */ - char *procName = (char *) GetSelfProc(in); - if (procName) { - Tcl_SetResult(in, procName, TCL_VOLATILE); - return TCL_OK; - } else { - return XOTclVarErrMsg(in, "Can't find proc", (char *) NULL); + static CONST char *opts[] = { + "proc", "class", + "activelevel", "args", +#if defined(ACTIVEMIXIN) + "activemixin", +#endif + "calledproc", "calledmethod", + "calledclass", "callingproc", + "callingclass", "callinglevel", + "callingobject", "filterreg", + "isnextcall", "next", + NULL + }; + + enum selfOptionIdx { + procIdx, classIdx, + activelevelIdx, argsIdx, +#if defined(ACTIVEMIXIN) + activemixinIdx, +#endif + calledprocIdx, calledmethodIdx, + calledclassIdx, callingprocIdx, + callingclassIdx, callinglevelIdx, + callingobjectIdx, filterregIdx, + isnextcallIdx, nextIdx + }; + + assert(option); + + if (Tcl_GetIndexFromObj(interp, option, opts, "self option", 0, &opt) != TCL_OK) { + return TCL_ERROR; } - } else if (isClassString(option)) { /* class subcommand */ - XOTclClass *cl = GetSelfClass(in); - Tcl_SetObjResult(in, cl ? cl->object.cmdName : XOTclGlobalObjects[XOTE_EMPTY]); - return TCL_OK; - } else { - XOTclCallStackContent *csc = NULL; - switch (*option) { /* other callstack information */ - case 'a': - if (!strcmp(option, "activelevel")) { - Tcl_SetObjResult(in, computeLevelObj(in, ACTIVE_LEVEL)); - return TCL_OK; - } else if (!strcmp(option,"args")) { - int nobjc; - Tcl_Obj **nobjv; - csc = CallStackGetTopFrame(in); - nobjc = Tcl_CallFrame_objc(csc->currentFramePtr); - nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr); - Tcl_SetObjResult(in, Tcl_NewListObj(nobjc-1,nobjv+1)); - return TCL_OK; - } + if (!obj && opt != callinglevelIdx) { + return XOTclVarErrMsg(interp, "self: no current object", (char *) NULL); + } + + switch (opt) { + case procIdx: { /* proc subcommand */ + csc = CallStackGetTopFrame(interp); + if (csc->currentFramePtr) { + CONST char *procName = Tcl_GetCommandName(interp, (Tcl_Command)csc->cmdPtr); + Tcl_SetResult(interp, (char *)procName, TCL_VOLATILE); + } else { + char *procName = (char *)GetSelfProc(interp); + if (procName) { + Tcl_SetResult(interp, procName, TCL_VOLATILE); + } else { + rc = XOTclVarErrMsg(interp, "Can't find proc", (char *) NULL); + } + } + break; + } + case classIdx: { /* class subcommand */ + XOTclClass *cl = GetSelfClass(interp); + Tcl_SetObjResult(interp, cl ? cl->object.cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + break; + } + case activelevelIdx: { + Tcl_SetObjResult(interp, computeLevelObj(interp, ACTIVE_LEVEL)); + break; + } + case argsIdx: { + int nobjc; + Tcl_Obj **nobjv; + csc = CallStackGetTopFrame(interp); + nobjc = Tcl_CallFrame_objc(csc->currentFramePtr); + nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr); + Tcl_SetObjResult(interp, Tcl_NewListObj(nobjc-1,nobjv+1)); + break; + } #if defined(ACTIVEMIXIN) - else if (!strcmp(option, "activemixin")) { - 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[XOTE_EMPTY]); - return TCL_OK; - } + case activemixinIdx: { + XOTclObject *o = NULL; + csc = CallStackGetTopFrame(interp); + /*CmdListPrint(interp,"self a....\n", obj->mixinOrder); + fprintf(stderr,"current cmdPtr = %p cl = %p, mo=%p %p\n", csc->cmdPtr, csc->cl, + obj->mixinOrder, RUNTIME_STATE(interp)->cmdPtr);*/ + if (RUNTIME_STATE(interp)->cmdPtr) { + o = XOTclGetObjectFromCmdPtr(RUNTIME_STATE(interp)->cmdPtr); + } + Tcl_SetObjResult(interp, o ? o->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + break; + } #endif - break; - case 'c': - if (!strcmp(option, "calledproc")) { - if (!(csc = CallStackFindActiveFilter(in))) - return XOTclVarErrMsg(in, - "self calledproc called from outside of a filter", + case calledprocIdx: + case calledmethodIdx: { + if (!(csc = CallStackFindActiveFilter(interp))) + rc = XOTclVarErrMsg(interp, "self ",ObjStr(option)," called from outside of a filter", (char *) NULL); - Tcl_SetObjResult(in, csc->filterStackEntry->calledProc); - return TCL_OK; - } else if (!strcmp(option, "calledclass")) { - Tcl_SetResult(in, className(FindCalledClass(in, obj)), TCL_VOLATILE); - return TCL_OK; - } else if (!strcmp(option, "callingproc")) { - csc = XOTclCallStackFindLastInvocation(in, 1); - Tcl_SetResult(in, csc ? (char *)Tcl_GetCommandName(in, csc->cmdPtr) : "", - TCL_VOLATILE); - return TCL_OK; - } else if (!strcmp(option, "callingclass")) { - csc = XOTclCallStackFindLastInvocation(in, 1); - Tcl_SetObjResult(in, csc && csc->cl ? csc->cl->object.cmdName : - XOTclGlobalObjects[XOTE_EMPTY]); - return TCL_OK; - } else if (!strcmp(option, "callinglevel")) { - Tcl_SetObjResult(in, computeLevelObj(in, CALLING_LEVEL)); - return TCL_OK; - } else if (!strcmp(option, "callingobject")) { + else + Tcl_SetObjResult(interp, csc->filterStackEntry->calledProc); + break; - /*XOTclStackDump(in); XOTclCallStackDump(in);*/ + } + case calledclassIdx: + Tcl_SetResult(interp, className(FindCalledClass(interp, obj)), TCL_VOLATILE); + break; - csc = XOTclCallStackFindLastInvocation(in, 1); - Tcl_SetObjResult(in, csc ? csc->self->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); - return TCL_OK; - } - break; - - case 'f': - if (!strcmp(option, "filterreg")) { - if (!(csc = CallStackFindActiveFilter(in))) { - return XOTclVarErrMsg(in, + case callingprocIdx: + csc = XOTclCallStackFindLastInvocation(interp, 1); + Tcl_SetResult(interp, csc ? (char *)Tcl_GetCommandName(interp, csc->cmdPtr) : "", + TCL_VOLATILE); + break; + + case callingclassIdx: + csc = XOTclCallStackFindLastInvocation(interp, 1); + Tcl_SetObjResult(interp, csc && csc->cl ? csc->cl->object.cmdName : + XOTclGlobalObjects[XOTE_EMPTY]); + break; + + case callinglevelIdx: + if (!obj) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetObjResult(interp, computeLevelObj(interp, CALLING_LEVEL)); + } + break; + + case callingobjectIdx: + csc = XOTclCallStackFindLastInvocation(interp, 1); + Tcl_SetObjResult(interp, csc ? csc->self->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + break; + + case filterregIdx: + if (!(csc = CallStackFindActiveFilter(interp))) { + rc = XOTclVarErrMsg(interp, "self filterreg called from outside of a filter", (char *) NULL); - } - Tcl_SetObjResult(in, FilterFindReg(in, obj, GetSelfProcCmdPtr(in))); - return TCL_OK; - } - break; + } else + Tcl_SetObjResult(interp, FilterFindReg(interp, obj, GetSelfProcCmdPtr(interp))); + break; - case 'i': - if (!strcmp(option, "isnextcall")) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - csc = cs->top; - csc--; - Tcl_SetBooleanObj(Tcl_GetObjResult(in), - (csc > cs->content && - (csc->callType & XOTCL_CSC_CALL_IS_NEXT))); - return TCL_OK; - } - break; - - case 'n': - if (!strcmp(option, "next")) - return FindSelfNext(in, obj); - break; + case isnextcallIdx: { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + csc = cs->top; + csc--; + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (csc > cs->content && + (csc->callType & XOTCL_CSC_CALL_IS_NEXT))); + break; } - } - return XOTclVarErrMsg(in, "unknown option '", option, - "' for self", (char *) NULL); -} + case nextIdx: + rc = FindSelfNext(interp, obj); + break; + } -/* -int -XOTclKObjCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - if (objc < 2) - return XOTclVarErrMsg(in, "wrong # of args for K", (char *) NULL); - - Tcl_SetObjResult(in, objv[1]); - return TCL_OK; + return rc; } -*/ int -XOTclGetSelfObjCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; +XOTclGetSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + int rc; - if (objc > 2) - return XOTclVarErrMsg(in, "wrong # of args for self", (char *) NULL); + if (objc > 2) + return XOTclVarErrMsg(interp, "wrong # of args for self", (char *) NULL); - obj = GetSelfObj(in); + obj = GetSelfObj(interp); - /*fprintf(stderr,"getSelfObj returns %p\n",obj);XOTclCallStackDump(in);*/ + /*fprintf(stderr,"getSelfObj returns %p\n",obj);XOTclCallStackDump(interp);*/ - if (!obj) { - if (objc == 2 && !strcmp(ObjStr(objv[1]),"callinglevel")) { - Tcl_SetIntObj(Tcl_GetObjResult(in), 1); - return TCL_OK; + if (objc == 1) { + if (obj) { + Tcl_SetObjResult(interp, obj->cmdName); + rc = TCL_OK; + } else { + rc = XOTclVarErrMsg(interp, "self: no current object", (char *) NULL); + } } else { - return XOTclVarErrMsg(in, "self: no current object", (char *) NULL); + rc = XOTclSelfSubCommand(interp, obj, objv[1]); } - } - - if (objc == 1) { - Tcl_SetObjResult(in, obj->cmdName); - return TCL_OK; - } else { - return XOTclSelfSubCommand(in, obj, ObjStr(objv[1])); - } + return rc; } /* * object creation & destruction */ -static int -unsetInAllNamespaces(Tcl_Interp *in, Namespace *nsPtr, char *name) { - int rc = 0; - fprintf(stderr, "### unsetInAllNamespaces %s\n",name); - if (nsPtr != NULL) { - Tcl_HashSearch search; - Tcl_HashEntry *entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - Tcl_Var *varPtr; - int rc = 0; - - varPtr = (Tcl_Var *) Tcl_FindNamespaceVar(in, name, (Tcl_Namespace *) nsPtr, 0); - /*fprintf(stderr, "found %s in %s -> %p\n",name, nsPtr->fullName, varPtr);*/ - if (varPtr) { - Tcl_DString dFullname, *dsPtr = &dFullname; - Tcl_DStringInit(dsPtr); - Tcl_DStringAppend(dsPtr, "unset ", -1); - Tcl_DStringAppend(dsPtr, nsPtr->fullName, -1); - Tcl_DStringAppend(dsPtr, "::", 2); - Tcl_DStringAppend(dsPtr, name, -1); - /*rc = Tcl_UnsetVar2(in, Tcl_DStringValue(dsPtr), NULL, TCL_LEAVE_ERR_MSG);*/ - rc = Tcl_Eval(in, Tcl_DStringValue(dsPtr)); - /* fprintf(stderr, "fqName = '%s' unset => %d %d\n",Tcl_DStringValue(dsPtr), rc, TCL_OK);*/ - if (rc == TCL_OK) { - rc = 1; - } else { - Tcl_Obj *resultObj = Tcl_GetObjResult(in); - fprintf(stderr, " err = '%s'\n", ObjStr(resultObj)); - } - Tcl_DStringFree(dsPtr); - } - - while (entryPtr != NULL) { - Namespace *childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); - /*fprintf(stderr, "child = %s\n", childNsPtr->fullName);*/ - entryPtr = Tcl_NextHashEntry(&search); - rc |= unsetInAllNamespaces(in, childNsPtr, name); - } - } - return rc; -} - -static int -freeUnsetTraceVariable(Tcl_Interp *in, XOTclObject *obj) { - int rc = TCL_OK; - if (obj->opt && obj->opt->volatileVarName) { - /* - Somebody destroys a volatile object manually while - the vartrace is still active. Destroying the object will - be a problem in case the variable is deleted later - and fires the trace. So, we unset the variable here - which will cause a destroy via var trace, which in - turn clears the volatileVarName flag. - */ - /*fprintf(stderr,"### freeUnsetTraceVariable %s\n", obj->opt->volatileVarName);*/ - - rc = Tcl_UnsetVar2(in, obj->opt->volatileVarName, NULL, 0); - if (rc != TCL_OK) { - int rc = Tcl_UnsetVar2(in, obj->opt->volatileVarName, NULL, TCL_GLOBAL_ONLY); - if (rc != TCL_OK) { - Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(in); - if (unsetInAllNamespaces(in, nsPtr, obj->opt->volatileVarName) == 0) { - fprintf(stderr, "### don't know how to delete variable '%s' of volatile object\n", - obj->opt->volatileVarName); - } - } - } - if (rc == TCL_OK) { - /*fprintf(stderr, "### success unset\n");*/ - } - } - return rc; -} - -static char * -XOTclUnsetTrace(ClientData cd, Tcl_Interp *in, CONST84 char *name, CONST84 char *name2, int flags) -{ - Tcl_Obj *obj = (Tcl_Obj *)cd; - XOTclObject *o; - char *result = NULL; - - /*fprintf(stderr,"XOTclUnsetTrace %s flags %x %x\n", name, flags, - flags & TCL_INTERP_DESTROYED); */ - - if ((flags & TCL_INTERP_DESTROYED) == 0) { - if (XOTclObjConvertObject(in, obj, &o) == TCL_OK) { - Tcl_Obj *res = Tcl_GetObjResult(in); /* save the result */ - INCR_REF_COUNT(res); - - /* clear variable, destroy is called from trace */ - if (o->opt && o->opt->volatileVarName) { - o->opt->volatileVarName = NULL; - } - - if (callMethod((ClientData)o, in, XOTclGlobalObjects[XOTE_DESTROY],2,0,0) != TCL_OK) { - result = "Destroy for volatile object failed"; - } else - result = "No XOTcl Object passed"; - - Tcl_SetObjResult(in, res); /* restore the result */ - DECR_REF_COUNT(res); - } - DECR_REF_COUNT(obj); - } else { - /*fprintf(stderr, "omitting destroy on %s %p\n", name);*/ - } - return result; -} - /* * mark an obj on the existing callstack, as not destroyed */ static void -UndestroyObj(Tcl_Interp *in, XOTclObject *obj) { - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - XOTclCallStackContent *csc; +UndestroyObj(Tcl_Interp *interp, XOTclObject *obj) { + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc; - /* - * mark the object on the whole callstack as not destroyed - */ - for (csc = &cs->content[1]; csc <= cs->top; csc++) { - if (obj == csc->self && csc->destroyedCmd) { - /* - * The ref count was incremented, when csc->destroyedCmd - * was set. We revert this first before forgetting the - * destroyedCmd. - */ - if (Tcl_Command_refCount(csc->destroyedCmd) > 1) { - Tcl_Command_refCount(csc->destroyedCmd)--; - MEM_COUNT_FREE("command refCount",csc->destroyedCmd); - } - csc->destroyedCmd = 0; + /* + * mark the object on the whole callstack as not destroyed + */ + for (csc = &cs->content[1]; csc <= cs->top; csc++) { + if (obj == csc->self && csc->destroyedCmd) { + /* + * The ref count was incremented, when csc->destroyedCmd + * was set. We revert this first before forgetting the + * destroyedCmd. + */ + if (Tcl_Command_refCount(csc->destroyedCmd) > 1) { + Tcl_Command_refCount(csc->destroyedCmd)--; + MEM_COUNT_FREE("command refCount",csc->destroyedCmd); + } + csc->destroyedCmd = 0; + } } - } - /* - * mark obj->flags XOTCL_DESTROY_CALLED as NOT CALLED (0) - */ - obj->flags &= ~XOTCL_DESTROY_CALLED; + /* + * mark obj->flags XOTCL_DESTROY_CALLED as NOT CALLED (0) + */ + obj->flags &= ~XOTCL_DESTROY_CALLED; } /* * bring an object into a state, as after initialization */ static void -CleanupDestroyObject(Tcl_Interp *in, XOTclObject *obj, int softrecreate) { - XOTclClass *thecls, *theobj; +CleanupDestroyObject(Tcl_Interp *interp, XOTclObject *obj, int softrecreate) { + XOTclClass *thecls, *theobj; - thecls = RUNTIME_STATE(in)->theClass; - theobj = RUNTIME_STATE(in)->theObject; - /* remove the instance, but not for ::Class/::Object */ - if (obj != &(thecls->object) && obj != &(theobj->object)) { + thecls = RUNTIME_STATE(interp)->theClass; + theobj = RUNTIME_STATE(interp)->theObject; + /* remove the instance, but not for ::Class/::Object */ + if (obj != &(thecls->object) && obj != &(theobj->object)) { - if (!softrecreate) { - (void)RemoveInstance(obj, obj->cl); + if (!softrecreate) { + (void)RemoveInstance(obj, obj->cl); + } } - } - if (obj->nsPtr) { - NSCleanupNamespace(in, obj->nsPtr); - NSDeleteChildren(in, obj->nsPtr); - } + if (obj->nsPtr) { + NSCleanupNamespace(interp, obj->nsPtr); + NSDeleteChildren(interp, obj->nsPtr); + } - if (obj->varTable) { - TclDeleteVars(((Interp *)in), obj->varTable); - ckfree((char *)obj->varTable); - /* - FREE(obj->varTable, obj->varTable);*/ - obj->varTable = 0; - } + if (obj->varTable) { + TclDeleteVars((Interp *)interp, obj->varTable); + ckfree((char *)obj->varTable); + /* FREE(obj->varTable, obj->varTable);*/ + obj->varTable = 0; + } - if (obj->opt) { - XOTclObjectOpt *opt = obj->opt; - AssertionRemoveStore(opt->assertions); - opt->assertions = NULL; + if (obj->opt) { + XOTclObjectOpt *opt = obj->opt; + AssertionRemoveStore(opt->assertions); + opt->assertions = NULL; #ifdef XOTCL_METADATA - XOTclMetaDataDestroy(obj); + XOTclMetaDataDestroy(obj); #endif - if (!softrecreate) { - CmdListRemoveList(&opt->mixins, GuardDel); - CmdListRemoveList(&opt->filters, GuardDel); + if (!softrecreate) { + CmdListRemoveList(&opt->mixins, GuardDel); + CmdListRemoveList(&opt->filters, GuardDel); - FREE(XOTclObjectOpt,opt); - opt = obj->opt = 0; + FREE(XOTclObjectOpt,opt); + opt = obj->opt = 0; + } } - } - if (obj->nonposArgsTable) { - NonposArgsFreeTable(obj->nonposArgsTable); - Tcl_DeleteHashTable(obj->nonposArgsTable); - MEM_COUNT_FREE("Tcl_InitHashTable", obj->nonposArgsTable); - ckfree((char *) obj->nonposArgsTable); - MEM_COUNT_FREE("Tcl_HashTable",obj->nonposArgsTable); - } + if (obj->nonposArgsTable) { + NonposArgsFreeTable(obj->nonposArgsTable); + Tcl_DeleteHashTable(obj->nonposArgsTable); + MEM_COUNT_FREE("Tcl_InitHashTable", obj->nonposArgsTable); + ckfree((char *) obj->nonposArgsTable); + MEM_COUNT_FREE("Tcl_HashTable",obj->nonposArgsTable); + } - obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; - if (obj->mixinOrder) MixinResetOrder(obj); - obj->flags &= ~XOTCL_FILTER_ORDER_VALID; - if (obj->filterOrder) FilterResetOrder(obj); + obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + if (obj->mixinOrder) MixinResetOrder(obj); + obj->flags &= ~XOTCL_FILTER_ORDER_VALID; + if (obj->filterOrder) FilterResetOrder(obj); } /* * do obj initialization & namespace creation */ static void -CleanupInitObject(Tcl_Interp *in, XOTclObject *obj, +CleanupInitObject(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl, Tcl_Namespace *namespacePtr, int softrecreate) { #ifdef OBJDELETION_TRACE - fprintf(stderr,"+++ CleanupInitObject\n"); + fprintf(stderr,"+++ CleanupInitObject\n"); #endif - obj->teardown = in; - obj->nsPtr = namespacePtr; - if (!softrecreate) { - AddInstance(obj, cl); - } - if (obj->flags & XOTCL_RECREATE) { - obj->opt = 0; - obj->varTable = 0; - obj->nonposArgsTable = 0; - obj->mixinOrder = 0; - obj->filterOrder = 0; - obj->flags = 0; - } + obj->teardown = interp; + obj->nsPtr = namespacePtr; + if (!softrecreate) { + AddInstance(obj, cl); + } + if (obj->flags & XOTCL_RECREATE) { + obj->opt = 0; + obj->varTable = 0; + obj->nonposArgsTable = 0; + obj->mixinOrder = 0; + obj->filterOrder = 0; + obj->flags = 0; + } + /* + fprintf(stderr, "cleanupInitObject %s: %p cl = %p\n", + obj->cmdName ? ObjStr(obj->cmdName) : "", obj, obj->cl);*/ } /* * physical object destroy */ static void -PrimitiveODestroy(ClientData cd) { - XOTclObject *obj = (XOTclObject*)cd; - Tcl_Interp *in; +PrimitiveODestroy(ClientData clientData) { + XOTclObject *obj = (XOTclObject*)clientData; + Tcl_Interp *interp; + Tcl_Command cmd; - /*fprintf(stderr, "****** PrimitiveODestroy %p\n",obj);*/ - assert(obj && !(obj->flags & XOTCL_DESTROYED)); + /*fprintf(stderr, "****** PrimitiveODestroy %p\n",obj);*/ + assert(obj && !(obj->flags & XOTCL_DESTROYED)); - /* - * check and latch against recurrent calls with obj->teardown - */ - PRINTOBJ("PrimitiveODestroy", obj); + /* + * check and latch against recurrent calls with obj->teardown + */ + PRINTOBJ("PrimitiveODestroy", obj); - if (!obj || !obj->teardown) return; - in = obj->teardown; - obj->teardown = 0; + if (!obj || !obj->teardown) return; + interp = obj->teardown; + obj->teardown = 0; - /* - * Don't destroy, if the interpreter is destroyed already - * e.g. TK calls Tcl_DeleteInterp directly, if the window is killed - */ - if (Tcl_InterpDeleted(in)) return; - /* - * call and latch user destroy with obj->id if we haven't - */ - if (!(obj->flags & XOTCL_DESTROY_CALLED)) { - callDestroyMethod(cd, in, obj, 0); - obj->id = 0; - } + /* + * Don't destroy, if the interpreter is destroyed already + * e.g. TK calls Tcl_DeleteInterp directly, if the window is killed + */ + if (Tcl_InterpDeleted(interp)) return; + /* + * call and latch user destroy with obj->id if we haven't + */ + if (!(obj->flags & XOTCL_DESTROY_CALLED)) { + callDestroyMethod(clientData, interp, obj, 0); + obj->id = 0; + } #ifdef OBJDELETION_TRACE - fprintf(stderr," physical delete of %p id=%p destroyCalled=%d '%s'\n", - obj, obj->id, (obj->flags & XOTCL_DESTROY_CALLED), ObjStr(obj->cmdName)); + fprintf(stderr," physical delete of %p id=%p destroyCalled=%d '%s'\n", + obj, obj->id, (obj->flags & XOTCL_DESTROY_CALLED), ObjStr(obj->cmdName)); #endif - CleanupDestroyObject(in, obj, 0); + CleanupDestroyObject(interp, obj, 0); - while (obj->mixinStack != NULL) - MixinStackPop(obj); - while (obj->filterStack != NULL) - FilterStackPop(obj); + while (obj->mixinStack != NULL) + MixinStackPop(obj); + while (obj->filterStack != NULL) + FilterStackPop(obj); -#if 0 - { - /* Prevent that PrimitiveODestroy is called more than once. - This code was used in earlier versions of XOTcl - but does not seem necessary any more. If it has to be used - again in the future, don't use Tcl_GetCommandFromObj() - in Tcl 8.4.* versions. - */ - Tcl_Command cmd = Tcl_FindCommand(in, ObjStr(obj->cmdName), 0, 0); + cmd = Tcl_GetCommandFromObj(interp, obj->cmdName); - if (cmd != NULL) - Tcl_Command_deleteProc(cmd) = 0; - } -#endif + if (cmd != NULL) + Tcl_Command_deleteProc(cmd) = 0; - if (obj->nsPtr) { - /*fprintf(stderr,"primitive odestroy calls deletenamespace for obj %p\n",obj);*/ - XOTcl_DeleteNamespace(in, obj->nsPtr); - obj->nsPtr = 0; - } + if (obj->nsPtr) { + /*fprintf(stderr,"primitive odestroy calls deletenamespace for obj %p\n",obj);*/ + XOTcl_DeleteNamespace(interp, obj->nsPtr); + obj->nsPtr = 0; + } - /*fprintf(stderr, " +++ OBJ/CLS free: %s\n", ObjStr(obj->cmdName));*/ + /*fprintf(stderr, " +++ OBJ/CLS free: %s\n", ObjStr(obj->cmdName));*/ - obj->flags |= XOTCL_DESTROYED; - objTrace("ODestroy", obj); + obj->flags |= XOTCL_DESTROYED; + objTrace("ODestroy", obj); #if REFCOUNT_TRACE - fprintf(stderr,"ODestroy %p flags %d rc %d destr %d dc %d\n", + fprintf(stderr,"ODestroy %p flags %d rc %d destr %d dc %d\n", obj, obj->flags, (obj->flags & XOTCL_REFCOUNTED) != 0, (obj->flags & XOTCL_DESTROYED) != 0, (obj->flags & XOTCL_DESTROY_CALLED) != 0 ); #endif #if REFCOUNTED - if (!(obj->flags & XOTCL_REFCOUNTED)) { - DECR_REF_COUNT(obj->cmdName); - } + if (!(obj->flags & XOTCL_REFCOUNTED)) { + DECR_REF_COUNT(obj->cmdName); + } #else - DECR_REF_COUNT(obj->cmdName); + DECR_REF_COUNT(obj->cmdName); #endif - XOTclCleanupObject(obj); + XOTclCleanupObject(obj); #if !defined(NDEBUG) - if (obj != (XOTclObject*)RUNTIME_STATE(in)->theClass) - checkAllInstances(in, RUNTIME_STATE(in)->theClass,0); + if (obj != (XOTclObject*)RUNTIME_STATE(interp)->theClass) + checkAllInstances(interp, RUNTIME_STATE(interp)->theClass,0); #endif } static void -PrimitiveOInit(void* mem, Tcl_Interp *in, char *name, XOTclClass *cl) { - XOTclObject *obj = (XOTclObject*)mem; +PrimitiveOInit(void *mem, Tcl_Interp *interp, char *name, XOTclClass *cl) { + XOTclObject *obj = (XOTclObject*)mem; #ifdef OBJDELETION_TRACE - fprintf(stderr,"+++ PrimitiveOInit\n"); + fprintf(stderr,"+++ PrimitiveOInit\n"); #endif #ifdef XOTCLOBJ_TRACE - fprintf(stderr, "OINIT %s = %p\n", name, obj); + fprintf(stderr, "OINIT %s = %p\n", name, obj); #endif - XOTclObjectRefCountIncr(obj); + XOTclObjectRefCountIncr(obj); - /* if the command of the obj was used before, we have to clean - * up the callstack from set "destroyedCmd" flags - */ - UndestroyObj(in, obj); + /* if the command of the obj was used before, we have to clean + * up the callstack from set "destroyedCmd" flags + */ + UndestroyObj(interp, obj); - if (Tcl_FindNamespace(in, name, NULL, 0)) { - CleanupInitObject(in, obj, cl, - NSGetFreshNamespace(in, (ClientData)obj, name), 0); - } else { - CleanupInitObject(in, obj, cl, NULL, 0); - } - /*obj->flags = XOTCL_MIXIN_ORDER_VALID | XOTCL_FILTER_ORDER_VALID;*/ - obj->mixinStack = 0; - obj->filterStack = 0; + if (Tcl_FindNamespace(interp, name, NULL, 0)) { + CleanupInitObject(interp, obj, cl, + NSGetFreshNamespace(interp, (ClientData)obj, name), 0); + } else { + CleanupInitObject(interp, obj, cl, NULL, 0); + } + /*obj->flags = XOTCL_MIXIN_ORDER_VALID | XOTCL_FILTER_ORDER_VALID;*/ + obj->mixinStack = 0; + obj->filterStack = 0; } /* * Object creation: create object name (full name) and Tcl command */ static XOTclObject* -PrimitiveOCreate(Tcl_Interp *in, char *name, XOTclClass *cl) { - XOTclObject *obj = (XOTclObject*)ckalloc(sizeof(XOTclObject)); - unsigned length; +PrimitiveOCreate(Tcl_Interp *interp, char *name, XOTclClass *cl) { + XOTclObject *obj = (XOTclObject*)ckalloc(sizeof(XOTclObject)); + unsigned length; - /*fprintf(stderr, "CKALLOC Object %p %s\n", obj, name);*/ + /*fprintf(stderr, "CKALLOC Object %p %s\n", obj, name);*/ #if defined(XOTCLOBJ_TRACE) - fprintf(stderr, "CKALLOC Object %p %s\n", obj, name); + fprintf(stderr, "CKALLOC Object %p %s\n", obj, name); #endif #ifdef OBJDELETION_TRACE - fprintf(stderr,"+++ PrimitiveOCreate\n"); + fprintf(stderr,"+++ PrimitiveOCreate\n"); #endif - memset(obj, 0, sizeof(XOTclObject)); - MEM_COUNT_ALLOC("XOTclObject/XOTclClass",obj); - assert(obj); /* ckalloc panics, if malloc fails */ - assert(isAbsolutePath(name)); + memset(obj, 0, sizeof(XOTclObject)); + MEM_COUNT_ALLOC("XOTclObject/XOTclClass",obj); + assert(obj); /* ckalloc panics, if malloc fails */ + assert(isAbsolutePath(name)); - length = strlen(name); - if (!NSCheckForParent(in, name, length)) { - ckfree((char *) obj); - return 0; - } - obj->id = Tcl_CreateObjCommand(in, name, XOTclObjDispatch, - (ClientData)obj, PrimitiveODestroy); + length = strlen(name); + if (!NSCheckForParent(interp, name, length)) { + ckfree((char *) obj); + return 0; + } + obj->id = Tcl_CreateObjCommand(interp, name, XOTclObjDispatch, + (ClientData)obj, PrimitiveODestroy); - PrimitiveOInit(obj, in, name, cl); + PrimitiveOInit(obj, interp, name, cl); #if 0 - /*defined(KEEP_TCL_CMD_TYPE)*/ - /*TclNewObj(obj->cmdName);*/ - obj->cmdName = Tcl_NewStringObj(name,length); - TclSetCmdNameObj(in, obj->cmdName, (Command*)obj->id); - /*fprintf(stderr, "new command has name '%s'\n", ObjStr(obj->cmdName));*/ + /*defined(KEEP_TCL_CMD_TYPE)*/ + /*TclNewObj(obj->cmdName);*/ + obj->cmdName = Tcl_NewStringObj(name,length); + TclSetCmdNameObj(interp, obj->cmdName, (Command*)obj->id); + /*fprintf(stderr, "new command has name '%s'\n", ObjStr(obj->cmdName));*/ #else - obj->cmdName = NewXOTclObjectObjName(obj, name, length); + obj->cmdName = NewXOTclObjectObjName(obj, name, length); #endif - INCR_REF_COUNT(obj->cmdName); + INCR_REF_COUNT(obj->cmdName); - objTrace("PrimitiveOCreate", obj); + objTrace("PrimitiveOCreate", obj); - return obj; + return obj; } +static XOTclClass *DefaultSuperClass(Tcl_Interp *interp, XOTclClass *cl, XOTclClass *topcl) { + XOTclObject *obj = (XOTclObject*)cl; + XOTclClass *defaultClass = topcl; + if (obj->cl) { + int result; + /*fprintf(stderr, "mcl= %s\n", ObjStr(obj->cl->object.cmdName));*/ + result = setInstVar(interp, (XOTclObject *)obj->cl, + XOTclGlobalObjects[XOTE_DEFAULTSUPERCLASS], NULL); + if (result == TCL_OK) { + Tcl_Obj *nameObj = Tcl_GetObjResult(interp); + if (GetXOTclClassFromObj(interp, nameObj, &defaultClass, 0) != TCL_OK) { + XOTclErrMsg(interp, "default superclass is not a class", TCL_STATIC); + } + } else { + Tcl_Obj *bootstrap = Tcl_GetVar2Ex(interp, "::xotcl::bootstrap", NULL, + TCL_GLOBAL_ONLY); + if (bootstrap) { + Tcl_Obj *nameObj = Tcl_NewStringObj("::xotcl::Object", -1); + INCR_REF_COUNT(nameObj); + if (GetXOTclClassFromObj(interp, nameObj, &defaultClass, 0) != TCL_OK) { + XOTclErrMsg(interp, "default superclass is not a class", TCL_STATIC); + } + DECR_REF_COUNT(nameObj); + } else { + /*fprintf(stderr, "no default_superclass for cl %s found, returning %s\n", + ObjStr(cl->object.cmdName), + ObjStr(defaultClass->object.cmdName));*/ + } + } + } else { + /* during bootstrapping, there might be no meta class defined yet */ + /*fprintf(stderr, "no meta class\n");*/ + } + return defaultClass; +} + /* * Cleanup class: remove filters, mixins, assertions, instances ... * and remove class from class hierarchy */ static void -CleanupDestroyClass(Tcl_Interp *in, XOTclClass *cl, int softrecreate) { - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr; - XOTclClass *theobj = RUNTIME_STATE(in)->theObject; - XOTclObject *obj = (XOTclObject*)cl; - XOTclClassOpt* opt = cl->opt; +CleanupDestroyClass(Tcl_Interp *interp, XOTclClass *cl, int softrecreate) { + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + XOTclClass *theobj = RUNTIME_STATE(interp)->theObject; + XOTclObject *obj = (XOTclObject*)cl; + XOTclClassOpt *opt = cl->opt; + XOTclClass *defaultClass = NULL; - if (opt) { - CmdListRemoveList(&opt->instmixins, GuardDel); - MixinInvalidateObjOrders(in, cl); + if (opt) { + CmdListRemoveList(&opt->instmixins, GuardDel); + MixinInvalidateObjOrders(interp, cl); - CmdListRemoveList(&opt->instfilters, GuardDel); - FilterInvalidateObjOrders(in, cl); + CmdListRemoveList(&opt->instfilters, GuardDel); + FilterInvalidateObjOrders(interp, cl); - /* remove dependent filters of this class from all subclasses*/ - FilterRemoveDependentFilterCmds(cl, cl); - AssertionRemoveStore(opt->assertions); + /* remove dependent filters of this class from all subclasses*/ + FilterRemoveDependentFilterCmds(cl, cl); + AssertionRemoveStore(opt->assertions); #ifdef XOTCL_OBJECTDATA - XOTclFreeObjectData(cl); + XOTclFreeObjectData(cl); #endif - } + } - Tcl_ForgetImport(in, cl->nsPtr, "*"); /* don't destroy namespace imported objects */ - NSCleanupNamespace(in, cl->nsPtr); - NSDeleteChildren(in, cl->nsPtr); + Tcl_ForgetImport(interp, cl->nsPtr, "*"); /* don't destroy namespace imported objects */ + NSCleanupNamespace(interp, cl->nsPtr); + NSDeleteChildren(interp, cl->nsPtr); - if (!softrecreate) { - /* reset all instances to the class ::xotcl::Object, that makes no sense - for ::Object itself */ - if (cl != theobj) { - hPtr = &cl->instances ? Tcl_FirstHashEntry(&cl->instances, &hSrch) : 0; - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - XOTclObject *inst = (XOTclObject*)Tcl_GetHashKey(&cl->instances, hPtr); - if (inst && (inst != (XOTclObject*)cl) && inst->id) { - if (inst != &(theobj->object)) { - (void)RemoveInstance(inst, obj->cl); - AddInstance(inst, theobj); - } - } - } + if (!softrecreate) { + defaultClass = DefaultSuperClass(interp, cl, RUNTIME_STATE(interp)->theObject); + /* reset all instances to the class ::xotcl::Object, that makes no sense + for ::Object itself */ + if (cl != theobj) { + hPtr = &cl->instances ? Tcl_FirstHashEntry(&cl->instances, &hSrch) : 0; + for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { + XOTclObject *inst = (XOTclObject*)Tcl_GetHashKey(&cl->instances, hPtr); + if (inst && (inst != (XOTclObject*)cl) && inst->id) { + if (inst != &(theobj->object)) { + (void)RemoveInstance(inst, obj->cl); + AddInstance(inst, defaultClass); + } + } + } + } + Tcl_DeleteHashTable(&cl->instances); + MEM_COUNT_FREE("Tcl_InitHashTable",&cl->instances); } - Tcl_DeleteHashTable(&cl->instances); - MEM_COUNT_FREE("Tcl_InitHashTable",&cl->instances); - } - if (cl->nonposArgsTable) { - NonposArgsFreeTable(cl->nonposArgsTable); - Tcl_DeleteHashTable(cl->nonposArgsTable); - MEM_COUNT_FREE("Tcl_InitHashTable", cl->nonposArgsTable); - ckfree((char *) cl->nonposArgsTable); - MEM_COUNT_FREE("Tcl_HashTable",cl->nonposArgsTable); - } + if (cl->nonposArgsTable) { + NonposArgsFreeTable(cl->nonposArgsTable); + Tcl_DeleteHashTable(cl->nonposArgsTable); + MEM_COUNT_FREE("Tcl_InitHashTable", cl->nonposArgsTable); + ckfree((char *) cl->nonposArgsTable); + MEM_COUNT_FREE("Tcl_HashTable",cl->nonposArgsTable); + } - if (cl->parameters) { - DECR_REF_COUNT(cl->parameters); - } + if (cl->parameters) { + DECR_REF_COUNT(cl->parameters); + } - if (opt) { - if (opt->parameterClass) { - DECR_REF_COUNT(opt->parameterClass); + if (opt) { + if (opt->parameterClass) { + DECR_REF_COUNT(opt->parameterClass); + } + FREE(XOTclClassOpt, opt); + opt = cl->opt = 0; } - FREE(XOTclClassOpt, opt); - opt = cl->opt = 0; - } - if (!softrecreate) { - /* - * flush all caches, unlink superclasses - */ + if (!softrecreate) { + /* + * flush all caches, unlink superclasses + */ - FlushPrecedences(cl); - while (cl->sub) { - XOTclClass *subClass = cl->sub->cl; - (void)RemoveSuper(subClass, cl); - /* if there are no more super classes add the Object - * class as superclasses - * -> don't do that for Object itself! - */ - if (subClass->super == 0 && cl != theobj) - AddSuper(subClass, theobj); + FlushPrecedences(cl); + while (cl->sub) { + XOTclClass *subClass = cl->sub->cl; + (void)RemoveSuper(subClass, cl); + /* if there are no more super classes add the Object + * class as superclasses + * -> don't do that for Object itself! + */ + if (subClass->super == 0 && cl != theobj) + AddSuper(subClass, defaultClass); + } + while (cl->super) + (void)RemoveSuper(cl, cl->super->cl); } - while (cl->super) (void)RemoveSuper(cl, cl->super->cl); - } } + /* * do class initialization & namespace creation */ static void -CleanupInitClass(Tcl_Interp *in, XOTclClass *cl, Tcl_Namespace *namespacePtr, +CleanupInitClass(Tcl_Interp *interp, XOTclClass *cl, Tcl_Namespace *namespacePtr, int softrecreate) { - XOTclObject *obj = (XOTclObject*)cl; + XOTclObject *obj = (XOTclObject*)cl; + XOTclClass *defaultSuperclass = RUNTIME_STATE(interp)->theObject; + /* fprintf(stderr,"+++ CleanupInitClass\n"); */ #ifdef OBJDELETION_TRACE - fprintf(stderr,"+++ CleanupInitClass\n"); + fprintf(stderr,"+++ CleanupInitClass\n"); #endif - /* - * during init of Object and Class the theClass value is not set - */ - /* - if (RUNTIME_STATE(in)->theClass != 0) - obj->type = RUNTIME_STATE(in)->theClass; - */ - XOTclObjectSetClass(obj); + /* + * during init of Object and Class the theClass value is not set + */ + /* + if (RUNTIME_STATE(interp)->theClass != 0) + obj->type = RUNTIME_STATE(interp)->theClass; + */ + XOTclObjectSetClass(obj); - cl->nsPtr = namespacePtr; + cl->nsPtr = namespacePtr; + cl->super = 0; + cl->sub = 0; + /* Look for a configured default superclass */ + defaultSuperclass = DefaultSuperClass(interp,cl,RUNTIME_STATE(interp)->theObject); - cl->super = 0; - cl->sub = 0; - AddSuper(cl, RUNTIME_STATE(in)->theObject); - cl->parent = RUNTIME_STATE(in)->theObject; - cl->color = WHITE; - cl->order = 0; - cl->parameters = 0; + /* + if (defaultSuperclass) { + fprintf(stderr, "default superclass= %s\n", ObjStr(defaultSuperclass->object.cmdName)); + } else { + fprintf(stderr, "empty super class\n"); + }*/ - if (!softrecreate) { - Tcl_InitHashTable(&cl->instances, TCL_ONE_WORD_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable",&cl->instances); - } + AddSuper(cl, defaultSuperclass); + cl->color = WHITE; + cl->order = 0; + cl->parameters = 0; - cl->opt = 0; - cl->nonposArgsTable = 0; + if (!softrecreate) { + Tcl_InitHashTable(&cl->instances, TCL_ONE_WORD_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable",&cl->instances); + } + + cl->opt = 0; + cl->nonposArgsTable = 0; } /* * class physical destruction */ static void -PrimitiveCDestroy(ClientData cd) { - XOTclClass *cl = (XOTclClass*)cd; - XOTclObject *obj = (XOTclObject*)cd; - Tcl_Interp *in; - Tcl_Namespace* saved; +PrimitiveCDestroy(ClientData clientData) { + XOTclClass *cl = (XOTclClass*)clientData; + XOTclObject *obj = (XOTclObject*)clientData; + Tcl_Interp *interp; + Tcl_Namespace *saved; - /* - * check and latch against recurrent calls with obj->teardown - */ - if (!obj || !obj->teardown) return; - in = obj->teardown; + /* + * check and latch against recurrent calls with obj->teardown + */ + if (!obj || !obj->teardown) return; + interp = obj->teardown; - /* - * Don't destroy, if the interpreted is destroyed already - * e.g. TK calls Tcl_DeleteInterp directly, if Window is killed - */ - if (Tcl_InterpDeleted(in)) return; + /* + * Don't destroy, if the interpreted is destroyed already + * e.g. TK calls Tcl_DeleteInterp directly, if Window is killed + */ + if (Tcl_InterpDeleted(interp)) return; - /* - * call and latch user destroy with obj->id if we haven't - */ - /*fprintf(stderr,"PrimitiveCDestroy %s flags %x\n",ObjStr(obj->cmdName),obj->flags);*/ - if (!(obj->flags & XOTCL_DESTROY_CALLED)) - /*fprintf(stderr,"PrimitiveCDestroy call destroy\n");*/ - callDestroyMethod(cd, in, obj, 0); + /* + * call and latch user destroy with obj->id if we haven't + */ + /*fprintf(stderr,"PrimitiveCDestroy %s flags %x\n",ObjStr(obj->cmdName),obj->flags);*/ + if (!(obj->flags & XOTCL_DESTROY_CALLED)) + /*fprintf(stderr,"PrimitiveCDestroy call destroy\n");*/ + callDestroyMethod(clientData, interp, obj, 0); - obj->teardown = 0; + obj->teardown = 0; - CleanupDestroyClass(in, cl, 0); + CleanupDestroyClass(interp, cl, 0); - /* - * handoff the primitive teardown - */ + /* + * handoff the primitive teardown + */ - saved = cl->nsPtr; - obj->teardown = in; + saved = cl->nsPtr; + obj->teardown = interp; - /* - * class object destroy + physical destroy - */ - /*fprintf(stderr,"primitive cdestroy calls primitive odestroy\n");*/ - PrimitiveODestroy(cd); + /* + * class object destroy + physical destroy + */ + /*fprintf(stderr,"primitive cdestroy calls primitive odestroy\n");*/ + PrimitiveODestroy(clientData); - /*fprintf(stderr,"primitive cdestroy calls deletenamespace for obj %p\n",cl);*/ - saved->clientData = 0; - XOTcl_DeleteNamespace(in, saved); + /*fprintf(stderr,"primitive cdestroy calls deletenamespace for obj %p\n",cl);*/ + saved->clientData = 0; + XOTcl_DeleteNamespace(interp, saved); - return; + return; } /* * class init */ static void -PrimitiveCInit(XOTclClass *cl, Tcl_Interp *in, char *name) { - TclCallFrame frame, *framePtr = &frame; - Tcl_Namespace* ns; +PrimitiveCInit(XOTclClass *cl, Tcl_Interp *interp, char *name) { + TclCallFrame frame, *framePtr = &frame; + Tcl_Namespace *ns; - /* - * ensure that namespace is newly created during CleanupInitClass - * ie. kill it, if it exists already - */ - if (Tcl_PushCallFrame(in, (Tcl_CallFrame *)framePtr, - RUNTIME_STATE(in)->XOTclClassesNS, 0) != TCL_OK) - return; - ns = NSGetFreshNamespace(in, (ClientData)cl, name); - Tcl_PopCallFrame(in); + /* + * ensure that namespace is newly created during CleanupInitClass + * ie. kill it, if it exists already + */ + if (Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, + RUNTIME_STATE(interp)->XOTclClassesNS, 0)!= TCL_OK) + return; + ns = NSGetFreshNamespace(interp, (ClientData)cl, name); + Tcl_PopCallFrame(interp); - CleanupInitClass(in, cl, ns, 0); - return; + CleanupInitClass(interp, cl, ns, 0); + return; } /* * class create: creation of namespace + class full name * calls class object creation */ static XOTclClass* -PrimitiveCCreate(Tcl_Interp *in, char *name, XOTclClass *class) { - XOTclClass *cl = (XOTclClass*)ckalloc(sizeof(XOTclClass)); - unsigned length; - XOTclObject *obj = (XOTclObject*)cl; +PrimitiveCCreate(Tcl_Interp *interp, char *name, XOTclClass *class) { + XOTclClass *cl = (XOTclClass*)ckalloc(sizeof(XOTclClass)); + unsigned length; + XOTclObject *obj = (XOTclObject*)cl; - /*fprintf(stderr, "CKALLOC Class %p %s\n", cl, name);*/ + /*fprintf(stderr, "CKALLOC Class %p %s\n", cl, name);*/ - memset(cl, 0, sizeof(XOTclClass)); - MEM_COUNT_ALLOC("XOTclObject/XOTclClass",cl); - /* - fprintf(stderr, " +++ CLS alloc: %s\n", name); - */ - assert(isAbsolutePath(name)); - length = strlen(name); - /* - fprintf(stderr,"Class alloc %p '%s'\n", cl, name); - */ - /* check whether Object parent NS already exists, - otherwise: error */ - if (!NSCheckForParent(in, name, length)) { - ckfree((char *) cl); - return 0; - } - obj->id = Tcl_CreateObjCommand(in, name, XOTclObjDispatch, - (ClientData)cl, PrimitiveCDestroy); + memset(cl, 0, sizeof(XOTclClass)); + MEM_COUNT_ALLOC("XOTclObject/XOTclClass",cl); + /* + fprintf(stderr, " +++ CLS alloc: %s\n", name); + */ + assert(isAbsolutePath(name)); + length = strlen(name); + /* + fprintf(stderr,"Class alloc %p '%s'\n", cl, name); + */ + /* check whether Object parent NS already exists, + otherwise: error */ + if (!NSCheckForParent(interp, name, length)) { + ckfree((char *) cl); + return 0; + } + obj->id = Tcl_CreateObjCommand(interp, name, XOTclObjDispatch, + (ClientData)cl, PrimitiveCDestroy); - PrimitiveOInit(obj, in, name, class); + PrimitiveOInit(obj, interp, name, class); - obj->cmdName = NewXOTclObjectObjName(obj,name,length); - INCR_REF_COUNT(obj->cmdName); - PrimitiveCInit(cl, in, name+2); + obj->cmdName = NewXOTclObjectObjName(obj,name,length); + INCR_REF_COUNT(obj->cmdName); + PrimitiveCInit(cl, interp, name+2); - objTrace("PrimitiveCCreate", obj); - return cl; + objTrace("PrimitiveCCreate", obj); + return cl; } /* change XOTcl class conditionally; obj must not be NULL */ XOTCLINLINE static int -changeClass(Tcl_Interp *in, XOTclObject *obj, XOTclClass *cl) { - assert(obj); +changeClass(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl) { + assert(obj); - if (cl != obj->cl) { - if (IsMetaClass(in, cl) && !IsMetaClass(in, obj->cl)) { - return XOTclVarErrMsg(in, "cannot change class of object ", - ObjStr(obj->cmdName), - " to metaclass ", - ObjStr(cl->object.cmdName),(char *) NULL); - } - (void)RemoveInstance(obj, obj->cl); - AddInstance(obj, cl); + if (cl != obj->cl) { + if (IsMetaClass(interp, cl) && !IsMetaClass(interp, obj->cl)) { + return XOTclVarErrMsg(interp, "cannot change class of object ", + ObjStr(obj->cmdName), + " to metaclass ", + ObjStr(cl->object.cmdName),(char *) NULL); + } + (void)RemoveInstance(obj, obj->cl); + AddInstance(obj, cl); - MixinComputeDefined(in, obj); - FilterComputeDefined(in, obj); - } - return TCL_OK; + MixinComputeDefined(interp, obj); + FilterComputeDefined(interp, obj); + } + return TCL_OK; } /* * Undestroy the object, reclass it, and call "cleanup" afterwards */ static int -doCleanup(Tcl_Interp *in, XOTclObject *newobj, XOTclObject *classobj, +doCleanup(Tcl_Interp *interp, XOTclObject *newobj, XOTclObject *classobj, int objc, Tcl_Obj *CONST objv[]) { - int destroyed = 0, result; - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - XOTclCallStackContent *csc; - /* - * we check whether the object to be re-created is destroyed or not - */ - for (csc = &cs->content[1]; csc <= cs->top; csc++) { - if (newobj == csc->self && csc->destroyedCmd) { - destroyed = 1; break; + int destroyed = 0, result; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *csc; + /* + * we check whether the object to be re-created is destroyed or not + */ + for (csc = &cs->content[1]; csc <= cs->top; csc++) { + if (newobj == csc->self && csc->destroyedCmd) { + destroyed = 1; break; + } } - } - if (destroyed) - UndestroyObj(in, newobj); + if (destroyed) + UndestroyObj(interp, newobj); - /* - * re-create, first ensure correct class for newobj - */ - - result = changeClass(in, newobj, (XOTclClass*) classobj); - - if (result == TCL_OK) { /* - * dispatch "cleanup" + * re-create, first ensure correct class for newobj */ - result = callMethod((ClientData) newobj, in, XOTclGlobalObjects[XOTE_CLEANUP], 2, 0, 0); - } - return result; + + result = changeClass(interp, newobj, (XOTclClass*) classobj); + + if (result == TCL_OK) { + /* + * dispatch "cleanup" + */ + result = callMethod((ClientData) newobj, interp, XOTclGlobalObjects[XOTE_CLEANUP], 2, 0, 0); + } + return result; } /* @@ -7501,60 +7750,49 @@ * call constructor "init", if it was not called before */ static int -doObjInitialization(Tcl_Interp *in, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]) { - int result, initArgsC = objc; - Tcl_Obj *savedObjResult = Tcl_GetObjResult(in); /* save the result */ - INCR_REF_COUNT(savedObjResult); +doObjInitialization(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]) { + int result; + Tcl_Obj *savedObjResult = Tcl_GetObjResult(interp); /* save the result */ + INCR_REF_COUNT(savedObjResult); - /* - * Search for default values of parameter on superclasses - */ - if (!(obj->flags & XOTCL_INIT_CALLED)) { - result = callParameterMethodWithArg(obj, in, XOTclGlobalObjects[XOTE_SEARCH_DEFAULTS], - obj->cmdName, 3, 0, 0); - if (result != TCL_OK) - return result; - } + /* + * clear INIT_CALLED flag + */ + obj->flags &= ~XOTCL_INIT_CALLED; - /* clear INIT_CALLED_FLAG */ - obj->flags &= ~XOTCL_INIT_CALLED; - - /* - * call configure methods (starting with '-') - */ - - result = callMethod((ClientData) obj, in, - XOTclGlobalObjects[XOTE_CONFIGURE], objc, objv+2, 0); - if (result != TCL_OK) - return result; - - /* check, whether init was called already, and determine where the - * configure (with '-') start (we don't send them as args to - * "init"). */ - - if (!(obj->flags & XOTCL_INIT_CALLED)) { - int newargs; - Tcl_Obj *resultObj = Tcl_GetObjResult(in); /* - * Call the user-defined constructor 'init' + * call configure methods (starting with '-') */ - INCR_REF_COUNT(resultObj); - result = Tcl_GetIntFromObj(in,resultObj,&newargs); - DECR_REF_COUNT(resultObj); + result = callMethod((ClientData) obj, interp, + XOTclGlobalObjects[XOTE_CONFIGURE], objc, objv+2, 0); + if (result != TCL_OK) { + goto objinitexit; + } - if (result == TCL_OK && newargs+2 < objc) - initArgsC = newargs+2; - result = callMethod((ClientData) obj, in, XOTclGlobalObjects[XOTE_INIT], - initArgsC, objv+2, 0); - obj->flags |= XOTCL_INIT_CALLED; - } + /* + * check, whether init was called already + */ + if (!(obj->flags & XOTCL_INIT_CALLED)) { + int nobjc = 0; + Tcl_Obj **nobjv, *resultObj = Tcl_GetObjResult(interp); + /* + * Call the user-defined constructor 'init' and pass the result of + * configure to it as arguments + */ + INCR_REF_COUNT(resultObj); + Tcl_ListObjGetElements(interp, resultObj, &nobjc, &nobjv); + result = callMethod((ClientData) obj, interp, XOTclGlobalObjects[XOTE_INIT], + nobjc+2, nobjv, 0); + obj->flags |= XOTCL_INIT_CALLED; + DECR_REF_COUNT(resultObj); + } - if (result == TCL_OK) { - Tcl_SetObjResult(in, savedObjResult); - } - DECR_REF_COUNT(savedObjResult); - - return result; + if (result == TCL_OK) { + Tcl_SetObjResult(interp, savedObjResult); + } + objinitexit: + DECR_REF_COUNT(savedObjResult); + return result; } @@ -7563,89 +7801,89 @@ */ #ifdef NOT_USED static int -XOTclResolveCmd(Tcl_Interp *in, char *name, Tcl_Namespace *contextNsPtr, +XOTclResolveCmd(Tcl_Interp *interp, char *name, Tcl_Namespace *contextNsPtr, int flags, Tcl_Command *rPtr) { - Tcl_Namespace *nsPtr[2], *cxtNsPtr; - char *simpleName; - register Tcl_HashEntry *entryPtr; - register Tcl_Command cmd; - register int search; + Tcl_Namespace *nsPtr[2], *cxtNsPtr; + char *simpleName; + register Tcl_HashEntry *entryPtr; + register Tcl_Command cmd; + register int search; - /*fprintf(stderr, " ***%s->%s\n", contextNsPtr->fullName, name);*/ + /*fprintf(stderr, " ***%s->%s\n", contextNsPtr->fullName, name);*/ - /* - * Find the namespace(s) that contain the command. - */ - if ((flags & TCL_GLOBAL_ONLY) != 0) { - cxtNsPtr = Tcl_GetGlobalNamespace(in); - } - else if (contextNsPtr != NULL) { - cxtNsPtr = contextNsPtr; - } - else { - cxtNsPtr = Tcl_GetCurrentNamespace(in); - } + /* + * Find the namespace(s) that contain the command. + */ + if ((flags & TCL_GLOBAL_ONLY) != 0) { + cxtNsPtr = Tcl_GetGlobalNamespace(interp); + } + else if (contextNsPtr != NULL) { + cxtNsPtr = contextNsPtr; + } + else { + cxtNsPtr = Tcl_GetCurrentNamespace(interp); + } - TclGetNamespaceForQualName(in, name, (Namespace *) contextNsPtr, - flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); - /*fprintf(stderr, " ***Found %s, %s\n", nsPtr[0]->fullName, nsPtr[0]->fullName);*/ + /*fprintf(stderr, " ***Found %s, %s\n", nsPtr[0]->fullName, nsPtr[0]->fullName);*/ - /* - * Look for the command in the command table of its namespace. - * Be sure to check both possible search paths: from the specified - * namespace context and from the global namespace. - */ + /* + * Look for the command in the command table of its namespace. + * Be sure to check both possible search paths: from the specified + * namespace context and from the global namespace. + */ - cmd = NULL; - for (search = 0; (search < 2) && (cmd == NULL); search++) { - if ((nsPtr[search] != NULL) && (simpleName != NULL)) { - cmdTable = Tcl_Namespace_cmdTable(nsPtr[search]); - entryPtr = Tcl_FindHashEntry(cmdTable, simpleName); - if (entryPtr != NULL) { - cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); - } + cmd = NULL; + for (search = 0; (search < 2) && (cmd == NULL); search++) { + if ((nsPtr[search] != NULL) && (simpleName != NULL)) { + cmdTable = Tcl_Namespace_cmdTable(nsPtr[search]); + entryPtr = Tcl_FindHashEntry(cmdTable, simpleName); + if (entryPtr != NULL) { + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + } + } } - } - if (cmd != NULL) { - Tcl_ObjCmdProc* objProc = Tcl_Command_objProc(cmd); - if (cxtNsPtr->deleteProc == NSNamespaceDeleteProc && - objProc != XOTclObjDispatch && - objProc != XOTclNextObjCmd && - objProc != XOTclGetSelfObjCmd) { + if (cmd != NULL) { + Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); + if (cxtNsPtr->deleteProc == NSNamespaceDeleteProc && + objProc != XOTclObjDispatch && + objProc != XOTclNextObjCmd && + objProc != XOTclGetSelfObjCmd) { - /* - * the cmd is defined in an XOTcl object or class namespace, but - * not an object & not self/next -> redispatch in - * global namespace - */ - cmd = 0; - nsPtr[0] = Tcl_GetGlobalNamespace(in); - if ((nsPtr[0] != NULL) && (simpleName != NULL)) { - cmdTable = Tcl_Namespace_cmdTable(nsPtr[0]); - if ((entryPtr = Tcl_FindHashEntry(cmdTable, simpleName))) { - cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); - } - } + /* + * the cmd is defined in an XOTcl object or class namespace, but + * not an object & not self/next -> redispatch in + * global namespace + */ + cmd = 0; + nsPtr[0] = Tcl_GetGlobalNamespace(interp); + if ((nsPtr[0] != NULL) && (simpleName != NULL)) { + cmdTable = Tcl_Namespace_cmdTable(nsPtr[0]); + if ((entryPtr = Tcl_FindHashEntry(cmdTable, simpleName))) { + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + } + } - /* - XOTclStackDump(in); - XOTclCallStackDump(in); - */ + /* + XOTclStackDump(interp); + XOTclCallStackDump(interp); + */ + } + *rPtr = cmd; + return TCL_OK; } - *rPtr = cmd; - return TCL_OK; - } - return TCL_CONTINUE; + return TCL_CONTINUE; } static int -XOTclResolveVar(Tcl_Interp *in, char *name, Tcl_Namespace *context, +XOTclResolveVar(Tcl_Interp *interp, char *name, Tcl_Namespace *context, Tcl_ResolvedVarInfo *rPtr) { - /*fprintf(stderr, "Resolving %s in %s\n", name, context->fullName);*/ + /*fprintf(stderr, "Resolving %s in %s\n", name, context->fullName);*/ - return TCL_CONTINUE; + return TCL_CONTINUE; } #endif @@ -7654,4200 +7892,5371 @@ */ static int -XOTclODestroyMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; +XOTclODestroyMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 1) return XOTclObjErrArgCnt(in, obj->cmdName, "destroy"); - PRINTOBJ("XOTclODestroyMethod", obj); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); + PRINTOBJ("XOTclODestroyMethod", obj); - /* - * call instdestroy for [self] - */ - return XOTclCallMethodWithArgs((ClientData)obj->cl, in, - XOTclGlobalObjects[XOTE_INSTDESTROY], obj->cmdName, - objc, objv+1, 0); + /* + * call instdestroy for [self] + */ + return XOTclCallMethodWithArgs((ClientData)obj->cl, interp, + XOTclGlobalObjects[XOTE_INSTDESTROY], obj->cmdName, + objc, objv+1, 0); } static int -XOTclOCleanupMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - XOTclClass *cl = XOTclObjectToClass(obj); - char *fn; - int softrecreate; - Tcl_Obj *savedNameObj; +XOTclOCleanupMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + XOTclClass *cl = XOTclObjectToClass(obj); + char *fn; + int softrecreate; + Tcl_Obj *savedNameObj; #if defined(OBJDELETION_TRACE) - fprintf(stderr,"+++ XOTclOCleanupMethod\n"); + fprintf(stderr,"+++ XOTclOCleanupMethod\n"); #endif - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 1) return XOTclObjErrArgCnt(in, obj->cmdName, "cleanup"); - PRINTOBJ("XOTclOCleanupMethod", obj); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); + PRINTOBJ("XOTclOCleanupMethod", obj); - fn = ObjStr(obj->cmdName); - savedNameObj = obj->cmdName; - INCR_REF_COUNT(savedNameObj); + fn = ObjStr(obj->cmdName); + savedNameObj = obj->cmdName; + INCR_REF_COUNT(savedNameObj); - /* save and pass around softrecreate*/ - softrecreate = obj->flags & XOTCL_RECREATE&& RUNTIME_STATE(in)->doSoftrecreate; + /* save and pass around softrecreate*/ + softrecreate = obj->flags & XOTCL_RECREATE&& RUNTIME_STATE(interp)->doSoftrecreate; - CleanupDestroyObject(in, obj, softrecreate); - CleanupInitObject(in, obj, obj->cl, obj->nsPtr, softrecreate); + CleanupDestroyObject(interp, obj, softrecreate); + CleanupInitObject(interp, obj, obj->cl, obj->nsPtr, softrecreate); - if (cl) { - CleanupDestroyClass(in, cl, softrecreate); - CleanupInitClass(in, cl, cl->nsPtr, softrecreate); - } + if (cl) { + CleanupDestroyClass(interp, cl, softrecreate); + CleanupInitClass(interp, cl, cl->nsPtr, softrecreate); + } - DECR_REF_COUNT(savedNameObj); + DECR_REF_COUNT(savedNameObj); - return TCL_OK; + return TCL_OK; } static int -XOTclOIsClassMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Obj *className; - XOTclObject *obj = (XOTclObject*)cd, *o; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 1 || objc > 2) return XOTclObjErrArgCnt(in, obj->cmdName, - "isclass ?className?"); - className = (objc == 2) ? objv[1] : obj->cmdName; +XOTclOIsClassMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + Tcl_Obj *className; + XOTclObject *obj = (XOTclObject*)clientData, *o; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 1 || objc > 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "?className?"); + className = (objc == 2) ? objv[1] : obj->cmdName; - Tcl_SetIntObj(Tcl_GetObjResult(in), - (XOTclObjConvertObject(in, className, &o) == TCL_OK - && XOTclObjectIsClass(o) )); - return TCL_OK; + Tcl_SetIntObj(Tcl_GetObjResult(interp), + (XOTclObjConvertObject(interp, className, &o) == TCL_OK + && XOTclObjectIsClass(o) )); + return TCL_OK; } static int -XOTclOIsObjectMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd, *o; +XOTclOIsObjectMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData, *o; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc != 2) return XOTclObjErrArgCnt(in, obj->cmdName, "isobject "); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); - if (XOTclObjConvertObject(in, objv[1], &o) == TCL_OK) { - Tcl_SetIntObj(Tcl_GetObjResult(in), 1); - } else { - Tcl_SetIntObj(Tcl_GetObjResult(in), 0); - } - return TCL_OK; + if (XOTclObjConvertObject(interp, objv[1], &o) == TCL_OK) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } + return TCL_OK; } static int -IsMetaClass(Tcl_Interp *in, XOTclClass *cl) { - /* check if cl is a meta-class by checking is Class is a superclass of cl*/ - XOTclClasses *pl, *checkList=0, *mixinClasses = 0, *mc; - int hasMCM = 0; +IsMetaClass(Tcl_Interp *interp, XOTclClass *cl) { + /* check if cl is a meta-class by checking is Class is a superclass of cl*/ + XOTclClasses *pl, *checkList=0, *mixinClasses = 0, *mc; + int hasMCM = 0; - if (cl == RUNTIME_STATE(in)->theClass) - return 1; + if (cl == RUNTIME_STATE(interp)->theClass) + return 1; - for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->next) { - if (pl->cl == RUNTIME_STATE(in)->theClass) - return 1; - } + for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { + if (pl->cl == RUNTIME_STATE(interp)->theClass) + return 1; + } - for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->next) { - XOTclClassOpt* opt = pl->cl->opt; - if (opt && opt->instmixins) { - MixinComputeOrderFullList(in, - &opt->instmixins, - &mixinClasses, - &checkList, 0); + for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->nextPtr) { + XOTclClassOpt *opt = pl->cl->opt; + if (opt && opt->instmixins) { + MixinComputeOrderFullList(interp, + &opt->instmixins, + &mixinClasses, + &checkList, 0); + } } - } - for (mc=mixinClasses; mc; mc = mc->next) { - /*fprintf(stderr,"- got %s\n",ObjStr(mc->cl->object.cmdName));*/ - if (isSubType(mc->cl, RUNTIME_STATE(in)->theClass)) { - hasMCM = 1; - break; + for (mc=mixinClasses; mc; mc = mc->nextPtr) { + /*fprintf(stderr,"- got %s\n",ObjStr(mc->cl->object.cmdName));*/ + if (isSubType(mc->cl, RUNTIME_STATE(interp)->theClass)) { + hasMCM = 1; + break; + } } - } - XOTclFreeClasses(mixinClasses); - XOTclFreeClasses(checkList); - /*fprintf(stderr,"has MC returns %d, mixinClasses = %p\n", - hasMCM, mixinClasses);*/ + XOTclClassListFree(mixinClasses); + XOTclClassListFree(checkList); + /*fprintf(stderr,"has MC returns %d, mixinClasses = %p\n", + hasMCM, mixinClasses);*/ - return hasMCM; + return hasMCM; } static int -XOTclOIsMetaClassMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd, *o; - Tcl_Obj *className; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 1 || objc > 2) return XOTclObjErrArgCnt(in, obj->cmdName, - "ismetaclass ?metaClassName?"); +XOTclOIsMetaClassMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData, *o; + Tcl_Obj *className; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 1 || objc > 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "?metaClassName?"); - className = (objc == 2) ? objv[1] : obj->cmdName; + className = (objc == 2) ? objv[1] : obj->cmdName; - if (XOTclObjConvertObject(in, className, &o) == TCL_OK - && XOTclObjectIsClass(o) - && IsMetaClass(in, (XOTclClass*)o)) { - Tcl_SetIntObj(Tcl_GetObjResult(in), 1); - } else { - Tcl_SetIntObj(Tcl_GetObjResult(in), 0); - } - return TCL_OK; + if (XOTclObjConvertObject(interp, className, &o) == TCL_OK + && XOTclObjectIsClass(o) + && IsMetaClass(interp, (XOTclClass*)o)) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + } + return TCL_OK; } static int isSubType(XOTclClass *subcl, XOTclClass *cl) { - XOTclClasses *t; - int success = 1; - assert(cl && subcl); + XOTclClasses *t; + int success = 1; + assert(cl && subcl); - if (cl != subcl) { - success = 0; - for (t = ComputeOrder(subcl, subcl->order, Super); t && t->cl; t = t->next) { - if (t->cl == cl) { - success = 1; - break; - } + if (cl != subcl) { + success = 0; + for (t = ComputeOrder(subcl, subcl->order, Super); t && t->cl; t = t->nextPtr) { + if (t->cl == cl) { + success = 1; + break; + } + } } - } - return success; + return success; } +static int +XOTclOIsTypeMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + XOTclClass *cl; + int success = 0; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); + if (obj->cl && GetXOTclClassFromObj(interp,objv[1], &cl, 0) == TCL_OK) { + success = isSubType(obj->cl,cl); + } + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), success); + return TCL_OK; +} + + + static int -XOTclOIsTypeMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - XOTclClass *cl; - int success = 0; +XOTclIsCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = NULL; + XOTclClass *cl = NULL; + int success = 0, opt; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc != 2) return XOTclObjErrArgCnt(in, obj->cmdName, "istype "); - if (obj->cl && GetXOTclClassFromObj(in,objv[1],&cl, 1) == TCL_OK) { - success = isSubType(obj->cl,cl); - } - Tcl_ResetResult(in); - Tcl_SetIntObj(Tcl_GetObjResult(in), success); - return TCL_OK; + static CONST char *opts[] = { + "type", "object", "class", "metaclass", "mixin", + NULL + }; + enum subCmdIdx { + typeIdx, objectIdx, classIdx, metaclassIdx, mixinIdx + }; + + if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, &opt) != TCL_OK) { + return TCL_ERROR; + } + + switch (opt) { + case typeIdx: + if (objc != 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, "type "); + success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK + && GetXOTclClassFromObj(interp, objv[3], &cl, 0) == TCL_OK + && isSubType(obj->cl,cl)); + break; + + case objectIdx: + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "object "); + success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK); + break; + + case classIdx: + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "class "); + success = (GetXOTclClassFromObj(interp, objv[1], &cl, 0) == TCL_OK); + break; + + case metaclassIdx: + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "metaclass "); + + success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK + && XOTclObjectIsClass(obj) + && IsMetaClass(interp, (XOTclClass*)obj)); + break; + + case mixinIdx: + if (objc != 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, "mixin "); + + success = (XOTclObjConvertObject(interp, objv[1], &obj) == TCL_OK + && GetXOTclClassFromObj(interp, objv[3], &cl, 0) == TCL_OK + && hasMixin(interp, obj, cl)); + break; + } + + Tcl_SetIntObj(Tcl_GetObjResult(interp), success); + return TCL_OK; } + static int -hasMixin(Tcl_Interp *in, XOTclObject *obj, XOTclClass *cl) { +hasMixin(Tcl_Interp *interp, XOTclObject *obj, XOTclClass *cl) { - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(in, obj); + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); - if ((obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { - XOTclCmdList *ml; - for (ml = obj->mixinOrder; ml; ml = ml->next) { - XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); - if (mixin == cl) { - return 1; - } + if ((obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID)) { + XOTclCmdList *ml; + for (ml = obj->mixinOrder; ml; ml = ml->nextPtr) { + XOTclClass *mixin = XOTclGetClassFromCmdPtr(ml->cmdPtr); + if (mixin == cl) { + return 1; + } + } } - } - return 0; + return 0; } static int -XOTclOIsMixinMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - XOTclClass *cl; - int success = 0; +XOTclOIsMixinMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + XOTclClass *cl; + int success = 0; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc != 2) return XOTclObjErrArgCnt(in, obj->cmdName, "ismixin "); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); - if (GetXOTclClassFromObj(in,objv[1],&cl, 1) == TCL_OK) { - success = hasMixin(in, obj, cl); - } - Tcl_ResetResult(in); - Tcl_SetIntObj(Tcl_GetObjResult(in), success); - return TCL_OK; + if (GetXOTclClassFromObj(interp,objv[1],&cl,0) == TCL_OK) { + success = hasMixin(interp, obj, cl); + } + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), success); + return TCL_OK; } static int -XOTclOExistsMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; +XOTclOExistsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc != 2) return XOTclObjErrArgCnt(in, obj->cmdName, "exists var"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "var"); - Tcl_SetIntObj(Tcl_GetObjResult(in), - varExists(in, obj, ObjStr(objv[1]),NULL, 1,1)); - return TCL_OK; + Tcl_SetIntObj(Tcl_GetObjResult(interp), + varExists(interp, obj, ObjStr(objv[1]), NULL, 1,1)); + return TCL_OK; } static int -countModifiers(int objc, Tcl_Obj * CONST objv[]) { - int i, count = 0; - char *to; - for (i = 2; i < objc; i++) { - to = ObjStr(objv[i]); - if (to[0] == '-') { - count++; - /* '--' stops modifiers */ - if (to[1] == '-') break; +countModifiers(int objc, Tcl_Obj *CONST objv[]) { + int i, count = 0; + char *to; + for (i = 2; i < objc; i++) { + to = ObjStr(objv[i]); + if (to[0] == '-') { + count++; + /* '--' stops modifiers */ + if (to[1] == '-') break; + } } - } - return count; + return count; } static int -checkForModifier(Tcl_Obj * CONST objv[], int numberModifiers, char *modifier) { - int i; - if (numberModifiers == 0) return 0; - for (i = 2; i-2 < numberModifiers; i++) { - char *ov = ObjStr(objv[i]); - /* all start with a "-", so there must be a ov[1] */ - if (ov[1] == modifier[1] && !strcmp(ov, modifier)) - return 1; - } - return 0; +checkForModifier(Tcl_Obj *CONST objv[], int numberModifiers, char *modifier) { + int i; + if (numberModifiers == 0) return 0; + for (i = 2; i-2 < numberModifiers; i++) { + char *ov = ObjStr(objv[i]); + /* all start with a "-", so there must be a ov[1] */ + if (ov[1] == modifier[1] && !strcmp(ov, modifier)) + return 1; + } + return 0; } +/************ info commands xxx ******/ + static int -XOTclOInfoMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - Tcl_Namespace *nsp = obj->nsPtr; - char *cmd, *pattern; - int modifiers = 0; - XOTclObjectOpt *opt; +XOTclObjInfoArgsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + Tcl_Namespace *nsp; + + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 2) - return XOTclObjErrArgCnt(in, obj->cmdName, "info ?args?"); + if (obj->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = NonposArgsGet(obj->nonposArgsTable, ObjStr(objv[2])); + if (nonposArgs && nonposArgs->ordinaryArgs) { + return ListArgsFromOrdinaryArgs(interp, nonposArgs); + } + } - opt = obj->opt; - cmd = ObjStr(objv[1]); - pattern = (objc > 2) ? ObjStr(objv[2]) : 0; + nsp = obj->nsPtr; + return nsp ? ListProcArgs(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2])) : TCL_OK; +} - /*fprintf(stderr, "OInfo cmd=%s, obj=%s, nsp=%p\n",cmd,ObjStr(obj->cmdName),nsp);*/ +static int +XOTclObjInfoBodyMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + Tcl_Namespace *nsp; + + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + nsp = obj->nsPtr; + return nsp ? ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2])) : TCL_OK; +} - /* - * check for "-" modifiers - */ - if (pattern && *pattern == '-') { - modifiers = countModifiers(objc, objv); - pattern = (objc > 2+modifiers) ? ObjStr(objv[2+modifiers]) : 0; - } +static int +XOTclObjInfoClassMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; - switch (*cmd) { - case 'a': - if (isArgsString(cmd)) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info args "); - if (obj->nonposArgsTable) { - XOTclNonposArgs* nonposArgs = - NonposArgsGet(obj->nonposArgsTable, pattern); - if (nonposArgs) { - return ListArgsFromOrdinaryArgs(in, nonposArgs); - } - } - if (nsp) - return ListProcArgs(in, Tcl_Namespace_cmdTable(nsp), pattern); - else - return TCL_OK; + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + Tcl_SetObjResult(interp, obj->cl->object.cmdName); + return TCL_OK; +} + +static int +XOTclObjInfoCommandsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + Tcl_Namespace *nsp; + + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + nsp = obj->nsPtr; + return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), objc == 3 ? ObjStr(objv[2]) : NULL); +} + +static int +XOTclObjInfoChildrenMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + return ListChildren(interp, obj, objc == 3 ? ObjStr(objv[2]) : NULL, 0); +} + +static int +XOTclObjInfoSlotObjectsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + return ListSlotObjects(interp, obj, objc == 3 ? ObjStr(objv[2]) : NULL); +} + +static int +XOTclObjInfoCheckMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + return AssertionListCheckOption(interp, obj); +} + +static int +XOTclObjInfoDefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + Tcl_Namespace *nsp; + + if (objc != 5) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + if (obj->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = NonposArgsGet(obj->nonposArgsTable, ObjStr(objv[2])); + if (nonposArgs && nonposArgs->ordinaryArgs) { + return ListDefaultFromOrdinaryArgs(interp, ObjStr(objv[2]), nonposArgs, ObjStr(objv[3]), objv[4]); + } } - break; + nsp = obj->nsPtr; + return nsp ? + ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2]), ObjStr(objv[3]), objv[4]) : + TCL_OK; +} - case 'b': - if (!strcmp(cmd, "body")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info body "); - if (nsp) - return ListProcBody(in, Tcl_Namespace_cmdTable(nsp), pattern); - else - return TCL_OK; +static int +XOTclObjInfoFilterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + XOTclObjectOpt *opt;; + int idx, nobjc, withGuards = 0, withOrder = 0; + static CONST char *options[] = {"-guards", "-order", NULL}; + enum options {guardsIdx, orderIdx}; + + for (idx = 2; idx < objc; idx++) { + char *name; + int index; + + name = Tcl_GetString(objv[idx]); + if (name[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case guardsIdx: withGuards = 1; break; + case orderIdx: withOrder = 1; break; + } } - break; + nobjc = objc - idx; + + if (objc < 2 || nobjc > 1 || objc > 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-guards|-order? ?pattern?"); - case 'c': - if (isClassString(cmd)) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info class ?class?"); - return ListClass(in, obj, pattern, objc, objv); - } else if (!strcmp(cmd, "commands")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info commands ?pat?"); - if (nsp) - return ListKeys(in, Tcl_Namespace_cmdTable(nsp), pattern); - else - return TCL_OK; - } else if (!strcmp(cmd, "children")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info children ?pat?"); - return ListChildren(in, obj, pattern, 0); - } else if (!strcmp(cmd, "check")) { - if (objc != 2 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info check"); - return AssertionListCheckOption(in, obj); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + if (withOrder) { + if (!(obj->flags & XOTCL_FILTER_ORDER_VALID)) + FilterComputeDefined(interp, obj); + return FilterInfo(interp, obj->filterOrder, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards, 1); } - break; + opt = obj->opt; + return opt ? FilterInfo(interp, opt->filters, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards, 0) : TCL_OK; +} - case 'd': - if (!strcmp(cmd, "default")) { - if (objc != 5 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info default "); +static int +XOTclObjInfoFilterguardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + XOTclObjectOpt *opt; + + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " filter"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - if (obj->nonposArgsTable) { - XOTclNonposArgs* nonposArgs = - NonposArgsGet(obj->nonposArgsTable, pattern); - if (nonposArgs) { - return ListDefaultFromOrdinaryArgs(in, pattern, nonposArgs, - ObjStr(objv[3]), objv[4]); - } - } - if (nsp) - return ListProcDefault(in, Tcl_Namespace_cmdTable(nsp), pattern, - ObjStr(objv[3]), objv[4]); - else - return TCL_OK; + opt = obj->opt; + return opt ? GuardList(interp, opt->filters, ObjStr(objv[2])) : TCL_OK; +} + +static int +XOTclObjInfoForwardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + Tcl_Namespace *nsp; + int withDefinition = 0; + char *name = NULL; + + if (objc < 2 || objc > 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-definition? ?name?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + if (objc > 2) { + name = ObjStr(objv[2]); + if (*name == '-' && !strcmp("-definition", name)) { + withDefinition = 1; + name = ObjStr(objv[3]); + } } - break; - case 'f': - if (!strcmp(cmd, "filter")) { - int withGuards = 0, withOrder = 0; - if (objc-modifiers > 3) - return XOTclObjErrArgCnt(in, obj->cmdName, - "info filter ?-guards? ?-order? ?pat?"); - if (modifiers > 0) { - withGuards = checkForModifier(objv, modifiers, "-guards"); - withOrder = checkForModifier(objv, modifiers, "-order"); + nsp = obj->nsPtr; + return nsp ? forwardList(interp, Tcl_Namespace_cmdTable(nsp), name, withDefinition) : TCL_OK; +} - if (withGuards == 0 && withOrder == 0) - return XOTclVarErrMsg(in, "info filter: unknown modifier ", - ObjStr(objv[2]), (char *) NULL); - /* - if (withGuards && withOrder) - return XOTclVarErrMsg(in, "info filter: cannot use -guards and -order together", - ObjStr(objv[2]), (char *) NULL); - */ - } +static int +XOTclObjInfoHasnamespaceMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + Tcl_Namespace *nsp;; - if (withOrder) { - if (!(obj->flags & XOTCL_FILTER_ORDER_VALID)) - FilterComputeDefined(in, obj); - return FilterInfo(in, obj->filterOrder, pattern, withGuards, 1); - } + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - return opt ? FilterInfo(in, opt->filters, pattern, withGuards, 0) : TCL_OK; + nsp = obj->nsPtr; + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), nsp != NULL); + return TCL_OK; +} - } else if (!strcmp(cmd, "filterguard")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info filterguard filter"); - return opt ? GuardList(in, opt->filters, pattern) : TCL_OK; - } else if (!strcmp(cmd, "forward")) { - int argc = objc-modifiers; - int definition; - if (argc < 2 || argc > 3) - return XOTclObjErrArgCnt(in, obj->cmdName, - "info forward ?-definition? ?name?"); - definition = checkForModifier(objv, modifiers, "-definition"); - if (nsp) - return forwardList(in, Tcl_Namespace_cmdTable(nsp), pattern, definition); - else - return TCL_OK; +static int +XOTclObjInfoInfoMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + return ListInfo(interp, GetXOTclClassFromObj(interp,obj->cmdName,NULL,0) == TCL_OK); +} + +static int +XOTclObjInfoInvarMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + XOTclObjectOpt *opt; + + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + opt = obj->opt; + if (opt && opt->assertions) { + Tcl_SetObjResult(interp, AssertionList(interp, opt->assertions->invariants)); } + return TCL_OK; +} - break; +static int +XOTclObjInfoMixinMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + XOTclObjectOpt *opt; + int idx, nobjc, withGuards = 0, withOrder = 0; + static CONST char *options[] = {"-guards", "-order", NULL}; + enum options {guardsIdx, orderIdx}; - case 'h': - if (!strcmp(cmd, "hasNamespace")) { - Tcl_SetBooleanObj(Tcl_GetObjResult(in), nsp != NULL); - return TCL_OK; + for (idx = 2; idx < objc; idx++) { + char *name; + int index; + + name = Tcl_GetString(objv[idx]); + if (name[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case guardsIdx: withGuards = 1; break; + case orderIdx: withOrder = 1; break; + } } - break; + nobjc = objc-idx; + + if (objc < 2 || nobjc > 1 || objc > 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-guards|-order? ?pattern?"); - case 'i': - if (!strcmp(cmd, "invar")) { - if (objc != 2 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info invar"); - if (opt && opt->assertions) - Tcl_SetObjResult(in, AssertionList(in, opt->assertions->invariants)); - return TCL_OK; - } else if (!strcmp(cmd, "info")) { - if (objc > 2 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info info"); - return ListInfo(in, GetXOTclClassFromObj(in,obj->cmdName,NULL,0) == TCL_OK); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + if (withOrder) { + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); + return MixinInfo(interp, obj->mixinOrder, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards); } - break; + + opt = obj->opt; + return opt ? MixinInfo(interp, opt->mixins, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards) : TCL_OK; +} - case 'm': - if (!strcmp(cmd, "mixin")) { - int withOrder = 0, withGuards = 0; - if (objc-modifiers > 3) - return XOTclObjErrArgCnt(in, obj->cmdName, - "info mixin ?-guards? ?-order? ?class?"); - if (modifiers > 0) { - withOrder = checkForModifier(objv, modifiers, "-order"); - withGuards = checkForModifier(objv, modifiers, "-guards"); +static int +XOTclObjInfoMixinguardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + XOTclObjectOpt *opt; - if (withOrder == 0 && withGuards == 0) - return XOTclVarErrMsg(in, "info mixin: unknown modifier . ", - ObjStr(objv[2]), (char *) NULL); - } + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " mixin"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); - if (withOrder) { - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(in, obj); - return MixinInfo(in, obj->mixinOrder, pattern, withGuards); - } + opt = obj->opt; + return opt ? GuardList(interp, opt->mixins, ObjStr(objv[2])) : TCL_OK; +} - return opt ? MixinInfo(in, opt->mixins, pattern, withGuards) : TCL_OK; +static int +XOTclObjInfoMethodsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + int idx, nobj, noprocs = 0, nocmds = 0, nomixins = 0, inContext = 0; + static CONST char *options[] = {"-noprocs", "-nocmds", "-nomixins", "-incontext", NULL}; + enum options {noprocsIdx, nocmdsIdx, nomixinsIdx, incontextIdx}; - } else if (!strcmp(cmd, "mixinguard")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info mixinguard mixin"); + for (idx = 2; idx < objc; idx++) { + char *name; + int index; - return opt ? GuardList(in, opt->mixins, pattern) : TCL_OK; - } else if (!strcmp(cmd, "methods")) { - int noprocs = 0, nocmds = 0, nomixins = 0, inContext = 0; - if (objc-modifiers > 3) - return XOTclObjErrArgCnt(in, obj->cmdName, - "info methods ?-noprocs? ?-nocmds? ?-nomixins? ?-incontext? ?pat?"); - if (modifiers > 0) { - noprocs = checkForModifier(objv, modifiers, "-noprocs"); - nocmds = checkForModifier(objv, modifiers, "-nocmds"); - nomixins = checkForModifier(objv, modifiers, "-nomixins"); - inContext = checkForModifier(objv, modifiers, "-incontext"); - } - return ListMethods(in, obj, pattern, noprocs, nocmds, nomixins, inContext); + name = Tcl_GetString(objv[idx]); + if (name[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case noprocsIdx: noprocs = 1; break; + case nocmdsIdx: nocmds = 1; break; + case nomixinsIdx: nomixins = 1; break; + case incontextIdx: inContext = 1; break; + } } -#ifdef XOTCL_METADATA - else if (!strcmp(cmd, "metadata")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info metadata ?pat?"); - return ListKeys(in, &obj->metaData, pattern); + nobj = objc-idx; + + if (nobj > 1) + return XOTclObjErrArgCnt(interp, objv[0], NULL, + " ?-noprocs? ?-nocmds? ?-nomixins? ?-incontext? ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + return ListMethods(interp, obj, nobj == 1 ? ObjStr(objv[idx]) : NULL, + noprocs, nocmds, nomixins, inContext); +} + +static int +XOTclObjInfoNonposargsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], objv[1], ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + if (obj->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = NonposArgsGet(obj->nonposArgsTable, ObjStr(objv[2])); + if (nonposArgs) { + Tcl_SetObjResult(interp, NonposArgsFormat(interp, nonposArgs->nonposArgs)); + } } -#endif - break; + return TCL_OK; +} - case 'n': - if (!strcmp(cmd, "nonposargs")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info nonposargs "); - if (obj->nonposArgsTable) { - XOTclNonposArgs* nonposArgs = - NonposArgsGet(obj->nonposArgsTable, pattern); - if (nonposArgs) { - Tcl_SetObjResult(in, NonposArgsFormat(in, nonposArgs->nonposArgs)); - } - } - return TCL_OK; +static int +XOTclObjInfoProcsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + Tcl_Namespace *nsp; + + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + nsp = obj->nsPtr; + return nsp ? ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), + objc == 3 ? ObjStr(objv[2]) : NULL, + /*noProcs*/ 0, /*noCmds*/ 1, NULL, 0 ) : TCL_OK; +} + +static int +XOTclObjInfoParentMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + return ListParent(interp, obj); +} + +static int +XOTclObjInfoPreMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + XOTclObjectOpt *opt; + + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + opt = obj->opt; + if (opt) { + XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); } - break; + return TCL_OK; +} - case 'p': - if (!strcmp(cmd, "procs")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info procs ?pat?"); - if (nsp) - return ListMethodKeys(in, Tcl_Namespace_cmdTable(nsp), pattern, - /*noProcs*/ 0, /*noCmds*/ 1, /* noDups */ 0, 0 ); - else - return TCL_OK; - } else if (!strcmp(cmd, "parent")) { - if (objc > 2 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info parent"); - return ListParent(in, obj); - } else if (!strcmp(cmd, "pre")) { - XOTclProcAssertion* procs; - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info pre "); - if (opt) { - procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(in, AssertionList(in, procs->pre)); - } - return TCL_OK; - } else if (!strcmp(cmd, "post")) { - XOTclProcAssertion* procs; - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info post "); - if (opt) { - procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(in, AssertionList(in, procs->post)); - } - return TCL_OK; - } else if (!strcmp(cmd, "precedence")) { - return ListPrecedence(in, obj, pattern); +static int +XOTclObjInfoPostMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + XOTclObjectOpt *opt; + + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + opt = obj->opt; + if (opt) { + XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); } - break; - case 'v': - if (!strcmp(cmd, "vars")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, obj->cmdName, "info vars ?pat?"); - return ListVars(in, obj, pattern); - } - break; - } - return XOTclErrBadVal(in, "info", - "an info option (use 'info info' to list all info options)", cmd); + return TCL_OK; } +static int +XOTclObjInfoPrecedenceMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + return ListPrecedence(interp, obj, objc == 3 ? ObjStr(objv[2]) : NULL); +} + static int -XOTclOProcMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - char *argStr, *bdyStr, *name; - XOTclObjectOpt *opt; - int incr = 0, result = TCL_OK; +XOTclObjInfoVarsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 4 || objc > 7) - return XOTclObjErrArgCnt(in, obj->cmdName, - "proc name ?non-positional-args? args body ?preAssertion postAssertion?"); + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Object"); + + return ListVars(interp, obj, objc == 3 ? ObjStr(objv[2]) : NULL); +} - if (objc == 5 || objc == 7) { - incr = 1; - } - argStr = ObjStr(objv[2 + incr]); - bdyStr = ObjStr(objv[3 + incr]); - name = ObjStr(objv[1 + incr]); +static int +XOTclOInfoMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + Tcl_Namespace *nsp = obj->nsPtr; + char *cmd, *pattern; + int modifiers = 0; + XOTclObjectOpt *opt; - if (*argStr == 0 && *bdyStr == 0) { + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], " ?args?"); + opt = obj->opt; - if (opt) - AssertionRemoveProc(opt->assertions, name); - if (obj->nsPtr) - NSDeleteCmd(in, obj->nsPtr, name); - } else { - XOTclAssertionStore* aStore = NULL; - if (objc > 5) { - opt = XOTclRequireObjectOpt(obj); - if (!opt->assertions) - opt->assertions = AssertionCreateStore(); - aStore = opt->assertions; + cmd = ObjStr(objv[1]); + pattern = (objc > 2) ? ObjStr(objv[2]) : 0; + + /*fprintf(stderr, "OInfo cmd=%s, obj=%s, nsp=%p\n",cmd,ObjStr(obj->cmdName),nsp);*/ + + /* + * check for "-" modifiers + */ + if (pattern && *pattern == '-') { + modifiers = countModifiers(objc, objv); + pattern = (objc > 2+modifiers) ? ObjStr(objv[2+modifiers]) : 0; } - requireObjNamespace(in, obj); - result = MakeProc(obj->nsPtr, aStore, &(obj->nonposArgsTable), - in, objc, (Tcl_Obj **) objv, obj); - } - /* could be a filter => recompute filter order */ - FilterComputeDefined(in, obj); + switch (*cmd) { + case 'a': + if (isArgsString(cmd)) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "args "); + if (obj->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = + NonposArgsGet(obj->nonposArgsTable, pattern); + if (nonposArgs && nonposArgs->ordinaryArgs) { + return ListArgsFromOrdinaryArgs(interp, nonposArgs); + } + } + if (nsp) + return ListProcArgs(interp, Tcl_Namespace_cmdTable(nsp), pattern); + else + return TCL_OK; + } + break; - return result; + case 'b': + if (!strcmp(cmd, "body")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "body "); + if (nsp) + return ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), pattern); + else + return TCL_OK; + } + break; + + case 'c': + if (isClassString(cmd)) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "class ?class?"); + return ListClass(interp, obj, pattern, objc, objv); + } else if (!strcmp(cmd, "commands")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "commands ?pat?"); + if (nsp) + return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern); + else + return TCL_OK; + } else if (!strcmp(cmd, "children")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "children ?pat?"); + return ListChildren(interp, obj, pattern, 0); + } else if (!strcmp(cmd, "check")) { + if (objc != 2 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "check"); + return AssertionListCheckOption(interp, obj); + } + break; + + case 'd': + if (!strcmp(cmd, "default")) { + if (objc != 5 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "default "); + + if (obj->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = + NonposArgsGet(obj->nonposArgsTable, pattern); + if (nonposArgs && nonposArgs->ordinaryArgs) { + return ListDefaultFromOrdinaryArgs(interp, pattern, nonposArgs, + ObjStr(objv[3]), objv[4]); + } + } + if (nsp) + return ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), pattern, + ObjStr(objv[3]), objv[4]); + else + return TCL_OK; + } + break; + + case 'f': + if (!strcmp(cmd, "filter")) { + int withGuards = 0, withOrder = 0; + if (objc-modifiers > 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "filter ?-guards? ?-order? ?pat?"); + if (modifiers > 0) { + withGuards = checkForModifier(objv, modifiers, "-guards"); + withOrder = checkForModifier(objv, modifiers, "-order"); + + if (withGuards == 0 && withOrder == 0) + return XOTclVarErrMsg(interp, "info filter: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); + /* + if (withGuards && withOrder) + return XOTclVarErrMsg(interp, "info filter: cannot use -guards and -order together", + ObjStr(objv[2]), (char *) NULL); + */ + } + + if (withOrder) { + if (!(obj->flags & XOTCL_FILTER_ORDER_VALID)) + FilterComputeDefined(interp, obj); + return FilterInfo(interp, obj->filterOrder, pattern, withGuards, 1); + } + + return opt ? FilterInfo(interp, opt->filters, pattern, withGuards, 0) : TCL_OK; + + } else if (!strcmp(cmd, "filterguard")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "filterguard filter"); + return opt ? GuardList(interp, opt->filters, pattern) : TCL_OK; + } else if (!strcmp(cmd, "forward")) { + int argc = objc-modifiers; + int definition; + if (argc < 2 || argc > 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "forward ?-definition? ?name?"); + definition = checkForModifier(objv, modifiers, "-definition"); + if (nsp) + return forwardList(interp, Tcl_Namespace_cmdTable(nsp), pattern, definition); + else + return TCL_OK; + } + + break; + + case 'h': + if (!strcmp(cmd, "hasNamespace")) { + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), nsp != NULL); + return TCL_OK; + } + break; + + case 'i': + if (!strcmp(cmd, "invar")) { + if (objc != 2 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "invar"); + if (opt && opt->assertions) + Tcl_SetObjResult(interp, AssertionList(interp, opt->assertions->invariants)); + return TCL_OK; + } else if (!strcmp(cmd, "info")) { + if (objc > 2 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "info"); + return ListInfo(interp, GetXOTclClassFromObj(interp,obj->cmdName,NULL,0) == TCL_OK); + } + break; + + case 'm': + if (!strcmp(cmd, "mixin")) { + int withOrder = 0, withGuards = 0; + if (objc-modifiers > 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "mixin ?-guards? ?-order? ?class?"); + if (modifiers > 0) { + withOrder = checkForModifier(objv, modifiers, "-order"); + withGuards = checkForModifier(objv, modifiers, "-guards"); + + if (withOrder == 0 && withGuards == 0) + return XOTclVarErrMsg(interp, "info mixin: unknown modifier . ", + ObjStr(objv[2]), (char *) NULL); + } + + if (withOrder) { + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); + return MixinInfo(interp, obj->mixinOrder, pattern, withGuards); + } + + return opt ? MixinInfo(interp, opt->mixins, pattern, withGuards) : TCL_OK; + + } else if (!strcmp(cmd, "mixinguard")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "mixinguard mixin"); + + return opt ? GuardList(interp, opt->mixins, pattern) : TCL_OK; + } else if (!strcmp(cmd, "methods")) { + int noprocs = 0, nocmds = 0, nomixins = 0, inContext = 0; + if (objc-modifiers > 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "methods ?-noprocs? ?-nocmds? ?-nomixins? ?-incontext? ?pat?"); + if (modifiers > 0) { + noprocs = checkForModifier(objv, modifiers, "-noprocs"); + nocmds = checkForModifier(objv, modifiers, "-nocmds"); + nomixins = checkForModifier(objv, modifiers, "-nomixins"); + inContext = checkForModifier(objv, modifiers, "-incontext"); + } + return ListMethods(interp, obj, pattern, noprocs, nocmds, nomixins, inContext); + } +#ifdef XOTCL_METADATA + else if (!strcmp(cmd, "metadata")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "metadata ?pat?"); + return ListKeys(interp, &obj->metaData, pattern); + } +#endif + break; + + case 'n': + if (!strcmp(cmd, "nonposargs")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "nonposargs "); + if (obj->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = + NonposArgsGet(obj->nonposArgsTable, pattern); + if (nonposArgs) { + Tcl_SetObjResult(interp, NonposArgsFormat(interp, nonposArgs->nonposArgs)); + } + } + return TCL_OK; + } + break; + + case 'p': + if (!strcmp(cmd, "procs")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "procs ?pat?"); + if (nsp) + return ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern, + /*noProcs*/ 0, /*noCmds*/ 1, NULL, 0 ); + else + return TCL_OK; + } else if (!strcmp(cmd, "parent")) { + if (objc > 2 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "parent"); + return ListParent(interp, obj); + } else if (!strcmp(cmd, "pre")) { + XOTclProcAssertion *procs; + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "pre "); + if (opt) { + procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); + } + return TCL_OK; + } else if (!strcmp(cmd, "post")) { + XOTclProcAssertion *procs; + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "post "); + if (opt) { + procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); + } + return TCL_OK; + } else if (!strcmp(cmd, "precedence")) { + return ListPrecedence(interp, obj, pattern); + } + break; + case 'v': + if (!strcmp(cmd, "vars")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "vars ?pat?"); + return ListVars(interp, obj, pattern); + } + break; + } + return XOTclErrBadVal(interp, "info", + "an info option (use 'info info' to list all info options)", cmd); } + static int -XOTclONoinitMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; +XOTclOProcMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + char *argStr, *bdyStr, *name; + XOTclObjectOpt *opt; + int incr = 0, result = TCL_OK; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc != 1) return XOTclObjErrArgCnt(in, obj->cmdName, "noninit"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 4 || objc > 7) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "name ?non-positional-args? args body ?preAssertion postAssertion?"); - obj->flags |= XOTCL_INIT_CALLED; + if (objc == 5 || objc == 7) { + incr = 1; + } - return TCL_OK; -} + argStr = ObjStr(objv[2 + incr]); + bdyStr = ObjStr(objv[3 + incr]); + name = ObjStr(objv[1 + incr]); -Tcl_Obj* -XOTclOSetInstVar(XOTcl_Object *obj, Tcl_Interp *in, - Tcl_Obj *name, Tcl_Obj *value, int flgs) { - return XOTclOSetInstVar2(obj, in, name, (Tcl_Obj *)NULL, value, (flgs|TCL_PARSE_PART1)); + if (*argStr == 0 && *bdyStr == 0) { + opt = obj->opt; + if (opt) + AssertionRemoveProc(opt->assertions, name); + if (obj->nsPtr) + NSDeleteCmd(interp, obj->nsPtr, name); + } else { + XOTclAssertionStore *aStore = NULL; + if (objc > 5) { + opt = XOTclRequireObjectOpt(obj); + if (!opt->assertions) + opt->assertions = AssertionCreateStore(); + aStore = opt->assertions; + } + result = MakeProc(requireObjNamespace(interp, obj), aStore, &(obj->nonposArgsTable), + interp, objc, (Tcl_Obj **) objv, obj, 0); + } + + /* could be a filter => recompute filter order */ + FilterComputeDefined(interp, obj); + + return result; } -Tcl_Obj* -XOTclOGetInstVar(XOTcl_Object *obj, Tcl_Interp *in, Tcl_Obj *name, int flgs) { - return XOTclOGetInstVar2(obj, in, name, (Tcl_Obj *)NULL, (flgs|TCL_PARSE_PART1)); +static int +XOTclONoinitMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); + + obj->flags |= XOTCL_INIT_CALLED; + + return TCL_OK; } -int -XOTclUnsetInstVar(XOTcl_Object *obj, Tcl_Interp *in, char *name, int flgs) { - return XOTclUnsetInstVar2 (obj, in, name,(char *)NULL, flgs); +extern int +XOTclCreateObject(Tcl_Interp *interp, Tcl_Obj *name, XOTcl_Class *class) { + XOTclClass *cl = (XOTclClass*) class; + int result; + INCR_REF_COUNT(name); + result = XOTclCallMethodWithArgs((ClientData)cl, interp, + XOTclGlobalObjects[XOTE_CREATE], name, 1, 0, 0); + DECR_REF_COUNT(name); + return result; } extern int -XOTclCreateObject(Tcl_Interp *in, Tcl_Obj *name, XOTcl_Class *cli) { - XOTclClass *cl = (XOTclClass*) cli; - int result; - INCR_REF_COUNT(name); - result = XOTclCallMethodWithArgs((ClientData)cl, in, - XOTclGlobalObjects[XOTE_CREATE], name, 1, 0, 0); - DECR_REF_COUNT(name); - return result; +XOTclCreateClass(Tcl_Interp *interp, Tcl_Obj *name, XOTcl_Class *class) { + XOTclClass *cl = (XOTclClass*) class; + int result; + INCR_REF_COUNT(name); + result = XOTclCallMethodWithArgs((ClientData)cl, interp, + XOTclGlobalObjects[XOTE_CREATE], name, 1, 0, 0); + DECR_REF_COUNT(name); + return result; } extern int -XOTclCreateClass(Tcl_Interp *in, Tcl_Obj *name, XOTcl_Class *cli) { - XOTclClass *cl = (XOTclClass*) cli; - int result; - INCR_REF_COUNT(name); - result = XOTclCallMethodWithArgs((ClientData)cl, in, - XOTclGlobalObjects[XOTE_CREATE], name, 1, 0, 0); - DECR_REF_COUNT(name); - return result; +XOTclCreate(Tcl_Interp *interp, XOTcl_Class *class, Tcl_Obj *name, ClientData data, + int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = (XOTclClass *) class; + int result; + + INCR_REF_COUNT(name); + + ALLOC_ON_STACK(Tcl_Obj *,objc+2, ov); + ov[0] = NULL; + ov[1] = name; + if (objc>0) { + memcpy(ov+2,objv, sizeof(Tcl_Obj *)*objc); + } + result = createMethod(interp, (XOTclClass *)cl, data, objc+2, ov); + + FREE_ON_STACK(ov); + DECR_REF_COUNT(name); + + return result; } int -XOTclDeleteObject(Tcl_Interp *in, XOTcl_Object *obji) { - XOTclObject *obj = (XOTclObject*) obji; - return callMethod((ClientData)obj, in, XOTclGlobalObjects[XOTE_DESTROY],2,0,0); +XOTclDeleteObject(Tcl_Interp *interp, XOTcl_Object *obji) { + XOTclObject *obj = (XOTclObject*) obji; + return callMethod((ClientData)obj, interp, XOTclGlobalObjects[XOTE_DESTROY],2,0,0); } int -XOTclDeleteClass(Tcl_Interp *in, XOTcl_Class *cli) { - XOTclClass *cl = (XOTclClass*) cli; - return callMethod((ClientData)cl, in, XOTclGlobalObjects[XOTE_DESTROY],2,0,0); +XOTclDeleteClass(Tcl_Interp *interp, XOTcl_Class *cli) { + XOTclClass *cl = (XOTclClass*) cli; + return callMethod((ClientData)cl, interp, XOTclGlobalObjects[XOTE_DESTROY],2,0,0); } -extern Tcl_Obj* -XOTclOSetInstVar2(XOTcl_Object *obji, Tcl_Interp *in, Tcl_Obj *name1, Tcl_Obj *name2, - Tcl_Obj *value, int flgs) { - XOTclObject *obj = (XOTclObject*) obji; - Tcl_Obj *result; - XOTcl_FrameDecls; - - XOTcl_PushFrame(in, obj); - if (obj->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; - - result = Tcl_ObjSetVar2(in, name1, name2, value, flgs); - XOTcl_PopFrame(in, obj); - return result; -} - extern int -XOTclUnsetInstVar2(XOTcl_Object *obji, Tcl_Interp *in, char *name1, char *name2, - int flgs) { - XOTclObject *obj = (XOTclObject*) obji; - int result; - XOTcl_FrameDecls; +XOTclUnsetInstVar2(XOTcl_Object *obji, Tcl_Interp *interp, char *name1, char *name2, + int flgs) { + XOTclObject *obj = (XOTclObject*) obji; + int result; + XOTcl_FrameDecls; - XOTcl_PushFrame(in, obj); - if (obj->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; + XOTcl_PushFrame(interp, obj); + if (obj->nsPtr) + flgs |= TCL_NAMESPACE_ONLY; - result = Tcl_UnsetVar2(in, name1, name2, flgs); - XOTcl_PopFrame(in, obj); - return result; + result = Tcl_UnsetVar2(interp, name1, name2, flgs); + XOTcl_PopFrame(interp, obj); + return result; } + static int -GetInstVarIntoCurrentScope(Tcl_Interp *in, XOTclObject *obj, +GetInstVarIntoCurrentScope(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *varName, Tcl_Obj *newName) { - Var *varPtr = NULL, *otherPtr = NULL, *arrayPtr; - int new; - Tcl_CallFrame *varFramePtr; - TclVarHashTable *tablePtr; - XOTcl_FrameDecls; + Var *varPtr = NULL, *otherPtr = NULL, *arrayPtr; + int new; + Tcl_CallFrame *varFramePtr; + TclVarHashTable *tablePtr; + XOTcl_FrameDecls; - int flgs = TCL_LEAVE_ERR_MSG | - /* PARSE_PART1 needed for 8.0.5 */ TCL_PARSE_PART1; + int flgs = TCL_LEAVE_ERR_MSG | + /* PARSE_PART1 needed for 8.0.5 */ TCL_PARSE_PART1; +#if 0 + /* why do we need to deal with vars with namepaces paths? */ + if (newName && strstr(varName, "::")) { + /* the source variable name contains a namespace path. to locate it, we need a namespace */ + requireObjNamespace(interp, obj); + } + /*fprintf(stderr,"GetIntoScope obj=%s ns=%p newName=%s\n",ObjStr(obj->cmdName),obj->nsPtr,newName);*/ +#endif - XOTcl_PushFrame(in, obj); - if (obj->nsPtr) { - flgs = flgs|TCL_NAMESPACE_ONLY; - } + XOTcl_PushFrame(interp, obj); + if (obj->nsPtr) { + flgs = flgs|TCL_NAMESPACE_ONLY; + } - otherPtr = XOTclObjLookupVar(in, varName, (char *) NULL, flgs, "define", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - XOTcl_PopFrame(in, obj); + otherPtr = XOTclObjLookupVar(interp, varName, (char *) NULL, flgs, "define", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + XOTcl_PopFrame(interp, obj); - if (otherPtr == NULL) { - return XOTclVarErrMsg(in, "can't make instvar ", ObjStr(varName), - ": can't find variable on ", ObjStr(obj->cmdName), - (char *) NULL); - } - - /* - * if newName == NULL -> there is no alias, use varName - * as target link name - */ - if (newName == NULL) { + if (otherPtr == NULL) { + return XOTclVarErrMsg(interp, "can't make instvar ", ObjStr(varName), + ": can't find variable on ", ObjStr(obj->cmdName), + (char *) NULL); + } /* - * Variable link into namespace cannot be an element in an array. - * see Tcl_VariableObjCmd ... + * if newName == NULL -> there is no alias, use varName + * as target link name */ - if (arrayPtr) { - return XOTclVarErrMsg(in, "can't make instvar ", ObjStr(varName), - " on ", ObjStr(obj->cmdName), - ": variable cannot be an element in an array;", - " use an alias or objeval.", (char *) NULL); - } + if (newName == NULL) { + /* + * Variable link into namespace cannot be an element in an array. + * see Tcl_VariableObjCmd ... + */ + if (arrayPtr) { + return XOTclVarErrMsg(interp, "can't make instvar ", ObjStr(varName), + " on ", ObjStr(obj->cmdName), + ": variable cannot be an element in an array;", + " use an alias or objeval.", (char *) NULL); + } - newName = varName; - } - - varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(in); - - /* - * If we are executing inside a Tcl procedure, create a local - * variable linked to the new namespace variable "varName". - */ - if (varFramePtr != NULL && Tcl_CallFrame_isProcCallFrame(varFramePtr)) { - Proc *procPtr = Tcl_CallFrame_procPtr(varFramePtr); - int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - Var *localVarPtr = Tcl_CallFrame_compiledLocals(varFramePtr); - char *newNameString = ObjStr(newName); - int i, nameLen = strlen(newNameString); - - for (i = 0; i < localCt; i++) { /* look in compiled locals */ - - /* fprintf(stderr,"%d of %d %s flags %x not isTemp %d\n",i,localCt, - localPtr->name,localPtr->flags, - !TclIsCompiledLocalTemporary(localPtr));*/ - - if (!TclIsCompiledLocalTemporary(localPtr)) { - char *localName = localPtr->name; - if ((newNameString[0] == localName[0]) - && (nameLen == localPtr->nameLength) - && (strcmp(newNameString, localName) == 0)) { - varPtr = getNthVar(localVarPtr,i); - new = 0; - break; - } - } - localPtr = localPtr->nextPtr; + newName = varName; } +#if 0 + /* fprintf(stderr,"ERRORMSG=%s newName='%s' array %p, othervar %p\n", + ObjStr(Tcl_GetObjResult(interp)),newName,arrayPtr,otherPtr); + */ + if (strstr(newName, "::")) { + return XOTclVarErrMsg(interp, "variable name \"", newName, + "\" illegal: must not contain namespace separator", + (char *) NULL); + } +#endif + varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); - if (varPtr == NULL) { /* look in frame's local var hashtable */ - tablePtr = Tcl_CallFrame_varTablePtr(varFramePtr); - if (tablePtr == NULL) { - tablePtr = (TclVarHashTable *) ckalloc(varHashTableSize); - InitVarHashTable(tablePtr, NULL); - Tcl_CallFrame_varTablePtr(varFramePtr) = tablePtr; - } - varPtr = VarHashCreateVar(tablePtr, newName, &new); - } /* - * if we define an alias (newName != varName), be sure that - * the target does not exist already + * If we are executing inside a Tcl procedure, create a local + * variable linked to the new namespace variable "varName". */ - if (!new) { - if (varPtr == otherPtr) - return XOTclVarErrMsg(in, "can't instvar to variable itself", - (char *) NULL); + if (varFramePtr != NULL && Tcl_CallFrame_isProcCallFrame(varFramePtr)) { + Proc *procPtr = Tcl_CallFrame_procPtr(varFramePtr); + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + Var *localVarPtr = Tcl_CallFrame_compiledLocals(varFramePtr); + char *newNameString = ObjStr(newName); + int i, nameLen = strlen(newNameString); + + for (i = 0; i < localCt; i++) { /* look in compiled locals */ + /* fprintf(stderr,"%d of %d %s flags %x not isTemp %d\n",i,localCt, + localPtr->name,localPtr->flags, + !TclIsCompiledLocalTemporary(localPtr));*/ - if (TclIsVarLink(varPtr)) { - /* we try to make the same instvar again ... this is ok */ - Var *linkPtr = valueOfVar(Var,varPtr,linkPtr); - if (linkPtr == otherPtr) { - return TCL_OK; - } + if (!TclIsCompiledLocalTemporary(localPtr)) { + char *localName = localPtr->name; + if ((newNameString[0] == localName[0]) + && (nameLen == localPtr->nameLength) + && (strcmp(newNameString, localName) == 0)) { + varPtr = getNthVar(localVarPtr,i); + new = 0; + break; + } + } + localPtr = localPtr->nextPtr; + } + + if (varPtr == NULL) { /* look in frame's local var hashtable */ + tablePtr = Tcl_CallFrame_varTablePtr(varFramePtr); + if (tablePtr == NULL) { + tablePtr = (TclVarHashTable *) ckalloc(varHashTableSize); + InitVarHashTable(tablePtr, NULL); + Tcl_CallFrame_varTablePtr(varFramePtr) = tablePtr; + } + varPtr = VarHashCreateVar(tablePtr, newName, &new); + } + /* + * if we define an alias (newName != varName), be sure that + * the target does not exist already + */ + if (!new) { + /*fprintf(stderr,"GetIntoScope createalias\n");*/ + if (varPtr == otherPtr) + return XOTclVarErrMsg(interp, "can't instvar to variable itself", + (char *) NULL); - /*fprintf(stderr, "linkvar flags=%x\n",linkPtr->flags); - panic("new linkvar %s... When does this happen?",newNameString,NULL);*/ - - /* We have already a variable with the same name imported - from a different object. Get rid of this old variable - */ - VarHashRefCount(linkPtr)--; - if (TclIsVarUndefined(linkPtr)) { - CleanupVar(linkPtr, (Var *) NULL); - } + if (TclIsVarLink(varPtr)) { + /* we try to make the same instvar again ... this is ok */ + Var *linkPtr = valueOfVar(Var,varPtr,linkPtr); + if (linkPtr == otherPtr) { + return TCL_OK; + } - } else if (!TclIsVarUndefined(varPtr)) { - return XOTclVarErrMsg(in, "variable '", ObjStr(newName), - "' exists already", (char *) NULL); - } else if (TclIsVarTraced(varPtr)) { - return XOTclVarErrMsg(in, "variable '", ObjStr(newName), - "' has traces: can't use for instvar", (char *) NULL); - } - } + /*fprintf(stderr, "linkvar flags=%x\n",linkPtr->flags); + panic("new linkvar %s... When does this happen?",newNameString,NULL);*/ + + /* We have already a variable with the same name imported + from a different object. Get rid of this old variable + */ + VarHashRefCount(linkPtr)--; + if (TclIsVarUndefined(linkPtr)) { + CleanupVar(linkPtr, (Var *) NULL); + } + + } else if (!TclIsVarUndefined(varPtr)) { + return XOTclVarErrMsg(interp, "variable '", ObjStr(newName), + "' exists already", (char *) NULL); + } else if (TclIsVarTraced(varPtr)) { + return XOTclVarErrMsg(interp, "variable '", ObjStr(newName), + "' has traces: can't use for instvar", (char *) NULL); + } + } - TclSetVarLink(varPtr); - TclClearVarUndefined(varPtr); + TclSetVarLink(varPtr); + TclClearVarUndefined(varPtr); #if FORWARD_COMPATIBLE - if (forwardCompatibleMode) { - Var85 *vPtr = (Var85 *)varPtr; - vPtr->value.linkPtr = (Var85 *)otherPtr; - } else { - varPtr->value.linkPtr = otherPtr; - } + if (forwardCompatibleMode) { + Var85 *vPtr = (Var85 *)varPtr; + vPtr->value.linkPtr = (Var85 *)otherPtr; + } else { + varPtr->value.linkPtr = otherPtr; + } #else - varPtr->value.linkPtr = otherPtr; + varPtr->value.linkPtr = otherPtr; #endif - VarHashRefCount(otherPtr)++; - - /* - { - Var85 *p = (Var85 *)varPtr; - fprintf(stderr,"defining an alias var='%s' in obj %s fwd %d flags %x isLink %d isTraced %d isUndefined %d\n", - ObjStr(newName), ObjStr(obj->cmdName), forwardCompatibleMode, - varFlags(varPtr), - TclIsVarLink(varPtr), TclIsVarTraced(varPtr), TclIsVarUndefined(varPtr)); + VarHashRefCount(otherPtr)++; + + /* + { + Var85 *p = (Var85 *)varPtr; + fprintf(stderr,"defining an alias var='%s' in obj %s fwd %d flags %x isLink %d isTraced %d isUndefined %d\n", + ObjStr(newName), ObjStr(obj->cmdName), forwardCompatibleMode, + varFlags(varPtr), + TclIsVarLink(varPtr), TclIsVarTraced(varPtr), TclIsVarUndefined(varPtr)); + } + */ } - */ - } - return TCL_OK; + return TCL_OK; } static int -XOTclOInstVarMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]); +XOTclOInstVarMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); extern int -XOTclInstVar(XOTcl_Object *obji, Tcl_Interp *in, char *name, char *destName) { - XOTclObject *obj = (XOTclObject*) obji; - int result; - Tcl_Obj *alias = 0; - ALLOC_ON_STACK(Tcl_Obj*,2, objv); +XOTclInstVar(XOTcl_Object *obji, Tcl_Interp *interp, char *name, char *destName) { + XOTclObject *obj = (XOTclObject*) obji; + int result; + Tcl_Obj *alias = 0; + ALLOC_ON_STACK(Tcl_Obj *,2, objv); - objv[0] = XOTclGlobalObjects[XOTE_INSTVAR]; - objv[1] = Tcl_NewStringObj(name, -1); - INCR_REF_COUNT(objv[1]); + objv[0] = XOTclGlobalObjects[XOTE_INSTVAR]; + objv[1] = Tcl_NewStringObj(name, -1); + INCR_REF_COUNT(objv[1]); - if (destName != 0) { - alias = Tcl_NewStringObj(destName, -1); - INCR_REF_COUNT(alias); - Tcl_ListObjAppendElement(in, objv[1], alias); - } + if (destName != 0) { + alias = Tcl_NewStringObj(destName, -1); + INCR_REF_COUNT(alias); + Tcl_ListObjAppendElement(interp, objv[1], alias); + } - result = XOTclOInstVarMethod((ClientData) obj, in, 2, objv); + result = XOTclOInstVarMethod((ClientData) obj, interp, 2, objv); - if (destName != 0) { - DECR_REF_COUNT(alias); - } - DECR_REF_COUNT(objv[1]); - FREE_ON_STACK(objv); - return result; + if (destName != 0) { + DECR_REF_COUNT(alias); + } + DECR_REF_COUNT(objv[1]); + FREE_ON_STACK(objv); + return result; } extern void -XOTclRemovePMethod(Tcl_Interp *in, XOTcl_Object *obji, char *nm) { - XOTclObject *obj = (XOTclObject*) obji; - if (obj->nsPtr) - NSDeleteCmd(in, obj->nsPtr, nm); +XOTclRemovePMethod(Tcl_Interp *interp, XOTcl_Object *obji, char *nm) { + XOTclObject *obj = (XOTclObject*) obji; + if (obj->nsPtr) + NSDeleteCmd(interp, obj->nsPtr, nm); } extern void -XOTclRemoveIMethod(Tcl_Interp *in, XOTcl_Class *cli, char *nm) { - XOTclClass *cl = (XOTclClass*) cli; - NSDeleteCmd(in, cl->nsPtr, nm); +XOTclRemoveIMethod(Tcl_Interp *interp, XOTcl_Class *cli, char *nm) { + XOTclClass *cl = (XOTclClass*) cli; + NSDeleteCmd(interp, cl->nsPtr, nm); } /* * obj/cl ClientData setter/getter */ extern void XOTclSetObjClientData(XOTcl_Object *obji, ClientData data) { - XOTclObject *obj = (XOTclObject*) obji; - XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); - opt->clientData = data; + XOTclObject *obj = (XOTclObject*) obji; + XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); + opt->clientData = data; } extern ClientData XOTclGetObjClientData(XOTcl_Object *obji) { - XOTclObject *obj = (XOTclObject*) obji; - return (obj && obj->opt) ? obj->opt->clientData : 0; + XOTclObject *obj = (XOTclObject*) obji; + return (obj && obj->opt) ? obj->opt->clientData : 0; } extern void XOTclSetClassClientData(XOTcl_Class *cli, ClientData data) { - XOTclClass *cl = (XOTclClass*) cli; - XOTclRequireClassOpt(cl); - cl->opt->clientData = data; + XOTclClass *cl = (XOTclClass*) cli; + XOTclRequireClassOpt(cl); + cl->opt->clientData = data; } extern ClientData XOTclGetClassClientData(XOTcl_Class *cli) { - XOTclClass *cl = (XOTclClass*) cli; - return (cl && cl->opt) ? cl->opt->clientData : 0; + XOTclClass *cl = (XOTclClass*) cli; + return (cl && cl->opt) ? cl->opt->clientData : 0; } static int -setInstVar(Tcl_Interp *in, XOTclObject *obj, Tcl_Obj *name, Tcl_Obj* value) { - Tcl_Obj *result; - int flags = (obj->nsPtr) ? TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY : TCL_LEAVE_ERR_MSG; - XOTcl_FrameDecls; - XOTcl_PushFrame(in, obj); +setInstVar(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *name, Tcl_Obj *value) { + Tcl_Obj *result; + int flags = (obj->nsPtr) ? TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY : TCL_LEAVE_ERR_MSG; + XOTcl_FrameDecls; + XOTcl_PushFrame(interp, obj); - if (value == NULL) { - result = Tcl_ObjGetVar2(in, name, NULL, flags); - } else { - result = Tcl_ObjSetVar2(in, name, NULL, value, flags); - } - XOTcl_PopFrame(in, obj); + if (value == NULL) { + result = Tcl_ObjGetVar2(interp, name, NULL, flags); + } else { + result = Tcl_ObjSetVar2(interp, name, NULL, value, flags); + } + XOTcl_PopFrame(interp, obj); - if (result) { - Tcl_SetObjResult(in, result); - return TCL_OK; - } - return TCL_ERROR; + if (result) { + Tcl_SetObjResult(interp, result); + return TCL_OK; + } + return TCL_ERROR; } static int -XOTclOSetMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; +XOTclOSetMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc > 3) XOTclObjErrArgCnt(in, obj->cmdName, "set var ?value?"); - return setInstVar(in, obj, objv[1], objc == 3 ? objv[2] : NULL); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc > 3) XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "var ?value?"); + return setInstVar(interp, obj, objv[1], objc == 3 ? objv[2] : NULL); } static int -XOTclSetterMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; +XOTclSetterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc > 2) return XOTclObjErrArgCnt(in, obj->cmdName, "parameter ?value?"); - return setInstVar(in, obj, objv[0], objc == 2 ? objv[1] : NULL); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc > 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?value?"); + return setInstVar(interp, obj, objv[0], objc == 2 ? objv[1] : NULL); } static int -XOTclOUpvarMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - Tcl_Obj *frameInfoObj = NULL; - int i, result = TCL_ERROR; - char *frameInfo; - callFrameContext ctx = {0}; +XOTclOUpvarMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + Tcl_Obj *frameInfoObj = NULL; + int i, result = TCL_ERROR; + char *frameInfo; + callFrameContext ctx = {0}; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 2) return XOTclObjErrArgCnt(in, obj->cmdName, - "?level? otherVar localVar ?otherVar localVar ...?"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "?level? otherVar localVar ?otherVar localVar ...?"); - if (objc % 2 == 0) { - frameInfo = ObjStr(objv[1]); - i = 2; - } else { - frameInfoObj = computeLevelObj(in, CALLING_LEVEL); - INCR_REF_COUNT(frameInfoObj); - frameInfo = ObjStr(frameInfoObj); - i = 1; - } + if (objc % 2 == 0) { + frameInfo = ObjStr(objv[1]); + i = 2; + } else { + frameInfoObj = computeLevelObj(interp, CALLING_LEVEL); + INCR_REF_COUNT(frameInfoObj); + frameInfo = ObjStr(frameInfoObj); + i = 1; + } - if (obj && (obj->filterStack || obj->mixinStack)) { - CallStackUseActiveFrames(in, &ctx); - } + if (obj && (obj->filterStack || obj->mixinStack)) { + CallStackUseActiveFrames(interp, &ctx); + } - for ( ; i < objc; i += 2) { - result = Tcl_UpVar2(in, frameInfo, ObjStr(objv[i]), NULL, - ObjStr(objv[i+1]), 0 /*flags*/); - if (result != TCL_OK) - break; - } + for ( ; i < objc; i += 2) { + result = Tcl_UpVar2(interp, frameInfo, ObjStr(objv[i]), NULL, + ObjStr(objv[i+1]), 0 /*flags*/); + if (result != TCL_OK) + break; + } - if (frameInfoObj) { - DECR_REF_COUNT(frameInfoObj); - } - CallStackRestoreSavedFrames(in, &ctx); - return result; + if (frameInfoObj) { + DECR_REF_COUNT(frameInfoObj); + } + CallStackRestoreSavedFrames(interp, &ctx); + return result; } static int -XOTclOUplevelMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { - XOTclObject *obj = (XOTclObject *)cd; - int i, result = TCL_ERROR; - char *frameInfo = NULL; - Tcl_CallFrame *framePtr = NULL, *savedVarFramePtr; +XOTclOUplevelMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject *)clientData; + int i, result = TCL_ERROR; + char *frameInfo = NULL; + Tcl_CallFrame *framePtr = NULL, *savedVarFramePtr; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 2) { - uplevelSyntax: - return XOTclObjErrArgCnt(in, obj->cmdName, "?level? command ?arg ...?"); - } - /* - * Find the level to use for executing the command. - */ - if (objc>2) { - CallFrame *cf; - frameInfo = ObjStr(objv[1]); - result = TclGetFrame(in, frameInfo, &cf); - if (result == -1) { - return TCL_ERROR; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) { + uplevelSyntax: + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?level? command ?arg ...?"); } - framePtr = (Tcl_CallFrame *)cf; - i = result+1; - } else { - i = 1; - } + /* + * Find the level to use for executing the command. + */ + if (objc>2) { + CallFrame *cf; + frameInfo = ObjStr(objv[1]); + result = TclGetFrame(interp, frameInfo, &cf); + if (result == -1) { + return TCL_ERROR; + } + framePtr = (Tcl_CallFrame *)cf; + i = result+1; + } else { + i = 1; + } - objc -= i; - objv += i; - if (objc == 0) { - goto uplevelSyntax; - } + objc -= i; + objv += i; + if (objc == 0) { + goto uplevelSyntax; + } - if (!framePtr) { - XOTclCallStackContent *csc = XOTclCallStackFindLastInvocation(in, 1); - if (csc) - framePtr = csc->currentFramePtr; - } + if (!framePtr) { + XOTclCallStackContent *csc = XOTclCallStackFindLastInvocation(interp, 1); + if (csc) + framePtr = csc->currentFramePtr; + } - savedVarFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(in); - Tcl_Interp_varFramePtr(in) = (CallFrame *)framePtr; + savedVarFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(interp); + Tcl_Interp_varFramePtr(interp) = (CallFrame *)framePtr; - /* - * Execute the residual arguments as a command. - */ - - if (objc == 1) { - result = Tcl_EvalObjEx(in, objv[0], TCL_EVAL_DIRECT); - } else { /* - * More than one argument: concatenate them together with spaces - * between, then evaluate the result. Tcl_EvalObjEx will delete - * the object when it decrements its refcount after eval'ing it. + * Execute the residual arguments as a command. */ - Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv); - result = Tcl_EvalObjEx(in, objPtr, TCL_EVAL_DIRECT); - } - if (result == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; - sprintf(msg, "\n (\"uplevel\" body line %d)", in->errorLine); - Tcl_AddObjErrorInfo(in, msg, -1); - } - /* - * Restore the variable frame, and return. - */ + if (objc == 1) { + result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT); + } else { + /* + * More than one argument: concatenate them together with spaces + * between, then evaluate the result. Tcl_EvalObjEx will delete + * the object when it decrements its refcount after eval'ing it. + */ + Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv); + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); + } + if (result == TCL_ERROR) { + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } - Tcl_Interp_varFramePtr(in) = (CallFrame *)savedVarFramePtr; - return result; + /* + * Restore the variable frame, and return. + */ + + Tcl_Interp_varFramePtr(interp) = (CallFrame *)savedVarFramePtr; + return result; } static int -forwardArg(Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[], +forwardArg(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], Tcl_Obj *o, forwardCmdClientData *tcd, Tcl_Obj **out, - Tcl_Obj **freeList, int *inputarg, int *mapvalue) { - char *element = ObjStr(o), *p; - int totalargs = objc + tcd->nr_args - 1; - char c = *element, c1; + Tcl_Obj **freeList, int *interpputarg, int *mapvalue) { + char *element = ObjStr(o), *p; + int totalargs = objc + tcd->nr_args - 1; + char c = *element, c1; - p = element; + p = element; - if (c == '%' && *(element+1) == '@') { - char *remainder = NULL; - long pos; - element += 2; - pos = strtol(element,&remainder,0); - /*fprintf(stderr,"strtol('%s) returned %ld '%s'\n",element,pos,remainder);*/ - if (element == remainder && *element == 'e' && !strncmp(element,"end",3)) { - pos = totalargs; - remainder += 3; + if (c == '%' && *(element+1) == '@') { + char *remainder = NULL; + long pos; + element += 2; + pos = strtol(element,&remainder,0); + /*fprintf(stderr,"strtol('%s) returned %ld '%s'\n",element,pos,remainder);*/ + if (element == remainder && *element == 'e' && !strncmp(element,"end",3)) { + pos = totalargs; + remainder += 3; + } + if (element == remainder || abs(pos) > totalargs) { + return XOTclVarErrMsg(interp, "forward: invalid index specified in argument ", + ObjStr(o), (char *) NULL); + } if (!remainder || *remainder != ' ') { + return XOTclVarErrMsg(interp, "forward: invaild syntax in '", ObjStr(o), + "' use: %@ ",(char *) NULL); + } + + element = ++remainder; + if (pos<0) pos = totalargs + pos; + /*fprintf(stderr,"remainder = '%s' pos = %ld\n",remainder,pos);*/ + *mapvalue = pos; + element = remainder; + c = *element; } - if (element == remainder || abs(pos) > totalargs) { - return XOTclVarErrMsg(in, "forward: invalid index specified in argument ", - ObjStr(o), (char *) NULL); - } if (!remainder || *remainder != ' ') { - return XOTclVarErrMsg(in, "forward: invaild syntax in '", ObjStr(o), - "' use: %@ ",(char *) NULL); - } + /*fprintf(stderr,"c==%c element = '%s'\n",c,element);*/ + if (c == '%') { + Tcl_Obj *list = 0, **listElements; + int nrargs = objc-1, nrElements = 0; + c = *++element; + c1 = *(element+1); - element = ++remainder; - if (pos<0) pos = totalargs + pos; - /*fprintf(stderr,"remainder = '%s' pos = %ld\n",remainder,pos);*/ - *mapvalue = pos; - element = remainder; - c = *element; - } - /*fprintf(stderr,"c==%c element = '%s'\n",c,element);*/ - if (c == '%') { - Tcl_Obj *list = 0, **listElements; - int nrargs = objc-1, nrElements = 0; - c = *++element; - c1 = *(element+1); - - if (c == 's' && !strcmp(element,"self")) { - *out = tcd->obj->cmdName; - } else if (c == 'p' && !strcmp(element,"proc")) { - *out = objv[0]; - } else if (c == '1' && (c1 == '\0' || c1 == ' ')) { - /*fprintf(stderr, " nrargs=%d, subcommands=%d inputarg=%d, objc=%d\n", - nrargs, tcd->nr_subcommands, inputarg, objc);*/ - if (c1 != '\0') { - if (Tcl_ListObjIndex(in, o, 1, &list) != TCL_OK) { - return XOTclVarErrMsg(in, "forward: %1 must by a valid list, given: '", - ObjStr(o), "'", (char *) NULL); - } - if (Tcl_ListObjGetElements(in, list, &nrElements, &listElements) != TCL_OK) { - return XOTclVarErrMsg(in, "forward: %1 contains invalid list '", - ObjStr(list),"'", (char *) NULL); - } - } else if (tcd->subcommands) { /* deprecated part */ - if (Tcl_ListObjGetElements(in, tcd->subcommands,&nrElements,&listElements) != TCL_OK) { - return XOTclVarErrMsg(in, "forward: %1 contains invalid list '", - ObjStr(list),"'", (char *) NULL); - } - } - if (nrElements > nrargs) { - /* insert default subcommand depending on number of arguments */ - *out = listElements[nrargs]; - } else if (objc<=1) { - return XOTclObjErrArgCnt(in, objv[0], "no argument given"); - } else { - *out = objv[1]; - *inputarg = 2; - } - } else if (c == 'a' && !strncmp(element,"argcl", 4)) { - if (Tcl_ListObjIndex(in, o, 1, &list) != TCL_OK) { - return XOTclVarErrMsg(in, "forward: %argclindex must by a valid list, given: '", - ObjStr(o), "'", (char *) NULL); - } - if (Tcl_ListObjGetElements(in, list, &nrElements, &listElements) != TCL_OK) { - return XOTclVarErrMsg(in, "forward: %argclindex contains invalid list '", - ObjStr(list),"'", (char *) NULL); - } - if (nrargs >= nrElements) { - return XOTclVarErrMsg(in, "forward: not enough elements in specified list of ARGC argument ", - ObjStr(o), (char *) NULL); - } - *out = listElements[nrargs]; - } else if (c == '%') { - Tcl_Obj *newarg = Tcl_NewStringObj(element,-1); - *out = newarg; - goto add_to_freelist; + if (c == 's' && !strcmp(element,"self")) { + *out = tcd->obj->cmdName; + } else if (c == 'p' && !strcmp(element,"proc")) { + *out = objv[0]; + } else if (c == '1' && (c1 == '\0' || c1 == ' ')) { + /*fprintf(stderr, " nrargs=%d, subcommands=%d inputarg=%d, objc=%d\n", + nrargs, tcd->nr_subcommands, inputarg, objc);*/ + if (c1 != '\0') { + if (Tcl_ListObjIndex(interp, o, 1, &list) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %1 must by a valid list, given: '", + ObjStr(o), "'", (char *) NULL); + } + if (Tcl_ListObjGetElements(interp, list, &nrElements, &listElements) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %1 contains invalid list '", + ObjStr(list),"'", (char *) NULL); + } + } else if (tcd->subcommands) { /* deprecated part */ + if (Tcl_ListObjGetElements(interp, tcd->subcommands,&nrElements,&listElements) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %1 contains invalid list '", + ObjStr(list),"'", (char *) NULL); + } + } + if (nrElements > nrargs) { + /* insert default subcommand depending on number of arguments */ + *out = listElements[nrargs]; + } else if (objc<=1) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, "option"); + } else { + *out = objv[1]; + *interpputarg = 2; + } + } else if (c == 'a' && !strncmp(element,"argcl", 4)) { + if (Tcl_ListObjIndex(interp, o, 1, &list) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %argclindex must by a valid list, given: '", + ObjStr(o), "'", (char *) NULL); + } + if (Tcl_ListObjGetElements(interp, list, &nrElements, &listElements) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %argclindex contains invalid list '", + ObjStr(list),"'", (char *) NULL); + } + if (nrargs >= nrElements) { + return XOTclVarErrMsg(interp, "forward: not enough elements in specified list of ARGC argument ", + ObjStr(o), (char *) NULL); + } + *out = listElements[nrargs]; + } else if (c == '%') { + Tcl_Obj *newarg = Tcl_NewStringObj(element,-1); + *out = newarg; + goto add_to_freelist; + } else { + /* evaluating given command */ + int result; + /*fprintf(stderr,"evaluating '%s'\n",element);*/ + if ((result = Tcl_EvalEx(interp, element, -1, 0)) != TCL_OK) + return result; + *out = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + /*fprintf(stderr,"result = '%s'\n",ObjStr(*out));*/ + goto add_to_freelist; + } } else { - /* evaluating given command */ - int result; - /*fprintf(stderr,"evaluating '%s'\n",element);*/ - if ((result = Tcl_EvalEx(in, element, -1, 0)) != TCL_OK) - return result; - *out = Tcl_DuplicateObj(Tcl_GetObjResult(in)); - /*fprintf(stderr,"result = '%s'\n",ObjStr(*out));*/ - goto add_to_freelist; + if (p == element) + *out = o; + else { + Tcl_Obj *newarg = Tcl_NewStringObj(element,-1); + *out = newarg; + goto add_to_freelist; + } } - } else { - if (p == element) - *out = o; - else { - Tcl_Obj *newarg = Tcl_NewStringObj(element,-1); - *out = newarg; - goto add_to_freelist; - } - } - return TCL_OK; + return TCL_OK; add_to_freelist: - if (!*freeList) { - *freeList = Tcl_NewListObj(1, out); - INCR_REF_COUNT(*freeList); - } else - Tcl_ListObjAppendElement(in, *freeList, *out); - return TCL_OK; + if (!*freeList) { + *freeList = Tcl_NewListObj(1, out); + INCR_REF_COUNT(*freeList); + } else + Tcl_ListObjAppendElement(interp, *freeList, *out); + return TCL_OK; } static int -callForwarder(forwardCmdClientData *tcd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - ClientData cd; - int result; - XOTcl_FrameDecls; +callForwarder(forwardCmdClientData *tcd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + ClientData clientData; + int result; + XOTcl_FrameDecls; - if (tcd->verbose) { - Tcl_Obj* cmd = Tcl_NewListObj(objc, objv); - fprintf(stderr,"calling %s\n", ObjStr(cmd)); - DECR_REF_COUNT(cmd); - } - if (tcd->objscope) { - XOTcl_PushFrame(in, tcd->obj); - } - if (tcd->objProc) { - result = (tcd->objProc)(tcd->cd, in, objc, objv); - } else if (tcd->cmdName->typePtr == &XOTclObjectType - && XOTclObjConvertObject(in, tcd->cmdName, (void*)&cd) == TCL_OK) { - /*fprintf(stderr, "XOTcl object %s, objc=%d\n", ObjStr(tcd->cmdName),objc);*/ - result = ObjDispatch(cd, in, objc, objv, 0); - } else { - /*fprintf(stderr, "no XOTcl object %s\n", ObjStr(tcd->cmdName));*/ - result = Tcl_EvalObjv(in, objc, objv, 0); - } + if (tcd->verbose) { + Tcl_Obj *cmd = Tcl_NewListObj(objc, objv); + fprintf(stderr,"calling %s\n", ObjStr(cmd)); + DECR_REF_COUNT(cmd); + } + if (tcd->objscope) { + XOTcl_PushFrame(interp, tcd->obj); + } + if (tcd->objProc) { + /*fprintf(stderr, "callForwarder: callobjproc\n");*/ + result = (tcd->objProc)(tcd->clientData, interp, objc, objv); + } else if (tcd->cmdName->typePtr == &XOTclObjectType + && XOTclObjConvertObject(interp, tcd->cmdName, (void*)&clientData) == TCL_OK) { + /*fprintf(stderr, "callForwarder: XOTcl object %s, objc=%d\n", ObjStr(tcd->cmdName),objc);*/ + result = ObjDispatch(clientData, interp, objc, objv, 0); + } else { + /*fprintf(stderr, "callForwarder: no XOTcl object %s\n", ObjStr(tcd->cmdName));*/ + result = Tcl_EvalObjv(interp, objc, objv, 0); + } - if (tcd->objscope) { - XOTcl_PopFrame(in, tcd->obj); - } - return result; + if (tcd->objscope) { + XOTcl_PopFrame(interp, tcd->obj); + } + if (result == TCL_ERROR && tcd && tcd->onerror) { + Tcl_Obj *ov[2]; + ov[0] = tcd->onerror; + ov[1] = Tcl_GetObjResult(interp); + INCR_REF_COUNT(ov[1]); + /*Tcl_EvalObjEx(interp, tcd->onerror, TCL_EVAL_DIRECT);*/ + Tcl_EvalObjv(interp, 2, ov, 0); + DECR_REF_COUNT(ov[1]); + } + return result; } static int -XOTclForwardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - forwardCmdClientData *tcd = (forwardCmdClientData *)cd; - int result, j, inputarg=1, outputarg=0; - if (!tcd || !tcd->obj) return XOTclObjErrType(in, objv[0], "Object"); +XOTclForwardMethod(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) { + forwardCmdClientData *tcd = (forwardCmdClientData *)clientData; + int result, j, inputarg=1, outputarg=0; + if (!tcd || !tcd->obj) return XOTclObjErrType(interp, objv[0], "Object"); - /* it is a c-method; establish a value for the currentFramePtr */ - RUNTIME_STATE(in)->cs.top->currentFramePtr = - (Tcl_CallFrame *) Tcl_Interp_varFramePtr(in); - /* - fprintf(stderr,"...setting currentFramePtr %p to %p (ForwardMethod)\n", - RUNTIME_STATE(in)->cs.top->currentFramePtr, - (Tcl_CallFrame *) Tcl_Interp_varFramePtr(in)); */ - + /* it is a c-method; establish a value for the currentFramePtr */ + RUNTIME_STATE(interp)->cs.top->currentFramePtr = + (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp); - if (tcd->passthrough) { /* two short cuts for simple cases */ - /* early binding, cmd* resolved, we have to care only for objscope */ - return callForwarder(tcd, in, objc, objv); - } else if (!tcd->args && *(ObjStr(tcd->cmdName)) != '%') { - /* we have ony to replace the method name with the given cmd name */ - ALLOC_ON_STACK(Tcl_Obj*,objc, ov); - memcpy(ov,objv, sizeof(Tcl_Obj *)*objc); - ov[0] = tcd->cmdName; - result = callForwarder(tcd, in, objc, ov); - FREE_ON_STACK(ov); - return result; - } else { - Tcl_Obj **ov, *freeList=NULL; - int totalargs = objc + tcd->nr_args + 3; - ALLOC_ON_STACK(Tcl_Obj*,totalargs, OV); - ALLOC_ON_STACK(int, totalargs, objvmap); + /*fprintf(stderr,"...setting currentFramePtr %p to %p (ForwardMethod)\n", + RUNTIME_STATE(interp)->cs.top->currentFramePtr, + (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp)); */ + + if (tcd->passthrough) { /* two short cuts for simple cases */ + /* early binding, cmd* resolved, we have to care only for objscope */ + /*fprintf(stderr,"+++ forwardMethod passthrough \n");*/ + return callForwarder(tcd, interp, objc, objv); + } else if (!tcd->args && *(ObjStr(tcd->cmdName)) != '%') { + /* we have ony to replace the method name with the given cmd name */ + ALLOC_ON_STACK(Tcl_Obj *,objc, ov); + /*fprintf(stderr,"+++ forwardMethod must subst \n");*/ + memcpy(ov,objv, sizeof(Tcl_Obj *)*objc); + ov[0] = tcd->cmdName; + result = callForwarder(tcd, interp, objc, ov); + FREE_ON_STACK(ov); + return result; + } else { + Tcl_Obj **ov, *freeList=NULL; + int totalargs = objc + tcd->nr_args + 3; + ALLOC_ON_STACK(Tcl_Obj *,totalargs, OV); + ALLOC_ON_STACK(int, totalargs, objvmap); + /*fprintf(stderr,"+++ forwardMethod standard case \n");*/ - ov = &OV[1]; - if (tcd->needobjmap) { - memset(objvmap, -1, sizeof(int)*totalargs); - } + ov = &OV[1]; + if (tcd->needobjmap) { + memset(objvmap, -1, sizeof(int)*totalargs); + } #if 0 - fprintf(stderr,"command %s (%p) objc=%d, subcommand=%d, args=%p, nrargs\n", - ObjStr(objv[0]), tcd, objc, - tcd->nr_subcommands, - tcd->args - ); + fprintf(stderr,"command %s (%p) objc=%d, subcommand=%d, args=%p, nrargs\n", + ObjStr(objv[0]), tcd, objc, + tcd->nr_subcommands, + tcd->args + ); #endif - /* the first argument is always the command, to which we forward */ + /* the first argument is always the command, to which we forward */ - if ((result = forwardArg(in, objc, objv, tcd->cmdName, tcd, - &ov[outputarg], &freeList, &inputarg, - &objvmap[outputarg])) != TCL_OK) { - goto exitforwardmethod; - } - outputarg++; + if ((result = forwardArg(interp, objc, objv, tcd->cmdName, tcd, + &ov[outputarg], &freeList, &inputarg, + &objvmap[outputarg])) != TCL_OK) { + goto exitforwardmethod; + } + outputarg++; - if (tcd->args) { - /* copy argument list from definition */ - Tcl_Obj **listElements; - int nrElements; - Tcl_ListObjGetElements(in, tcd->args, &nrElements, &listElements); + if (tcd->args) { + /* copy argument list from definition */ + Tcl_Obj **listElements; + int nrElements; + Tcl_ListObjGetElements(interp, tcd->args, &nrElements, &listElements); - for (j=0; jnr_subcommands=%d size=%d\n", - objc, tcd->nr_subcommands, objc+ 2 );*/ + for (j=0; jnr_subcommands=%d size=%d\n", + objc, tcd->nr_subcommands, objc+ 2 );*/ - if (objc-inputarg>0) { - /*fprintf(stderr, " copying remaining %d args starting at [%d]\n", - objc-inputarg, outputarg);*/ - memcpy(ov+outputarg, objv+inputarg, sizeof(Tcl_Obj *)*(objc-inputarg)); - } else { - /*fprintf(stderr, " nothing to copy, objc=%d, inputarg=%d\n", objc, inputarg);*/ - } - objc += outputarg - inputarg; + if (objc-inputarg>0) { + /*fprintf(stderr, " copying remaining %d args starting at [%d]\n", + objc-inputarg, outputarg);*/ + memcpy(ov+outputarg, objv+inputarg, sizeof(Tcl_Obj *)*(objc-inputarg)); + } else { + /*fprintf(stderr, " nothing to copy, objc=%d, inputarg=%d\n", objc, inputarg);*/ + } + objc += outputarg - inputarg; #if 0 - for(j=0; jneedobjmap) - for (j=0; jpos) { - for(i=j; i>pos; i--) { - /*fprintf(stderr,"...moving right %d to %d\n",i-1,i);*/ - ov[i] = ov[i-1]; - objvmap[i] = objvmap[i-1]; - } - } else { - for(i=j; i %s\n",pos,ObjStr(tmp)); */ - ov[pos] = tmp; - objvmap[pos] = -1; - } + if (tcd->needobjmap) + for (j=0; jpos) { + for(i=j; i>pos; i--) { + /*fprintf(stderr,"...moving right %d to %d\n",i-1,i);*/ + ov[i] = ov[i-1]; + objvmap[i] = objvmap[i-1]; + } + } else { + for(i=j; i %s\n",pos,ObjStr(tmp)); */ + ov[pos] = tmp; + objvmap[pos] = -1; + } - if (tcd->prefix) { - /* prepend a prefix for the subcommands to avoid name clashes */ - Tcl_Obj *methodName = Tcl_DuplicateObj(tcd->prefix); - Tcl_AppendObjToObj(methodName, ov[1]); - ov[1] = methodName; - INCR_REF_COUNT(ov[1]); - } + if (tcd->prefix) { + /* prepend a prefix for the subcommands to avoid name clashes */ + Tcl_Obj *methodName = Tcl_DuplicateObj(tcd->prefix); + Tcl_AppendObjToObj(methodName, ov[1]); + ov[1] = methodName; + INCR_REF_COUNT(ov[1]); + } #if 0 - for(j=0; jcmdName; - result = callForwarder(tcd, in, objc, ov); + OV[0] = tcd->cmdName; + result = callForwarder(tcd, interp, objc, ov); - if (tcd->prefix) {DECR_REF_COUNT(ov[1]);} - exitforwardmethod: - if (freeList) {DECR_REF_COUNT(freeList);} - FREE_ON_STACK(objvmap); - FREE_ON_STACK(OV); - } - return result; + if (tcd->prefix) {DECR_REF_COUNT(ov[1]);} + exitforwardmethod: + if (freeList) {DECR_REF_COUNT(freeList);} + FREE_ON_STACK(objvmap); + FREE_ON_STACK(OV); + } + return result; } static int -XOTclOInstVarMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - Tcl_Obj **ov; - int i, oc, result = TCL_OK; - callFrameContext ctx = {0}; +XOTclOInstVarMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + Tcl_Obj **ov; + int i, oc, result = TCL_OK; + callFrameContext ctx = {0}; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 2) return XOTclObjErrArgCnt(in, obj->cmdName, "instvar ?vars?"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?vars?"); - if (obj && (obj->filterStack || obj->mixinStack) ) { - CallStackUseActiveFrames(in, &ctx); - } - if (!Tcl_Interp_varFramePtr(in)) { - CallStackRestoreSavedFrames(in, &ctx); - return XOTclVarErrMsg(in, "instvar used on ", ObjStr(obj->cmdName), - ", but callstack is not in procedure scope", - (char *) NULL); - } + if (obj && (obj->filterStack || obj->mixinStack) ) { + CallStackUseActiveFrames(interp, &ctx); + } + if (!Tcl_Interp_varFramePtr(interp)) { + CallStackRestoreSavedFrames(interp, &ctx); + return XOTclVarErrMsg(interp, "instvar used on ", ObjStr(obj->cmdName), + ", but callstack is not in procedure scope", + (char *) NULL); + } - for (i=1; icmdName, "vwait varname"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "varname"); - nameString = ObjStr(objv[1]); + nameString = ObjStr(objv[1]); - /* - * Make sure the var table exists and the varname is in there - */ - if (NSRequireVariableOnObj(in, obj, nameString, flgs) == 0) - return XOTclVarErrMsg(in, "Can't lookup (and create) variable ", - nameString, " on ", ObjStr(obj->cmdName), - (char *) NULL); + /* + * Make sure the var table exists and the varname is in there + */ + if (NSRequireVariableOnObj(interp, obj, nameString, flgs) == 0) + return XOTclVarErrMsg(interp, "Can't lookup (and create) variable ", + nameString, " on ", ObjStr(obj->cmdName), + (char *) NULL); - XOTcl_PushFrame(in, obj); - /* - * much of this is copied from Tcl, since we must avoid - * access with flag TCL_GLOBAL_ONLY ... doesn't work on - * obj->varTable vars - */ - if (Tcl_TraceVar(in, nameString, flgs, (Tcl_VarTraceProc *)VwaitVarProc, - (ClientData) &done) != TCL_OK) { - return TCL_ERROR; - } - done = 0; - foundEvent = 1; - while (!done && foundEvent) { - foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); - } - Tcl_UntraceVar(in, nameString, flgs, (Tcl_VarTraceProc *)VwaitVarProc, - (ClientData) &done); - XOTcl_PopFrame(in, obj); - /* - * Clear out the interpreter's result, since it may have been set - * by event handlers. - */ - Tcl_ResetResult(in); + XOTcl_PushFrame(interp, obj); + /* + * much of this is copied from Tcl, since we must avoid + * access with flag TCL_GLOBAL_ONLY ... doesn't work on + * obj->varTable vars + */ + if (Tcl_TraceVar(interp, nameString, flgs, (Tcl_VarTraceProc *)VwaitVarProc, + (ClientData) &done) != TCL_OK) { + return TCL_ERROR; + } + done = 0; + foundEvent = 1; + while (!done && foundEvent) { + foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); + } + Tcl_UntraceVar(interp, nameString, flgs, (Tcl_VarTraceProc *)VwaitVarProc, + (ClientData) &done); + XOTcl_PopFrame(interp, obj); + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + Tcl_ResetResult(interp); - if (!foundEvent) { - return XOTclVarErrMsg(in, "can't wait for variable '", nameString, - "': would wait forever", (char *) NULL); - } - return TCL_OK; + if (!foundEvent) { + return XOTclVarErrMsg(interp, "can't wait for variable '", nameString, + "': would wait forever", (char *) NULL); + } + return TCL_OK; } static int -XOTclOInvariantsMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - XOTclObjectOpt *opt; +XOTclOInvariantsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + XOTclObjectOpt *opt; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc != 2) - return XOTclObjErrArgCnt(in, obj->cmdName, "invar "); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); - opt = XOTclRequireObjectOpt(obj); + opt = XOTclRequireObjectOpt(obj); - if (opt->assertions) - TclObjListFreeList(opt->assertions->invariants); - else - opt->assertions = AssertionCreateStore(); + if (opt->assertions) + TclObjListFreeList(opt->assertions->invariants); + else + opt->assertions = AssertionCreateStore(); - opt->assertions->invariants = AssertionNewList(in, objv[1]); - return TCL_OK; + opt->assertions->invariants = AssertionNewList(interp, objv[1]); + return TCL_OK; } static int -XOTclOAutonameMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - int instanceOpt = 0, resetOpt = 0; - Tcl_Obj *autoname; +XOTclOAutonameMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + int instanceOpt = 0, resetOpt = 0; + Tcl_Obj *autoname; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc == 3) { - instanceOpt = (strcmp(ObjStr(objv[1]), "-instance") == 0); - resetOpt = (strcmp(ObjStr(objv[1]), "-reset") == 0); - } - if ((objc < 2 || objc > 3) || (objc == 3 && !instanceOpt && !resetOpt)) - return XOTclObjErrArgCnt(in, obj->cmdName, "autoname [-instance | -reset] name"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc == 3) { + instanceOpt = (strcmp(ObjStr(objv[1]), "-instance") == 0); + resetOpt = (strcmp(ObjStr(objv[1]), "-reset") == 0); + } + if ((objc < 2 || objc > 3) || (objc == 3 && !instanceOpt && !resetOpt)) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?-instance|-reset? name"); - autoname = AutonameIncr(in, objv[objc-1], obj, instanceOpt, resetOpt); - if (autoname) { - Tcl_SetObjResult(in, autoname); - DECR_REF_COUNT(autoname); - } - else - return XOTclVarErrMsg(in, - "Autoname failed. Probably format string (with %) was not well-formed", - (char *) NULL); + autoname = AutonameIncr(interp, objv[objc-1], obj, instanceOpt, resetOpt); + if (autoname) { + Tcl_SetObjResult(interp, autoname); + DECR_REF_COUNT(autoname); + } + else + return XOTclVarErrMsg(interp, + "Autoname failed. Probably format string (with %) was not well-formed", + (char *) NULL); - return TCL_OK; + return TCL_OK; } static int -XOTclOCheckMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - int ocArgs; Tcl_Obj **ovArgs; - int i; - XOTclObjectOpt *opt; +XOTclOCheckMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + int ocArgs; Tcl_Obj **ovArgs; + int i; + XOTclObjectOpt *opt; - /*fprintf(stderr,"checkmethod\n");*/ - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc != 2) - return XOTclObjErrArgCnt(in, obj->cmdName, - "check (?all? ?pre? ?post? ?invar? ?instinvar?)"); + /*fprintf(stderr,"checkmethod\n");*/ + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 2) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "?all? ?pre? ?post? ?invar? ?instinvar?"); - opt = XOTclRequireObjectOpt(obj); - opt->checkoptions = CHECK_NONE; + opt = XOTclRequireObjectOpt(obj); + opt->checkoptions = CHECK_NONE; - if (Tcl_ListObjGetElements(in, objv[1], &ocArgs, &ovArgs) == TCL_OK - && ocArgs > 0) { - for (i = 0; i < ocArgs; i++) { - char *option = ObjStr(ovArgs[i]); - if (option != 0) { - switch (*option) { - case 'i': - if (strcmp(option, "instinvar") == 0) { - opt->checkoptions |= CHECK_CLINVAR; - } else if (strcmp(option, "invar") == 0) { - opt->checkoptions |= CHECK_OBJINVAR; - } - break; - case 'p': - if (strcmp(option, "pre") == 0) { - opt->checkoptions |= CHECK_PRE; - } else if (strcmp(option, "post") == 0) { - opt->checkoptions |= CHECK_POST; - } - break; - case 'a': - if (strcmp(option, "all") == 0) { - opt->checkoptions |= CHECK_ALL; - } - break; - } - } + if (Tcl_ListObjGetElements(interp, objv[1], &ocArgs, &ovArgs) == TCL_OK + && ocArgs > 0) { + for (i = 0; i < ocArgs; i++) { + char *option = ObjStr(ovArgs[i]); + if (option != 0) { + switch (*option) { + case 'i': + if (strcmp(option, "instinvar") == 0) { + opt->checkoptions |= CHECK_CLINVAR; + } else if (strcmp(option, "invar") == 0) { + opt->checkoptions |= CHECK_OBJINVAR; + } + break; + case 'p': + if (strcmp(option, "pre") == 0) { + opt->checkoptions |= CHECK_PRE; + } else if (strcmp(option, "post") == 0) { + opt->checkoptions |= CHECK_POST; + } + break; + case 'a': + if (strcmp(option, "all") == 0) { + opt->checkoptions |= CHECK_ALL; + } + break; + } + } + } } - } - if (opt->checkoptions == CHECK_NONE && ocArgs>0) { - return XOTclVarErrMsg(in, "Unknown check option in command '", - ObjStr(obj->cmdName), " ", ObjStr(objv[0]), - " ", ObjStr(objv[1]), - "', valid: all pre post invar instinvar", - (char *) NULL); - } + if (opt->checkoptions == CHECK_NONE && ocArgs>0) { + return XOTclVarErrMsg(interp, "Unknown check option in command '", + ObjStr(obj->cmdName), " ", ObjStr(objv[0]), + " ", ObjStr(objv[1]), + "', valid: all pre post invar instinvar", + (char *) NULL); + } - Tcl_ResetResult(in); - return TCL_OK; + Tcl_ResetResult(interp); + return TCL_OK; } static int -XOTclConfigureCommand(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - int bool, opt, result = TCL_OK; - static CONST char *opts[] = { - "filter", "softrecreate", - NULL - }; - enum subCmdIdx { - filterIdx, softrecreateIdx - }; +XOTclConfigureCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + int bool, opt, result = TCL_OK; + static CONST char *opts[] = { + "filter", "softrecreate", + NULL + }; + enum subCmdIdx { + filterIdx, softrecreateIdx, + }; - if (objc < 2 || objc>3) - return XOTclObjErrArgCnt(in, objv[0], - "::xotcl::configure filter|softrecreate ?on|off?"); + if (objc < 2 || objc>3) + return XOTclObjErrArgCnt(interp, objv[0], NULL, + "filter|softrecreate ?on|off?"); - if (Tcl_GetIndexFromObj(in, objv[1], opts, "option", 0, &opt) != TCL_OK) { - return TCL_ERROR; - } + if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0, &opt) != TCL_OK) { + return TCL_ERROR; + } - if (objc == 3) { - result = Tcl_GetBooleanFromObj(in, objv[2], &bool); - } - if (result == TCL_OK) { - switch (opt) { - case filterIdx: - Tcl_SetBooleanObj(Tcl_GetObjResult(in), - (RUNTIME_STATE(in)->doFilters)); - if (objc == 3) - RUNTIME_STATE(in)->doFilters = bool; - break; + if (objc == 3) { + result = Tcl_GetBooleanFromObj(interp, objv[2], &bool); + } + if (result == TCL_OK) { + switch (opt) { + case filterIdx: + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (RUNTIME_STATE(interp)->doFilters)); + if (objc == 3) + RUNTIME_STATE(interp)->doFilters = bool; + break; - case softrecreateIdx: - Tcl_SetBooleanObj(Tcl_GetObjResult(in), - (RUNTIME_STATE(in)->doSoftrecreate)); - if (objc == 3) - RUNTIME_STATE(in)->doSoftrecreate = bool; - break; + case softrecreateIdx: + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (RUNTIME_STATE(interp)->doSoftrecreate)); + if (objc == 3) + RUNTIME_STATE(interp)->doSoftrecreate = bool; + break; + } } - } - return result; + return result; } static int -XOTclObjscopedMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - aliasCmdClientData *tcd = (aliasCmdClientData *)cd; - XOTclObject *obj = tcd->obj; - int rc; - XOTcl_FrameDecls; - /*fprintf(stderr,"objscopedMethod obj=%p, ptr=%p\n",obj,tcd->objProc);*/ - XOTcl_PushFrame(in, obj); - rc = (tcd->objProc)(tcd->cd, in, objc, objv); - XOTcl_PopFrame(in, obj); - return rc; +XOTclObjscopedMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + aliasCmdClientData *tcd = (aliasCmdClientData *)clientData; + XOTclObject *obj = tcd->obj; + int rc; + XOTcl_FrameDecls; + /*fprintf(stderr,"objscopedMethod obj=%p, ptr=%p\n",obj,tcd->objProc);*/ + XOTcl_PushFrame(interp, obj); + rc = (tcd->objProc)(tcd->clientData, interp, objc, objv); + XOTcl_PopFrame(interp, obj); + return rc; } -static void aliasCmdDeleteProc(ClientData cd) { - aliasCmdClientData *tcd = (aliasCmdClientData *)cd; - if (tcd->cmdName) {DECR_REF_COUNT(tcd->cmdName);} - /*fprintf(stderr,"aliasCmdDeleteProc\n");*/ - FREE(aliasCmdClientData, tcd); +static void aliasCmdDeleteProc(ClientData clientData) { + aliasCmdClientData *tcd = (aliasCmdClientData *)clientData; + if (tcd->cmdName) {DECR_REF_COUNT(tcd->cmdName);} + /*fprintf(stderr,"aliasCmdDeleteProc\n");*/ + FREE(aliasCmdClientData, tcd); } static int -XOTclAliasCommand(ClientData cd, Tcl_Interp *in, - int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = NULL; - XOTclClass *cl = NULL; - Tcl_Command cmd = NULL; - Tcl_ObjCmdProc *objProc; - char allocation, *methodName, *optionName; - Tcl_CmdDeleteProc* dp = NULL; - aliasCmdClientData *tcd = NULL; - int objscope = 0, i; +XOTclMethodPropertyCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = NULL; + XOTclClass *cl = NULL; + Tcl_Command cmd = NULL; + char allocation, *methodName, *optionName; + int protected = 0, i, opt; - if (objc < 4 || objc > 6) { - return XOTclObjErrArgCnt(in, objv[0], - "| ?-objscope? ?-per-object? "); - } + static CONST char *opts[] = {"protected", "public", "slotobj", NULL}; + enum subCmdIdx {protectedIdx, publicIdx, soltobjIdx}; + + /* TODO introspection */ + + if (objc < 4 || objc > 6) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, + "| ?-per-object? ??"); + } - GetXOTclClassFromObj(in, objv[1], &cl, 1); - if (!cl) { - XOTclObjConvertObject(in, objv[1], &obj); - if (!obj) - return XOTclObjErrType(in, objv[1], "Class|Object"); - allocation = 'o'; - } else { - allocation = 'c'; - } + GetXOTclClassFromObj(interp, objv[1], &cl, 0); + if (!cl) { + XOTclObjConvertObject(interp, objv[1], &obj); + if (!obj) + return XOTclVarErrMsg(interp, ObjStr(objv[0]), + " should be called on Class|Object, not ", + ObjStr(objv[1]), NULL); + allocation = 'o'; + } else { + obj = &cl->object; + allocation = 'c'; + } - methodName = ObjStr(objv[2]); + methodName = ObjStr(objv[2]); - for (i=3; i<5; i++) { - optionName = ObjStr(objv[i]); - if (*optionName != '-') break; - if (!strcmp("-objscope",optionName)) { - objscope = 1; - } else if (!strcmp("-per-object",optionName)) { - allocation = 'o'; + for (i=3; i<5 && i < objc; i++) { + optionName = ObjStr(objv[i]); + if (*optionName != '-') break; + if (!strcmp("-per-object",optionName)) { + allocation = 'o'; + if (cl) obj = &(cl->object); + } else { + return XOTclErrBadVal(interp, "::xotcl::methodproperty", + "option -per-object", optionName); + } + } + + if (Tcl_GetIndexFromObj(interp, objv[i], opts, "methodproperty", 0, &opt) != TCL_OK) { + return TCL_ERROR; + } + + /*fprintf(stderr, "allocation for %s = %c\n",ObjStr(objv[1]),allocation);*/ + + if (allocation == 'o') { /* xxx */ + if (obj->nsPtr) + cmd = FindMethod(methodName, obj->nsPtr); + if (!cmd) { + return XOTclVarErrMsg(interp, ObjStr(objv[0]), + " cannot lookup object method '", + methodName, "' for object ",ObjStr(objv[1]), + (char *) NULL); + } } else { - return XOTclErrBadVal(in, "::xotcl::alias", - "option -objscope or -per-object", optionName); + if (cl->nsPtr) + cmd = FindMethod(methodName, cl->nsPtr); + if (!cmd) + return XOTclVarErrMsg(interp, ObjStr(objv[0]), " cannot lookup method '", + methodName, "' from class ",ObjStr(objv[1]), + (char *) NULL); } - } + + if (opt == protectedIdx || opt == publicIdx) { + protected = (opt == protectedIdx); + + if (protected) { + Tcl_Command_flags(cmd) |= XOTCL_PROTECTED_METHOD; + } else { + Tcl_Command_flags(cmd) &= XOTCL_PROTECTED_METHOD; + } + } else { /* slotobj */ + Tcl_HashTable **nonposArgsTable = allocation == 'o' ? + &(obj->nonposArgsTable) : + &(cl->nonposArgsTable); + XOTclNonposArgs *nonposArgs; - cmd = Tcl_GetCommandFromObj(in, objv[i]); - if (cmd == NULL) - return XOTclVarErrMsg(in, "cannot lookup command '", - ObjStr(objv[i]), "'", (char *) NULL); - objProc = Tcl_Command_objProc(cmd); + if (i + 2 != objc) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, + "| ?-per-object? slotobj "); + } - if (objc>i+1) { - return XOTclVarErrMsg(in, "invalid argument '", - ObjStr(objv[i+1]), "'", (char *) NULL); - } + if (*nonposArgsTable == 0) { + *nonposArgsTable = NonposArgsCreateTable(); + fprintf(stderr,"this can only happen if we define a slotobj for a class/object without nonposargs\n"); + } + nonposArgs = NonposArgsGet(*nonposArgsTable, methodName); + if (nonposArgs == NULL) { + int nw; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(*nonposArgsTable, methodName, &nw); + assert(nw); - if (objscope) { - tcd = NEW(aliasCmdClientData); - tcd->cmdName = 0; - tcd->obj = allocation == 'c' ? &cl->object : obj; - tcd->objProc = objProc; - tcd->cd = Tcl_Command_objClientData(cmd); - objProc = XOTclObjscopedMethod; - dp = aliasCmdDeleteProc; - } + fprintf(stderr,"this can only happen if we define a slotobj for a method without nonpospargs\n slotobj = %s\n", ObjStr(objv[i+1])); - if (allocation == 'c') { - XOTclAddIMethod(in, (XOTcl_Class*)cl, methodName, objProc, tcd, dp); - } else { - XOTclAddPMethod(in, (XOTcl_Object*)obj, methodName, objProc, tcd, dp); - } - return TCL_OK; -} + MEM_COUNT_ALLOC("nonposArg",nonposArgs); + nonposArgs = (XOTclNonposArgs*)ckalloc(sizeof(XOTclNonposArgs)); + nonposArgs->slotObj = NULL; + nonposArgs->nonposArgs = NULL; + nonposArgs->ordinaryArgs = NULL; + Tcl_SetHashValue(hPtr, (ClientData)nonposArgs); + /* TODO check: + problem with nonposArgs->nonposArgs = NULL ? + problem with nonposArgs->ordinaryArgs = NULL ? + what happens if first method property and then method. + what happens if method then property then new method? + */ + } else { + + fprintf(stderr,"define slotobj for a method with nonpospargs\n slotobj = %s \n", ObjStr(objv[i+1])); + if (nonposArgs->slotObj) { + DECR_REF_COUNT(nonposArgs->slotObj); + } + } + nonposArgs->slotObj = objv[i+1]; + INCR_REF_COUNT(nonposArgs->slotObj); + } + + return TCL_OK; +} + static int -XOTclSetInstvarCommand(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj; +XOTclDispatchCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) { + int result; + char *method; + XOTclObject *obj; + register char *n; + ClientData cp; + /* xxx */ - if (objc < 3 || objc > 4) - return XOTclObjErrArgCnt(in, objv[0], "::xotcl::instvarset obj var ?value?"); + if (objc < 3) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?args?"); + } + XOTclObjConvertObject(interp, objv[2], &obj); + if (!obj) + return XOTclObjErrType(interp, objv[2], "Class|Object"); - XOTclObjConvertObject(in, objv[1], &obj); - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); + method = ObjStr(objv[1]); + n = method + strlen(method); - return setInstVar(in, obj ,objv[2], objc == 4 ? objv[3] : NULL); + /*search for last '::'*/ + while ((*n != ':' || *(n-1) != ':') && n-1 > method) {n--; } + if (*n == ':' && n > method && *(n-1) == ':') {n--;} + + if ((n-method)>1 || *method == ':') { + Tcl_DString parentNSName, *dsp = &parentNSName; + Tcl_Namespace *ns; + Tcl_Command cmd, importedCmd; + char *parentName, *tail = n+2; + DSTRING_INIT(dsp); + + if (n-method != 0) { + Tcl_DStringAppend(dsp, method, (n-method)); + parentName = Tcl_DStringValue(dsp); + ns = Tcl_FindNamespace(interp, parentName, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); + DSTRING_FREE(dsp); + } else { + ns = Tcl_FindNamespace(interp, "::", (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); + } + if (!ns) { + return XOTclVarErrMsg(interp, "cannot lookup parent namespace '", + method, "'", (char *) NULL); + } + + cmd = FindMethod(tail, ns); + if (cmd && (importedCmd = TclGetOriginalCommand(cmd))) { + cmd = importedCmd; + } + + if (cmd == NULL) { + return XOTclVarErrMsg(interp, "cannot lookup command '", + tail, "'", (char *) NULL); + } + + cp = Tcl_Command_objClientData(cmd); + result = DoCallProcCheck(cp, (ClientData)obj, interp, + objc-1, objv+1, cmd, obj, + NULL /*XOTclClass *cl*/, tail, + XOTCL_CSC_TYPE_PLAIN, 0, 1); + } else { + /* no colons, use method from dispatch order, with filters etc. - + strictly speaking unneccessary, but can be used to invoke protected methods */ + int nobjc; + Tcl_Obj *arg; + Tcl_Obj *CONST *nobjv; + + if (objc >= 3) { + arg = objv[3]; + nobjv = objv + 2; + } else { + arg = NULL; + nobjv = NULL; + } + nobjc = objc-3; + result = XOTclCallMethodWithArgs((ClientData)obj, interp, objv[1], arg, + nobjc, nobjv, XOTCL_CM_NO_UNKNOWN); + } + return result; } static int -XOTclSetRelationCommand(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - int oc; Tcl_Obj **ov; - XOTclObject *obj = NULL; - XOTclClass *cl = NULL; - XOTclObjectOpt *objopt = NULL; - XOTclClassOpt *clopt = NULL; - int i, opt; - static CONST char *opts[] = { - "mixin", "instmixin", - "filter", "instfilter", - "class", "superclass", - NULL - }; - enum subCmdIdx { - mixinIdx, instmixinIdx, - filterIdx, instfilterIdx, - classIdx, superclassIdx - }; +XOTclAliasCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = NULL; + XOTclClass *cl = NULL; + Tcl_Command cmd = NULL, importedCmd, newCmd; + Tcl_ObjCmdProc *objProc; + char allocation, *methodName, *optionName; + Tcl_CmdDeleteProc *dp = NULL; + aliasCmdClientData *tcd = NULL; + int objscope = 0, protected = 0, flags = 0, i; + + if (objc < 4 || objc > 6) { + return XOTclObjErrArgCnt(interp, objv[0], NULL, + "| ?-objscope? ?-per-object? "); + } + + GetXOTclClassFromObj(interp, objv[1], &cl, 0); + if (!cl) { + XOTclObjConvertObject(interp, objv[1], &obj); + if (!obj) + return XOTclObjErrType(interp, objv[1], "Class|Object"); + allocation = 'o'; + } else { + allocation = 'c'; + } + + methodName = ObjStr(objv[2]); - if (objc < 3) - return XOTclObjErrArgCnt(in, objv[0], "::xotcl::setrelation obj reltype classes"); + for (i=3; i<6 && i < objc; i++) { + optionName = ObjStr(objv[i]); + if (*optionName != '-') break; + if (!strcmp("-objscope",optionName)) { + objscope = 1; + } else if (!strcmp("-per-object",optionName)) { + allocation = 'o'; + } else if (!strcmp("-protected",optionName)) { + protected = 1; + } else { + return XOTclErrBadVal(interp, "::xotcl::alias", + "option -objscope or -per-object", optionName); + } + } - if (Tcl_GetIndexFromObj(in, objv[2], opts, "relation type", 0, &opt) != TCL_OK) { - return TCL_ERROR; - } + cmd = Tcl_GetCommandFromObj(interp, objv[i]); + if (cmd == NULL) + return XOTclVarErrMsg(interp, "cannot lookup command '", + ObjStr(objv[i]), "'", (char *) NULL); + + if ((importedCmd = TclGetOriginalCommand(cmd))) { + cmd = importedCmd; + } + objProc = Tcl_Command_objProc(cmd); - switch (opt) { - case mixinIdx: - case filterIdx: { - XOTclObjConvertObject(in, objv[1], &obj); - if (!obj) return XOTclObjErrType(in, objv[1], "Object"); - if (Tcl_ListObjGetElements(in, objv[3], &oc, &ov) != TCL_OK) - return TCL_ERROR; - objopt = XOTclRequireObjectOpt(obj); - break; - } - case instmixinIdx: - case instfilterIdx: { - GetXOTclClassFromObj(in, objv[1], &cl, 1); - if (!cl) return XOTclObjErrType(in, objv[1], "Class"); - if (Tcl_ListObjGetElements(in, objv[3], &oc, &ov) != TCL_OK) - return TCL_ERROR; - clopt = XOTclRequireClassOpt(cl); - break; - } - case superclassIdx: - { - GetXOTclClassFromObj(in, objv[1], &cl, 1); - if (!cl) return XOTclObjErrType(in, objv[1], "Class"); - if (Tcl_ListObjGetElements(in, objv[3], &oc, &ov) != TCL_OK) - return TCL_ERROR; - return SuperclassAdd(in, cl, oc, ov, objv[3]); + if (objc>i+1) { + return XOTclVarErrMsg(interp, "invalid argument '", + ObjStr(objv[i+1]), "'", (char *) NULL); } - case classIdx: - { - XOTclObjConvertObject(in, objv[1], &obj); - if (!obj) return XOTclObjErrType(in, objv[1], "Object"); - GetXOTclClassFromObj(in, objv[3], &cl, 1); - if (!cl) return XOTclErrBadVal(in, "class", "a class", ObjStr(objv[1])); - return changeClass(in, obj, cl); + + if (objscope) { + tcd = NEW(aliasCmdClientData); + tcd->cmdName = 0; + tcd->obj = allocation == 'c' ? &cl->object : obj; + tcd->objProc = objProc; + tcd->clientData = Tcl_Command_objClientData(cmd); + objProc = XOTclObjscopedMethod; + dp = aliasCmdDeleteProc; } - } - switch (opt) { - case mixinIdx: - { - if (objopt->mixins) CmdListRemoveList(&objopt->mixins, GuardDel); - - obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; - /* - * since mixin procs may be used as filters -> we have to invalidate - */ - obj->flags &= ~XOTCL_FILTER_ORDER_VALID; - - for (i = 0; i < oc; i++) { - if (MixinAdd(in, &objopt->mixins, ov[i]) != TCL_OK) - return TCL_ERROR; - } - - MixinComputeDefined(in, obj); - FilterComputeDefined(in, obj); - break; + if (protected) { + flags = XOTCL_PROTECTED_METHOD; } - case filterIdx: - { - if (objopt->filters) CmdListRemoveList(&objopt->filters, GuardDel); - - obj->flags &= ~XOTCL_FILTER_ORDER_VALID; - for (i = 0; i < oc; i ++) { - if (FilterAdd(in, &objopt->filters, ov[i], obj, 0) != TCL_OK) - return TCL_ERROR; - } - /*FilterComputeDefined(in, obj);*/ - break; + + if (allocation == 'c') { + /*fprintf(stderr,"alias for %s allocation %c\n",ObjStr(cl->object.cmdName),allocation);*/ + newCmd = XOTclAddInstanceMethod(interp, (XOTcl_Class*)cl, methodName, + objProc, tcd, dp, flags); + } else { + /*fprintf(stderr,"alias for %s allocation %c\n",ObjStr(obj->cmdName),allocation);*/ + newCmd = XOTclAddObjectMethod(interp, (XOTcl_Object*)obj, methodName, + objProc, tcd, dp, flags); } - case instmixinIdx: - { - if (clopt->instmixins) CmdListRemoveList(&clopt->instmixins, GuardDel); + return TCL_OK; +} - MixinInvalidateObjOrders(in, cl); - /* - * since mixin procs may be used as filters -> we have to invalidate - */ - FilterInvalidateObjOrders(in, cl); - - for (i = 0; i < oc; i++) { - if (MixinAdd(in, &clopt->instmixins, ov[i]) != TCL_OK) - return TCL_ERROR; - } - break; + + +static int +XOTclSetInstvarCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = NULL; + + if (objc < 3 || objc > 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, "obj var ?value?"); + /*fprintf(stderr,"setinstvar obj '%s' var '%s' %d\n",ObjStr(objv[1]),ObjStr(objv[2]),objc);*/ + XOTclObjConvertObject(interp, objv[1], &obj); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + + return setInstVar(interp, obj ,objv[2], objc == 4 ? objv[3] : NULL); +} + + +static int +XOTclRelationCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + int oc; Tcl_Obj **ov; + XOTclObject *obj = NULL; + XOTclClass *cl = NULL; + XOTclObjectOpt *objopt = NULL; + XOTclClassOpt *clopt = NULL; + int i, opt; + static CONST char *opts[] = { + "mixin", "instmixin", "object-mixin", "class-mixin", + "filter", "instfilter", "object-filter", "class-filter", + "class", "superclass", + NULL + }; + enum subCmdIdx { + mixinIdx, instmixinIdx, pomIdx, pcmIdx, + filterIdx, instfilterIdx, pofIdx, pcfIdx, + classIdx, superclassIdx + }; + + if (objc < 3 || objc > 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, "obj reltype values"); + + if (Tcl_GetIndexFromObj(interp, objv[2], opts, "relation type", 0, &opt) != TCL_OK) { + return TCL_ERROR; } - case instfilterIdx: - { - if (clopt->instfilters) CmdListRemoveList(&clopt->instfilters, GuardDel); - FilterInvalidateObjOrders(in, cl); + switch (opt) { + case pomIdx: + case mixinIdx: + case pofIdx: + case filterIdx: + XOTclObjConvertObject(interp, objv[1], &obj); + if (!obj) return XOTclObjErrType(interp, objv[1], "Object"); + if (objc == 3) { + objopt = obj->opt; + switch (opt) { + case pomIdx: + case mixinIdx: return objopt ? MixinInfo(interp, objopt->mixins, NULL, 1) : TCL_OK; + case pofIdx: + case filterIdx: return objopt ? FilterInfo(interp, objopt->filters, NULL, 1, 0) : TCL_OK; + } + } + if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) + return TCL_ERROR; + objopt = XOTclRequireObjectOpt(obj); + break; - for (i = 0; i < oc; i ++) { - if (FilterAdd(in, &clopt->instfilters, ov[i], 0, cl) != TCL_OK) - return TCL_ERROR; - } - break; + case pcmIdx: + case instmixinIdx: + case pcfIdx: + case instfilterIdx: + GetXOTclClassFromObj(interp, objv[1], &cl, 0); + if (!cl) return XOTclObjErrType(interp, objv[1], "Class"); + + if (objc == 3) { + clopt = cl->opt; + switch (opt) { + case pcmIdx: + case instmixinIdx: return clopt ? MixinInfo(interp, clopt->instmixins, NULL, 1) : TCL_OK; + case pcfIdx: + case instfilterIdx: return objopt ? FilterInfo(interp, clopt->instfilters, NULL, 1, 0) : TCL_OK; + } + } + + if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) + return TCL_ERROR; + clopt = XOTclRequireClassOpt(cl); + break; + + case superclassIdx: + GetXOTclClassFromObj(interp, objv[1], &cl, 0); + if (objc == 3) { + return ListSuperclasses(interp, cl, NULL); + } + if (!cl) return XOTclObjErrType(interp, objv[1], "Class"); + if (Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) + return TCL_ERROR; + return SuperclassAdd(interp, cl, oc, ov, objv[3], cl->object.cl); + + case classIdx: + XOTclObjConvertObject(interp, objv[1], &obj); + if (objc == 3) { + Tcl_SetObjResult(interp, obj->cl->object.cmdName); + return TCL_OK; + } + if (!obj) return XOTclObjErrType(interp, objv[1], "Object"); + GetXOTclClassFromObj(interp, objv[3], &cl, obj->cl); + if (!cl) return XOTclErrBadVal(interp, "class", "a class", ObjStr(objv[1])); + return changeClass(interp, obj, cl); } - } - return TCL_OK; + + switch (opt) { + case pomIdx: + case mixinIdx: + if (objopt->mixins) CmdListRemoveList(&objopt->mixins, GuardDel); + + obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + /* + * since mixin procs may be used as filters -> we have to invalidate + */ + obj->flags &= ~XOTCL_FILTER_ORDER_VALID; + + for (i = 0; i < oc; i++) { + if (MixinAdd(interp, &objopt->mixins, ov[i], obj->cl->object.cl) != TCL_OK) + return TCL_ERROR; + } + + MixinComputeDefined(interp, obj); + FilterComputeDefined(interp, obj); + break; + + case pofIdx: + case filterIdx: + if (objopt->filters) CmdListRemoveList(&objopt->filters, GuardDel); + + obj->flags &= ~XOTCL_FILTER_ORDER_VALID; + for (i = 0; i < oc; i ++) { + if (FilterAdd(interp, &objopt->filters, ov[i], obj, 0) != TCL_OK) + return TCL_ERROR; + } + /*FilterComputeDefined(interp, obj);*/ + break; + + case pcmIdx: + case instmixinIdx: + if (clopt->instmixins) CmdListRemoveList(&clopt->instmixins, GuardDel); + + MixinInvalidateObjOrders(interp, cl); + /* + * since mixin procs may be used as filters -> we have to invalidate + */ + FilterInvalidateObjOrders(interp, cl); + + for (i = 0; i < oc; i++) { + if (MixinAdd(interp, &clopt->instmixins, ov[i], cl->object.cl) != TCL_OK) + return TCL_ERROR; + } + break; + + case pcfIdx: + case instfilterIdx: + if (clopt->instfilters) CmdListRemoveList(&clopt->instfilters, GuardDel); + + FilterInvalidateObjOrders(interp, cl); + for (i = 0; i < oc; i ++) { + if (FilterAdd(interp, &clopt->instfilters, ov[i], 0, cl) != TCL_OK) + return TCL_ERROR; + } + break; + + } + return TCL_OK; } static int -XOTclOMixinGuardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - XOTclCmdList* h; - XOTclObjectOpt *opt; +XOTclOMixinGuardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + XOTclCmdList *h; + XOTclObjectOpt *opt; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc != 3) - return XOTclObjErrArgCnt(in, obj->cmdName, "mixinguard mixin guards"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "mixin guards"); - opt = obj->opt; - if (opt && opt->mixins) { - XOTclClass *mixinCl = XOTclpGetClass(in, ObjStr(objv[1])); - Tcl_Command mixinCmd = NULL; - if (mixinCl) { - mixinCmd = Tcl_GetCommandFromObj(in, mixinCl->object.cmdName); + opt = obj->opt; + if (opt && opt->mixins) { + XOTclClass *mixinCl = XOTclpGetClass(interp, ObjStr(objv[1])); + Tcl_Command mixinCmd = NULL; + if (mixinCl) { + mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName); + } + if (mixinCmd) { + h = CmdListFindCmdInList(mixinCmd, opt->mixins); + if (h) { + if (h->clientData) + GuardDel((XOTclCmdList*) h); + GuardAdd(interp, h, objv[2]); + obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + return TCL_OK; + } + } } - if (mixinCmd) { - h = CmdListFindCmdInList(mixinCmd, opt->mixins); - if (h) { - if (h->clientData) - GuardDel((XOTclCmdList*) h); - GuardAdd(in, h, objv[2]); - obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; - return TCL_OK; - } - } - } - return XOTclVarErrMsg(in, "Mixinguard: can't find mixin ", - ObjStr(objv[1]), " on ", ObjStr(obj->cmdName), - (char *) NULL); + return XOTclVarErrMsg(interp, "Mixinguard: can't find mixin ", + ObjStr(objv[1]), " on ", ObjStr(obj->cmdName), + (char *) NULL); } static int -XOTclOFilterGuardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - XOTclCmdList* h; - XOTclObjectOpt *opt; +XOTclOFilterGuardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + XOTclCmdList *h; + XOTclObjectOpt *opt; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc != 3) - return XOTclObjErrArgCnt(in, obj->cmdName, "filterguard filtername filterGuards"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 3) + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "filtername filterGuards"); - opt = obj->opt; - if (opt && opt->filters) { - h = CmdListFindNameInList(in, ObjStr(objv[1]), opt->filters); - if (h) { - if (h->clientData) - GuardDel((XOTclCmdList*) h); - GuardAdd(in, h, objv[2]); - obj->flags &= ~XOTCL_FILTER_ORDER_VALID; - return TCL_OK; + opt = obj->opt; + if (opt && opt->filters) { + h = CmdListFindNameInList(interp, ObjStr(objv[1]), opt->filters); + if (h) { + if (h->clientData) + GuardDel((XOTclCmdList*) h); + GuardAdd(interp, h, objv[2]); + obj->flags &= ~XOTCL_FILTER_ORDER_VALID; + return TCL_OK; + } } - } - return XOTclVarErrMsg(in, "Filterguard: can't find filter ", - ObjStr(objv[1]), " on ", ObjStr(obj->cmdName), - (char *) NULL); + return XOTclVarErrMsg(interp, "Filterguard: can't find filter ", + ObjStr(objv[1]), " on ", ObjStr(obj->cmdName), + (char *) NULL); } /* * Searches for filter on [self] and returns fully qualified name * if it is not found it returns an empty string */ static int -XOTclOFilterSearchMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - char *methodName; - XOTclCmdList *cmdList; - XOTclClass *fcl; - XOTclObject *fobj; +XOTclOFilterSearchMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + char *methodName; + XOTclCmdList *cmdList; + XOTclClass *fcl; + XOTclObject *fobj; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 2) return XOTclObjErrArgCnt(in, obj->cmdName, "filtersearch name"); - Tcl_ResetResult(in); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); + Tcl_ResetResult(interp); - if (!(obj->flags & XOTCL_FILTER_ORDER_VALID)) - FilterComputeDefined(in, obj); - if (!(obj->flags & XOTCL_FILTER_ORDER_DEFINED)) - return TCL_OK; + if (!(obj->flags & XOTCL_FILTER_ORDER_VALID)) + FilterComputeDefined(interp, obj); + if (!(obj->flags & XOTCL_FILTER_ORDER_DEFINED)) + return TCL_OK; - methodName = ObjStr(objv[1]); - cmdList = obj->filterOrder; + methodName = ObjStr(objv[1]); + cmdList = obj->filterOrder; - while (cmdList) { - CONST84 char *filterName = Tcl_GetCommandName(in, cmdList->cmdPtr); - if (filterName[0] == methodName[0] && !strcmp(filterName, methodName)) - break; - cmdList = cmdList->next; - } + while (cmdList) { + CONST84 char *filterName = Tcl_GetCommandName(interp, cmdList->cmdPtr); + if (filterName[0] == methodName[0] && !strcmp(filterName, methodName)) + break; + cmdList = cmdList->nextPtr; + } - if (!cmdList) - return TCL_OK; + if (!cmdList) + return TCL_OK; - fcl = cmdList->clorobj; - if (fcl && XOTclObjectIsClass(&fcl->object)) { - fobj = 0; - } else { - fobj = (XOTclObject*)fcl; - fcl = 0; - } + fcl = cmdList->clorobj; + if (fcl && XOTclObjectIsClass(&fcl->object)) { + fobj = 0; + } else { + fobj = (XOTclObject*)fcl; + fcl = 0; + } - Tcl_SetObjResult(in, - getFullProcQualifier(in, methodName, fobj, fcl, - cmdList->cmdPtr)); - return TCL_OK; + Tcl_SetObjResult(interp, + getFullProcQualifier(interp, methodName, fobj, fcl, + cmdList->cmdPtr)); + return TCL_OK; } static int -XOTclOProcSearchMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - XOTclClass *pcl = NULL; - Tcl_Command cmd = 0; - char *simpleName, *methodName; +XOTclOProcSearchMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + XOTclClass *pcl = NULL; + Tcl_Command cmd = NULL; + char *simpleName, *methodName; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 2) return XOTclObjErrArgCnt(in, obj->cmdName, "procsearch name"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], ""); - Tcl_ResetResult(in); + Tcl_ResetResult(interp); - methodName = ObjStr(objv[1]); + methodName = ObjStr(objv[1]); - if (obj->nsPtr) - cmd = FindMethod(methodName, obj->nsPtr); + if (obj->nsPtr) + cmd = FindMethod(methodName, obj->nsPtr); - if (!cmd) { - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(in, obj); + if (!cmd) { + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); - if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList* mixinList = obj->mixinOrder; - while (mixinList) { - XOTclClass *mcl = XOTclpGetClass(in, (char *)Tcl_GetCommandName(in, mixinList->cmdPtr)); - if (mcl && (pcl = SearchCMethod(mcl, methodName, &cmd))) { - break; - } - mixinList = mixinList->next; - } + if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *mixinList = obj->mixinOrder; + while (mixinList) { + XOTclClass *mcl = XOTclpGetClass(interp, (char *)Tcl_GetCommandName(interp, mixinList->cmdPtr)); + if (mcl && (pcl = SearchCMethod(mcl, methodName, &cmd))) { + break; + } + mixinList = mixinList->nextPtr; + } + } } - } - if (!cmd && obj->cl) - pcl = SearchCMethod(obj->cl, methodName, &cmd); + if (!cmd && obj->cl) + pcl = SearchCMethod(obj->cl, methodName, &cmd); - if (cmd) { - XOTclObject *pobj = pcl ? NULL : obj; - simpleName = (char *)Tcl_GetCommandName(in, cmd); - Tcl_SetObjResult(in, getFullProcQualifier(in, simpleName, pobj, pcl, cmd)); - } - return TCL_OK; + if (cmd) { + XOTclObject *pobj = pcl ? NULL : obj; + simpleName = (char *)Tcl_GetCommandName(interp, cmd); + Tcl_SetObjResult(interp, getFullProcQualifier(interp, simpleName, pobj, pcl, cmd)); + } + return TCL_OK; } static int -XOTclORequireNamespaceMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; +XOTclORequireNamespaceMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc != 1) return XOTclObjErrArgCnt(in, obj->cmdName, "requireNamespace"); + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc != 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); - requireObjNamespace(in, obj); - return TCL_OK; + requireObjNamespace(interp, obj); + return TCL_OK; } typedef enum {NO_DASH, SKALAR_DASH, LIST_DASH} dashArgType; static dashArgType -isDashArg(Tcl_Interp *in, Tcl_Obj *obj, char **methodName, int *objc, Tcl_Obj **objv[]) { - char *flag; - static Tcl_ObjType *listType = NULL; +isDashArg(Tcl_Interp *interp, Tcl_Obj *obj, char **methodName, int *objc, Tcl_Obj **objv[]) { + char *flag; + static Tcl_ObjType *listType = NULL; - assert(obj); + assert(obj); - /* fetch list type, if not set already; if used on more places, this should - be moved into the interpreter state - */ - if (listType == NULL) { + /* fetch list type, if not set already; if used on more places, this should + be moved into the interpreter state + */ + if (listType == NULL) { #if defined(PRE82) - Tcl_Obj *tmp = Tcl_NewListObj(1, &obj); - listType = tmp->typePtr; - DECR_REF_COUNT(tmp); + Tcl_Obj *tmp = Tcl_NewListObj(1, &obj); + listType = tmp->typePtr; + DECR_REF_COUNT(tmp); #else - static XOTclMutex initMutex = 0; - XOTclMutexLock(&initMutex); - if (listType == NULL) { - listType = Tcl_GetObjType("list"); - /*fprintf(stderr, "fetching listType=%p\n",listType);*/ - } - XOTclMutexUnlock(&initMutex); + static XOTclMutex initMutex = 0; + XOTclMutexLock(&initMutex); + if (listType == NULL) { + listType = Tcl_GetObjType("list"); + /*fprintf(stderr, "fetching listType=%p\n",listType);*/ + } + XOTclMutexUnlock(&initMutex); #endif - } + } - if (obj->typePtr == listType) { - if (Tcl_ListObjGetElements(in, obj, objc, objv) == TCL_OK && *objc>1) { - flag = ObjStr(*objv[0]); - /*fprintf(stderr, "we have a list starting with '%s'\n", flag);*/ - if (*flag == '-') { - *methodName = flag+1; - return LIST_DASH; - } + if (obj->typePtr == listType) { + if (Tcl_ListObjGetElements(interp, obj, objc, objv) == TCL_OK && *objc>1) { + flag = ObjStr(*objv[0]); + /*fprintf(stderr, "we have a list starting with '%s'\n", flag);*/ + if (*flag == '-') { + *methodName = flag+1; + return LIST_DASH; + } + } } - } - flag = ObjStr(obj); - /*fprintf(stderr, "we have a scalar '%s'\n", flag);*/ - if (*flag == '-' && isalpha((int)*((flag)+1))) { - *methodName = flag+1; - *objc = 1; - return SKALAR_DASH; - } - return NO_DASH; + flag = ObjStr(obj); + /*fprintf(stderr, "we have a scalar '%s'\n", flag);*/ + if (*flag == '-' && isalpha((int)*((flag)+1))) { + *methodName = flag+1; + *objc = 1; + return SKALAR_DASH; + } + return NO_DASH; } static int -callConfigureMethod(Tcl_Interp *in, XOTclObject *obj, +callConfigureMethod(Tcl_Interp *interp, XOTclObject *obj, char *methodName, int argc, Tcl_Obj *CONST argv[]) { - int result; - Tcl_Obj *method = Tcl_NewStringObj(methodName,-1); + int result; + Tcl_Obj *method = Tcl_NewStringObj(methodName,-1); - /*fprintf(stderr,"callConfigureMethod method %s->'%s' argc %d\n", - ObjStr(obj->cmdName), methodName, argc);*/ + /*fprintf(stderr,"callConfigureMethod method %s->'%s' argc %d\n", + ObjStr(obj->cmdName), methodName, argc);*/ - if (isInitString(methodName)) - obj->flags |= XOTCL_INIT_CALLED; + if (isInitString(methodName)) + obj->flags |= XOTCL_INIT_CALLED; - INCR_REF_COUNT(method); - result = callMethod((ClientData)obj, in, method, argc, argv, XOTCL_CM_NO_UNKNOWN); - DECR_REF_COUNT(method); + Tcl_ResetResult(interp); + INCR_REF_COUNT(method); + result = callMethod((ClientData)obj, interp, method, argc, argv, XOTCL_CM_NO_UNKNOWN); + DECR_REF_COUNT(method); - /*fprintf(stderr, "method '%s' called args: %d o=%p, result=%d\n", - methodName, argc+1, obj, result); */ + /*fprintf(stderr, "method '%s' called args: %d o=%p, result=%d %d\n", + methodName, argc+1, obj, result, TCL_ERROR);*/ - if (result != TCL_OK) { - Tcl_Obj *res = Tcl_DuplicateObj(Tcl_GetObjResult(in)); /* save the result */ - INCR_REF_COUNT(res); - XOTclVarErrMsg(in, ObjStr(res), " during '", ObjStr(obj->cmdName), " ", - methodName, "'", (char *) NULL); - DECR_REF_COUNT(res); - } - return result; + if (result != TCL_OK) { + /* XXXX TODO not sure, if we really need this; see kristoffer lawson mail */ + Tcl_Obj *res = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); /* save the result */ + INCR_REF_COUNT(res); + XOTclVarErrMsg(interp, ObjStr(res), " during '", ObjStr(obj->cmdName), " ", + methodName, "'", (char *) NULL); + DECR_REF_COUNT(res); + } + + return result; } static int -XOTclOConfigureMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - Tcl_Obj **argv, **nextArgv; - int i, argc, nextArgc, normalArgs, result = TCL_OK, isdasharg = NO_DASH; - char *methodName, *nextMethodName; +XOTclOSetvaluesMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + Tcl_Obj **argv, **nextArgv, *resultObj; + int i, argc, nextArgc, normalArgs, result = TCL_OK, isdasharg = NO_DASH; + char *methodName, *nextMethodName; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 1) return XOTclObjErrArgCnt(in, obj->cmdName, - "configure ?args?"); - /* find arguments without leading dash */ - for (i=1; i < objc; i++) { - if ((isdasharg = isDashArg(in, objv[i], &methodName, &argc, &argv))) - break; - } - normalArgs = i-1; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "?args?"); - for( ; i < objc; argc=nextArgc, argv=nextArgv, methodName=nextMethodName) { - Tcl_ResetResult(in); - switch (isdasharg) { - case SKALAR_DASH: /* argument is a skalar with a leading dash */ - { int j; - for (j = i+1; j < objc; j++, argc++) { - if ((isdasharg = isDashArg(in, objv[j], &nextMethodName, &nextArgc, &nextArgv))) - break; - } - result = callConfigureMethod(in, obj, methodName, argc+1, objv+i+1); - if (result != TCL_OK) - return result; - i += argc; - break; - } - case LIST_DASH: /* argument is a list with a leading dash, grouping determined by list */ - { i++; - if (icmdName), - " configure: unexpected argument '", - ObjStr(objv[i]), - "' between parameters", (char *) NULL); - } + /* find arguments without leading dash */ + for (i=1; i < objc; i++) { + if ((isdasharg = isDashArg(interp, objv[i], &methodName, &argc, &argv))) + break; } - } - Tcl_ResetResult(in); - Tcl_SetIntObj(Tcl_GetObjResult(in), normalArgs); - return result; + normalArgs = i-1; + Tcl_ResetResult(interp); + + for( ; i < objc; argc=nextArgc, argv=nextArgv, methodName=nextMethodName) { + Tcl_ResetResult(interp); + switch (isdasharg) { + case SKALAR_DASH: /* argument is a skalar with a leading dash */ + { int j; + for (j = i+1; j < objc; j++, argc++) { + if ((isdasharg = isDashArg(interp, objv[j], &nextMethodName, &nextArgc, &nextArgv))) + break; + } + result = callConfigureMethod(interp, obj, methodName, argc+1, objv+i+1); + if (result != TCL_OK) { + return result; + } + i += argc; + break; + } + case LIST_DASH: /* argument is a list with a leading dash, grouping determined by list */ + { i++; + if (icmdName), + " configure: unexpected argument '", + ObjStr(objv[i]), + "' between parameters", (char *) NULL); + } + } + } + + resultObj = Tcl_NewListObj(normalArgs, objv+1); + /*fprintf(stderr,".... setvalues returns %s\n",ObjStr(resultObj));*/ + Tcl_SetObjResult(interp, resultObj); + + return result; } +static int +XOTclOConfigureMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)clientData; + XOTclObjects *slotObjects, *so; + int result; + /* would be nice to do it here instead of setValue + XOTcl_FrameDecls; + XOTcl_PushFrame(interp, obj); make instvars of obj accessible */ + /* + * Search for default values on slots + */ + slotObjects = computeSlotObjects(interp, obj, NULL); + for (so = slotObjects; so; so = so->nextPtr) { + result = setDefaultValue(interp, obj, so->obj); + if (result != TCL_OK) { + goto configure_exit; + } + } + + /* + * call configure methods (starting with '-') + */ + result = callMethod((ClientData) obj, interp, + XOTclGlobalObjects[XOTE_SETVALUES], objc+1, objv+1, 0); + if (result != TCL_OK) { + goto configure_exit; + } + + /* + * Check, if we got the required values + */ + for (so = slotObjects; so; so = so->nextPtr) { + result = checkRequiredValue(interp, obj, so->obj); + if (result != TCL_OK) { + goto configure_exit; + } + } + + configure_exit: + /*XOTcl_PopFrame(interp, obj);*/ + + if (slotObjects) + XOTclObjectListFree(slotObjects); + return result; +} + + /* * class method implementations */ static int -XOTclCInstDestroyMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - XOTclObject *delobj; - int rc; +XOTclCInstDestroyMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclObject *delobj; - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc < 2) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "instdestroy "); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], ""); - if (XOTclObjConvertObject(in, objv[1], &delobj) != TCL_OK) - return XOTclVarErrMsg(in, "Can't destroy object ", - ObjStr(objv[1]), " that does not exist.", - (char *) NULL); + if (XOTclObjConvertObject(interp, objv[1], &delobj) != TCL_OK) + return XOTclVarErrMsg(interp, "Can't destroy object ", + ObjStr(objv[1]), " that does not exist.", + (char *) NULL); + /* + * latch, and call delete command if not already in progress + */ + delobj->flags |= XOTCL_DESTROY_CALLED; + RUNTIME_STATE(interp)->callIsDestroy = 1; + /*fprintf(stderr,"instDestroy %s : setting callIsDestroy = 1\n",ObjStr(objv[1]));*/ + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound != + XOTCL_EXITHANDLER_ON_SOFT_DESTROY) { + CallStackDestroyObject(interp, delobj); + } - /* fprintf(stderr,"instdestroy obj=%s, opt=%p\n",ObjStr(delobj->cmdName),delobj->opt);*/ - - rc = freeUnsetTraceVariable(in, delobj); - if (rc != TCL_OK) { - return rc; - } - - /* - * latch, and call delete command if not already in progress - */ - delobj->flags |= XOTCL_DESTROY_CALLED; - RUNTIME_STATE(in)->callIsDestroy = 1; - /*fprintf(stderr,"instDestroy: setting callIsDestroy = 1\n");*/ - if (RUNTIME_STATE(in)->exitHandlerDestroyRound != - XOTCL_EXITHANDLER_ON_SOFT_DESTROY) { - CallStackDestroyObject(in, delobj); - } - - return TCL_OK; + return TCL_OK; } static Tcl_Namespace * -callingNameSpace(Tcl_Interp *in) { - Tcl_Namespace *ns = NULL; - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; - XOTclCallStackContent *top = cs->top; - XOTclCallStackContent *csc = XOTclCallStackFindLastInvocation(in, 0); +callingNameSpace(Tcl_Interp *interp) { + Tcl_Namespace *ns = NULL; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; + XOTclCallStackContent *top = cs->top; + XOTclCallStackContent *csc = XOTclCallStackFindLastInvocation(interp, 0); - /*fprintf(stderr," **** use last invocation csc = %p\n", csc);*/ - if (csc && csc->currentFramePtr) { - /* use the callspace from the last invocation */ - XOTclCallStackContent *called = csccurrentFramePtr) : NULL; - /*fprintf(stderr," **** csc use frame= %p\n", f);*/ - if (f) { - ns = f->nsPtr; - } else { - Tcl_CallFrame *f = Tcl_CallFrame_callerPtr(csc->currentFramePtr); - ns = Tcl_GetCurrentNamespace(in); - /* find last incovation outside ::xotcl (for things like relmgr) */ - while (ns == RUNTIME_STATE(in)->XOTclNS) { - if (f) { - ns = f->nsPtr; - f = Tcl_CallFrame_callerPtr(f); - } else { - ns = Tcl_GetGlobalNamespace(in); - } - } - /*fprintf(stderr, "found ns %p '%s'\n",ns, ns?ns->fullName:"NULL");*/ + /*fprintf(stderr," **** use last invocation csc = %p\n", csc);*/ + if (csc && csc->currentFramePtr) { + /* use the callspace from the last invocation */ + XOTclCallStackContent *called = csccurrentFramePtr) : NULL; + /*fprintf(stderr," **** csc use frame= %p\n", f);*/ + if (f) { + ns = f->nsPtr; + } else { + Tcl_CallFrame *f = Tcl_CallFrame_callerPtr(csc->currentFramePtr); + ns = Tcl_GetCurrentNamespace(interp); + /* find last incovation outside ::xotcl (for things like relmgr) */ + while (ns == RUNTIME_STATE(interp)->XOTclNS) { + if (f) { + ns = f->nsPtr; + f = Tcl_CallFrame_callerPtr(f); + } else { + ns = Tcl_GetGlobalNamespace(interp); + } + } + /*fprintf(stderr, "found ns %p '%s'\n",ns, ns?ns->fullName:"NULL");*/ + } } - } - if (!ns) { - /* calls on xotcl toplevel */ - XOTclCallStackContent *bot = cs->content + 1; - /*fprintf(stderr, " **** bot=%p diff=%d\n",bot, top-bot);*/ - if (top - bot >= 0 && bot->currentFramePtr) { - /* get calling tcl environment */ - Tcl_CallFrame *f = Tcl_CallFrame_callerPtr(bot->currentFramePtr); - if (f) { - ns = f->nsPtr; - /*fprintf(stderr, "top=%p, bot=%p b->c=%p f=%p ns=%p\n", - top,bot,bot->currentFramePtr, f, ns);*/ - /*fprintf(stderr,"ns from calling tcl environment %p '%s'\n", - ns, ns?ns->fullName : "" );*/ - } else { - /* fprintf(stderr, "nothing found, use ::\n"); */ - ns = Tcl_GetGlobalNamespace(in); - } + if (!ns) { + /* calls on xotcl toplevel */ + XOTclCallStackContent *bot = cs->content + 1; + /*fprintf(stderr, " **** bot=%p diff=%d\n",bot, top-bot);*/ + if (top - bot >= 0 && bot->currentFramePtr) { + /* get calling tcl environment */ + Tcl_CallFrame *f = Tcl_CallFrame_callerPtr(bot->currentFramePtr); + if (f) { + ns = f->nsPtr; + /*fprintf(stderr, "top=%p, bot=%p b->c=%p f=%p ns=%p\n", + top,bot,bot->currentFramePtr, f, ns);*/ + /*fprintf(stderr,"ns from calling tcl environment %p '%s'\n", + ns, ns?ns->fullName : "" );*/ + } else { + /* fprintf(stderr, "nothing found, use ::\n"); */ + ns = Tcl_GetGlobalNamespace(interp); + } + } } - } - /*XOTclCallStackDump(in);*/ - /*XOTclStackDump(in);*/ + /*XOTclCallStackDump(interp);*/ + /*XOTclStackDump(interp);*/ - /*fprintf(stderr,"callingNameSpace returns %p %s\n",ns,ns?ns->fullName:"");*/ - return ns; + /*fprintf(stderr,"callingNameSpace returns %p %s\n",ns,ns?ns->fullName:"");*/ + return ns; } static int -XOTclCAllocMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - XOTclClass *newcl; - XOTclObject *newobj; - int result; +XOTclCAllocMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclClass *newcl; + XOTclObject *newobj; + int result; - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc < 2) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "alloc ?args?"); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); #if 0 - fprintf(stderr, "type(%s)=%p %s %d\n", - ObjStr(objv[1]), objv[1]->typePtr, objv[1]->typePtr? - objv[1]->typePtr->name:"NULL", - XOTclObjConvertObject(in, objv[1], &newobj) - ); - /* - * if the lookup via GetObject for the object succeeds, - * the object exists already, - * and we do not overwrite it, but re-create it - */ - if (XOTclObjConvertObject(in, objv[1], &newobj) == TCL_OK) { - fprintf(stderr, "lookup successful\n"); - result = doCleanup(in, newobj, &cl->object, objc, objv); - } else + fprintf(stderr, "type(%s)=%p %s %d\n", + ObjStr(objv[1]), objv[1]->typePtr, objv[1]->typePtr? + objv[1]->typePtr->name:"NULL", + XOTclObjConvertObject(interp, objv[1], &newobj) + ); + /* + * if the lookup via GetObject for the object succeeds, + * the object exists already, + * and we do not overwrite it, but re-create it + */ + if (XOTclObjConvertObject(interp, objv[1], &newobj) == TCL_OK) { + fprintf(stderr, "lookup successful\n"); + result = doCleanup(interp, newobj, &cl->object, objc, objv); + } else #endif - { - /* - * create a new object from scratch - */ - char *objName = ObjStr(objv[1]); - Tcl_Obj *tmpName = NULL; + { + /* + * create a new object from scratch + */ + char *objName = ObjStr(objv[1]); + Tcl_Obj *tmpName = NULL; - if (!isAbsolutePath(objName)) { - /*fprintf(stderr, "CallocMethod\n");*/ - tmpName = NameInNamespaceObj(in,objName,callingNameSpace(in)); - /*fprintf(stderr, "NoAbsoluteName for '%s' -> determined = '%s'\n", - objName, ObjStr(tmpName));*/ - objName = ObjStr(tmpName); + if (!NSCheckColons(objName, 0)) { + return XOTclVarErrMsg(interp, "Cannot allocate object -- illegal name '", + objName, "'", (char *) NULL); + } - /*fprintf(stderr," **** name is '%s'\n", objName);*/ - INCR_REF_COUNT(tmpName); - } + if (!isAbsolutePath(objName)) { + /*fprintf(stderr, "CallocMethod\n");*/ + tmpName = NameInNamespaceObj(interp,objName,callingNameSpace(interp)); + /*fprintf(stderr, "NoAbsoluteName for '%s' -> determined = '%s'\n", + objName, ObjStr(tmpName));*/ + objName = ObjStr(tmpName); - if (IsMetaClass(in, cl)) { - /* - * if the base class is a meta-class, we create a class - */ - newcl = PrimitiveCCreate(in, objName, cl); - if (newcl == 0) - result = XOTclVarErrMsg(in, "Class alloc failed for '",objName, - "' (possibly parent namespace does not exist)", - (char *) NULL); - else { - Tcl_SetObjResult(in, newcl->object.cmdName); - result = TCL_OK; - } - } else { - /* - * if the base class is an ordinary class, we create an object - */ - newobj = PrimitiveOCreate(in, objName, cl); - if (newobj == 0) - result = XOTclVarErrMsg(in, "Object alloc failed for '",objName, - "' (possibly parent namespace does not exist)", - (char *) NULL); - else { - result = TCL_OK; - Tcl_SetObjResult(in, newobj->cmdName); - } - } + /*fprintf(stderr," **** name is '%s'\n", objName);*/ + INCR_REF_COUNT(tmpName); + } - if (tmpName) { - DECR_REF_COUNT(tmpName); - } + if (IsMetaClass(interp, cl)) { + /* + * if the base class is a meta-class, we create a class + */ + newcl = PrimitiveCCreate(interp, objName, cl); + if (newcl == 0) + result = XOTclVarErrMsg(interp, "Class alloc failed for '",objName, + "' (possibly parent namespace does not exist)", + (char *) NULL); + else { + Tcl_SetObjResult(interp, newcl->object.cmdName); + result = TCL_OK; + } + } else { + /* + * if the base class is an ordinary class, we create an object + */ + newobj = PrimitiveOCreate(interp, objName, cl); + if (newobj == 0) + result = XOTclVarErrMsg(interp, "Object alloc failed for '",objName, + "' (possibly parent namespace does not exist)", + (char *) NULL); + else { + result = TCL_OK; + Tcl_SetObjResult(interp, newobj->cmdName); + } + } + + if (tmpName) { + DECR_REF_COUNT(tmpName); + } - } + } - return result; + return result; } static int -createMethod(Tcl_Interp *in, XOTclClass *cl, XOTclObject *obj, - int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *newobj = NULL; - Tcl_Obj *nameObj, *tmpObj = NULL; - int result; - char *objName, *specifiedName; +createMethod(Tcl_Interp *interp, XOTclClass *cl, ClientData data, + int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *newobj = NULL; + Tcl_Obj *nameObj, *tmpObj = NULL; + int result; + char *objName, *specifiedName; - ALLOC_ON_STACK(Tcl_Obj*,objc, tov); + ALLOC_ON_STACK(Tcl_Obj *,objc, tov); - memcpy(tov, objv, sizeof(Tcl_Obj *)*(objc)); - specifiedName = objName = ObjStr(objv[1]); - /* - * complete the name if it is not absolute - */ - if (!isAbsolutePath(objName)) { - tmpObj = NameInNamespaceObj(in,objName,callingNameSpace(in)); - objName = ObjStr(tmpObj); - /*fprintf(stderr," **** name is '%s'\n", objName);*/ + memcpy(tov, objv, sizeof(Tcl_Obj *)*(objc)); + specifiedName = objName = ObjStr(objv[1]); + /* + * complete the name if it is not absolute + */ + if (!isAbsolutePath(objName)) { + tmpObj = NameInNamespaceObj(interp,objName,callingNameSpace(interp)); + objName = ObjStr(tmpObj); + /*fprintf(stderr," **** fixed name is '%s'\n", objName);*/ - INCR_REF_COUNT(tmpObj); - tov[1] = tmpObj; - } + INCR_REF_COUNT(tmpObj); + tov[1] = tmpObj; + } - /* - * Check whether we have to call recreate (i.e. when the - * object exists already) - */ - newobj = XOTclpGetObject(in, objName); + /* + * Check whether we have to call recreate (i.e. when the + * object exists already) + */ + newobj = XOTclpGetObject(interp, objName); - /*fprintf(stderr,"+++ create objv[1] '%s', specifiedName '%s', newObj=%p\n", - specifiedName, objName, newobj);*/ + /*fprintf(stderr,"+++ create objv[1] '%s', specifiedName '%s', newObj=%p\n", + specifiedName, objName, newobj);*/ - /* don't allow an object to be recreated as a class */ - if (newobj && (!IsMetaClass(in, cl) || IsMetaClass(in, newobj->cl))) { - /*fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d\n", - ObjStr(tov[1]),objc+1);*/ - /* call recreate --> initialization */ - result = callMethod((ClientData) obj, in, - XOTclGlobalObjects[XOTE_RECREATE], objc+1, tov+1, 0); - if (result != TCL_OK) - goto create_method_exit; + /* don't allow an object to be recreated as a class */ + if (newobj && (!IsMetaClass(interp, cl) || IsMetaClass(interp, newobj->cl))) { + /*fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d\n", + ObjStr(tov[1]),objc+1);*/ + /* call recreate --> initialization */ + result = callMethod((ClientData) cl, interp, + XOTclGlobalObjects[XOTE_RECREATE], objc+1, tov+1, 0); + if (result != TCL_OK) + goto create_method_exit; - Tcl_SetObjResult(in, newobj->cmdName); - nameObj = newobj->cmdName; - objTrace("RECREATE", newobj); + Tcl_SetObjResult(interp, newobj->cmdName); + nameObj = newobj->cmdName; + objTrace("RECREATE", newobj); - } else { + } else { - if (!NSCheckColons(specifiedName, 0)) { - result = XOTclVarErrMsg(in, "Cannot create object -- illegal name '", - specifiedName, "'", (char *) NULL); - goto create_method_exit; - } - - /* fprintf(stderr, "alloc ... %s\n", ObjStr(tov[1]));*/ - result = callMethod((ClientData) obj, in, - XOTclGlobalObjects[XOTE_ALLOC], objc+1, tov+1, 0); - if (result != TCL_OK) - goto create_method_exit; + /* fprintf(stderr, "alloc ... %s\n", ObjStr(tov[1]));*/ + result = callMethod((ClientData) cl, interp, + XOTclGlobalObjects[XOTE_ALLOC], objc+1, tov+1, 0); + if (result != TCL_OK) + goto create_method_exit; - nameObj = Tcl_GetObjResult(in); - if (XOTclObjConvertObject(in, nameObj, &newobj) != TCL_OK) { - result = XOTclErrMsg(in, "couldn't find result of alloc", TCL_STATIC); - goto create_method_exit; - } + nameObj = Tcl_GetObjResult(interp); + if (XOTclObjConvertObject(interp, nameObj, &newobj) != TCL_OK) { + result = XOTclErrMsg(interp, "couldn't find result of alloc", TCL_STATIC); + goto create_method_exit; + } - (void)RemoveInstance(newobj, newobj->cl); - AddInstance(newobj, cl); - objTrace("CREATE", newobj); + /*(void)RemoveInstance(newobj, newobj->cl);*/ /* TODO needed? remove? */ + AddInstance(newobj, cl); + objTrace("CREATE", newobj); - /* in case, the object is destroyed during initialization, we incr refcount */ - INCR_REF_COUNT(nameObj); - result = doObjInitialization(in, newobj, objc, objv); - DECR_REF_COUNT(nameObj); - } + if (data) { + XOTclObjectOpt *objopt = XOTclRequireObjectOpt(newobj); + objopt->clientData = data; + } + + /* in case, the object is destroyed during initialization, we incr refcount */ + INCR_REF_COUNT(nameObj); + result = doObjInitialization(interp, newobj, objc, objv); + DECR_REF_COUNT(nameObj); + } create_method_exit: - /* fprintf(stderr, "create -- end ... %s\n", ObjStr(tov[1]));*/ - if (tmpObj) {DECR_REF_COUNT(tmpObj);} - FREE_ON_STACK(tov); - return result; + /* fprintf(stderr, "create -- end ... %s\n", ObjStr(tov[1]));*/ + if (tmpObj) {DECR_REF_COUNT(tmpObj);} + FREE_ON_STACK(tov); + return result; } static int -XOTclCCreateMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); +XOTclCCreateMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(clientData); - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc < 2) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "create ?args?"); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); - if (RUNTIME_STATE(in)->exitHandlerDestroyRound != XOTCL_EXITHANDLER_OFF) { - fprintf(stderr,"### Can't create object %s during shutdown\n",ObjStr(objv[1])); - return TCL_ERROR; - return TCL_OK; /* don't fail, if this happens during destroy, it might be canceled */ - } + return createMethod(interp, cl, NULL, objc, objv); +} - return createMethod(in, cl, &cl->object, objc, objv); +static char * +XOTclUnsetTrace(ClientData clientData, Tcl_Interp *interp, CONST84 char *name, CONST84 char *name2, int flags) +{ + Tcl_Obj *obj = (Tcl_Obj *)clientData; + XOTclObject *o; + char *result = NULL; + + if (RUNTIME_STATE(interp)->exitHandlerDestroyRound == XOTCL_EXITHANDLER_OFF) { + if (XOTclObjConvertObject(interp, obj, &o) == TCL_OK) { + Tcl_Obj *res = Tcl_GetObjResult(interp); /* save the result */ + INCR_REF_COUNT(res); + + if (callMethod((ClientData)o, interp, XOTclGlobalObjects[XOTE_DESTROY],2,0,0) != TCL_OK) { + result = "Destroy for volatile object failed"; + } else + result = "No XOTcl Object passed"; + + Tcl_SetObjResult(interp, res); /* restore the result */ + DECR_REF_COUNT(res); + } + DECR_REF_COUNT(obj); + } else { + /*fprintf(stderr, "omitting destroy on %s %p\n", name);*/ + } + return result; } + static int -XOTclCNewMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - XOTclObject *child = NULL; - Tcl_Obj *fullname; - int result, offset = 1, +XOTclCNewMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclObject *child = NULL; + Tcl_Obj *fullname; + int result, offset = 1, #if REFCOUNTED - isrefcount = 0, + isrefcount = 0, #endif - i, prefixLength; - Tcl_DString dFullname, *dsPtr = &dFullname; - XOTclStringIncrStruct *iss = &RUNTIME_STATE(in)->iss; + i, prefixLength; + Tcl_DString dFullname, *dsPtr = &dFullname; + XOTclStringIncrStruct *iss = &RUNTIME_STATE(interp)->iss; - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 1) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "new [-childof obj] ?args?"); + if (objc < 1) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "?-childof obj? ?args?"); - for (i=1; icmdName), -1); - Tcl_DStringAppend(dsPtr, "::__#", 5); - } else { - Tcl_DStringAppend(dsPtr, "::xotcl::__#", 12); - } - prefixLength = dsPtr->length; + Tcl_DStringInit(dsPtr); + if (child) { + Tcl_DStringAppend(dsPtr, ObjStr(child->cmdName), -1); + Tcl_DStringAppend(dsPtr, "::__#", 5); + } else { + Tcl_DStringAppend(dsPtr, "::xotcl::__#", 12); + } + prefixLength = dsPtr->length; - while (1) { - (void)XOTclStringIncr(iss); - Tcl_DStringAppend(dsPtr, iss->start, iss->length); - if (!Tcl_FindCommand(in, Tcl_DStringValue(dsPtr), NULL, 0)) { - break; + while (1) { + (void)XOTclStringIncr(iss); + Tcl_DStringAppend(dsPtr, iss->start, iss->length); + if (!Tcl_FindCommand(interp, Tcl_DStringValue(dsPtr), NULL, 0)) { + break; + } + /* in case the value existed already, reset prefix to the + original length */ + Tcl_DStringSetLength(dsPtr, prefixLength); } - /* in case the value existed already, reset prefix to the - original length */ - Tcl_DStringSetLength(dsPtr, prefixLength); - } - fullname = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr)); + fullname = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr)); - INCR_REF_COUNT(fullname); + INCR_REF_COUNT(fullname); - objc -= offset; - { - ALLOC_ON_STACK(Tcl_Obj*,objc+3, ov); + objc -= offset; + { + ALLOC_ON_STACK(Tcl_Obj *,objc+3, ov); - ov[0] = objv[0]; - ov[1] = XOTclGlobalObjects[XOTE_CREATE]; - ov[2] = fullname; - if (objc >= 1) - memcpy(ov+3, objv+offset, sizeof(Tcl_Obj *)*objc); + ov[0] = objv[0]; + ov[1] = XOTclGlobalObjects[XOTE_CREATE]; + ov[2] = fullname; + if (objc >= 1) + memcpy(ov+3, objv+offset, sizeof(Tcl_Obj *)*objc); - result = DoDispatch(cd, in, objc+3, ov, 0); - FREE_ON_STACK(ov); - } + result = DoDispatch(clientData, interp, objc+3, ov, 0); + FREE_ON_STACK(ov); + } #if REFCOUNTED - if (result == TCL_OK) { - if (isrefcount) { - Tcl_Obj *obj = Tcl_GetObjResult(in); - XOTclObject *o = (XOTclObject*) obj->internalRep.otherValuePtr; - o->flags |= XOTCL_REFCOUNTED; - o->teardown = in; - DECR_REF_COUNT(obj); + if (result == TCL_OK) { + if (isrefcount) { + Tcl_Obj *obj = Tcl_GetObjResult(interp); + XOTclObject *o = (XOTclObject*) obj->internalRep.otherValuePtr; + o->flags |= XOTCL_REFCOUNTED; + o->teardown = in; + DECR_REF_COUNT(obj); + } } - } #endif - DECR_REF_COUNT(fullname); - Tcl_DStringFree(dsPtr); + DECR_REF_COUNT(fullname); + Tcl_DStringFree(dsPtr); - return result; + return result; } static int -XOTclCRecreateMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - XOTclObject *newobj; - int result; +XOTclCRecreateMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclObject *newobj; + int result; - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc < 2) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "recreate ?args?"); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); - if (XOTclObjConvertObject(in, objv[1], &newobj) != TCL_OK) - return XOTclVarErrMsg(in, "can't recreate not existing obj ", - ObjStr(objv[1]), (char *) NULL); + if (XOTclObjConvertObject(interp, objv[1], &newobj) != TCL_OK) + return XOTclVarErrMsg(interp, "can't recreate not existing obj ", + ObjStr(objv[1]), (char *) NULL); - INCR_REF_COUNT(objv[1]); - newobj->flags |= XOTCL_RECREATE; + INCR_REF_COUNT(objv[1]); + newobj->flags |= XOTCL_RECREATE; - result = doCleanup(in, newobj, &cl->object, objc, objv); - if (result == TCL_OK) { - result = doObjInitialization(in, newobj, objc, objv); - if (result == TCL_OK) - Tcl_SetObjResult(in, objv[1]); - } - DECR_REF_COUNT(objv[1]); - return result; + result = doCleanup(interp, newobj, &cl->object, objc, objv); + if (result == TCL_OK) { + result = doObjInitialization(interp, newobj, objc, objv); + if (result == TCL_OK) + Tcl_SetObjResult(interp, objv[1]); + } + DECR_REF_COUNT(objv[1]); + return result; } + + + static int -XOTclCInfoMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - Tcl_Namespace *nsp; - XOTclClassOpt *opt; - char *pattern, *cmd; - int modifiers = 0; +XOTclClassInfoHeritageMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; - if (objc < 2) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "info ?args?"); + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - if (cl) { + return ListHeritage(interp, cl, objc == 3 ? ObjStr(objv[2]) : NULL); +} + +static int +XOTclClassInfoInstancesMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + return ListObjPtrHashTable(interp, &cl->instances, objc == 3 ? ObjStr(objv[2]) : NULL); +} + + +static int +XOTclClassInfoInstargsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + Tcl_Namespace *nsp; + + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + if (cl->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = NonposArgsGet(cl->nonposArgsTable, ObjStr(objv[2])); + if (nonposArgs && nonposArgs->ordinaryArgs) { + return ListArgsFromOrdinaryArgs(interp, nonposArgs); + } + } nsp = cl->nsPtr; + return ListProcArgs(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2])); +} + +static int +XOTclClassInfoInstbodyMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + Tcl_Namespace *nsp; + + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + nsp = cl->nsPtr; + return ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2])); +} + +static int +XOTclClassInfoInstcommandsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + Tcl_Namespace *nsp; + + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + nsp = cl->nsPtr; + return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), objc == 3 ? ObjStr(objv[2]) : NULL); +} + +static int +XOTclClassInfoInstdefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + Tcl_Namespace *nsp; + + if (objc != 5) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + if (cl->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = NonposArgsGet(cl->nonposArgsTable, ObjStr(objv[2])); + if (nonposArgs && nonposArgs->ordinaryArgs) { + return ListDefaultFromOrdinaryArgs(interp, ObjStr(objv[2]), nonposArgs, ObjStr(objv[3]), objv[4]); + } + } + nsp = cl->nsPtr; + return nsp ? + ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), ObjStr(objv[2]), ObjStr(objv[3]), objv[4]) : + TCL_OK; +} + +static int +XOTclClassInfoInstfilterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + XOTclClassOpt *opt; + int idx, nobjc, withGuards = 0; + static CONST char *options[] = {"-guards", NULL}; + enum options {guardsIdx}; + + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + for (idx = 2; idx < objc; idx++) { + char *name; + int index; + + name = Tcl_GetString(objv[idx]); + if (name[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case guardsIdx: withGuards = 1; break; + } + } + nobjc = objc - idx; + + if (objc < 2 || nobjc > 1 || objc > 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-guards? ?pattern?"); + opt = cl->opt; + return opt ? FilterInfo(interp, opt->instfilters, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards, 0) : TCL_OK; +} - cmd = ObjStr(objv[1]); - pattern = (objc > 2) ? ObjStr(objv[2]) : 0; +static int +XOTclClassInfoInstfilterguardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + XOTclClassOpt *opt; + + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " filter"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - /* - * check for "-" modifiers - */ - if (pattern && *pattern == '-') { - modifiers = countModifiers(objc, objv); - pattern = (objc > 2+modifiers) ? ObjStr(objv[2+modifiers]) : 0; + opt = cl->opt; + return opt ? GuardList(interp, opt->instfilters, ObjStr(objv[2])) : TCL_OK; +} + +static int +XOTclClassInfoInstforwardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + Tcl_Namespace *nsp; + int withDefinition = 0; + char *name = NULL; + + if (objc < 2 || objc > 4) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-definition? ?name?"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + if (objc > 2) { + name = ObjStr(objv[2]); + if (*name == '-' && !strcmp("-definition", name)) { + withDefinition = 1; + name = ObjStr(objv[3]); + } } - switch (*cmd) { - case 'c': - if (!strcmp(cmd, "classchildren")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "info classchildren ?pat?"); - return ListChildren(in, (XOTclObject*) cl, pattern, 1); - } else if (!strcmp(cmd, "classparent")) { - if (objc > 2 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "info classparent"); - return ListParent(in, &cl->object); - } - break; + nsp = cl->nsPtr; + return forwardList(interp, Tcl_Namespace_cmdTable(cl->nsPtr), name, withDefinition); +} - case 'h': - if (!strcmp(cmd, "heritage")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "info heritage ?pat?"); - return ListHeritage(in, cl, pattern); - } - break; +static int +XOTclClassInfoInstinvarMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + XOTclClassOpt *opt; - case 'i': - if (cmd[1] == 'n' && cmd[2] == 's' && cmd[3] == 't') { - char *cmdTail = cmd + 4; - switch (*cmdTail) { - case 'a': - if (!strcmp(cmdTail, "ances")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "info instances ?pat?"); - return ListObjPtrHashTable(in, &cl->instances, pattern); - } else if (!strcmp(cmdTail, "args")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instargs "); - if (cl->nonposArgsTable) { - XOTclNonposArgs* nonposArgs = - NonposArgsGet(cl->nonposArgsTable, pattern); - if (nonposArgs) { - return ListArgsFromOrdinaryArgs(in, nonposArgs); - } - } - return ListProcArgs(in, Tcl_Namespace_cmdTable(nsp), pattern); - } - break; - - case 'b': - if (!strcmp(cmdTail, "body")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instbody "); - return ListProcBody(in, Tcl_Namespace_cmdTable(nsp), pattern); - } - break; + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - case 'c': - if (!strcmp(cmdTail, "commands")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instcommands ?pat?"); - return ListKeys(in, Tcl_Namespace_cmdTable(nsp), pattern); - } - break; - - case 'd': - if (!strcmp(cmdTail, "default")) { - if (objc != 5 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instdefault "); - - if (cl->nonposArgsTable) { - XOTclNonposArgs* nonposArgs = - NonposArgsGet(cl->nonposArgsTable, pattern); - if (nonposArgs) { - return ListDefaultFromOrdinaryArgs(in, pattern, nonposArgs, - ObjStr(objv[3]), objv[4]); - } - } - return ListProcDefault(in, Tcl_Namespace_cmdTable(nsp), pattern, - ObjStr(objv[3]), objv[4]); - } - break; - - case 'f': - if (!strcmp(cmdTail, "filter")) { - int withGuards = 0; - if (objc-modifiers > 3) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instfilter ?-guards? ?pat?"); - if (modifiers > 0) { - withGuards = checkForModifier(objv, modifiers, "-guards"); - if (withGuards == 0) - return XOTclVarErrMsg(in, "info instfilter: unknown modifier ", - ObjStr(objv[2]), (char *) NULL); - } - return opt ? FilterInfo(in, opt->instfilters, pattern, withGuards, 0) : TCL_OK; - - } else if (!strcmp(cmdTail, "filterguard")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instfilterguard filter"); - return opt ? GuardList(in, opt->instfilters, pattern) : TCL_OK; - } else if (!strcmp(cmdTail, "forward")) { - int argc = objc-modifiers; - int definition; - if (argc < 2 || argc > 3) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instforward ?-definition? ?name?"); - definition = checkForModifier(objv, modifiers, "-definition"); - if (nsp) - return forwardList(in, Tcl_Namespace_cmdTable(nsp), pattern, definition); - else - return TCL_OK; - } - break; + opt = cl->opt; + if (opt && opt->assertions) { + Tcl_SetObjResult(interp, AssertionList(interp, opt->assertions->invariants)); + } + + return TCL_OK; +} - case 'i': - if (!strcmp(cmdTail, "invar")) { - XOTclAssertionStore *assertions = opt ? opt->assertions : 0; - if (objc != 2 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instinvar"); - - if (assertions && assertions->invariants) - Tcl_SetObjResult(in, AssertionList(in, assertions->invariants)); - return TCL_OK; - } - break; - - case 'm': - if (!strcmp(cmdTail, "mixin")) { - int withGuards = 0; - - if (objc-modifiers > 3 || modifiers > 1) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instmixin ?-guards? ?class?"); - if (modifiers > 0) { - withGuards = checkForModifier(objv, modifiers, "-guards"); - if (withGuards == 0) - return XOTclVarErrMsg(in, "info instfilter: unknown modifier ", - ObjStr(objv[2]), (char *) NULL); - } - return opt ? MixinInfo(in, opt->instmixins, pattern, withGuards) : TCL_OK; - - } else if (!strcmp(cmdTail, "mixinguard")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instmixinguard mixin"); - return opt ? GuardList(in, opt->instmixins, pattern) : TCL_OK; - } - break; - - case 'n': - if (!strcmp(cmdTail, "nonposargs")) { - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instnonposargs "); - if (cl->nonposArgsTable) { - XOTclNonposArgs* nonposArgs = - NonposArgsGet(cl->nonposArgsTable, pattern); - if (nonposArgs) { - Tcl_SetObjResult(in, NonposArgsFormat(in, - nonposArgs->nonposArgs)); - } - } - return TCL_OK; - } - break; - - case 'p': - if (!strcmp(cmdTail, "procs")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "info instprocs ?pat?"); - return ListMethodKeys(in, Tcl_Namespace_cmdTable(nsp), pattern, - /*noProcs*/ 0, /*noCmds*/ 1, /* noDups */ 0, 0); - } else if (!strcmp(cmdTail, "pre")) { - XOTclProcAssertion* procs; - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instpre "); - if (opt && opt->assertions) { - procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(in, AssertionList(in, procs->pre)); - } - return TCL_OK; - } else if (!strcmp(cmdTail, "post")) { - XOTclProcAssertion* procs; - if (objc != 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info instpost "); - if (opt && opt->assertions) { - procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(in, AssertionList(in, procs->post)); - } - return TCL_OK; - } - break; - } - } - break; +static int +XOTclClassInfoInstmixinMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + XOTclClassOpt *opt; + int idx, nobjc, withGuards = 0; + static CONST char *options[] = {"-guards", NULL}; + enum options {guardsIdx}; - case 'p': - if (!strcmp(cmd, "parameterclass")) { - if (opt && opt->parameterClass) { - Tcl_SetObjResult(in, opt->parameterClass); - } else { - Tcl_SetObjResult(in, XOTclGlobalObjects[XOTE_PARAM_CL]); - } - return TCL_OK; - } else if (!strcmp(cmd, "parameter")) { + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - Tcl_DString ds, *dsPtr = &ds; - XOTclObject *o; - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, className(cl), -1); - Tcl_DStringAppend(dsPtr, "::slot", 6); - o = XOTclpGetObject(in, Tcl_DStringValue(dsPtr)); - if (o) { - Tcl_Obj *varNameObj = Tcl_NewStringObj("__parameter",-1); - Tcl_Obj *parameters = XOTclOGetInstVar2((XOTcl_Object*)o, - in, varNameObj, NULL, - TCL_LEAVE_ERR_MSG); - if (parameters) { - Tcl_SetObjResult(in, parameters); - } else { - fprintf(stderr, "info parameters: No value for %s\n", - Tcl_DStringValue(dsPtr)); - Tcl_SetObjResult(in, XOTclGlobalObjects[XOTE_EMPTY]); - } - DECR_REF_COUNT(varNameObj); - } else { - Tcl_SetObjResult(in, XOTclGlobalObjects[XOTE_EMPTY]); - } - DSTRING_FREE(dsPtr); -#if 0 - if (cl->parameters) { - Tcl_SetObjResult(in, cl->parameters); - } else { - Tcl_SetObjResult(in, XOTclGlobalObjects[XOTE_EMPTY]); - } -#endif - return TCL_OK; - } - break; + for (idx = 2; idx < objc; idx++) { + char *name; + int index; - case 's': - if (!strcmp(cmd, "superclass")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info superclass ?class?"); - return ListSuperclasses(in, cl, pattern); - } else if (!strcmp(cmd, "subclass")) { - if (objc > 3 || modifiers > 0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "info subclass ?class?"); - return ListSubclasses(in, cl, pattern); - } else if (!strcmp(cmd, "slots")) { - Tcl_DString ds, *dsPtr = &ds; - XOTclObject *o; - int rc; - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, className(cl), -1); - Tcl_DStringAppend(dsPtr, "::slot", 6); - o = XOTclpGetObject(in, Tcl_DStringValue(dsPtr)); - if (o) { - rc = ListChildren(in, o, NULL, 0); - } else { - rc = TCL_OK; - } - DSTRING_FREE(dsPtr); - return rc; - } - break; + name = Tcl_GetString(objv[idx]); + if (name[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case guardsIdx: withGuards = 1; break; + } } - } + nobjc = objc-idx; + + if (objc < 2 || nobjc > 1 || objc > 4) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?-guards? ?pattern?"); + + opt = cl->opt; + return opt ? MixinInfo(interp, opt->instmixins, idx < objc ? ObjStr(objv[idx]) : NULL, withGuards) : TCL_OK; +} - return XOTclOInfoMethod(cd, in, objc, (Tcl_Obj **)objv); +static int +XOTclClassInfoInstmixinguardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + XOTclClassOpt *opt; + + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " mixin"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + opt = cl->opt; + return opt ? GuardList(interp, opt->instmixins, ObjStr(objv[2])) : TCL_OK; } + static int -XOTclCParameterMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - Tcl_Obj **pv = 0; - int elts, pc, result; - char * params; - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc != 2) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "parameter ?params?"); - if (cl->parameters) { - DECR_REF_COUNT(cl->parameters); - } +XOTclClassInfoInstnonposargsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - /* did we delete the parameters ? */ - params = ObjStr(objv[1]); - if ((params == NULL) || (*params == '\0')) { - cl->parameters = 0; + if (cl->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = NonposArgsGet(cl->nonposArgsTable, ObjStr(objv[2])); + if (nonposArgs) { + Tcl_SetObjResult(interp, NonposArgsFormat(interp, nonposArgs->nonposArgs)); + } + } return TCL_OK; - } +} - /* ok, remember the params */ - cl->parameters = objv[1]; - INCR_REF_COUNT(cl->parameters); +static int +XOTclClassInfoInstprocsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; - /* call getter/setter methods in params */ - result = Tcl_ListObjGetElements(in, objv[1], &pc, &pv); - if (result == TCL_OK) { - for (elts = 0; elts < pc; elts++) { - result = callParameterMethodWithArg(&cl->object, in, - XOTclGlobalObjects[XOTE_MKGETTERSETTER], - cl->object.cmdName, 3+1, &pv[elts],0); - if (result != TCL_OK) - break; + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + return ListMethodKeys(interp, Tcl_Namespace_cmdTable(cl->nsPtr), + objc == 3 ? ObjStr(objv[2]) : NULL, + /*noProcs*/ 0, /*noCmds*/ 1, NULL, 0 ); +} + +static int +XOTclClassInfoInstpreMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + XOTclClassOpt *opt; + + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], objv[1], ""); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + opt = cl->opt; + if (opt) { + XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); } - } - return result; + return TCL_OK; } static int -XOTclCParameterClassMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - char *paramClStr; - XOTclClassOpt *opt; +XOTclClassInfoInstpostMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + XOTclClassOpt *opt; - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc != 2) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "parameterclass cl"); + if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - paramClStr = ObjStr(objv[1]); - opt = cl->opt; - if (opt && opt->parameterClass) { - DECR_REF_COUNT(opt->parameterClass); - } - if ((paramClStr == NULL) || (*paramClStr == '\0')) { - if (opt) - opt->parameterClass = 0; - } else { - opt = XOTclRequireClassOpt(cl); - opt->parameterClass = objv[1]; - INCR_REF_COUNT(opt->parameterClass); - } - return TCL_OK; + opt = cl->opt; + if (opt) { + XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); + } + return TCL_OK; } static int -XOTclCInstParameterCmdMethod(ClientData cd, Tcl_Interp *in, - int objc, Tcl_Obj * CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); +XOTclClassInfoParameterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + Tcl_DString ds, *dsPtr = &ds; + XOTclClass *cl; + XOTclObject *o; - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc < 2) return XOTclObjErrArgCnt(in, cl->object.cmdName, "instparametercmd name"); - XOTclAddIMethod(in, (XOTcl_Class*) cl, ObjStr(objv[1]), - (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0); - return TCL_OK; + if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(cl), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (o) { + Tcl_Obj *varNameObj = Tcl_NewStringObj("__parameter",-1); + Tcl_Obj *parameters = XOTcl_ObjGetVar2((XOTcl_Object*)o, + interp, varNameObj, NULL, + TCL_LEAVE_ERR_MSG); + if (parameters) { + Tcl_SetObjResult(interp, parameters); + } + DECR_REF_COUNT(varNameObj); + } + DSTRING_FREE(dsPtr); + return TCL_OK; } static int -XOTclCParameterCmdMethod(ClientData cd, Tcl_Interp *in, - int objc, Tcl_Obj * CONST objv[]) { - XOTclObject *obj = (XOTclObject*) cd; +XOTclClassInfoSuperclassMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; - if (objc < 2) return XOTclObjErrArgCnt(in, obj->cmdName, "parametercmd name"); - XOTclAddPMethod(in, (XOTcl_Object*) obj, ObjStr(objv[1]), - (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0); - return TCL_OK; + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + return ListSuperclasses(interp, cl, objc == 3 ? ObjStr(objv[2]) : NULL); } -static void forwardCmdDeleteProc(ClientData cd) { - forwardCmdClientData *tcd = (forwardCmdClientData *)cd; - if (tcd->cmdName) {DECR_REF_COUNT(tcd->cmdName);} - if (tcd->subcommands) {DECR_REF_COUNT(tcd->subcommands);} - if (tcd->prefix) {DECR_REF_COUNT(tcd->prefix);} - if (tcd->args) {DECR_REF_COUNT(tcd->args);} - FREE(forwardCmdClientData, tcd); +static int +XOTclClassInfoSubclassMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl; + + if (objc < 2 || objc > 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?pattern?"); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); + + return ListSubclasses(interp, cl, objc == 3 ? ObjStr(objv[2]) : NULL); } static int -forwardProcessOptions(Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[], - forwardCmdClientData **tcdp) { - forwardCmdClientData *tcd; - int i, rc = 0, earlybinding = 0; +XOTclClassInfoSlotsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + Tcl_DString ds, *dsPtr = &ds; + XOTclClass *cl; + XOTclObject *o; + int rc; - tcd = NEW(forwardCmdClientData); - memset(tcd, 0, sizeof(forwardCmdClientData)); + if (objc < 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); + if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) + return XOTclObjErrType(interp, objv[1], "Class"); - for (i=2; isubcommands = objv[i+1]; - rc = Tcl_ListObjLength(in,objv[i+1],&tcd->nr_subcommands); - if (rc != TCL_OK) break; - INCR_REF_COUNT(tcd->subcommands); - i++; - } else if (!strcmp(ObjStr(objv[i]),"-methodprefix")) { - if (objc <= i+1) {rc = TCL_ERROR; break;} - tcd->prefix = objv[i+1]; - INCR_REF_COUNT(tcd->prefix); - i++; - } else if (!strcmp(ObjStr(objv[i]),"-objscope")) { - tcd->objscope = 1; - } else if (!strcmp(ObjStr(objv[i]),"-earlybinding")) { - earlybinding = 1; - } else if (!strcmp(ObjStr(objv[i]),"-verbose")) { - tcd->verbose = 1; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(cl), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (o) { + rc = ListChildren(interp, o, NULL, 0); } else { - break; + rc = TCL_OK; } - } + DSTRING_FREE(dsPtr); + return rc; +} - tcd->needobjmap = 0; - for (; ineedobjmap |= (*element == '%' && *(element+1) == '@'); +static int +XOTclCInfoMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(clientData); + Tcl_Namespace *nsp; + XOTclClassOpt *opt; + char *pattern, *cmd; + int modifiers = 0; - if (tcd->cmdName == 0) { - tcd->cmdName = objv[i]; - } else if (tcd->args == 0) { - tcd->args = Tcl_NewListObj(1, &objv[i]); - tcd->nr_args++; - INCR_REF_COUNT(tcd->args); - } else { - Tcl_ListObjAppendElement(in, tcd->args, objv[i]); - tcd->nr_args++; + if (objc < 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); + + if (cl) { + nsp = cl->nsPtr; + opt = cl->opt; + + cmd = ObjStr(objv[1]); + pattern = (objc > 2) ? ObjStr(objv[2]) : 0; + + /* + * check for "-" modifiers + */ + if (pattern && *pattern == '-') { + modifiers = countModifiers(objc, objv); + pattern = (objc > 2+modifiers) ? ObjStr(objv[2+modifiers]) : 0; + } + + switch (*cmd) { + case 'c': + if (!strcmp(cmd, "classchildren")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "classchildren ?pat?"); + return ListChildren(interp, (XOTclObject*) cl, pattern, 1); + } else if (!strcmp(cmd, "classparent")) { + if (objc > 2 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "classparent"); + return ListParent(interp, &cl->object); + } + break; + + case 'h': + if (!strcmp(cmd, "heritage")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "heritage ?pat?"); + return ListHeritage(interp, cl, pattern); + } + break; + + case 'i': + if (cmd[1] == 'n' && cmd[2] == 's' && cmd[3] == 't') { + char *cmdTail = cmd + 4; + switch (*cmdTail) { + case 'a': + if (!strcmp(cmdTail, "ances")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "instances ?pat?"); + return ListObjPtrHashTable(interp, &cl->instances, pattern); + } else if (!strcmp(cmdTail, "args")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instargs "); + if (cl->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = + NonposArgsGet(cl->nonposArgsTable, pattern); + if (nonposArgs && nonposArgs->ordinaryArgs) { + return ListArgsFromOrdinaryArgs(interp, nonposArgs); + } + } + return ListProcArgs(interp, Tcl_Namespace_cmdTable(nsp), pattern); + } + break; + + case 'b': + if (!strcmp(cmdTail, "body")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instbody "); + return ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), pattern); + } + break; + + case 'c': + if (!strcmp(cmdTail, "commands")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instcommands ?pat?"); + return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern); + } + break; + + case 'd': + if (!strcmp(cmdTail, "default")) { + if (objc != 5 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instdefault "); + + if (cl->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = + NonposArgsGet(cl->nonposArgsTable, pattern); + if (nonposArgs && nonposArgs->ordinaryArgs) { + return ListDefaultFromOrdinaryArgs(interp, pattern, nonposArgs, + ObjStr(objv[3]), objv[4]); + } + } + return ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), pattern, + ObjStr(objv[3]), objv[4]); + } + break; + + case 'f': + if (!strcmp(cmdTail, "filter")) { + int withGuards = 0; + if (objc-modifiers > 3) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instfilter ?-guards? ?pat?"); + if (modifiers > 0) { + withGuards = checkForModifier(objv, modifiers, "-guards"); + if (withGuards == 0) + return XOTclVarErrMsg(interp, "info instfilter: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); + } + return opt ? FilterInfo(interp, opt->instfilters, pattern, withGuards, 0) : TCL_OK; + + } else if (!strcmp(cmdTail, "filterguard")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instfilterguard filter"); + return opt ? GuardList(interp, opt->instfilters, pattern) : TCL_OK; + } else if (!strcmp(cmdTail, "forward")) { + int argc = objc-modifiers; + int definition; + if (argc < 2 || argc > 3) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instforward ?-definition? ?name?"); + definition = checkForModifier(objv, modifiers, "-definition"); + if (nsp) + return forwardList(interp, Tcl_Namespace_cmdTable(nsp), pattern, definition); + else + return TCL_OK; + } + break; + + case 'i': + if (!strcmp(cmdTail, "invar")) { + XOTclAssertionStore *assertions = opt ? opt->assertions : 0; + if (objc != 2 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instinvar"); + + if (assertions && assertions->invariants) + Tcl_SetObjResult(interp, AssertionList(interp, assertions->invariants)); + return TCL_OK; + } + break; + + case 'm': + if (!strcmp(cmdTail, "mixin")) { + int withGuards = 0; + + if (objc-modifiers > 3 || modifiers > 1) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instmixin ?-guards? ?class?"); + if (modifiers > 0) { + withGuards = checkForModifier(objv, modifiers, "-guards"); + if (withGuards == 0) + return XOTclVarErrMsg(interp, "info instfilter: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); + } + return opt ? MixinInfo(interp, opt->instmixins, pattern, withGuards) : TCL_OK; + + } else if (!strcmp(cmdTail, "mixinguard")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instmixinguard mixin"); + return opt ? GuardList(interp, opt->instmixins, pattern) : TCL_OK; + } + break; + + case 'n': + if (!strcmp(cmdTail, "nonposargs")) { + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instnonposargs "); + if (cl->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = + NonposArgsGet(cl->nonposArgsTable, pattern); + if (nonposArgs) { + Tcl_SetObjResult(interp, NonposArgsFormat(interp, + nonposArgs->nonposArgs)); + } + } + return TCL_OK; + } + break; + + case 'p': + if (!strcmp(cmdTail, "procs")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instprocs ?pat?"); + return ListMethodKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern, + /*noProcs*/ 0, /*noCmds*/ 1, NULL, 0); + } else if (!strcmp(cmdTail, "pre")) { + XOTclProcAssertion *procs; + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instpre "); + if (opt && opt->assertions) { + procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); + } + return TCL_OK; + } else if (!strcmp(cmdTail, "post")) { + XOTclProcAssertion *procs; + if (objc != 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "instpost "); + if (opt && opt->assertions) { + procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); + } + return TCL_OK; + } + break; + } + } + break; + + case 'p': + if (!strcmp(cmd, "parameter")) { + + Tcl_DString ds, *dsPtr = &ds; + XOTclObject *o; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(cl), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (o) { + Tcl_Obj *varNameObj = Tcl_NewStringObj("__parameter",-1); + Tcl_Obj *parameters = XOTcl_ObjGetVar2((XOTcl_Object*)o, + interp, varNameObj, NULL, + TCL_LEAVE_ERR_MSG); + if (parameters) { + Tcl_SetObjResult(interp, parameters); + } else { + fprintf(stderr, "info parameters: No value for %s\n", + Tcl_DStringValue(dsPtr)); + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + } + DECR_REF_COUNT(varNameObj); + } else { + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + } + DSTRING_FREE(dsPtr); +#if 0 + if (cl->parameters) { + Tcl_SetObjResult(interp, cl->parameters); + } else { + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + } +#endif + return TCL_OK; + } + break; + + case 's': + if (!strcmp(cmd, "superclass")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "superclass ?class?"); + return ListSuperclasses(interp, cl, pattern); + } else if (!strcmp(cmd, "subclass")) { + if (objc > 3 || modifiers > 0) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "subclass ?class?"); + return ListSubclasses(interp, cl, pattern); + } else if (!strcmp(cmd, "slots")) { + Tcl_DString ds, *dsPtr = &ds; + XOTclObject *o; + int rc; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(cl), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (o) { + rc = ListChildren(interp, o, NULL, 0); + } else { + rc = TCL_OK; + } + DSTRING_FREE(dsPtr); + return rc; + } + break; + } } - } - if (!tcd->cmdName) { - tcd->cmdName = objv[1]; - } + return XOTclOInfoMethod(clientData, interp, objc, (Tcl_Obj **)objv); +} - if (tcd->objscope) { - /* when we evaluating objscope, and define ... - o forward append -objscope append - a call to - o append ... - would lead to a recursive call; so we add the appropriate namespace - */ - char *name = ObjStr(tcd->cmdName); - if (!isAbsolutePath(name)) { - tcd->cmdName = NameInNamespaceObj(in, name, callingNameSpace(in)); - /*fprintf(stderr,"name %s not absolute, therefore qualifying %s\n", name, - ObjStr(tcd->cmdName));*/ +static int +XOTclCInstParameterCmdMethod(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(clientData); + + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 2) return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "name"); + XOTclAddInstanceMethod(interp, (XOTcl_Class*) cl, ObjStr(objv[1]), + (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); + return TCL_OK; +} + +static int +XOTclCParameterCmdMethod(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*) clientData; + + if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "name"); + XOTclAddObjectMethod(interp, (XOTcl_Object*) obj, ObjStr(objv[1]), + (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); + return TCL_OK; +} + +static void forwardCmdDeleteProc(ClientData clientData) { + forwardCmdClientData *tcd = (forwardCmdClientData *)clientData; + if (tcd->cmdName) {DECR_REF_COUNT(tcd->cmdName);} + if (tcd->subcommands) {DECR_REF_COUNT(tcd->subcommands);} + if (tcd->onerror) {DECR_REF_COUNT(tcd->onerror);} + if (tcd->prefix) {DECR_REF_COUNT(tcd->prefix);} + if (tcd->args) {DECR_REF_COUNT(tcd->args);} + FREE(forwardCmdClientData, tcd); +} + +static int +forwardProcessOptions(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], + forwardCmdClientData **tcdp) { + forwardCmdClientData *tcd; + int i, rc = 0, earlybinding = 0; + + tcd = NEW(forwardCmdClientData); + memset(tcd, 0, sizeof(forwardCmdClientData)); + + for (i=2; isubcommands = objv[i+1]; + rc = Tcl_ListObjLength(interp,objv[i+1],&tcd->nr_subcommands); + if (rc != TCL_OK) break; + INCR_REF_COUNT(tcd->subcommands); + i++; + } else if (!strcmp(ObjStr(objv[i]),"-methodprefix")) { + if (objc <= i+1) {rc = TCL_ERROR; break;} + tcd->prefix = objv[i+1]; + INCR_REF_COUNT(tcd->prefix); + i++; + } else if (!strcmp(ObjStr(objv[i]),"-onerror")) { + if (objc <= i+1) {rc = TCL_ERROR; break;} + tcd->onerror = objv[i+1]; + INCR_REF_COUNT(tcd->onerror); + i++; + } else if (!strcmp(ObjStr(objv[i]),"-objscope")) { + tcd->objscope = 1; + } else if (!strcmp(ObjStr(objv[i]),"-earlybinding")) { + earlybinding = 1; + } else if (!strcmp(ObjStr(objv[i]),"-verbose")) { + tcd->verbose = 1; + } else { + /* todo protected */ + break; + } } - } - INCR_REF_COUNT(tcd->cmdName); - if (earlybinding) { - Tcl_Command cmd = Tcl_GetCommandFromObj(in, tcd->cmdName); - if (cmd == NULL) - return XOTclVarErrMsg(in, "cannot lookup command '",ObjStr(tcd->cmdName), "'", (char *) NULL); + tcd->needobjmap = 0; + for (; ineedobjmap |= (*element == '%' && *(element+1) == '@'); - tcd->objProc = Tcl_Command_objProc(cmd); - if (tcd->objProc == XOTclObjDispatch /* don't do direct invoke on xotcl objects */ - || tcd->objProc == TclObjInterpProc /* don't do direct invoke on tcl procs */ - ) { - /* silently ignore earlybinding flag */ - tcd->objProc = NULL; - } else { - tcd->cd = Tcl_Command_objClientData(cmd); + if (tcd->cmdName == 0) { + tcd->cmdName = objv[i]; + } else if (tcd->args == 0) { + tcd->args = Tcl_NewListObj(1, &objv[i]); + tcd->nr_args++; + INCR_REF_COUNT(tcd->args); + } else { + Tcl_ListObjAppendElement(interp, tcd->args, objv[i]); + tcd->nr_args++; + } } - } - tcd->passthrough = !tcd->args && *(ObjStr(tcd->cmdName)) != '%' && tcd->objProc != NULL; + if (!tcd->cmdName) { + tcd->cmdName = objv[1]; + } - /*fprintf(stderr, "forward args = %p, name = '%s'\n",tcd->args, ObjStr(tcd->cmdName));*/ - if (rc == TCL_OK) { - *tcdp = tcd; - } else { - forwardCmdDeleteProc((ClientData)tcd); - } - return rc; + if (tcd->objscope) { + /* when we evaluating objscope, and define ... + o forward append -objscope append + a call to + o append ... + would lead to a recursive call; so we add the appropriate namespace + */ + char *name = ObjStr(tcd->cmdName); + if (!isAbsolutePath(name)) { + tcd->cmdName = NameInNamespaceObj(interp, name, callingNameSpace(interp)); + /*fprintf(stderr,"name %s not absolute, therefore qualifying %s\n", name, + ObjStr(tcd->cmdName));*/ + } + } + INCR_REF_COUNT(tcd->cmdName); + + if (earlybinding) { + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, tcd->cmdName); + if (cmd == NULL) + return XOTclVarErrMsg(interp, "cannot lookup command '",ObjStr(tcd->cmdName), "'", (char *) NULL); + + tcd->objProc = Tcl_Command_objProc(cmd); + if (tcd->objProc == XOTclObjDispatch /* don't do direct invoke on xotcl objects */ + || tcd->objProc == TclObjInterpProc /* don't do direct invoke on tcl procs */ + ) { + /* silently ignore earlybinding flag */ + tcd->objProc = NULL; + } else { + tcd->clientData = Tcl_Command_objClientData(cmd); + } + } + + tcd->passthrough = !tcd->args && *(ObjStr(tcd->cmdName)) != '%' && tcd->objProc != NULL; + + /*fprintf(stderr, "forward args = %p, name = '%s'\n",tcd->args, ObjStr(tcd->cmdName));*/ + if (rc == TCL_OK) { + *tcdp = tcd; + } else { + forwardCmdDeleteProc((ClientData)tcd); + } + return rc; } static int -XOTclCInstForwardMethod(ClientData cd, Tcl_Interp *in, - int objc, Tcl_Obj * CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - forwardCmdClientData *tcd; - int rc; +XOTclCInstForwardMethod(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(clientData); + forwardCmdClientData *tcd; + int rc; - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc < 2) goto forward_argc_error; - rc = forwardProcessOptions(in, objc, objv, &tcd); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 2) goto forward_argc_error; + rc = forwardProcessOptions(interp, objc, objv, &tcd); - if (rc == TCL_OK) { - tcd->obj = &cl->object; - XOTclAddIMethod(in, (XOTcl_Class*) cl, NSTail(ObjStr(objv[1])), - (Tcl_ObjCmdProc*)XOTclForwardMethod, - (ClientData)tcd, forwardCmdDeleteProc); - return TCL_OK; - } else { - forward_argc_error: - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "instforward method ?target? ?-default name? ?-objscope? ?-methodprefix string? ?args?"); - } + if (rc == TCL_OK) { + tcd->obj = &cl->object; + XOTclAddInstanceMethod(interp, (XOTcl_Class*) cl, NSTail(ObjStr(objv[1])), + (Tcl_ObjCmdProc*)XOTclForwardMethod, + (ClientData)tcd, forwardCmdDeleteProc, 0); + return TCL_OK; + } else { + forward_argc_error: + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "method ?target? ?-default name? ?-objscope? ?-onerror cmd? ?-methodprefix string? ?args?"); + } } static int -XOTclOForwardMethod(ClientData cd, Tcl_Interp *in, - int objc, Tcl_Obj * CONST objv[]) { - XOTcl_Object *obj = (XOTcl_Object*) cd; - forwardCmdClientData *tcd; - int rc; +XOTclOForwardMethod(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) { + XOTcl_Object *obj = (XOTcl_Object*) clientData; + forwardCmdClientData *tcd; + int rc; - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 2) goto forward_argc_error; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (objc < 2) goto forward_argc_error; - rc = forwardProcessOptions(in, objc, objv, &tcd); + rc = forwardProcessOptions(interp, objc, objv, &tcd); - if (rc == TCL_OK) { - tcd->obj = (XOTclObject*)obj; - XOTclAddPMethod(in, obj, NSTail(ObjStr(objv[1])), - (Tcl_ObjCmdProc*)XOTclForwardMethod, - (ClientData)tcd, forwardCmdDeleteProc); - return TCL_OK; - } else { - forward_argc_error: - return XOTclObjErrArgCnt(in, obj->cmdName, - "forward method ?target? ?-default name? ?-objscope? ?-methodprefix string? ?args?"); - } + if (rc == TCL_OK) { + tcd->obj = (XOTclObject*)obj; + XOTclAddObjectMethod(interp, obj, NSTail(ObjStr(objv[1])), + (Tcl_ObjCmdProc*)XOTclForwardMethod, + (ClientData)tcd, forwardCmdDeleteProc, 0); + return TCL_OK; + } else { + forward_argc_error: + return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], + "method ?target? ?-default name? ?-objscope? ?-methodprefix string? ?args?"); + } } static int -XOTclOVolatileMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { - XOTclObject *obj = (XOTclObject*) cd; - Tcl_Obj *o = obj->cmdName; - int result = TCL_ERROR; - char *fullName = ObjStr(o); - char *vn; - callFrameContext ctx = {0}; +XOTclOVolatileMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*) clientData; + Tcl_Obj *o = obj->cmdName; + int result = TCL_ERROR; + char *fullName = ObjStr(o); + char *vn; + callFrameContext ctx = {0}; - if (objc != 1) - return XOTclObjErrArgCnt(in, obj->cmdName, "volatile"); + if (objc != 1) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], NULL); - if (RUNTIME_STATE(in)->exitHandlerDestroyRound != XOTCL_EXITHANDLER_OFF) { - fprintf(stderr,"### Can't make objects volatile during shutdown\n"); - return XOTclVarErrMsg(in, "Can't make objects volatile during shutdown\n",NULL); - } + CallStackUseActiveFrames(interp, &ctx); + vn = NSTail(fullName); - CallStackUseActiveFrames(in, &ctx); - vn = NSTail(fullName); + if (Tcl_SetVar2(interp, vn, 0, fullName, 0) != NULL) { + result = Tcl_TraceVar(interp, vn, TCL_TRACE_UNSETS, (Tcl_VarTraceProc*)XOTclUnsetTrace, + (ClientData)o); + } + CallStackRestoreSavedFrames(interp, &ctx); - if (Tcl_SetVar2(in, vn, NULL, fullName, 0) != NULL) { - XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); - - /*fprintf(stderr,"### setting trace for %s\n", fullName);*/ - result = Tcl_TraceVar(in, vn, TCL_TRACE_UNSETS, (Tcl_VarTraceProc*)XOTclUnsetTrace, - (ClientData)o); - opt->volatileVarName = vn; - } - CallStackRestoreSavedFrames(in, &ctx); - - if (result == TCL_OK) { - INCR_REF_COUNT(o); - } - return result; + if (result == TCL_OK) { + INCR_REF_COUNT(o); + } + return result; } static int -XOTclCInstProcMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - char *argStr, *bdyStr, *name; - XOTclClassOpt* opt; - int incr = 0, result = TCL_OK; +makeMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int clsns) { - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc < 4 || objc > 7) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "instproc name ?non-positional-args? args body ?preAssertion postAssertion?"); + XOTclClass *cl = XOTclObjectToClass(clientData); + char *argStr, *bdyStr, *name; + XOTclClassOpt *opt; + int incr = 0, result = TCL_OK; - if (objc == 5 || objc == 7) { - incr = 1; - } + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc < 4 || objc > 7) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "name ?non-positional-args? args body ?preAssertion postAssertion?"); - argStr = ObjStr(objv[2 + incr]); - bdyStr = ObjStr(objv[3 + incr]); - name = ObjStr(objv[1 + incr]); + if (objc == 5 || objc == 7) { + incr = 1; + } - if ((cl == RUNTIME_STATE(in)->theObject && isDestroyString(name)) || - (cl == RUNTIME_STATE(in)->theClass && isInstDestroyString(name)) || - (cl == RUNTIME_STATE(in)->theClass && isAllocString(name)) || - (cl == RUNTIME_STATE(in)->theClass && isCreateString(name))) - return XOTclVarErrMsg(in, className(cl), " instproc: '", name, "' of ", - className(cl), " can not be overwritten. Derive a ", - "sub-class", (char *) NULL); + argStr = ObjStr(objv[2 + incr]); + bdyStr = ObjStr(objv[3 + incr]); + name = ObjStr(objv[1 + incr]); - if (*argStr == 0 && *bdyStr == 0) { - int rc; - opt = cl->opt; - if (opt && opt->assertions) - AssertionRemoveProc(opt->assertions, name); - rc = NSDeleteCmd(in, cl->nsPtr, name); - if (rc < 0) - return XOTclVarErrMsg(in, className(cl), " cannot delete instproc: '", name, - "' of class ", className(cl), (char *) NULL); - } else { - XOTclAssertionStore* aStore = NULL; - if (objc > 5) { - opt = XOTclRequireClassOpt(cl); - if (!opt->assertions) - opt->assertions = AssertionCreateStore(); - aStore = opt->assertions; + if ((cl == RUNTIME_STATE(interp)->theObject && isDestroyString(name)) || + (cl == RUNTIME_STATE(interp)->theClass && isInstDestroyString(name)) || + (cl == RUNTIME_STATE(interp)->theClass && isDeallocString(name)) || + (cl == RUNTIME_STATE(interp)->theClass && isAllocString(name)) || + (cl == RUNTIME_STATE(interp)->theClass && isCreateString(name))) + return XOTclVarErrMsg(interp, className(cl), " method '", name, "' of ", + className(cl), " can not be overwritten. Derive a ", + "sub-class", (char *) NULL); + + if (*argStr == 0 && *bdyStr == 0) { + int rc; + opt = cl->opt; + if (opt && opt->assertions) + AssertionRemoveProc(opt->assertions, name); + rc = NSDeleteCmd(interp, cl->nsPtr, name); + if (rc < 0) + return XOTclVarErrMsg(interp, className(cl), " cannot delete method '", name, + "' of class ", className(cl), (char *) NULL); + } else { + XOTclAssertionStore *aStore = NULL; + if (objc > 5) { + opt = XOTclRequireClassOpt(cl); + if (!opt->assertions) + opt->assertions = AssertionCreateStore(); + aStore = opt->assertions; + } + result = MakeProc(cl->nsPtr, aStore, &(cl->nonposArgsTable), + interp, objc, (Tcl_Obj **) objv, &cl->object, clsns); } - result = MakeProc(cl->nsPtr, aStore, &(cl->nonposArgsTable), - in, objc, (Tcl_Obj **) objv, &cl->object); - } - /* could be a filter or filter inheritance ... update filter orders */ - FilterInvalidateObjOrders(in, cl); + /* could be a filter or filter inheritance ... update filter orders */ + FilterInvalidateObjOrders(interp, cl); - return result; + return result; } static int -XOTclCInstFilterGuardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - XOTclCmdList* h; - XOTclClassOpt* opt; +XOTclCInstProcMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + return makeMethod(clientData, interp, objc, objv, 0); +} - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc != 3) return XOTclObjErrArgCnt(in, cl->object.cmdName, - "instfilterguard filtername filterGuard"); +static int +XOTclCInstProcMethodC(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + return makeMethod(clientData, interp, objc, objv, 1); +} - opt = cl->opt; - if (opt && opt->instfilters) { - h = CmdListFindNameInList(in, ObjStr(objv[1]), opt->instfilters); - if (h) { - if (h->clientData) - GuardDel(h); - GuardAdd(in, h, objv[2]); - FilterInvalidateObjOrders(in, cl); - return TCL_OK; +static int +XOTclCInstFilterGuardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclCmdList *h; + XOTclClassOpt *opt; + + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc != 3) return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "filtername filterGuard"); + + opt = cl->opt; + if (opt && opt->instfilters) { + h = CmdListFindNameInList(interp, ObjStr(objv[1]), opt->instfilters); + if (h) { + if (h->clientData) + GuardDel(h); + GuardAdd(interp, h, objv[2]); + FilterInvalidateObjOrders(interp, cl); + return TCL_OK; + } } - } - return XOTclVarErrMsg(in, "Instfilterguard: can't find filter ", - ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName), - (char *) NULL); + return XOTclVarErrMsg(interp, "Instfilterguard: can't find filter ", + ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName), + (char *) NULL); } static int -XOTclCInstMixinGuardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - XOTclCmdList* h; +XOTclCInstMixinGuardMethod(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclCmdList *h; - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc != 3) return XOTclObjErrArgCnt(in, cl->object.cmdName, - "instmixinguard mixin guard"); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc != 3) return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + "mixin guard"); - if (cl->opt && cl->opt->instmixins) { - XOTclClass *mixinCl = XOTclpGetClass(in, ObjStr(objv[1])); - Tcl_Command mixinCmd = NULL; - if (mixinCl) { - mixinCmd = Tcl_GetCommandFromObj(in, mixinCl->object.cmdName); + if (cl->opt && cl->opt->instmixins) { + XOTclClass *mixinCl = XOTclpGetClass(interp, ObjStr(objv[1])); + Tcl_Command mixinCmd = NULL; + if (mixinCl) { + mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName); + } + if (mixinCmd) { + h = CmdListFindCmdInList(mixinCmd, cl->opt->instmixins); + if (h) { + if (h->clientData) + GuardDel((XOTclCmdList*) h); + GuardAdd(interp, h, objv[2]); + MixinInvalidateObjOrders(interp, cl); + return TCL_OK; + } + } } - if (mixinCmd) { - h = CmdListFindCmdInList(mixinCmd, cl->opt->instmixins); - if (h) { - if (h->clientData) - GuardDel((XOTclCmdList*) h); - GuardAdd(in, h, objv[2]); - MixinInvalidateObjOrders(in, cl); - return TCL_OK; - } - } - } - return XOTclVarErrMsg(in, "Instmixinguard: can't find mixin ", - ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName), - (char *) NULL); + return XOTclVarErrMsg(interp, "Instmixinguard: can't find mixin ", + ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName), + (char *) NULL); } static int -XOTclCInvariantsMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - XOTclClassOpt* opt; +XOTclCInvariantsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(clientData); + XOTclClassOpt *opt; - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc != 2) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "instinvar "); - opt = XOTclRequireClassOpt(cl); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (objc != 2) + return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], + ""); + opt = XOTclRequireClassOpt(cl); - if (opt->assertions) - TclObjListFreeList(opt->assertions->invariants); - else - opt->assertions = AssertionCreateStore(); + if (opt->assertions) + TclObjListFreeList(opt->assertions->invariants); + else + opt->assertions = AssertionCreateStore(); - opt->assertions->invariants = AssertionNewList(in, objv[1]); - return TCL_OK; + opt->assertions->invariants = AssertionNewList(interp, objv[1]); + return TCL_OK; } static int -XOTclCUnknownMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*) cd; - char *self = ObjStr(obj->cmdName); - int rc; +XOTclCUnknownMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*) clientData; + char *self = ObjStr(obj->cmdName); + int rc; - if (objc < 2) return XOTclObjErrArgCnt(in, objv[0], "message ?args .. args?"); - if (isCreateString(self)) - return XOTclVarErrMsg(in, "error ", self, ": unable to dispatch '", - ObjStr(objv[1]), "'", (char *) NULL); + if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "message ?args .. args?"); + if (isCreateString(self)) + return XOTclVarErrMsg(interp, "error ", self, ": unable to dispatch '", + ObjStr(objv[1]), "'", (char *) NULL); - rc = callMethod(cd, in, XOTclGlobalObjects[XOTE_CREATE], objc+1, objv+1, 0); - return rc; + rc = callMethod(clientData, interp, XOTclGlobalObjects[XOTE_CREATE], objc+1, objv+1, 0); + return rc; } /* * New Tcl Commands */ static int -XOTcl_NSCopyCmds(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Command cmd; - Tcl_Obj *newFullCmdName, *oldFullCmdName; - char *newName, *oldName, *name; - Tcl_Namespace *ns, *newNs; - Tcl_HashTable *cmdTable; - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr; +XOTcl_NSCopyCmds(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + Tcl_Command cmd; + Tcl_Obj *newFullCmdName, *oldFullCmdName; + char *newName, *oldName, *name; + Tcl_Namespace *ns, *newNs; + Tcl_HashTable *cmdTable; + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; - if (objc != 3) - return XOTclObjErrArgCnt(in, NULL, "namespace_copycmds fromNs toNs"); + if (objc != 3) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - ns = ObjFindNamespace(in, objv[1]); - if (!ns) - return TCL_OK; + ns = ObjFindNamespace(interp, objv[1]); + if (!ns) + return TCL_OK; - newNs = ObjFindNamespace(in, objv[2]); - if (!newNs) - return XOTclVarErrMsg(in, "CopyCmds: Destination namespace ", - ObjStr(objv[2]), " does not exist", (char *) NULL); - /* - * copy all procs & commands in the ns - */ - cmdTable = Tcl_Namespace_cmdTable(ns); - hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); - while (hPtr != NULL) { - name = Tcl_GetHashKey(cmdTable, hPtr); - + newNs = ObjFindNamespace(interp, objv[2]); + if (!newNs) + return XOTclVarErrMsg(interp, "CopyCmds: Destination namespace ", + ObjStr(objv[2]), " does not exist", (char *) NULL); /* - * construct full cmd names + * copy all procs & commands in the ns */ - newFullCmdName = Tcl_NewStringObj(newNs->fullName,-1); - oldFullCmdName = Tcl_NewStringObj(ns->fullName,-1); + cmdTable = Tcl_Namespace_cmdTable(ns); + hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); - INCR_REF_COUNT(newFullCmdName); INCR_REF_COUNT(oldFullCmdName); - Tcl_AppendStringsToObj(newFullCmdName, "::", name, (char *) NULL); - Tcl_AppendStringsToObj(oldFullCmdName, "::", name, (char *) NULL); - newName = ObjStr(newFullCmdName); - oldName = ObjStr(oldFullCmdName); + /*fprintf(stderr,"copy cmdTable = %p, first=%p\n",cmdTable,hPtr);*/ + while (hPtr != NULL) { + name = Tcl_GetHashKey(cmdTable, hPtr); - /* - * Make sure that the destination command does not already exist. - * Otherwise: do not copy - */ - cmd = Tcl_FindCommand(in, newName, 0, 0); + /* + * construct full cmd names + */ + newFullCmdName = Tcl_NewStringObj(newNs->fullName,-1); + oldFullCmdName = Tcl_NewStringObj(ns->fullName,-1); - if (cmd != NULL) { - /*fprintf(stderr, "%s already exists\n", newName);*/ - if (!XOTclpGetObject(in, newName)) { - /* command or instproc will be deleted & then copied */ - Tcl_DeleteCommandFromToken(in, cmd); - } else { - /* don't overwrite objects -> will be recreated */ - hPtr = Tcl_NextHashEntry(&hSrch); - DECR_REF_COUNT(newFullCmdName); - DECR_REF_COUNT(oldFullCmdName); - continue; - } - } + INCR_REF_COUNT(newFullCmdName); INCR_REF_COUNT(oldFullCmdName); + Tcl_AppendStringsToObj(newFullCmdName, "::", name, (char *) NULL); + Tcl_AppendStringsToObj(oldFullCmdName, "::", name, (char *) NULL); + newName = ObjStr(newFullCmdName); + oldName = ObjStr(oldFullCmdName); - /* - * Find the existing command. An error is returned if simpleName can't - * be found - */ - cmd = Tcl_FindCommand(in, oldName, 0, 0); + /*fprintf(stderr,"try to copy command from '%s' to '%s'\n",oldName, newName);*/ + /* + * Make sure that the destination command does not already exist. + * Otherwise: do not copy + */ + cmd = Tcl_FindCommand(interp, newName, 0, 0); - if (cmd == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(in), "can't copy ", " \"", - oldName, "\": command doesn't exist", - (char *) NULL); - DECR_REF_COUNT(newFullCmdName); - DECR_REF_COUNT(oldFullCmdName); - return TCL_ERROR; - } - /* - * Do not copy Objects or Classes - */ - if (!XOTclpGetObject(in, oldName)) { - if (TclIsProc((Command*)cmd)) { - Proc *procPtr = TclFindProc((Interp *)in, oldName); - Tcl_Obj *arglistObj; - CompiledLocal *localPtr; + if (cmd != NULL) { + /*fprintf(stderr, "%s already exists\n", newName);*/ + if (!XOTclpGetObject(interp, newName)) { + /* command or instproc will be deleted & then copied */ + Tcl_DeleteCommandFromToken(interp, cmd); + } else { + /* don't overwrite objects -> will be recreated */ + hPtr = Tcl_NextHashEntry(&hSrch); + DECR_REF_COUNT(newFullCmdName); + DECR_REF_COUNT(oldFullCmdName); + continue; + } + } - /* - * Build a list containing the arguments of the proc - */ + /* + * Find the existing command. An error is returned if simpleName can't + * be found + */ + cmd = Tcl_FindCommand(interp, oldName, 0, 0); - arglistObj = Tcl_NewListObj(0, NULL); - INCR_REF_COUNT(arglistObj); + if (cmd == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't copy ", " \"", + oldName, "\": command doesn't exist", + (char *) NULL); + DECR_REF_COUNT(newFullCmdName); + DECR_REF_COUNT(oldFullCmdName); + return TCL_ERROR; + } + /* + * Do not copy Objects or Classes + */ + if (!XOTclpGetObject(interp, oldName)) { + if (TclIsProc((Command*)cmd)) { + Proc *procPtr = TclFindProc((Interp *)interp, oldName); + Tcl_Obj *arglistObj; + CompiledLocal *localPtr; - for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; - localPtr = localPtr->nextPtr) { + /* + * Build a list containing the arguments of the proc + */ - if (TclIsCompiledLocalArgument(localPtr)) { - Tcl_Obj *defVal, *defStringObj = Tcl_NewStringObj(localPtr->name, -1); - INCR_REF_COUNT(defStringObj); - /* check for default values */ - if ((GetProcDefault(in, cmdTable, name, - localPtr->name, &defVal) == TCL_OK) && - (defVal != 0)) { - Tcl_AppendStringsToObj(defStringObj, " ", ObjStr(defVal), - (char *) NULL); - } - Tcl_ListObjAppendElement(in, arglistObj, defStringObj); - DECR_REF_COUNT(defStringObj); - } - } + arglistObj = Tcl_NewListObj(0, NULL); + INCR_REF_COUNT(arglistObj); + + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + + if (TclIsCompiledLocalArgument(localPtr)) { + Tcl_Obj *defVal, *defStringObj = Tcl_NewStringObj(localPtr->name, -1); + INCR_REF_COUNT(defStringObj); + /* check for default values */ + if ((GetProcDefault(interp, cmdTable, name, + localPtr->name, &defVal) == TCL_OK) && + (defVal != 0)) { + Tcl_AppendStringsToObj(defStringObj, " ", ObjStr(defVal), + (char *) NULL); + } + Tcl_ListObjAppendElement(interp, arglistObj, defStringObj); + DECR_REF_COUNT(defStringObj); + } + } - if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(in)->objInterpProc) { - Tcl_DString ds, *dsPtr = &ds; + if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) { + Tcl_DString ds, *dsPtr = &ds; - if (isClassName(ns->fullName)) { - /* it started with ::xotcl::classes */ - XOTclClass *cl = XOTclpGetClass(in, NSCutXOTclClasses(ns->fullName)); - XOTclProcAssertion* procs; + if (isClassName(ns->fullName)) { + /* it started with ::xotcl::classes */ + XOTclClass *cl = XOTclpGetClass(interp, NSCutXOTclClasses(ns->fullName)); + XOTclProcAssertion *procs; - if (cl) { - procs = cl->opt ? - AssertionFindProcs(cl->opt->assertions, name) : 0; - } else { - DECR_REF_COUNT(newFullCmdName); - DECR_REF_COUNT(oldFullCmdName); - DECR_REF_COUNT(arglistObj); - return XOTclVarErrMsg(in, "No class for inst - assertions", (char *) NULL); - } + if (cl) { + procs = cl->opt ? + AssertionFindProcs(cl->opt->assertions, name) : 0; + } else { + DECR_REF_COUNT(newFullCmdName); + DECR_REF_COUNT(oldFullCmdName); + DECR_REF_COUNT(arglistObj); + return XOTclVarErrMsg(interp, "No class for inst - assertions", (char *) NULL); + } - /* XOTcl InstProc */ - DSTRING_INIT(dsPtr); - Tcl_DStringAppendElement(dsPtr, NSCutXOTclClasses(newNs->fullName)); - Tcl_DStringAppendElement(dsPtr, "instproc"); - Tcl_DStringAppendElement(dsPtr, name); - Tcl_DStringAppendElement(dsPtr, ObjStr(arglistObj)); - Tcl_DStringAppendElement(dsPtr, StripBodyPrefix(ObjStr(procPtr->bodyPtr))); - if (procs) { - XOTclRequireClassOpt(cl); - AssertionAppendPrePost(in, dsPtr, procs); - } - Tcl_EvalEx(in, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr),0); - DSTRING_FREE(dsPtr); - } else { - XOTclObject *obj = XOTclpGetObject(in, ns->fullName); - XOTclProcAssertion* procs; - if (obj) { - procs = obj->opt ? - AssertionFindProcs(obj->opt->assertions, name) : 0; - } else { - DECR_REF_COUNT(newFullCmdName); - DECR_REF_COUNT(oldFullCmdName); - DECR_REF_COUNT(arglistObj); - return XOTclVarErrMsg(in, "No object for assertions", (char *) NULL); - } + /* XOTcl InstProc */ + DSTRING_INIT(dsPtr); + Tcl_DStringAppendElement(dsPtr, NSCutXOTclClasses(newNs->fullName)); + Tcl_DStringAppendElement(dsPtr, "instproc"); + Tcl_DStringAppendElement(dsPtr, name); + Tcl_DStringAppendElement(dsPtr, ObjStr(arglistObj)); + Tcl_DStringAppendElement(dsPtr, StripBodyPrefix(ObjStr(procPtr->bodyPtr))); + if (procs) { + XOTclRequireClassOpt(cl); + AssertionAppendPrePost(interp, dsPtr, procs); + } + Tcl_EvalEx(interp, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr),0); + DSTRING_FREE(dsPtr); + } else { + XOTclObject *obj = XOTclpGetObject(interp, ns->fullName); + XOTclProcAssertion *procs; + if (obj) { + procs = obj->opt ? + AssertionFindProcs(obj->opt->assertions, name) : 0; + } else { + DECR_REF_COUNT(newFullCmdName); + DECR_REF_COUNT(oldFullCmdName); + DECR_REF_COUNT(arglistObj); + return XOTclVarErrMsg(interp, "No object for assertions", (char *) NULL); + } - /* XOTcl Proc */ - DSTRING_INIT(dsPtr); - Tcl_DStringAppendElement(dsPtr, newNs->fullName); - Tcl_DStringAppendElement(dsPtr, "proc"); - Tcl_DStringAppendElement(dsPtr, name); - Tcl_DStringAppendElement(dsPtr, ObjStr(arglistObj)); - Tcl_DStringAppendElement(dsPtr, StripBodyPrefix(ObjStr(procPtr->bodyPtr))); - if (procs) { - XOTclRequireObjectOpt(obj); - AssertionAppendPrePost(in, dsPtr, procs); - } - Tcl_EvalEx(in, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr),0); - DSTRING_FREE(dsPtr); - } - DECR_REF_COUNT(arglistObj); - } else { - /* Tcl Proc */ - Tcl_VarEval(in, "proc ", newName, " {", ObjStr(arglistObj),"} {\n", - ObjStr(procPtr->bodyPtr), "}", (char *) NULL); - } - } else { - /* - * Otherwise copy command - */ - Tcl_ObjCmdProc* objProc = Tcl_Command_objProc(cmd); - Tcl_CmdDeleteProc *deleteProc = Tcl_Command_deleteProc(cmd); - ClientData cd; - if (objProc) { - cd = Tcl_Command_objClientData(cmd); - if (cd == 0 || cd == XOTCL_NONLEAF_METHOD) { - /* if client data not null, we would have to copy - the client data; we don't know its size...., so rely - on introspection for copying */ - Tcl_CreateObjCommand(in, newName, objProc, - Tcl_Command_objClientData(cmd), deleteProc); - } - } else { - cd = Tcl_Command_clientData(cmd); - if (cd == 0 || cd == XOTCL_NONLEAF_METHOD) { - Tcl_CreateCommand(in, newName, Tcl_Command_proc(cmd), - Tcl_Command_clientData(cmd), deleteProc); - } - } - } + /* XOTcl Proc */ + DSTRING_INIT(dsPtr); + Tcl_DStringAppendElement(dsPtr, newNs->fullName); + Tcl_DStringAppendElement(dsPtr, "proc"); + Tcl_DStringAppendElement(dsPtr, name); + Tcl_DStringAppendElement(dsPtr, ObjStr(arglistObj)); + Tcl_DStringAppendElement(dsPtr, StripBodyPrefix(ObjStr(procPtr->bodyPtr))); + if (procs) { + XOTclRequireObjectOpt(obj); + AssertionAppendPrePost(interp, dsPtr, procs); + } + Tcl_EvalEx(interp, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr),0); + DSTRING_FREE(dsPtr); + } + DECR_REF_COUNT(arglistObj); + } else { + /* Tcl Proc */ + Tcl_VarEval(interp, "proc ", newName, " {", ObjStr(arglistObj),"} {\n", + ObjStr(procPtr->bodyPtr), "}", (char *) NULL); + } + } else { + /* + * Otherwise copy command + */ + Tcl_ObjCmdProc *objProc = Tcl_Command_objProc(cmd); + Tcl_CmdDeleteProc *deleteProc = Tcl_Command_deleteProc(cmd); + ClientData clientData; + if (objProc) { + clientData = Tcl_Command_objClientData(cmd); + if (clientData == 0) { + /* if client data not null, we would have to copy + the client data; we don't know its size...., so rely + on introspection for copying */ + Tcl_CreateObjCommand(interp, newName, objProc, + Tcl_Command_objClientData(cmd), deleteProc); + } + } else { + clientData = Tcl_Command_clientData(cmd); + if (clientData == 0) { + Tcl_CreateCommand(interp, newName, Tcl_Command_proc(cmd), + Tcl_Command_clientData(cmd), deleteProc); + } + } + } + } + hPtr = Tcl_NextHashEntry(&hSrch); + DECR_REF_COUNT(newFullCmdName); DECR_REF_COUNT(oldFullCmdName); } - hPtr = Tcl_NextHashEntry(&hSrch); - DECR_REF_COUNT(newFullCmdName); DECR_REF_COUNT(oldFullCmdName); - } - return TCL_OK; + return TCL_OK; } static int -XOTcl_NSCopyVars(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Namespace *ns, *newNs; - Var *varPtr = NULL; - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr; - TclVarHashTable *varTable; - int rc = TCL_OK; - XOTclObject *obj; - char *destFullName; - Tcl_Obj *destFullNameObj; - TclCallFrame frame, *framePtr = &frame; - Tcl_Obj *varNameObj = NULL; - Tcl_Obj *nobjv[4]; - int nobjc; - Tcl_Obj *setObj; - - if (objc != 3) - return XOTclObjErrArgCnt(in, NULL, "namespace_copyvars fromNs toNs"); +XOTcl_NSCopyVars(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + Tcl_Namespace *ns, *newNs; + Var *varPtr = NULL; + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + TclVarHashTable *varTable; + int rc = TCL_OK; + XOTclObject *obj; + char *destFullName; + Tcl_Obj *destFullNameObj; + TclCallFrame frame, *framePtr = &frame; + Tcl_Obj *varNameObj = NULL; + Tcl_Obj *nobjv[4]; + int nobjc; + Tcl_Obj *setObj; - ns = ObjFindNamespace(in, objv[1]); - if (ns) { - newNs = ObjFindNamespace(in, objv[2]); - if (!newNs) - return XOTclVarErrMsg(in, "CopyVars: Destination namespace ", - ObjStr(objv[2]), " does not exist", (char *) NULL); + if (objc != 3) + return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - obj = XOTclpGetObject(in, ObjStr(objv[1])); - destFullName = newNs->fullName; - destFullNameObj = Tcl_NewStringObj(destFullName, -1); - INCR_REF_COUNT(destFullNameObj); - varTable = Tcl_Namespace_varTable(ns); - Tcl_PushCallFrame(in,(Tcl_CallFrame *)framePtr,newNs,0); - } else { - XOTclObject *newObj; - if (XOTclObjConvertObject(in, objv[1], &obj) != TCL_OK) { - return XOTclVarErrMsg(in, "CopyVars: Origin object/namespace ", - ObjStr(objv[1]), " does not exist", (char *) NULL); + ns = ObjFindNamespace(interp, objv[1]); + if (ns) { + newNs = ObjFindNamespace(interp, objv[2]); + if (!newNs) + return XOTclVarErrMsg(interp, "CopyVars: Destination namespace ", + ObjStr(objv[2]), " does not exist", (char *) NULL); + + obj = XOTclpGetObject(interp, ObjStr(objv[1])); + destFullName = newNs->fullName; + destFullNameObj = Tcl_NewStringObj(destFullName, -1); + INCR_REF_COUNT(destFullNameObj); + varTable = Tcl_Namespace_varTable(ns); + Tcl_PushCallFrame(interp,(Tcl_CallFrame *)framePtr,newNs,0); + } else { + XOTclObject *newObj; + if (XOTclObjConvertObject(interp, objv[1], &obj) != TCL_OK) { + return XOTclVarErrMsg(interp, "CopyVars: Origin object/namespace ", + ObjStr(objv[1]), " does not exist", (char *) NULL); + } + if (XOTclObjConvertObject(interp, objv[2], &newObj) != TCL_OK) { + return XOTclVarErrMsg(interp, "CopyVars: Destination object/namespace ", + ObjStr(objv[2]), " does not exist", (char *) NULL); + } + varTable = obj->varTable; + destFullNameObj = newObj->cmdName; + destFullName = ObjStr(destFullNameObj); } - if (XOTclObjConvertObject(in, objv[2], &newObj) != TCL_OK) { - return XOTclVarErrMsg(in, "CopyVars: Destination object/namespace ", - ObjStr(objv[2]), " does not exist", (char *) NULL); - } - varTable = obj->varTable; - destFullNameObj = newObj->cmdName; - destFullName = ObjStr(destFullNameObj); - } - setObj= Tcl_NewStringObj("set", 3); - INCR_REF_COUNT(setObj); - nobjc = 4; - nobjv[0] = destFullNameObj; - nobjv[1] = setObj; - - /* copy all vars in the namespace */ - hPtr = varTable ? Tcl_FirstHashEntry(VarHashTable(varTable), &hSrch) : 0; - while (hPtr != NULL) { + setObj= Tcl_NewStringObj("set", 3); + INCR_REF_COUNT(setObj); + nobjc = 4; + nobjv[0] = destFullNameObj; + nobjv[1] = setObj; - getVarAndNameFromHash(hPtr, &varPtr, &varNameObj); - INCR_REF_COUNT(varNameObj); + /* copy all vars in the ns */ + hPtr = varTable ? Tcl_FirstHashEntry(VarHashTable(varTable), &hSrch) : NULL; + while (hPtr != NULL) { - if (!TclIsVarUndefined(varPtr) && !TclIsVarLink(varPtr)) { - if (TclIsVarScalar(varPtr)) { - /* it may seem odd that we do not copy obj vars with the - * same SetVar2 as normal vars, but we want to dispatch it in order to - * be able to intercept the copying */ + getVarAndNameFromHash(hPtr, &varPtr, &varNameObj); + INCR_REF_COUNT(varNameObj); - if (obj) { - nobjv[2] = varNameObj; - nobjv[3] = valueOfVar(Tcl_Obj,varPtr,objPtr); - rc = Tcl_EvalObjv(in, nobjc, nobjv, 0); - } else { - Tcl_ObjSetVar2(in, varNameObj, NULL, - valueOfVar(Tcl_Obj,varPtr,objPtr), - TCL_NAMESPACE_ONLY); - } - } else { - if (TclIsVarArray(varPtr)) { - /* HERE!! PRE85 Why not [array get/set] based? Let the core iterate*/ - TclVarHashTable *aTable = valueOfVar(TclVarHashTable,varPtr,tablePtr); - Tcl_HashSearch ahSrch; - Tcl_HashEntry* ahPtr = aTable ? Tcl_FirstHashEntry(VarHashTable(aTable), &ahSrch) :0; - for (; ahPtr != 0; ahPtr = Tcl_NextHashEntry(&ahSrch)) { - Tcl_Obj *eltNameObj; - Var *eltVar; + if (!TclIsVarUndefined(varPtr) && !TclIsVarLink(varPtr)) { + if (TclIsVarScalar(varPtr)) { + /* it may seem odd that we do not copy obj vars with the + * same SetVar2 as normal vars, but we want to dispatch it in order to + * be able to intercept the copying */ - getVarAndNameFromHash(ahPtr, &eltVar, &eltNameObj); + if (obj) { +#if 1 + /* can't rely on "set", if there are multiple object systems */ + setInstVar(interp, obj, varNameObj,valueOfVar(Tcl_Obj,varPtr,objPtr)); +#else + nobjv[2] = varNameObj; + nobjv[3] = valueOfVar(Tcl_Obj,varPtr,objPtr); + rc = Tcl_EvalObjv(interp, nobjc, nobjv, 0); +#endif + } else { + Tcl_ObjSetVar2(interp, varNameObj, NULL, + valueOfVar(Tcl_Obj,varPtr,objPtr), + TCL_NAMESPACE_ONLY); + } + } else { + if (TclIsVarArray(varPtr)) { + /* //// HERE!! PRE85 Why not [array get/set] based? Let the core iterate */ + TclVarHashTable *aTable = valueOfVar(TclVarHashTable,varPtr,tablePtr); + Tcl_HashSearch ahSrch; + Tcl_HashEntry* ahPtr = aTable ? Tcl_FirstHashEntry(VarHashTable(aTable), &ahSrch) : NULL; + + for (; ahPtr != 0; ahPtr = Tcl_NextHashEntry(&ahSrch)) { + Tcl_Obj *eltNameObj; + Var *eltVar; - INCR_REF_COUNT(eltNameObj); + getVarAndNameFromHash(ahPtr, &eltVar, &eltNameObj); + INCR_REF_COUNT(eltNameObj); - if (TclIsVarScalar(eltVar)) { - if (obj) { - Tcl_Obj *fullVarNameObj = Tcl_DuplicateObj(varNameObj); - - INCR_REF_COUNT(fullVarNameObj); - Tcl_AppendStringsToObj(fullVarNameObj, "(", - ObjStr(eltNameObj), ")", NULL); - nobjv[2] = fullVarNameObj; - nobjv[3] = valueOfVar(Tcl_Obj,eltVar,objPtr); - - rc = Tcl_EvalObjv(in, nobjc, nobjv, 0); - DECR_REF_COUNT(fullVarNameObj); - } else { - Tcl_ObjSetVar2(in, varNameObj, eltNameObj, - valueOfVar(Tcl_Obj,eltVar,objPtr), - TCL_NAMESPACE_ONLY); - } - } - DECR_REF_COUNT(eltNameObj); - } - } - } + if (TclIsVarScalar(eltVar)) { + if (obj) { +#if 1 + XOTcl_ObjSetVar2((XOTcl_Object*)obj, interp, varNameObj, eltNameObj, valueOfVar(Tcl_Obj,eltVar,objPtr), 0); +#else + Tcl_Obj *fullVarNameObj = Tcl_DuplicateObj(varNameObj); + + INCR_REF_COUNT(fullVarNameObj); + Tcl_AppendStringsToObj(fullVarNameObj, "(", + ObjStr(eltNameObj), ")", NULL); + nobjv[2] = fullVarNameObj; + nobjv[3] = valueOfVar(Tcl_Obj,eltVar,objPtr); + + rc = Tcl_EvalObjv(interp, nobjc, nobjv, 0); + DECR_REF_COUNT(fullVarNameObj); +#endif + } else { + Tcl_ObjSetVar2(interp, varNameObj, eltNameObj, + valueOfVar(Tcl_Obj,eltVar,objPtr), + TCL_NAMESPACE_ONLY); + } + } + DECR_REF_COUNT(eltNameObj); + } + } + } + } + DECR_REF_COUNT(varNameObj); + hPtr = Tcl_NextHashEntry(&hSrch); } - DECR_REF_COUNT(varNameObj); - hPtr = Tcl_NextHashEntry(&hSrch); - } - if (ns) { - DECR_REF_COUNT(destFullNameObj); - Tcl_PopCallFrame(in); - } - DECR_REF_COUNT(setObj); - return rc; + if (ns) { + DECR_REF_COUNT(destFullNameObj); + Tcl_PopCallFrame(interp); + } + DECR_REF_COUNT(setObj); + return rc; } int -XOTclSelfDispatchCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *self; - int result; - if (objc < 2) return XOTclObjErrArgCnt(in, objv[0], "::xotcl::my method ?args?"); - if ((self = GetSelfObj(in))) { - result = callMethod((ClientData)self, in, objv[1], objc, objv+2, 0); - } else { - result = XOTclVarErrMsg(in, "Cannot resolve 'self', probably called outside the context of an XOTcl Object", - (char *) NULL); - } - return result; +XOTclSelfDispatchCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *self; + int result; + if (objc < 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, "?-local? method ?args?"); + if ((self = GetSelfObj(interp))) { + int i = 1; + char *arg1 = ObjStr(objv[1]); + if (*arg1 == '-' && !strcmp("-local",arg1)) { + XOTclClass *cl = GetSelfClass(interp); + Tcl_Command cmd; + ClientData cp; + char *method; + if (objc < 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, "?-local? method ?args?"); + method = ObjStr(objv[2]); + i++; + cmd = FindMethod(method, cl->nsPtr); + if (cmd == 0) + return XOTclVarErrMsg(interp, ObjStr(self->cmdName), + ": unable to dispatch local method '", + method, "' in class ", ObjStr(cl->object.cmdName), + (char *) NULL); + cp = Tcl_Command_objClientData(cmd); + /*fprintf(stderr, "method %s, cmd = %p objc=%d\n", method, cmd, objc); + for (i=0; icmdName),objc,ObjStr(objv[1])); + {int i; fprintf(stderr, "MY\tCALL ");for(i=0; ivarFramePtr = varFramePtr;*/ + /*RUNTIME_STATE(interp)->varFramePtr = varFramePtr;*/ #if 0 - Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(RUNTIME_STATE(in)->cs.top->cmdPtr); - fprintf(stderr,"initProcNS self=%s cmd=%p, '%s'\n", - ObjStr(RUNTIME_STATE(in)->cs.top->self->cmdName), - nsPtr, nsPtr->fullName); - fprintf(stderr,"\tsetting currentFramePtr in %p to %p in initProcNS\n", - RUNTIME_STATE(in)->cs.top->currentFramePtr, varFramePtr); - XOTclCallStackDump(in); + Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(RUNTIME_STATE(interp)->cs.top->cmdPtr); + fprintf(stderr,"initProcNS self=%s cmd=%p, '%s'\n", + ObjStr(RUNTIME_STATE(interp)->cs.top->self->cmdName), + nsPtr, nsPtr->fullName); + fprintf(stderr,"\tsetting currentFramePtr in %p to %p in initProcNS\n", + RUNTIME_STATE(interp)->cs.top->currentFramePtr, varFramePtr); + XOTclCallStackDump(interp); #endif - if (RUNTIME_STATE(in)->cs.top->currentFramePtr == 0) { - RUNTIME_STATE(in)->cs.top->currentFramePtr = varFramePtr; - } /* else { + if (RUNTIME_STATE(interp)->cs.top->currentFramePtr == 0) { + RUNTIME_STATE(interp)->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); + fprintf(stderr,"not overwriting currentFramePtr in %p from %p to %p\n", + RUNTIME_STATE(interp)->cs.top, + RUNTIME_STATE(interp)->cs.top->currentFramePtr, varFramePtr); } */ #if !defined(NAMESPACEINSTPROCS) - if (varFramePtr) { - varFramePtr->nsPtr = GetCallerVarFrame(in,varFramePtr); - } + if (varFramePtr) { + varFramePtr->nsPtr = GetCallerVarFrame(interp,varFramePtr); + } #endif - return TCL_OK; + return TCL_OK; } /* * Interpretation of Non-Positional Args */ int -isNonposArg(Tcl_Interp *in, char * argStr, +isNonposArg(Tcl_Interp *interp, char *argStr, int nonposArgsDefc, Tcl_Obj **nonposArgsDefv, Tcl_Obj **var, char **type) { - int i, npac; - Tcl_Obj **npav; - char *varName; - if (argStr[0] == '-') { - for (i=0; i < nonposArgsDefc; i++) { - if (Tcl_ListObjGetElements(in, nonposArgsDefv[i], - &npac, &npav) == TCL_OK && npac > 0) { - varName = argStr+1; - if (!strcmp(varName, ObjStr(npav[0]))) { - *var = npav[0]; - *type = ObjStr(npav[1]); - return 1; - } - } + int i, npac; + Tcl_Obj **npav; + char *varName; + if (argStr[0] == '-') { + for (i=0; i < nonposArgsDefc; i++) { + if (Tcl_ListObjGetElements(interp, nonposArgsDefv[i], + &npac, &npav) == TCL_OK && npac > 0) { + varName = argStr+1; + if (!strcmp(varName, ObjStr(npav[0]))) { + *var = npav[0]; + *type = ObjStr(npav[1]); + return 1; + } + } + } } - } - return 0; + return 0; } int -XOTclCheckBooleanArgs(ClientData cd, Tcl_Interp *in, int objc, +XOTclCheckBooleanArgs(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - int result, bool; - Tcl_Obj* boolean; + int result, bool; + Tcl_Obj *boolean; - if (objc == 2) { - /* the variable is not yet defined (set), so we cannot check - whether it is boolean or not */ - return TCL_OK; - } else if (objc != 3) { - return XOTclObjErrArgCnt(in, NULL, - "::xotcl::nonposArgs boolean name ?value?"); - } + if (objc == 2) { + /* the variable is not yet defined (set), so we cannot check + whether it is boolean or not */ + return TCL_OK; + } else if (objc != 3) { + return XOTclObjErrArgCnt(interp, NULL, objv[0], "name ?value?"); + } - boolean = Tcl_DuplicateObj(objv[2]); - INCR_REF_COUNT(boolean); - result = Tcl_GetBooleanFromObj(in, boolean, &bool); - DECR_REF_COUNT(boolean); - /* - result = TCL_OK; - */ - if (result != TCL_OK) - return XOTclVarErrMsg(in, - "non-positional argument: '", ObjStr(objv[1]), "' with value '", - ObjStr(objv[2]), "' is not of type boolean", - (char *) NULL); - return TCL_OK; + boolean = Tcl_DuplicateObj(objv[2]); + INCR_REF_COUNT(boolean); + result = Tcl_GetBooleanFromObj(interp, boolean, &bool); + DECR_REF_COUNT(boolean); + /* + if (result != TCL_OK) + return XOTclVarErrMsg(interp, + "non-positional argument: '", ObjStr(objv[1]), "' with value '", + ObjStr(objv[2]), "' is not of type boolean", + (char *) NULL); + */ + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), (result == TCL_OK)); + return TCL_OK; } int -XOTclCheckRequiredArgs(ClientData cd, Tcl_Interp *in, int objc, +XOTclCheckRequiredArgs(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - if (objc != 2 && objc != 3) - return XOTclObjErrArgCnt(in, NULL, - "::xotcl::nonposArgs required ?currentValue?"); + if (objc != 2 && objc != 3) + return XOTclObjErrArgCnt(interp, NULL, objv[0], " ?currentValue?"); - if (objc != 3) - return XOTclVarErrMsg(in, - "required arg: '", ObjStr(objv[1]), "' missing", - (char *) NULL); - return TCL_OK; + if (objc != 3) + return XOTclVarErrMsg(interp, + "required arg '", ObjStr(objv[1]), "' missing", + (char *) NULL); + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + return TCL_OK; } int -XOTclInterpretNonpositionalArgsCmd(ClientData cd, Tcl_Interp *in, int objc, +XOTclInterpretNonpositionalArgsCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Obj **npav, **checkv, **checkArgv, **argsv, **nonposArgsDefv, - *invocation[4], **ordinaryArgsDefv, **defaultValueObjv, *list, - *checkObj, *ordinaryArg; - int npac, checkc, checkArgc, argsc, nonposArgsDefc, - ordinaryArgsDefc, defaultValueObjc, argsDefined = 0, - ordinaryArgsCounter = 0, i, j, result, ic; - char * lastDefArg = NULL, *arg, *argStr; - int endOfNonposArgsReached = 0; - Var *varPtr; + Tcl_Obj **npav, **checkv, **checkArgv, **argsv, **nonposArgsDefv, + *invocation[4], **ordinaryArgsDefv, **defaultValueObjv, *list, + *checkObj, *ordinaryArg; + int npac, checkc, checkArgc, argsc, nonposArgsDefc, + ordinaryArgsDefc, defaultValueObjc, argsDefined = 0, + ordinaryArgsCounter = 0, i, j, result, ic; + char *lastDefArg = NULL, *arg, *argStr; + int endOfNonposArgsReached = 0; + Var *varPtr; - XOTclClass* selfClass = GetSelfClass(in); - char *methodName = (char *) GetSelfProc(in); - Tcl_HashTable* nonposArgsTable; - XOTclNonposArgs* nonposArgs; - XOTclObject* selfObj; - int r1, r2, r3, r4; + XOTclClass *selfClass = GetSelfClass(interp); + char *methodName = (char *) GetSelfProc(interp); + Tcl_HashTable *nonposArgsTable; + XOTclNonposArgs *nonposArgs; + XOTclObject *selfObj; + int r1, r2, r3, r4; - if (objc != 2) - return XOTclObjErrArgCnt(in, NULL, - "::xotcl::interpretNonpositionalArgs "); + if (objc != 2) + return XOTclObjErrArgCnt(interp, objv[0], NULL, "?args?"); - if (selfClass) { - nonposArgsTable = selfClass->nonposArgsTable; - } else if ((selfObj = GetSelfObj(in))) { - nonposArgsTable = selfObj->nonposArgsTable; - } else { - return XOTclVarErrMsg(in, "Non positional args: can't find self/self class", - (char *) NULL); - } + if (selfClass) { + nonposArgsTable = selfClass->nonposArgsTable; + } else if ((selfObj = GetSelfObj(interp))) { + nonposArgsTable = selfObj->nonposArgsTable; + } else { + return XOTclVarErrMsg(interp, "Non-positional args: can't find self/self class", + (char *) NULL); + } - nonposArgs = NonposArgsGet(nonposArgsTable, methodName); - if (nonposArgs == 0) { - return XOTclVarErrMsg(in, - "Non positional args: can't find hash entry for: ", - methodName, - (char *) NULL); - } + nonposArgs = NonposArgsGet(nonposArgsTable, methodName); + if (nonposArgs == 0) { + return XOTclVarErrMsg(interp, + "Non-positional args: can't find hash entry for: ", + methodName, + (char *) NULL); + } - r1 = Tcl_ListObjGetElements(in, nonposArgs->nonposArgs, - &nonposArgsDefc, &nonposArgsDefv); - r2 = Tcl_ListObjGetElements(in, nonposArgs->ordinaryArgs, - &ordinaryArgsDefc, &ordinaryArgsDefv); - r3 = Tcl_ListObjGetElements(in, objv[1], &argsc, &argsv); + fprintf(stderr,"interpretnonposargs nonposargs = %s, ordinaryArgs = %s\n", + ObjStr(nonposArgs->nonposArgs), ObjStr(nonposArgs->ordinaryArgs)); + + r1 = Tcl_ListObjGetElements(interp, nonposArgs->nonposArgs, + &nonposArgsDefc, &nonposArgsDefv); + r2 = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs, + &ordinaryArgsDefc, &ordinaryArgsDefv); + r3 = Tcl_ListObjGetElements(interp, objv[1], &argsc, &argsv); - if (r1 != TCL_OK || r2 != TCL_OK || r3 != TCL_OK) { - return XOTclVarErrMsg(in, - "Cannot split non positional args list: ", - methodName, - (char *) NULL); - } + if (r1 != TCL_OK || r2 != TCL_OK || r3 != TCL_OK) { + return XOTclVarErrMsg(interp, + "Cannot split non-positional args list: ", + methodName, + (char *) NULL); + } - /* setting variables to default values */ - for (i=0; i < nonposArgsDefc; i++) { - r1 = Tcl_ListObjGetElements(in, nonposArgsDefv[i], &npac, &npav); - if (r1 == TCL_OK) { - if (npac == 3) { - Tcl_ObjSetVar2(in, npav[0], NULL, npav[2], 0); - } else if (npac == 2 && !strcmp(ObjStr(npav[1]), "switch")) { - Tcl_ObjSetVar2(in, npav[0], NULL, Tcl_NewBooleanObj(0), 0); - } + /* setting variables to default values */ + for (i=0; i < nonposArgsDefc; i++) { + r1 = Tcl_ListObjGetElements(interp, nonposArgsDefv[i], &npac, &npav); + if (r1 == TCL_OK) { + if (npac == 3) { + /* not sure, whether Tcl_ObjSetVar2 would be better or would + cause shimmering between list elements and vars (2 times) */ + Tcl_SetVar2Ex(interp, ObjStr(npav[0]), NULL, npav[2], 0); + } else if (npac == 2 && !strcmp(ObjStr(npav[1]), "switch")) { + /* default for switch is "off" */ + Tcl_SetVar2Ex(interp, ObjStr(npav[0]), NULL, Tcl_NewBooleanObj(0), 0); + } + } } - } - if (ordinaryArgsDefc > 0) { - lastDefArg = ObjStr(ordinaryArgsDefv[ordinaryArgsDefc-1]); - if (isArgsString(lastDefArg)) { - argsDefined = 1; + if (ordinaryArgsDefc > 0) { + lastDefArg = ObjStr(ordinaryArgsDefv[ordinaryArgsDefc-1]); + if (isArgsString(lastDefArg)) { + argsDefined = 1; + } } - } - /* setting specified variables */ - for (i=0; i < argsc; i++) { + /* setting specified variables */ + for (i=0; i < argsc; i++) { - if (!endOfNonposArgsReached) { - char *type; - Tcl_Obj *var; - argStr = ObjStr(argsv[i]); + if (!endOfNonposArgsReached) { + char *type; + Tcl_Obj *var; + argStr = ObjStr(argsv[i]); - if (isDoubleDashString(argStr)) { - endOfNonposArgsReached = 1; - i++; - } - if (isNonposArg(in, argStr, nonposArgsDefc, nonposArgsDefv, &var,&type)) { - if (*type == 's' && !strcmp(type, "switch")) { - int bool; - Tcl_Obj *boolObj = Tcl_ObjGetVar2(in, var, 0, 0); - if (Tcl_GetBooleanFromObj(in, boolObj, &bool) != TCL_OK) { - return XOTclVarErrMsg(in, "Non positional arg '",argStr, - "': no boolean value", (char *) NULL); - } - Tcl_ObjSetVar2(in, var, NULL, Tcl_NewBooleanObj(!bool), 0); - } else { - i++; - if (i >= argsc) - return XOTclVarErrMsg(in, "Non positional arg '", - argStr, "': value missing", (char *) NULL); - Tcl_ObjSetVar2(in, var, NULL, argsv[i], 0); - } - } else { - endOfNonposArgsReached = 1; - } - } + if (isDoubleDashString(argStr)) { + endOfNonposArgsReached = 1; + i++; + } + if (isNonposArg(interp, argStr, nonposArgsDefc, nonposArgsDefv, &var,&type)) { + if (*type == 's' && !strcmp(type, "switch")) { + int bool; + Tcl_Obj *boolObj = Tcl_ObjGetVar2(interp, var, 0, 0); + if (Tcl_GetBooleanFromObj(interp, boolObj, &bool) != TCL_OK) { + return XOTclVarErrMsg(interp, "Non positional arg '",argStr, + "': no boolean value", (char *) NULL); + } + Tcl_ObjSetVar2(interp, var, NULL, Tcl_NewBooleanObj(!bool), 0); + } else { + i++; + if (i >= argsc) + return XOTclVarErrMsg(interp, "Non positional arg '", + argStr, "' missing", (char *) NULL); + Tcl_ObjSetVar2(interp, var, NULL, argsv[i], 0); + } + } else { + endOfNonposArgsReached = 1; + } + } - if (endOfNonposArgsReached && i < argsc) { - if (ordinaryArgsCounter >= ordinaryArgsDefc) { - Tcl_Obj *tmp = NonposArgsFormat(in, nonposArgs->nonposArgs); - XOTclVarErrMsg(in, "unknown argument '", - ObjStr(argsv[i]), - "' for method '", - methodName, - "': valid arguments ", - ObjStr(tmp), - " ", - ObjStr(nonposArgs->ordinaryArgs), - (char *) NULL); - DECR_REF_COUNT(tmp); - return TCL_ERROR; - } - arg = ObjStr(ordinaryArgsDefv[ordinaryArgsCounter]); - /* this is the last arg and 'args' is defined */ - if (argsDefined && ordinaryArgsCounter+1 == ordinaryArgsDefc) { - list = Tcl_NewListObj(0, NULL); - INCR_REF_COUNT(list); - for(; i < argsc; i++) - Tcl_ListObjAppendElement(in, list, argsv[i]); - Tcl_ObjSetVar2(in, ordinaryArgsDefv[ordinaryArgsCounter], NULL, list, 0); - DECR_REF_COUNT(list); - } else { - /* break down this argument, if it has a default value, - use only the first part */ - ordinaryArg = ordinaryArgsDefv[ordinaryArgsCounter]; - r4 = Tcl_ListObjGetElements(in, ordinaryArg, - &defaultValueObjc, &defaultValueObjv); - if (r4 == TCL_OK && defaultValueObjc == 2) { - ordinaryArg = defaultValueObjv[0]; - } - Tcl_ObjSetVar2(in, ordinaryArg, NULL, argsv[i], 0); - } - ordinaryArgsCounter++; + if (endOfNonposArgsReached && i < argsc) { + if (ordinaryArgsCounter >= ordinaryArgsDefc) { + Tcl_Obj *tmp = NonposArgsFormat(interp, nonposArgs->nonposArgs); + XOTclVarErrMsg(interp, "unknown argument '", + ObjStr(argsv[i]), + "' for method '", + methodName, + "': valid arguments ", + ObjStr(tmp), + " ", + ObjStr(nonposArgs->ordinaryArgs), + (char *) NULL); + DECR_REF_COUNT(tmp); + return TCL_ERROR; + } + arg = ObjStr(ordinaryArgsDefv[ordinaryArgsCounter]); + /* this is the last arg and 'args' is defined */ + if (argsDefined && ordinaryArgsCounter+1 == ordinaryArgsDefc) { + list = Tcl_NewListObj(0, NULL); + INCR_REF_COUNT(list); + for(; i < argsc; i++) { + Tcl_ListObjAppendElement(interp, list, argsv[i]); + } + Tcl_ObjSetVar2(interp, ordinaryArgsDefv[ordinaryArgsCounter], NULL, list, 0); + DECR_REF_COUNT(list); + } else { + /* break down this argument, if it has a default value, + use only the first part */ + ordinaryArg = ordinaryArgsDefv[ordinaryArgsCounter]; + r4 = Tcl_ListObjGetElements(interp, ordinaryArg, + &defaultValueObjc, &defaultValueObjv); + if (r4 == TCL_OK && defaultValueObjc == 2) { + ordinaryArg = defaultValueObjv[0]; + } + Tcl_ObjSetVar2(interp, ordinaryArg, NULL, argsv[i], 0); + } + ordinaryArgsCounter++; + } } - } - /*fprintf(stderr,"... args defined %d argsc=%d oa %d oad %d\n", - argsDefined, argsc, - ordinaryArgsCounter, ordinaryArgsDefc); */ + /*fprintf(stderr,"... args defined %d argsc=%d oa %d oad %d\n", + argsDefined, argsc, + ordinaryArgsCounter, ordinaryArgsDefc); */ - if ((!argsDefined && ordinaryArgsCounter != ordinaryArgsDefc) || - (argsDefined && ordinaryArgsCounter < ordinaryArgsDefc-1)) { + if ((!argsDefined && ordinaryArgsCounter != ordinaryArgsDefc) || + (argsDefined && ordinaryArgsCounter < ordinaryArgsDefc-1)) { - /* we do not have enough arguments, maybe there are default arguments - for the missing args */ - while (ordinaryArgsCounter != ordinaryArgsDefc) { - if (argsDefined && ordinaryArgsCounter+1 == ordinaryArgsDefc) - break; - r4 = Tcl_ListObjGetElements(in, ordinaryArgsDefv[ordinaryArgsCounter], - &defaultValueObjc, &defaultValueObjv); - /*fprintf(stderr,"... try to get default for '%s', rc %d, objc %d\n", + /* we do not have enough arguments, maybe there are default arguments + for the missing args */ + while (ordinaryArgsCounter != ordinaryArgsDefc) { + if (argsDefined && ordinaryArgsCounter+1 == ordinaryArgsDefc) + break; + r4 = Tcl_ListObjGetElements(interp, ordinaryArgsDefv[ordinaryArgsCounter], + &defaultValueObjc, &defaultValueObjv); + /*fprintf(stderr,"... try to get default for '%s', rc %d, objc %d\n", ObjStr(ordinaryArgsDefv[ordinaryArgsCounter]), r4,defaultValueObjc);*/ - if (r4 == TCL_OK && defaultValueObjc == 2) { - Tcl_ObjSetVar2(in, defaultValueObjv[0], NULL, defaultValueObjv[1], 0); - } else { - Tcl_Obj *tmp = NonposArgsFormat(in, nonposArgs->nonposArgs); - XOTclVarErrMsg(in, "wrong # args for method '", - methodName, "': valid arguments ", ObjStr(tmp), " ", - ObjStr(nonposArgs->ordinaryArgs), - (char *) NULL); - DECR_REF_COUNT(tmp); - return TCL_ERROR; - } - ordinaryArgsCounter++; + if (r4 == TCL_OK && defaultValueObjc == 2) { + Tcl_ObjSetVar2(interp, defaultValueObjv[0], NULL, defaultValueObjv[1], 0); + } else { + Tcl_Obj *tmp = NonposArgsFormat(interp, nonposArgs->nonposArgs); + XOTclVarErrMsg(interp, "wrong # args for method '", + methodName, "': valid arguments ", ObjStr(tmp), " ", + ObjStr(nonposArgs->ordinaryArgs), + (char *) NULL); + DECR_REF_COUNT(tmp); + return TCL_ERROR; + } + ordinaryArgsCounter++; + } + if (argsDefined) { + Tcl_SetVar2(interp, "args", 0, "", 0); + } + } else if (argsDefined && ordinaryArgsCounter == ordinaryArgsDefc-1) { + Tcl_SetVar2(interp, "args", 0, "", 0); } - if (argsDefined) { - Tcl_SetVar2(in, "args", NULL, "", 0); + + if (!argsDefined) { + Tcl_UnsetVar2(interp, "args", 0, 0); } - } else if (argsDefined && ordinaryArgsCounter == ordinaryArgsDefc-1) { - Tcl_SetVar2(in, "args", NULL, "", 0); - } - if (!argsDefined) { - Tcl_UnsetVar2(in, "args", NULL, 0); - } - - /* checking vars */ - for (i=0; i < nonposArgsDefc; i++) { - r1 = Tcl_ListObjGetElements(in, nonposArgsDefv[i], &npac, &npav); - if (r1 == TCL_OK && npac > 1 && *(ObjStr(npav[1])) != '\0') { - r1 = Tcl_ListObjGetElements(in, npav[1], &checkc, &checkv); - if (r1 == TCL_OK) { - checkObj = XOTclGlobalObjects[XOTE_NON_POS_ARGS_OBJ]; - for (j=0; j < checkc; j++) { - r1 = Tcl_ListObjGetElements(in, checkv[j], &checkArgc, &checkArgv); - if (r1 == TCL_OK && checkArgc > 1) { - if (isCheckObjString((ObjStr(checkArgv[0]))) && checkArgc == 2) { - checkObj = checkArgv[1]; - continue; - } - } - invocation[0] = checkObj; - invocation[1] = checkv[j]; - varPtr = TclVarTraceExists(in, ObjStr(npav[0])); - invocation[2] = npav[0]; - ic = 3; - if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) { - invocation[3] = Tcl_ObjGetVar2(in, npav[0], 0, 0); - ic = 4; - } - result = Tcl_EvalObjv(in, ic, invocation, 0); - /* - objPtr = Tcl_ConcatObj(ic, invocation); - fprintf(stderr,"eval on <%s>\n",ObjStr(objPtr)); - result = Tcl_EvalObjEx(in, objPtr, TCL_EVAL_DIRECT); - */ - if (result != TCL_OK) { - return result; - } - } - } - } - } - return TCL_OK; + /* checking vars */ + for (i=0; i < nonposArgsDefc; i++) { + r1 = Tcl_ListObjGetElements(interp, nonposArgsDefv[i], &npac, &npav); + if (r1 == TCL_OK && npac > 1 && *(ObjStr(npav[1])) != '\0') { + r1 = Tcl_ListObjGetElements(interp, npav[1], &checkc, &checkv); + if (r1 == TCL_OK) { + int checkResult = 0; + checkObj = nonposArgs->slotObj == NULL ? + XOTclGlobalObjects[XOTE_NON_POS_ARGS_OBJ] : + nonposArgs->slotObj; + for (j=0; j < checkc; j++) { + r1 = Tcl_ListObjGetElements(interp, checkv[j], &checkArgc, &checkArgv); + if (r1 == TCL_OK && checkArgc > 1) { + if (isCheckObjString((ObjStr(checkArgv[0]))) && checkArgc == 2) { + checkObj = checkArgv[1]; + continue; + } + } + invocation[0] = checkObj; + invocation[1] = checkv[j]; + varPtr = TclVarTraceExists(interp, ObjStr(npav[0])); + invocation[2] = npav[0]; + ic = 3; + if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) { + invocation[3] = Tcl_ObjGetVar2(interp, npav[0], 0, 0); + ic = 4; + } + result = Tcl_EvalObjv(interp, ic, invocation, 0); + /* + objPtr = Tcl_ConcatObj(ic, invocation); + fprintf(stderr,"eval on <%s>\n",ObjStr(objPtr)); + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); + */ + if (result == TCL_OK && ic == 4) { + result = Tcl_GetIntFromObj(interp,Tcl_GetObjResult(interp),&checkResult); + } + if (result != TCL_OK) { + return result; + } + if (!checkResult && ic == 4) { + return XOTclVarErrMsg(interp, + "non-positional argument: '", ObjStr(invocation[2]), "' with value '", + ObjStr(invocation[3]), "' is not of ", ObjStr(invocation[1]), + (char *) NULL); + } + } + } + } + } + return TCL_OK; } /* create a slave interp that calls XOTcl Init */ static int -XOTcl_InterpObjCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Interp *slave; - char *subCmd; - ALLOC_ON_STACK(Tcl_Obj*,objc, ov); +XOTcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + Tcl_Interp *slave; + char *subCmd; + ALLOC_ON_STACK(Tcl_Obj *,objc, ov); - memcpy(ov, objv, sizeof(Tcl_Obj *)*objc); - if (objc < 1) { - XOTclObjErrArgCnt(in, NULL, "::xotcl::interp name ?args?"); - goto interp_error; - } + memcpy(ov, objv, sizeof(Tcl_Obj *)*objc); + if (objc < 1) { + XOTclObjErrArgCnt(interp, objv[0], NULL, "name ?args?"); + goto interp_error; + } - ov[0] = XOTclGlobalObjects[XOTE_INTERP]; - if (Tcl_EvalObjv(in, objc, ov, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) != TCL_OK) { - goto interp_error; - } - - subCmd = ObjStr(ov[1]); - if (isCreateString(subCmd)) { - slave = Tcl_GetSlave(in, ObjStr(ov[2])); - if (!slave) { - XOTclVarErrMsg(in, "Creation of slave interpreter failed", (char *) NULL); - goto interp_error; + ov[0] = XOTclGlobalObjects[XOTE_INTERP]; + if (Tcl_EvalObjv(interp, objc, ov, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) != TCL_OK) { + goto interp_error; } - if (Xotcl_Init(slave) == TCL_ERROR) { - goto interp_error; - } + + subCmd = ObjStr(ov[1]); + if (isCreateString(subCmd)) { + slave = Tcl_GetSlave(interp, ObjStr(ov[2])); + if (!slave) { + XOTclVarErrMsg(interp, "Creation of slave interpreter failed", (char *) NULL); + goto interp_error; + } + if (Xotcl_Init(slave) == TCL_ERROR) { + goto interp_error; + } #ifdef XOTCL_MEM_COUNT - xotclMemCountInterpCounter++; + xotclMemCountInterpCounter++; #endif - } - FREE_ON_STACK(ov); - return TCL_OK; + } + FREE_ON_STACK(ov); + return TCL_OK; interp_error: - FREE_ON_STACK(ov); - return TCL_ERROR; + FREE_ON_STACK(ov); + return TCL_ERROR; } -extern Tcl_Obj* -XOTclOGetInstVar2(XOTcl_Object *obj, Tcl_Interp *in, Tcl_Obj *name1, Tcl_Obj *name2, - int flgs) { - Tcl_Obj *result; - XOTcl_FrameDecls; - XOTcl_PushFrame(in, (XOTclObject*)obj); - if (((XOTclObject*)obj)->nsPtr) - flgs |= TCL_NAMESPACE_ONLY; - result = Tcl_ObjGetVar2(in, name1, name2, flgs); - XOTcl_PopFrame(in, (XOTclObject*)obj); - - return result; -} - - #if !defined(NDEBUG) static void -checkAllInstances(Tcl_Interp *in, XOTclClass *cl, int lvl) { - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - if (cl && cl->object.refCount>0) { - /*fprintf(stderr,"checkallinstances %d cl=%p '%s'\n", lvl, cl, ObjStr(cl->object.cmdName));*/ - for (hPtr = Tcl_FirstHashEntry(&cl->instances, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(&cl->instances, hPtr); - assert(inst); - assert(inst->refCount>0); - assert(inst->cmdName->refCount>0); - if (XOTclObjectIsClass(inst) && (XOTclClass*)inst != RUNTIME_STATE(in)->theClass) { - checkAllInstances(in, (XOTclClass*) inst, lvl+1); - } +checkAllInstances(Tcl_Interp *interp, XOTclClass *cl, int lvl) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + if (cl && cl->object.refCount>0) { + /*fprintf(stderr,"checkallinstances %d cl=%p '%s'\n", lvl, cl, ObjStr(cl->object.cmdName));*/ + for (hPtr = Tcl_FirstHashEntry(&cl->instances, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + XOTclObject *interpst = (XOTclObject*) Tcl_GetHashKey(&cl->instances, hPtr); + assert(inst); + assert(inst->refCount>0); + assert(inst->cmdName->refCount>0); + if (XOTclObjectIsClass(inst) && (XOTclClass*)inst != RUNTIME_STATE(interp)->theClass) { + checkAllInstances(interp, (XOTclClass*) inst, lvl+1); + } + } } - } } #endif #ifdef DO_FULL_CLEANUP /* delete global variables and procs */ -static void deleteProcsAndVars(Tcl_Interp *in) { - Tcl_Namespace *ns = Tcl_GetGlobalNamespace(in); - Tcl_HashTable *varTable = ns ? Tcl_Namespace_varTable(ns) : NULL; - Tcl_HashTable *cmdTable = ns ? Tcl_Namespace_cmdTable(ns) : NULL; - Tcl_HashSearch search; - Var *varPtr; - Tcl_Command cmd; - register Tcl_HashEntry *entryPtr; - char *varName; +static void deleteProcsAndVars(Tcl_Interp *interp) { + Tcl_Namespace *ns = Tcl_GetGlobalNamespace(interp); + Tcl_HashTable *varTable = ns ? Tcl_Namespace_varTable(ns) : NULL; + Tcl_HashTable *cmdTable = ns ? Tcl_Namespace_cmdTable(ns) : NULL; + Tcl_HashSearch search; + Var *varPtr; + Tcl_Command cmd; + register Tcl_HashEntry *entryPtr; + char *varName; - entryPtr = Tcl_FirstHashEntry(varTable, &search); - while (entryPtr != NULL) { - Tcl_Obj *nameObj; - getVarAndNameFromHash(entryPtr, &varPtr, &nameObj); - if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { - /* fprintf(stderr, "unsetting var %s\n", ObjStr(nameObj));*/ - Tcl_UnsetVar2(in, ObjStr(nameObj), (char *)NULL, TCL_GLOBAL_ONLY); + entryPtr = Tcl_FirstHashEntry(varTable, &search); + while (entryPtr != NULL) { + Tcl_Obj *nameObj; + getVarAndNameFromHash(entryPtr, &varPtr, &nameObj); + if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { + /* fprintf(stderr, "unsetting var %s\n", ObjStr(nameObj));*/ + Tcl_UnsetVar2(interp, ObjStr(nameObj), (char *) NULL, TCL_GLOBAL_ONLY); + } + entryPtr = Tcl_NextHashEntry(&search); } - entryPtr = Tcl_NextHashEntry(&search); - } + entryPtr = Tcl_FirstHashEntry(cmdTable, &search); + while (entryPtr) { + cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); - entryPtr = Tcl_FirstHashEntry(cmdTable, &search); - while (entryPtr) { - cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); + if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) { + char *key = Tcl_GetHashKey(cmdTable, entryPtr); - if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(in)->objInterpProc) { - char *key = Tcl_GetHashKey(cmdTable, entryPtr); - - /*fprintf(stderr, "cmdname = %s cmd %p proc %p objProc %p %d\n", + /*fprintf(stderr, "cmdname = %s cmd %p proc %p objProc %p %d\n", key,cmd,Tcl_Command_proc(cmd),Tcl_Command_objProc(cmd), - Tcl_Command_proc(cmd)==RUNTIME_STATE(in)->objInterpProc);*/ + Tcl_Command_proc(cmd)==RUNTIME_STATE(interp)->objInterpProc);*/ - Tcl_DeleteCommandFromToken(in, cmd); + Tcl_DeleteCommandFromToken(interp, cmd); + } + entryPtr = Tcl_NextHashEntry(&search); } - entryPtr = Tcl_NextHashEntry(&search); - } } #endif #ifdef DO_CLEANUP static int ClassHasSubclasses(XOTclClass *cl) { - return (cl->sub != NULL); + return (cl->sub != NULL); } static int ClassHasInstances(XOTclClass *cl) { - Tcl_HashSearch hSrch; - return (Tcl_FirstHashEntry(&cl->instances, &hSrch) != NULL); + Tcl_HashSearch hSrch; + return (Tcl_FirstHashEntry(&cl->instances, &hSrch) != NULL); } static int -ObjectHasChildren(Tcl_Interp *in, XOTclObject *obj) { - Tcl_Namespace *ns = obj->nsPtr; - int result = 0; +ObjectHasChildren(Tcl_Interp *interp, XOTclObject *obj) { + Tcl_Namespace *ns = obj->nsPtr; + int result = 0; - if (ns) { - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSrch; - Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); - XOTcl_FrameDecls; + if (ns) { + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSrch; + Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); + XOTcl_FrameDecls; - XOTcl_PushFrame(in, obj); - for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; - hPtr = Tcl_NextHashEntry(&hSrch)) { - char *key = Tcl_GetHashKey(cmdTable, hPtr); - if (XOTclpGetObject(in, key)) { - /*fprintf(stderr,"child = %s\n",key);*/ - result = 1; - break; - } + XOTcl_PushFrame(interp, obj); + for (hPtr = Tcl_FirstHashEntry(cmdTable, &hSrch); hPtr; + hPtr = Tcl_NextHashEntry(&hSrch)) { + char *key = Tcl_GetHashKey(cmdTable, hPtr); + if (XOTclpGetObject(interp, key)) { + /*fprintf(stderr,"child = %s\n",key);*/ + result = 1; + break; + } + } + XOTcl_PopFrame(interp,obj); } - XOTcl_PopFrame(in,obj); - } - return result; + return result; } -static void freeAllXOTclObjectsAndClasses(Tcl_Interp *in, Tcl_HashTable *commandTable) { - Tcl_HashEntry *hPtr, *hDel; - Tcl_HashSearch hSrch; - XOTclObject *obj; - XOTclClass *thecls, *theobj, *cl; +static void freeAllXOTclObjectsAndClasses(Tcl_Interp *interp, Tcl_HashTable *commandTable) { + Tcl_HashEntry *hPtr, *hDel; + Tcl_HashSearch hSrch; + XOTclObject *obj; + XOTclClass *thecls, *theobj, *cl; - /* fprintf(stderr,"??? freeAllXOTclObjectsAndClasses in %p\n", in); */ + /*fprintf(stderr,"??? freeAllXOTclObjectsAndClasses in %p\n", in);*/ - thecls = RUNTIME_STATE(in)->theClass; - theobj = RUNTIME_STATE(in)->theObject; - /***** PHYSICAL DESTROY *****/ - RUNTIME_STATE(in)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY; - while (1) { - int deleted = 0; - hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); - while (hPtr) { - char *key = Tcl_GetHashKey(commandTable, hPtr); - obj = XOTclpGetObject(in, key); - if (obj && !XOTclObjectIsClass(obj) && !ObjectHasChildren(in,obj)) { - /* fprintf(stderr," ... delete object %s %p, class=%s\n",key,obj, - ObjStr(obj->cl->object.cmdName));*/ - freeUnsetTraceVariable(in, obj); - Tcl_DeleteCommandFromToken(in, obj->id); - hDel = hPtr; - deleted++; - } else { - hDel = NULL; - } - hPtr = Tcl_NextHashEntry(&hSrch); - if (hDel) - Tcl_DeleteHashEntry(hDel); - } - /* fprintf(stderr, "deleted %d Objects\n",deleted);*/ - if (deleted>0) - continue; + thecls = RUNTIME_STATE(interp)->theClass; + theobj = RUNTIME_STATE(interp)->theObject; + /***** PHYSICAL DESTROY *****/ + RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_PHYSICAL_DESTROY; + while (1) { + int deleted = 0; + hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); + while (hPtr) { + char *key = Tcl_GetHashKey(commandTable, hPtr); + obj = XOTclpGetObject(interp, key); + if (obj && !XOTclObjectIsClass(obj) && !ObjectHasChildren(interp,obj)) { + /*fprintf(stderr," ... delete object %s %p, class=%s\n",key,obj, + ObjStr(obj->cl->object.cmdName));*/ + Tcl_DeleteCommandFromToken(interp, obj->id); + hDel = hPtr; + deleted++; + } else { + hDel = NULL; + } + hPtr = Tcl_NextHashEntry(&hSrch); + if (hDel) + Tcl_DeleteHashEntry(hDel); + } + /*fprintf(stderr, "deleted %d Objects\n",deleted);*/ + if (deleted>0) + continue; - hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); - while (hPtr) { - char *key = Tcl_GetHashKey(commandTable, hPtr); - cl = XOTclpGetClass(in, key); - /* fprintf(stderr,"cl key = %s %p\n", key, cl); */ - if (cl - && !ObjectHasChildren(in, (XOTclObject*)cl) - && !ClassHasInstances(cl) - && !ClassHasSubclasses(cl) - && cl != RUNTIME_STATE(in)->theClass - && cl != RUNTIME_STATE(in)->theObject - ) { - /* fprintf(stderr," ... delete class %s %p\n",key,cl); */ - freeUnsetTraceVariable(in, &cl->object); - Tcl_DeleteCommandFromToken(in, cl->object.id); - hDel = hPtr; - deleted++; - } else { - hDel = NULL; - } - hPtr = Tcl_NextHashEntry(&hSrch); - if (hDel) - Tcl_DeleteHashEntry(hDel); + hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); + while (hPtr) { + char *key = Tcl_GetHashKey(commandTable, hPtr); + cl = XOTclpGetClass(interp, key); + /* fprintf(stderr,"cl key = %s %p\n", key, cl); */ + if (cl + && !ObjectHasChildren(interp, (XOTclObject*)cl) + && !ClassHasInstances(cl) + && !ClassHasSubclasses(cl) + && cl != RUNTIME_STATE(interp)->theClass + && cl != RUNTIME_STATE(interp)->theObject + ) { + /* fprintf(stderr," ... delete class %s %p\n",key,cl); */ + Tcl_DeleteCommandFromToken(interp, cl->object.id); + hDel = hPtr; + deleted++; + } else { + hDel = NULL; + } + hPtr = Tcl_NextHashEntry(&hSrch); + if (hDel) + Tcl_DeleteHashEntry(hDel); + } + /* fprintf(stderr, "deleted %d Classes\n",deleted);*/ + if (deleted == 0) { + break; + } } - /* fprintf(stderr, "deleted %d Classes\n",deleted);*/ - if (deleted == 0) { - break; - } - } #ifdef DO_FULL_CLEANUP - deleteProcsAndVars(in); + deleteProcsAndVars(interp); #endif - RUNTIME_STATE(in)->callDestroy = 0; - RemoveSuper(thecls, theobj); - RemoveInstance((XOTclObject*)thecls, thecls); - RemoveInstance((XOTclObject*)theobj, thecls); + RUNTIME_STATE(interp)->callDestroy = 0; + RemoveSuper(thecls, theobj); + RemoveInstance((XOTclObject*)thecls, thecls); + RemoveInstance((XOTclObject*)theobj, thecls); - Tcl_DeleteCommandFromToken(in, theobj->object.id); - RUNTIME_STATE(in)->theObject = NULL; + Tcl_DeleteCommandFromToken(interp, theobj->object.id); + RUNTIME_STATE(interp)->theObject = NULL; - Tcl_DeleteCommandFromToken(in, thecls->object.id); - RUNTIME_STATE(in)->theClass = NULL; + Tcl_DeleteCommandFromToken(interp, thecls->object.id); + RUNTIME_STATE(interp)->theClass = NULL; - XOTcl_DeleteNamespace(in, RUNTIME_STATE(in)->fakeNS); - XOTcl_DeleteNamespace(in, RUNTIME_STATE(in)->XOTclClassesNS); - XOTcl_DeleteNamespace(in, RUNTIME_STATE(in)->XOTclNS); + XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->fakeNS); + XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->XOTclClassesNS); + XOTcl_DeleteNamespace(interp, RUNTIME_STATE(interp)->XOTclNS); } #endif /* DO_CLEANUP */ @@ -11857,134 +13266,138 @@ * Exit Handler */ static void -ExitHandler(ClientData cd) { - Tcl_Interp *in = (Tcl_Interp *) cd; - XOTclObject *obj; - XOTclClass *cl; - int result, flags, i; - Tcl_HashSearch hSrch; - Tcl_HashEntry *hPtr; - Tcl_HashTable objTable, *commandTable = &objTable; - XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; +ExitHandler(ClientData clientData) { + Tcl_Interp *interp = (Tcl_Interp *) clientData; + XOTclObject *obj; + XOTclClass *cl; + int result, flags, i; + Tcl_HashSearch hSrch; + Tcl_HashEntry *hPtr; + Tcl_HashTable objTable, *commandTable = &objTable; + XOTclCallStack *cs = &RUNTIME_STATE(interp)->cs; - /* - * Don't use exit handler, if the interpreted is destroyed already - * Call to exit handler comes after freeing namespaces, commands, etc. - * e.g. TK calls Tcl_DeleteInterp directly, if Window is killed - */ + /* + * Don't use exit handler, if the interpreted is destroyed already + * Call to exit handler comes after freeing namespaces, commands, etc. + * e.g. TK calls Tcl_DeleteInterp directly, if Window is killed + */ - /* - * Ahem ... - * - * Since we *must* be sure that our destroy methods will run - * we must *cheat* (I mean CHEAT) here: we flip the interp - * flag, saying, "hey boy, you're not deleted any more". - * After our handlers are done, we restore the old state... - * All this is needed so we can do an eval in the interp which - * is potentially marked for delete when we start working here. - * - * I know, I know, this is not really elegant. But... I'd need a - * standard way of invoking some code at interpreter delete time - * but JUST BEFORE the actual deletion process starts. Sadly, - * there is no such hook in Tcl as of Tcl8.3.2, that I know of. - * - * So, for the rest of procedure, assume the interp is alive ! - */ + /* + * Ahem ... + * + * Since we *must* be sure that our destroy methods will run + * we must *cheat* (I mean CHEAT) here: we flip the interp + * flag, saying, "hey boy, you're not deleted any more". + * After our handlers are done, we restore the old state... + * All this is needed so we can do an eval in the interp which + * is potentially marked for delete when we start working here. + * + * I know, I know, this is not really elegant. But... I'd need a + * standard way of invoking some code at interpreter delete time + * but JUST BEFORE the actual deletion process starts. Sadly, + * there is no such hook in Tcl as of Tcl8.3.2, that I know of. + * + * So, for the rest of procedure, assume the interp is alive ! + */ - /*fprintf(stderr,"+++ EXIT handler\n"); */ - flags = Tcl_Interp_flags(in); - Tcl_Interp_flags(in) &= ~DELETED; + /*fprintf(stderr,"+++ EXIT handler\n"); */ + flags = Tcl_Interp_flags(interp); + Tcl_Interp_flags(interp) &= ~DELETED; #if defined(PROFILE) - XOTclProfilePrintData(in); + XOTclProfilePrintData(interp); #endif - /* - * evaluate user-defined exit handler - */ - result = callMethod((ClientData)RUNTIME_STATE(in)->theObject, in, - XOTclGlobalObjects[XOTE_EXIT_HANDLER], 2, 0, 0); - if (result != TCL_OK) { - fprintf(stderr,"User defined exit handler contains errors!\n" - "Error in line %d: %s\nExecution interrupted.\n", - in->errorLine, ObjStr(Tcl_GetObjResult(in))); - } - /* - * Pop any callstack entry that is still alive (e.g. - * if "exit" is called and we were jumping out of the - * callframe - */ - while (cs->top > cs->content) - CallStackPop(in); + /* + * evaluate user-defined exit handler + */ + result = Tcl_Eval(interp, "::xotcl::__exitHandler"); + if (result != TCL_OK) { + fprintf(stderr,"User defined exit handler contains errors!\n" + "Error in line %d: %s\nExecution interrupted.\n", + interp->errorLine, ObjStr(Tcl_GetObjResult(interp))); + } + /* + * Pop any callstack entry that is still alive (e.g. + * if "exit" is called and we were jumping out of the + * callframe + */ + while (cs->top > cs->content) + CallStackPop(interp); - while (1) { - Tcl_CallFrame *f = Tcl_Interp_framePtr(in); - if (!f) break; - if (Tcl_CallFrame_level(f) == 0) break; - Tcl_PopCallFrame(in); - } + while (1) { + Tcl_CallFrame *f = Tcl_Interp_framePtr(interp); + if (!f) break; + if (Tcl_CallFrame_level(f) == 0) break; + Tcl_PopCallFrame(interp); + } - /* deleting in two rounds: - * (a) SOFT DESTROY: call all user-defined destroys - * (b) PHYSICAL DESTROY: delete the commands, user-defined - * destroys are not executed anymore - * - * this is to prevent user-defined destroys from overriding physical - * destroy during exit handler, but still ensure that all - * user-defined destroys are called. - */ + /* deleting in two rounds: + * (a) SOFT DESTROY: call all user-defined destroys + * (b) PHYSICAL DESTROY: delete the commands, user-defined + * destroys are not executed anymore + * + * this is to prevent user-defined destroys from overriding physical + * destroy during exit handler, but still ensure that all + * user-defined destroys are called. + */ - Tcl_InitHashTable(commandTable, TCL_STRING_KEYS); - MEM_COUNT_ALLOC("Tcl_InitHashTable",commandTable); - getAllInstances(commandTable, RUNTIME_STATE(in)->theClass); - /***** SOFT DESTROY *****/ - RUNTIME_STATE(in)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_SOFT_DESTROY; + Tcl_InitHashTable(commandTable, TCL_STRING_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable",commandTable); + getAllInstances(interp, commandTable, RUNTIME_STATE(interp)->theClass,0); - hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); - while (hPtr) { - char *key = Tcl_GetHashKey(commandTable, hPtr); - obj = XOTclpGetObject(in, key); - /* fprintf(stderr,"key = %s %p %d\n", - key, obj, obj && !XOTclObjectIsClass(obj)); */ - if (obj && !XOTclObjectIsClass(obj) - && !(obj->flags & XOTCL_DESTROY_CALLED)) - callDestroyMethod((ClientData)obj, in, obj, 0); - hPtr = Tcl_NextHashEntry(&hSrch); - } - hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); - while (hPtr) { - char *key = Tcl_GetHashKey(commandTable, hPtr); - cl = XOTclpGetClass(in, key); - if (cl - && !(cl->object.flags & XOTCL_DESTROY_CALLED)) - callDestroyMethod((ClientData)cl, in, (XOTclObject*)cl, 0); - hPtr = Tcl_NextHashEntry(&hSrch); - } + /***** SOFT DESTROY *****/ + RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_ON_SOFT_DESTROY; + + hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); + while (hPtr) { + char *key = Tcl_GetHashKey(commandTable, hPtr); + obj = XOTclpGetObject(interp, key); + /*fprintf(stderr,"key = %s %p %d\n", + key, obj, obj && !XOTclObjectIsClass(obj));*/ + if (obj && !XOTclObjectIsClass(obj) + && !(obj->flags & XOTCL_DESTROY_CALLED)) + callDestroyMethod((ClientData)obj, interp, obj, XOTCL_CM_NO_UNKNOWN); + hPtr = Tcl_NextHashEntry(&hSrch); + } + + hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); + while (hPtr) { + char *key = Tcl_GetHashKey(commandTable, hPtr); + cl = XOTclpGetClass(interp, key); + if (cl + && !(cl->object.flags & XOTCL_DESTROY_CALLED)) { + /*fprintf(stderr,"call destroy key = %s, cl = %p\n",key,cl);*/ + callDestroyMethod((ClientData)cl, interp, (XOTclObject*)cl, XOTCL_CM_NO_UNKNOWN); + } + hPtr = Tcl_NextHashEntry(&hSrch); + } + #ifdef DO_CLEANUP - freeAllXOTclObjectsAndClasses(in, commandTable); + freeAllXOTclObjectsAndClasses(interp, commandTable); #endif - /* must be before freeing of XOTclGlobalObjects */ - XOTclShadowTclCommands(in, SHADOW_UNLOAD); - /* free global objects */ - for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { - DECR_REF_COUNT(XOTclGlobalObjects[i]); - } - XOTclStringIncrFree(&RUNTIME_STATE(in)->iss); - FREE(Tcl_Obj**, XOTclGlobalObjects); - FREE(XOTclRuntimeState, RUNTIME_STATE(in)); + /* must be before freeing of XOTclGlobalObjects */ + XOTclShadowTclCommands(interp, SHADOW_UNLOAD); + /* free global objects */ + for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { + DECR_REF_COUNT(XOTclGlobalObjects[i]); + } + XOTclStringIncrFree(&RUNTIME_STATE(interp)->iss); + FREE(Tcl_Obj **, XOTclGlobalObjects); + FREE(XOTclRuntimeState, RUNTIME_STATE(interp)); - MEM_COUNT_FREE("Tcl_InitHashTable",commandTable); - Tcl_DeleteHashTable(commandTable); + MEM_COUNT_FREE("Tcl_InitHashTable",commandTable); + Tcl_DeleteHashTable(commandTable); #if defined(TCL_MEM_DEBUG) - TclDumpMemoryInfo (stderr); - Tcl_DumpActiveMemory ("./xotclActiveMem"); - /* Tcl_GlobalEval(in, "puts {checkmem to checkmemFile}; - checkmem checkmemFile"); */ + TclDumpMemoryInfo(stderr); + Tcl_DumpActiveMemory("./xotclActiveMem"); + /* Tcl_GlobalEval(interp, "puts {checkmem to checkmemFile}; + checkmem checkmemFile"); */ #endif - MEM_COUNT_DUMP(); + MEM_COUNT_DUMP(); - Tcl_Interp_flags(in) = flags; - Tcl_Release((ClientData) in); + Tcl_Interp_flags(interp) = flags; + Tcl_Release((ClientData) interp); } @@ -11993,438 +13406,480 @@ * Gets activated at thread-exit */ static void -XOTcl_ThreadExitProc(ClientData cd) { - /*fprintf(stderr,"+++ XOTcl_ThreadExitProc\n");*/ +XOTcl_ThreadExitProc(ClientData clientData) { + /*fprintf(stderr,"+++ XOTcl_ThreadExitProc\n");*/ #if !defined(PRE83) - void XOTcl_ExitProc(ClientData cd); - Tcl_DeleteExitHandler(XOTcl_ExitProc, cd); + void XOTcl_ExitProc(ClientData clientData); + Tcl_DeleteExitHandler(XOTcl_ExitProc, clientData); #endif - ExitHandler(cd); + ExitHandler(clientData); } #endif /* * Gets activated at application-exit */ void -XOTcl_ExitProc(ClientData cd) { - /*fprintf(stderr,"+++ XOTcl_ExitProc\n");*/ +XOTcl_ExitProc(ClientData clientData) { + /*fprintf(stderr,"+++ XOTcl_ExitProc\n");*/ #if !defined(PRE83) && defined(TCL_THREADS) - Tcl_DeleteThreadExitHandler(XOTcl_ThreadExitProc, cd); + Tcl_DeleteThreadExitHandler(XOTcl_ThreadExitProc, clientData); #endif - ExitHandler(cd); + ExitHandler(clientData); } /* * Registers thread/appl exit handlers. */ static void -RegisterExitHandlers(ClientData cd) { - Tcl_Preserve(cd); +RegisterExitHandlers(ClientData clientData) { + Tcl_Preserve(clientData); #if !defined(PRE83) && defined(TCL_THREADS) - Tcl_CreateThreadExitHandler(XOTcl_ThreadExitProc, cd); + Tcl_CreateThreadExitHandler(XOTcl_ThreadExitProc, clientData); #endif - Tcl_CreateExitHandler(XOTcl_ExitProc, cd); + Tcl_CreateExitHandler(XOTcl_ExitProc, clientData); } +int +XOTclCreateObjectSystem(Tcl_Interp *interp, char *Object, char *Class) { + XOTclClass *theobj = 0; + XOTclClass *thecls = 0; + + /* create Object and Class, and store them in the RUNTIME STATE */ + theobj = PrimitiveCCreate(interp, Object, 0); + RUNTIME_STATE(interp)->theObject = theobj; + if (!theobj) panic("Cannot create base Object class",0); + thecls = PrimitiveCCreate(interp, Class, 0); + RUNTIME_STATE(interp)->theClass = thecls; + if (!thecls) panic("Cannot create base Class",0); + /*theobj->parent = 0; + thecls->parent = theobj;*/ + + /*Tcl_AddInterpResolvers(interp, "XOTcl", XOTclResolveCmd, 0, 0);*/ + +#if defined(PROFILE) + XOTclProfileInit(interp); +#endif + + /* test Object and Class creation */ + if (!theobj || !thecls) { + int i; + RUNTIME_STATE(interp)->callDestroy = 0; + + if (thecls) PrimitiveCDestroy((ClientData) thecls); + if (theobj) PrimitiveCDestroy((ClientData) theobj); + + for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { + DECR_REF_COUNT(XOTclGlobalObjects[i]); + } + FREE(Tcl_Obj **, XOTclGlobalObjects); + FREE(XOTclRuntimeState, RUNTIME_STATE(interp)); + + return XOTclErrMsg(interp, "Object/Class failed", TCL_STATIC); + } + + AddInstance((XOTclObject*)theobj, thecls); + AddInstance((XOTclObject*)thecls, thecls); + AddSuper(thecls, theobj); + + return TCL_OK; +} + + + /* * Tcl extension initialization routine */ extern int -Xotcl_Init(Tcl_Interp *in) { - XOTclClass *theobj = 0; - XOTclClass *thecls = 0; - XOTclClass *paramCl = 0; - XOTclClass *nonposArgsCl = 0; - ClientData runtimeState; - int result, i; +Xotcl_Init(Tcl_Interp *interp) { + ClientData runtimeState; + int result, i; #ifdef XOTCL_BYTECODE - XOTclCompEnv *instructions = XOTclGetCompEnv(); + XOTclCompEnv *interpstructions = XOTclGetCompEnv(); #endif #ifndef PRE81 # ifdef USE_TCL_STUBS - if (Tcl_InitStubs(in, "8.1", 0) == NULL) { - return TCL_ERROR; - } + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + return TCL_ERROR; + } # endif #endif #if defined(TCL_MEM_DEBUG) - TclDumpMemoryInfo(stderr); + TclDumpMemoryInfo(stderr); #endif - MEM_COUNT_INIT(); + MEM_COUNT_INIT(); - /* - fprintf(stderr, "SIZES: obj=%d, tcl_obj=%d, DString=%d, class=%d, namespace=%d, command=%d, HashTable=%d\n", sizeof(XOTclObject), sizeof(Tcl_Obj), sizeof(Tcl_DString), sizeof(XOTclClass), sizeof(Namespace), sizeof(Command), sizeof(Tcl_HashTable)); - */ - + /* + fprintf(stderr, "SIZES: obj=%d, tcl_obj=%d, DString=%d, class=%d, namespace=%d, command=%d, HashTable=%d\n", sizeof(XOTclObject), sizeof(Tcl_Obj), sizeof(Tcl_DString), sizeof(XOTclClass), sizeof(Namespace), sizeof(Command), sizeof(Tcl_HashTable)); + */ #if FORWARD_COMPATIBLE - { + { int major, minor, patchlvl, type; Tcl_GetVersion(&major, &minor, &patchlvl, &type); - + if ((major == 8) && (minor < 5)) { - /* - * loading a version of xotcl compiled for 8.4 version - * into a 8.4 Tcl - */ - /* - fprintf(stderr, "loading a version of xotcl compiled for 8.4 version into a 8.4 Tcl\n"); - */ - forwardCompatibleMode = 0; - lookupVarFromTable = LookupVarFromTable84; - tclVarHashCreateVar = VarHashCreateVar84; - tclInitVarHashTable = InitVarHashTable84; - tclCleanupVar = TclCleanupVar84; - varRefCountOffset = TclOffset(Var, refCount); - varHashTableSize = sizeof(Tcl_HashTable); + /* + * loading a version of xotcl compiled for 8.4 version + * into a 8.4 Tcl + */ + fprintf(stderr, "loading a version of xotcl compiled for 8.4 version into a 8.4 Tcl\n"); + forwardCompatibleMode = 0; + lookupVarFromTable = LookupVarFromTable84; + tclVarHashCreateVar = VarHashCreateVar84; + tclInitVarHashTable = InitVarHashTable84; + tclCleanupVar = TclCleanupVar84; + varRefCountOffset = TclOffset(Var, refCount); + varHashTableSize = sizeof(Tcl_HashTable); } else { - /* - * loading a version of xotcl compiled for 8.4 version - * into a 8.5 Tcl - */ - /* - fprintf(stderr, "loading a version of xotcl compiled for 8.4 version into a 8.5 Tcl\n"); - */ - forwardCompatibleMode = 1; - lookupVarFromTable = LookupVarFromTable85; - tclVarHashCreateVar = VarHashCreateVar85; - tclInitVarHashTable = (Tcl_InitVarHashTableFunction*)*((&tclIntStubsPtr->reserved0)+235); - tclCleanupVar = (Tcl_CleanupVarFunction*)*((&tclIntStubsPtr->reserved0)+176); - varRefCountOffset = TclOffset(VarInHash, refCount); - varHashTableSize = sizeof(TclVarHashTable85); + /* + * loading a version of xotcl compiled for 8.4 version + * into a 8.5 Tcl + */ + fprintf(stderr, "loading a version of xotcl compiled for 8.4 version into a 8.5 Tcl\n"); + forwardCompatibleMode = 1; + lookupVarFromTable = LookupVarFromTable85; + tclVarHashCreateVar = VarHashCreateVar85; + tclInitVarHashTable = (Tcl_InitVarHashTableFunction*)*((&tclIntStubsPtr->reserved0)+235); + tclCleanupVar = (Tcl_CleanupVarFunction*)*((&tclIntStubsPtr->reserved0)+176); + varRefCountOffset = TclOffset(VarInHash, refCount); + varHashTableSize = sizeof(TclVarHashTable85); } - - } + + } #endif - - /* - * Runtime State stored in the client data of the Interp's global - * Namespace in order to avoid global state information - */ - runtimeState = (ClientData) NEW(XOTclRuntimeState); + /* + * Runtime State stored in the client data of the Interp's global + * Namespace in order to avoid global state information + */ + runtimeState = (ClientData) NEW(XOTclRuntimeState); #if USE_ASSOC_DATA - Tcl_SetAssocData(in, "XOTclRuntimeState", NULL, runtimeState); + Tcl_SetAssocData(interp, "XOTclRuntimeState", NULL, runtimeState); #else - Tcl_Interp_globalNsPtr(in)->clientData = runtimeState; + Tcl_Interp_globalNsPtr(interp)->clientData = runtimeState; #endif - /* CallStack initialization */ - memset(RUNTIME_STATE(in), 0, sizeof(XOTclRuntimeState)); - memset(RUNTIME_STATE(in)->cs.content, 0, sizeof(XOTclCallStackContent)); + /* CallStack initialization */ + memset(RUNTIME_STATE(interp), 0, sizeof(XOTclRuntimeState)); + memset(RUNTIME_STATE(interp)->cs.content, 0, sizeof(XOTclCallStackContent)); - RUNTIME_STATE(in)->cs.top = RUNTIME_STATE(in)->cs.content; - RUNTIME_STATE(in)->doFilters = 1; - RUNTIME_STATE(in)->callDestroy = 1; + RUNTIME_STATE(interp)->cs.top = RUNTIME_STATE(interp)->cs.content; + RUNTIME_STATE(interp)->doFilters = 1; + RUNTIME_STATE(interp)->callDestroy = 1; - /* create xotcl namespace */ - RUNTIME_STATE(in)->XOTclNS = - Tcl_CreateNamespace(in, "::xotcl", (ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL); + /* create xotcl namespace */ + RUNTIME_STATE(interp)->XOTclNS = + Tcl_CreateNamespace(interp, "::xotcl", (ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL); - MEM_COUNT_ALLOC("TclNamespace",RUNTIME_STATE(in)->XOTclNS); + MEM_COUNT_ALLOC("TclNamespace",RUNTIME_STATE(interp)->XOTclNS); - /* - * init an empty, faked proc structure in the RUNTIME state - */ - RUNTIME_STATE(in)->fakeProc.iPtr = (Interp *)in; - RUNTIME_STATE(in)->fakeProc.refCount = 1; - RUNTIME_STATE(in)->fakeProc.cmdPtr = NULL; - RUNTIME_STATE(in)->fakeProc.bodyPtr = NULL; - RUNTIME_STATE(in)->fakeProc.numArgs = 0; - RUNTIME_STATE(in)->fakeProc.numCompiledLocals = 0; - RUNTIME_STATE(in)->fakeProc.firstLocalPtr = NULL; - RUNTIME_STATE(in)->fakeProc.lastLocalPtr = NULL; - RUNTIME_STATE(in)->fakeNS = - Tcl_CreateNamespace(in, "::xotcl::fakeNS", (ClientData)NULL, - (Tcl_NamespaceDeleteProc*)NULL); - MEM_COUNT_ALLOC("TclNamespace",RUNTIME_STATE(in)->fakeNS); + /* + * init an empty, faked proc structure in the RUNTIME state + */ + RUNTIME_STATE(interp)->fakeProc.iPtr = (Interp *)interp; + RUNTIME_STATE(interp)->fakeProc.refCount = 1; + RUNTIME_STATE(interp)->fakeProc.cmdPtr = NULL; + RUNTIME_STATE(interp)->fakeProc.bodyPtr = NULL; + RUNTIME_STATE(interp)->fakeProc.numArgs = 0; + RUNTIME_STATE(interp)->fakeProc.numCompiledLocals = 0; + RUNTIME_STATE(interp)->fakeProc.firstLocalPtr = NULL; + RUNTIME_STATE(interp)->fakeProc.lastLocalPtr = NULL; + RUNTIME_STATE(interp)->fakeNS = + Tcl_CreateNamespace(interp, "::xotcl::fakeNS", (ClientData)NULL, + (Tcl_NamespaceDeleteProc *)NULL); + MEM_COUNT_ALLOC("TclNamespace",RUNTIME_STATE(interp)->fakeNS); - /* XOTclClasses in separate Namespace / Objects */ - RUNTIME_STATE(in)->XOTclClassesNS = - Tcl_CreateNamespace(in, "::xotcl::classes", (ClientData)NULL, - (Tcl_NamespaceDeleteProc*)NULL); - MEM_COUNT_ALLOC("TclNamespace",RUNTIME_STATE(in)->XOTclClassesNS); + /* XOTclClasses in separate Namespace / Objects */ + RUNTIME_STATE(interp)->XOTclClassesNS = + Tcl_CreateNamespace(interp, "::xotcl::classes", (ClientData)NULL, + (Tcl_NamespaceDeleteProc *)NULL); + MEM_COUNT_ALLOC("TclNamespace",RUNTIME_STATE(interp)->XOTclClassesNS); - /* cache interpreters proc interpretation functions */ - RUNTIME_STATE(in)->objInterpProc = TclGetObjInterpProc(); + /* cache interpreters proc interpretation functions */ + RUNTIME_STATE(interp)->objInterpProc = TclGetObjInterpProc(); #if USE_INTERP_PROC - RUNTIME_STATE(in)->interpProc = TclGetInterpProc(); + RUNTIME_STATE(interp)->interpProc = TclGetInterpProc(); #endif - RUNTIME_STATE(in)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_OFF; + RUNTIME_STATE(interp)->exitHandlerDestroyRound = XOTCL_EXITHANDLER_OFF; - RegisterObjTypes(); - RegisterExitHandlers((ClientData)in); + RegisterObjTypes(); + RegisterExitHandlers((ClientData)interp); - XOTclStringIncrInit(&RUNTIME_STATE(in)->iss); + XOTclStringIncrInit(&RUNTIME_STATE(interp)->iss); - /* initialize global Tcl_Obj*/ - XOTclGlobalObjects = NEW_ARRAY(Tcl_Obj*,nr_elements(XOTclGlobalStrings)); + /* initialize global Tcl_Obj */ + XOTclGlobalObjects = NEW_ARRAY(Tcl_Obj *,nr_elements(XOTclGlobalStrings)); - for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { - XOTclGlobalObjects[i] = Tcl_NewStringObj(XOTclGlobalStrings[i],-1); - INCR_REF_COUNT(XOTclGlobalObjects[i]); - } + for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { + XOTclGlobalObjects[i] = Tcl_NewStringObj(XOTclGlobalStrings[i],-1); + INCR_REF_COUNT(XOTclGlobalObjects[i]); + } +#if defined(OO) + Tcl_CreateNamespace(interp, "::oo", (ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL); + XOTclCreateObjectSystem(interp, "::oo::object", "::oo::class"); +#else + XOTclCreateObjectSystem(interp, "::xotcl::Object", "::xotcl::Class"); +#endif - /* create Object and Class, and store them in the RUNTIME STATE */ - theobj = PrimitiveCCreate(in, "::xotcl::Object", 0); - RUNTIME_STATE(in)->theObject = theobj; - if (!theobj) panic("Cannot create ::xotcl::Object",0); + { + typedef struct methodDefinition { + char *methodName; + Tcl_ObjCmdProc *proc; + } methodDefinition; - thecls = PrimitiveCCreate(in, "::xotcl::Class", 0); - RUNTIME_STATE(in)->theClass = thecls; - if (!thecls) panic("Cannot create ::xotcl::Class",0); + char *namespace_names[] = { + "::xotcl::cmd::Object", + "::xotcl::cmd::Class", + "::xotcl::cmd::NonposArgs", + "::xotcl::cmd::ObjectInfo", + "::xotcl::cmd::ClassInfo" + }; - theobj->parent = 0; - thecls->parent = theobj; - - Tcl_Export(in, RUNTIME_STATE(in)->XOTclNS, "Object", 0); - Tcl_Export(in, RUNTIME_STATE(in)->XOTclNS, "Class", 0); - /*Tcl_AddInterpResolvers(in, "XOTcl", XOTclResolveCmd, 0, 0);*/ - -#if defined(PROFILE) - XOTclProfileInit(in); + methodDefinition definitions1[] = { + {"autoname", XOTclOAutonameMethod}, + {"check", XOTclOCheckMethod}, + {"cleanup", XOTclOCleanupMethod}, + {"configure", XOTclOConfigureMethod}, + {"destroy", XOTclODestroyMethod}, + {"exists", XOTclOExistsMethod}, + {"filterguard", XOTclOFilterGuardMethod}, + {"filtersearch", XOTclOFilterSearchMethod}, + {"info", XOTclOInfoMethod}, + {"instvar", XOTclOInstVarMethod}, + {"invar", XOTclOInvariantsMethod}, + {"isclass", XOTclOIsClassMethod}, + {"ismetaclass", XOTclOIsMetaClassMethod}, + {"isobject", XOTclOIsObjectMethod}, + {"istype", XOTclOIsTypeMethod}, + {"ismixin", XOTclOIsMixinMethod}, +#ifdef XOTCL_METADATA + {"metadata", XOTclOMetaDataMethod}, #endif + {"mixinguard", XOTclOMixinGuardMethod}, + {"__next", XOTclONextMethod}, + /* {"next", XOTclONextMethod2},*/ + {"noinit", XOTclONoinitMethod}, + {"parametercmd", XOTclCParameterCmdMethod}, + {"proc", XOTclOProcMethod}, + {"procsearch", XOTclOProcSearchMethod}, + {"requireNamespace", XOTclORequireNamespaceMethod}, + {"set", XOTclOSetMethod}, /***??**/ + {"setvalues", XOTclOSetvaluesMethod}, + {"forward", XOTclOForwardMethod}, + {"uplevel", XOTclOUplevelMethod}, + {"upvar", XOTclOUpvarMethod}, + {"volatile", XOTclOVolatileMethod}, + {"vwait", XOTclOVwaitMethod} + }; + methodDefinition definitions2[] = { + {"alloc", XOTclCAllocMethod}, + {"create", XOTclCCreateMethod}, + {"dealloc", XOTclCInstDestroyMethod}, + {"new", XOTclCNewMethod}, + {"info", XOTclCInfoMethod}, + {"instdestroy", XOTclCInstDestroyMethod}, + {"instfilterguard", XOTclCInstFilterGuardMethod}, + {"instinvar", XOTclCInvariantsMethod}, + {"instmixinguard", XOTclCInstMixinGuardMethod}, + {"instparametercmd", XOTclCInstParameterCmdMethod}, + {"instproc", XOTclCInstProcMethod}, + {"classscopedinstproc", XOTclCInstProcMethodC}, + {"instforward", XOTclCInstForwardMethod}, + {"recreate", XOTclCRecreateMethod}, + {"unknown", XOTclCUnknownMethod} + }; + methodDefinition definitions3[] = { + {"type=required", XOTclCheckRequiredArgs}, + {"type=switch", XOTclCheckBooleanArgs}, + {"type=boolean", XOTclCheckBooleanArgs} + }; - /* test Object and Class creation */ - if (!theobj || !thecls) { - RUNTIME_STATE(in)->callDestroy = 0; + methodDefinition definitions4[] = { + {"args", XOTclObjInfoArgsMethod}, + {"body", XOTclObjInfoBodyMethod}, + {"class", XOTclObjInfoClassMethod}, + {"commands", XOTclObjInfoCommandsMethod}, + {"children", XOTclObjInfoChildrenMethod}, + {"check", XOTclObjInfoCheckMethod}, + {"default", XOTclObjInfoDefaultMethod}, + {"filter", XOTclObjInfoFilterMethod}, + {"filterguard", XOTclObjInfoFilterguardMethod}, + {"forward", XOTclObjInfoForwardMethod}, + {"hasNamespace", XOTclObjInfoHasnamespaceMethod}, + /*{"info", XOTclObjInfoInfoMethod},*/ + {"invar", XOTclObjInfoInvarMethod}, + {"methods", XOTclObjInfoMethodsMethod}, + {"mixin", XOTclObjInfoMixinMethod}, + {"mixinguard", XOTclObjInfoMixinguardMethod}, + {"methods", XOTclObjInfoMethodsMethod}, + {"nonposargs", XOTclObjInfoNonposargsMethod}, + {"parent", XOTclObjInfoParentMethod}, + {"post", XOTclObjInfoPostMethod}, + {"pre", XOTclObjInfoPreMethod}, + {"procs", XOTclObjInfoProcsMethod}, + {"precedence", XOTclObjInfoPrecedenceMethod}, + {"slotobjects", XOTclObjInfoSlotObjectsMethod}, + {"vars", XOTclObjInfoVarsMethod} + }; - if (thecls) PrimitiveCDestroy((ClientData) thecls); - if (theobj) PrimitiveCDestroy((ClientData) theobj); + methodDefinition definitions5[] = { + {"heritage", XOTclClassInfoHeritageMethod}, + {"instances", XOTclClassInfoInstancesMethod}, + {"instargs", XOTclClassInfoInstargsMethod}, + {"instbody", XOTclClassInfoInstbodyMethod}, + {"instcommands", XOTclClassInfoInstcommandsMethod}, + {"instdefault", XOTclClassInfoInstdefaultMethod}, + {"instfilter", XOTclClassInfoInstfilterMethod}, + {"instfilterguard", XOTclClassInfoInstfilterguardMethod}, + {"instforward", XOTclClassInfoInstforwardMethod}, + {"instinvar", XOTclClassInfoInstinvarMethod}, + {"instmixin", XOTclClassInfoInstmixinMethod}, + {"instmixinguard", XOTclClassInfoInstmixinguardMethod}, + {"instprocs", XOTclClassInfoInstprocsMethod}, + {"instnonposargs", XOTclClassInfoInstnonposargsMethod}, + {"instpre", XOTclClassInfoInstpreMethod}, + {"instpost", XOTclClassInfoInstpostMethod}, + {"parameter", XOTclClassInfoParameterMethod}, + {"subclass", XOTclClassInfoSubclassMethod}, + {"superclass", XOTclClassInfoSuperclassMethod}, + {"slots", XOTclClassInfoSlotsMethod} + }; - for (i = 0; i < nr_elements(XOTclGlobalStrings); i++) { - DECR_REF_COUNT(XOTclGlobalObjects[i]); - } - FREE(Tcl_Obj**, XOTclGlobalObjects); - FREE(XOTclRuntimeState, RUNTIME_STATE(in)); + methodDefinition *definitions[] = {definitions1, definitions2, definitions3, + definitions4, definitions5}; + int nr_definitions[] = {nr_elements(definitions1), nr_elements(definitions2), + nr_elements(definitions3), nr_elements(definitions4), + nr_elements(definitions5)}; - return XOTclErrMsg(in, "Object/Class failed", TCL_STATIC); - } + int namespacelength; + Tcl_DString ds, *dsPtr = &ds; - AddInstance((XOTclObject*)theobj, thecls); - AddInstance((XOTclObject*)thecls, thecls); - AddSuper(thecls, theobj); - { - typedef struct methodDefinition { - char *methodName; - Tcl_ObjCmdProc *proc; - } methodDefinition; - methodDefinition objInstcmds[] = { - {"autoname", XOTclOAutonameMethod}, - {"check", XOTclOCheckMethod}, - {"cleanup", XOTclOCleanupMethod}, - {"configure", XOTclOConfigureMethod}, - {"destroy", XOTclODestroyMethod}, - {"exists", XOTclOExistsMethod}, - {"filterguard", XOTclOFilterGuardMethod}, - {"filtersearch", XOTclOFilterSearchMethod}, - {"info", XOTclOInfoMethod}, - {"instvar", XOTclOInstVarMethod}, - {"invar", XOTclOInvariantsMethod}, - {"isclass", XOTclOIsClassMethod}, - {"ismetaclass", XOTclOIsMetaClassMethod}, - {"isobject", XOTclOIsObjectMethod}, - {"istype", XOTclOIsTypeMethod}, - {"ismixin", XOTclOIsMixinMethod}, -#ifdef XOTCL_METADATA - {"metadata", XOTclOMetaDataMethod}, -#endif - {"mixinguard", XOTclOMixinGuardMethod}, - {"__next", XOTclONextMethod}, - /* {"next", XOTclONextMethod2},*/ - {"noinit", XOTclONoinitMethod}, - {"parametercmd", XOTclCParameterCmdMethod}, - { "proc", XOTclOProcMethod}, - {"procsearch", XOTclOProcSearchMethod}, - {"requireNamespace", XOTclORequireNamespaceMethod}, - {"set", XOTclOSetMethod}, /***??**/ - {"forward", XOTclOForwardMethod}, - {"uplevel", XOTclOUplevelMethod}, - {"upvar", XOTclOUpvarMethod}, - {"volatile", XOTclOVolatileMethod}, - {"vwait", XOTclOVwaitMethod} - }; - methodDefinition classInstcmds[] = { - {"autoname", XOTclOAutonameMethod}, - {"alloc", XOTclCAllocMethod}, - {"create", XOTclCCreateMethod}, - {"new", XOTclCNewMethod}, - {"info", XOTclCInfoMethod}, - {"instdestroy", XOTclCInstDestroyMethod}, - {"instfilterguard", XOTclCInstFilterGuardMethod}, - {"instinvar", XOTclCInvariantsMethod}, - {"instmixinguard", XOTclCInstMixinGuardMethod}, - {"instparametercmd", XOTclCInstParameterCmdMethod}, - {"instproc", XOTclCInstProcMethod}, - {"instforward", XOTclCInstForwardMethod}, - {"parameter", XOTclCParameterMethod}, - {"parameterclass", XOTclCParameterClassMethod}, - {"recreate", XOTclCRecreateMethod}, - {"unknown", XOTclCUnknownMethod} - }; + Tcl_CreateNamespace(interp, "::xotcl::cmd", 0, (Tcl_NamespaceDeleteProc*)NULL); - int namespacelength; - Tcl_DString ds, *dsPtr = &ds; + DSTRING_INIT(dsPtr); + for (i=0; i < nr_elements(namespace_names); i++) { + int j; + Tcl_DStringAppend(dsPtr, namespace_names[i], -1); + /*fprintf(stderr,"namespace '%s'\n",namespace_names[i]);*/ + Tcl_CreateNamespace(interp, Tcl_DStringValue(dsPtr), 0, (Tcl_NamespaceDeleteProc*)NULL); + Tcl_DStringAppend(dsPtr,"::", 2); + namespacelength = Tcl_DStringLength(dsPtr); + for (j = 0; j < nr_definitions[i]; j++) { + Tcl_DStringAppend(dsPtr, definitions[i][j].methodName, -1); + /*fprintf(stderr,"defining '%s' (%d of %d)\n", Tcl_DStringValue(dsPtr), j, nr_definitions[i]);*/ + Tcl_CreateObjCommand(interp, Tcl_DStringValue(dsPtr), definitions[i][j].proc, 0, 0); + Tcl_DStringSetLength(dsPtr, namespacelength); + } + Tcl_DStringSetLength(dsPtr, 0); + } - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr,"::xotcl::Object::instcmd", -1); - Tcl_CreateNamespace(in, Tcl_DStringValue(dsPtr), 0, (Tcl_NamespaceDeleteProc*)NULL); - Tcl_DStringAppend(dsPtr,"::", 2); - namespacelength = Tcl_DStringLength(dsPtr); - - for (i = 0; i < nr_elements(objInstcmds); i++) { - Tcl_DStringAppend(dsPtr, objInstcmds[i].methodName, -1); - Tcl_CreateObjCommand(in, Tcl_DStringValue(dsPtr), objInstcmds[i].proc, 0, 0); - Tcl_DStringSetLength(dsPtr, namespacelength); + DSTRING_FREE(dsPtr); } - Tcl_DStringSetLength(dsPtr, 0); - Tcl_DStringAppend(dsPtr,"::xotcl::Class::instcmd", -1); - Tcl_CreateNamespace(in, Tcl_DStringValue(dsPtr), 0, (Tcl_NamespaceDeleteProc*)NULL); - Tcl_DStringAppend(dsPtr,"::", 2); - namespacelength = Tcl_DStringLength(dsPtr); - for (i = 0; i < nr_elements(classInstcmds); i++) { - Tcl_DStringAppend(dsPtr, classInstcmds[i].methodName, -1); - Tcl_CreateObjCommand(in, Tcl_DStringValue(dsPtr), classInstcmds[i].proc, 0, 0); - Tcl_DStringSetLength(dsPtr, namespacelength); - } + /* + * overwritten tcl objs + */ + result = XOTclShadowTclCommands(interp, SHADOW_LOAD); + if (result != TCL_OK) + return result; - DSTRING_FREE(dsPtr); - } - - /* - * overwritten tcl objs - */ - result = XOTclShadowTclCommands(in, SHADOW_LOAD); - if (result != TCL_OK) - return result; - - /* - * new tcl cmds - */ + /* + * new tcl cmds + */ #ifdef XOTCL_BYTECODE - instructions[INST_SELF_DISPATCH].cmdPtr = (Command *) + instructions[INST_SELF_DISPATCH].cmdPtr = (Command *) #endif - Tcl_CreateObjCommand(in, "::xotcl::my", XOTclSelfDispatchCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::my", XOTclSelfDispatchCmd, 0, 0); #ifdef XOTCL_BYTECODE - instructions[INST_NEXT].cmdPtr = (Command *) + instructions[INST_NEXT].cmdPtr = (Command *) #endif - Tcl_CreateObjCommand(in, "::xotcl::next", XOTclNextObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::next", XOTclNextObjCmd, 0, 0); #ifdef XOTCL_BYTECODE - instructions[INST_SELF].cmdPtr = (Command *) + instructions[INST_SELF].cmdPtr = (Command *) #endif - Tcl_CreateObjCommand(in, "::xotcl::self", XOTclGetSelfObjCmd, 0, 0); - /*Tcl_CreateObjCommand(in, "::xotcl::K", XOTclKObjCmd, 0, 0);*/ + Tcl_CreateObjCommand(interp, "::xotcl::self", XOTclGetSelfObjCmd, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::alias", XOTclAliasCommand, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::configure", XOTclConfigureCommand, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::deprecated", XOTcl_DeprecatedCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::alias", XOTclAliasCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::dispatch", XOTclDispatchCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::methodproperty", XOTclMethodPropertyCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::configure", XOTclConfigureCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::deprecated", XOTcl_DeprecatedCmd, 0, 0); #ifdef XOTCL_BYTECODE - instructions[INST_INITPROC].cmdPtr = (Command *) + instructions[INST_INITPROC].cmdPtr = (Command *) #endif - Tcl_CreateObjCommand(in, "::xotcl::initProcNS", XOTclInitProcNSCmd, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::interpretNonpositionalArgs", - XOTclInterpretNonpositionalArgsCmd, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::interp", XOTcl_InterpObjCmd, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::namespace_copyvars", XOTcl_NSCopyVars, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::namespace_copycmds", XOTcl_NSCopyCmds, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::__qualify", XOTclQualifyObjCmd, 0,0); - Tcl_CreateObjCommand(in, "::xotcl::setinstvar", XOTclSetInstvarCommand, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::setrelation", XOTclSetRelationCommand, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::trace", XOTcl_TraceObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::initProcNS", XOTclInitProcNSCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::interpretNonpositionalArgs", + XOTclInterpretNonpositionalArgsCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::interp", XOTcl_InterpObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::namespace_copyvars", XOTcl_NSCopyVars, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::namespace_copycmds", XOTcl_NSCopyCmds, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::__qualify", XOTclQualifyObjCmd, 0,0); + Tcl_CreateObjCommand(interp, "::xotcl::relation", XOTclRelationCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::setinstvar", XOTclSetInstvarCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::trace", XOTcl_TraceObjCmd, 0, 0); + Tcl_CreateObjCommand(interp, "::xotcl::is", XOTclIsCmd, 0, 0); - Tcl_Export(in, RUNTIME_STATE(in)->XOTclNS, "self", 0); - Tcl_Export(in, RUNTIME_STATE(in)->XOTclNS, "next", 0); - Tcl_Export(in, RUNTIME_STATE(in)->XOTclNS, "my", 0); + Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "self", 0); + Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "next", 0); + Tcl_Export(interp, RUNTIME_STATE(interp)->XOTclNS, "my", 0); #ifdef XOTCL_BYTECODE - XOTclBytecodeInit(); + XOTclBytecodeInit(); #endif - /* - * Non-Positional Args Object - */ + /* + * set runtime version information in Tcl variable + */ + Tcl_SetVar(interp, "::xotcl::version", XOTCLVERSION, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "::xotcl::patchlevel", XOTCLPATCHLEVEL, TCL_GLOBAL_ONLY); - nonposArgsCl = PrimitiveCCreate(in, - XOTclGlobalStrings[XOTE_NON_POS_ARGS_CL], - thecls); - XOTclAddIMethod(in, (XOTcl_Class*) nonposArgsCl, - "required", - (Tcl_ObjCmdProc*) XOTclCheckRequiredArgs, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) nonposArgsCl, - "switch", - (Tcl_ObjCmdProc*) XOTclCheckBooleanArgs, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) nonposArgsCl, - "boolean", - (Tcl_ObjCmdProc*) XOTclCheckBooleanArgs, 0, 0); - PrimitiveOCreate(in, XOTclGlobalStrings[XOTE_NON_POS_ARGS_OBJ], - nonposArgsCl); + /* + * with some methods and library procs in tcl - they could go in a + * xotcl.tcl file, but they're embedded here with Tcl_GlobalEval + * to avoid the need to carry around a separate file at runtime. + */ + { - /* - * Parameter Class - */ - { - XOTclObject *paramObject; - paramCl = PrimitiveCCreate(in, XOTclGlobalStrings[XOTE_PARAM_CL], thecls); - paramObject = ¶mCl->object; - XOTclAddPMethod(in, (XOTcl_Object*) paramObject, - XOTclGlobalStrings[XOTE_SEARCH_DEFAULTS], - (Tcl_ObjCmdProc*) ParameterSearchDefaultsMethod, 0, 0); - } - - /* - * set runtime version information in Tcl variable - */ - Tcl_SetVar(in, "::xotcl::version", XOTCLVERSION, TCL_GLOBAL_ONLY); - Tcl_SetVar(in, "::xotcl::patchlevel", XOTCLPATCHLEVEL, TCL_GLOBAL_ONLY); - - /* - * with some methods and library procs in tcl - they could go in a - * xotcl.tcl file, but they're embedded here with Tcl_GlobalEval - * to avoid the need to carry around a separate file at runtime. - */ - { - #include "predefined.h" - /* fprintf(stderr, "predefined=<<%s>>\n",cmd);*/ - if (Tcl_GlobalEval(in, cmd) != TCL_OK) - return TCL_ERROR; - } + /* fprintf(stderr, "predefined=<<%s>>\n",cmd);*/ + if (Tcl_GlobalEval(interp, cmd) != TCL_OK) + return TCL_ERROR; + } #ifndef AOL_SERVER - /* the AOL server uses a different package loading mechanism */ + /* the AOL server uses a different package loading mechanism */ # ifdef COMPILE_XOTCL_STUBS - Tcl_PkgProvideEx(in, "XOTcl", PACKAGE_VERSION, (ClientData) &xotclStubs); + Tcl_PkgProvideEx(interp, "XOTcl", PACKAGE_VERSION, (ClientData) &xotclStubs); # else - Tcl_PkgProvide(in, "XOTcl", PACKAGE_VERSION); + Tcl_PkgProvide(interp, "XOTcl", PACKAGE_VERSION); # endif #endif #if !defined(TCL_THREADS) && !defined(PRE81) - if ((Tcl_GetVar2(in, "tcl_platform", "threaded", TCL_GLOBAL_ONLY) != NULL)) { - /* a non threaded XOTcl version is loaded into a threaded environment */ - fprintf(stderr, "\n A non threaded XOTCL version is loaded into threaded environment\n Please reconfigure XOTcl with --enable-threads!\n\n\n"); - } + if ((Tcl_GetVar2(interp, "tcl_platform", "threaded", TCL_GLOBAL_ONLY) != NULL)) { + /* a non threaded XOTcl version is loaded into a threaded environment */ + fprintf(stderr, "\n A non threaded XOTCL version is loaded into threaded environment\n Please reconfigure XOTcl with --enable-threads!\n\n\n"); + } #endif - Tcl_ResetResult(in); - Tcl_SetIntObj(Tcl_GetObjResult(in), 1); + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - return TCL_OK; + return TCL_OK; } extern int Xotcl_SafeInit(Tcl_Interp *interp) { - /*** dummy for now **/ - return Xotcl_Init(interp); + /*** dummy for now **/ + return Xotcl_Init(interp); }