Index: xotcl/generic/xotcl.c =================================================================== diff -u -r2846921e448d4d4aeb3245ebbfe4381182f0e286 -r1aa7246cc8e44078c9dbd33e03992478615f314f --- xotcl/generic/xotcl.c (.../xotcl.c) (revision 2846921e448d4d4aeb3245ebbfe4381182f0e286) +++ xotcl/generic/xotcl.c (.../xotcl.c) (revision 1aa7246cc8e44078c9dbd33e03992478615f314f) @@ -1,11 +1,11 @@ -/* $Id: xotcl.c,v 1.41 2006/09/25 08:29:04 neumann Exp $ +/* $Id: xotcl.c,v 1.42 2006/09/27 08:12:40 neumann Exp $ * * XOTcl - Extended OTcl * * Copyright (C) 1999-2006 Gustaf Neumann (a), Uwe Zdun (a) * * (a) Vienna University of Economics and Business Administration - * Dept. of Information Systems / New Media + * Institute. of Information Systems and New Media * A-1090, Augasse 2-6 * Vienna, Austria * @@ -65,15 +65,11 @@ #ifdef USE_TCL_STUBS # define XOTcl_ExprObjCmd(cd,in,objc,objv) \ XOTclCallCommand(in, XOTE_EXPR, objc, objv) -# define XOTcl_IncrObjCmd(cd,in,objc,objv) \ - XOTclCallCommand(in, XOTE_INCR, objc, objv) # define XOTcl_SubstObjCmd(cd,in,objc,objv) \ XOTclCallCommand(in, XOTE_SUBST, objc, objv) #else # define XOTcl_ExprObjCmd(cd,in,objc,objv) \ Tcl_ExprObjCmd(cd, in, objc, objv) -# define XOTcl_IncrObjCmd(cd,in,objc,objv) \ - Tcl_IncrObjCmd(cd, in, objc, objv) # define XOTcl_SubstObjCmd(cd,in,objc,objv) \ Tcl_SubstObjCmd(cd, in, objc, objv) #endif @@ -104,7 +100,6 @@ SetXOTclObjectFromAny }; - typedef enum { CALLING_LEVEL, ACTIVE_LEVEL } CallStackLevel; typedef struct callFrameContext { @@ -119,13 +114,24 @@ 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; } forwardCmdClientData; +typedef struct aliasCmdClientData { + XOTclObject *obj; + Tcl_Obj *cmdName; + Tcl_ObjCmdProc *objProc; + ClientData cd; +} aliasCmdClientData; static int ObjDispatch(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[], int flags); @@ -136,7 +142,12 @@ int useCSObjs); static int XOTclForwardMethod(ClientData cd, Tcl_Interp *in, int objc, - Tcl_Obj * CONST objv[]); + Tcl_Obj *CONST objv[]); +static int XOTclObjscopedMethod(ClientData cd, Tcl_Interp *in, int objc, + Tcl_Obj *CONST objv[]); +static int XOTclSetterMethod(ClientData cd, Tcl_Interp *in, int objc, + Tcl_Obj *CONST objv[]); + static int callDestroyMethod(ClientData cd, Tcl_Interp *in, XOTclObject *obj, int flags); static XOTclObject *XOTclpGetObject(Tcl_Interp *in, char *name); @@ -169,15 +180,8 @@ return result; } static int -Tcl_IncrObjCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - int result; - char *argv[3]; - argv[0] = XOTclGlobalStrings[XOTE_INCR]; - argv[1] = ObjStr(objv[1]); - if (objc == 3) - argv[2] = ObjStr(objv[2]); - result = Tcl_IncrCmd(cd, in, objc, argv); - return result; +Tcl_EvalEx(Tcl_Interp *in, char *cmd, int len, int flats) { + return Tcl_Eval(in, cmd); } static int Tcl_SubstObjCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { @@ -204,9 +208,10 @@ tov[0] = obj->cmdName; tov[1] = method; + 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); @@ -216,15 +221,19 @@ } int -XOTclCallMethodWithArg(ClientData cd, Tcl_Interp *in, Tcl_Obj *method, Tcl_Obj *arg, - int objc, Tcl_Obj *CONST objv[], int flags) { +XOTclCallMethodWithArgs(ClientData cd, Tcl_Interp *in, Tcl_Obj *method, Tcl_Obj *arg, + int givenobjc, Tcl_Obj *CONST objv[], int flags) { XOTclObject *obj = (XOTclObject*) cd; + int objc = givenobjc + 2; int result; ALLOC_ON_STACK(Tcl_Obj*,objc, tov); + assert(objc>1); tov[0] = obj->cmdName; tov[1] = method; - tov[2] = arg; + if (objc>2) { + tov[2] = arg; + } if (objc>3) memcpy(tov+3, objv, sizeof(Tcl_Obj *)*(objc-3)); @@ -238,7 +247,7 @@ * realize self, class, proc through the [self] command */ -XOTCLINLINE static CONST84 char* +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); @@ -256,6 +265,12 @@ return CallStackGetFrame(in)->self; } +/* extern callable GetSelfObj */ +XOTcl_Object* +XOTclGetSelfObj(Tcl_Interp *in) { + return (XOTcl_Object*)GetSelfObj(in); +} + XOTCLINLINE static Tcl_Command GetSelfProcCmdPtr(Tcl_Interp *in) { /*return RUNTIME_STATE(in)->cs.top->cmdPtr;*/ @@ -344,11 +359,14 @@ /* search for tail of name */ -static char* +static char * NSTail(char *string) { - register char *p; - for (p=string+strlen(string); p>=string && *p != ':'; p--); - return (p+1); + register char *p = string+strlen(string); + while (p > string) { + if (*p == ':' && *(p-1) == ':') return p+1; + *p--; + } + return string; } XOTCLINLINE static int @@ -357,13 +375,13 @@ } /* removes preceding ::xotcl::classes from a string */ -XOTCLINLINE static char* +XOTCLINLINE static char * NSCutXOTclClasses(char *string) { assert(strncmp((string), "::xotcl::classes", 16) == 0); return string+16; } -XOTCLINLINE static char* +XOTCLINLINE static char * NSCmdFullName(Tcl_Command cmd) { Tcl_Namespace *nsPtr = Tcl_Command_nsPtr(cmd); return nsPtr ? nsPtr->fullName : ""; @@ -557,7 +575,7 @@ Tcl_DStringAppend(dsp, Tcl_GetCommandName(NULL, obj->id), -1); l = (unsigned) Tcl_DStringLength(dsp)+1; - objPtr->bytes = (char*) ckalloc(l); + objPtr->bytes = (char *) ckalloc(l); memcpy(objPtr->bytes, Tcl_DStringValue(dsp), l); objPtr->length = Tcl_DStringLength(dsp); DSTRING_FREE(dsp); @@ -765,7 +783,7 @@ Tcl_Command cmd = NSFindCommand(in, objName, callingNameSpace(in)); /*fprintf(stderr, "GetXOTclClassFromObj %s cmd = %p cl=%p retry=%d\n", - objName, cmd, cmd? XOTclGetClassFromCmdPtr(cmd) : NULL, retry);*/ + objName, cmd, cmd ? XOTclGetClassFromCmdPtr(cmd) : NULL, retry);*/ if (cmd) { cls = XOTclGetClassFromCmdPtr(cmd); if (cl) *cl = cls; @@ -811,15 +829,43 @@ return result; } +extern void +XOTclFreeClasses(XOTclClasses* sl) { + XOTclClasses *n; + for (; sl; sl = n) { + n = sl->next; + 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); +} + /* * 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 int TopoSort(XOTclClass *cl, XOTclClass *base, XOTclClasses* (*next)(XOTclClass*)) { - XOTclClasses* sl = (*next)(cl); + /*XOTclClasses* sl = (*next)(cl);*/ + XOTclClasses* sl = next == Super ? cl->super : cl->sub; XOTclClasses* pl; /* @@ -853,60 +899,6 @@ return 1; } -extern void -XOTclFreeClasses(XOTclClasses* sl) { - XOTclClasses *n; - for (; sl; sl = n) { - n = sl->next; - FREE(XOTclClasses,sl); - } -} - -/** FIXME ****/ -extern void -XOTclFreeClasses1(XOTclClasses* sl) { - XOTclClasses *n; - for (; sl; sl = n) { - n = sl->next; - fprintf(stderr, "freeing %p\n",sl); - 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); -} - -/** FIXME ****/ -extern XOTclClasses** -XOTclAddClass1(XOTclClasses **cList, XOTclClass *cl, ClientData cd) { - XOTclClasses *l = *cList, *element = NEW(XOTclClasses); - element->cl = cl; - element->clientData = cd; - element->next = NULL; - fprintf(stderr, "allocating XOTclClasses %p for list %p\n", element, cList); - if (l) { - while (l->next) l = l->next; - l->next = element; - } else - *cList = element; - return &(element->next); -} - -static XOTclClasses* Super(XOTclClass *cl) { return cl->super; } -static XOTclClasses* Sub(XOTclClass *cl) { return cl->sub; } - static XOTclClasses* TopoOrder(XOTclClass *cl, XOTclClasses* (*next)(XOTclClass*)) { if (TopoSort(cl, cl, next)) @@ -916,21 +908,21 @@ return 0; } -XOTCLINLINE static XOTclClasses* -ComputeOrder(register XOTclClass *cl, XOTclClasses* (*direction)(XOTclClass*)) { - if (!cl->order) - cl->order = TopoOrder(cl, direction); - return cl->order; +static XOTclClasses* +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, Super); + return ComputeOrder(cl, cl->order, Super); } extern XOTclClasses* XOTclComputeDependents(XOTclClass *cl) { - return ComputeOrder(cl, Sub); + return ComputeOrder(cl, cl->order, Sub); } @@ -939,7 +931,7 @@ XOTclClasses* pc; XOTclFreeClasses(cl->order); cl->order = 0; - pc = ComputeOrder(cl, Sub); + pc = ComputeOrder(cl, cl->order, Sub); /* * ordering doesn't matter here - we're just using toposort @@ -960,14 +952,14 @@ obj->cl = cl; if (cl != 0) { int nw; - (void) Tcl_CreateHashEntry(&cl->instances, (char*)obj, &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); + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&cl->instances, (char *)obj); if (hPtr) { Tcl_DeleteHashEntry(hPtr); return 1; @@ -1037,10 +1029,9 @@ * internal type checking */ -extern XOTcl_Class* +extern XOTcl_Class* XOTclIsClass(Tcl_Interp *in, ClientData cd) { - XOTclObject *obj = (XOTclObject*)cd; - if (obj && XOTclObjectIsClass(obj)) + if (cd && XOTclObjectIsClass((XOTclObject *)cd)) return (XOTcl_Class*) cd; return 0; } @@ -1051,23 +1042,31 @@ /*XOTCLINLINE*/ static Tcl_Command FindMethod(char *methodName, Tcl_Namespace* nsPtr) { - Tcl_HashTable *cmdTable; Tcl_HashEntry *entryPtr; - Tcl_Command cmd; +#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))) { - cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); - } else { - cmd = NULL; - } + return (Tcl_Command) Tcl_GetHashValue(entryPtr); + } /*fprintf(stderr, "find %s in %p returns %p\n",methodName,cmdTable,cmd);*/ - return 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; } -XOTCLINLINE static XOTclClass* +static XOTclClass* SearchPLMethod(register XOTclClasses* pl, char *nm, Tcl_Command *cmd) { /* Search the class hierarchy */ for (; pl; pl = pl->next) { @@ -1084,7 +1083,7 @@ static XOTclClass* SearchCMethod(XOTclClass *cl, char *nm, Tcl_Command *cmd) { assert(cl); - return SearchPLMethod(ComputeOrder(cl, Super), nm, cmd); + return SearchPLMethod(ComputeOrder(cl, cl->order, Super), nm, cmd); } static int @@ -1132,7 +1131,7 @@ static char cmd[] = "puts stderr \"[self]: Error in instproc destroy\n\ $::errorCode $::errorInfo\""; - Tcl_Eval(in, cmd); + Tcl_EvalEx(in, cmd, -1, 0); if (++RUNTIME_STATE(in)->errorCount > 20) panic("too many destroy errors occured. Endless loop?", NULL); } else { @@ -1244,7 +1243,7 @@ } /* typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( - * Tcl_Interp* in, CONST char* name, Tcl_Namespace *context, + * Tcl_Interp* in, CONST char * name, Tcl_Namespace *context, * int flags, Tcl_Var *rPtr)); */ int @@ -1611,12 +1610,12 @@ register Tcl_Command cmd; assert(name); cmd = NSFindCommand(in, name, NULL); - /* - if (cmd) { - fprintf(stderr,"+++ XOTclGetObject objProc=%p, dispatch=%p\n", - 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); } @@ -1707,19 +1706,31 @@ int valueLength, mustCopy = 1, format = 0; char *valueString, *c; Tcl_Obj *valueObject, *result = NULL, *savedResult = NULL; - XOTcl_FrameDecls; +#ifdef PRE83 + int flgs = 0; +#else int flgs = TCL_LEAVE_ERR_MSG; +#endif + XOTcl_FrameDecls; XOTcl_PushFrame(in, obj); if (obj->nsPtr) flgs |= TCL_NAMESPACE_ONLY; -#ifndef PRE83 - valueObject = TclIncrVar2(in, XOTclGlobalObjects[XOTE_AUTONAMES], name, 1, flgs); -#else - valueObject = TclIncrVar2(in, XOTclGlobalObjects[XOTE_AUTONAMES], name, 1, 0); -#endif - + 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); + } + Tcl_SetLongObj(valueObject,autoname_counter); + } + Tcl_ObjSetVar2(in, XOTclGlobalObjects[XOTE_AUTONAMES], name, + valueObject, flgs); + if (resetOpt) { if (valueObject != NULL) { /* we have an entry */ Tcl_UnsetVar2(in, XOTclGlobalStrings[XOTE_AUTONAMES], ObjStr(name), flgs); @@ -1729,7 +1740,7 @@ } else { if (valueObject == NULL) { valueObject = Tcl_ObjSetVar2(in, XOTclGlobalObjects[XOTE_AUTONAMES], - name, XOTclGlobalObjects[XOTE_ZERO], flgs); + name, XOTclGlobalObjects[XOTE_ONE], flgs); } if (instanceOpt) { char buffer[1], firstChar, *nextChars; @@ -1750,8 +1761,6 @@ fprintf(stderr,"*** copy %p %s = %p\n", name,ObjStr(name),result); */ } - valueString = Tcl_GetStringFromObj(valueObject,&valueLength); - /* 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.: @@ -1789,10 +1798,7 @@ DECR_REF_COUNT(savedResult); FREE_ON_STACK(ov); } else { - /* append the value string, if not - formated or if only %% occurs */ - /*fprintf(stderr,"+++ append to obj %p %s : %s\n", - result,ObjStr(result), valueString);*/ + valueString = Tcl_GetStringFromObj(valueObject,&valueLength); Tcl_AppendToObj(result, valueString, valueLength); /*fprintf(stderr,"+++ append to obj done\n");*/ } @@ -1930,7 +1936,7 @@ TCL_STATIC); return TCL_ERROR; } - + /*fprintf(stderr, "CallStackPush sets self\n");*/ csc = ++cs->top; csc->self = obj; csc->cl = cl; @@ -1947,7 +1953,7 @@ /*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), + cmd, (char *) Tcl_GetCommandName(in, cmd), obj->id, Tcl_GetCommandName(in, obj->id), csc);*/ MEM_COUNT_ALLOC("CallStack",NULL); @@ -2126,7 +2132,8 @@ MEM_COUNT_FREE("command refCount",cmd); } -/* +#if 0 +/** for debug purposes only */ static void CmdListPrint(Tcl_Interp *in, char *title, XOTclCmdList* cmdList) { if (cmdList) @@ -2140,7 +2147,7 @@ cmdList = cmdList->next; } } -*/ +#endif /* * physically delete an entry 'del' @@ -2296,7 +2303,7 @@ Tcl_AppendStringsToObj(newAssStr, "{", ObjStr(alist->content), "}", (char *) NULL); if (alist->next != NULL) - Tcl_AppendStringsToObj(newAssStr, " ", (char*) NULL); + Tcl_AppendStringsToObj(newAssStr, " ", (char *) NULL); } return newAssStr; } @@ -2505,13 +2512,13 @@ INCR_REF_COUNT(sr); XOTclVarErrMsg(in, "Error in Assertion: {", ObjStr(checkFailed->content), "} in proc '", - GetSelfProc(in), "'\n\n", ObjStr(sr), (char *)NULL); + 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); + GetSelfProc(in), "'", (char *) NULL); } Tcl_SetObjResult(in, savedObjResult); @@ -2531,7 +2538,7 @@ if (result != TCL_ERROR && checkoptions & CHECK_CLINVAR) { XOTclClasses* clPtr; - clPtr = ComputeOrder(obj->cl, Super); + 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) { @@ -2575,6 +2582,9 @@ return result; } + + + /* * Per-Object-Mixins */ @@ -2618,7 +2628,7 @@ while (m) { XOTclClass *mCl = XOTclGetClassFromCmdPtr(m->cmdPtr); if (mCl) { - for (pl = ComputeOrder(mCl, Super); pl; pl = pl->next) { + 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; @@ -2687,7 +2697,7 @@ } /* append per-class mixins */ - for (pl = ComputeOrder(obj->cl, Super); pl; pl = pl->next) { + 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, @@ -2711,7 +2721,7 @@ if (checker == 0) { /* check obj->cl hierachy */ - for (checker = ComputeOrder(obj->cl, Super); checker; checker = checker->next) { + for (checker = ComputeOrder(obj->cl, obj->cl->order, Super); checker; checker = checker->next) { if (checker->cl == mixinClasses->cl) break; } @@ -2761,11 +2771,11 @@ 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);*/ + "' has too many elements.", (char *) NULL);*/ } if (GetXOTclClassFromObj(in, name, &mixin, 1) != TCL_OK) - return XOTclErrBadVal(in, "a class as mixin", ObjStr(name)); + return XOTclErrBadVal(in, "mixin", "a class as mixin", ObjStr(name)); new = CmdListAdd(mixinList, mixin->object.id, /*noDuplicates*/ 1); @@ -2819,13 +2829,13 @@ cl->order = 0; - for (clPtr = ComputeOrder(cl, Sub); clPtr; clPtr = clPtr->next) { + 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; - /* 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 @@ -2841,9 +2851,13 @@ XOTclFreeClasses(cl->order); cl->order = saved; +#if 1 + /* TODO: Uwe, this slows down superclass by a factor of 5! + maybe we can use a mixin epoch? + */ /* invalidate the mixins on all instances that have this mixin (cl) - at the moments */ + at the moment */ Tcl_InitHashTable(commandTable, TCL_STRING_KEYS); MEM_COUNT_ALLOC("Tcl_InitHashTable",commandTable); getAllInstances(commandTable, RUNTIME_STATE(in)->theClass); @@ -2861,16 +2875,17 @@ if (mixin == cl) { MixinResetOrder(obj); obj->flags &= ~XOTCL_MIXIN_ORDER_VALID; + break; } } } 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); /* * the mixin order is either * DEFINED (there are mixins on the instance), @@ -2902,26 +2917,47 @@ /* ensure that the mixin order is not invalid, otherwise compute order */ assert(obj->flags & XOTCL_MIXIN_ORDER_VALID); - /* otherwise: MixinComputeDefined(in, obj);*/ - + /*MixinComputeDefined(in, obj);*/ currentCmdPtr = obj->mixinStack->currentCmdPtr; - *cmdList = obj->mixinOrder; + /* + { + XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; + XOTclCallStackContent *csc = cs->top; + fprintf(stderr, "%p == %p ==> %d \n", csc->cl, currentCmdPtr, + csc->cmdPtr == currentCmdPtr); + } + */ + + /*** + { 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); + } + ***/ + + *cmdList = obj->mixinOrder; + /* fprintf(stderr, "->1 mixin seek current = %p next = %p %s\n", currentCmdPtr, (*cmdList)->next, (*cmdList)->next ? Tcl_GetCommandName(in, (*cmdList)->next->cmdPtr) : ""); */ + #if defined(ACTIVEMIXIN) /*RUNTIME_STATE(in)->cmdPtr = (*cmdList)->next ? (*cmdList)->next->cmdPtr : NULL;*/ RUNTIME_STATE(in)->cmdPtr = (*cmdList)->cmdPtr; #endif + /* go forward to current class */ while (*cmdList && currentCmdPtr) { /* fprintf(stderr, "->2 mixin seek current = %p next = %p\n", currentCmdPtr, (*cmdList)->next);*/ if ((*cmdList)->cmdPtr == currentCmdPtr) currentCmdPtr = 0; *cmdList = (*cmdList)->next; + #if defined(ACTIVEMIXIN) /*RUNTIME_STATE(in)->cmdPtr = (*cmdList)->next ? (*cmdList)->next->cmdPtr : NULL;*/ RUNTIME_STATE(in)->cmdPtr = (*cmdList)->cmdPtr; @@ -2947,9 +2983,10 @@ MixinSeekCurrent(in, 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(in,"MixinSearch CL = \n", cmdList);*/ + while (cmdList) { if(Tcl_Command_cmdEpoch(cmdList->cmdPtr)) { @@ -2997,6 +3034,7 @@ 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 || @@ -3022,7 +3060,7 @@ Tcl_Command cmd; while (mixinList) { XOTclClass *mcl = - XOTclpGetClass(in, (char*) Tcl_GetCommandName(in, mixinList->cmdPtr)); + XOTclpGetClass(in, (char *) Tcl_GetCommandName(in, mixinList->cmdPtr)); if (mcl && SearchCMethod(mcl, name, &cmd)) return cmd; @@ -3138,7 +3176,7 @@ /* fprintf(stderr, " +++ ERROR\n");*/ XOTclVarErrMsg(in, "Guard Error: '", ObjStr(guard), "'\n\n", - ObjStr(sr), (char *)NULL); + ObjStr(sr), (char *) NULL); DECR_REF_COUNT(sr); return TCL_ERROR; } @@ -3276,7 +3314,7 @@ if (!guardAdded) { /* search per-class filters */ - for (pl = ComputeOrder(obj->cl, Super); !guardAdded && pl; pl = pl->next) { + 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, @@ -3296,7 +3334,7 @@ */ if (!guardAdded) { XOTclCmdList* registeredFilter = - CmdListFindNameInList(in,(char*) Tcl_GetCommandName(in, filterCmd), + CmdListFindNameInList(in,(char *) Tcl_GetCommandName(in, filterCmd), obj->filterOrder); if (registeredFilter) { GuardAdd(in, dest, (Tcl_Obj*) registeredFilter->clientData); @@ -3328,7 +3366,7 @@ } } return XOTclVarErrMsg(in, "info (*)guard: can't find filter/mixin ", - interceptorName, (char *)NULL); + interceptorName, (char *) NULL); } /* @@ -3353,11 +3391,11 @@ if (startingObj) return XOTclVarErrMsg(in, "filter: can't find filterproc on: ", ObjStr(startingObj->cmdName), " - proc: ", - ObjStr(name), (char *)NULL); + ObjStr(name), (char *) NULL); else return XOTclVarErrMsg(in, "instfilter: can't find filterproc on: ", ObjStr(startingCl->object.cmdName), " - proc: ", - ObjStr(name), (char *)NULL); + ObjStr(name), (char *) NULL); } /* fprintf(stderr, " +++ adding filter %s \n", ObjStr(name)); @@ -3398,7 +3436,7 @@ CmdListRemoveEpoched(filters, GuardDel); cmdList = *filters; while (cmdList) { - simpleName = (char*) Tcl_GetCommandName(in, cmdList->cmdPtr); + simpleName = (char *) Tcl_GetCommandName(in, cmdList->cmdPtr); cmd = FilterSearch(in, simpleName, startingObj, startingCl); if (cmd == NULL) { del = cmdList; @@ -3428,7 +3466,7 @@ XOTclClasses *saved = cl->order, *clPtr, *savePtr; cl->order = 0; - savePtr = clPtr = ComputeOrder(cl, Sub); + savePtr = clPtr = ComputeOrder(cl, cl->order, Sub); cl->order = saved; while (clPtr != 0) { @@ -3465,7 +3503,7 @@ XOTclClasses *saved = cl->order, *clPtr; cl->order = 0; - for (clPtr = ComputeOrder(cl, Sub); clPtr; clPtr = clPtr->next) { + 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; @@ -3492,15 +3530,37 @@ */ static Tcl_Obj* getFullProcQualifier(Tcl_Interp *in, CONST84 char *cmdName, - XOTclObject *obj, XOTclClass *cl) { + 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); + if (cl) { Tcl_ListObjAppendElement(in, list, cl->object.cmdName); - Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_INSTPROC]); + /*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]); + } else { + Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_INSTCMD]); + } } else { Tcl_ListObjAppendElement(in, list, obj->cmdName); - Tcl_ListObjAppendElement(in, list, XOTclGlobalObjects[XOTE_PROC]); + 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; @@ -3541,7 +3601,8 @@ XOTclClass *fcl = GetClassFromFullName(in,fullName); XOTclObject *fobj = fcl ? 0 : XOTclpGetObject(in, fullName); Tcl_ListObjAppendElement(in, list, - getFullProcQualifier(in, simpleName, fobj, fcl)); + getFullProcQualifier(in, simpleName, + fobj, fcl, f->cmdPtr)); } else { Tcl_ListObjAppendElement(in, list, Tcl_NewStringObj(simpleName, -1)); } @@ -3572,7 +3633,7 @@ for (f = *filters; f; f = f->next) { char *fullName = NSCmdFullName(f->cmdPtr); - simpleName = (char*) Tcl_GetCommandName(in, f->cmdPtr); + simpleName = (char *) Tcl_GetCommandName(in, f->cmdPtr); fCl = GetClassFromFullName(in, fullName); CmdListAdd(filterList, f->cmdPtr, /*noDuplicates*/ 0); @@ -3586,7 +3647,7 @@ /* if we have a filter class -> search up the inheritance hierarchy*/ if (fCl) { - pl = ComputeOrder(fCl, Super); + pl = ComputeOrder(fCl, fCl->order, Super); if (pl && pl->next) { /* don't search on the start class again */ pl = pl->next; @@ -3642,7 +3703,7 @@ FilterComputeOrderFullList(in, &obj->opt->filters, &filterList); /* append per-class filters */ - for (pl = ComputeOrder(obj->cl, Super); pl; pl=pl->next) { + 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); @@ -3799,7 +3860,7 @@ } /* search per-class filters */ - for (pl = ComputeOrder(obj->cl, Super); pl; pl = pl->next) { + 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)) { @@ -3857,92 +3918,285 @@ } +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; + + 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; + } + + /* invalidate all interceptors orders of instances of this + and of all depended classes */ + MixinInvalidateObjOrders(in, cl); + FilterInvalidateObjOrders(in, 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)); + } + } + + /* + * 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; + } + } + + if (reversed != 0) { + return XOTclErrBadVal(in, "superclass", "classes in dependence order", + ObjStr(arg)); + } + + while (cl->super != 0) { + + /* + * 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); + + if (!ComputeOrder(cl, cl->order, Super)) { + + /* + * 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); + + /* if there are no more super classes add the Object + class as superclasses */ + if (cl->super == 0) + AddSuper(cl, RUNTIME_STATE(in)->theObject); + + Tcl_ResetResult(in); + return TCL_OK; +} + + + +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); + } + + XOTcl_PushFrame(in, obj); + +#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_PopFrame(in, obj); + + if (obj->nsPtr) { + Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, + (Tcl_ResolveVarProc *)NULL, + (Tcl_ResolveCompiledVarProc*)NULL); + } + return result; +} + + /* * 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; - register Tcl_HashEntry* entryPtr = 0; - Var* defaults; + register Tcl_HashEntry *entryPtr = 0, *initcmdsPtr = 0; + Var *defaults = 0, *initcmds = 0; Tcl_Namespace *ns = targetClass->object.nsPtr; if (ns) { Tcl_HashTable *varTable = Tcl_Namespace_varTable(ns); entryPtr = Tcl_FindHashEntry(varTable, "__defaults"); + initcmdsPtr = Tcl_FindHashEntry(varTable, "__initcmds"); } else if (targetClass->object.varTable) { entryPtr = Tcl_FindHashEntry(targetClass->object.varTable, "__defaults"); + initcmdsPtr = Tcl_FindHashEntry(targetClass->object.varTable, "__initcmds"); } if (entryPtr) { defaults = (Var*) Tcl_GetHashValue(entryPtr); + } + if (initcmdsPtr) { + initcmds = (Var*) Tcl_GetHashValue(initcmdsPtr); + } + + if (defaults && TclIsVarArray(defaults)) { + Tcl_HashTable *table = defaults->value.tablePtr; + Tcl_HashSearch hSrch; + Tcl_HashEntry* hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; - /* - fprintf(stderr, "+++ we have defaults for <%s>\n", - className(targetClass)); - */ + /*fprintf(stderr, "+++ we have defaults for <%s>\n", + className(targetClass));*/ - if (TclIsVarArray(defaults)) { - Tcl_HashTable *table = defaults->value.tablePtr; - Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; - - for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - char *varName = Tcl_GetHashKey(table, hPtr); - Tcl_Obj *varNameObj = Tcl_NewStringObj(varName,-1); - Var *val = (Var*)Tcl_GetHashValue(hPtr); - INCR_REF_COUNT(varNameObj); - if (TclIsVarScalar(val)) { - Tcl_Obj *oldValue; - 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) { - char *value = ObjStr(val->value.objPtr), *v; - Tcl_Obj *valueObj = val->value.objPtr; - int doSubst = 0; - for (v=value; *v; v++) { - if (*v == '[' && doSubst == 0) - doSubst = 1; - else if ((doSubst == 1 && *v == ']') || *v == '$') { - doSubst = 2; - break; - } + for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *varName = Tcl_GetHashKey(table, hPtr); + Tcl_Obj *varNameObj = Tcl_NewStringObj(varName,-1); + Var *val = (Var*)Tcl_GetHashValue(hPtr); + INCR_REF_COUNT(varNameObj); + if (TclIsVarScalar(val)) { + Tcl_Obj *oldValue; + 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) { + char *value = ObjStr(val->value.objPtr), *v; + Tcl_Obj *valueObj = val->value.objPtr; + 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; - } + } + 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; } - INCR_REF_COUNT(valueObj); - result = XOTclCallMethodWithArg((ClientData)obj, in, - varNameObj, valueObj, 3, 0, 0); - DECR_REF_COUNT(valueObj); - - if (result != TCL_OK) { + 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 result; + 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); } + DECR_REF_COUNT(varNameObj); } + } + + if (initcmds && TclIsVarArray(initcmds)) { + Tcl_HashTable *table = initcmds->value.tablePtr; + Tcl_HashSearch hSrch; + Tcl_HashEntry* hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; + + /*fprintf(stderr, "+++ we have initcmds for <%s>\n", className(targetClass));*/ + + for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { + char *varName = Tcl_GetHashKey(table, hPtr); + Tcl_Obj *varNameObj = Tcl_NewStringObj(varName,-1); + Var *val = (Var*)Tcl_GetHashValue(hPtr); + INCR_REF_COUNT(varNameObj); + /*fprintf(stderr,"varexists(%s->%s) = %d\n", + ObjStr(obj->cmdName), + varName, varExists(in, obj, varName, NULL, 0, 0));*/ + + if (TclIsVarScalar(val) && + (!varExists(in, obj, varName, NULL, 0, 0) || + varExists(in, &targetClass->object, "__defaults", varName, 0,0) + )) { + Tcl_Obj *valueObj = val->value.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'\n",ObjStr(valueObj)); */ + + rc = Tcl_EvalObjEx(in, valueObj, TCL_EVAL_DIRECT); + CallStackPop(in); + DECR_REF_COUNT(varNameObj); + XOTcl_PopFrame(in, obj); + if (rc != TCL_OK) { + return rc; + } + /* fprintf(stderr,"... varexists(%s->%s) = %d\n", + ObjStr(obj->cmdName), + varName, varExists(in, obj, varName, NULL, 0, 0)); */ + } + } + } } return result; } @@ -3975,7 +4229,7 @@ break; ml = ml->next; } - for (pl = ComputeOrder(cl, Super); pl; pl = pl->next) { + for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->next) { result = SearchDefaultValuesOnClass(in, obj, cmdCl, pl->cl); if (result != TCL_OK) break; @@ -3992,11 +4246,10 @@ if (!cl) return XOTclObjErrType(in, objv[0], "Class"); if (objc != 2) - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "searchDefaults obj"); + return XOTclObjErrArgCnt(in, cl->object.cmdName, "searchDefaults obj"); if (GetXOTclObjectFromObj(in, objv[1], &defaultObj) != TCL_OK) return XOTclVarErrMsg(in, "Can't find default object ", - ObjStr(objv[1]), (char *)NULL); + ObjStr(objv[1]), (char *) NULL); /* * Search for default values for vars on superclasses @@ -4008,17 +4261,19 @@ 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 = (opt && opt->parameterClass) ? opt->parameterClass : - XOTclGlobalObjects[XOTE_PARAM_CL]; + Tcl_Obj *pcl = XOTclGlobalObjects[XOTE_PARAM_CL]; XOTclClass *paramCl; int result; + if (opt && opt->parameterClass) pcl = opt->parameterClass; + if (GetXOTclClassFromObj(in,pcl,¶mCl, 1) == TCL_OK) { - result = XOTclCallMethodWithArg((ClientData)paramCl, in, - method, arg, objc, objv, flags); + result = XOTclCallMethodWithArgs((ClientData)paramCl, in, + method, arg, objc-2, objv, flags); } else - result = XOTclVarErrMsg(in, "create: can't find parameter class", (char *)NULL); + result = XOTclVarErrMsg(in, "create: can't find parameter class", + (char *) NULL); return result; } @@ -4030,9 +4285,9 @@ /* actually call a method (with assertion checking) */ static int callProcCheck(ClientData cp, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[], - Tcl_Command cmd, XOTclObject *obj, XOTclClass *cl, char *methodName, - int frameType, int isTclProc) { - int result = TCL_OK, callStackPushed = 0; + Tcl_Command cmd, XOTclObject *obj, XOTclClass *cl, + char *methodName, int frameType, int isTclProc) { + int result = TCL_OK; XOTclRuntimeState *rst = RUNTIME_STATE(in); CheckOptions co; @@ -4059,28 +4314,18 @@ Tcl_GetCommandName(in, cmd), Tcl_Command_objProc(cmd) == XOTclObjDispatch, XOTclObjDispatch, Tcl_Command_objProc(cmd) == XOTclForwardMethod, XOTclForwardMethod, +XOTclObjscopedMethod objv[0], objc ); */ - if (isTclProc - || (Tcl_Command_objProc(cmd) == XOTclObjDispatch) - || (Tcl_Command_objProc(cmd) == XOTclForwardMethod) - ) { - /* push the xotcl info */ - if ((CallStackPush(in, obj, cl, cmd, objc, objv, frameType)) == TCL_OK) - callStackPushed = 1; - else { - result = TCL_ERROR; goto finish; - } - } - #ifdef CALLSTACK_TRACE XOTclCallStackDump(in); #endif if (!isTclProc && obj->teardown) { - co = obj->opt ? obj->opt->checkoptions : 0; + co = 0; + if (obj->opt) co = obj->opt->checkoptions; if ((co & CHECK_INVAR) && ((result = AssertionCheckInvars(in, obj, methodName, co)) == TCL_ERROR)) { goto finish; @@ -4105,9 +4350,10 @@ fprintf(stderr, "method=%s\n", methodName); } */ - co = !rst->callIsDestroy && obj->opt ? obj->opt->checkoptions : 0; + co = 0; + if (!rst->callIsDestroy && obj->opt) co = obj->opt->checkoptions; if ((co & CHECK_INVAR) && - ((result = AssertionCheckInvars(in, obj, methodName, co)) == TCL_ERROR)) { + ((result = AssertionCheckInvars(in, obj, methodName,co)) == TCL_ERROR)) { goto finish; } } else { @@ -4149,18 +4395,15 @@ } - if (callStackPushed) { - CallStackPop(in); - } return rc; } } } if (!rst->callIsDestroy && obj->teardown && !(obj->flags & XOTCL_DESTROY_CALLED)) { - co = obj->opt ? obj->opt->checkoptions : 0; - if ((co & CHECK_PRE) && + if (obj->opt && + (obj->opt->checkoptions & CHECK_PRE) && (result = AssertionCheck(in, obj, cl, methodName, CHECK_PRE)) == TCL_ERROR) { goto finish; } @@ -4195,16 +4438,14 @@ /*fprintf(stderr,"callProcCheck: setting callIsDestroy = 1\n");*/ } - co = obj->opt ? obj->opt->checkoptions : 0; - if (!rst->callIsDestroy && obj->teardown && (co & CHECK_POST) && + if (obj->opt && !rst->callIsDestroy && obj->teardown && + (obj->opt->checkoptions & CHECK_POST) && (result = AssertionCheck(in, obj, cl, methodName, CHECK_POST) == TCL_ERROR)) { goto finish; } } finish: - if (callStackPushed) - CallStackPop(in); #if defined(PROFILE) if (rst->callIsDestroy == 0) { @@ -4218,53 +4459,59 @@ static int DoCallProcCheck(ClientData cp, ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[], - Tcl_Command cmd, XOTclObject *obj, XOTclClass *cl, char *methodName, + Tcl_Command cmd, XOTclObject *obj, + XOTclClass *cl, char *methodName, int frameType, int fromNext) { - int isTclProc = (TclIsProc((Command *)cmd) != 0); - int xotclCall = 0; + int rc, push = 1, isTclProc = 0; if (cp) { - if ( - Tcl_Command_objProc(cmd) == XOTclForwardMethod) { - /*fprintf(stderr,"calling forward obj=%p %s\n", obj, ObjStr(obj->cmdName));*/ - + 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; - xotclCall = 1; - } else if (Tcl_Command_objProc(cmd) == XOTclObjDispatch) - xotclCall = 1; + assert((TclIsProc((Command *)cmd) == NULL)); + } else if (cp == XOTCL_NONLEAF_METHOD) { + cp = cd; + assert((TclIsProc((Command *)cmd) == NULL)); + } else { + assert((TclIsProc((Command *)cmd) != NULL)); + isTclProc = 1; + } } else { - xotclCall = 1; + push = 0; + assert((TclIsProc((Command *)cmd) == NULL)); cp = cd; } - /* - fprintf(stderr,"*** DoCallProcCheck: cmd = %p\n",cmd); - fprintf(stderr, - "DoCallProcCheck cp=%p, tclProc=%d %p %s, dispatch=%d %p, eval=%d %p, ov[0]=%p oc=%d, %d %d\n", - cp, - TclIsProc((Command*)cmd)!=0, cmd, - Tcl_GetCommandName(in, cmd), - Tcl_Command_objProc(cmd) == XOTclObjDispatch, XOTclObjDispatch, - Tcl_Command_objProc(cmd) == XOTclForwardMethod, XOTclForwardMethod, - objv[0], objc, xotclCall, fromNext - ); - */ - - if ((xotclCall || isTclProc) && !fromNext) { + if (!fromNext) { objc--; objv++; } - return callProcCheck(cp, in, objc, objv, cmd, obj, cl, - methodName, frameType, isTclProc); + + 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); + } + + return rc; } XOTCLINLINE static int -DoDispatch(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[], int flags) { +DoDispatch(ClientData cd, Tcl_Interp *in, int objc, + Tcl_Obj *CONST objv[], int flags) { register XOTclObject *obj = (XOTclObject*)cd; int result = TCL_OK, mixinStackPushed = 0, - filterStackPushed = 0, unknown, + filterStackPushed = 0, unknown, objflags, frameType = XOTCL_CSC_TYPE_PLAIN; #ifdef OBJDELETION_TRACE Tcl_Obj *method; @@ -4274,16 +4521,16 @@ ClientData cp = 0; Tcl_ObjCmdProc *proc = 0; Tcl_Command cmd = 0; - Tcl_Obj *cmdName = obj->cmdName; XOTclRuntimeState *rst = RUNTIME_STATE(in); + Tcl_Obj *cmdName = obj->cmdName; XOTclCallStack *cs = &rst->cs; /*int isdestroy = (objv[1] == XOTclGlobalObjects[XOTE_DESTROY]); */ #ifdef AUTOVARS int isNext; #endif assert(objc>0); - methodName = callMethod = ObjStr(objv[1]); + methodName = ObjStr(objv[1]); #ifdef AUTOVARS isNext = isNextString(methodName); @@ -4302,14 +4549,16 @@ } #endif + objflags = obj->flags; /* avoid stalling */ INCR_REF_COUNT(cmdName); - if (!(obj->flags & XOTCL_FILTER_ORDER_VALID)) + if (!(objflags & XOTCL_FILTER_ORDER_VALID)) FilterComputeDefined(in, obj); - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + if (!(objflags & XOTCL_MIXIN_ORDER_VALID)) MixinComputeDefined(in, obj); + callMethod = methodName; #ifdef AUTOVARS if(!isNext) { #endif @@ -4331,7 +4580,7 @@ if (cmd) { /* 'proc' and the other output vars are set as well */ frameType = XOTCL_CSC_TYPE_ACTIVE_FILTER; cl = GetClassFromFullName(in, NSCmdFullName(cmd)); - callMethod = (char*) Tcl_GetCommandName(in, cmd); + callMethod = (char *) Tcl_GetCommandName(in, cmd); /* rst->filterCalls++; */ } else { FilterStackPop(obj); @@ -4389,10 +4638,10 @@ } if (proc) { - result = DoCallProcCheck(cp, cd, in, objc, objv, cmd, obj, cl, - callMethod, frameType, 0 /* fromNext */); - if (result == TCL_ERROR) { - XOTclErrInProc(in, cmdName, cl ? cl->object.cmdName : NULL, callMethod); + result = TCL_OK; + if (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; } else { @@ -4404,9 +4653,9 @@ if (unknown) { if (XOTclObjectIsClass(obj) && (flags & XOTCL_CM_NO_UNKNOWN)) { - Tcl_AppendResult(in, ObjStr(objv[0]), ": unable to dispatch method '", - callMethod, "'", 0); - result = TCL_ERROR; + 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; @@ -4429,9 +4678,9 @@ FREE_ON_STACK(tov); } else { /* unknown failed */ - Tcl_AppendResult(in, ObjStr(objv[0]), ": unable to dispatch method '", - ObjStr(objv[2]), "'", 0); - result = TCL_ERROR; + return XOTclVarErrMsg(in, ObjStr(objv[0]), + ": unable to dispatch method '", + ObjStr(objv[2]), "'", (char *) NULL); } } @@ -4488,7 +4737,7 @@ tov[1] = XOTclGlobalObjects[XOTE_DEFAULTMETHOD]; result = DoDispatch(cd, in, 2, tov, flags); } else { - /* try normal dispatch */ + /* normal dispatch */ result = DoDispatch(cd, in, objc, objv, flags); } @@ -4497,7 +4746,8 @@ #ifdef XOTCL_BYTECODE int -XOTclDirectSelfDispatch(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { +XOTclDirectSelfDispatch(ClientData cd, Tcl_Interp *in, + int objc, Tcl_Obj *CONST objv[]) { int result; #ifdef XOTCLOBJ_TRACE XOTclObject *obj; @@ -4510,7 +4760,8 @@ #endif int -XOTclObjDispatch(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { +XOTclObjDispatch(ClientData cd, Tcl_Interp *in, + int objc, Tcl_Obj *CONST objv[]) { return ObjDispatch(cd, in, objc, objv, 0); } @@ -4525,7 +4776,7 @@ DECR_REF_COUNT(nonposArg->nonposArgs); DECR_REF_COUNT(nonposArg->ordinaryArgs); MEM_COUNT_FREE("nonposArg",nonposArg); - ckfree((char*) nonposArg); + ckfree((char *) nonposArg); Tcl_DeleteHashEntry(hPtr); } } @@ -4551,7 +4802,7 @@ } static XOTclNonposArgs* -NonposArgsGet(Tcl_HashTable* nonposArgsTable, char* methodName) { +NonposArgsGet(Tcl_HashTable* nonposArgsTable, char * methodName) { Tcl_HashEntry* hPtr; if (nonposArgsTable && ((hPtr = Tcl_FindHashEntry(nonposArgsTable, methodName)))) { @@ -4567,6 +4818,8 @@ *list = Tcl_NewListObj(0, NULL), *innerlist, *nameStringObj; + /*fprintf(stderr, "nonposargsformat '%s'\n", ObjStr(nonposArgsData));*/ + r1 = Tcl_ListObjGetElements(in, nonposArgsData, &npalistc, &npalistv); if (r1 == TCL_OK) { for (i=0; i < npalistc; i++) { @@ -4590,11 +4843,28 @@ } } } + /* 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]); } +#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); + } +#endif Tcl_ListObjAppendElement(in, list, innerlist); } } @@ -4610,13 +4880,13 @@ Tcl_Obj* resultBody; resultBody = Tcl_NewStringObj("", 0); INCR_REF_COUNT(resultBody); - Tcl_AppendStringsToObj(resultBody, "::xotcl::initProcNS\n", NULL); + Tcl_AppendStringsToObj(resultBody, "::xotcl::initProcNS\n", (char *) NULL); if (nonposArgs) { Tcl_AppendStringsToObj(resultBody, "::xotcl::interpretNonpositionalArgs $args\n", - NULL); + (char *) NULL); } - Tcl_AppendStringsToObj(resultBody, ObjStr(body), NULL); + Tcl_AppendStringsToObj(resultBody, ObjStr(body), (char *) NULL); return resultBody; } @@ -4631,7 +4901,7 @@ rc = Tcl_ListObjGetElements(in, npArgs, &nonposArgsDefc, &nonposArgsDefv); if (rc != TCL_OK) { return XOTclVarErrMsg(in, "cannot break down non-positional args: ", - ObjStr(npArgs), (char *)NULL); + ObjStr(npArgs), (char *) NULL); } if (nonposArgsDefc > 0) { int start, end, length, i, j, nw = 0; @@ -4646,15 +4916,15 @@ 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); + 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); + arg, " in: ", ObjStr(npArgs), (char *) NULL); } length = strlen(arg); @@ -4671,15 +4941,18 @@ for (l=start; l0 && isspace((int)arg[end-1]); end--); - Tcl_ListObjAppendElement(in, list, Tcl_NewStringObj(arg+start, end-start)); + 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)); + Tcl_ListObjAppendElement(in, list, + Tcl_NewStringObj(arg+start, end-start)); + /* append the whole thing to the list */ Tcl_ListObjAppendElement(in, npaObj, list); } else { @@ -4710,7 +4983,7 @@ INCR_REF_COUNT(ordinaryArgs); Tcl_SetHashValue(hPtr, (ClientData)nonposArg); } else { - /* for strange resons, we did not find nonpos-args, although we + /* for strange reasons, we did not find nonpos-args, although we have definitions */ DECR_REF_COUNT(nonposArgsObj); } @@ -4757,13 +5030,22 @@ 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); + ObjStr(objv[2]), (char *) NULL); } for (i=0; insPtr) { - Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, - varResolver, (Tcl_ResolveCompiledVarProc*)NULL); - } - - XOTcl_PushFrame(in, obj); - -#if defined(PRE83) - varPtr = TclLookupVar(in, varName, (char *) NULL, TCL_PARSE_PART1, "access", - /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); -#else - if (triggerTrace) - varPtr = TclVarTraceExists(in, varName); - else - varPtr = TclLookupVar(in, varName, (char *) NULL, TCL_PARSE_PART1, "access", - /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); -#endif - result = ((varPtr != NULL) && !TclIsVarUndefined(varPtr)); - - XOTcl_PopFrame(in, obj); - - if (obj->nsPtr) { - Tcl_SetNamespaceResolvers(obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, - (Tcl_ResolveVarProc *)NULL, - (Tcl_ResolveCompiledVarProc*)NULL); - } - return result; -} - static int ListVars(Tcl_Interp *in, XOTclObject *obj, char *pattern) { Tcl_Obj *varlist, *okList, *element; @@ -4957,7 +5205,7 @@ okList = Tcl_NewListObj(0, NULL); for (i=0; icmdName); } else { @@ -5008,6 +5256,7 @@ 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; @@ -5016,10 +5265,10 @@ if (result == TCL_OK) { int found = 0; for (i=0; icl, Super); pl; pl = pl->next) { + 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; } -static int XOTclCInfoMethod(ClientData d, Tcl_Interp *h, int i, Tcl_Obj *CONST v[]); +static int XOTclCInfoMethod(ClientData, Tcl_Interp *, int, Tcl_Obj *CONST v[]); static int ListClass(Tcl_Interp *in, XOTclObject *obj, char *pattern, @@ -5161,14 +5410,15 @@ } else { XOTclClass *isc = XOTclpGetClass(in, pattern); XOTclClasses* pl; - if (isc == 0) return XOTclErrBadVal(in, "a class", pattern); + if (isc == 0) + return XOTclErrBadVal(in, "info superclass", "a class", pattern); /* * search precedence to see if we're related or not */ - for (pl = ComputeOrder(cl, Super); pl; pl = pl->next) { + for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->next) { if (pl->cl == isc) { - Tcl_SetIntObj(Tcl_GetObjResult(in), 1); + Tcl_SetIntObj(Tcl_GetObjResult(in), 1); break; } } @@ -5195,14 +5445,15 @@ XOTclClasses* pl; XOTclClasses* saved; - if (isc == 0) return XOTclErrBadVal(in, "a class", pattern); + if (isc == 0) + return XOTclErrBadVal(in, "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, Sub); pl; pl = pl->next) { + for (pl = ComputeOrder(cl, cl->order, Sub); pl; pl = pl->next) { if (pl->cl == isc) { Tcl_SetIntObj(Tcl_GetObjResult(in), 1); break; @@ -5221,7 +5472,7 @@ static int ListHeritage(Tcl_Interp *in, XOTclClass *cl, char *pattern) { - XOTclClasses* pl = ComputeOrder(cl, Super); + XOTclClasses* pl = ComputeOrder(cl, cl->order, Super); Tcl_ResetResult(in); if (pl) pl=pl->next; for (; pl != 0; pl = pl->next) { @@ -5250,7 +5501,7 @@ ml = ml->next; } } - pl = ComputeOrder(obj->cl, Super); + 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; @@ -5289,7 +5540,7 @@ } return TCL_OK; } - return XOTclErrBadVal(in, "a tcl method name", name); + return XOTclErrBadVal(in, "info args", "a tcl method name", name); } static int @@ -5359,9 +5610,8 @@ CallStackRestoreSavedFrames(in, &ctx); if (result == TCL_ERROR) { - Tcl_ResetResult(in); - Tcl_AppendResult(in, "couldn't store default value in variable '", - var, "'", (char *) 0); + XOTclVarErrMsg(in, "couldn't store default value in variable '", + var, "'", (char *) NULL); } return result; } @@ -5374,10 +5624,9 @@ if (GetProcDefault(in, table, name, arg, &defVal) == TCL_OK) { result = SetProcDefault(in, var, defVal); } else { - Tcl_ResetResult(in); - Tcl_AppendResult(in, "method '", name, - "' doesn't exist or doesn't have an argument '", - arg, "'", (char *) 0); + XOTclVarErrMsg(in, "method '", name, + "' doesn't exist or doesn't have an argument '", + arg, "'", (char *) NULL); result = TCL_ERROR; } return result; @@ -5403,9 +5652,8 @@ defaultValueObjv[1] : NULL); } } - Tcl_ResetResult(in); - Tcl_AppendResult(in, "method '", procName, "' doesn't have an argument '", - arg, "'", (char *) 0); + XOTclVarErrMsg(in, "method '", procName, "' doesn't have an argument '", + arg, "'", (char *) NULL); return TCL_ERROR; } @@ -5422,7 +5670,7 @@ Tcl_SetObjResult(in, Tcl_NewStringObj(body, -1)); return TCL_OK; } - return XOTclErrBadVal(in, "a tcl method name", name); + return XOTclErrBadVal(in, "info body", "a tcl method name", name); } static int @@ -5449,9 +5697,10 @@ 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)) { - char *key = Tcl_GetHashKey(cmdTable, hPtr); + key = Tcl_GetHashKey(cmdTable, hPtr); if (!pattern || Tcl_StringMatch(key, pattern)) { if ((childobj = XOTclpGetObject(in, key)) && (!classesOnly || XOTclObjectIsClass(childobj)) && @@ -5488,7 +5737,7 @@ 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); + methodName = (char *) GetSelfProc(in); if (!methodName) methodName = ""; @@ -5519,8 +5768,9 @@ * Next in filters */ /*assert(obj->flags & XOTCL_FILTER_ORDER_VALID); *** strange, worked before ****/ - FilterComputeDefined(in, obj); + FilterComputeDefined(in, obj); + if ((obj->flags & XOTCL_FILTER_ORDER_VALID) && obj->filterStack && obj->filterStack->currentCmdPtr) { @@ -5539,7 +5789,7 @@ /*fprintf(stderr,"EndOfChain resetting cl\n");*/ } } else { - *method = (char*) Tcl_GetCommandName(in, *cmd); + *method = (char *) Tcl_GetCommandName(in, *cmd); *cl = GetClassFromFullName(in, NSCmdFullName(*cmd)); *isFilterEntry = 1; return; @@ -5552,8 +5802,13 @@ assert(obj->flags & XOTCL_MIXIN_ORDER_VALID); /* otherwise: MixinComputeDefined(in, obj); */ - if ((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; @@ -5583,7 +5838,7 @@ if (!*cmd) { - for (pl = ComputeOrder(obj->cl, Super); pl && *cl; pl = pl->next) { + for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl && *cl; pl = pl->next) { if (pl->cl == *cl) *cl = 0; } @@ -5636,17 +5891,27 @@ } cf = (Tcl_CallFrame *)((CallFrame *)cf)->callerPtr; } - + /* if (!found) { - fprintf(stderr,"found (csc->currentFramePtr %p)= %d cur level=%d\n", - csc->currentFramePtr,found,Tcl_CallFrame_level(Tcl_Interp_varFramePtr(in))); + 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); + */ /* if no args are given => use args from stack */ - if (objc < 2 && useCallstackObjs) { + if (objc < 2 && useCallstackObjs && csc->currentFramePtr) { nobjc = Tcl_CallFrame_objc(csc->currentFramePtr); nobjv = (Tcl_Obj **)Tcl_CallFrame_objv(csc->currentFramePtr); } else { @@ -5662,7 +5927,7 @@ /* fprintf(stderr, "NextSearchMethod -- RETURN: method=%s eoffc=%d,", - *method, endOfFilterChain); + *method, endOfFilterChain); if (obj) fprintf(stderr, " obj=%s,", ObjStr(obj->cmdName)); if ((*cl)) @@ -5738,21 +6003,22 @@ XOTclCallStackContent *csc = CallStackGetTopFrame(in); if (!csc->self) - return XOTclVarErrMsg(in, "next: can't find self", (char *)NULL); + return XOTclVarErrMsg(in, "next: can't find self", (char *) NULL); if (!csc->cmdPtr) return XOTclErrMsg(in, "next: no executing proc", TCL_STATIC); return XOTclNextMethod(csc->self, in, csc->cl, - (char*)Tcl_GetCommandName(in, csc->cmdPtr), objc, objv, 1); + (char *)Tcl_GetCommandName(in, csc->cmdPtr), + objc, objv, 1); } 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); + return XOTclVarErrMsg(in, "wrong # of args for __qualify", (char *) NULL); string = ObjStr(objv[1]); if (!isAbsolutePath(string)) { @@ -5762,7 +6028,8 @@ } 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; @@ -5774,20 +6041,22 @@ if (csc->self == obj) break; } if (csccontent) - return XOTclVarErrMsg(in, "__next: can't find object", ObjStr(obj->cmdName), NULL); - methodName = (char*)Tcl_GetCommandName(in, csc->cmdPtr); + 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); } +#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; - /*char *methodName;*/ if (!obj) return XOTclObjErrType(in, objv[0], "Object"); @@ -5810,8 +6079,8 @@ /*result = Tcl_EvalObjv(in, objc, ov, 0);*/ return result; } +#endif - /* * "self" object command */ @@ -5831,29 +6100,20 @@ Tcl_ResetResult(in); - methodName = (char*) GetSelfProc(in); + methodName = (char *) GetSelfProc(in); if (!methodName) return TCL_OK; NextSearchMethod(o, in, csc, &cl, &methodName, &proc, &cmd, &cp, &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); if (cmd) { - Tcl_SetObjResult(in, getFullProcQualifier(in, Tcl_GetCommandName(in, cmd), o, cl)); + Tcl_SetObjResult(in, getFullProcQualifier(in, Tcl_GetCommandName(in, cmd), + o, cl, cmd)); } return TCL_OK; } -/* -#define checkIsXOTclProcFrame(frame) \ - (((CallFrame*)frame)->isProcCallFrame && ((CallFrame*)frame)->procPtr && \ - ((CallFrame*)frame)->procPtr->cmdPtr && \ - !((CallFrame*)frame)->procPtr->cmdPtr->cmdEpoch && \ - ((CallFrame*)frame)->procPtr->cmdPtr->nsPtr && \ - ((CallFrame*)frame)->procPtr->cmdPtr->nsPtr->deleteProc == NSNamespaceDeleteProc) -*/ - - static Tcl_Obj * computeLevelObj(Tcl_Interp *in, CallStackLevel level) { XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; @@ -5889,12 +6149,13 @@ assert(option); if (isProcString(option)) { /* proc subcommand */ - char *procName = (char*) GetSelfProc(in); + 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); + } else { + return XOTclVarErrMsg(in, "Can't find proc", (char *) NULL); + } } else if (isClassString(option)) { /* class subcommand */ XOTclClass *cl = GetSelfClass(in); Tcl_SetObjResult(in, cl ? cl->object.cmdName : XOTclGlobalObjects[XOTE_EMPTY]); @@ -5934,17 +6195,17 @@ case 'c': if (!strcmp(option, "calledproc")) { if (!(csc = CallStackFindActiveFilter(in))) - return XOTclVarErrMsg(in, "self calledproc called from outside of a filter", - NULL); + return XOTclVarErrMsg(in, + "self calledproc called from outside of a filter", + (char *) NULL); Tcl_SetObjResult(in, csc->filterStackEntry->calledProc); return TCL_OK; } else if (!strcmp(option, "calledclass")) { - Tcl_ResetResult(in); - Tcl_AppendResult(in, className(FindCalledClass(in, obj)), (char*) NULL); + 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_SetResult(in, csc ? (char *)Tcl_GetCommandName(in, csc->cmdPtr) : "", TCL_VOLATILE); return TCL_OK; } else if (!strcmp(option, "callingclass")) { @@ -5956,6 +6217,9 @@ Tcl_SetObjResult(in, computeLevelObj(in, CALLING_LEVEL)); return TCL_OK; } else if (!strcmp(option, "callingobject")) { + + /*XOTclStackDump(in); XOTclCallStackDump(in);*/ + csc = XOTclCallStackFindLastInvocation(in, 1); Tcl_SetObjResult(in, csc ? csc->self->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); return TCL_OK; @@ -5964,9 +6228,11 @@ case 'f': if (!strcmp(option, "filterreg")) { - if (!(csc = CallStackFindActiveFilter(in))) - return XOTclVarErrMsg(in, "self filterreg called from outside of a filter", - NULL); + if (!(csc = CallStackFindActiveFilter(in))) { + return XOTclVarErrMsg(in, + "self filterreg called from outside of a filter", + (char *) NULL); + } Tcl_SetObjResult(in, FilterFindReg(in, obj, GetSelfProcCmdPtr(in))); return TCL_OK; } @@ -5990,15 +6256,16 @@ break; } } - return XOTclVarErrMsg(in, "unknown option '", option, "' for self", (char *)NULL); + return XOTclVarErrMsg(in, "unknown option '", option, + "' for self", (char *) NULL); } int XOTclGetSelfObjCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj; if (objc > 2) - return XOTclVarErrMsg(in, "wrong # of args for self", (char *)NULL); + return XOTclVarErrMsg(in, "wrong # of args for self", (char *) NULL); obj = GetSelfObj(in); @@ -6009,7 +6276,7 @@ Tcl_SetIntObj(Tcl_GetObjResult(in), 1); return TCL_OK; } else { - return XOTclVarErrMsg(in, "self: no current object", (char *)NULL); + return XOTclVarErrMsg(in, "self: no current object", (char *) NULL); } } @@ -6081,7 +6348,7 @@ if (obj->varTable) { TclDeleteVars(((Interp *)in), obj->varTable); - ckfree((char*)obj->varTable); + ckfree((char *)obj->varTable); /* FREE(obj->varTable, obj->varTable);*/ obj->varTable = 0; @@ -6109,7 +6376,7 @@ NonposArgsFreeTable(obj->nonposArgsTable); Tcl_DeleteHashTable(obj->nonposArgsTable); MEM_COUNT_FREE("Tcl_InitHashTable", obj->nonposArgsTable); - ckfree((char*) obj->nonposArgsTable); + ckfree((char *) obj->nonposArgsTable); MEM_COUNT_FREE("Tcl_HashTable",obj->nonposArgsTable); } @@ -6280,7 +6547,7 @@ length = strlen(name); if (!NSCheckForParent(in, name, length)) { - ckfree((char*) obj); + ckfree((char *) obj); return 0; } obj->id = Tcl_CreateObjCommand(in, name, XOTclObjDispatch, @@ -6357,7 +6624,7 @@ NonposArgsFreeTable(cl->nonposArgsTable); Tcl_DeleteHashTable(cl->nonposArgsTable); MEM_COUNT_FREE("Tcl_InitHashTable", cl->nonposArgsTable); - ckfree((char*) cl->nonposArgsTable); + ckfree((char *) cl->nonposArgsTable); MEM_COUNT_FREE("Tcl_HashTable",cl->nonposArgsTable); } @@ -6537,7 +6804,7 @@ /* check whether Object parent NS already exists, otherwise: error */ if (!NSCheckForParent(in, name, length)) { - ckfree((char*) cl); + ckfree((char *) cl); return 0; } obj->id = Tcl_CreateObjCommand(in, name, XOTclObjDispatch, @@ -6564,7 +6831,7 @@ return XOTclVarErrMsg(in, "cannot change class of object ", ObjStr(obj->cmdName), " to metaclass ", - ObjStr(cl->object.cmdName),(char *)NULL); + ObjStr(cl->object.cmdName),(char *) NULL); } (void)RemoveInstance(obj, obj->cl); AddInstance(obj, cl); @@ -6581,7 +6848,7 @@ */ static int doCleanup(Tcl_Interp *in, XOTclObject *newobj, XOTclObject *classobj, - int objc, Tcl_Obj *objv[]) { + int objc, Tcl_Obj *CONST objv[]) { int destroyed = 0, result; XOTclCallStack *cs = &RUNTIME_STATE(in)->cs; XOTclCallStackContent *csc; @@ -6619,7 +6886,7 @@ * call constructor "init", if it was not called before */ static int -doObjInitialization(Tcl_Interp *in, XOTclObject *obj, int objc, Tcl_Obj *objv[]) { +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); @@ -6638,7 +6905,7 @@ obj->flags &= ~XOTCL_INIT_CALLED; /* - * call init methods (starting with '-') + * call configure methods (starting with '-') */ result = callMethod((ClientData) obj, in, @@ -6782,9 +7049,9 @@ /* * call instdestroy for [self] */ - return XOTclCallMethodWithArg((ClientData)obj->cl, in, + return XOTclCallMethodWithArgs((ClientData)obj->cl, in, XOTclGlobalObjects[XOTE_INSTDESTROY], obj->cmdName, - objc+2, objv+1, 0); + objc, objv+1, 0); } static int @@ -6825,26 +7092,22 @@ static int XOTclOIsClassMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd, *o; 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; - if (GetXOTclObjectFromObj(in, className, &o) == TCL_OK - && XOTclObjectIsClass(o)) { - Tcl_SetIntObj(Tcl_GetObjResult(in), 1); - } else { - Tcl_SetIntObj(Tcl_GetObjResult(in), 0); - } + Tcl_SetIntObj(Tcl_GetObjResult(in), + (GetXOTclObjectFromObj(in, 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;; + XOTclObject *obj = (XOTclObject*)cd, *o; if (!obj) return XOTclObjErrType(in, objv[0], "Object"); if (objc != 2) return XOTclObjErrArgCnt(in, obj->cmdName, "isobject "); @@ -6866,12 +7129,12 @@ if (cl == RUNTIME_STATE(in)->theClass) return 1; - for (pl = ComputeOrder(cl, Super); pl; pl = pl->next) { + for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->next) { if (pl->cl == RUNTIME_STATE(in)->theClass) return 1; } - for (pl = ComputeOrder(cl, Super); pl; pl = pl->next) { + for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->next) { XOTclClassOpt* opt = pl->cl->opt; if (opt && opt->instmixins) { MixinComputeOrderFullList(in, @@ -6920,14 +7183,12 @@ static int isSubType(XOTclClass *subcl, XOTclClass *cl) { XOTclClasses *t; - int success; + int success = 1; assert(cl && subcl); - if (cl == subcl) { - success = 1; - } else { + if (cl != subcl) { success = 0; - for (t = ComputeOrder(subcl, Super); t && t->cl; t = t->next) { + for (t = ComputeOrder(subcl, subcl->order, Super); t && t->cl; t = t->next) { if (t->cl == cl) { success = 1; break; @@ -6985,35 +7246,20 @@ 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; } static int -XOTclOClassMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { +XOTclOExistsMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = (XOTclObject*)cd; - XOTclClass *cl; if (!obj) return XOTclObjErrType(in, objv[0], "Object"); - if (objc != 2) return XOTclObjErrArgCnt(in, obj->cmdName, "class "); - - /* - * allow a change to any class; type system enforces safety later - */ - if (GetXOTclClassFromObj(in, objv[1], &cl, 1) != TCL_OK) - return XOTclErrBadVal(in, "a class", ObjStr(objv[1])); - - return changeClass(in, obj, cl); -} - -static int -XOTclOExistsMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); if (objc != 2) return XOTclObjErrArgCnt(in, obj->cmdName, "exists var"); - Tcl_SetIntObj(Tcl_GetObjResult(in), varExists(in, obj, ObjStr(objv[1]),1)); + Tcl_SetIntObj(Tcl_GetObjResult(in), + varExists(in, obj, ObjStr(objv[1]),NULL, 1,1)); return TCL_OK; } @@ -7157,11 +7403,11 @@ if (withGuards == 0 && withOrder == 0) return XOTclVarErrMsg(in, "info filter: unknown modifier ", - ObjStr(objv[2]), (char *)NULL); + ObjStr(objv[2]), (char *) NULL); /* if (withGuards && withOrder) return XOTclVarErrMsg(in, "info filter: cannot use -guards and -order together", - ObjStr(objv[2]), (char *)NULL); + ObjStr(objv[2]), (char *) NULL); */ } @@ -7225,7 +7471,7 @@ if (withOrder == 0 && withGuards == 0) return XOTclVarErrMsg(in, "info mixin: unknown modifier . ", - ObjStr(objv[2]), (char *)NULL); + ObjStr(objv[2]), (char *) NULL); } if (withOrder) { @@ -7321,8 +7567,8 @@ } break; } - return XOTclErrBadVal - (in, "an info option (use 'info info' to list all info options)", cmd); + return XOTclErrBadVal(in, "info", + "an info option (use 'info info' to list all info options)", cmd); } @@ -7383,24 +7629,6 @@ return TCL_OK; } -static int -XOTclOIncrMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { - XOTclObject *obj = (XOTclObject*)cd; - XOTcl_FrameDecls; - int result; - - if (!obj) - return XOTclObjErrType(in, objv[0], "Object"); - if (objc < 2) - return XOTclObjErrArgCnt(in, obj->cmdName, "incr ?increment?"); - - XOTcl_PushFrame(in, obj); - result = XOTcl_IncrObjCmd(cd, in, objc, objv); - XOTcl_PopFrame(in, obj); - - return result; -} - Tcl_Obj* XOTclOSetInstVar(XOTcl_Object *obj, Tcl_Interp *in, Tcl_Obj *name, Tcl_Obj *value, int flgs) { @@ -7414,16 +7642,16 @@ int XOTclUnsetInstVar(XOTcl_Object *obj, Tcl_Interp *in, char *name, int flgs) { - return XOTclUnsetInstVar2 (obj, in, name,(char*)NULL, flgs); + return XOTclUnsetInstVar2 (obj, in, name,(char *)NULL, flgs); } extern int XOTclCreateObject(Tcl_Interp *in, Tcl_Obj *name, XOTcl_Class *cli) { XOTclClass *cl = (XOTclClass*) cli; int result; INCR_REF_COUNT(name); - result = XOTclCallMethodWithArg((ClientData)cl, in, - XOTclGlobalObjects[XOTE_CREATE], name, 3, 0, 0); + result = XOTclCallMethodWithArgs((ClientData)cl, in, + XOTclGlobalObjects[XOTE_CREATE], name, 1, 0, 0); DECR_REF_COUNT(name); return result; } @@ -7433,8 +7661,8 @@ XOTclClass *cl = (XOTclClass*) cli; int result; INCR_REF_COUNT(name); - result = XOTclCallMethodWithArg((ClientData)cl, in, - XOTclGlobalObjects[XOTE_CREATE], name, 3, 0, 0); + result = XOTclCallMethodWithArgs((ClientData)cl, in, + XOTclGlobalObjects[XOTE_CREATE], name, 1, 0, 0); DECR_REF_COUNT(name); return result; } @@ -7547,7 +7775,8 @@ if (otherPtr == NULL) { return XOTclVarErrMsg(in, "can't make instvar ", varName, - ": can't find variable on ", ObjStr(obj->cmdName), NULL); + ": can't find variable on ", ObjStr(obj->cmdName), + (char *) NULL); } /* @@ -7563,7 +7792,7 @@ return XOTclVarErrMsg(in, "can't make instvar ", varName, " on ", ObjStr(obj->cmdName), ": variable cannot be an element in an array;", - " use an alias or objeval.", (char *)NULL); + " use an alias or objeval.", (char *) NULL); } newName = varName; @@ -7622,7 +7851,8 @@ */ if (!new) { if (varPtr == otherPtr) - return XOTclVarErrMsg(in, "can't instvar to variable itself", (char *)NULL); + return XOTclVarErrMsg(in, "can't instvar to variable itself", + (char *) NULL); if (TclIsVarLink(varPtr)) { /* we try to make the same instvar again ... this is ok */ Var *linkPtr = varPtr->value.linkPtr; @@ -7636,16 +7866,14 @@ } /* - return XOTclVarErrMsg(in, "can't instvar to link", (char *)NULL); + return XOTclVarErrMsg(in, "can't instvar to link", (char *) NULL); */ } else if (!TclIsVarUndefined(varPtr)) { - Tcl_AppendResult(in, "variable \"", newName, - "\" already exists", (char *)NULL); - return TCL_ERROR; + return XOTclVarErrMsg(in, "variable '", newName, + "' exists already", (char *) NULL); } else if (varPtr->tracePtr != NULL) { - Tcl_AppendResult(in, "variable \"", newName, - "\" has traces: can't use for instvar", (char *) NULL); - return TCL_ERROR; + return XOTclVarErrMsg(in, "variable '", newName, + "' has traces: can't use for instvar", (char *) NULL); } } TclSetVarLink(varPtr); @@ -7657,7 +7885,7 @@ } static int -XOTclOInstVarMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]); +XOTclOInstVarMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]); extern int XOTclInstVar(XOTcl_Object *obji, Tcl_Interp *in, char *name, char *destName) { @@ -7725,82 +7953,46 @@ return (cl && cl->opt) ? cl->opt->clientData : 0; } -static int -XOTclOSetMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { - XOTclObject *obj = (XOTclObject*)cd; +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); - if (!obj) return XOTclObjErrType(in, objv[0], "Object"); + if (value == NULL) { + result = Tcl_ObjGetVar2(in, name, NULL, flags); + } else { + result = Tcl_ObjSetVar2(in, name, NULL, value, flags); + } + XOTcl_PopFrame(in, obj); - if (objc == 2) { - /*fprintf(stderr,"+++ read var '%s'\n", ObjStr(objv[1]));*/ - result = XOTclOGetInstVar2((XOTcl_Object*)obj, in, objv[1], NULL, - (TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1)); - } else if (objc == 3) { - /*fprintf(stderr,"+++ write var '%s' = '%s'\n", - ObjStr(objv[1]),ObjStr(objv[2]));*/ - result = XOTclOSetInstVar2((XOTcl_Object*)obj, in, objv[1], NULL, objv[2], - (TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1)); - } else - return XOTclObjErrArgCnt(in, obj->cmdName, "set var ?value?"); - if (result) { Tcl_SetObjResult(in, result); return TCL_OK; - } else { - return TCL_ERROR; - } + } + return TCL_ERROR; } static int -XOTclSetterMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclOSetMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = (XOTclObject*)cd; - Tcl_Obj *result; 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 (objc == 1) - result = XOTclOGetInstVar2((XOTcl_Object*)obj, in, objv[0], NULL, - (TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1)); - else if (objc == 2) - result = XOTclOSetInstVar2((XOTcl_Object*)obj, in, objv[0], NULL, objv[1], - (TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1)); - else - return XOTclObjErrArgCnt(in, obj->cmdName, " ?value?"); +static int +XOTclSetterMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj = (XOTclObject*)cd; - if (result) { - Tcl_SetObjResult(in, result); - return TCL_OK; - } else { - return XOTclVarErrMsg(in, "Can't find result of parameter ", - ObjStr(objv[0]), (char *)NULL); - } + if (!obj) return XOTclObjErrType(in, objv[0], "Object"); + if (objc > 2) XOTclObjErrArgCnt(in, obj->cmdName, "parameter ?value?"); + return setInstVar(in, obj, objv[0], objc == 2 ? objv[1] : NULL); } -/* static int */ -/* XOTclOUnsetMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { */ -/* XOTclObject *obj = (XOTclObject*)cd; */ -/* int i, result = TCL_ERROR; */ -/* XOTcl_FrameDecls; */ -/* int flgs = TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1; */ -/* if (!obj) return XOTclObjErrType(in, objv[0], "Object"); */ -/* if (objc < 2) return XOTclObjErrArgCnt(in, obj->cmdName, "unset ?vars?"); */ - -/* XOTcl_PushFrame(in, obj); */ - -/* if (obj->nsPtr) */ -/* flgs = flgs|TCL_NAMESPACE_ONLY; */ - -/* for (i=1; inr_args - 1; + char c = *element, c1; + p = element; + if (c == '%' && *(element+1) == '@') { char *remainder = NULL; long pos; @@ -7933,11 +8127,10 @@ } if (element == remainder || abs(pos) > totalargs) { return XOTclVarErrMsg(in, "forward: invalid index specified in argument ", - ObjStr(o), (char *)NULL); - } - if (!remainder || *remainder != ' ') { + ObjStr(o), (char *) NULL); + } if (!remainder || *remainder != ' ') { return XOTclVarErrMsg(in, "forward: invaild syntax in '", ObjStr(o), - "' use: %@ ",(char *)NULL); + "' use: %@ ",(char *) NULL); } element = ++remainder; @@ -7949,43 +8142,72 @@ } /*fprintf(stderr,"c==%c element = '%s'\n",c,element);*/ if (c == '%') { + Tcl_Obj *list = 0, **listElements; + int nrargs = objc-1, nrElements = 0; c = *++element; - /*fprintf(stderr,"...c==%c element = '%s'\n",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]; - /*fprintf(stderr,"+++ %%proc returns '%s'\n", ObjStr(objv[0]));*/ - } else if (c == '1' && (*(element+1) == '\0')) { - int nrargs = objc-1; + } 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 (tcd->nr_subcommands > nrargs) { + 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 */ - int rc = Tcl_ListObjIndex(in, tcd->subcommands, nrargs, out); - if (rc != TCL_OK) - return rc; + *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; } else { + /* evaluating given command */ int result; /*fprintf(stderr,"evaluating '%s'\n",element);*/ - if ((result = Tcl_Eval(in, element)) != TCL_OK) + 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; } } else { - if (p==element) + if (p == element) *out = o; else { Tcl_Obj *newarg = Tcl_NewStringObj(element,-1); @@ -8004,30 +8226,75 @@ return TCL_OK; } + +static int +callForwarder(forwardCmdClientData *tcd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { + ClientData cd; + 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 + && GetXOTclObjectFromObj(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->objscope) { + XOTcl_PopFrame(in, tcd->obj); + } + return result; +} + static int XOTclForwardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { forwardCmdClientData *tcd = (forwardCmdClientData *)cd; - XOTcl_FrameDecls; int result, j, inputarg=1, outputarg=0; if (!tcd || !tcd->obj) return XOTclObjErrType(in, 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)); */ + + + 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(int, totalargs, objvmap); ALLOC_ON_STACK(Tcl_Obj*,totalargs, OV); + ALLOC_ON_STACK(int, totalargs, objvmap); ov = &OV[1]; - for (j=0; jcs.top->currentFramePtr, - (Tcl_CallFrame *) Tcl_Interp_varFramePtr(in)); */ - - /* it is a c-method; establish a value for the currentFramePtr */ - RUNTIME_STATE(in)->cs.top->currentFramePtr = - (Tcl_CallFrame *) Tcl_Interp_varFramePtr(in); - + 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, @@ -8080,30 +8347,30 @@ fprintf(stderr,"\n"); #endif - - 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]; + 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; } - /* fprintf(stderr,"...setting at %d -> %s\n",pos,ObjStr(tmp)); */ - ov[pos] = tmp; - objvmap[pos] = -1; - } if (tcd->prefix) { /* prepend a prefix for the subcommands to avoid name clashes */ @@ -8120,37 +8387,9 @@ } #endif - if (tcd->objscope) { - /* - if (tcd->obj->nsPtr) { - Tcl_SetNamespaceResolvers(tcd->obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, - varResolver, (Tcl_ResolveCompiledVarProc*)NULL); - } - */ - XOTcl_PushFrame(in, tcd->obj); - /*fprintf(stderr,"pushing obj=%p '%s'\n",tcd->obj, tcd->obj ? ObjStr(tcd->obj->cmdName) : ""); - XOTclCallStackDump(in);*/ - } + OV[0] = tcd->cmdName; + result = callForwarder(tcd, in, objc, ov); - if (tcd->cmdName->typePtr == &XOTclObjectType - && GetXOTclObjectFromObj(in, tcd->cmdName, (void*)&cd) == TCL_OK) { - /*fprintf(stderr, "XOTcl object %s, objc=%d\n", ObjStr(tcd->cmdName),objc);*/ - result = ObjDispatch(cd, in, objc, ov, 0); - } else { - /*fprintf(stderr, "no XOTcl object %s\n", ObjStr(tcd->cmdName));*/ - OV[0] = tcd->cmdName; - result = Tcl_EvalObjv(in, objc, ov, 0); - } - - if (tcd->objscope) { - XOTcl_PopFrame(in, tcd->obj); - /* - if (tcd->obj->nsPtr) { - Tcl_SetNamespaceResolvers(tcd->obj->nsPtr, (Tcl_ResolveCmdProc*)NULL, - NULL, (Tcl_ResolveCompiledVarProc*)NULL); - } */ - } - if (tcd->prefix) {DECR_REF_COUNT(ov[1]);} exitforwardmethod: if (freeList) {DECR_REF_COUNT(freeList);} @@ -8163,7 +8402,7 @@ static int -XOTclOInstVarMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +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; @@ -8178,7 +8417,8 @@ if (!Tcl_Interp_varFramePtr(in)) { CallStackRestoreSavedFrames(in, &ctx); return XOTclVarErrMsg(in, "instvar used on ", ObjStr(obj->cmdName), - ", but callstack is not in procedure scope", NULL); + ", but callstack is not in procedure scope", + (char *) NULL); } for (i=1; icmdName), NULL); + nameString, " on ", ObjStr(obj->cmdName), + (char *) NULL); XOTcl_PushFrame(in, obj); /* @@ -8269,15 +8510,14 @@ Tcl_ResetResult(in); if (!foundEvent) { - Tcl_AppendResult(in, "can't wait for variable \"", nameString, - "\": would wait forever", (char *) NULL); - return TCL_ERROR; + return XOTclVarErrMsg(in, "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 *objv[]) { +XOTclOInvariantsMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = (XOTclObject*)cd; XOTclObjectOpt *opt; @@ -8318,13 +8558,13 @@ else return XOTclVarErrMsg(in, "Autoname failed. Probably format string (with %) was not well-formed", - NULL); + (char *) NULL); return TCL_OK; } static int -XOTclOCheckMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclOCheckMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = (XOTclObject*)cd; int ocArgs; Tcl_Obj **ovArgs; int i; @@ -8372,7 +8612,8 @@ 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); + "', valid: all pre post invar instinvar", + (char *) NULL); } Tcl_ResetResult(in); @@ -8381,35 +8622,36 @@ static int XOTclConfigureCommand(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - int bool, result = TCL_OK; - char *subcommand; - enum {CONFIGURE_FILTER, CONFIGURE_SOFTRECREATE} cmd; + 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?"); - subcommand = ObjStr(objv[1]); - if (*subcommand == 'f' && !strcmp(subcommand, "filter")) { - cmd = CONFIGURE_FILTER; - } else if (*subcommand == 's' && !strcmp(subcommand, "softrecreate")) { - cmd = CONFIGURE_SOFTRECREATE; - } else { - return XOTclObjErrType(in, objv[1], "first argument must be filter|softrecreate"); + if (Tcl_GetIndexFromObj(in, 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 (cmd) { - case CONFIGURE_FILTER: + switch (opt) { + case filterIdx: Tcl_SetBooleanObj(Tcl_GetObjResult(in), (RUNTIME_STATE(in)->doFilters)); if (objc == 3) RUNTIME_STATE(in)->doFilters = bool; break; - case CONFIGURE_SOFTRECREATE: + case softrecreateIdx: Tcl_SetBooleanObj(Tcl_GetObjResult(in), (RUNTIME_STATE(in)->doSoftrecreate)); if (objc == 3) @@ -8421,128 +8663,243 @@ } static int -XOTclSetrelationCommand(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { - int oc; Tcl_Obj **ov; +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; +} + +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 int +XOTclAliasCommand(ClientData cd, Tcl_Interp *in, + int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = NULL; XOTclClass *cl = NULL; - int i, len, result = TCL_OK; - char *reltype; - enum {mixin, filter, instmixin, instfilter} kind = 0; + Tcl_Command cmd = NULL; + Tcl_ObjCmdProc *objProc; + char allocation, *methodName, *optionName; + Tcl_CmdDeleteProc* dp = NULL; + aliasCmdClientData *tcd = NULL; + int objscope = 0, i; - if (objc < 3) - return XOTclObjErrArgCnt(in, objv[0], "::xotcl::setrelation obj ?reltype? classes"); + if (objc < 4 || objc > 6) { + return XOTclObjErrArgCnt(in, objv[0], + "| ?-objscope? ?-per-object? "); + } + + GetXOTclClassFromObj(in, objv[1], &cl, 1); + if (!cl) { + GetXOTclObjectFromObj(in, objv[1], &obj); + if (!obj) + return XOTclObjErrType(in, objv[1], "Class|Object"); + allocation = 'o'; + } else { + allocation = 'c'; + } - reltype = ObjStr(objv[2]); - len = strlen(reltype); + 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'; + } else { + return XOTclErrBadVal(in, "::xotcl::alias", + "option -objscope or -per-object", optionName); + } + } - if (*reltype == 'm' && len == 5 && !strcmp(reltype, "mixin")) { - kind = mixin; - } else if (*reltype == 'f' && len == 6 && !strcmp(reltype, "filter")) { - kind = filter; - } else if (*reltype == 'i' && len == 9 && !strcmp(reltype, "instmixin")) { - kind = instmixin; - } else if (*reltype == 'i' && len == 10 && !strcmp(reltype, "instfilter")) { - kind = instfilter; + 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 (objc>i+1) { + return XOTclVarErrMsg(in, "invalid argument '", + ObjStr(objv[i+1]), "'", (char *) NULL); + } + + 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; + } + + if (allocation == 'c') { + XOTclAddIMethod(in, (XOTcl_Class*)cl, methodName, objProc, tcd, dp); } else { - result = XOTclObjErrType(in, objv[2], "reltype (mixin, filter, instmixin, instfilter)"); - goto setrelationexit; + XOTclAddPMethod(in, (XOTcl_Object*)obj, methodName, objProc, tcd, dp); } + return TCL_OK; +} - if (kind == mixin || kind == filter) { + +static int +XOTclSetInstvarCommand(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *obj; + + if (objc < 3 || objc > 4) + return XOTclObjErrArgCnt(in, objv[0], "::xotcl::instvarset obj var ?value?"); + + GetXOTclObjectFromObj(in, objv[1], &obj); + if (!obj) return XOTclObjErrType(in, objv[0], "Object"); + + return setInstVar(in, obj ,objv[2], objc == 4 ? objv[3] : NULL); +} + + +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 + }; + + if (objc < 3) + return XOTclObjErrArgCnt(in, objv[0], "::xotcl::setrelation obj reltype classes"); + + if (Tcl_GetIndexFromObj(in, objv[2], opts, "relation type", 0, &opt) != TCL_OK) { + return TCL_ERROR; + } + + switch (opt) { + case mixinIdx: + case filterIdx: { GetXOTclObjectFromObj(in, objv[1], &obj); - if (!obj) { - result = XOTclObjErrType(in, objv[1], "Object"); - goto setrelationexit; - } - } else { + 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) { - result = XOTclObjErrType(in, objv[1], "Class"); - goto setrelationexit; + 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]); } + case classIdx: + { + GetXOTclObjectFromObj(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); + } } - /* objv[3] might be a shared object with objv[1]; we do the split later, since - GetXOTclObjectFromObj() might do some shimmering to convert the list to an object - */ - if ((result = Tcl_ListObjGetElements(in, objv[3], &oc, &ov)!= TCL_OK)) - goto setrelationexit; - - switch (kind) { - case mixin: + switch (opt) { + case mixinIdx: { - XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); - if (opt->mixins) CmdListRemoveList(&opt->mixins, GuardDel); - + 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 ((result = MixinAdd(in, &opt->mixins, ov[i])) != TCL_OK) - goto setrelationexit; + if (MixinAdd(in, &objopt->mixins, ov[i]) != TCL_OK) + return TCL_ERROR; } - + MixinComputeDefined(in, obj); FilterComputeDefined(in, obj); break; } - case filter: + case filterIdx: { - XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); - if (opt->filters) CmdListRemoveList(&obj->opt->filters, GuardDel); - + if (objopt->filters) CmdListRemoveList(&objopt->filters, GuardDel); + obj->flags &= ~XOTCL_FILTER_ORDER_VALID; for (i = 0; i < oc; i ++) { - if ((result = FilterAdd(in, &opt->filters, ov[i], obj, 0)) != TCL_OK) - goto setrelationexit; + if (FilterAdd(in, &objopt->filters, ov[i], obj, 0) != TCL_OK) + return TCL_ERROR; } /*FilterComputeDefined(in, obj);*/ break; } - case instmixin: + case instmixinIdx: { - XOTclClassOpt* opt = XOTclRequireClassOpt(cl); - if (opt->instmixins) CmdListRemoveList(&opt->instmixins, GuardDel); + if (clopt->instmixins) CmdListRemoveList(&clopt->instmixins, GuardDel); 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 ((result = MixinAdd(in, &opt->instmixins, ov[i])) != TCL_OK) - goto setrelationexit; + if (MixinAdd(in, &clopt->instmixins, ov[i]) != TCL_OK) + return TCL_ERROR; } break; } - case instfilter: + case instfilterIdx: { - XOTclClassOpt* opt = XOTclRequireClassOpt(cl); - if (opt->instfilters) CmdListRemoveList(&opt->instfilters, GuardDel); + if (clopt->instfilters) CmdListRemoveList(&clopt->instfilters, GuardDel); FilterInvalidateObjOrders(in, cl); - opt = XOTclRequireClassOpt(cl); for (i = 0; i < oc; i ++) { - if ((result = FilterAdd(in, &opt->instfilters, ov[i], 0, cl)) != TCL_OK) - goto setrelationexit; + if (FilterAdd(in, &clopt->instfilters, ov[i], 0, cl) != TCL_OK) + return TCL_ERROR; } break; } } - setrelationexit: - /*DECR_REF_COUNT(list);*/ - return result; + return TCL_OK; } static int -XOTclOMixinGuardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclOMixinGuardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = (XOTclObject*)cd; XOTclCmdList* h; XOTclObjectOpt *opt; @@ -8571,12 +8928,13 @@ } return XOTclVarErrMsg(in, "Mixinguard: can't find mixin ", - ObjStr(objv[1]), " on ", ObjStr(obj->cmdName), NULL); + ObjStr(objv[1]), " on ", ObjStr(obj->cmdName), + (char *) NULL); } static int -XOTclOFilterGuardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclOFilterGuardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = (XOTclObject*)cd; XOTclCmdList* h; XOTclObjectOpt *opt; @@ -8598,15 +8956,16 @@ } return XOTclVarErrMsg(in, "Filterguard: can't find filter ", - ObjStr(objv[1]), " on ", ObjStr(obj->cmdName), NULL); + 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 *objv[]) { +XOTclOFilterSearchMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = (XOTclObject*)cd; char *methodName, *fullName; XOTclCmdList *cmdList; @@ -8642,12 +9001,14 @@ fobj = XOTclpGetObject(in, fullName); } - Tcl_SetObjResult(in, getFullProcQualifier(in, methodName, fobj, fcl)); + Tcl_SetObjResult(in, + getFullProcQualifier(in, methodName, fobj, fcl, + cmdList->cmdPtr)); return TCL_OK; } static int -XOTclOProcSearchMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclOProcSearchMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = (XOTclObject*)cd; XOTclClass *cl = 0; Tcl_Command cmd = 0; @@ -8685,14 +9046,15 @@ char *fullName = NSCmdFullName(cmd); XOTclClass *pcl = GetClassFromFullName(in, fullName); XOTclObject *pobj = pcl ? 0 : XOTclpGetObject(in, fullName); - simpleName = (char*) Tcl_GetCommandName(in, cmd); - Tcl_SetObjResult(in, getFullProcQualifier(in, simpleName, pobj, pcl)); + simpleName = (char *) Tcl_GetCommandName(in, cmd); + Tcl_SetObjResult(in, getFullProcQualifier(in, simpleName, pobj, pcl, + cmd)); } return TCL_OK; } static int -XOTclORequireNamespaceMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclORequireNamespaceMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = (XOTclObject*)cd; if (!obj) return XOTclObjErrType(in, objv[0], "Object"); @@ -8752,7 +9114,7 @@ static int callConfigureMethod(Tcl_Interp *in, XOTclObject *obj, - char *methodName, int argc, Tcl_Obj *argv[]) { + char *methodName, int argc, Tcl_Obj *CONST argv[]) { int result; Tcl_Obj *method = Tcl_NewStringObj(methodName,-1); @@ -8770,15 +9132,15 @@ methodName, argc+1, obj, result); */ if (result != TCL_OK) { - Tcl_AppendResult(in, " during '", ObjStr(obj->cmdName), " ", - methodName, "'", 0); + XOTclVarErrMsg(in, " during '", ObjStr(obj->cmdName), " ", + methodName, "'", (char *) NULL); } return result; } static int -XOTclOConfigureMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +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; @@ -8820,10 +9182,10 @@ } default: { - Tcl_AppendResult(in, ObjStr(obj->cmdName), - " configure: unexpected argument '", ObjStr(objv[i]), - "' between parameters", 0); - return TCL_ERROR; + return XOTclVarErrMsg(in, ObjStr(obj->cmdName), + " configure: unexpected argument '", + ObjStr(objv[i]), + "' between parameters", (char *) NULL); } } } @@ -8848,7 +9210,8 @@ if (GetXOTclObjectFromObj(in, objv[1], &delobj) != TCL_OK) return XOTclVarErrMsg(in, "Can't destroy object ", - ObjStr(objv[1]), " that does not exist.", NULL); + ObjStr(objv[1]), " that does not exist.", + (char *) NULL); /* * latch, and call delete command if not already in progress */ @@ -8924,7 +9287,7 @@ static int -XOTclCAllocMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclCAllocMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclClass *cl = XOTclObjectToClass(cd); XOTclClass *newcl; XOTclObject *newobj; @@ -8975,7 +9338,8 @@ newcl = PrimitiveCCreate(in, objName, cl); if (newcl == 0) result = XOTclVarErrMsg(in, "Class alloc failed for '",objName, - "' (possibly parent namespace does not exist)", NULL); + "' (possibly parent namespace does not exist)", + (char *) NULL); else { Tcl_SetObjResult(in, newcl->object.cmdName); result = TCL_OK; @@ -8987,7 +9351,8 @@ newobj = PrimitiveOCreate(in, objName, cl); if (newobj == 0) result = XOTclVarErrMsg(in, "Object alloc failed for '",objName, - "' (possibly parent namespace does not exist)", NULL); + "' (possibly parent namespace does not exist)", + (char *) NULL); else { result = TCL_OK; Tcl_SetObjResult(in, newobj->cmdName); @@ -9006,7 +9371,7 @@ static int createMethod(Tcl_Interp *in, XOTclClass *cl, XOTclObject *obj, - int objc, Tcl_Obj *objv[]) { + int objc, Tcl_Obj *CONST objv[]) { XOTclObject *newobj = NULL; Tcl_Obj *nameObj, *tmpObj = NULL; int result; @@ -9055,7 +9420,7 @@ if (!NSCheckColons(specifiedName, 0)) { result = XOTclVarErrMsg(in, "Cannot create object -- illegal name '", - specifiedName, "'", (char *)NULL); + specifiedName, "'", (char *) NULL); goto create_method_exit; } @@ -9090,7 +9455,7 @@ static int -XOTclCCreateMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclCCreateMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclClass *cl = XOTclObjectToClass(cd); if (!cl) return XOTclObjErrType(in, objv[0], "Class"); @@ -9130,7 +9495,7 @@ static int -XOTclCNewMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclCNewMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclClass *cl = XOTclObjectToClass(cd); XOTclObject *child = NULL; Tcl_Obj *fullname; @@ -9221,7 +9586,7 @@ static int -XOTclCRecreateMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclCRecreateMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclClass *cl = XOTclObjectToClass(cd); XOTclObject *newobj; int result; @@ -9232,7 +9597,7 @@ if (GetXOTclObjectFromObj(in, objv[1], &newobj) != TCL_OK) return XOTclVarErrMsg(in, "can't recreate not existing obj ", - ObjStr(objv[1]), (char *)NULL); + ObjStr(objv[1]), (char *) NULL); INCR_REF_COUNT(objv[1]); newobj->flags |= XOTCL_RECREATE; @@ -9248,114 +9613,6 @@ } static int -XOTclCSuperClassMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); - XOTclClasses* osl = 0; - int oc; Tcl_Obj **ov; - XOTclClass **scl = 0; - int reversed = 0; - int i, j; - XOTclClasses* filterCheck; - - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc != 2) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "superclass "); - - if (Tcl_ListObjGetElements(in, objv[1], &oc, &ov)!= TCL_OK || oc==0) - return XOTclObjErrArgCnt(in, cl->object.cmdName, "superclass "); - - - filterCheck = ComputeOrder(cl, 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; - } - - /* invalidate all interceptors orders of instances of this - and of all depended classes */ - MixinInvalidateObjOrders(in, cl); - FilterInvalidateObjOrders(in, 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, "a list of classes", ObjStr(objv[1])); - } - } - - /* - * 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], Super); - if (reversed != 0) break; - while (dl != 0) { - if (dl->cl == scl[i]) break; - dl = dl->next; - } - if (dl != 0) reversed = 1; - } - } - - if (reversed != 0) { - return XOTclErrBadVal(in, "classes in dependence order", ObjStr(objv[1])); - } - - while (cl->super != 0) { - - /* - * 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); - - if (!ComputeOrder(cl, Super)) { - - /* - * 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, "a cycle-free graph", ObjStr(objv[1])); - } - XOTclFreeClasses(osl); - - /* if there are no more super classes add the Object - class as superclasses */ - if (cl->super == 0) - AddSuper(cl, RUNTIME_STATE(in)->theObject); - - Tcl_ResetResult(in); - return TCL_OK; -} - -static int XOTclCInfoMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { XOTclClass *cl = XOTclObjectToClass(cd); Tcl_Namespace *nsp; @@ -9473,7 +9730,7 @@ withGuards = checkForModifier(objv, modifiers, "-guards"); if (withGuards == 0) return XOTclVarErrMsg(in, "info instfilter: unknown modifier ", - ObjStr(objv[2]), (char *)NULL); + ObjStr(objv[2]), (char *) NULL); } return opt ? FilterInfo(in, opt->instfilters, pattern, withGuards, 0) : TCL_OK; @@ -9520,7 +9777,7 @@ withGuards = checkForModifier(objv, modifiers, "-guards"); if (withGuards == 0) return XOTclVarErrMsg(in, "info instfilter: unknown modifier ", - ObjStr(objv[2]), (char *)NULL); + ObjStr(objv[2]), (char *) NULL); } return opt ? MixinInfo(in, opt->instmixins, pattern, withGuards) : TCL_OK; @@ -9590,11 +9847,37 @@ } return TCL_OK; } else 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(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; @@ -9610,6 +9893,21 @@ 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; } @@ -9619,7 +9917,7 @@ } static int -XOTclCParameterMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclCParameterMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclClass *cl = XOTclObjectToClass(cd); Tcl_Obj **pv = 0; int elts, pc, result; @@ -9657,7 +9955,7 @@ } static int -XOTclCParameterClassMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclCParameterClassMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclClass *cl = XOTclObjectToClass(cd); char *paramClStr; XOTclClassOpt *opt; @@ -9714,22 +10012,15 @@ FREE(forwardCmdClientData, tcd); } - static int forwardProcessOptions(Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[], forwardCmdClientData **tcdp) { forwardCmdClientData *tcd; - int i, rc; + int i, rc = 0, earlybinding = 0; - rc = 0; tcd = NEW(forwardCmdClientData); - tcd->cmdName = 0; - tcd->args = 0; - tcd->nr_args = 0; - tcd->subcommands = 0; - tcd->nr_subcommands = 0; - tcd->prefix = 0; - tcd->objscope = 0; + memset(tcd, 0, sizeof(forwardCmdClientData)); + for (i=2; iobjscope = 1; + } else if (!strcmp(ObjStr(objv[i]),"-earlybinding")) { + earlybinding = 1; + } else if (!strcmp(ObjStr(objv[i]),"-verbose")) { + tcd->verbose = 1; } else { break; } } + tcd->needobjmap = 0; for (; ineedobjmap |= (*element == '%' && *(element+1) == '@'); + if (tcd->cmdName == 0) { tcd->cmdName = objv[i]; } else if (tcd->args == 0) { @@ -9767,20 +10066,39 @@ if (!tcd->cmdName) { tcd->cmdName = objv[1]; } + 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 current namespace + would lead to a recursive call; so we add the appropriate namespace */ - char * name = ObjStr(tcd->cmdName); + char *name = ObjStr(tcd->cmdName); if (!isAbsolutePath(name)) { - tcd->cmdName = NameInNamespaceObj(in, name, callingNameSpace(in) /* NULL */); + tcd->cmdName = NameInNamespaceObj(in, name, callingNameSpace(in)); + /*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(in, tcd->cmdName); + if (cmd == NULL) + return XOTclVarErrMsg(in, "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 = NULL; + } else { + tcd->cd = Tcl_Command_objClientData(cmd); + } + } + + tcd->passthrough = !tcd->args && *(ObjStr(tcd->cmdName)) != '%' && tcd->objProc != 0; + + /*fprintf(stderr, "forward args = %p, name = '%s'\n",tcd->args, ObjStr(tcd->cmdName));*/ if (rc == TCL_OK) { *tcdp = tcd; } else { @@ -9799,7 +10117,6 @@ if (!cl) return XOTclObjErrType(in, objv[0], "Class"); if (objc < 2) goto forward_argc_error; - rc = forwardProcessOptions(in, objc, objv, &tcd); if (rc == TCL_OK) { @@ -9816,7 +10133,7 @@ } static int -XOTclCForwardMethod(ClientData cd, Tcl_Interp *in, +XOTclOForwardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { XOTcl_Object *obj = (XOTcl_Object*) cd; forwardCmdClientData *tcd; @@ -9842,7 +10159,7 @@ static int -XOTclCVolatileMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { +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; @@ -9868,7 +10185,7 @@ } static int -XOTclCInstProcMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclCInstProcMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclClass *cl = XOTclObjectToClass(cd); char *argStr, *bdyStr, *name; XOTclClassOpt* opt; @@ -9893,7 +10210,7 @@ (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); + "sub-class", (char *) NULL); if (*argStr == 0 && *bdyStr == 0) { int rc; @@ -9903,7 +10220,7 @@ rc = NSDeleteCmd(in, cl->nsPtr, name); if (rc < 0) return XOTclVarErrMsg(in, className(cl), " cannot delete instproc: '", name, - "' of class ", className(cl), (char*) NULL); + "' of class ", className(cl), (char *) NULL); } else { XOTclAssertionStore* aStore = NULL; if (objc > 5) { @@ -9924,7 +10241,7 @@ static int -XOTclCInstFilterGuardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclCInstFilterGuardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclClass *cl = XOTclObjectToClass(cd); XOTclCmdList* h; XOTclClassOpt* opt; @@ -9946,12 +10263,13 @@ } return XOTclVarErrMsg(in, "Instfilterguard: can't find filter ", - ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName), NULL); + ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName), + (char *) NULL); } static int -XOTclCInstMixinGuardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclCInstMixinGuardMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclClass *cl = XOTclObjectToClass(cd); XOTclCmdList* h; @@ -9978,11 +10296,12 @@ } return XOTclVarErrMsg(in, "Instmixinguard: can't find mixin ", - ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName), NULL); + ObjStr(objv[1]), " on ", ObjStr(cl->object.cmdName), + (char *) NULL); } static int -XOTclCInvariantsMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTclCInvariantsMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { XOTclClass *cl = XOTclObjectToClass(cd); XOTclClassOpt* opt; @@ -10010,7 +10329,7 @@ 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); + ObjStr(objv[1]), "'", (char *) NULL); rc = callMethod(cd, in, XOTclGlobalObjects[XOTE_CREATE], objc+1, objv+1, 0); return rc; @@ -10039,7 +10358,7 @@ newNs = Tcl_FindNamespace(in, ObjStr(objv[2]), (Tcl_Namespace *)NULL, 0); if (!newNs) return XOTclVarErrMsg(in, "CopyCmds: Destination namespace ", - ObjStr(objv[2]), " does not exist", (char *)NULL); + ObjStr(objv[2]), " does not exist", (char *) NULL); /* * copy all procs & commands in the ns */ @@ -10055,8 +10374,8 @@ oldFullCmdName = Tcl_NewStringObj(ns->fullName,-1); INCR_REF_COUNT(newFullCmdName); INCR_REF_COUNT(oldFullCmdName); - Tcl_AppendStringsToObj(newFullCmdName, "::", name, (char*)NULL); - Tcl_AppendStringsToObj(oldFullCmdName, "::", name, (char*)NULL); + Tcl_AppendStringsToObj(newFullCmdName, "::", name, (char *) NULL); + Tcl_AppendStringsToObj(oldFullCmdName, "::", name, (char *) NULL); newName = ObjStr(newFullCmdName); oldName = ObjStr(oldFullCmdName); @@ -10087,7 +10406,8 @@ if (cmd == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(in), "can't copy ", " \"", - oldName, "\": command doesn't exist", (char *) NULL); + oldName, "\": command doesn't exist", + (char *) NULL); DECR_REF_COUNT(newFullCmdName); DECR_REF_COUNT(oldFullCmdName); return TCL_ERROR; } @@ -10115,7 +10435,8 @@ if ((GetProcDefault(in, cmdTable, name, localPtr->name, &defVal) == TCL_OK) && (defVal != 0)) { - Tcl_AppendStringsToObj(defStringObj, " ", ObjStr(defVal), 0); + Tcl_AppendStringsToObj(defStringObj, " ", ObjStr(defVal), + (char *) NULL); } Tcl_ListObjAppendElement(in, arglistObj, defStringObj); DECR_REF_COUNT(defStringObj); @@ -10137,7 +10458,7 @@ DECR_REF_COUNT(newFullCmdName); DECR_REF_COUNT(oldFullCmdName); DECR_REF_COUNT(arglistObj); - return XOTclVarErrMsg(in, "No class for inst - assertions", (char *)NULL); + return XOTclVarErrMsg(in, "No class for inst - assertions", (char *) NULL); } /* XOTcl InstProc */ @@ -10151,7 +10472,7 @@ XOTclRequireClassOpt(cl); AssertionAppendPrePost(in, dsPtr, procs); } - Tcl_Eval(in, Tcl_DStringValue(dsPtr)); + Tcl_EvalEx(in, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr),0); DSTRING_FREE(dsPtr); } else { XOTclObject *obj = XOTclpGetObject(in, ns->fullName); @@ -10163,7 +10484,7 @@ DECR_REF_COUNT(newFullCmdName); DECR_REF_COUNT(oldFullCmdName); DECR_REF_COUNT(arglistObj); - return XOTclVarErrMsg(in, "No object for assertions", (char *)NULL); + return XOTclVarErrMsg(in, "No object for assertions", (char *) NULL); } /* XOTcl Proc */ @@ -10177,14 +10498,14 @@ XOTclRequireObjectOpt(obj); AssertionAppendPrePost(in, dsPtr, procs); } - Tcl_Eval(in, Tcl_DStringValue(dsPtr)); + 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), "}", 0); + ObjStr(procPtr->bodyPtr), "}", (char *) NULL); } } else { /* @@ -10228,7 +10549,7 @@ newNs = Tcl_FindNamespace(in, ObjStr(objv[2]), (Tcl_Namespace *)NULL, 0); if (!newNs) return XOTclVarErrMsg(in, "CopyVars: Destination namespace ", - ObjStr(objv[2]), " does not exist", (char *)NULL); + ObjStr(objv[2]), " does not exist", (char *) NULL); obj = XOTclpGetObject(in, ns->fullName); varTable = Tcl_Namespace_varTable(ns); destFullName = newNs->fullName; @@ -10237,11 +10558,11 @@ obj = XOTclpGetObject(in, ObjStr(objv[1])); if (!obj) return XOTclVarErrMsg(in, "CopyVars: Origin object/namespace ", - ObjStr(objv[1]), " does not exist", (char *)NULL); + ObjStr(objv[1]), " does not exist", (char *) NULL); newObj = XOTclpGetObject(in, ObjStr(objv[2])); if (!newObj) return XOTclVarErrMsg(in, "CopyVars: Destination object/namespace ", - ObjStr(objv[2]), " does not exist", (char *)NULL); + ObjStr(objv[2]), " does not exist", (char *) NULL); varTable = obj->varTable; destFullName = ObjStr(newObj->cmdName); } @@ -10263,7 +10584,7 @@ Tcl_DStringAppendElement(dsPtr, "set"); Tcl_DStringAppendElement(dsPtr, varName); Tcl_DStringAppendElement(dsPtr, ObjStr(varPtr->value.objPtr)); - rc = Tcl_Eval(in, Tcl_DStringValue(dsPtr)); + rc = Tcl_EvalEx(in, Tcl_DStringValue(dsPtr),Tcl_DStringLength(dsPtr),0); DSTRING_FREE(dsPtr); } else { ALLOC_NAME_NS(&ds, destFullName, varName); @@ -10294,7 +10615,8 @@ Tcl_DStringAppend(ds2Ptr, ")", 1); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(ds2Ptr)); Tcl_DStringAppendElement(dsPtr, ObjStr(eltVar->value.objPtr)); - rc = Tcl_Eval(in, Tcl_DStringValue(dsPtr)); + /*fprintf(stderr,"array CP '%s'\n",Tcl_DStringValue(dsPtr));*/ + rc = Tcl_EvalEx(in, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr),0); DSTRING_FREE(dsPtr); DSTRING_FREE(ds2Ptr); } else { @@ -10322,7 +10644,7 @@ 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); + (char *) NULL); } return result; } @@ -10344,13 +10666,13 @@ if (RUNTIME_STATE(in)->cs.top->currentFramePtr == 0) { RUNTIME_STATE(in)->cs.top->currentFramePtr = varFramePtr; - } else { - /* + } /* else { + fprintf(stderr,"not overwriting currentFramePtr in %p from %p to %p\n", RUNTIME_STATE(in)->cs.top, RUNTIME_STATE(in)->cs.top->currentFramePtr, varFramePtr); - */ - } + } */ + #if !defined(NAMESPACEINSTPROCS) if (varFramePtr) { varFramePtr->nsPtr = GetCallerVarFrame(in,varFramePtr); @@ -10363,7 +10685,7 @@ * Interpretation of Non-Positional Args */ int -isNonposArg(Tcl_Interp *in, char* argStr, +isNonposArg(Tcl_Interp *in, char * argStr, int nonposArgsDefc, Tcl_Obj **nonposArgsDefv, Tcl_Obj **var, char **type) { int i, npac; @@ -10411,7 +10733,7 @@ return XOTclVarErrMsg(in, "non-positional argument: '", ObjStr(objv[1]), "' with value '", ObjStr(objv[2]), "' is not of type boolean", - NULL); + (char *) NULL); return TCL_OK; } @@ -10425,7 +10747,7 @@ if (objc != 3) return XOTclVarErrMsg(in, "required arg: '", ObjStr(objv[1]), "' missing", - NULL); + (char *) NULL); return TCL_OK; } @@ -10438,12 +10760,12 @@ int npac, checkc, checkArgc, argsc, nonposArgsDefc, ordinaryArgsDefc, defaultValueObjc, argsDefined = 0, ordinaryArgsCounter = 0, i, j, result, ic; - char* lastDefArg = NULL, *arg, *argStr; + char * lastDefArg = NULL, *arg, *argStr; int endOfNonposArgsReached = 0; Var *varPtr; XOTclClass* selfClass = GetSelfClass(in); - char* methodName = (char*) GetSelfProc(in); + char *methodName = (char *) GetSelfProc(in); Tcl_HashTable* nonposArgsTable; XOTclNonposArgs* nonposArgs; XOTclObject* selfObj; @@ -10459,29 +10781,29 @@ nonposArgsTable = selfObj->nonposArgsTable; } else { return XOTclVarErrMsg(in, "Non positional args: can't find self/self class", - NULL); + (char *) NULL); } nonposArgs = NonposArgsGet(nonposArgsTable, methodName); if (nonposArgs == 0) { return XOTclVarErrMsg(in, "Non positional args: can't find hash entry for: ", methodName, - NULL); + (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); - - + + if (r1 != TCL_OK || r2 != TCL_OK || r3 != TCL_OK) { return XOTclVarErrMsg(in, "Cannot split non positional args list: ", methodName, - NULL); + (char *) NULL); } /* setting variables to default values */ @@ -10492,7 +10814,7 @@ Tcl_ObjSetVar2(in, npav[0], 0, npav[2], 0); } else if (npac == 2 && !strcmp(ObjStr(npav[1]), "switch")) { Tcl_ObjSetVar2(in, npav[0], 0, Tcl_NewBooleanObj(0), 0); -} + } } } @@ -10524,17 +10846,28 @@ i++; if (i >= argsc) return XOTclVarErrMsg(in, "Non positional arg '", - argStr, "': value missing", NULL); + argStr, "': value missing", (char *) NULL); Tcl_SetVar2(in, ObjStr(var), 0, ObjStr(argsv[i]), 0); } } else { endOfNonposArgsReached = 1; } } - + if (endOfNonposArgsReached && i < argsc) { if (ordinaryArgsCounter >= ordinaryArgsDefc) { - return XOTclObjErrArgCnt(in, NULL, ObjStr(nonposArgs->ordinaryArgs)); + 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 */ @@ -10559,26 +10892,48 @@ ordinaryArgsCounter++; } } - if (!argsDefined) { - if (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)) { + /* we do not have enough arguments, maybe there are default arguments for the missing args */ - while (ordinaryArgsCounter != ordinaryArgsDefc) { - r4 = Tcl_ListObjGetElements(in, ordinaryArgsDefv[ordinaryArgsCounter], - &defaultValueObjc, &defaultValueObjv); - if (r4 == TCL_OK && defaultValueObjc == 2) { - Tcl_ObjSetVar2(in, defaultValueObjv[0], 0, defaultValueObjv[1], 0); - } else { - return XOTclObjErrArgCnt(in, NULL, ObjStr(nonposArgs->ordinaryArgs)); - } - ordinaryArgsCounter++; + 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", + ObjStr(ordinaryArgsDefv[ordinaryArgsCounter]), + r4,defaultValueObjc);*/ + if (r4 == TCL_OK && defaultValueObjc == 2) { + Tcl_ObjSetVar2(in, defaultValueObjv[0], 0, 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++; } - Tcl_UnsetVar2(in, "args", 0, 0); - } else if (ordinaryArgsCounter == 0) { + if (argsDefined) { + Tcl_SetVar2(in, "args", 0, "", 0); + } + } else if (argsDefined && ordinaryArgsCounter == ordinaryArgsDefc-1) { Tcl_SetVar2(in, "args", 0, "", 0); } + if (!argsDefined) { + Tcl_UnsetVar2(in, "args", 0, 0); + } + /* checking vars */ for (i=0; i < nonposArgsDefc; i++) { r1 = Tcl_ListObjGetElements(in, nonposArgsDefv[i], &npac, &npav); @@ -10622,39 +10977,43 @@ /* create a slave interp that calls XOTcl Init */ static int -XOTcl_InterpObjCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *objv[]) { +XOTcl_InterpObjCmd(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { Tcl_Interp *slave; - Tcl_Obj *saved; char *subCmd; + ALLOC_ON_STACK(Tcl_Obj*,objc, ov); - if (objc < 1) - return XOTclObjErrArgCnt(in, NULL, "::xotcl::interp name ?args?"); + memcpy(ov, objv, sizeof(Tcl_Obj *)*objc); + if (objc < 1) { + XOTclObjErrArgCnt(in, NULL, "::xotcl::interp name ?args?"); + goto interp_error; + } - saved = objv[0]; - objv[0] = XOTclGlobalObjects[XOTE_INTERP]; - if (Tcl_EvalObjv(in, objc, objv, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) != TCL_OK) { - objv[0] = saved; - return TCL_ERROR; + ov[0] = XOTclGlobalObjects[XOTE_INTERP]; + if (Tcl_EvalObjv(in, objc, ov, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) != TCL_OK) { + goto interp_error; } - objv[0] = saved; - subCmd = ObjStr(objv[1]); + subCmd = ObjStr(ov[1]); if (isCreateString(subCmd)) { - slave = Tcl_GetSlave(in, ObjStr(objv[2])); - if (!slave) - return XOTclVarErrMsg(in, "Creation of slave interpreter failed", (char*)NULL); + slave = Tcl_GetSlave(in, ObjStr(ov[2])); + if (!slave) { + XOTclVarErrMsg(in, "Creation of slave interpreter failed", (char *) NULL); + goto interp_error; + } if (Xotcl_Init(slave) == TCL_ERROR) { - return TCL_ERROR; + goto interp_error; } #ifdef XOTCL_MEM_COUNT xotclMemCountInterpCounter++; #endif } - + FREE_ON_STACK(ov); return TCL_OK; + interp_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) { @@ -11090,7 +11449,7 @@ /* create xotcl namespace */ RUNTIME_STATE(in)->XOTclNS = Tcl_CreateNamespace(in, "::xotcl", (ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL); - + MEM_COUNT_ALLOC("TclNamespace",RUNTIME_STATE(in)->XOTclNS); /* @@ -11152,23 +11511,6 @@ Tcl_Export(in, RUNTIME_STATE(in)->XOTclNS, "Class", 0); /*Tcl_AddInterpResolvers(in, "XOTcl", XOTclResolveCmd, 0, 0);*/ -#ifdef XOTCL_BYTECODE - instructions[INST_SELF].cmdPtr = (Command *) -#endif - Tcl_CreateObjCommand(in, "::xotcl::self", XOTclGetSelfObjCmd, 0, 0); -#ifdef XOTCL_BYTECODE - instructions[INST_NEXT].cmdPtr = (Command *) -#endif - Tcl_CreateObjCommand(in, "::xotcl::next", (Tcl_ObjCmdProc*) XOTclNextObjCmd, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::__qualify", (Tcl_ObjCmdProc*)XOTclQualifyObjCmd, 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); - - /* for the time being, should be registered as method "set" of :xotcl::mixin */ - Tcl_CreateObjCommand(in, "::xotcl::setrelation", XOTclSetrelationCommand, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::configure", XOTclConfigureCommand, 0, 0); - #if defined(PROFILE) XOTclProfileInit(in); #endif @@ -11192,68 +11534,95 @@ AddInstance((XOTclObject*)theobj, thecls); AddInstance((XOTclObject*)thecls, thecls); AddSuper(thecls, theobj); - - /* - * and fill them with functionality - */ - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "autoname", XOTclOAutonameMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "check", (Tcl_ObjCmdProc*)XOTclOCheckMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "class", XOTclOClassMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "cleanup", XOTclOCleanupMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "configure", (Tcl_ObjCmdProc*) XOTclOConfigureMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "destroy", XOTclODestroyMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "exists", (Tcl_ObjCmdProc*)XOTclOExistsMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "filterguard", (Tcl_ObjCmdProc*)XOTclOFilterGuardMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "filtersearch", (Tcl_ObjCmdProc*)XOTclOFilterSearchMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "incr", (Tcl_ObjCmdProc*)XOTclOIncrMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "info", XOTclOInfoMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "instvar", (Tcl_ObjCmdProc*)XOTclOInstVarMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "invar", (Tcl_ObjCmdProc*)XOTclOInvariantsMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "isclass", XOTclOIsClassMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "ismetaclass", XOTclOIsMetaClassMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "isobject", XOTclOIsObjectMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "istype", XOTclOIsTypeMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "ismixin", XOTclOIsMixinMethod, 0, 0); + { + 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 - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "metadata", (Tcl_ObjCmdProc*)XOTclOMetaDataMethod, 0, 0); + {"metadata", XOTclOMetaDataMethod}, #endif - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "mixinguard", (Tcl_ObjCmdProc*)XOTclOMixinGuardMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "__next", (Tcl_ObjCmdProc*)XOTclONextMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "next", (Tcl_ObjCmdProc*)XOTclONextMethod2, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "noinit", (Tcl_ObjCmdProc*)XOTclONoinitMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "parametercmd", (Tcl_ObjCmdProc*)XOTclCParameterCmdMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "proc", XOTclOProcMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "procsearch", (Tcl_ObjCmdProc*)XOTclOProcSearchMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "requireNamespace", (Tcl_ObjCmdProc*)XOTclORequireNamespaceMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "set", (Tcl_ObjCmdProc*)XOTclOSetMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "forward", (Tcl_ObjCmdProc*)XOTclCForwardMethod, 0, 0); - /* XOTclAddIMethod(in, (XOTcl_Class*) theobj, "unset", XOTclOUnsetMethod, 0, 0);*/ - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "uplevel", XOTclOUplevelMethod, 0,0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "upvar", XOTclOUpvarMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "volatile", (Tcl_ObjCmdProc*)XOTclCVolatileMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) theobj, "vwait", (Tcl_ObjCmdProc*)XOTclOVwaitMethod, 0, 0); + {"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} + }; + int namespacelength; + Tcl_DString ds, *dsPtr = &ds; + 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); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "alloc", (Tcl_ObjCmdProc*)XOTclCAllocMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "create", (Tcl_ObjCmdProc*)XOTclCCreateMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "new", (Tcl_ObjCmdProc*)XOTclCNewMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "info", XOTclCInfoMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "instdestroy", XOTclCInstDestroyMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "instfilterguard", (Tcl_ObjCmdProc*)XOTclCInstFilterGuardMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "instinvar", (Tcl_ObjCmdProc*)XOTclCInvariantsMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "instmixinguard", (Tcl_ObjCmdProc*)XOTclCInstMixinGuardMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "instparametercmd", (Tcl_ObjCmdProc*)XOTclCInstParameterCmdMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "instproc", (Tcl_ObjCmdProc*)XOTclCInstProcMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "instforward", (Tcl_ObjCmdProc*)XOTclCInstForwardMethod, 0, 0); + 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); + } + 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); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "parameter", (Tcl_ObjCmdProc*)XOTclCParameterMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "parameterclass", (Tcl_ObjCmdProc*)XOTclCParameterClassMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "recreate", (Tcl_ObjCmdProc*) XOTclCRecreateMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "superclass", (Tcl_ObjCmdProc*)XOTclCSuperClassMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "unknown", (Tcl_ObjCmdProc*) XOTclCUnknownMethod, 0, 0); + 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); + } - /* + DSTRING_FREE(dsPtr); + } + + /* * overwritten tcl objs */ result = XOTclShadowTclCommands(in, SHADOW_LOAD); @@ -11263,22 +11632,39 @@ /* * new tcl cmds */ - Tcl_CreateObjCommand(in, "::xotcl::interp", (Tcl_ObjCmdProc*)XOTcl_InterpObjCmd, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::trace", XOTcl_TraceObjCmd, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::namespace_copyvars", XOTcl_NSCopyVars, 0, 0); - Tcl_CreateObjCommand(in, "::xotcl::namespace_copycmds", XOTcl_NSCopyCmds, 0, 0); +#ifdef XOTCL_BYTECODE + instructions[INST_SELF_DISPATCH].cmdPtr = (Command *) +#endif + Tcl_CreateObjCommand(in, "::xotcl::my", XOTclSelfDispatchCmd, 0, 0); +#ifdef XOTCL_BYTECODE + instructions[INST_NEXT].cmdPtr = (Command *) +#endif + Tcl_CreateObjCommand(in, "::xotcl::next", XOTclNextObjCmd, 0, 0); +#ifdef XOTCL_BYTECODE + instructions[INST_SELF].cmdPtr = (Command *) +#endif + Tcl_CreateObjCommand(in, "::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); #ifdef XOTCL_BYTECODE 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); -#ifdef XOTCL_BYTECODE - instructions[INST_SELF_DISPATCH].cmdPtr = (Command *) -#endif - Tcl_CreateObjCommand(in, "::xotcl::my", XOTclSelfDispatchCmd, 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); #ifdef XOTCL_BYTECODE XOTclBytecodeInit();