From 044f0ead3d698c920cda0d202cfae25a0119c9bd Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Dec 2015 18:27:23 +0000 Subject: [593baa032c] Possible fix (with test) for segfault in superclass teardown. --- generic/tclOO.c | 29 ++++++++++++++++++++--------- tests/oo.test | 7 +++++++ 2 files changed, 27 insertions(+), 9 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 5fca220..f2e0ca9 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -58,6 +58,7 @@ static const struct { static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, const char *nsNameStr); +static void ClearSuperclasses(Class *clsPtr); static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method *mPtr, Tcl_Obj *namePtr, Method **newMPtrPtr); @@ -905,6 +906,20 @@ ObjectRenamedTrace( */ static void +ClearSuperclasses( + Class *clsPtr) +{ + int i; + Class *superPtr; + + FOREACH(superPtr, clsPtr->superclasses) { + TclOORemoveFromSubclasses(clsPtr, superPtr); + } + ckfree(clsPtr->superclasses.list); + clsPtr->superclasses.num = 0; +} + +static void ReleaseClassContents( Tcl_Interp *interp, /* The interpreter containing the class. */ Object *oPtr) /* The object representing the class. */ @@ -999,6 +1014,9 @@ ReleaseClassContents( if (!Deleted(subclassPtr->thisPtr)) { Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); } + if (subclassPtr->superclasses.num) { + ClearSuperclasses(subclassPtr); + } DelRef(subclassPtr->thisPtr); DelRef(subclassPtr); } @@ -1195,7 +1213,6 @@ ObjectNamespaceDeleted( } if (clsPtr != NULL) { - Class *superPtr; Tcl_ObjectMetadataType *metadataTypePtr; ClientData value; @@ -1224,14 +1241,8 @@ ObjectNamespaceDeleted( ckfree(clsPtr->mixins.list); clsPtr->mixins.num = 0; } - FOREACH(superPtr, clsPtr->superclasses) { - if (!Deleted(superPtr->thisPtr)) { - TclOORemoveFromSubclasses(clsPtr, superPtr); - } - } - if (i) { - ckfree(clsPtr->superclasses.list); - clsPtr->superclasses.num = 0; + if (clsPtr->superclasses.num) { + ClearSuperclasses(clsPtr); } if (clsPtr->subclasses.list) { ckfree(clsPtr->subclasses.list); diff --git a/tests/oo.test b/tests/oo.test index 2112f10..ca5c7f9 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3671,6 +3671,13 @@ test oo-35.2 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { unset -nocomplain result fruitMetaclass destroy } -result {::appleClass ::orange ::oo::class ::oo::class 1 1 ::appleClass ::pear} +test oo-35.3 {Bug 593baa032c: superclass list teardown} { + # Bug makes this crash, especially with mem-debugging on + oo::class create B {} + oo::class create D {superclass B} + namespace eval [info object namespace D] [list [namespace which B] destroy] +} {} + cleanupTests return -- cgit v0.12 From be81d9e9777a4fb2e009987d81a9e82471974142 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Dec 2015 19:50:04 +0000 Subject: [593baa032c] Additional fix for the mixinSubs list. --- generic/tclOO.c | 29 +++++++++++++++++++++-------- tests/oo.test | 6 ++++++ 2 files changed, 27 insertions(+), 8 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index f2e0ca9..34eb5ad 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -58,6 +58,7 @@ static const struct { static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, const char *nsNameStr); +static void ClearMixins(Class *clsPtr); static void ClearSuperclasses(Class *clsPtr); static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method *mPtr, Tcl_Obj *namePtr, @@ -906,6 +907,20 @@ ObjectRenamedTrace( */ static void +ClearMixins( + Class *clsPtr) +{ + int i; + Class *mixinPtr; + + FOREACH(mixinPtr, clsPtr->mixins) { + TclOORemoveFromMixinSubs(clsPtr, mixinPtr); + } + ckfree(clsPtr->mixins.list); + clsPtr->mixins.num = 0; +} + +static void ClearSuperclasses( Class *clsPtr) { @@ -994,6 +1009,9 @@ ReleaseClassContents( Tcl_DeleteCommandFromToken(interp, mixinSubclassPtr->thisPtr->command); } + if (mixinSubclassPtr->mixins.num) { + ClearMixins(mixinSubclassPtr); + } DelRef(mixinSubclassPtr->thisPtr); DelRef(mixinSubclassPtr); } @@ -1232,14 +1250,9 @@ ObjectNamespaceDeleted( ckfree(clsPtr->filters.list); clsPtr->filters.num = 0; } - FOREACH(mixinPtr, clsPtr->mixins) { - if (!Deleted(mixinPtr->thisPtr)) { - TclOORemoveFromMixinSubs(clsPtr, mixinPtr); - } - } - if (i) { - ckfree(clsPtr->mixins.list); - clsPtr->mixins.num = 0; + + if (clsPtr->mixins.num) { + ClearMixins(clsPtr); } if (clsPtr->superclasses.num) { ClearSuperclasses(clsPtr); diff --git a/tests/oo.test b/tests/oo.test index ca5c7f9..895f7ed 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3677,6 +3677,12 @@ test oo-35.3 {Bug 593baa032c: superclass list teardown} { oo::class create D {superclass B} namespace eval [info object namespace D] [list [namespace which B] destroy] } {} +test oo-35.4 {Bug 593baa032c: mixins list teardown} { + # Bug makes this crash, especially with mem-debugging on + oo::class create B {} + oo::class create D {mixin B} + namespace eval [info object namespace D] [list [namespace which B] destroy] +} {} cleanupTests -- cgit v0.12 From f6bb864fc7610c6c893acee7b4a7604a287e6018 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Jan 2016 09:28:55 +0000 Subject: Minor tweaks in documentation/testcases. Don't use deprecated Tcl methods any more --- doc/zipfs.n | 4 ++-- generic/zipfs.c | 10 +++++----- tests/zipfs.test | 2 +- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/zipfs.n b/doc/zipfs.n index b21ad57..d16c047 100644 --- a/doc/zipfs.n +++ b/doc/zipfs.n @@ -22,7 +22,7 @@ zipfs \- Mount and work with ZIP files within Tcl \fB::zipfs::mkimg\fR \fIoutfile\fR \fIindir\fR \fI?strip?\fR \fI?password?\fR \fI?infile?\fR \fB::zipfs::mkkey\fR \fIpassword\fR \fB::zipfs::mkzip\fR \fIoutfile\fR \fIindir\fR \fI?strip?\fR \fI?password?\fR -\fB::zipfs::mount\fR \fI?zipfile\fR \fI?mountpoint?\fR \fI?password?\fR +\fB::zipfs::mount\fR \fI?zipfile?\fR \fI?mountpoint?\fR \fI?password?\fR \fB::zipfs::unmount\fR \fIzipfile\fR .fi .BE @@ -94,7 +94,7 @@ Caution: the choice of the \fIindir\fR parameter archive's content. .RE .TP -\fB::zipfs::mount ?\fIzipfile\fR? ?\fImountpoint\fR? +\fB::zipfs::mount ?\fIzipfile\fR? ?\fImountpoint\fR? ?\fIpassword\fR? . The \fB::zipfs::mount\fR command mounts a ZIP archive file as a VFS. After this command executes, files contained in \fIzipfile\fR diff --git a/generic/zipfs.c b/generic/zipfs.c index 55c6d2c..e789e14 100644 --- a/generic/zipfs.c +++ b/generic/zipfs.c @@ -1507,7 +1507,7 @@ ZipFSMountObjCmd(ClientData clientData, Tcl_Interp *interp, { if (objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "?zipfile mountpoint password?"); + "?zipfile? ?mountpoint? ?password?"); return TCL_ERROR; } return Tclzipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL, @@ -1729,7 +1729,7 @@ wrerr: init_keys(passwd, keys, crc32tab); for (i = 0; i < 12 - 2; i++) { - if (Tcl_Eval(interp, "expr int(rand() * 256) % 256") != TCL_OK) { + if (Tcl_EvalEx(interp, "expr int(rand() * 256) % 256", -1, 0) != TCL_OK) { Tcl_AppendResult(interp, "PRNG error", (char *) NULL); Tcl_Close(interp, in); return TCL_ERROR; @@ -1966,8 +1966,8 @@ ZipFSMkZipOrImgObjCmd(ClientData clientData, Tcl_Interp *interp, } else { if ((objc < 3) || (objc > (isImg ? 6 : 5))) { Tcl_WrongNumArgs(interp, 1, objv, isImg ? - "outfile indir ?strip password infile?" : - "outfile indir ?strip password?"); + "outfile indir ?strip? ?password? ?infile?" : + "outfile indir ?strip? ?password?"); return TCL_ERROR; } } @@ -4009,7 +4009,7 @@ Zipfs_doInit(Tcl_Interp *interp, int safe) ZipFSLMkImgObjCmd, 0, 0); Tcl_CreateObjCommand(interp, "::zipfs::lmkzip", ZipFSLMkZipObjCmd, 0, 0); - Tcl_GlobalEval(interp, findproc); + Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); } Tcl_CreateObjCommand(interp, "::zipfs::exists", ZipFSExistsObjCmd, 0, 0); Tcl_CreateObjCommand(interp, "::zipfs::info", ZipFSInfoObjCmd, 0, 0); diff --git a/tests/zipfs.test b/tests/zipfs.test index 3f53cf8..189461a 100644 --- a/tests/zipfs.test +++ b/tests/zipfs.test @@ -27,7 +27,7 @@ test zipfs-1.2 {zipfs basics} -constraints zipfs -body { test zipfs-1.3 {zipfs basics} -constraints zipfs -returnCodes error -body { ::zipfs::mount a b c d e f -} -result {wrong # args: should be "::zipfs::mount ?zipfile ?mountpoint? ?password???"} +} -result {wrong # args: should be "::zipfs::mount ?zipfile? ?mountpoint? ?password?"} test zipfs-1.4 {zipfs basics} -constraints zipfs -returnCodes error -body { ::zipfs::unmount a b c d e f -- cgit v0.12 From 76cf0cf48d120594a02f8b1ce0f8f8fb2969e7e7 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 18 Jan 2016 10:16:35 +0000 Subject: Put the file location information that Tcl has into the disassembled code. Important for tclquadcode. --- generic/tclDisassemble.c | 99 +++++++++++++++++++++++++++++++++++++++++++----- generic/tclInt.h | 3 +- tests/compile.test | 42 ++++++++++++++++++-- 3 files changed, 131 insertions(+), 13 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 86f0e1d..a60a58d 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -21,9 +21,13 @@ * Prototypes for procedures defined later in this file: */ -static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Obj *objPtr); +static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Interp *interp, + Tcl_Obj *objPtr); static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); +static void GetLocationInformation(Tcl_Interp *interp, + Proc *procPtr, Tcl_Obj **fileObjPtr, + int *linePtr); static void PrintSourceToObj(Tcl_Obj *appendObj, const char *stringPtr, int maxChars); static void UpdateStringOfInstName(Tcl_Obj *objPtr); @@ -48,6 +52,57 @@ static const Tcl_ObjType tclInstNameType = { #define BYTECODE(objPtr) \ ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1) +/* + *---------------------------------------------------------------------- + * + * GetLocationInformation -- + * + * This procedure looks up the information about where a procedure was + * originally declared. + * + * Results: + * Writes to the variables pointed at by fileObjPtr and linePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +GetLocationInformation( + Tcl_Interp *interp, /* Where to look up the location + * information. */ + Proc *procPtr, /* What to look up the information for. */ + Tcl_Obj **fileObjPtr, /* Where to write the information about what + * file the code came from. Will be written + * to, either with the object (assume shared!) + * that describes what the file was, or with + * NULL if the information is not + * available. */ + int *linePtr) /* Where to write the information about what + * line number represented the start of the + * code in question. Will be written to, + * either with the line number or with -1 if + * the information is not available. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hePtr; + CmdFrame *cfPtr; + + *fileObjPtr = NULL; + *linePtr = -1; + if (iPtr != NULL && procPtr != NULL) { + hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, procPtr); + if (hePtr != NULL && (cfPtr = Tcl_GetHashValue(hePtr)) != NULL) { + *linePtr = cfPtr->line[0]; + if (cfPtr->type == TCL_LOCATION_SOURCE) { + *fileObjPtr = cfPtr->data.eval.path; + } + } + } +} + #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- @@ -68,10 +123,10 @@ static const Tcl_ObjType tclInstNameType = { void TclPrintByteCodeObj( - Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ + Tcl_Interp *interp, /* Used only for getting location info. */ Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); + Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(interp, objPtr); fprintf(stdout, "\n%s", TclGetString(bufPtr)); Tcl_DecrRefCount(bufPtr); @@ -187,15 +242,16 @@ TclPrintSource( Tcl_Obj * TclDisassembleByteCodeObj( + Tcl_Interp *interp, Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { ByteCode *codePtr = BYTECODE(objPtr); unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; - int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; + int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line; Interp *iPtr = (Interp *) *codePtr->interpHandle; - Tcl_Obj *bufferObj; + Tcl_Obj *bufferObj, *fileObj; char ptrBuf1[20], ptrBuf2[20]; TclNewObj(bufferObj); @@ -220,6 +276,11 @@ TclDisassembleByteCodeObj( Tcl_AppendToObj(bufferObj, " Source ", -1); PrintSourceToObj(bufferObj, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); + GetLocationInformation(interp, codePtr->procPtr, &fileObj, &line); + if (line > -1 && fileObj != NULL) { + Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", + Tcl_GetString(fileObj), line); + } Tcl_AppendPrintfToObj(bufferObj, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, @@ -881,14 +942,16 @@ PrintSourceToObj( static Tcl_Obj * DisassembleByteCodeAsDicts( + Tcl_Interp *interp, /* Used for looking up the CmdFrame for the + * procedure, if one exists. */ Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ { ByteCode *codePtr = BYTECODE(objPtr); Tcl_Obj *description, *literals, *variables, *instructions, *inst; - Tcl_Obj *aux, *exn, *commands; + Tcl_Obj *aux, *exn, *commands, *file; unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; int codeOffset, codeLength, sourceOffset, sourceLength; - int i, val; + int i, val, line; /* * Get the literals from the bytecode. @@ -1152,6 +1215,13 @@ DisassembleByteCodeAsDicts( #undef Decode /* + * Get the source file and line number information from the CmdFrame + * system if it is available. + */ + + GetLocationInformation(interp, codePtr->procPtr, &file, &line); + + /* * Build the overall result. */ @@ -1174,6 +1244,15 @@ DisassembleByteCodeAsDicts( Tcl_NewIntObj(codePtr->maxStackDepth)); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1), Tcl_NewIntObj(codePtr->maxExceptDepth)); + if (line > -1) { + Tcl_DictObjPut(NULL, description, + Tcl_NewStringObj("initiallinenumber", -1), + Tcl_NewIntObj(line)); + } + if (file) { + Tcl_DictObjPut(NULL, description, + Tcl_NewStringObj("sourcefile", -1), file); + } return description; } @@ -1403,9 +1482,11 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } if (PTR2INT(clientData)) { - Tcl_SetObjResult(interp, DisassembleByteCodeAsDicts(codeObjPtr)); + Tcl_SetObjResult(interp, + DisassembleByteCodeAsDicts(interp, codeObjPtr)); } else { - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); + Tcl_SetObjResult(interp, + TclDisassembleByteCodeObj(interp, codeObjPtr)); } return TCL_OK; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 082fab4..9a5b4bf 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3152,7 +3152,8 @@ MODULE_SCOPE void TclFinalizeThreadStorage(void); MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); #endif -MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr); +MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); diff --git a/tests/compile.test b/tests/compile.test index d4a31d4..46e678a 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -765,7 +765,7 @@ test compile-18.24 {disassembler - basics} -returnCodes error -body { } -result "can't interpret \"\{\" as a lambda expression" test compile-18.25 {disassembler - basics} -body { dict keys [tcl::unsupported::getbytecode lambda {{} {}}] -} -result $bytecodekeys +} -result "$bytecodekeys initiallinenumber sourcefile" test compile-18.26 {disassembler - basics} -returnCodes error -body { tcl::unsupported::getbytecode proc } -match glob -result {wrong # args: should be "* proc procName"} @@ -778,7 +778,43 @@ test compile-18.28 {disassembler - basics} -setup { dict keys [tcl::unsupported::getbytecode proc chewonthis] } -cleanup { rename chewonthis {} +} -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.28.1 {disassembler - tricky bit} -setup { + eval [list proc chewonthis {} {}] +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename chewonthis {} +} -result $bytecodekeys +test compile-18.28.2 {disassembler - tricky bit} -setup { + eval {proc chewonthis {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename chewonthis {} +} -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.28.3 {disassembler - tricky bit} -setup { + proc Proc {n a b} { + proc $n $a $b + } + Proc chewonthis {} {} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename Proc {} + rename chewonthis {} } -result $bytecodekeys +test compile-18.28.4 {disassembler - tricky bit} -setup { + proc Proc {n a b} { + tailcall proc $n $a $b + } + Proc chewonthis {} {} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename Proc {} + rename chewonthis {} +} -result "$bytecodekeys initiallinenumber sourcefile" test compile-18.29 {disassembler - basics} -returnCodes error -body { tcl::unsupported::getbytecode script } -match glob -result {wrong # args: should be "* script script"} @@ -807,7 +843,7 @@ test compile-18.35 {disassembler - basics} -setup { dict keys [tcl::unsupported::getbytecode method foo bar] } -cleanup { foo destroy -} -result $bytecodekeys +} -result "$bytecodekeys initiallinenumber sourcefile" test compile-18.36 {disassembler - basics} -returnCodes error -body { tcl::unsupported::getbytecode objmethod } -match glob -result {wrong # args: should be "* objmethod objectName methodName"} @@ -824,7 +860,7 @@ test compile-18.39 {disassembler - basics} -setup { dict keys [tcl::unsupported::getbytecode objmethod foo bar] } -cleanup { foo destroy -} -result $bytecodekeys +} -result "$bytecodekeys initiallinenumber sourcefile" test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { # This will panic in a --enable-symbols=compile build, unless bug is fixed. -- cgit v0.12 From c610c391004b3206e110cfbacb5412d6b918a305 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Jan 2016 12:19:31 +0000 Subject: Make function TclDisassembleByteCodeObj() static, since it is only used in a single source file. --- generic/tclDisassemble.c | 14 ++++++++------ generic/tclInt.h | 2 -- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index a60a58d..c85fe13 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -23,6 +23,8 @@ static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Interp *interp, Tcl_Obj *objPtr); +static Tcl_Obj * DisassembleByteCodeObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); static void GetLocationInformation(Tcl_Interp *interp, @@ -126,7 +128,7 @@ TclPrintByteCodeObj( Tcl_Interp *interp, /* Used only for getting location info. */ Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(interp, objPtr); + Tcl_Obj *bufPtr = DisassembleByteCodeObj(interp, objPtr); fprintf(stdout, "\n%s", TclGetString(bufPtr)); Tcl_DecrRefCount(bufPtr); @@ -231,7 +233,7 @@ TclPrintSource( /* *---------------------------------------------------------------------- * - * TclDisassembleByteCodeObj -- + * DisassembleByteCodeObj -- * * Given an object which is of bytecode type, return a disassembled * version of the bytecode (in a new refcount 0 object). No guarantees @@ -240,8 +242,8 @@ TclPrintSource( *---------------------------------------------------------------------- */ -Tcl_Obj * -TclDisassembleByteCodeObj( +static Tcl_Obj * +DisassembleByteCodeObj( Tcl_Interp *interp, Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { @@ -368,7 +370,7 @@ TclDisassembleByteCodeObj( rangePtr->catchOffset); break; default: - Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", + Tcl_Panic("DisassembleByteCodeObj: bad ExceptionRange type %d", rangePtr->type); } } @@ -1486,7 +1488,7 @@ Tcl_DisassembleObjCmd( DisassembleByteCodeAsDicts(interp, codeObjPtr)); } else { Tcl_SetObjResult(interp, - TclDisassembleByteCodeObj(interp, codeObjPtr)); + DisassembleByteCodeObj(interp, codeObjPtr)); } return TCL_OK; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 9a5b4bf..42c13dd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3152,8 +3152,6 @@ MODULE_SCOPE void TclFinalizeThreadStorage(void); MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); #endif -MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); -- cgit v0.12 From e52d82d888bff754f2b3c98ab0b8b11b49889292 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Jan 2016 14:32:41 +0000 Subject: Eliminate some usages of Tcl_GlobalEval() and Tcl_Eval(), which are deprecated functions. --- generic/tclTest.c | 12 ++++++------ generic/tclTestProcBodyObj.c | 2 +- generic/tclThreadTest.c | 6 +++--- generic/tclTrace.c | 3 ++- generic/tclZlib.c | 4 ++-- unix/dltest/pkge.c | 2 +- 6 files changed, 15 insertions(+), 14 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 600f5ec..284d80a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -958,7 +958,7 @@ AsyncHandlerProc( listArgv[3] = NULL; cmd = Tcl_Merge(3, listArgv); if (interp != NULL) { - code = Tcl_Eval(interp, cmd); + code = Tcl_EvalEx(interp, cmd, -1, 0); } else { /* * this should not happen, but by definition of how async handlers are @@ -1241,7 +1241,7 @@ TestcmdtraceCmd( if (strcmp(argv[1], "tracetest") == 0) { Tcl_DStringInit(&buffer); cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1257,13 +1257,13 @@ TestcmdtraceCmd( */ cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL); - Tcl_Eval(interp, argv[2]); + Tcl_EvalEx(interp, argv[2], -1, 0); } else if (strcmp(argv[1], "leveltest") == 0) { Interp *iPtr = (Interp *) interp; Tcl_DStringInit(&buffer); cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, CmdTraceProc, &buffer); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1987,7 +1987,7 @@ EncodingToUtfProc( TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd); + Tcl_EvalEx(encodingPtr->interp,encodingPtr->toUtfCmd,-1,TCL_EVAL_GLOBAL); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { @@ -2019,7 +2019,7 @@ EncodingFromUtfProc( TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd); + Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd,-1,TCL_EVAL_GLOBAL); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 0d3617e..4d32c5a 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -143,7 +143,7 @@ RegisterCommand( if (cmdTablePtr->exportIt) { sprintf(buf, "namespace eval %s { namespace export %s }", namespace, cmdTablePtr->cmdName); - if (Tcl_Eval(interp, buf) != TCL_OK) { + if (Tcl_EvalEx(interp, buf, -1, 0) != TCL_OK) { return TCL_ERROR; } } diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 02ee038..75f8a15 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -613,7 +613,7 @@ NewTestThread( */ Tcl_Preserve(tsdPtr->interp); - result = Tcl_Eval(tsdPtr->interp, threadEvalScript); + result = Tcl_EvalEx(tsdPtr->interp, threadEvalScript, -1, 0); if (result != TCL_OK) { ThreadErrorProc(tsdPtr->interp); } @@ -834,7 +834,7 @@ ThreadSend( if (threadId == Tcl_GetCurrentThread()) { Tcl_MutexUnlock(&threadMutex); - return Tcl_GlobalEval(interp, script); + return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL); } /* @@ -1029,7 +1029,7 @@ ThreadEventProc( Tcl_Preserve(interp); Tcl_ResetResult(interp); Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script); - code = Tcl_GlobalEval(interp, threadEventPtr->script); + code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL); Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script); if (code != TCL_OK) { errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); diff --git a/generic/tclTrace.c b/generic/tclTrace.c index fe52d59..4e74c54 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -1889,7 +1889,8 @@ TraceExecutionProc( * interpreter. */ - traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + traceCode = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), + Tcl_DStringLength(&cmd), 0); tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; /* diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 44dd9e0..ba3e9cb 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -762,7 +762,7 @@ Tcl_ZlibStreamInit( */ if (interp != NULL) { - if (Tcl_Eval(interp, "::incr ::tcl::zlib::cmdcounter") != TCL_OK) { + if (Tcl_EvalEx(interp, "::incr ::tcl::zlib::cmdcounter", -1, 0) != TCL_OK) { goto error; } Tcl_DStringInit(&cmdname); @@ -3816,7 +3816,7 @@ TclZlibInit( * commands. */ - Tcl_Eval(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}"); + Tcl_EvalEx(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}", -1, 0); /* * Create the public scripted interface to this file's functionality. diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c index d616352..395cd0e 100644 --- a/unix/dltest/pkge.c +++ b/unix/dltest/pkge.c @@ -50,5 +50,5 @@ Pkge_Init( if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { return TCL_ERROR; } - return Tcl_Eval(interp, script); + return Tcl_EvalEx(interp, script, -1, 0); } -- cgit v0.12 From fe1ab20fb7e24faed6a14cc30ce438e29847c64f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Jan 2016 15:00:49 +0000 Subject: One more Tcl_GlobalEval() usage. --- generic/tclTest.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 284d80a..5468c56 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -4507,7 +4507,7 @@ TestfeventCmd( return TCL_ERROR; } if (interp2 != NULL) { - code = Tcl_GlobalEval(interp2, argv[2]); + code = Tcl_EvalEx(interp2, argv[2], -1, TCL_EVAL_GLOBAL); Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2)); return code; } else { -- cgit v0.12 From af6bc3e8603fff12286d897a75a073587da56911 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Jan 2016 13:11:15 +0000 Subject: Fix compiler warnings (discovered on latest clang/gcc6), suggested by Gustaf Neumann. All harmless, no change of functionality. --- generic/tclClock.c | 10 ++++++---- generic/tclExecute.c | 12 +++++++----- macosx/tclMacOSXBundle.c | 4 +--- 3 files changed, 14 insertions(+), 12 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 32ba145..782c681 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -562,8 +562,9 @@ ClockGetjuliandayfromerayearmonthdayObjCmd ( || TclGetIntFromObj(interp, fieldPtr, &(fields.dayOfMonth)) != TCL_OK || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) { - if (fieldPtr == NULL) - Tcl_SetObjResult(interp, Tcl_NewStringObj("expected key(s) not found in dictionary", -1)); + if (fieldPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("expected key(s) not found in dictionary", -1)); + } return TCL_ERROR; } fields.era = era; @@ -655,8 +656,9 @@ ClockGetjuliandayfromerayearweekdayObjCmd ( || fieldPtr == NULL || TclGetIntFromObj(interp, fieldPtr, &(fields.dayOfWeek)) != TCL_OK || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) { - if (fieldPtr == NULL) - Tcl_SetObjResult(interp, Tcl_NewStringObj("expected key(s) not found in dictionary", -1)); + if (fieldPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("expected key(s) not found in dictionary", -1)); + } return TCL_ERROR; } fields.era = era; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 248b1b3..bfb9d17 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -280,6 +280,8 @@ VarHashCreateVar( #define CURR_DEPTH (tosPtr - initTosPtr) +#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1) + /* * Macros used to trace instruction execution. The macros TRACE, * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. O2S is @@ -722,7 +724,7 @@ TclCreateExecEnv( esPtr->nextPtr = NULL; esPtr->markerPtr = NULL; esPtr->endPtr = &esPtr->stackWords[TCL_STACK_INITIAL_SIZE-1]; - esPtr->tosPtr = &esPtr->stackWords[-1]; + esPtr->tosPtr = STACK_BASE(esPtr); Tcl_MutexLock(&execMutex); if (!execInitialized) { @@ -934,8 +936,8 @@ GrowEvaluationStack( if (esPtr->nextPtr) { oldPtr = esPtr; esPtr = oldPtr->nextPtr; - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; - if (esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) { + currElems = esPtr->endPtr - STACK_BASE(esPtr); + if (esPtr->markerPtr || (esPtr->tosPtr != STACK_BASE(esPtr))) { Tcl_Panic("STACK: Stack after current is in use"); } if (esPtr->nextPtr) { @@ -947,7 +949,7 @@ GrowEvaluationStack( DeleteExecStack(esPtr); esPtr = oldPtr; } else { - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; + currElems = esPtr->endPtr - STACK_BASE(esPtr); } /* @@ -1089,7 +1091,7 @@ TclStackFree( * Return to previous stack. */ - esPtr->tosPtr = &esPtr->stackWords[-1]; + esPtr->tosPtr = STACK_BASE(esPtr); if (esPtr->prevPtr) { eePtr->execStackPtr = esPtr->prevPtr; } diff --git a/macosx/tclMacOSXBundle.c b/macosx/tclMacOSXBundle.c index c4fc82d..b2a88e5 100644 --- a/macosx/tclMacOSXBundle.c +++ b/macosx/tclMacOSXBundle.c @@ -237,9 +237,7 @@ Tcl_MacOSXOpenVersionedBundleResources( } if (openresourcemap) { - short refNum; - - refNum = openresourcemap(bundleRef); + openresourcemap(bundleRef); } } -- cgit v0.12 From c3dccf719622f99411ccbccbc079379124879e8e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 22 Jan 2016 10:27:29 +0000 Subject: Improve code 'quality' by fixing some harmless clang/cppcheck warnings. Thanks to Gustaf Neumann. No change in functionality. --- generic/tclIORChan.c | 9 +++--- generic/tclInterp.c | 1 - generic/tclVar.c | 82 ++++++++++++++++++++++++++++++++-------------------- 3 files changed, 55 insertions(+), 37 deletions(-) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index bbb5b88..c9939d6 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -516,7 +516,6 @@ TclChanCreateObjCmd( * Expect at least one list element. Abbreviations are ok. */ - modeObj = objv[MODE]; if (EncodeEventMask(interp, "mode", objv[MODE], &mode) != TCL_OK) { return TCL_ERROR; } @@ -1109,7 +1108,7 @@ ReflectClose( if (rcPtr->interp) { rcmPtr = GetReflectedChannelMap (rcPtr->interp); - hPtr = Tcl_FindHashEntry (&rcmPtr->map, + hPtr = Tcl_FindHashEntry (&rcmPtr->map, Tcl_GetChannelName (rcPtr->chan)); if (hPtr) { Tcl_DeleteHashEntry (hPtr); @@ -1117,7 +1116,7 @@ ReflectClose( } #ifdef TCL_THREADS rcmPtr = GetThreadReflectedChannelMap(); - hPtr = Tcl_FindHashEntry (&rcmPtr->map, + hPtr = Tcl_FindHashEntry (&rcmPtr->map, Tcl_GetChannelName (rcPtr->chan)); if (hPtr) { Tcl_DeleteHashEntry (hPtr); @@ -2750,12 +2749,12 @@ ForwardProc( */ rcmPtr = GetReflectedChannelMap (interp); - hPtr = Tcl_FindHashEntry (&rcmPtr->map, + hPtr = Tcl_FindHashEntry (&rcmPtr->map, Tcl_GetChannelName (rcPtr->chan)); Tcl_DeleteHashEntry (hPtr); rcmPtr = GetThreadReflectedChannelMap(); - hPtr = Tcl_FindHashEntry (&rcmPtr->map, + hPtr = Tcl_FindHashEntry (&rcmPtr->map, Tcl_GetChannelName (rcPtr->chan)); Tcl_DeleteHashEntry (hPtr); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 0231909..dbbf10a 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1748,7 +1748,6 @@ AliasObjCmd( cmdv = (Tcl_Obj **) TclStackAlloc(interp, cmdc*(int)sizeof(Tcl_Obj*)); } - prefv = &aliasPtr->objPtr; memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); diff --git a/generic/tclVar.c b/generic/tclVar.c index c013e8d..bdc64b7 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -916,7 +916,7 @@ TclLookupSimpleVar( * the variable. */ Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; ResolverScheme *resPtr; - int isNew, i, result; + int isNew; const char *varName = TclGetString(varNamePtr); varPtr = NULL; @@ -937,6 +937,8 @@ TclLookupSimpleVar( if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) && !(flags & AVOID_RESOLVERS)) { + int result; + resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { result = (*cxtNsPtr->varResProc)(interp, varName, @@ -1006,9 +1008,10 @@ TclLookupSimpleVar( (Tcl_Namespace *) cxtNsPtr, (flags | AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); if (varPtr == NULL) { - Tcl_Obj *tailPtr; if (create) { /* Var wasn't found so create it. */ + Tcl_Obj *tailPtr; + TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); if (varNsPtr == NULL) { @@ -1044,6 +1047,7 @@ TclLookupSimpleVar( } else { /* Local var: look in frame varFramePtr. */ int localCt = varFramePtr->numCompiledLocals; Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; + int i; for (i=0 ; iflags & VAR_TRACED_UNSET))) { + Tcl_HashEntry *tPtr = NULL; + dummyVar.flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) @@ -2581,10 +2587,8 @@ Tcl_AppendObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Var *varPtr, *arrayPtr; register Tcl_Obj *varValuePtr = NULL; /* Initialized to avoid compiler warning. */ - int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); @@ -2597,6 +2601,9 @@ Tcl_AppendObjCmd( return TCL_ERROR; } } else { + Var *arrayPtr, *varPtr; + int i; + varPtr = TclObjLookupVarEx(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { @@ -2648,8 +2655,7 @@ Tcl_LappendObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *varValuePtr, *newValuePtr; - int numElems, createdNewObj; - Var *varPtr, *arrayPtr; + int numElems; int result; if (objc < 2) { @@ -2677,6 +2683,9 @@ Tcl_LappendObjCmd( } } } else { + Var *varPtr, *arrayPtr; + int createdNewObj = 0; + /* * We have arguments to append. We used to call Tcl_SetVar2 to append * each argument one at a time to ensure that traces were run for each @@ -2687,8 +2696,6 @@ Tcl_LappendObjCmd( * copy to modify: this is "copy on write". */ - createdNewObj = 0; - /* * Protect the variable pointers around the TclPtrGetVar call * to insure that they remain valid even if the variable was undefined @@ -2870,10 +2877,8 @@ Tcl_ArrayObjCmd( return TCL_ERROR; } while (1) { - Var *varPtr2; - if (searchPtr->nextEntry != NULL) { - varPtr2 = VarHashGetValue(searchPtr->nextEntry); + Var *varPtr2 = VarHashGetValue(searchPtr->nextEntry); if (!TclIsVarUndefined(varPtr2)) { break; } @@ -3303,7 +3308,6 @@ Tcl_ArrayObjCmd( case ARRAY_SIZE: { Tcl_HashSearch search; - Var *varPtr2; int size; if (objc != 3) { @@ -3318,6 +3322,8 @@ Tcl_ArrayObjCmd( */ if (!notArray) { + Var *varPtr2; + for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { if (TclIsVarUndefined(varPtr2)) { @@ -3661,7 +3667,7 @@ TclPtrMakeUpvar( } /* Callers must Incr myNamePtr if they plan to Decr it. */ - + int TclPtrObjMakeUpvar( Tcl_Interp *interp, /* Interpreter containing variables. Used for @@ -3676,7 +3682,7 @@ TclPtrObjMakeUpvar( { Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; - const char *errMsg, *p, *myName; + const char *errMsg, *myName; Var *varPtr; if (index >= 0) { @@ -3687,6 +3693,7 @@ TclPtrObjMakeUpvar( myNamePtr = localName(iPtr->varFramePtr, index); myName = myNamePtr? TclGetString(myNamePtr) : NULL; } else { + const char *p; /* * Do not permit the new variable to look like an array reference, as * it will not be reachable in that case [Bug 600812, TIP 184]. The @@ -3889,8 +3896,6 @@ Tcl_GetVariableFullName( { Interp *iPtr = (Interp *) interp; register Var *varPtr = (Var *) variable; - Tcl_Obj *namePtr; - Namespace *nsPtr; /* * Add the full name of the containing namespace (if any), followed by the @@ -3899,6 +3904,9 @@ Tcl_GetVariableFullName( if (varPtr) { if (!TclIsVarArrayElement(varPtr)) { + Tcl_Obj *namePtr; + Namespace *nsPtr; + nsPtr = TclGetVarNsPtr(varPtr); if (nsPtr) { Tcl_AppendToObj(objPtr, nsPtr->fullName, -1); @@ -3952,7 +3960,7 @@ Tcl_GlobalObjCmd( register Tcl_Obj *objPtr, *tailPtr; char *varName; register char *tail; - int result, i; + int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?"); @@ -3968,6 +3976,8 @@ Tcl_GlobalObjCmd( } for (i=1 ; iflags & VAR_SEARCH_ACTIVE) { + ArraySearch *searchPtr, *nextPtr; + Tcl_HashEntry *sPtr; + sPtr = Tcl_FindHashEntry(&iPtr->varSearches, (char *) arrayVarPtr); for (searchPtr = (ArraySearch *) Tcl_GetHashValue(sPtr); searchPtr != NULL; searchPtr = nextPtr) { @@ -4919,9 +4930,10 @@ DupParsedVarName( register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; register char *elem = srcPtr->internalRep.twoPtrValue.ptr2; char *elemCopy; - unsigned int elemLen; if (arrayPtr != NULL) { + unsigned int elemLen; + Tcl_IncrRefCount(arrayPtr); elemLen = strlen(elem); elemCopy = ckalloc(elemLen+1); @@ -5048,7 +5060,6 @@ ObjFindNamespaceVar( const char *simpleName; Var *varPtr; register int search; - int result; Tcl_Var var; Tcl_Obj *simpleNamePtr; char *name = TclGetString(namePtr); @@ -5069,6 +5080,8 @@ ObjFindNamespaceVar( if (!(flags & AVOID_RESOLVERS) && (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL)) { + int result; + resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { @@ -5161,14 +5174,13 @@ TclInfoVarsCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - char *varName, *pattern; + char *pattern; const char *simplePattern; Tcl_HashSearch search; - Var *varPtr; Namespace *nsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - Tcl_Obj *listPtr, *elemObjPtr; + Tcl_Obj *listPtr; int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ Tcl_Obj *simplePatternPtr = NULL, *varNamePtr; @@ -5224,6 +5236,9 @@ TclInfoVarsCmd( if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC) || specificNsInPattern) { + Var *varPtr; + Tcl_Obj *elemObjPtr; + /* * There is no frame pointer, the frame pointer was pushed only to * activate a namespace, or we are in a procedure call frame but a @@ -5264,9 +5279,11 @@ TclInfoVarsCmd( /* * Have to scan the tables of variables. */ + char *varName; varPtr = VarHashFirstVar(&nsPtr->varTable, &search); while (varPtr) { + if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { varNamePtr = VarHashGetKey(varPtr); @@ -5354,11 +5371,11 @@ TclInfoGlobalsCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - char *varName, *pattern; + char *pattern; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); Tcl_HashSearch search; Var *varPtr; - Tcl_Obj *listPtr, *varNamePtr, *patternPtr; + Tcl_Obj *listPtr, *patternPtr; if (objc == 1) { pattern = NULL; @@ -5405,6 +5422,9 @@ TclInfoGlobalsCmd( for (varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); varPtr != NULL; varPtr = VarHashNextVar(&search)) { + char *varName; + Tcl_Obj *varNamePtr; + if (TclIsVarUndefined(varPtr)) { continue; } -- cgit v0.12 From 4df5497f65a1c1de3d19ed2dfa26c5b55fb9c01f Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Sat, 23 Jan 2016 19:46:58 +0000 Subject: add a test to insure that callbacks run at the correct C-stack depth while unwinding the NRE stack. --- generic/tclTest.c | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/nre.test | 4 ++++ 2 files changed, 57 insertions(+) diff --git a/generic/tclTest.c b/generic/tclTest.c index 5468c56..2ea3016 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -412,6 +412,12 @@ static int TestNumUtfCharsCmd(ClientData clientData, static int TestHashSystemHashCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); + +static int NREUnwind_callback(ClientData data[], Tcl_Interp *interp, + int result); +static int TestNREUnwind(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestNRELevels(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -697,6 +703,8 @@ Tcltest_Init( NULL); #endif /* TCL_NO_DEPRECATED */ + Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, + NULL, NULL); Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, NULL, NULL); Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, @@ -6846,6 +6854,51 @@ TestgetintCmd( } static int +NREUnwind_callback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + int none; + + if (data[0] == INT2PTR(-1)) { + TclNRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1), + INT2PTR(-1), NULL); + } else if (data[1] == INT2PTR(-1)) { + TclNRAddCallback(interp, NREUnwind_callback, data[0], &none, + INT2PTR(-1), NULL); + } else if (data[2] == INT2PTR(-1)) { + TclNRAddCallback(interp, NREUnwind_callback, data[0], data[1], + &none, NULL); + } else { + Tcl_Obj *idata[3]; + idata[0] = Tcl_NewIntObj((int) (data[1] - data[0])); + idata[1] = Tcl_NewIntObj((int) (data[2] - data[0])); + idata[2] = Tcl_NewIntObj((int) ((void *) &none - data[0])); + Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata)); + } + return TCL_OK; +} + +static int +TestNREUnwind( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + /* + * Insure that callbacks effectively run at the proper level during the + * unwinding of the NRE stack. + */ + + TclNRAddCallback(interp, NREUnwind_callback, INT2PTR(-1), INT2PTR(-1), + INT2PTR(-1), NULL); + return TCL_OK; +} + + +static int TestNRELevels( ClientData clientData, Tcl_Interp *interp, diff --git a/tests/nre.test b/tests/nre.test index e512eac..9df5eb1 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -64,6 +64,10 @@ if {[testConstraint testnrelevels]} { namespace import testnre::* } +test nre-0.1 {levels while unwinding} { + testnreunwind +} {0 0 0} + test nre-1.1 {self-recursive procs} -setup { proc a i [makebody {a $i}] } -body { -- cgit v0.12 From 727efcf0120542b9998b9949210ae60b51ce1598 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 24 Jan 2016 16:52:56 +0000 Subject: Fix "make test" broken by previous commit --- generic/tclTest.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 2ea3016..63a6740 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -6862,13 +6862,13 @@ NREUnwind_callback( int none; if (data[0] == INT2PTR(-1)) { - TclNRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1), + Tcl_NRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1), INT2PTR(-1), NULL); } else if (data[1] == INT2PTR(-1)) { - TclNRAddCallback(interp, NREUnwind_callback, data[0], &none, + Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], &none, INT2PTR(-1), NULL); } else if (data[2] == INT2PTR(-1)) { - TclNRAddCallback(interp, NREUnwind_callback, data[0], data[1], + Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], data[1], &none, NULL); } else { Tcl_Obj *idata[3]; @@ -6892,7 +6892,7 @@ TestNREUnwind( * unwinding of the NRE stack. */ - TclNRAddCallback(interp, NREUnwind_callback, INT2PTR(-1), INT2PTR(-1), + Tcl_NRAddCallback(interp, NREUnwind_callback, INT2PTR(-1), INT2PTR(-1), INT2PTR(-1), NULL); return TCL_OK; } -- cgit v0.12 From 22f5c55560bbc2db11df037944b62c294e250928 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 29 Jan 2016 09:17:55 +0000 Subject: Upstream zipfs change and unbreak zipfs test-case --- generic/zipfs.c | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/generic/zipfs.c b/generic/zipfs.c index c5cb65b..1c96f7b 100644 --- a/generic/zipfs.c +++ b/generic/zipfs.c @@ -3854,6 +3854,8 @@ Zip_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME); if ((objs[1] != NULL) && (Zip_FSAccessProc(objs[1], R_OK) == 0)) { + const char *execName = Tcl_GetNameOfExecutable(); + /* * Shared object is not in ZIP but its path prefix is, * thus try to load from directory where the executable @@ -3861,8 +3863,23 @@ Zip_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, */ TclDecrRefCount(objs[1]); objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL); - objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), - TCL_PATH_DIRNAME); + /* + * Get directory name of executable manually to deal + * with cases where [file dirname [info nameofexecutable]] + * is equal to [info nameofexecutable] due to VFS effects. + */ + if (execName != NULL) { + const char *p = strrchr(execName, '/'); + + if (p > execName + 1) { + --p; + objs[0] = Tcl_NewStringObj(execName, p - execName); + } + } + if (objs[0] == NULL) { + objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), + TCL_PATH_DIRNAME); + } if (objs[0] != NULL) { altPath = TclJoinPath(2, objs); if (altPath != NULL) { @@ -3980,6 +3997,7 @@ Zipfs_doInit(Tcl_Interp *interp, int safe) }; static const char findproc[] = + "namespace eval zipfs {}\n" "proc ::zipfs::find dir {\n" " set result {}\n" " if {[catch {glob -directory $dir -tails -nocomplain * .*} list]} {\n" @@ -4018,13 +4036,15 @@ Zipfs_doInit(Tcl_Interp *interp, int safe) Tcl_StaticPackage(interp, "zipfs", Tclzipfs_Init, Tclzipfs_SafeInit); } Unlock(); - Tcl_PkgProvide(interp, "zipfs", "1.0"); if (!safe) { Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); Tcl_LinkVar(interp, "::zipfs::wrmax", (char *) &ZipFS.wrmax, TCL_LINK_INT); } TclMakeEnsemble(interp, "zipfs", safe ? initSafeMap : initMap); + + Tcl_PkgProvide(interp, "zipfs", "1.0"); + return TCL_OK; #else if (interp != NULL) { -- cgit v0.12