summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tclDisassemble.c109
-rw-r--r--generic/tclInt.h1
-rw-r--r--generic/tclInterp.c1
-rw-r--r--generic/tclOO.c58
-rw-r--r--generic/tclTest.c67
-rw-r--r--generic/tclTestProcBodyObj.c2
-rw-r--r--generic/tclThreadTest.c6
-rw-r--r--generic/tclTrace.c3
-rw-r--r--generic/tclZlib.c4
-rw-r--r--tests/compile.test42
-rw-r--r--tests/nre.test4
-rw-r--r--tests/oo.test13
-rw-r--r--unix/dltest/pkge.c2
13 files changed, 262 insertions, 50 deletions
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index 86f0e1d..c85fe13 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -21,9 +21,15 @@
* 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 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,
+ 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 +54,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 +125,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 = DisassembleByteCodeObj(interp, objPtr);
fprintf(stdout, "\n%s", TclGetString(bufPtr));
Tcl_DecrRefCount(bufPtr);
@@ -176,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
@@ -185,17 +242,18 @@ TclPrintSource(
*----------------------------------------------------------------------
*/
-Tcl_Obj *
-TclDisassembleByteCodeObj(
+static Tcl_Obj *
+DisassembleByteCodeObj(
+ 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 +278,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,
@@ -307,7 +370,7 @@ TclDisassembleByteCodeObj(
rangePtr->catchOffset);
break;
default:
- Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d",
+ Tcl_Panic("DisassembleByteCodeObj: bad ExceptionRange type %d",
rangePtr->type);
}
}
@@ -881,14 +944,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 +1217,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 +1246,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 +1484,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,
+ DisassembleByteCodeObj(interp, codeObjPtr));
}
return TCL_OK;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 082fab4..42c13dd 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3152,7 +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_Obj *objPtr);
MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp);
MODULE_SCOPE void * TclpThreadCreateKey(void);
MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 0da5d47..5c94461 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -1882,7 +1882,6 @@ AliasObjCmd(
cmdv = TclStackAlloc(interp, cmdc * 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/tclOO.c b/generic/tclOO.c
index 5fca220..34eb5ad 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -58,6 +58,8 @@ 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,
Method **newMPtrPtr);
@@ -905,6 +907,34 @@ 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)
+{
+ 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. */
@@ -979,6 +1009,9 @@ ReleaseClassContents(
Tcl_DeleteCommandFromToken(interp,
mixinSubclassPtr->thisPtr->command);
}
+ if (mixinSubclassPtr->mixins.num) {
+ ClearMixins(mixinSubclassPtr);
+ }
DelRef(mixinSubclassPtr->thisPtr);
DelRef(mixinSubclassPtr);
}
@@ -999,6 +1032,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 +1231,6 @@ ObjectNamespaceDeleted(
}
if (clsPtr != NULL) {
- Class *superPtr;
Tcl_ObjectMetadataType *metadataTypePtr;
ClientData value;
@@ -1215,23 +1250,12 @@ 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;
- }
- FOREACH(superPtr, clsPtr->superclasses) {
- if (!Deleted(superPtr->thisPtr)) {
- TclOORemoveFromSubclasses(clsPtr, superPtr);
- }
+
+ if (clsPtr->mixins.num) {
+ ClearMixins(clsPtr);
}
- 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/generic/tclTest.c b/generic/tclTest.c
index 600f5ec..9794f59 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,
@@ -958,7 +966,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 +1249,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 +1265,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 +1995,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 +2027,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) {
@@ -4507,7 +4515,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 {
@@ -6846,6 +6854,51 @@ TestgetintCmd(
}
static int
+NREUnwind_callback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ int none;
+
+ if (data[0] == INT2PTR(-1)) {
+ Tcl_NRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1),
+ INT2PTR(-1), NULL);
+ } else if (data[1] == INT2PTR(-1)) {
+ Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], &none,
+ INT2PTR(-1), NULL);
+ } else if (data[2] == INT2PTR(-1)) {
+ Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], data[1],
+ &none, NULL);
+ } else {
+ Tcl_Obj *idata[3];
+ idata[0] = Tcl_NewIntObj((int) ((char *) data[1] - (char *) data[0]));
+ idata[1] = Tcl_NewIntObj((int) ((char *) data[2] - (char *) data[0]));
+ idata[2] = Tcl_NewIntObj((int) ((char *) &none - (char *) 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.
+ */
+
+ Tcl_NRAddCallback(interp, NREUnwind_callback, INT2PTR(-1), INT2PTR(-1),
+ INT2PTR(-1), NULL);
+ return TCL_OK;
+}
+
+
+static int
TestNRELevels(
ClientData clientData,
Tcl_Interp *interp,
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/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.
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 {
diff --git a/tests/oo.test b/tests/oo.test
index 2112f10..895f7ed 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -3671,6 +3671,19 @@ 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]
+} {}
+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
return
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);
}