Index: xotcl/generic/xotcl.c =================================================================== diff -u -r7eebad4e9179bac6fac6af582851da851ff8def6 -rf9bb662bd07a30d00a33e75ab3354bb9f8463999 --- xotcl/generic/xotcl.c (.../xotcl.c) (revision 7eebad4e9179bac6fac6af582851da851ff8def6) +++ xotcl/generic/xotcl.c (.../xotcl.c) (revision f9bb662bd07a30d00a33e75ab3354bb9f8463999) @@ -1,4 +1,4 @@ -/* $Id: xotcl.c,v 1.45 2007/08/08 01:19:06 neumann Exp $ +/* $Id: xotcl.c,v 1.46 2007/08/14 16:36:47 neumann Exp $ * * XOTcl - Extended OTcl * @@ -58,7 +58,6 @@ int xotclMemCountInterpCounter = 0; #endif - /* * Tcl_Obj Types for XOTcl Objects */ @@ -151,7 +150,6 @@ static int callDestroyMethod(ClientData cd, Tcl_Interp *in, XOTclObject *obj, int flags); -static int XOTclObjConvertObject(Tcl_Interp *in, register Tcl_Obj *objPtr, XOTclObject **obj); static XOTclObject *XOTclpGetObject(Tcl_Interp *in, char *name); static XOTclClass *XOTclpGetClass(Tcl_Interp *in, char *name); static XOTclCallStackContent* CallStackGetFrame(Tcl_Interp *in); @@ -182,7 +180,7 @@ return result; } static int -Tcl_EvalEx(Tcl_Interp *in, char *cmd, int len, int flags) { +Tcl_EvalEx(Tcl_Interp *in, char *cmd, int len, int flats) { return Tcl_Eval(in, cmd); } static int @@ -198,146 +196,7 @@ #endif -#if defined(PRE85) -/* - * for backward compatibility - */ -#define VarHashGetValue(hPtr) \ - (Var *) Tcl_GetHashValue(hPtr) -#define TclIsVarTraced(varPtr) \ - (varPtr->tracePtr != NULL) -#define VarHashTable(t) t -#define TclVarHashTable Tcl_HashTable -#define TclInitVarHashTable(tablePtr, nsPtr) \ - Tcl_InitHashTable((tablePtr), TCL_STRING_KEYS) -#define VarHashRefCount(varPtr) (varPtr)->refCount - /* - * We need NewVar from tclVar.c ... but its not exported - */ -static Var *NewVar() { - register Var *varPtr; - - varPtr = (Var *) ckalloc(sizeof(Var)); - varPtr->value.objPtr = NULL; - varPtr->name = NULL; - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE); - return varPtr; -} - -static void -TclCleanupVar(Var * varPtr, Var *arrayPtr) { - if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0) - && (varPtr->tracePtr == NULL) - && (varPtr->flags & VAR_IN_HASHTABLE)) { - if (varPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(varPtr->hPtr); - } - ckfree((char *) varPtr); - } - if (arrayPtr != NULL) { - if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0) - && (arrayPtr->tracePtr == NULL) - && (arrayPtr->flags & VAR_IN_HASHTABLE)) { - if (arrayPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(arrayPtr->hPtr); - } - ckfree((char *) arrayPtr); - } - } -} - -static inline Var * -VarHashCreateVar(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr) { - char *newName = ObjStr(key); - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tablePtr, newName, newPtr); - Var *varPtr; - - if (newPtr && *newPtr) { - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = NULL; /* a local variable */ - } else { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - } - - return varPtr; -} - -#define ObjFindNamespace(interp, objPtr) \ - Tcl_FindNamespace((interp), ObjStr(objPtr), NULL, 0); - -#else - -/* - * definitions for tcl 8.5 - */ - -#define VarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) -#define VarHashGetKey(varPtr) \ - (((VarInHash *)(varPtr))->entry.key.objPtr) -#define VarHashDeleteEntry(varPtr) \ - Tcl_DeleteHashEntry(&(((VarInHash *) varPtr)->entry)) -#define VarHashTable(varTable) \ - &(varTable)->table - -static XOTCLINLINE Var * -VarHashCreateVar(TclVarHashTable *tablePtr, Tcl_Obj *key,int *newPtr) -{ - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr, - (char *) key, newPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { - return NULL; - } -} - -XOTCLINLINE static Tcl_Namespace * -ObjFindNamespace(Tcl_Interp *interp, Tcl_Obj *objPtr) { - Tcl_Namespace *nsPtr; - - if (TclGetNamespaceFromObj(interp, objPtr, &nsPtr) == TCL_OK) { - return nsPtr; - } else { - return NULL; - } -} -#endif - - -XOTCLINLINE static Var * -lookupVarFromVarTable(TclVarHashTable *varTable, CONST char *simpleName, - XOTclObject *obj) { -#if defined(PRE85) - Var *varPtr = NULL; - Tcl_HashEntry *entryPtr; - - if (varTable) { - entryPtr = Tcl_FindHashEntry(varTable, simpleName); - if (entryPtr) { - varPtr = VarHashGetValue(entryPtr); - } - } - return varPtr; -#else - if (varTable) { - return TclVarHashFindVar(varTable, simpleName); - } - return NULL; -#endif -} - - - -/* * call an XOTcl method */ static int @@ -505,7 +364,7 @@ register char *p = string+strlen(string); while (p > string) { if (*p == ':' && *(p-1) == ':') return p+1; - p--; + *p--; } return string; } @@ -771,16 +630,17 @@ return objPtr; } +static int +GetXOTclObjectFromObj(Tcl_Interp *in, register Tcl_Obj *objPtr, XOTclObject **obj) +{ + int result; + register Tcl_ObjType *cmdType = objPtr->typePtr; #ifdef KEEP_TCL_CMD_TYPE -XOTCLINLINE static Tcl_ObjType * -GetCmdNameType(Tcl_ObjType *cmdType) { static Tcl_ObjType *tclCmdNameType = NULL; - + if (tclCmdNameType == NULL) { # if defined(PRE82) - if (cmdType - && cmdType != &XOTclObjectType - && !strcmp(cmdType->name,"cmdName")) { + if (cmdType && cmdType != &XOTclObjectType && !strcmp(cmdType->name,"cmdName")) { tclCmdNameType = cmdType; } # else @@ -791,51 +651,11 @@ XOTclMutexUnlock(&initMutex); # endif } - return tclCmdNameType; -} #endif -#if NOTUSED -static int -XOTclObjGetObject(Tcl_Interp *in, register Tcl_Obj *objPtr, XOTclObject **obj) { - int result; - register Tcl_ObjType *cmdType = objPtr->typePtr; - XOTclObject *o; - - if (cmdType == &XOTclObjectType) { - o = (XOTclObject*) objPtr->internalRep.otherValuePtr; - if (!(o->flags & XOTCL_DESTROYED)) { - *obj = o; - return TCL_OK; - } - } - - if (cmdType == GetCmdNameType(cmdType)) { - Tcl_Command cmd = Tcl_GetCommandFromObj(in, objPtr); - /*fprintf(stderr,"obj is of type tclCmd\n");*/ - if (cmd) { - o = XOTclGetObjectFromCmdPtr(cmd); - if (o) { - *obj = o; - return TCL_OK; - } - } - } - - o = XOTclpGetObject(in, ObjStr(objPtr)); - if (o) { - *obj = o; - return TCL_OK; - } - return TCL_ERROR; -} -#endif - -static int -XOTclObjConvertObject(Tcl_Interp *in, Tcl_Obj *objPtr, XOTclObject **obj) { - int result; - register Tcl_ObjType *cmdType = objPtr->typePtr; - + /* fprintf(stderr,"GetXotclObjectFromObj '%s' type=%p '%s'\n", + ObjStr(objPtr), + cmdType,cmdType? cmdType->name : "");*/ /* * Only really share the "::x" Tcl_Objs but not "x" because we so not have * references upon object kills and then will get dangling @@ -863,27 +683,27 @@ #ifdef XOTCLOBJ_TRACE if (result == TCL_OK) - fprintf(stderr,"XOTclObjConvertObject tcl %p (%d) xotcl %p (%d) r=%d %s\n", + fprintf(stderr,"GetXOTclObjectFromObj tcl %p (%d) xotcl %p (%d) r=%d %s\n", objPtr, objPtr->refCount, o, o->refCount, refetch, objPtr->bytes); else - fprintf(stderr,"XOTclObjConvertObject tcl %p (%d) **** rc=%d r=%d %s\n", + fprintf(stderr,"GetXOTclObjectFromObj tcl %p (%d) **** rc=%d r=%d %s\n", objPtr, objPtr->refCount, result, refetch, objPtr->bytes); #endif } else { result = TCL_OK; } #ifdef KEEP_TCL_CMD_TYPE - } else if (cmdType == GetCmdNameType(cmdType)) { + } else if (cmdType == tclCmdNameType) { Tcl_Command cmd = Tcl_GetCommandFromObj(in, objPtr); - /*fprintf(stderr,"obj %s is of type tclCmd, cmd=%p\n",ObjStr(objPtr),cmd);*/ + /*fprintf(stderr,"obj is of type tclCmd\n");*/ if (cmd) { XOTclObject *o = XOTclGetObjectFromCmdPtr(cmd); - /* - fprintf(stderr,"Got Object from '%s' %p\n",objPtr->bytes,o); + + /*fprintf(stderr,"Got Object from '%s' %p\n",objPtr->bytes,o); fprintf(stderr,"cmd->objProc %p == %p, proc=%p\n", Tcl_Command_objProc(cmd), XOTclObjDispatch, - Tcl_Command_proc(cmd) ); - */ + Tcl_Command_proc(cmd) );*/ + if (o) { if (obj) *obj = o; result = TCL_OK; @@ -970,7 +790,7 @@ } if (!cls) { - result = XOTclObjConvertObject(in, objPtr, &obj); + result = GetXOTclObjectFromObj(in, objPtr, &obj); if (result == TCL_OK) { cls = XOTclObjectToClass(obj); if (cls) { @@ -1368,28 +1188,52 @@ /* * Copy all obj variables to the newly created namespace */ - if (obj->varTable) { - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - TclVarHashTable *varTable = Tcl_Namespace_varTable(nsPtr); - Tcl_HashTable *varHashTable = VarHashTable(varTable); - Tcl_HashTable *objHashTable = VarHashTable(obj->varTable); + Tcl_HashSearch search; + Tcl_HashEntry *hPtr, *newHPtr; + register Var *varPtr; - *varHashTable = *objHashTable; /* copy the table */ - - if (objHashTable->buckets == objHashTable->staticBuckets) { - varHashTable->buckets = varHashTable->staticBuckets; - } - for (hPtr = Tcl_FirstHashEntry(varHashTable, &search); hPtr != NULL; + for (hPtr = Tcl_FirstHashEntry(obj->varTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { -#if defined(PRE85) - Var *varPtr = (Var *) Tcl_GetHashValue(hPtr); - varPtr->nsPtr = (Namespace *)nsPtr; -#endif - hPtr->tablePtr = varHashTable; - } + int new = 0; + char *name = Tcl_GetHashKey(obj->varTable, hPtr); + Tcl_HashTable *varTable = Tcl_Namespace_varTable(nsPtr); + varPtr = (Var *) Tcl_GetHashValue(hPtr); + + if (!name) { + panic("Can't copy: Hash Entry with no name", NULL); + continue; + } + + newHPtr = Tcl_CreateHashEntry(varTable, name, &new); + if (new) { + /* + * put var into new hashtable entry + */ + varPtr->flags |= VAR_IN_HASHTABLE; + Tcl_SetHashValue(newHPtr, varPtr); + varPtr->hPtr = newHPtr; + /* + * Mark the variable as a namespace variable + + if (!(varPtr->flags & VAR_NAMESPACE_VAR)) { + varPtr->flags |= VAR_NAMESPACE_VAR; + varPtr->refCount++; + } + */ + /* + * and correct the namespace information + */ + varPtr->nsPtr = (Namespace *)nsPtr; + } else { + panic("Can't copy varTable variable to new namespace", NULL); + } + } + /* + MEM_COUNT_FREE("obj->varTable",obj->varTable); + */ + Tcl_DeleteHashTable(obj->varTable); ckfree((char *) obj->varTable); obj->varTable = 0; } @@ -1402,9 +1246,18 @@ */ int varResolver(Tcl_Interp *in, CONST char *name, Tcl_Namespace *ns, int flags, Tcl_Var* varPtr) { - *varPtr = (Tcl_Var)lookupVarFromVarTable(Tcl_Namespace_varTable(ns), name,NULL); - /*fprintf(stderr,"lookup '%s' successful %d\n",name, *varPtr != NULL);*/ - return *varPtr ? TCL_OK : TCL_ERROR; + Tcl_HashEntry *entry; + + entry = Tcl_FindHashEntry(Tcl_Namespace_varTable(ns), name); + if (entry != NULL) { + /*fprintf(stderr,"lookup '%s' successful %d\n",name, flags);*/ + *varPtr = (Tcl_Var)Tcl_GetHashValue(entry); + return TCL_OK; + } else { + /*fprintf(stderr,"lookup '%s' failed %d\n",name, flags);*/ + *varPtr = NULL; + return TCL_ERROR; + } } @@ -1557,17 +1410,17 @@ */ static void NSCleanupNamespace(Tcl_Interp *in, Tcl_Namespace* ns) { - TclVarHashTable *varTable = Tcl_Namespace_varTable(ns); + Tcl_HashTable *varTable = Tcl_Namespace_varTable(ns); Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(ns); Tcl_HashSearch hSrch; Tcl_HashEntry* hPtr; Tcl_Command cmd; /* * Delete all variables and initialize var table again - * (deleteVars frees the vartable) + * (deletevars frees the vartable) */ TclDeleteVars((Interp *)in, varTable); - TclInitVarHashTable(varTable, (Namespace *)ns); + Tcl_InitHashTable(varTable, TCL_STRING_KEYS); /* * Delete all user-defined procs in the namespace @@ -2193,7 +2046,7 @@ register XOTclCallStackContent *top = cs->top; Tcl_CallFrame *varFramePtr = (Tcl_CallFrame *)Tcl_Interp_varFramePtr(in); - /* fprintf(stderr, "Tcl_Interp_framePtr(in) %p != varFramePtr %p && top->currentFramePtr %p\n", Tcl_Interp_framePtr(in), varFramePtr, top->currentFramePtr);*/ + /*fprintf(stderr, "Tcl_Interp_framePtr(in) %p != varFramePtr %p && top->currentFramePtr %p\n", Tcl_Interp_framePtr(in), varFramePtr, top->currentFramePtr);*/ if (Tcl_Interp_framePtr(in) != varFramePtr && top->currentFramePtr) { XOTclCallStackContent *bot = cs->content + 1; @@ -4225,30 +4078,37 @@ SearchDefaultValuesOnClass(Tcl_Interp *in, XOTclObject *obj, XOTclClass *cmdCl, XOTclClass *targetClass) { int result = TCL_OK; - Var *defaults, *initcmds; + register Tcl_HashEntry *entryPtr = 0, *initcmdsPtr = 0; + Var *defaults = 0, *initcmds = 0; Tcl_Namespace *ns = targetClass->object.nsPtr; - TclVarHashTable *varTable = ns ? Tcl_Namespace_varTable(ns) : targetClass->object.varTable; - defaults = lookupVarFromVarTable(varTable, "__defaults",(XOTclObject*)targetClass); - initcmds = lookupVarFromVarTable(varTable, "__initcmds",(XOTclObject*)targetClass); + 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)) { - TclVarHashTable *tablePtr = defaults->value.tablePtr; + Tcl_HashTable *table = defaults->value.tablePtr; Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr = tablePtr ? Tcl_FirstHashEntry(VarHashTable(tablePtr), &hSrch) : 0; + 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));*/ - /* iterate over all elements of the defaults array */ for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - Var *val = VarHashGetValue(hPtr); -#if defined(PRE85) - char *varName = Tcl_GetHashKey(tablePtr, hPtr); + char *varName = Tcl_GetHashKey(table, hPtr); Tcl_Obj *varNameObj = Tcl_NewStringObj(varName,-1); -#else - Tcl_Obj *varNameObj = VarHashGetKey(val); -#endif - + Var *val = (Var*)Tcl_GetHashValue(hPtr); INCR_REF_COUNT(varNameObj); if (TclIsVarScalar(val)) { Tcl_Obj *oldValue; @@ -4303,25 +4163,18 @@ DECR_REF_COUNT(varNameObj); } } - + if (initcmds && TclIsVarArray(initcmds)) { - TclVarHashTable *tablePtr = initcmds->value.tablePtr; + Tcl_HashTable *table = initcmds->value.tablePtr; Tcl_HashSearch hSrch; - Tcl_HashEntry* hPtr = tablePtr ? Tcl_FirstHashEntry(VarHashTable(tablePtr), &hSrch) : 0; - + Tcl_HashEntry* hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; + /*fprintf(stderr, "+++ we have initcmds for <%s>\n", className(targetClass));*/ - /* iterate over the elements of initcmds */ + for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) { - - Var *val = VarHashGetValue(hPtr); -#if defined(PRE85) - char *varName = Tcl_GetHashKey(tablePtr, hPtr); + char *varName = Tcl_GetHashKey(table, hPtr); Tcl_Obj *varNameObj = Tcl_NewStringObj(varName,-1); -#else - Tcl_Obj *varNameObj = VarHashGetKey(val); - char *varName = ObjStr(varNameObj); -#endif - + Var *val = (Var*)Tcl_GetHashValue(hPtr); INCR_REF_COUNT(varNameObj); /*fprintf(stderr,"varexists(%s->%s) = %d\n", ObjStr(obj->cmdName), @@ -4340,22 +4193,20 @@ CallStackPush(in, obj, cmdCl, 0, 1, &varNameObj, XOTCL_CSC_TYPE_PLAIN); /*allow to call self*/ - /*fprintf(stderr,"evaluating '%s' obj=%s\n\n",ObjStr(valueObj),ObjStr(obj->cmdName)); - XOTclCallStackDump(in);*/ - + /* 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) { - DECR_REF_COUNT(varNameObj); return rc; } /* fprintf(stderr,"... varexists(%s->%s) = %d\n", ObjStr(obj->cmdName), varName, varExists(in, obj, varName, NULL, 0, 0)); */ } } - DECR_REF_COUNT(varNameObj); } } return result; @@ -4407,7 +4258,7 @@ if (!cl) return XOTclObjErrType(in, objv[0], "Class"); if (objc != 2) return XOTclObjErrArgCnt(in, cl->object.cmdName, "searchDefaults obj"); - if (XOTclObjConvertObject(in, objv[1], &defaultObj) != TCL_OK) + if (GetXOTclObjectFromObj(in, objv[1], &defaultObj) != TCL_OK) return XOTclVarErrMsg(in, "Can't find default object ", ObjStr(objv[1]), (char *) NULL); @@ -5197,7 +5048,7 @@ /* arg = ObjStr(argsv[i]); fprintf(stderr, "*** argparse0 arg='%s'\n",arg);*/ rc = Tcl_ListObjGetElements(in, argsv[i], &npac, &npav); - if (rc == TCL_OK && npac > 0) { + if (rc == TCL_OK) { arg = ObjStr(npav[0]); /*fprintf(stderr, "*** argparse1 arg='%s' rc=%d\n",arg,rc);*/ if (*arg == '-') { @@ -5347,54 +5198,19 @@ return TCL_OK; } -#if !defined(PRE85) -static int -ListVarKeys(Tcl_Interp *in, Tcl_HashTable *tablePtr, char *pattern) { - Tcl_HashEntry* hPtr; - if (pattern && noMetaChars(pattern)) { - Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); - INCR_REF_COUNT(patternObj); - - hPtr = tablePtr ? Tcl_CreateHashEntry(tablePtr, (char *)patternObj, NULL) : 0; - if (hPtr) { - Var *val = VarHashGetValue(hPtr); - Tcl_SetObjResult(in, VarHashGetKey(val)); - } else { - Tcl_SetObjResult(in, XOTclGlobalObjects[XOTE_EMPTY]); - } - DECR_REF_COUNT(patternObj); - } else { - Tcl_Obj *list = Tcl_NewListObj(0, NULL); - Tcl_HashSearch hSrch; - hPtr = tablePtr ? Tcl_FirstHashEntry(tablePtr, &hSrch) : 0; - for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { - Var *val = VarHashGetValue(hPtr); - Tcl_Obj *key = VarHashGetKey(val); - if (!pattern || Tcl_StringMatch(ObjStr(key), pattern)) { - Tcl_ListObjAppendElement(in, list, key); - } - } - Tcl_SetObjResult(in, list); - } - return TCL_OK; -} -#endif - - static int ListVars(Tcl_Interp *in, XOTclObject *obj, char *pattern) { Tcl_Obj *varlist, *okList, *element; int i, length; - TclVarHashTable *varTable = obj->nsPtr ? Tcl_Namespace_varTable(obj->nsPtr) : obj->varTable; -#if defined(PRE85) - ListKeys(in, varTable, pattern); -#else - ListVarKeys(in, VarHashTable(varTable), pattern); -#endif + if (obj->nsPtr) { + Tcl_HashTable *varTable = Tcl_Namespace_varTable(obj->nsPtr); + ListKeys(in, varTable, pattern); + } else { + ListKeys(in, obj->varTable, pattern); + } varlist = Tcl_GetObjResult(in); - Tcl_ListObjLength(in, varlist, &length); okList = Tcl_NewListObj(0, NULL); for (i=0; ifilterStack != NULL) FilterStackPop(obj); - cmd = Tcl_GetCommandFromObj(in, obj->cmdName); + cmd = Tcl_FindCommand(in, ObjStr(obj->cmdName), 0, 0); if (cmd != NULL) Tcl_Command_deleteProc(cmd) = 0; @@ -7293,7 +7109,7 @@ className = (objc == 2) ? objv[1] : obj->cmdName; Tcl_SetIntObj(Tcl_GetObjResult(in), - (XOTclObjConvertObject(in, className, &o) == TCL_OK + (GetXOTclObjectFromObj(in, className, &o) == TCL_OK && XOTclObjectIsClass(o) )); return TCL_OK; } @@ -7305,7 +7121,7 @@ if (!obj) return XOTclObjErrType(in, objv[0], "Object"); if (objc != 2) return XOTclObjErrArgCnt(in, obj->cmdName, "isobject "); - if (XOTclObjConvertObject(in, objv[1], &o) == TCL_OK) { + if (GetXOTclObjectFromObj(in, objv[1], &o) == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(in), 1); } else { Tcl_SetIntObj(Tcl_GetObjResult(in), 0); @@ -7362,7 +7178,7 @@ className = (objc == 2) ? objv[1] : obj->cmdName; - if (XOTclObjConvertObject(in, className, &o) == TCL_OK + if (GetXOTclObjectFromObj(in, className, &o) == TCL_OK && XOTclObjectIsClass(o) && IsMetaClass(in, (XOTclClass*)o)) { Tcl_SetIntObj(Tcl_GetObjResult(in), 1); @@ -7904,13 +7720,54 @@ return result; } +/* + * We need NewVar from tclVar.c ... but its not exported + */ +static Var *NewVar() { + register Var *varPtr; + + varPtr = (Var *) ckalloc(sizeof(Var)); + varPtr->value.objPtr = NULL; + varPtr->name = NULL; + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE); + return varPtr; +} + +static void +CleanupVar(Var * varPtr, Var *arrayPtr) { + if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0) + && (varPtr->tracePtr == NULL) + && (varPtr->flags & VAR_IN_HASHTABLE)) { + if (varPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(varPtr->hPtr); + } + ckfree((char *) varPtr); + } + if (arrayPtr != NULL) { + if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0) + && (arrayPtr->tracePtr == NULL) + && (arrayPtr->flags & VAR_IN_HASHTABLE)) { + if (arrayPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(arrayPtr->hPtr); + } + ckfree((char *) arrayPtr); + } + } +} + static int GetInstVarIntoCurrentScope(Tcl_Interp *in, XOTclObject *obj, - Tcl_Obj *varName, Tcl_Obj *newName) { - Var *varPtr = NULL, *otherPtr = NULL, *arrayPtr; + char *varName, char *newName) { + Var *varPtr, *otherPtr = 0, *arrayPtr; int new; Tcl_CallFrame *varFramePtr; - TclVarHashTable *tablePtr; + Tcl_HashEntry *hPtr; + Tcl_HashTable *tablePtr; XOTcl_FrameDecls; int flgs = TCL_LEAVE_ERR_MSG | @@ -7921,12 +7778,12 @@ flgs = flgs|TCL_NAMESPACE_ONLY; } - otherPtr = TclObjLookupVar(in, varName, (char *) NULL, flgs, "define", + otherPtr = TclLookupVar(in, varName, (char *) NULL, flgs, "define", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); XOTcl_PopFrame(in, obj); if (otherPtr == NULL) { - return XOTclVarErrMsg(in, "can't make instvar ", ObjStr(varName), + return XOTclVarErrMsg(in, "can't make instvar ", varName, ": can't find variable on ", ObjStr(obj->cmdName), (char *) NULL); } @@ -7941,7 +7798,7 @@ * see Tcl_VariableObjCmd ... */ if (arrayPtr) { - return XOTclVarErrMsg(in, "can't make instvar ", ObjStr(varName), + 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); @@ -7957,19 +7814,20 @@ * variable linked to the new namespace variable "varName". */ if (varFramePtr != NULL && Tcl_CallFrame_isProcCallFrame(varFramePtr)) { - Proc *procPtr = Tcl_CallFrame_procPtr(varFramePtr); - int localCt = procPtr->numCompiledLocals; + Proc *procPtr = Tcl_CallFrame_procPtr(varFramePtr); + int localCt = procPtr->numCompiledLocals; CompiledLocal *localPtr = procPtr->firstLocalPtr; - Var *localVarPtr = Tcl_CallFrame_compiledLocals(varFramePtr); - char *newNameString = ObjStr(newName); - int i, nameLen = strlen(newNameString); + Var *localVarPtr = Tcl_CallFrame_compiledLocals(varFramePtr); + int nameLen = strlen(newName); + int i; + varPtr = NULL; for (i = 0; i < localCt; i++) { /* look in compiled locals */ if (!TclIsVarTemporary(localPtr)) { - char *localName = localPtr->name; - if ((newNameString[0] == localName[0]) + char *localName = localVarPtr->name; + if ((newName[0] == localName[0]) && (nameLen == localPtr->nameLength) - && (strcmp(newNameString, localName) == 0)) { + && (strcmp(newName, localName) == 0)) { varPtr = localVarPtr; new = 0; break; @@ -7982,12 +7840,19 @@ if (varPtr == NULL) { /* look in frame's local var hashtable */ tablePtr = Tcl_CallFrame_varTablePtr(varFramePtr); if (tablePtr == NULL) { - - tablePtr = (TclVarHashTable *) ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(tablePtr, NULL); + tablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); Tcl_CallFrame_varTablePtr(varFramePtr) = tablePtr; } - varPtr = VarHashCreateVar(tablePtr, newName, &new); + hPtr = Tcl_CreateHashEntry(tablePtr, newName, &new); + if (new) { + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = (Namespace *)varFramePtr->nsPtr; + } else { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + } } /* * if we define an alias (newName != varName), be sure that @@ -8004,29 +7869,26 @@ return TCL_OK; } - fprintf(stderr, "linkvar flags=%x\n",linkPtr->flags); - panic("new linkvar... When does this happen?",0); - - VarHashRefCount(otherPtr)--; + linkPtr->refCount--; if (TclIsVarUndefined(linkPtr)) { - TclCleanupVar(linkPtr, (Var *) NULL); + CleanupVar(linkPtr, (Var *) NULL); } - /* - return XOTclVarErrMsg(in, "can't link instvar", (char *) NULL); - */ + /* + return XOTclVarErrMsg(in, "can't instvar to link", (char *) NULL); + */ } else if (!TclIsVarUndefined(varPtr)) { - return XOTclVarErrMsg(in, "variable '", ObjStr(newName), + return XOTclVarErrMsg(in, "variable '", newName, "' exists already", (char *) NULL); - } else if (TclIsVarTraced(varPtr)) { - return XOTclVarErrMsg(in, "variable '", ObjStr(newName), + } else if (varPtr->tracePtr != NULL) { + return XOTclVarErrMsg(in, "variable '", newName, "' has traces: can't use for instvar", (char *) NULL); } } TclSetVarLink(varPtr); TclClearVarUndefined(varPtr); varPtr->value.linkPtr = otherPtr; - VarHashRefCount(otherPtr)++; + otherPtr->refCount++; } return TCL_OK; } @@ -8391,7 +8253,7 @@ if (tcd->objProc) { result = (tcd->objProc)(tcd->cd, in, objc, objv); } else if (tcd->cmdName->typePtr == &XOTclObjectType - && XOTclObjConvertObject(in, tcd->cmdName, (void*)&cd) == TCL_OK) { + && 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 { @@ -8571,11 +8433,11 @@ for (i=1; i 4) return XOTclObjErrArgCnt(in, objv[0], "::xotcl::instvarset obj var ?value?"); - XOTclObjConvertObject(in, objv[1], &obj); + GetXOTclObjectFromObj(in, objv[1], &obj); if (!obj) return XOTclObjErrType(in, objv[0], "Object"); return setInstVar(in, obj ,objv[2], objc == 4 ? objv[3] : NULL); @@ -8945,7 +8807,7 @@ switch (opt) { case mixinIdx: case filterIdx: { - XOTclObjConvertObject(in, objv[1], &obj); + GetXOTclObjectFromObj(in, objv[1], &obj); if (!obj) return XOTclObjErrType(in, objv[1], "Object"); if (Tcl_ListObjGetElements(in, objv[3], &oc, &ov) != TCL_OK) return TCL_ERROR; @@ -8971,7 +8833,7 @@ } case classIdx: { - XOTclObjConvertObject(in, objv[1], &obj); + 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])); @@ -9357,7 +9219,7 @@ if (objc < 2) return XOTclObjErrArgCnt(in, cl->object.cmdName, "instdestroy "); - if (XOTclObjConvertObject(in, objv[1], &delobj) != TCL_OK) + if (GetXOTclObjectFromObj(in, objv[1], &delobj) != TCL_OK) return XOTclVarErrMsg(in, "Can't destroy object ", ObjStr(objv[1]), " that does not exist.", (char *) NULL); @@ -9401,7 +9263,7 @@ ns = f->nsPtr; f = Tcl_CallFrame_callerPtr(f); } else { - ns = Tcl_GetGlobalNamespace(in); + ns = Tcl_FindNamespace(in, "::", NULL, 0); } } /*fprintf(stderr, "found ns %p '%s'\n",ns, ns?ns->fullName:"NULL");*/ @@ -9422,7 +9284,7 @@ ns, ns?ns->fullName : "" );*/ } else { /* fprintf(stderr, "nothing found, use ::\n"); */ - ns = Tcl_GetGlobalNamespace(in); + ns = Tcl_FindNamespace(in, "::", NULL, 0); } } } @@ -9450,14 +9312,14 @@ fprintf(stderr, "type(%s)=%p %s %d\n", ObjStr(objv[1]), objv[1]->typePtr, objv[1]->typePtr? objv[1]->typePtr->name:"NULL", - XOTclObjConvertObject(in, objv[1], &newobj) + GetXOTclObjectFromObj(in, objv[1], &newobj) ); /* * if the lookup via GetObject for the object succeeds, * the object exists already, * and we do not overwrite it, but re-create it */ - if (XOTclObjConvertObject(in, objv[1], &newobj) == TCL_OK) { + if (GetXOTclObjectFromObj(in, objv[1], &newobj) == TCL_OK) { fprintf(stderr, "lookup successful\n"); result = doCleanup(in, newobj, &cl->object, objc, objv); } else @@ -9580,7 +9442,7 @@ goto create_method_exit; nameObj = Tcl_GetObjResult(in); - if (XOTclObjConvertObject(in, nameObj, &newobj) != TCL_OK) { + if (GetXOTclObjectFromObj(in, nameObj, &newobj) != TCL_OK) { result = XOTclErrMsg(in, "couldn't find result of alloc", TCL_STATIC); goto create_method_exit; } @@ -9622,7 +9484,7 @@ char *result = NULL; if (RUNTIME_STATE(in)->exitHandlerDestroyRound == XOTCL_EXITHANDLER_OFF) { - if (XOTclObjConvertObject(in, obj, &o) == TCL_OK) { + if (GetXOTclObjectFromObj(in, obj, &o) == TCL_OK) { Tcl_Obj *res = Tcl_GetObjResult(in); /* save the result */ INCR_REF_COUNT(res); @@ -9665,7 +9527,7 @@ char *option = ObjStr(objv[i]); if (*option == '-' && strcmp(option,"-childof")==0 && iobject.cmdName, "recreate ?args?"); - if (XOTclObjConvertObject(in, objv[1], &newobj) != TCL_OK) + if (GetXOTclObjectFromObj(in, objv[1], &newobj) != TCL_OK) return XOTclVarErrMsg(in, "can't recreate not existing obj ", ObjStr(objv[1]), (char *) NULL); @@ -10500,11 +10362,11 @@ if (objc != 3) return XOTclObjErrArgCnt(in, NULL, "namespace_copycmds fromNs toNs"); - ns = ObjFindNamespace(in, objv[1]); + ns = Tcl_FindNamespace(in, ObjStr(objv[1]), (Tcl_Namespace *)NULL, 0); if (!ns) return TCL_OK; - newNs = ObjFindNamespace(in, objv[2]); + 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); @@ -10537,13 +10399,12 @@ if (cmd != NULL) { /*fprintf(stderr, "%s already exists\n", newName);*/ if (!XOTclpGetObject(in, newName)) { - /* command or instproc will be deleted & then copied */ + /* command or instproc will be deleted & than copied */ Tcl_DeleteCommandFromToken(in, cmd); } else { /* don't overwrite objects -> will be recreated */ hPtr = Tcl_NextHashEntry(&hSrch); - DECR_REF_COUNT(newFullCmdName); - DECR_REF_COUNT(oldFullCmdName); + DECR_REF_COUNT(newFullCmdName); DECR_REF_COUNT(oldFullCmdName); continue; } } @@ -10558,8 +10419,7 @@ Tcl_AppendStringsToObj(Tcl_GetObjResult(in), "can't copy ", " \"", oldName, "\": command doesn't exist", (char *) NULL); - DECR_REF_COUNT(newFullCmdName); - DECR_REF_COUNT(oldFullCmdName); + DECR_REF_COUNT(newFullCmdName); DECR_REF_COUNT(oldFullCmdName); return TCL_ERROR; } /* @@ -10693,136 +10553,106 @@ XOTcl_NSCopyVars(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj *CONST objv[]) { Tcl_Namespace *ns, *newNs; Var *varPtr = 0; + Tcl_DString ds, *dsPtr = &ds; Tcl_HashSearch hSrch; Tcl_HashEntry* hPtr; - TclVarHashTable *varTable; + Tcl_HashTable *varTable; int rc = TCL_OK; char *varName; XOTclObject *obj; char *destFullName; - Tcl_Obj *destFullNameObj; - Tcl_CallFrame frame; - Tcl_Obj *varNameObj = NULL; - Tcl_Obj *nobjv[4]; - int nobjc; - Tcl_Obj *setObj; - + if (objc != 3) return XOTclObjErrArgCnt(in, NULL, "namespace_copyvars fromNs toNs"); - ns = ObjFindNamespace(in, objv[1]); + ns = Tcl_FindNamespace(in, ObjStr(objv[1]), (Tcl_Namespace *)NULL, 0); if (ns) { - newNs = ObjFindNamespace(in, objv[2]); + 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); - - obj = XOTclpGetObject(in, ObjStr(objv[1])); - destFullName = newNs->fullName; - destFullNameObj = Tcl_NewStringObj(destFullName, -1); - INCR_REF_COUNT(destFullNameObj); + obj = XOTclpGetObject(in, ns->fullName); varTable = Tcl_Namespace_varTable(ns); - Tcl_PushCallFrame(in,&frame,newNs,0); + destFullName = newNs->fullName; } else { XOTclObject *newObj; - if (XOTclObjConvertObject(in, objv[1], &obj) != TCL_OK) { + obj = XOTclpGetObject(in, ObjStr(objv[1])); + if (!obj) return XOTclVarErrMsg(in, "CopyVars: Origin object/namespace ", ObjStr(objv[1]), " does not exist", (char *) NULL); - } - if (XOTclObjConvertObject(in, objv[2], &newObj) != TCL_OK) { + newObj = XOTclpGetObject(in, ObjStr(objv[2])); + if (!newObj) return XOTclVarErrMsg(in, "CopyVars: Destination object/namespace ", ObjStr(objv[2]), " does not exist", (char *) NULL); - } varTable = obj->varTable; - destFullNameObj = newObj->cmdName; - destFullName = ObjStr(destFullNameObj); + destFullName = ObjStr(newObj->cmdName); } - setObj= Tcl_NewStringObj("set", 3); - INCR_REF_COUNT(setObj); - nobjc = 4; - nobjv[0] = destFullNameObj; - nobjv[1] = setObj; - - /* copy all vars in the namespace */ - hPtr = varTable ? Tcl_FirstHashEntry(VarHashTable(varTable), &hSrch) : 0; + /* copy all vars in the ns */ + hPtr = varTable ? Tcl_FirstHashEntry(varTable, &hSrch) : 0; while (hPtr != NULL) { -#if defined(PRE85) varPtr = (Var *) Tcl_GetHashValue(hPtr); - varName = Tcl_GetHashKey(VarHashTable(varTable), hPtr); - varNameObj = Tcl_NewStringObj(varName, -1); - INCR_REF_COUNT(varNameObj); -#else - varPtr = VarHashGetValue(hPtr); - varNameObj = VarHashGetKey(varPtr); - varName = ObjStr(varNameObj); -#endif if (!TclIsVarUndefined(varPtr) && !TclIsVarLink(varPtr)) { + varName = Tcl_GetHashKey(varTable, hPtr); + if (TclIsVarScalar(varPtr)) { /* it may seem odd that we do not copy obj vars with the * same SetVar2 as normal vars, but we want to dispatch it in order to * be able to intercept the copying */ - if (obj) { - nobjv[2] = varNameObj; - nobjv[3] = varPtr->value.objPtr; - rc = Tcl_EvalObjv(in, nobjc, nobjv, 0); + DSTRING_INIT(dsPtr); + Tcl_DStringAppendElement(dsPtr, destFullName); + Tcl_DStringAppendElement(dsPtr, "set"); + Tcl_DStringAppendElement(dsPtr, varName); + Tcl_DStringAppendElement(dsPtr, ObjStr(varPtr->value.objPtr)); + rc = Tcl_EvalEx(in, Tcl_DStringValue(dsPtr),Tcl_DStringLength(dsPtr),0); + DSTRING_FREE(dsPtr); } else { - Tcl_ObjSetVar2(in, varNameObj, NULL, varPtr->value.objPtr, TCL_NAMESPACE_ONLY); + ALLOC_NAME_NS(&ds, destFullName, varName); + Tcl_SetVar2(in, Tcl_DStringValue(&ds), 0, + ObjStr(varPtr->value.objPtr), TCL_GLOBAL_ONLY); + DSTRING_FREE(&ds); } } else { if (TclIsVarArray(varPtr)) { - //// HERE!! PRE85 Why not [array get/set] based? Let the core iterate - TclVarHashTable *aTable = varPtr->value.tablePtr; + Tcl_HashTable *aTable = varPtr->value.tablePtr; Tcl_HashSearch ahSrch; - Tcl_HashEntry* ahPtr = aTable ? Tcl_FirstHashEntry(VarHashTable(aTable), &ahSrch) :0; - Tcl_Obj *eltNameObj = NULL; + Tcl_HashEntry* ahPtr = aTable ? Tcl_FirstHashEntry(aTable, &ahSrch) : 0; + for (; ahPtr != 0; ahPtr = Tcl_NextHashEntry(&ahSrch)) { - char *eltName; - Var *eltVar; -#if defined(PRE85) - eltName = Tcl_GetHashKey(VarHashTable(aTable), ahPtr); - eltVar = (Var *) Tcl_GetHashValue(ahPtr); -#else - eltVar = VarHashGetValue(ahPtr); - eltNameObj = VarHashGetKey(eltVar); - eltName = ObjStr(eltNameObj); -#endif + char *eltName = Tcl_GetHashKey(aTable, ahPtr); + Var *eltVar = (Var*) Tcl_GetHashValue(ahPtr); + if (TclIsVarScalar(eltVar)) { if (obj) { - Tcl_Obj *fullVarNameObj = Tcl_DuplicateObj(varNameObj); - - INCR_REF_COUNT(fullVarNameObj); - Tcl_AppendStringsToObj(fullVarNameObj, "(", eltName, ")", NULL); - nobjv[2] = fullVarNameObj; - nobjv[3] = eltVar->value.objPtr; - rc = Tcl_EvalObjv(in, nobjc, nobjv, 0); - DECR_REF_COUNT(fullVarNameObj); + Tcl_DString ds2, *ds2Ptr = &ds2; + DSTRING_INIT(dsPtr); + Tcl_DStringAppendElement(dsPtr, destFullName); + Tcl_DStringAppendElement(dsPtr, "set"); + DSTRING_INIT(ds2Ptr); + Tcl_DStringAppend(ds2Ptr, varName, -1); + Tcl_DStringAppend(ds2Ptr, "(", 1); + Tcl_DStringAppend(ds2Ptr, eltName, -1); + Tcl_DStringAppend(ds2Ptr, ")", 1); + Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(ds2Ptr)); + Tcl_DStringAppendElement(dsPtr, ObjStr(eltVar->value.objPtr)); + /*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 { -#if defined(PRE85) - eltNameObj = Tcl_NewStringObj(eltName, -1); - INCR_REF_COUNT(eltNameObj); -#endif - Tcl_ObjSetVar2(in, varNameObj, eltNameObj, varPtr->value.objPtr, TCL_NAMESPACE_ONLY); -#if defined(PRE85) - DECR_REF_COUNT(eltNameObj); -#endif + ALLOC_NAME_NS(&ds, destFullName, varName); + Tcl_SetVar2(in, Tcl_DStringValue(&ds), eltName, + ObjStr(eltVar->value.objPtr), TCL_GLOBAL_ONLY); + DSTRING_FREE(&ds); } } } } } } -#if defined(PRE85) - DECR_REF_COUNT(varNameObj); -#endif hPtr = Tcl_NextHashEntry(&hSrch); } - if (ns) { - DECR_REF_COUNT(destFullNameObj); - Tcl_PopCallFrame(in); - } - DECR_REF_COUNT(setObj); return rc; } @@ -11002,9 +10832,9 @@ r1 = Tcl_ListObjGetElements(in, nonposArgsDefv[i], &npac, &npav); if (r1 == TCL_OK) { if (npac == 3) { - Tcl_ObjSetVar2(in, npav[0], NULL, npav[2], 0); + Tcl_SetVar2Ex(in, ObjStr(npav[0]), NULL, npav[2], 0); } else if (npac == 2 && !strcmp(ObjStr(npav[1]), "switch")) { - Tcl_ObjSetVar2(in, npav[0], NULL, Tcl_NewBooleanObj(0), 0); + Tcl_SetVar2Ex(in, ObjStr(npav[0]), NULL, Tcl_NewBooleanObj(0), 0); } } } @@ -11031,18 +10861,14 @@ if (isNonposArg(in, argStr, nonposArgsDefc, nonposArgsDefv, &var,&type)) { if (*type == 's' && !strcmp(type, "switch")) { int bool; - Tcl_Obj *boolObj = Tcl_ObjGetVar2(in, var, 0, 0); - if (Tcl_GetBooleanFromObj(in, boolObj, &bool) != TCL_OK) { - return XOTclVarErrMsg(in, "Non positional arg '",argStr, - "': no boolean value", (char *) NULL); - } - Tcl_ObjSetVar2(in, var, NULL, boolObj, 0); + Tcl_GetBooleanFromObj(in, Tcl_ObjGetVar2(in, var, 0, 0), &bool); + Tcl_SetVar2(in, ObjStr(var), 0, bool ? "0" : "1", 0); } else { i++; if (i >= argsc) return XOTclVarErrMsg(in, "Non positional arg '", argStr, "': value missing", (char *) NULL); - Tcl_ObjSetVar2(in, var, NULL, argsv[i], 0); + Tcl_SetVar2Ex(in, ObjStr(var), NULL, argsv[i], 0); } } else { endOfNonposArgsReached = 1; @@ -11071,7 +10897,7 @@ INCR_REF_COUNT(list); for(; i < argsc; i++) Tcl_ListObjAppendElement(in, list, argsv[i]); - Tcl_ObjSetVar2(in, ordinaryArgsDefv[ordinaryArgsCounter], NULL, list, 0); + Tcl_SetVar2Ex(in, ObjStr(ordinaryArgsDefv[ordinaryArgsCounter]), NULL, list, 0); DECR_REF_COUNT(list); } else { /* break down this argument, if it has a default value, @@ -11082,7 +10908,7 @@ if (r4 == TCL_OK && defaultValueObjc == 2) { ordinaryArg = defaultValueObjv[0]; } - Tcl_ObjSetVar2(in, ordinaryArg, NULL, argsv[i], 0); + Tcl_SetVar2Ex(in, ObjStr(ordinaryArg), NULL, argsv[i], 0); } ordinaryArgsCounter++; } @@ -11106,7 +10932,7 @@ ObjStr(ordinaryArgsDefv[ordinaryArgsCounter]), r4,defaultValueObjc);*/ if (r4 == TCL_OK && defaultValueObjc == 2) { - Tcl_ObjSetVar2(in, defaultValueObjv[0], NULL, defaultValueObjv[1], 0); + Tcl_SetVar2Ex(in, ObjStr(defaultValueObjv[0]), NULL, defaultValueObjv[1], 0); } else { Tcl_Obj *tmp = NonposArgsFormat(in, nonposArgs->nonposArgs); XOTclVarErrMsg(in, "wrong # args for method '", @@ -11891,15 +11717,10 @@ /* * Parameter Class */ - { - XOTclObject *paramObject; - paramCl = PrimitiveCCreate(in, XOTclGlobalStrings[XOTE_PARAM_CL], thecls); - paramObject = ¶mCl->object; - XOTclAddPMethod(in, (XOTcl_Object*) paramObject, + paramCl = PrimitiveCCreate(in, XOTclGlobalStrings[XOTE_PARAM_CL], thecls); + XOTclAddPMethod(in, (XOTcl_Object*) ¶mCl->object, XOTclGlobalStrings[XOTE_SEARCH_DEFAULTS], (Tcl_ObjCmdProc*) ParameterSearchDefaultsMethod, 0, 0); - } - /* * set runtime version information in Tcl variable */