summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2016-01-19 13:06:40 (GMT)
committerdgp <dgp@users.sourceforge.net>2016-01-19 13:06:40 (GMT)
commitb29c8c9024a6b9e1b6ede8a02f6d3243607e4410 (patch)
tree57df9a3646872d41da4caf86b97f8e20ec90bbfe /generic
parent75a948c82b849db12be6bbe74005435ff2905812 (diff)
parent7dd65dcdd0d8e9013803356230cce9a9ac6dfef3 (diff)
downloadtcl-b29c8c9024a6b9e1b6ede8a02f6d3243607e4410.zip
tcl-b29c8c9024a6b9e1b6ede8a02f6d3243607e4410.tar.gz
tcl-b29c8c9024a6b9e1b6ede8a02f6d3243607e4410.tar.bz2
merge trunkbug_593baa032c
Diffstat (limited to 'generic')
-rw-r--r--generic/tclDisassemble.c109
-rw-r--r--generic/tclInt.h1
-rw-r--r--generic/tclTest.c14
-rw-r--r--generic/tclTestProcBodyObj.c2
-rw-r--r--generic/tclThreadTest.c6
-rw-r--r--generic/tclTrace.c3
-rw-r--r--generic/tclZlib.c4
7 files changed, 111 insertions, 28 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/tclTest.c b/generic/tclTest.c
index 600f5ec..5468c56 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) {
@@ -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 {
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.