Compare commits
250
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
c8b1fb73cd | ||
|
|
3ca5f5cceb | ||
|
|
cdc54b926e | ||
|
|
f91b53c427 | ||
|
|
46d15d8d83 | ||
|
|
1f316ee4c2 | ||
|
|
a3b32a90f4 | ||
|
|
21f38a5b59 | ||
|
|
4cffc50544 | ||
|
|
dbf69a5c35 | ||
|
|
04dc9cf4b5 | ||
|
|
551c1accdd | ||
|
|
8e6ab8a2a9 | ||
|
|
e4e0c66422 | ||
|
|
5064ac18f0 | ||
|
|
3f46e4e2ce | ||
|
|
512d604373 | ||
|
|
e471a6ae36 | ||
|
|
9dc234c0a0 | ||
|
|
ee4741dd28 | ||
|
|
1520a2b646 | ||
|
|
a214397a5d | ||
|
|
cdbf5bbccc | ||
|
|
5888a02ed9 | ||
|
|
4f819978f6 | ||
|
|
efb3476a31 | ||
|
|
397ac6a836 | ||
|
|
c7f5a5be0d | ||
|
|
c55a3c7bd1 | ||
|
|
5514e4cd62 | ||
|
|
e69f4bb611 | ||
|
|
af5874a216 | ||
|
|
93693d537c | ||
|
|
6fd304fbe7 | ||
|
|
30cf0815d4 | ||
|
|
16b3aeb50f | ||
|
|
d73f0b41ac | ||
|
|
e4e745a30f | ||
|
|
1d326dba2e | ||
|
|
8597c3aaa2 | ||
|
|
c9152240b9 | ||
|
|
d6ec1e9bfc | ||
|
|
b49ab44beb | ||
|
|
a5d25d127e | ||
|
|
d22d1ef546 | ||
|
|
952dfe7d9a | ||
|
|
f84ad530c8 | ||
|
|
d90a64d3a1 | ||
|
|
b787c05026 | ||
|
|
89c58435c6 | ||
|
|
448e2efa85 | ||
|
|
d7d1ee7807 | ||
|
|
20bddd92a8 | ||
|
|
47c98dba00 | ||
|
|
e3ab152270 | ||
|
|
a7ae483978 | ||
|
|
73ab49a965 | ||
|
|
fc79fbbb21 | ||
|
|
54b132e055 | ||
|
|
60d431c6d7 | ||
|
|
bc33fd2059 | ||
|
|
6947941311 | ||
|
|
d8c4cd990a | ||
|
|
0fac9eaadc | ||
|
|
b9a114d0cb | ||
|
|
39f3fe70f2 | ||
|
|
690131269a | ||
|
|
6b395aa2a8 | ||
|
|
93d1bfd43a | ||
|
|
a8d9a59847 | ||
|
|
21bafe08ff | ||
|
|
cca69ee36f | ||
|
|
ddafbe446f | ||
|
|
cf4113b31e | ||
|
|
2996690592 | ||
|
|
8093042dd1 | ||
|
|
37377ce24b | ||
|
|
6aa85ad35f | ||
|
|
44ccdb891c | ||
|
|
ec2a6698ff | ||
|
|
6ad21baf09 | ||
|
|
6bf9f93888 | ||
|
|
92cb904c7c | ||
|
|
c35920b380 | ||
|
|
1a0d01992a | ||
|
|
8c1902c743 | ||
|
|
77e313226d | ||
|
|
53f9934a44 | ||
|
|
db45f45b11 | ||
|
|
2cad7f4e4c | ||
|
|
21d1155d39 | ||
|
|
b1bc33f2e0 | ||
|
|
2eca5d1f24 | ||
|
|
6797693d1b | ||
|
|
f71d89bb77 | ||
|
|
1105fdfb2e | ||
|
|
565ca47945 | ||
|
|
33168443c9 | ||
|
|
fe7b5135d4 | ||
|
|
7d2f7fa0e8 | ||
|
|
f37347c455 | ||
|
|
266f2ef65c | ||
|
|
6ca6ce4c6d | ||
|
|
07d3ddab92 | ||
|
|
178985197d | ||
|
|
aef36bf11d | ||
|
|
0dc45b9fe3 | ||
|
|
e65b021050 | ||
|
|
b5100ee98f | ||
|
|
2951fec86b | ||
|
|
d07793f49c | ||
|
|
e00ad288cc | ||
|
|
5b8ce14566 | ||
|
|
facce70703 | ||
|
|
26f4ba76ca | ||
|
|
aaf8665696 | ||
|
|
a8c55de8fc | ||
|
|
cebb11e97e | ||
|
|
e4dd07e735 | ||
|
|
e98a68549d | ||
|
|
1fc4f8eaa3 | ||
|
|
70bccae334 | ||
|
|
7442eb42a1 | ||
|
|
052f5d50c9 | ||
|
|
5815a325af | ||
|
|
3ff398393a | ||
|
|
ef0bb68bcb | ||
|
|
382a840e23 | ||
|
|
1e6fd4531c | ||
|
|
21e80b3a25 | ||
|
|
8e6efd7026 | ||
|
|
39365ed3c0 | ||
|
|
f52f05c3b1 | ||
|
|
388741b7d0 | ||
|
|
b2ca802381 | ||
|
|
b05600e60a | ||
|
|
98a8b3604f | ||
|
|
905d1e5d03 | ||
|
|
cb7c84c310 | ||
|
|
03bdf41de2 | ||
|
|
206428d2cf | ||
|
|
bc0d613154 | ||
|
|
1d6f003314 | ||
|
|
e81a4abd60 | ||
|
|
06ebe62a5e | ||
|
|
0d78d389e1 | ||
|
|
eea64f8d90 | ||
|
|
4c5cc88bdf | ||
|
|
a1cee7cd20 | ||
|
|
3327979282 | ||
|
|
8c19725a30 | ||
|
|
0a224ddfc8 | ||
|
|
9a7c011683 | ||
|
|
13614048fb | ||
|
|
44427fccaa | ||
|
|
ac3cc1fbaa | ||
|
|
c4cf77f310 | ||
|
|
8f1ee5dd0a | ||
|
|
9b00a63b22 | ||
|
|
91d9bd02c0 | ||
|
|
56b69c4e9a | ||
|
|
d2b1e66352 | ||
|
|
d29d888dc6 | ||
|
|
f4ed4079b7 | ||
|
|
dde5a2565e | ||
|
|
e59a1e0b14 | ||
|
|
c4b5bfbd50 | ||
|
|
44869c9e35 | ||
|
|
e5463e8ec8 | ||
|
|
bddf737714 | ||
|
|
ef0fd808de | ||
|
|
f4fb1d1752 | ||
|
|
59ea8cb145 | ||
|
|
e9cf99c212 | ||
|
|
80630f4ec9 | ||
|
|
e63dcc2677 | ||
|
|
9bbc90b227 | ||
|
|
8e5dbc8a27 | ||
|
|
29c6b72a83 | ||
|
|
fd5b3bb085 | ||
|
|
2fda7e49a0 | ||
|
|
27256fcd71 | ||
|
|
e702454abe | ||
|
|
9423df2491 | ||
|
|
05b1764f74 | ||
|
|
bff7817ec0 | ||
|
|
13bc69a8a4 | ||
|
|
9aa711e8e0 | ||
|
|
b339d4bf03 | ||
|
|
1e58e8e42d | ||
|
|
91af7f6f90 | ||
|
|
68191ded75 | ||
|
|
ac3d0b69d3 | ||
|
|
96f611f896 | ||
|
|
ec9c29c80d | ||
|
|
5b0b0b2ebe | ||
|
|
558783ed98 | ||
|
|
f18725b93e | ||
|
|
9a444ac954 | ||
|
|
afd3fa8ec6 | ||
|
|
5cd87d3025 | ||
|
|
a264f75d26 | ||
|
|
c57bbe7251 | ||
|
|
41f2eec0d4 | ||
|
|
2ce05888c7 | ||
|
|
4708a19126 | ||
|
|
d148e32af0 | ||
|
|
905b9e972f | ||
|
|
1c9d460f32 | ||
|
|
97db7170af | ||
|
|
7a0a9420c3 | ||
|
|
040e838613 | ||
|
|
8f87fdcd28 | ||
|
|
8b9fac43b6 | ||
|
|
2fff4b469c | ||
|
|
e0c01d21ae | ||
|
|
8d7ec7c576 | ||
|
|
20c84a8226 | ||
|
|
12dbf3de12 | ||
|
|
0213956b39 | ||
|
|
31a9bc1834 | ||
|
|
ff7299334c | ||
|
|
83a937c2d5 | ||
|
|
fdcfb81f83 | ||
|
|
39878dbe95 | ||
|
|
84a8faf3c9 | ||
|
|
9aaa527752 | ||
|
|
a50038030d | ||
|
|
2ce8dd1adb | ||
|
|
b008558525 | ||
|
|
0d02084a65 | ||
|
|
b0b36a96c2 | ||
|
|
9ca77c6cdc | ||
|
|
92d92b75a0 | ||
|
|
e2deeab694 | ||
|
|
3b1caea6de | ||
|
|
2cd27e8398 | ||
|
|
6c7d46ec49 | ||
|
|
cbc374cdf7 | ||
|
|
d125ef5038 | ||
|
|
45d63ba185 | ||
|
|
485f2c31d4 | ||
|
|
bb772bd9d5 | ||
|
|
ecc345e041 | ||
|
|
52802cf7f3 | ||
|
|
7e40428abd | ||
|
|
1e6c86443d | ||
|
|
36a65fa0bc | ||
|
|
d3b19bec3e | ||
|
|
5dc389ff43 |
+25
-51
@@ -28,8 +28,7 @@
|
||||
*- returnCodeBranch
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
#include "tclCompile.h"
|
||||
#include "tclEngineInt.h"
|
||||
#include "tclOOInt.h"
|
||||
|
||||
/*
|
||||
@@ -234,6 +233,8 @@ typedef struct AssemblyEnv {
|
||||
|
||||
static void AddBasicBlockRangeToErrorInfo(AssemblyEnv*,
|
||||
BasicBlock*);
|
||||
static void AdvanceLines(int *line, const char *start,
|
||||
const char *end);
|
||||
static BasicBlock * AllocBB(AssemblyEnv*);
|
||||
static int AssembleOneLine(AssemblyEnv* envPtr);
|
||||
static void BBAdjustStackDepth(BasicBlock* bbPtr, int consumed,
|
||||
@@ -323,22 +324,6 @@ static const Tcl_ObjType assembleCodeType = {
|
||||
NULL /* setFromAnyProc */
|
||||
};
|
||||
|
||||
/*
|
||||
* TIP #280: Remember the per-word line information of the current command. An
|
||||
* index is used instead of a pointer as recursive compilation may reallocate,
|
||||
* i.e. move, the array. This is also the reason to save the nuloc now, it may
|
||||
* change during the course of the function.
|
||||
*
|
||||
* Macro to encapsulate the variable definition and setup.
|
||||
*/
|
||||
|
||||
#define DefineLineInformation \
|
||||
ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
|
||||
int eclIndex = mapPtr->nuloc - 1
|
||||
|
||||
#define SetLineInformation(word) \
|
||||
envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
|
||||
envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
|
||||
|
||||
/*
|
||||
* Flags bits used by PushVarName.
|
||||
@@ -527,6 +512,21 @@ static const unsigned char NonThrowingByteCodes[] = {
|
||||
INST_INFO_LEVEL_NUM, /* 152 */
|
||||
INST_RESOLVE_COMMAND /* 154 */
|
||||
};
|
||||
|
||||
static void
|
||||
AdvanceLines(
|
||||
int *line,
|
||||
const char *start,
|
||||
const char *end)
|
||||
{
|
||||
register const char *p;
|
||||
|
||||
for (p = start; p < end; p++) {
|
||||
if (*p == '\n') {
|
||||
(*line)++;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* Helper macros.
|
||||
@@ -877,17 +877,14 @@ CompileAssembleObj(
|
||||
FreeAssembleCodeInternalRep(objPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* Set up the compilation environment, and assemble the code.
|
||||
*/
|
||||
/* Set up the compilation environment, and assemble the code */
|
||||
|
||||
source = TclGetStringFromObj(objPtr, &sourceLen);
|
||||
TclInitCompileEnv(interp, &compEnv, source, sourceLen, NULL, 0);
|
||||
TclInitCompileEnv(interp, &compEnv, source, sourceLen);
|
||||
status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT);
|
||||
if (status != TCL_OK) {
|
||||
/*
|
||||
* Assembly failed. Clean up and report the error.
|
||||
*/
|
||||
|
||||
/* Assembly failed. Clean up and report the error */
|
||||
|
||||
/*
|
||||
* Free any literals that were constructed for the assembly.
|
||||
@@ -908,24 +905,6 @@ CompileAssembleObj(
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* TIP 280. If there is extended command line information,
|
||||
* we need to clean it up.
|
||||
*/
|
||||
|
||||
if (compEnv.extCmdMapPtr != NULL) {
|
||||
if (compEnv.extCmdMapPtr->type == TCL_LOCATION_SOURCE) {
|
||||
Tcl_DecrRefCount(compEnv.extCmdMapPtr->path);
|
||||
}
|
||||
for (i = 0; i < compEnv.extCmdMapPtr->nuloc; ++i) {
|
||||
ckfree(compEnv.extCmdMapPtr->loc[i].line);
|
||||
}
|
||||
if (compEnv.extCmdMapPtr->loc != NULL) {
|
||||
ckfree(compEnv.extCmdMapPtr->loc);
|
||||
}
|
||||
Tcl_DeleteHashTable(&(compEnv.extCmdMapPtr->litInfo));
|
||||
}
|
||||
|
||||
TclFreeCompileEnv(&compEnv);
|
||||
return NULL;
|
||||
}
|
||||
@@ -1090,10 +1069,8 @@ TclAssembleCode(
|
||||
* Advance the pointers around any leading commentary.
|
||||
*/
|
||||
|
||||
TclAdvanceLines(&assemEnvPtr->cmdLine, instPtr,
|
||||
AdvanceLines(&assemEnvPtr->cmdLine, instPtr,
|
||||
parsePtr->commandStart);
|
||||
TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext,
|
||||
parsePtr->commandStart - envPtr->source);
|
||||
|
||||
/*
|
||||
* Process the line of code.
|
||||
@@ -1131,10 +1108,8 @@ TclAssembleCode(
|
||||
nextPtr = parsePtr->commandStart + parsePtr->commandSize;
|
||||
bytesLeft -= (nextPtr - instPtr);
|
||||
instPtr = nextPtr;
|
||||
TclAdvanceLines(&assemEnvPtr->cmdLine, parsePtr->commandStart,
|
||||
AdvanceLines(&assemEnvPtr->cmdLine, parsePtr->commandStart,
|
||||
instPtr);
|
||||
TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext,
|
||||
instPtr - envPtr->source);
|
||||
Tcl_FreeParse(parsePtr);
|
||||
} while (bytesLeft > 0);
|
||||
|
||||
@@ -1175,8 +1150,7 @@ NewAssemblyEnv(
|
||||
|
||||
assemEnvPtr->envPtr = envPtr;
|
||||
assemEnvPtr->parsePtr = parsePtr;
|
||||
assemEnvPtr->cmdLine = envPtr->line;
|
||||
assemEnvPtr->clNext = envPtr->clNext;
|
||||
assemEnvPtr->cmdLine = 1;
|
||||
|
||||
/*
|
||||
* Make the hashtables that store symbol resolution.
|
||||
|
||||
+130
-1143
File diff suppressed because it is too large
Load Diff
+23
-59
@@ -304,7 +304,6 @@ TclNRCatchObjCmd(
|
||||
{
|
||||
Tcl_Obj *varNamePtr = NULL;
|
||||
Tcl_Obj *optionVarNamePtr = NULL;
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
|
||||
if ((objc < 2) || (objc > 4)) {
|
||||
Tcl_WrongNumArgs(interp, 1, objv,
|
||||
@@ -319,14 +318,10 @@ TclNRCatchObjCmd(
|
||||
optionVarNamePtr = objv[3];
|
||||
}
|
||||
|
||||
TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
|
||||
Tcl_NRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc),
|
||||
varNamePtr, optionVarNamePtr, NULL);
|
||||
|
||||
/*
|
||||
* TIP #280. Make invoking context available to caught script.
|
||||
*/
|
||||
|
||||
return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
|
||||
return TclNREvalObjEx(interp, objv[1], 0);
|
||||
}
|
||||
|
||||
static int
|
||||
@@ -761,9 +756,6 @@ TclNREvalObjCmd(
|
||||
Tcl_Obj *const objv[]) /* Argument objects. */
|
||||
{
|
||||
register Tcl_Obj *objPtr;
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
CmdFrame *invoker = NULL;
|
||||
int word = 0;
|
||||
|
||||
if (objc < 2) {
|
||||
Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
|
||||
@@ -771,28 +763,18 @@ TclNREvalObjCmd(
|
||||
}
|
||||
|
||||
if (objc == 2) {
|
||||
/*
|
||||
* TIP #280. Make argument location available to eval'd script.
|
||||
*/
|
||||
|
||||
invoker = iPtr->cmdFramePtr;
|
||||
word = 1;
|
||||
objPtr = objv[1];
|
||||
TclArgumentGet(interp, objPtr, &invoker, &word);
|
||||
} else {
|
||||
/*
|
||||
* More than one argument: concatenate them together with spaces
|
||||
* between, then evaluate the result. Tcl_EvalObjEx will delete the
|
||||
* object when it decrements its refcount after eval'ing it.
|
||||
*
|
||||
* TIP #280. Make invoking context available to eval'd script, done
|
||||
* with the default values.
|
||||
*/
|
||||
|
||||
objPtr = Tcl_ConcatObj(objc-1, objv+1);
|
||||
}
|
||||
TclNRAddCallback(interp, EvalCmdErrMsg, NULL, NULL, NULL, NULL);
|
||||
return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
|
||||
Tcl_NRAddCallback(interp, EvalCmdErrMsg, NULL, NULL, NULL, NULL);
|
||||
return TclNREvalObjEx(interp, objPtr, 0);
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -890,10 +872,10 @@ TclNRExprObjCmd(
|
||||
Tcl_IncrRefCount(resultPtr);
|
||||
if (objc == 2) {
|
||||
objPtr = objv[1];
|
||||
TclNRAddCallback(interp, ExprCallback, resultPtr, NULL, NULL, NULL);
|
||||
Tcl_NRAddCallback(interp, ExprCallback, resultPtr, NULL, NULL, NULL);
|
||||
} else {
|
||||
objPtr = Tcl_ConcatObj(objc-1, objv+1);
|
||||
TclNRAddCallback(interp, ExprCallback, resultPtr, objPtr, NULL, NULL);
|
||||
Tcl_NRAddCallback(interp, ExprCallback, resultPtr, objPtr, NULL, NULL);
|
||||
}
|
||||
|
||||
return Tcl_NRExprObj(interp, objPtr, resultPtr);
|
||||
@@ -2409,12 +2391,11 @@ TclNRForObjCmd(
|
||||
int objc, /* Number of arguments. */
|
||||
Tcl_Obj *const objv[]) /* Argument objects. */
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
ForIterData *iterPtr;
|
||||
|
||||
if (objc != 5) {
|
||||
Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
|
||||
return TCL_ERROR;
|
||||
Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr);
|
||||
@@ -2422,15 +2403,9 @@ TclNRForObjCmd(
|
||||
iterPtr->body = objv[4];
|
||||
iterPtr->next = objv[3];
|
||||
iterPtr->msg = "\n (\"for\" body line %d)";
|
||||
iterPtr->word = 4;
|
||||
|
||||
TclNRAddCallback(interp, ForSetupCallback, iterPtr, NULL, NULL, NULL);
|
||||
|
||||
/*
|
||||
* TIP #280. Make invoking context available to initial script.
|
||||
*/
|
||||
|
||||
return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
|
||||
Tcl_NRAddCallback(interp, ForSetupCallback, iterPtr, NULL, NULL, NULL);
|
||||
return TclNREvalObjEx(interp, objv[1], 0);
|
||||
}
|
||||
|
||||
static int
|
||||
@@ -2448,7 +2423,7 @@ ForSetupCallback(
|
||||
TclSmallFreeEx(interp, iterPtr);
|
||||
return result;
|
||||
}
|
||||
TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
|
||||
Tcl_NRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
@@ -2472,7 +2447,7 @@ TclNRForIterCallback(
|
||||
|
||||
Tcl_ResetResult(interp);
|
||||
TclNewObj(boolObj);
|
||||
TclNRAddCallback(interp, ForCondCallback, iterPtr, boolObj, NULL,
|
||||
Tcl_NRAddCallback(interp, ForCondCallback, iterPtr, boolObj, NULL,
|
||||
NULL);
|
||||
return Tcl_NRExprObj(interp, iterPtr->cond, boolObj);
|
||||
case TCL_BREAK:
|
||||
@@ -2493,7 +2468,6 @@ ForCondCallback(
|
||||
Tcl_Interp *interp,
|
||||
int result)
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
ForIterData *iterPtr = data[0];
|
||||
Tcl_Obj *boolObj = data[1];
|
||||
int value;
|
||||
@@ -2510,16 +2484,14 @@ ForCondCallback(
|
||||
Tcl_DecrRefCount(boolObj);
|
||||
|
||||
if (value) {
|
||||
/* TIP #280. */
|
||||
if (iterPtr->next) {
|
||||
TclNRAddCallback(interp, ForNextCallback, iterPtr, NULL, NULL,
|
||||
Tcl_NRAddCallback(interp, ForNextCallback, iterPtr, NULL, NULL,
|
||||
NULL);
|
||||
} else {
|
||||
TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL,
|
||||
Tcl_NRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL,
|
||||
NULL, NULL);
|
||||
}
|
||||
return TclNREvalObjEx(interp, iterPtr->body, 0, iPtr->cmdFramePtr,
|
||||
iterPtr->word);
|
||||
return TclNREvalObjEx(interp, iterPtr->body, 0);
|
||||
}
|
||||
TclSmallFreeEx(interp, iterPtr);
|
||||
return result;
|
||||
@@ -2531,22 +2503,16 @@ ForNextCallback(
|
||||
Tcl_Interp *interp,
|
||||
int result)
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
ForIterData *iterPtr = data[0];
|
||||
Tcl_Obj *next = iterPtr->next;
|
||||
|
||||
if ((result == TCL_OK) || (result == TCL_CONTINUE)) {
|
||||
TclNRAddCallback(interp, ForPostNextCallback, iterPtr, NULL, NULL,
|
||||
Tcl_NRAddCallback(interp, ForPostNextCallback, iterPtr, NULL, NULL,
|
||||
NULL);
|
||||
|
||||
/*
|
||||
* TIP #280. Make invoking context available to next script.
|
||||
*/
|
||||
|
||||
return TclNREvalObjEx(interp, next, 0, iPtr->cmdFramePtr, 3);
|
||||
return TclNREvalObjEx(interp, next, 0);
|
||||
}
|
||||
|
||||
TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
|
||||
Tcl_NRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
|
||||
return result;
|
||||
}
|
||||
|
||||
@@ -2565,7 +2531,7 @@ ForPostNextCallback(
|
||||
}
|
||||
return result;
|
||||
}
|
||||
TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
|
||||
Tcl_NRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
|
||||
return result;
|
||||
}
|
||||
|
||||
@@ -2736,9 +2702,8 @@ EachloopCmd(
|
||||
goto done;
|
||||
}
|
||||
|
||||
TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL);
|
||||
return TclNREvalObjEx(interp, objv[objc-1], 0,
|
||||
((Interp *) interp)->cmdFramePtr, objc-1);
|
||||
Tcl_NRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL);
|
||||
return TclNREvalObjEx(interp, objv[objc-1], 0);
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -2802,9 +2767,8 @@ ForeachLoopStep(
|
||||
goto done;
|
||||
}
|
||||
|
||||
TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL);
|
||||
return TclNREvalObjEx(interp, statePtr->bodyPtr, 0,
|
||||
((Interp *) interp)->cmdFramePtr, statePtr->bodyIdx);
|
||||
Tcl_NRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL);
|
||||
return TclNREvalObjEx(interp, statePtr->bodyPtr, 0);
|
||||
}
|
||||
|
||||
/*
|
||||
|
||||
+3
-418
@@ -119,12 +119,6 @@ static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp,
|
||||
int objc, Tcl_Obj *const objv[]);
|
||||
static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp,
|
||||
int objc, Tcl_Obj *const objv[]);
|
||||
/* TIP #348 - New 'info' subcommand 'errorstack' */
|
||||
static int InfoErrorStackCmd(ClientData dummy, Tcl_Interp *interp,
|
||||
int objc, Tcl_Obj *const objv[]);
|
||||
/* TIP #280 - New 'info' subcommand 'frame' */
|
||||
static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp,
|
||||
int objc, Tcl_Obj *const objv[]);
|
||||
static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp,
|
||||
int objc, Tcl_Obj *const objv[]);
|
||||
static int InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp,
|
||||
@@ -168,9 +162,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
|
||||
{"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
|
||||
{"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
|
||||
{"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0},
|
||||
{"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
|
||||
{"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0},
|
||||
{"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
|
||||
{"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
|
||||
{"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
|
||||
{"hostname", InfoHostnameCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
|
||||
@@ -254,7 +246,6 @@ IfConditionCallback(
|
||||
Tcl_Interp *interp,
|
||||
int result)
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
int objc = PTR2INT(data[0]);
|
||||
Tcl_Obj *const *objv = data[1];
|
||||
int i = PTR2INT(data[2]);
|
||||
@@ -297,12 +288,7 @@ IfConditionCallback(
|
||||
i++;
|
||||
if (i >= objc) {
|
||||
if (thenScriptIndex) {
|
||||
/*
|
||||
* TIP #280. Make invoking context available to branch.
|
||||
*/
|
||||
|
||||
return TclNREvalObjEx(interp, objv[thenScriptIndex], 0,
|
||||
iPtr->cmdFramePtr, thenScriptIndex);
|
||||
return TclNREvalObjEx(interp, objv[thenScriptIndex], 0);
|
||||
}
|
||||
return TCL_OK;
|
||||
}
|
||||
@@ -354,14 +340,9 @@ IfConditionCallback(
|
||||
return TCL_ERROR;
|
||||
}
|
||||
if (thenScriptIndex) {
|
||||
/*
|
||||
* TIP #280. Make invoking context available to branch/else.
|
||||
*/
|
||||
|
||||
return TclNREvalObjEx(interp, objv[thenScriptIndex], 0,
|
||||
iPtr->cmdFramePtr, thenScriptIndex);
|
||||
return TclNREvalObjEx(interp, objv[thenScriptIndex], 0);
|
||||
}
|
||||
return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i);
|
||||
return TclNREvalObjEx(interp, objv[i], 0);
|
||||
|
||||
missingScript:
|
||||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||||
@@ -1025,55 +1006,6 @@ InfoDefaultCmd(
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* InfoErrorStackCmd --
|
||||
*
|
||||
* Called to implement the "info errorstack" command that returns information
|
||||
* about the last error's call stack. Handles the following syntax:
|
||||
*
|
||||
* info errorstack ?interp?
|
||||
*
|
||||
* Results:
|
||||
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
|
||||
*
|
||||
* Side effects:
|
||||
* Returns a result in the interpreter's result object. If there is an
|
||||
* error, the result is an error message.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
static int
|
||||
InfoErrorStackCmd(
|
||||
ClientData dummy, /* Not used. */
|
||||
Tcl_Interp *interp, /* Current interpreter. */
|
||||
int objc, /* Number of arguments. */
|
||||
Tcl_Obj *const objv[]) /* Argument objects. */
|
||||
{
|
||||
Tcl_Interp *target;
|
||||
Interp *iPtr;
|
||||
|
||||
if ((objc != 1) && (objc != 2)) {
|
||||
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
target = interp;
|
||||
if (objc == 2) {
|
||||
target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
|
||||
if (target == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
}
|
||||
|
||||
iPtr = (Interp *) target;
|
||||
Tcl_SetObjResult(interp, iPtr->errorStack);
|
||||
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
@@ -1117,353 +1049,6 @@ TclInfoExistsCmd(
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* InfoFrameCmd --
|
||||
* TIP #280
|
||||
*
|
||||
* Called to implement the "info frame" command that returns the location
|
||||
* of either the currently executing command, or its caller. Handles the
|
||||
* following syntax:
|
||||
*
|
||||
* info frame ?number?
|
||||
*
|
||||
* Results:
|
||||
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
|
||||
*
|
||||
* Side effects:
|
||||
* Returns a result in the interpreter's result object. If there is an
|
||||
* error, the result is an error message.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
static int
|
||||
InfoFrameCmd(
|
||||
ClientData dummy, /* Not used. */
|
||||
Tcl_Interp *interp, /* Current interpreter. */
|
||||
int objc, /* Number of arguments. */
|
||||
Tcl_Obj *const objv[]) /* Argument objects. */
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
int level, topLevel, code = TCL_OK;
|
||||
CmdFrame *runPtr, *framePtr;
|
||||
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
|
||||
|
||||
if (objc > 2) {
|
||||
Tcl_WrongNumArgs(interp, 1, objv, "?number?");
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
topLevel = ((iPtr->cmdFramePtr == NULL)
|
||||
? 0
|
||||
: iPtr->cmdFramePtr->level);
|
||||
|
||||
if (corPtr) {
|
||||
/*
|
||||
* A coroutine: must fix the level computations AND the cmdFrame chain,
|
||||
* which is interrupted at the base.
|
||||
*/
|
||||
|
||||
CmdFrame *lastPtr = NULL;
|
||||
|
||||
runPtr = iPtr->cmdFramePtr;
|
||||
|
||||
/* TODO - deal with overflow */
|
||||
topLevel += corPtr->caller.cmdFramePtr->level;
|
||||
while (runPtr) {
|
||||
runPtr->level += corPtr->caller.cmdFramePtr->level;
|
||||
lastPtr = runPtr;
|
||||
runPtr = runPtr->nextPtr;
|
||||
}
|
||||
if (lastPtr) {
|
||||
lastPtr->nextPtr = corPtr->caller.cmdFramePtr;
|
||||
} else {
|
||||
iPtr->cmdFramePtr = corPtr->caller.cmdFramePtr;
|
||||
}
|
||||
}
|
||||
|
||||
if (objc == 1) {
|
||||
/*
|
||||
* Just "info frame".
|
||||
*/
|
||||
|
||||
Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel));
|
||||
goto done;
|
||||
}
|
||||
|
||||
/*
|
||||
* We've got "info frame level" and must parse the level first.
|
||||
*/
|
||||
|
||||
if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) {
|
||||
code = TCL_ERROR;
|
||||
goto done;
|
||||
}
|
||||
|
||||
if ((level > topLevel) || (level <= - topLevel)) {
|
||||
levelError:
|
||||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||||
"bad level \"%s\"", TclGetString(objv[1])));
|
||||
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME",
|
||||
TclGetString(objv[1]), NULL);
|
||||
code = TCL_ERROR;
|
||||
goto done;
|
||||
}
|
||||
|
||||
/*
|
||||
* Let us convert to relative so that we know how many levels to go back
|
||||
*/
|
||||
|
||||
if (level > 0) {
|
||||
level -= topLevel;
|
||||
}
|
||||
|
||||
framePtr = iPtr->cmdFramePtr;
|
||||
while (++level <= 0) {
|
||||
framePtr = framePtr->nextPtr;
|
||||
if (!framePtr) {
|
||||
goto levelError;
|
||||
}
|
||||
}
|
||||
|
||||
Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr));
|
||||
|
||||
done:
|
||||
if (corPtr) {
|
||||
|
||||
if (iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr) {
|
||||
iPtr->cmdFramePtr = NULL;
|
||||
} else {
|
||||
runPtr = iPtr->cmdFramePtr;
|
||||
while (runPtr->nextPtr != corPtr->caller.cmdFramePtr) {
|
||||
runPtr->level -= corPtr->caller.cmdFramePtr->level;
|
||||
runPtr = runPtr->nextPtr;
|
||||
}
|
||||
runPtr->level = 1;
|
||||
runPtr->nextPtr = NULL;
|
||||
}
|
||||
|
||||
}
|
||||
return code;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclInfoFrame --
|
||||
*
|
||||
* Core of InfoFrameCmd, returns TIP280 dict for a given frame.
|
||||
*
|
||||
* Results:
|
||||
* Returns TIP280 dict.
|
||||
*
|
||||
* Side effects:
|
||||
* None.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
Tcl_Obj *
|
||||
TclInfoFrame(
|
||||
Tcl_Interp *interp, /* Current interpreter. */
|
||||
CmdFrame *framePtr) /* Frame to get info for. */
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
Tcl_Obj *tmpObj;
|
||||
Tcl_Obj *lv[20]; /* Keep uptodate when more keys are added to
|
||||
* the dict. */
|
||||
int lc = 0;
|
||||
/*
|
||||
* This array is indexed by the TCL_LOCATION_... values, except
|
||||
* for _LAST.
|
||||
*/
|
||||
static const char *const typeString[TCL_LOCATION_LAST] = {
|
||||
"eval", "eval", "eval", "precompiled", "source", "proc"
|
||||
};
|
||||
Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL;
|
||||
|
||||
/*
|
||||
* Pull the information and construct the dictionary to return, as list.
|
||||
* Regarding use of the CmdFrame fields see tclInt.h, and its definition.
|
||||
*/
|
||||
|
||||
#define ADD_PAIR(name, value) \
|
||||
TclNewLiteralStringObj(tmpObj, name); \
|
||||
lv[lc++] = tmpObj; \
|
||||
lv[lc++] = (value)
|
||||
|
||||
switch (framePtr->type) {
|
||||
case TCL_LOCATION_EVAL:
|
||||
/*
|
||||
* Evaluation, dynamic script. Type, line, cmd, the latter through
|
||||
* str.
|
||||
*/
|
||||
|
||||
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
|
||||
ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
|
||||
ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd,
|
||||
framePtr->cmd.str.len));
|
||||
break;
|
||||
|
||||
case TCL_LOCATION_EVAL_LIST:
|
||||
/*
|
||||
* List optimized evaluation. Type, line, cmd, the latter through
|
||||
* listPtr, possibly a frame.
|
||||
*/
|
||||
|
||||
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
|
||||
ADD_PAIR("line", Tcl_NewIntObj(1));
|
||||
|
||||
/*
|
||||
* We put a duplicate of the command list obj into the result to
|
||||
* ensure that the 'pure List'-property of the command itself is not
|
||||
* destroyed. Otherwise the query here would disable the list
|
||||
* optimization path in Tcl_EvalObjEx.
|
||||
*/
|
||||
|
||||
ADD_PAIR("cmd", Tcl_DuplicateObj(framePtr->cmd.listPtr));
|
||||
break;
|
||||
|
||||
case TCL_LOCATION_PREBC:
|
||||
/*
|
||||
* Precompiled. Result contains the type as signal, nothing else.
|
||||
*/
|
||||
|
||||
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
|
||||
break;
|
||||
|
||||
case TCL_LOCATION_BC: {
|
||||
/*
|
||||
* Execution of bytecode. Talk to the BC engine to fill out the frame.
|
||||
*/
|
||||
|
||||
CmdFrame *fPtr = TclStackAlloc(interp, sizeof(CmdFrame));
|
||||
|
||||
*fPtr = *framePtr;
|
||||
|
||||
/*
|
||||
* Note:
|
||||
* Type BC => f.data.eval.path is not used.
|
||||
* f.data.tebc.codePtr is used instead.
|
||||
*/
|
||||
|
||||
TclGetSrcInfoForPc(fPtr);
|
||||
|
||||
/*
|
||||
* Now filled: cmd.str.(cmd,len), line
|
||||
* Possibly modified: type, path!
|
||||
*/
|
||||
|
||||
ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1));
|
||||
if (fPtr->line) {
|
||||
ADD_PAIR("line", Tcl_NewIntObj(fPtr->line[0]));
|
||||
}
|
||||
|
||||
if (fPtr->type == TCL_LOCATION_SOURCE) {
|
||||
ADD_PAIR("file", fPtr->data.eval.path);
|
||||
|
||||
/*
|
||||
* Death of reference by TclGetSrcInfoForPc.
|
||||
*/
|
||||
|
||||
Tcl_DecrRefCount(fPtr->data.eval.path);
|
||||
}
|
||||
|
||||
ADD_PAIR("cmd",
|
||||
Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len));
|
||||
TclStackFree(interp, fPtr);
|
||||
break;
|
||||
}
|
||||
|
||||
case TCL_LOCATION_SOURCE:
|
||||
/*
|
||||
* Evaluation of a script file.
|
||||
*/
|
||||
|
||||
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
|
||||
ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
|
||||
ADD_PAIR("file", framePtr->data.eval.path);
|
||||
|
||||
/*
|
||||
* Refcount framePtr->data.eval.path goes up when lv is converted into
|
||||
* the result list object.
|
||||
*/
|
||||
|
||||
ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd,
|
||||
framePtr->cmd.str.len));
|
||||
break;
|
||||
|
||||
case TCL_LOCATION_PROC:
|
||||
Tcl_Panic("TCL_LOCATION_PROC found in standard frame");
|
||||
break;
|
||||
}
|
||||
|
||||
/*
|
||||
* 'proc'. Common to all frame types. Conditional on having an associated
|
||||
* Procedure CallFrame.
|
||||
*/
|
||||
|
||||
if (procPtr != NULL) {
|
||||
Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr;
|
||||
|
||||
if (namePtr) {
|
||||
Tcl_Obj *procNameObj;
|
||||
|
||||
/*
|
||||
* This is a regular command.
|
||||
*/
|
||||
|
||||
TclNewObj(procNameObj);
|
||||
Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
|
||||
procNameObj);
|
||||
ADD_PAIR("proc", procNameObj);
|
||||
} else if (procPtr->cmdPtr->clientData) {
|
||||
ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData;
|
||||
int i;
|
||||
|
||||
/*
|
||||
* This is a non-standard command. Luckily, it's told us how to
|
||||
* render extra information about its frame.
|
||||
*/
|
||||
|
||||
for (i=0 ; i<efiPtr->length ; i++) {
|
||||
lv[lc++] = Tcl_NewStringObj(efiPtr->fields[i].name, -1);
|
||||
if (efiPtr->fields[i].proc) {
|
||||
lv[lc++] =
|
||||
efiPtr->fields[i].proc(efiPtr->fields[i].clientData);
|
||||
} else {
|
||||
lv[lc++] = efiPtr->fields[i].clientData;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* 'level'. Common to all frame types. Conditional on having an associated
|
||||
* _visible_ CallFrame.
|
||||
*/
|
||||
|
||||
if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) {
|
||||
CallFrame *current = framePtr->framePtr;
|
||||
CallFrame *top = iPtr->varFramePtr;
|
||||
CallFrame *idx;
|
||||
|
||||
for (idx=top ; idx!=NULL ; idx=idx->callerVarPtr) {
|
||||
if (idx == current) {
|
||||
int c = framePtr->framePtr->level;
|
||||
int t = iPtr->varFramePtr->level;
|
||||
|
||||
ADD_PAIR("level", Tcl_NewIntObj(t - c));
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return Tcl_NewListObj(lc, lv);
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
|
||||
+8
-159
@@ -3480,12 +3480,6 @@ TclNRSwitchObjCmd(
|
||||
Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
|
||||
Tcl_Obj *const *savedObjv = objv;
|
||||
Tcl_RegExp regExpr = NULL;
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
int pc = 0;
|
||||
int bidx = 0; /* Index of body argument. */
|
||||
Tcl_Obj *blist = NULL; /* List obj which is the body */
|
||||
CmdFrame *ctxPtr; /* Copy of the topmost cmdframe, to allow us
|
||||
* to mess with the line information */
|
||||
|
||||
/*
|
||||
* If you add options that make -e and -g not unique prefixes of -exact or
|
||||
@@ -3609,22 +3603,16 @@ TclNRSwitchObjCmd(
|
||||
stringObj = objv[i];
|
||||
objc -= i + 1;
|
||||
objv += i + 1;
|
||||
bidx = i + 1; /* First after the match string. */
|
||||
|
||||
/*
|
||||
* If all of the pattern/command pairs are lumped into a single argument,
|
||||
* split them out again.
|
||||
*
|
||||
* TIP #280: Determine the lines the words in the list start at, based on
|
||||
* the same data for the list word itself. The cmdFramePtr line
|
||||
* information is manipulated directly.
|
||||
*/
|
||||
|
||||
splitObjs = 0;
|
||||
if (objc == 1) {
|
||||
Tcl_Obj **listv;
|
||||
|
||||
blist = objv[0];
|
||||
if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){
|
||||
return TCL_ERROR;
|
||||
}
|
||||
@@ -3852,58 +3840,6 @@ TclNRSwitchObjCmd(
|
||||
*/
|
||||
|
||||
matchFound:
|
||||
ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
|
||||
*ctxPtr = *iPtr->cmdFramePtr;
|
||||
|
||||
if (splitObjs) {
|
||||
/*
|
||||
* We have to perform the GetSrc and other type dependent handling of
|
||||
* the frame here because we are munging with the line numbers,
|
||||
* something the other commands like if, etc. are not doing. Them are
|
||||
* fine with simply passing the CmdFrame through and having the
|
||||
* special handling done in 'info frame', or the bc compiler
|
||||
*/
|
||||
|
||||
if (ctxPtr->type == TCL_LOCATION_BC) {
|
||||
/*
|
||||
* Type BC => ctxPtr->data.eval.path is not used.
|
||||
* ctxPtr->data.tebc.codePtr is used instead.
|
||||
*/
|
||||
|
||||
TclGetSrcInfoForPc(ctxPtr);
|
||||
pc = 1;
|
||||
|
||||
/*
|
||||
* The line information in the cmdFrame is now a copy we do not
|
||||
* own.
|
||||
*/
|
||||
}
|
||||
|
||||
if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
|
||||
int bline = ctxPtr->line[bidx];
|
||||
|
||||
ctxPtr->line = ckalloc(objc * sizeof(int));
|
||||
ctxPtr->nline = objc;
|
||||
TclListLines(blist, bline, objc, ctxPtr->line, objv);
|
||||
} else {
|
||||
/*
|
||||
* This is either a dynamic code word, when all elements are
|
||||
* relative to themselves, or something else less expected and
|
||||
* where we have no information. The result is the same in both
|
||||
* cases; tell the code to come that it doesn't know where it is,
|
||||
* which triggers reversion to the old behavior.
|
||||
*/
|
||||
|
||||
int k;
|
||||
|
||||
ctxPtr->line = ckalloc(objc * sizeof(int));
|
||||
ctxPtr->nline = objc;
|
||||
for (k=0; k < objc; k++) {
|
||||
ctxPtr->line[k] = -1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
for (j = i + 1; ; j += 2) {
|
||||
if (j >= objc) {
|
||||
/*
|
||||
@@ -3918,13 +3854,8 @@ TclNRSwitchObjCmd(
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* TIP #280: Make invoking context available to switch branch.
|
||||
*/
|
||||
|
||||
Tcl_NRAddCallback(interp, SwitchPostProc, INT2PTR(splitObjs), ctxPtr,
|
||||
INT2PTR(pc), (ClientData) pattern);
|
||||
return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j);
|
||||
Tcl_NRAddCallback(interp, SwitchPostProc, (ClientData) pattern, NULL, NULL, NULL);
|
||||
return TclNREvalObjEx(interp, objv[j], 0);
|
||||
}
|
||||
|
||||
static int
|
||||
@@ -3935,27 +3866,9 @@ SwitchPostProc(
|
||||
{
|
||||
/* Unpack the preserved data */
|
||||
|
||||
int splitObjs = PTR2INT(data[0]);
|
||||
CmdFrame *ctxPtr = data[1];
|
||||
int pc = PTR2INT(data[2]);
|
||||
const char *pattern = data[3];
|
||||
const char *pattern = data[0];
|
||||
int patternLength = strlen(pattern);
|
||||
|
||||
/*
|
||||
* Clean up TIP 280 context information
|
||||
*/
|
||||
|
||||
if (splitObjs) {
|
||||
ckfree(ctxPtr->line);
|
||||
if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) {
|
||||
/*
|
||||
* Death of SrcInfo reference.
|
||||
*/
|
||||
|
||||
Tcl_DecrRefCount(ctxPtr->data.eval.path);
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* Generate an error message if necessary.
|
||||
*/
|
||||
@@ -3969,7 +3882,6 @@ SwitchPostProc(
|
||||
(overflow ? limit : patternLength), pattern,
|
||||
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
|
||||
}
|
||||
TclStackFree(interp, ctxPtr);
|
||||
return result;
|
||||
}
|
||||
|
||||
@@ -4298,8 +4210,7 @@ TclNRTryObjCmd(
|
||||
|
||||
Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj,
|
||||
(ClientData)objv, INT2PTR(objc));
|
||||
return TclNREvalObjEx(interp, bodyObj, 0,
|
||||
((Interp *) interp)->cmdFramePtr, 1);
|
||||
return TclNREvalObjEx(interp, bodyObj, 0);
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -4514,8 +4425,7 @@ TryPostBody(
|
||||
Tcl_NRAddCallback(interp, TryPostHandler, objv, options, info[0],
|
||||
INT2PTR((finallyObj == NULL) ? 0 : objc - 1));
|
||||
Tcl_DecrRefCount(handlersObj);
|
||||
return TclNREvalObjEx(interp, handlerBodyObj, 0,
|
||||
((Interp *) interp)->cmdFramePtr, 4*i + 5);
|
||||
return TclNREvalObjEx(interp, handlerBodyObj, 0);
|
||||
|
||||
handlerFailed:
|
||||
resultObj = Tcl_GetObjResult(interp);
|
||||
@@ -4541,8 +4451,7 @@ TryPostBody(
|
||||
if (finallyObj != NULL) {
|
||||
Tcl_NRAddCallback(interp, TryPostFinal, resultObj, options, cmdObj,
|
||||
NULL);
|
||||
return TclNREvalObjEx(interp, finallyObj, 0,
|
||||
((Interp *) interp)->cmdFramePtr, objc - 1);
|
||||
return TclNREvalObjEx(interp, finallyObj, 0);
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -4621,14 +4530,11 @@ TryPostHandler(
|
||||
*/
|
||||
|
||||
if (finallyObj != NULL) {
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
|
||||
Tcl_NRAddCallback(interp, TryPostFinal, resultObj, options, cmdObj,
|
||||
NULL);
|
||||
|
||||
/* The 'finally' script is always the last argument word. */
|
||||
return TclNREvalObjEx(interp, finallyObj, 0, iPtr->cmdFramePtr,
|
||||
finally);
|
||||
return TclNREvalObjEx(interp, finallyObj, 0);
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -4754,69 +4660,12 @@ TclNRWhileObjCmd(
|
||||
iterPtr->body = objv[2];
|
||||
iterPtr->next = NULL;
|
||||
iterPtr->msg = "\n (\"while\" body line %d)";
|
||||
iterPtr->word = 2;
|
||||
|
||||
TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL,
|
||||
Tcl_NRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL,
|
||||
NULL, NULL);
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclListLines --
|
||||
*
|
||||
* ???
|
||||
*
|
||||
* Results:
|
||||
* Filled in array of line numbers?
|
||||
*
|
||||
* Side effects:
|
||||
* None.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
void
|
||||
TclListLines(
|
||||
Tcl_Obj *listObj, /* Pointer to obj holding a string with list
|
||||
* structure. Assumed to be valid. Assumed to
|
||||
* contain n elements. */
|
||||
int line, /* Line the list as a whole starts on. */
|
||||
int n, /* #elements in lines */
|
||||
int *lines, /* Array of line numbers, to fill. */
|
||||
Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of
|
||||
* derived continuation data */
|
||||
{
|
||||
const char *listStr = Tcl_GetString(listObj);
|
||||
const char *listHead = listStr;
|
||||
int i, length = strlen(listStr);
|
||||
const char *element = NULL, *next = NULL;
|
||||
ContLineLoc *clLocPtr = TclContinuationsGet(listObj);
|
||||
int *clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL);
|
||||
|
||||
for (i = 0; i < n; i++) {
|
||||
TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL);
|
||||
|
||||
TclAdvanceLines(&line, listStr, element);
|
||||
/* Leading whitespace */
|
||||
TclAdvanceContinuations(&line, &clNext, element - listHead);
|
||||
if (elems && clNext) {
|
||||
TclContinuationsEnterDerived(elems[i], element-listHead, clNext);
|
||||
}
|
||||
lines[i] = line;
|
||||
length -= (next - listStr);
|
||||
TclAdvanceLines(&line, element, next);
|
||||
/* Element */
|
||||
listStr = next;
|
||||
|
||||
if (*element == 0) {
|
||||
/* ASSERT i == n */
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* Local Variables:
|
||||
* mode: c
|
||||
|
||||
+83
-190
File diff suppressed because it is too large
Load Diff
+20
-152
@@ -15,8 +15,7 @@
|
||||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
#include "tclCompile.h"
|
||||
#include "tclEngineInt.h"
|
||||
|
||||
/*
|
||||
* Prototypes for procedures defined later in this file:
|
||||
@@ -30,8 +29,7 @@ static void PrintJumptableInfo(ClientData clientData,
|
||||
static int PushVarName(Tcl_Interp *interp,
|
||||
Tcl_Token *varTokenPtr, CompileEnv *envPtr,
|
||||
int flags, int *localIndexPtr,
|
||||
int *simpleVarNamePtr, int *isScalarPtr,
|
||||
int line, int *clNext);
|
||||
int *simpleVarNamePtr, int *isScalarPtr);
|
||||
static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
|
||||
Tcl_Parse *parsePtr, const char *identity,
|
||||
int instruction, CompileEnv *envPtr);
|
||||
@@ -45,17 +43,13 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp,
|
||||
Tcl_Parse *parsePtr, int instruction,
|
||||
CompileEnv *envPtr);
|
||||
static void IssueSwitchChainedTests(Tcl_Interp *interp,
|
||||
CompileEnv *envPtr, ExtCmdLoc *mapPtr,
|
||||
int eclIndex, int mode, int noCase,
|
||||
CompileEnv *envPtr, int mode, int noCase,
|
||||
int valueIndex, Tcl_Token *valueTokenPtr,
|
||||
int numWords, Tcl_Token **bodyToken,
|
||||
int *bodyLines, int **bodyNext);
|
||||
int numWords, Tcl_Token **bodyToken);
|
||||
static void IssueSwitchJumpTable(Tcl_Interp *interp,
|
||||
CompileEnv *envPtr, ExtCmdLoc *mapPtr,
|
||||
int eclIndex, int valueIndex,
|
||||
CompileEnv *envPtr, int valueIndex,
|
||||
Tcl_Token *valueTokenPtr, int numWords,
|
||||
Tcl_Token **bodyToken, int *bodyLines,
|
||||
int **bodyContLines);
|
||||
Tcl_Token **bodyToken);
|
||||
static int IssueTryFinallyInstructions(Tcl_Interp *interp,
|
||||
CompileEnv *envPtr, Tcl_Token *bodyToken,
|
||||
int numHandlers, int *matchCodes,
|
||||
@@ -81,34 +75,10 @@ static int IssueTryInstructions(Tcl_Interp *interp,
|
||||
TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
|
||||
(tokenPtr)[1].size), (envPtr)); \
|
||||
} else { \
|
||||
envPtr->line = mapPtr->loc[eclIndex].line[word]; \
|
||||
envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \
|
||||
TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
|
||||
(envPtr)); \
|
||||
}
|
||||
|
||||
/*
|
||||
* TIP #280: Remember the per-word line information of the current command. An
|
||||
* index is used instead of a pointer as recursive compilation may reallocate,
|
||||
* i.e. move, the array. This is also the reason to save the nuloc now, it may
|
||||
* change during the course of the function.
|
||||
*
|
||||
* Macro to encapsulate the variable definition and setup.
|
||||
*/
|
||||
|
||||
#define DefineLineInformation \
|
||||
ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
|
||||
int eclIndex = mapPtr->nuloc - 1
|
||||
|
||||
#define SetLineInformation(word) \
|
||||
envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
|
||||
envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
|
||||
|
||||
#define PushVarNameWord(i,v,e,f,l,s,sc,word) \
|
||||
PushVarName(i,v,e,f,l,s,sc, \
|
||||
mapPtr->loc[eclIndex].line[(word)], \
|
||||
mapPtr->loc[eclIndex].next[(word)])
|
||||
|
||||
/*
|
||||
* Flags bits used by PushVarName.
|
||||
*/
|
||||
@@ -138,7 +108,7 @@ const AuxDataType tclJumptableInfoType = {
|
||||
#define OP44(name,val1,val2) \
|
||||
TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
|
||||
#define BODY(token,index) \
|
||||
SetLineInformation((index));CompileBody(envPtr,(token),interp)
|
||||
CompileBody(envPtr,(token),interp)
|
||||
#define PUSH(str) \
|
||||
PushLiteral(envPtr,(str),strlen(str))
|
||||
#define JUMP(var,name) \
|
||||
@@ -179,7 +149,6 @@ TclCompileSetCmd(
|
||||
{
|
||||
Tcl_Token *varTokenPtr, *valueTokenPtr;
|
||||
int isAssignment, isScalar, simpleVarName, localIndex, numWords;
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
|
||||
numWords = parsePtr->numWords;
|
||||
if ((numWords != 2) && (numWords != 3)) {
|
||||
@@ -196,8 +165,8 @@ TclCompileSetCmd(
|
||||
*/
|
||||
|
||||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||||
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
|
||||
&localIndex, &simpleVarName, &isScalar, 1);
|
||||
PushVarName(interp, varTokenPtr, envPtr, 0,
|
||||
&localIndex, &simpleVarName, &isScalar);
|
||||
|
||||
/*
|
||||
* If we are doing an assignment, push the new value.
|
||||
@@ -276,7 +245,6 @@ TclCompileStringCmpCmd(
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
Tcl_Token *tokenPtr;
|
||||
|
||||
/*
|
||||
@@ -308,7 +276,6 @@ TclCompileStringEqualCmd(
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
Tcl_Token *tokenPtr;
|
||||
|
||||
/*
|
||||
@@ -340,7 +307,6 @@ TclCompileStringFirstCmd(
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
Tcl_Token *tokenPtr;
|
||||
|
||||
/*
|
||||
@@ -372,7 +338,6 @@ TclCompileStringLastCmd(
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
Tcl_Token *tokenPtr;
|
||||
|
||||
/*
|
||||
@@ -404,7 +369,6 @@ TclCompileStringIndexCmd(
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
Tcl_Token *tokenPtr;
|
||||
|
||||
if (parsePtr->numWords != 3) {
|
||||
@@ -432,7 +396,6 @@ TclCompileStringMatchCmd(
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
Tcl_Token *tokenPtr;
|
||||
int i, length, exactMatch = 0, nocase = 0;
|
||||
const char *str;
|
||||
@@ -486,7 +449,6 @@ TclCompileStringMatchCmd(
|
||||
}
|
||||
PushLiteral(envPtr, str, length);
|
||||
} else {
|
||||
SetLineInformation(i+1+nocase);
|
||||
CompileTokens(envPtr, tokenPtr, interp);
|
||||
}
|
||||
tokenPtr = TokenAfter(tokenPtr);
|
||||
@@ -513,7 +475,6 @@ TclCompileStringLenCmd(
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
Tcl_Token *tokenPtr;
|
||||
Tcl_Obj *objPtr;
|
||||
|
||||
@@ -536,7 +497,6 @@ TclCompileStringLenCmd(
|
||||
len = sprintf(buf, "%d", len);
|
||||
PushLiteral(envPtr, buf, len);
|
||||
} else {
|
||||
SetLineInformation(1);
|
||||
CompileTokens(envPtr, tokenPtr, interp);
|
||||
TclEmitOpcode(INST_STR_LEN, envPtr);
|
||||
}
|
||||
@@ -553,7 +513,6 @@ TclCompileStringMapCmd(
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
Tcl_Token *mapTokenPtr, *stringTokenPtr;
|
||||
Tcl_Obj *mapObj, **objv;
|
||||
char *bytes;
|
||||
@@ -616,7 +575,6 @@ TclCompileStringRangeCmd(
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr;
|
||||
Tcl_Obj *tmpObj;
|
||||
int idx1, idx2, result;
|
||||
@@ -731,7 +689,6 @@ TclCompileSubstCmd(
|
||||
Tcl_Obj **objv/*, *toSubst = NULL*/;
|
||||
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||||
int code = TCL_ERROR;
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
|
||||
if (numArgs == 0) {
|
||||
return TCL_ERROR;
|
||||
@@ -775,9 +732,8 @@ TclCompileSubstCmd(
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
SetLineInformation(numArgs);
|
||||
TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size,
|
||||
flags, mapPtr->loc[eclIndex].line[numArgs], envPtr);
|
||||
flags, envPtr);
|
||||
|
||||
/* TclDecrRefCount(toSubst);*/
|
||||
return TCL_OK;
|
||||
@@ -789,11 +745,10 @@ TclSubstCompile(
|
||||
const char *bytes,
|
||||
int numBytes,
|
||||
int flags,
|
||||
int line,
|
||||
CompileEnv *envPtr)
|
||||
{
|
||||
Tcl_Token *endTokenPtr, *tokenPtr;
|
||||
int breakOffset = 0, count = 0, bline = line;
|
||||
int breakOffset = 0, count = 0;
|
||||
Tcl_Parse parse;
|
||||
Tcl_InterpState state = NULL;
|
||||
|
||||
@@ -825,8 +780,6 @@ TclSubstCompile(
|
||||
literal = TclRegisterNewLiteral(envPtr,
|
||||
tokenPtr->start, tokenPtr->size);
|
||||
TclEmitPush(literal, envPtr);
|
||||
TclAdvanceLines(&bline, tokenPtr->start,
|
||||
tokenPtr->start + tokenPtr->size);
|
||||
count++;
|
||||
continue;
|
||||
case TCL_TOKEN_BS:
|
||||
@@ -859,9 +812,7 @@ TclSubstCompile(
|
||||
}
|
||||
}
|
||||
|
||||
envPtr->line = bline;
|
||||
TclCompileVarSubst(interp, tokenPtr, envPtr);
|
||||
bline = envPtr->line;
|
||||
count++;
|
||||
continue;
|
||||
}
|
||||
@@ -890,7 +841,6 @@ TclSubstCompile(
|
||||
}
|
||||
}
|
||||
|
||||
envPtr->line = bline;
|
||||
catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
|
||||
OP4( BEGIN_CATCH4, catchRange);
|
||||
ExceptionRangeStarts(envPtr, catchRange);
|
||||
@@ -1007,7 +957,6 @@ TclSubstCompile(
|
||||
Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d",
|
||||
(int) (CurrentOffset(envPtr) - endFixup.codeOffset));
|
||||
}
|
||||
bline = envPtr->line;
|
||||
}
|
||||
|
||||
while (count > 255) {
|
||||
@@ -1074,15 +1023,10 @@ TclCompileSwitchCmd(
|
||||
|
||||
Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */
|
||||
Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */
|
||||
int *bodyLines; /* Array of line numbers for body list
|
||||
* items. */
|
||||
int **bodyContLines; /* Array of continuation line info. */
|
||||
int noCase; /* Has the -nocase flag been given? */
|
||||
int foundMode = 0; /* Have we seen a mode flag yet? */
|
||||
int i, valueIndex;
|
||||
int result = TCL_ERROR;
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
int *clNext = envPtr->clNext;
|
||||
|
||||
/*
|
||||
* Only handle the following versions:
|
||||
@@ -1221,10 +1165,6 @@ TclCompileSwitchCmd(
|
||||
if (numWords == 1) {
|
||||
const char *bytes;
|
||||
int maxLen, numBytes;
|
||||
int bline; /* TIP #280: line of the pattern/action list,
|
||||
* and start of list for when tracking the
|
||||
* location. This list comes immediately after
|
||||
* the value we switch on. */
|
||||
|
||||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||||
return TCL_ERROR;
|
||||
@@ -1239,10 +1179,7 @@ TclCompileSwitchCmd(
|
||||
}
|
||||
bodyTokenArray = ckalloc(sizeof(Tcl_Token) * maxLen);
|
||||
bodyToken = ckalloc(sizeof(Tcl_Token *) * maxLen);
|
||||
bodyLines = ckalloc(sizeof(int) * maxLen);
|
||||
bodyContLines = ckalloc(sizeof(int*) * maxLen);
|
||||
|
||||
bline = mapPtr->loc[eclIndex].line[valueIndex+1];
|
||||
numWords = 0;
|
||||
|
||||
while (numBytes > 0) {
|
||||
@@ -1259,20 +1196,6 @@ TclCompileSwitchCmd(
|
||||
bodyTokenArray[numWords].numComponents = 0;
|
||||
bodyToken[numWords] = bodyTokenArray + numWords;
|
||||
|
||||
/*
|
||||
* TIP #280: Now determine the line the list element starts on
|
||||
* (there is no need to do it earlier, due to the possibility of
|
||||
* aborting, see above).
|
||||
*/
|
||||
|
||||
TclAdvanceLines(&bline, prevBytes, bodyTokenArray[numWords].start);
|
||||
TclAdvanceContinuations(&bline, &clNext,
|
||||
bodyTokenArray[numWords].start - envPtr->source);
|
||||
bodyLines[numWords] = bline;
|
||||
bodyContLines[numWords] = clNext;
|
||||
TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes);
|
||||
TclAdvanceContinuations(&bline, &clNext, bytes - envPtr->source);
|
||||
|
||||
numBytes -= (bytes - prevBytes);
|
||||
numWords++;
|
||||
}
|
||||
@@ -1280,8 +1203,6 @@ TclCompileSwitchCmd(
|
||||
abort:
|
||||
ckfree((char *) bodyToken);
|
||||
ckfree((char *) bodyTokenArray);
|
||||
ckfree((char *) bodyLines);
|
||||
ckfree((char *) bodyContLines);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
} else if (numWords % 2 || numWords == 0) {
|
||||
@@ -1300,8 +1221,6 @@ TclCompileSwitchCmd(
|
||||
*/
|
||||
|
||||
bodyToken = ckalloc(sizeof(Tcl_Token *) * numWords);
|
||||
bodyLines = ckalloc(sizeof(int) * numWords);
|
||||
bodyContLines = ckalloc(sizeof(int*) * numWords);
|
||||
bodyTokenArray = NULL;
|
||||
for (i=0 ; i<numWords ; i++) {
|
||||
/*
|
||||
@@ -1315,12 +1234,6 @@ TclCompileSwitchCmd(
|
||||
}
|
||||
bodyToken[i] = tokenPtr+1;
|
||||
|
||||
/*
|
||||
* TIP #280: Copy line information from regular cmd info.
|
||||
*/
|
||||
|
||||
bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i];
|
||||
bodyContLines[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i];
|
||||
tokenPtr = TokenAfter(tokenPtr);
|
||||
}
|
||||
}
|
||||
@@ -1344,12 +1257,11 @@ TclCompileSwitchCmd(
|
||||
*/
|
||||
|
||||
if (mode == Switch_Exact) {
|
||||
IssueSwitchJumpTable(interp, envPtr, mapPtr, eclIndex, valueIndex,
|
||||
valueTokenPtr, numWords, bodyToken, bodyLines, bodyContLines);
|
||||
IssueSwitchJumpTable(interp, envPtr, valueIndex,
|
||||
valueTokenPtr, numWords, bodyToken);
|
||||
} else {
|
||||
IssueSwitchChainedTests(interp, envPtr, mapPtr, eclIndex, mode,noCase,
|
||||
valueIndex, valueTokenPtr, numWords, bodyToken, bodyLines,
|
||||
bodyContLines);
|
||||
IssueSwitchChainedTests(interp, envPtr, mode,noCase,
|
||||
valueIndex, valueTokenPtr, numWords, bodyToken);
|
||||
}
|
||||
result = TCL_OK;
|
||||
|
||||
@@ -1359,8 +1271,6 @@ TclCompileSwitchCmd(
|
||||
|
||||
freeTemporaries:
|
||||
ckfree(bodyToken);
|
||||
ckfree(bodyLines);
|
||||
ckfree(bodyContLines);
|
||||
if (bodyTokenArray != NULL) {
|
||||
ckfree(bodyTokenArray);
|
||||
}
|
||||
@@ -1387,9 +1297,6 @@ static void
|
||||
IssueSwitchChainedTests(
|
||||
Tcl_Interp *interp, /* Context for compiling script bodies. */
|
||||
CompileEnv *envPtr, /* Holds resulting instructions. */
|
||||
ExtCmdLoc *mapPtr, /* For mapping tokens to their source code
|
||||
* location. */
|
||||
int eclIndex,
|
||||
int mode, /* Exact, Glob or Regexp */
|
||||
int noCase, /* Case-insensitivity flag. */
|
||||
int valueIndex, /* The value to match against. */
|
||||
@@ -1397,10 +1304,7 @@ IssueSwitchChainedTests(
|
||||
int numBodyTokens, /* Number of tokens describing things the
|
||||
* switch can match against and bodies to
|
||||
* execute when the match succeeds. */
|
||||
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
|
||||
int *bodyLines, /* Array of line numbers for body list
|
||||
* items. */
|
||||
int **bodyContLines) /* Array of continuation line info. */
|
||||
Tcl_Token **bodyToken) /* Array of pointers to pattern list items. */
|
||||
{
|
||||
enum {Switch_Exact, Switch_Glob, Switch_Regexp};
|
||||
int savedStackDepth = envPtr->currStackDepth;
|
||||
@@ -1422,7 +1326,6 @@ IssueSwitchChainedTests(
|
||||
* First, we push the value we're matching against on the stack.
|
||||
*/
|
||||
|
||||
SetLineInformation(valueIndex);
|
||||
CompileTokens(envPtr, valueTokenPtr, interp);
|
||||
|
||||
/*
|
||||
@@ -1576,8 +1479,6 @@ IssueSwitchChainedTests(
|
||||
|
||||
OP( POP);
|
||||
envPtr->currStackDepth = savedStackDepth + 1;
|
||||
envPtr->line = bodyLines[i+1]; /* TIP #280 */
|
||||
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
|
||||
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
|
||||
|
||||
if (!foundDefault) {
|
||||
@@ -1654,18 +1555,12 @@ static void
|
||||
IssueSwitchJumpTable(
|
||||
Tcl_Interp *interp, /* Context for compiling script bodies. */
|
||||
CompileEnv *envPtr, /* Holds resulting instructions. */
|
||||
ExtCmdLoc *mapPtr, /* For mapping tokens to their source code
|
||||
* location. */
|
||||
int eclIndex,
|
||||
int valueIndex, /* The value to match against. */
|
||||
Tcl_Token *valueTokenPtr,
|
||||
int numBodyTokens, /* Number of tokens describing things the
|
||||
* switch can match against and bodies to
|
||||
* execute when the match succeeds. */
|
||||
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
|
||||
int *bodyLines, /* Array of line numbers for body list
|
||||
* items. */
|
||||
int **bodyContLines) /* Array of continuation line info. */
|
||||
Tcl_Token **bodyToken) /* Array of pointers to pattern list items. */
|
||||
{
|
||||
JumptableInfo *jtPtr;
|
||||
int savedStackDepth = envPtr->currStackDepth;
|
||||
@@ -1678,7 +1573,6 @@ IssueSwitchJumpTable(
|
||||
* First, we push the value we're matching against on the stack.
|
||||
*/
|
||||
|
||||
SetLineInformation(valueIndex);
|
||||
CompileTokens(envPtr, valueTokenPtr, interp);
|
||||
|
||||
/*
|
||||
@@ -1782,8 +1676,6 @@ IssueSwitchJumpTable(
|
||||
*/
|
||||
|
||||
envPtr->currStackDepth = savedStackDepth;
|
||||
envPtr->line = bodyLines[i+1]; /* TIP #280 */
|
||||
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
|
||||
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
|
||||
|
||||
/*
|
||||
@@ -1944,7 +1836,6 @@ TclCompileTailcallCmd(
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
|
||||
int i;
|
||||
|
||||
@@ -1990,7 +1881,6 @@ TclCompileThrowCmd(
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
int numWords = parsePtr->numWords;
|
||||
int savedStackDepth = envPtr->currStackDepth;
|
||||
Tcl_Token *codeToken, *msgToken;
|
||||
@@ -2123,8 +2013,6 @@ TclCompileTryCmd(
|
||||
* No handlers or finally; do nothing beyond evaluating the body.
|
||||
*/
|
||||
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
SetLineInformation(1);
|
||||
CompileBody(envPtr, bodyToken, interp);
|
||||
return TCL_OK;
|
||||
}
|
||||
@@ -2339,7 +2227,6 @@ IssueTryInstructions(
|
||||
int *optionVars,
|
||||
Tcl_Token **handlerTokens)
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
int range, resultVar, optionsVar;
|
||||
int savedStackDepth = envPtr->currStackDepth;
|
||||
int i, j, len, forwardsNeedFixing = 0;
|
||||
@@ -2493,7 +2380,6 @@ IssueTryFinallyInstructions(
|
||||
Tcl_Token **handlerTokens,
|
||||
Tcl_Token *finallyToken) /* Not NULL */
|
||||
{
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
int savedStackDepth = envPtr->currStackDepth;
|
||||
int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0;
|
||||
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
|
||||
@@ -2733,7 +2619,6 @@ TclCompileUnsetCmd(
|
||||
Tcl_Token *varTokenPtr;
|
||||
int isScalar, simpleVarName, localIndex, numWords, flags, i;
|
||||
Tcl_Obj *leadingWord;
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
|
||||
numWords = parsePtr->numWords-1;
|
||||
flags = 1;
|
||||
@@ -2771,8 +2656,8 @@ TclCompileUnsetCmd(
|
||||
* namespace qualifiers.
|
||||
*/
|
||||
|
||||
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
|
||||
&localIndex, &simpleVarName, &isScalar, 1);
|
||||
PushVarName(interp, varTokenPtr, envPtr, 0,
|
||||
&localIndex, &simpleVarName, &isScalar);
|
||||
|
||||
/*
|
||||
* Emit instructions to unset the variable.
|
||||
@@ -2834,7 +2719,6 @@ TclCompileWhileCmd(
|
||||
int loopMayEnd = 1; /* This is set to 0 if it is recognized as an
|
||||
* infinite loop. */
|
||||
Tcl_Obj *boolObj;
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
|
||||
if (parsePtr->numWords != 3) {
|
||||
return TCL_ERROR;
|
||||
@@ -2922,7 +2806,6 @@ TclCompileWhileCmd(
|
||||
* Compile the loop body.
|
||||
*/
|
||||
|
||||
SetLineInformation(2);
|
||||
bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
|
||||
CompileBody(envPtr, bodyTokenPtr, interp);
|
||||
ExceptionRangeEnds(envPtr, range);
|
||||
@@ -2942,7 +2825,6 @@ TclCompileWhileCmd(
|
||||
testCodeOffset += 3;
|
||||
}
|
||||
envPtr->currStackDepth = savedStackDepth;
|
||||
SetLineInformation(1);
|
||||
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
|
||||
envPtr->currStackDepth = savedStackDepth + 1;
|
||||
|
||||
@@ -3013,7 +2895,6 @@ TclCompileYieldCmd(
|
||||
if (parsePtr->numWords == 1) {
|
||||
PushLiteral(envPtr, "", 0);
|
||||
} else {
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||||
|
||||
CompileWord(envPtr, valueTokenPtr, interp, 1);
|
||||
@@ -3049,10 +2930,7 @@ PushVarName(
|
||||
int flags, /* TCL_NO_LARGE_INDEX. */
|
||||
int *localIndexPtr, /* Must not be NULL. */
|
||||
int *simpleVarNamePtr, /* Must not be NULL. */
|
||||
int *isScalarPtr, /* Must not be NULL. */
|
||||
int line, /* Line the token starts on. */
|
||||
int *clNext) /* Reference to offset of next hidden cont.
|
||||
* line. */
|
||||
int *isScalarPtr) /* Must not be NULL. */
|
||||
{
|
||||
register const char *p;
|
||||
const char *name, *elName;
|
||||
@@ -3232,8 +3110,6 @@ PushVarName(
|
||||
|
||||
if (elName != NULL) {
|
||||
if (elNameChars) {
|
||||
envPtr->line = line;
|
||||
envPtr->clNext = clNext;
|
||||
TclCompileTokens(interp, elemTokenPtr, elemTokenCount,
|
||||
envPtr);
|
||||
} else {
|
||||
@@ -3245,8 +3121,6 @@ PushVarName(
|
||||
* The var name isn't simple: compile and push it.
|
||||
*/
|
||||
|
||||
envPtr->line = line;
|
||||
envPtr->clNext = clNext;
|
||||
CompileTokens(envPtr, varTokenPtr, interp);
|
||||
}
|
||||
|
||||
@@ -3288,7 +3162,6 @@ CompileUnaryOpCmd(
|
||||
CompileEnv *envPtr)
|
||||
{
|
||||
Tcl_Token *tokenPtr;
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
|
||||
if (parsePtr->numWords != 2) {
|
||||
return TCL_ERROR;
|
||||
@@ -3330,7 +3203,6 @@ CompileAssociativeBinaryOpCmd(
|
||||
CompileEnv *envPtr)
|
||||
{
|
||||
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
int words;
|
||||
|
||||
for (words=1 ; words<parsePtr->numWords ; words++) {
|
||||
@@ -3414,7 +3286,6 @@ CompileComparisonOpCmd(
|
||||
CompileEnv *envPtr)
|
||||
{
|
||||
Tcl_Token *tokenPtr;
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
|
||||
if (parsePtr->numWords < 3) {
|
||||
PushLiteral(envPtr, "1", 1);
|
||||
@@ -3580,7 +3451,6 @@ TclCompilePowOpCmd(
|
||||
*/
|
||||
|
||||
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
int words;
|
||||
|
||||
for (words=1 ; words<parsePtr->numWords ; words++) {
|
||||
@@ -3750,7 +3620,6 @@ TclCompileMinusOpCmd(
|
||||
CompileEnv *envPtr)
|
||||
{
|
||||
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
int words;
|
||||
|
||||
if (parsePtr->numWords == 1) {
|
||||
@@ -3795,7 +3664,6 @@ TclCompileDivOpCmd(
|
||||
CompileEnv *envPtr)
|
||||
{
|
||||
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
|
||||
DefineLineInformation; /* TIP #280 */
|
||||
int words;
|
||||
|
||||
if (parsePtr->numWords == 1) {
|
||||
|
||||
@@ -0,0 +1,802 @@
|
||||
#include "tclEngineInt.h"
|
||||
|
||||
/*
|
||||
* How to compile a subcommand using its own command compiler. To do that, we
|
||||
* have to perform some trickery to rewrite the arguments, as compilers *must*
|
||||
* have parse tokens that refer to addresses in the original script.
|
||||
*/
|
||||
|
||||
int
|
||||
TclCompileToCompiledCommand(
|
||||
Tcl_Interp *interp,
|
||||
Tcl_Parse *parsePtr,
|
||||
int depth,
|
||||
Command *cmdPtr,
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
Tcl_Parse synthetic;
|
||||
Tcl_Token *tokenPtr;
|
||||
int result, i;
|
||||
int savedNumCmds = envPtr->numCommands;
|
||||
int savedStackDepth = envPtr->currStackDepth;
|
||||
unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
|
||||
|
||||
if (cmdPtr->compileProc == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
TclParseInit(interp, NULL, 0, &synthetic);
|
||||
synthetic.numWords = parsePtr->numWords - depth + 1;
|
||||
TclGrowParseTokenArray(&synthetic, 2);
|
||||
synthetic.numTokens = 2;
|
||||
|
||||
/*
|
||||
* Now we have the space to work in, install something rewritten. The
|
||||
* first word will "officially" be the bytes of the structured ensemble
|
||||
* name. That's technically wrong, but nobody will care; we just need
|
||||
* *something* here...
|
||||
*/
|
||||
|
||||
synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD;
|
||||
synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start;
|
||||
synthetic.tokenPtr[0].numComponents = 1;
|
||||
synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT;
|
||||
synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start;
|
||||
synthetic.tokenPtr[1].numComponents = 0;
|
||||
for (i=0,tokenPtr=parsePtr->tokenPtr ; i<depth ; i++) {
|
||||
int sclen = (tokenPtr->start - synthetic.tokenPtr[0].start)
|
||||
+ tokenPtr->size;
|
||||
|
||||
synthetic.tokenPtr[0].size = sclen;
|
||||
synthetic.tokenPtr[1].size = sclen;
|
||||
tokenPtr = TokenAfter(tokenPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* Copy over the real argument tokens.
|
||||
*/
|
||||
|
||||
for (i=1; i<synthetic.numWords; i++) {
|
||||
int toCopy;
|
||||
|
||||
toCopy = tokenPtr->numComponents + 1;
|
||||
TclGrowParseTokenArray(&synthetic, toCopy);
|
||||
memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr,
|
||||
sizeof(Tcl_Token) * toCopy);
|
||||
synthetic.numTokens += toCopy;
|
||||
tokenPtr = TokenAfter(tokenPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* Hand off compilation to the subcommand compiler. At last!
|
||||
*/
|
||||
|
||||
result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
|
||||
|
||||
/*
|
||||
* If our target fails to compile, revert the number of commands and the
|
||||
* pointer to the place to issue the next instruction. [Bug 3600328]
|
||||
*/
|
||||
|
||||
if (result != TCL_OK) {
|
||||
envPtr->numCommands = savedNumCmds;
|
||||
envPtr->currStackDepth = savedStackDepth;
|
||||
envPtr->codeNext = envPtr->codeStart + savedCodeNext;
|
||||
}
|
||||
|
||||
/*
|
||||
* Clean up if necessary.
|
||||
*/
|
||||
|
||||
Tcl_FreeParse(&synthetic);
|
||||
return result;
|
||||
}
|
||||
|
||||
/*
|
||||
* How to compile a subcommand to a _replacing_ invoke of its implementation
|
||||
* command.
|
||||
*/
|
||||
|
||||
void
|
||||
TclCompileToInvokedCommand(
|
||||
Tcl_Interp *interp,
|
||||
Tcl_Parse *parsePtr,
|
||||
Tcl_Obj *replacements,
|
||||
Command *cmdPtr,
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
Tcl_Token *tokPtr;
|
||||
Tcl_Obj *objPtr, **words;
|
||||
char *bytes;
|
||||
int length, i, numWords, cmdLit;
|
||||
|
||||
/*
|
||||
* Push the words of the command. Take care; the command words may be
|
||||
* scripts that have backslashes in them, and [info frame 0] can see the
|
||||
* difference. Hence the call to TclContinuationsEnterDerived...
|
||||
*/
|
||||
|
||||
Tcl_ListObjGetElements(NULL, replacements, &numWords, &words);
|
||||
for (i=0,tokPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
|
||||
if (i > 0 && i < numWords+1) {
|
||||
bytes = Tcl_GetStringFromObj(words[i-1], &length);
|
||||
PushLiteral(envPtr, bytes, length);
|
||||
} else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||||
int literal = TclRegisterNewLiteral(envPtr,
|
||||
tokPtr[1].start, tokPtr[1].size);
|
||||
|
||||
TclEmitPush(literal, envPtr);
|
||||
} else {
|
||||
CompileTokens(envPtr, tokPtr, interp);
|
||||
}
|
||||
tokPtr = TokenAfter(tokPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* Push the name of the command we're actually dispatching to as part of
|
||||
* the implementation.
|
||||
*/
|
||||
|
||||
objPtr = Tcl_NewObj();
|
||||
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
|
||||
bytes = Tcl_GetStringFromObj(objPtr, &length);
|
||||
cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
|
||||
TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr, cmdPtr);
|
||||
TclEmitPush(cmdLit, envPtr);
|
||||
TclDecrRefCount(objPtr);
|
||||
|
||||
/*
|
||||
* Do the replacing dispatch.
|
||||
*/
|
||||
|
||||
TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr);
|
||||
TclEmitInt1(numWords+1, envPtr);
|
||||
TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */
|
||||
}
|
||||
|
||||
/*
|
||||
* Helpers that do issuing of instructions for commands that "don't have
|
||||
* compilers" (well, they do; these). They all work by just generating base
|
||||
* code to invoke the command; they're intended for ensemble subcommands so
|
||||
* that the costs of INST_INVOKE_REPLACE can be avoided where we can work out
|
||||
* that they're not needed.
|
||||
*
|
||||
* Note that these are NOT suitable for commands where there's an argument
|
||||
* that is a script, as an [info level] or [info frame] in the inner context
|
||||
* can see the difference.
|
||||
*/
|
||||
|
||||
int
|
||||
TclCompileBasicNArgCommand(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
Tcl_Token *tokenPtr;
|
||||
Tcl_Obj *objPtr;
|
||||
char *bytes;
|
||||
int length, i, literal;
|
||||
|
||||
/*
|
||||
* Push the name of the command we're actually dispatching to as part of
|
||||
* the implementation.
|
||||
*/
|
||||
|
||||
objPtr = Tcl_NewObj();
|
||||
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
|
||||
bytes = Tcl_GetStringFromObj(objPtr, &length);
|
||||
literal = TclRegisterNewCmdLiteral(envPtr, bytes, length);
|
||||
TclSetCmdNameObj(interp, envPtr->literalArrayPtr[literal].objPtr, cmdPtr);
|
||||
TclEmitPush(literal, envPtr);
|
||||
TclDecrRefCount(objPtr);
|
||||
|
||||
/*
|
||||
* Push the words of the command.
|
||||
*/
|
||||
|
||||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||||
for (i=1 ; i<parsePtr->numWords ; i++) {
|
||||
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||||
PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size);
|
||||
} else {
|
||||
CompileTokens(envPtr, tokenPtr, interp);
|
||||
}
|
||||
tokenPtr = TokenAfter(tokenPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* Do the standard dispatch.
|
||||
*/
|
||||
|
||||
if (i <= 255) {
|
||||
TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr);
|
||||
} else {
|
||||
TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr);
|
||||
}
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic0ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 1) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic1ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 2) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic2ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 3) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic3ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 4) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic0Or1ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 1 && parsePtr->numWords != 2) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic1Or2ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic2Or3ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic0To2ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords < 1 || parsePtr->numWords > 3) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic1To3ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasicMin0ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords < 1) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasicMin1ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords < 2) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasicMin2ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords < 3) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclCompileEnsemble --
|
||||
*
|
||||
* Procedure called to compile an ensemble command. Note that most
|
||||
* ensembles are not compiled, since modifying a compiled ensemble causes
|
||||
* a invalidation of all existing bytecode (expensive!) which is not
|
||||
* normally warranted.
|
||||
*
|
||||
* Results:
|
||||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||||
* evaluation to runtime.
|
||||
*
|
||||
* Side effects:
|
||||
* Instructions are added to envPtr to execute the subcommands of the
|
||||
* ensemble at runtime if a compile-time mapping is possible.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
int
|
||||
TclCompileEnsemble(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||||
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
|
||||
Tcl_Obj *replaced = Tcl_NewObj(), *replacement;
|
||||
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
|
||||
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
|
||||
int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
|
||||
int ourResult = TCL_ERROR;
|
||||
unsigned numBytes;
|
||||
const char *word;
|
||||
|
||||
Tcl_IncrRefCount(replaced);
|
||||
|
||||
/*
|
||||
* This is where we return to if we are parsing multiple nested compiled
|
||||
* ensembles. [info object] is such a beast.
|
||||
*/
|
||||
|
||||
checkNextWord:
|
||||
if (parsePtr->numWords < depth + 1) {
|
||||
goto failed;
|
||||
}
|
||||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||||
/*
|
||||
* Too hard.
|
||||
*/
|
||||
|
||||
goto failed;
|
||||
}
|
||||
|
||||
word = tokenPtr[1].start;
|
||||
numBytes = tokenPtr[1].size;
|
||||
|
||||
/*
|
||||
* There's a sporting chance we'll be able to compile this. But now we
|
||||
* must check properly. To do that, check that we're compiling an ensemble
|
||||
* that has a compilable command as its appropriate subcommand.
|
||||
*/
|
||||
|
||||
if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
|
||||
|| mapObj == NULL) {
|
||||
/*
|
||||
* Either not an ensemble or a mapping isn't installed. Crud. Too hard
|
||||
* to proceed.
|
||||
*/
|
||||
|
||||
goto failed;
|
||||
}
|
||||
|
||||
/*
|
||||
* Also refuse to compile anything that uses a formal parameter list for
|
||||
* now, on the grounds that it is too complex.
|
||||
*/
|
||||
|
||||
if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK
|
||||
|| listObj != NULL) {
|
||||
/*
|
||||
* Figuring out how to compile this has become too much. Bail out.
|
||||
*/
|
||||
|
||||
goto failed;
|
||||
}
|
||||
|
||||
/*
|
||||
* Next, get the flags. We need them on several code paths so that we can
|
||||
* know whether we're to do prefix matching.
|
||||
*/
|
||||
|
||||
(void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags);
|
||||
|
||||
/*
|
||||
* Check to see if there's also a subcommand list; must check to see if
|
||||
* the subcommand we are calling is in that list if it exists, since that
|
||||
* list filters the entries in the map.
|
||||
*/
|
||||
|
||||
(void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
|
||||
if (listObj != NULL) {
|
||||
int sclen;
|
||||
const char *str;
|
||||
Tcl_Obj *matchObj = NULL;
|
||||
|
||||
if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
|
||||
goto failed;
|
||||
}
|
||||
for (i=0 ; i<len ; i++) {
|
||||
str = Tcl_GetStringFromObj(elems[i], &sclen);
|
||||
if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) {
|
||||
/*
|
||||
* Exact match! Excellent!
|
||||
*/
|
||||
|
||||
result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
|
||||
if (result != TCL_OK || targetCmdObj == NULL) {
|
||||
goto failed;
|
||||
}
|
||||
replacement = elems[i];
|
||||
goto doneMapLookup;
|
||||
}
|
||||
|
||||
/*
|
||||
* Check to see if we've got a prefix match. A single prefix match
|
||||
* is fine, and allows us to refine our dictionary lookup, but
|
||||
* multiple prefix matches is a Bad Thing and will prevent us from
|
||||
* making progress. Note that we cannot do the lookup immediately
|
||||
* in the prefix case; might be another entry later in the list
|
||||
* that causes things to fail.
|
||||
*/
|
||||
|
||||
if ((flags & TCL_ENSEMBLE_PREFIX)
|
||||
&& strncmp(word, str, numBytes) == 0) {
|
||||
if (matchObj != NULL) {
|
||||
goto failed;
|
||||
}
|
||||
matchObj = elems[i];
|
||||
}
|
||||
}
|
||||
if (matchObj == NULL) {
|
||||
goto failed;
|
||||
}
|
||||
result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
|
||||
if (result != TCL_OK || targetCmdObj == NULL) {
|
||||
goto failed;
|
||||
}
|
||||
replacement = matchObj;
|
||||
} else {
|
||||
Tcl_DictSearch s;
|
||||
int done, matched;
|
||||
Tcl_Obj *tmpObj;
|
||||
|
||||
/*
|
||||
* No map, so check the dictionary directly.
|
||||
*/
|
||||
|
||||
TclNewStringObj(subcmdObj, word, (int) numBytes);
|
||||
result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
|
||||
if (result == TCL_OK && targetCmdObj != NULL) {
|
||||
/*
|
||||
* Got it. Skip the fiddling around with prefixes.
|
||||
*/
|
||||
|
||||
replacement = subcmdObj;
|
||||
goto doneMapLookup;
|
||||
}
|
||||
TclDecrRefCount(subcmdObj);
|
||||
|
||||
/*
|
||||
* We've not literally got a valid subcommand. But maybe we have a
|
||||
* prefix. Check if prefix matches are allowed.
|
||||
*/
|
||||
|
||||
if (!(flags & TCL_ENSEMBLE_PREFIX)) {
|
||||
goto failed;
|
||||
}
|
||||
|
||||
/*
|
||||
* Iterate over the keys in the dictionary, checking to see if we're a
|
||||
* prefix.
|
||||
*/
|
||||
|
||||
Tcl_DictObjFirst(NULL, mapObj, &s, &subcmdObj, &tmpObj, &done);
|
||||
matched = 0;
|
||||
replacement = NULL; /* Silence, fool compiler! */
|
||||
while (!done) {
|
||||
if (strncmp(TclGetString(subcmdObj), word, numBytes) == 0) {
|
||||
if (matched++) {
|
||||
/*
|
||||
* Must have matched twice! Not unique, so no point
|
||||
* looking further.
|
||||
*/
|
||||
|
||||
break;
|
||||
}
|
||||
replacement = subcmdObj;
|
||||
targetCmdObj = tmpObj;
|
||||
}
|
||||
Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
|
||||
}
|
||||
Tcl_DictObjDone(&s);
|
||||
|
||||
/*
|
||||
* If we have anything other than a single match, we've failed the
|
||||
* unique prefix check.
|
||||
*/
|
||||
|
||||
if (matched != 1) {
|
||||
invokeAnyway = 1;
|
||||
goto failed;
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* OK, we definitely map to something. But what?
|
||||
*
|
||||
* The command we map to is the first word out of the map element. Note
|
||||
* that we also reject dealing with multi-element rewrites if we are in a
|
||||
* safe interpreter, as there is otherwise a (highly gnarly!) way to make
|
||||
* Tcl crash open to exploit.
|
||||
*/
|
||||
|
||||
doneMapLookup:
|
||||
Tcl_ListObjAppendElement(NULL, replaced, replacement);
|
||||
if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
|
||||
goto failed;
|
||||
} else if (len != 1) {
|
||||
/*
|
||||
* Note that at this point we know we can't issue any special
|
||||
* instruction sequence as the mapping isn't one that we support at
|
||||
* the compiled level.
|
||||
*/
|
||||
|
||||
goto cleanup;
|
||||
}
|
||||
targetCmdObj = elems[0];
|
||||
|
||||
oldCmdPtr = cmdPtr;
|
||||
Tcl_IncrRefCount(targetCmdObj);
|
||||
newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
|
||||
TclDecrRefCount(targetCmdObj);
|
||||
if (newCmdPtr == NULL || Tcl_IsSafe(interp)
|
||||
|| newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
|
||||
|| newCmdPtr->flags & CMD_HAS_EXEC_TRACES
|
||||
|| ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
|
||||
/*
|
||||
* Maps to an undefined command or a command without a compiler.
|
||||
* Cannot compile.
|
||||
*/
|
||||
|
||||
goto cleanup;
|
||||
}
|
||||
cmdPtr = newCmdPtr;
|
||||
depth++;
|
||||
|
||||
/*
|
||||
* See whether we have a nested ensemble. If we do, we can go round the
|
||||
* mulberry bush again, consuming the next word.
|
||||
*/
|
||||
|
||||
if (cmdPtr->compileProc == TclCompileEnsemble) {
|
||||
tokenPtr = TokenAfter(tokenPtr);
|
||||
ensemble = (Tcl_Command) cmdPtr;
|
||||
goto checkNextWord;
|
||||
}
|
||||
|
||||
/*
|
||||
* Now we've done the mapping process, can now actually try to compile.
|
||||
* If there is a subcommand compiler and that successfully produces code,
|
||||
* we'll use that. Otherwise, we fall back to generating opcodes to do the
|
||||
* invoke at runtime.
|
||||
*/
|
||||
|
||||
invokeAnyway = 1;
|
||||
if (TclCompileToCompiledCommand(interp, parsePtr, depth, cmdPtr,
|
||||
envPtr) == TCL_OK) {
|
||||
ourResult = TCL_OK;
|
||||
goto cleanup;
|
||||
}
|
||||
|
||||
/*
|
||||
* Failed to do a full compile for some reason. Try to do a direct invoke
|
||||
* instead of going through the ensemble lookup process again.
|
||||
*/
|
||||
|
||||
failed:
|
||||
if (depth < 250) {
|
||||
if (depth > 1) {
|
||||
if (!invokeAnyway) {
|
||||
cmdPtr = oldCmdPtr;
|
||||
depth--;
|
||||
}
|
||||
(void) Tcl_ListObjReplace(NULL, replaced, depth, 2, 0, NULL);
|
||||
}
|
||||
TclCompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr);
|
||||
ourResult = TCL_OK;
|
||||
}
|
||||
|
||||
/*
|
||||
* Release the memory we allocated. If we've got here, we've either done
|
||||
* something useful or we're in a case that we can't compile at all and
|
||||
* we're just giving up.
|
||||
*/
|
||||
|
||||
cleanup:
|
||||
Tcl_DecrRefCount(replaced);
|
||||
return ourResult;
|
||||
}
|
||||
|
||||
@@ -11,8 +11,7 @@
|
||||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
#include "tclCompile.h" /* CompileEnv */
|
||||
#include "tclEngineInt.h" /* CompileEnv */
|
||||
|
||||
/*
|
||||
* Expression parsing takes place in the routine ParseExpr(). It takes a
|
||||
@@ -2142,10 +2141,6 @@ TclCompileExpr(
|
||||
Tcl_Obj *const *litObjv;
|
||||
Tcl_Obj **funcObjv;
|
||||
|
||||
/* TIP #280 : Track Lines within the expression */
|
||||
TclAdvanceLines(&envPtr->line, script,
|
||||
script + TclParseAllWhiteSpace(script, numBytes));
|
||||
|
||||
TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv);
|
||||
TclListObjGetElements(NULL, funcList, &objc, &funcObjv);
|
||||
CompileExprTree(interp, opTree, 0, &litObjv, funcObjv,
|
||||
@@ -2190,7 +2185,6 @@ ExecConstantExprTree(
|
||||
ByteCode *byteCodePtr;
|
||||
int code;
|
||||
Tcl_Obj *byteCodeObj = Tcl_NewObj();
|
||||
NRE_callback *rootPtr = TOP_CB(interp);
|
||||
|
||||
/*
|
||||
* Note we are compiling an expression with literal arguments. This means
|
||||
@@ -2198,8 +2192,9 @@ ExecConstantExprTree(
|
||||
* bytecode, so there's no need to tend to TIP 280 issues.
|
||||
*/
|
||||
|
||||
TclNRSetRoot(interp);
|
||||
envPtr = TclStackAlloc(interp, sizeof(CompileEnv));
|
||||
TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0);
|
||||
TclInitCompileEnv(interp, envPtr, NULL, 0);
|
||||
CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr,
|
||||
0 /* optimize */);
|
||||
TclEmitOpcode(INST_DONE, envPtr);
|
||||
@@ -2209,7 +2204,7 @@ ExecConstantExprTree(
|
||||
TclStackFree(interp, envPtr);
|
||||
byteCodePtr = byteCodeObj->internalRep.otherValuePtr;
|
||||
TclNRExecuteByteCode(interp, byteCodePtr);
|
||||
code = TclNRRunCallbacks(interp, TCL_OK, rootPtr);
|
||||
code = TclNRRunCallbacks(interp, TCL_OK);
|
||||
Tcl_DecrRefCount(byteCodeObj);
|
||||
return code;
|
||||
}
|
||||
|
||||
+22
-714
@@ -12,8 +12,7 @@
|
||||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
#include "tclCompile.h"
|
||||
#include "tclEngineInt.h"
|
||||
|
||||
/*
|
||||
* Table of all AuxData types.
|
||||
@@ -563,16 +562,6 @@ static int FormatInstruction(ByteCode *codePtr,
|
||||
const unsigned char *pc, Tcl_Obj *bufferObj);
|
||||
static void PrintSourceToObj(Tcl_Obj *appendObj,
|
||||
const char *stringPtr, int maxChars);
|
||||
static void UpdateStringOfInstName(Tcl_Obj *objPtr);
|
||||
|
||||
/*
|
||||
* TIP #280: Helper for building the per-word line information of all compiled
|
||||
* commands.
|
||||
*/
|
||||
static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset,
|
||||
Tcl_Token *tokenPtr, const char *cmd, int len,
|
||||
int numWords, int line, int *clNext, int **lines,
|
||||
CompileEnv *envPtr);
|
||||
|
||||
/*
|
||||
* The structure below defines the bytecode Tcl object type by means of
|
||||
@@ -600,18 +589,17 @@ static const Tcl_ObjType substCodeType = {
|
||||
NULL, /* setFromAnyProc */
|
||||
};
|
||||
|
||||
/*
|
||||
* The structure below defines an instruction name Tcl object to allow
|
||||
* reporting of inner contexts in errorstack without string allocation.
|
||||
*/
|
||||
|
||||
static const Tcl_ObjType tclInstNameType = {
|
||||
"instname", /* name */
|
||||
NULL, /* freeIntRepProc */
|
||||
NULL, /* dupIntRepProc */
|
||||
UpdateStringOfInstName, /* updateStringProc */
|
||||
NULL, /* setFromAnyProc */
|
||||
};
|
||||
void TclForceBodyNS(
|
||||
Tcl_Obj *bodyPtr,
|
||||
Namespace *nsPtr)
|
||||
{
|
||||
if (bodyPtr->typePtr == &tclByteCodeType) {
|
||||
((ByteCode *)bodyPtr->internalRep.otherValuePtr)->nsPtr = nsPtr;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
@@ -647,7 +635,6 @@ TclSetByteCodeFromAny(
|
||||
CompileHookProc *hookProc, /* Procedure to invoke after compilation. */
|
||||
ClientData clientData) /* Hook procedure private data. */
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
CompileEnv compEnv; /* Compilation environment structure allocated
|
||||
* in frame. */
|
||||
register const AuxData *auxDataPtr;
|
||||
@@ -655,7 +642,6 @@ TclSetByteCodeFromAny(
|
||||
register int i;
|
||||
int length, result = TCL_OK;
|
||||
const char *stringPtr;
|
||||
ContLineLoc *clLocPtr;
|
||||
|
||||
#ifdef TCL_COMPILE_DEBUG
|
||||
if (!traceInitialized) {
|
||||
@@ -669,14 +655,7 @@ TclSetByteCodeFromAny(
|
||||
|
||||
stringPtr = TclGetStringFromObj(objPtr, &length);
|
||||
|
||||
/*
|
||||
* TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
|
||||
* use to initialize the tracking in the compiler. This information was
|
||||
* stored by TclCompEvalObj and ProcCompileProc.
|
||||
*/
|
||||
|
||||
TclInitCompileEnv(interp, &compEnv, stringPtr, length,
|
||||
iPtr->invokeCmdFramePtr, iPtr->invokeWord);
|
||||
TclInitCompileEnv(interp, &compEnv, stringPtr, length);
|
||||
|
||||
/*
|
||||
* Now we check if we have data about invisible continuation lines for the
|
||||
@@ -690,13 +669,6 @@ TclSetByteCodeFromAny(
|
||||
* "tclObj.c".
|
||||
*/
|
||||
|
||||
clLocPtr = TclContinuationsGet(objPtr);
|
||||
if (clLocPtr) {
|
||||
compEnv.clLoc = clLocPtr;
|
||||
compEnv.clNext = &compEnv.clLoc->loc[0];
|
||||
Tcl_Preserve(compEnv.clLoc);
|
||||
}
|
||||
|
||||
TclCompileScript(interp, stringPtr, length, &compEnv);
|
||||
|
||||
/*
|
||||
@@ -741,7 +713,7 @@ TclSetByteCodeFromAny(
|
||||
entryPtr++;
|
||||
}
|
||||
#ifdef TCL_COMPILE_DEBUG
|
||||
TclVerifyGlobalLiteralTable(iPtr);
|
||||
TclVerifyGlobalLiteralTable((Interp *)interp);
|
||||
#endif /*TCL_COMPILE_DEBUG*/
|
||||
|
||||
auxDataPtr = compEnv.auxDataArrayPtr;
|
||||
@@ -879,7 +851,6 @@ TclCleanupByteCode(
|
||||
register ByteCode *codePtr) /* Points to the ByteCode to free. */
|
||||
{
|
||||
Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
int numLitObjects = codePtr->numLitObjects;
|
||||
int numAuxDataItems = codePtr->numAuxDataItems;
|
||||
register Tcl_Obj **objArrayPtr, *objPtr;
|
||||
@@ -892,7 +863,7 @@ TclCleanupByteCode(
|
||||
Tcl_Time destroyTime;
|
||||
int lifetimeSec, lifetimeMicroSec, log2;
|
||||
|
||||
statsPtr = &iPtr->stats;
|
||||
statsPtr = &((Interp *)interp)->stats;
|
||||
|
||||
statsPtr->numByteCodesFreed++;
|
||||
statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
|
||||
@@ -979,39 +950,6 @@ TclCleanupByteCode(
|
||||
auxDataPtr++;
|
||||
}
|
||||
|
||||
/*
|
||||
* TIP #280. Release the location data associated with this byte code
|
||||
* structure, if any. NOTE: The interp we belong to may be gone already,
|
||||
* and the data with it.
|
||||
*
|
||||
* See also tclBasic.c, DeleteInterpProc
|
||||
*/
|
||||
|
||||
if (iPtr) {
|
||||
Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
|
||||
(char *) codePtr);
|
||||
|
||||
if (hePtr) {
|
||||
ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
|
||||
|
||||
if (eclPtr->type == TCL_LOCATION_SOURCE) {
|
||||
Tcl_DecrRefCount(eclPtr->path);
|
||||
}
|
||||
for (i=0 ; i<eclPtr->nuloc ; i++) {
|
||||
ckfree(eclPtr->loc[i].line);
|
||||
}
|
||||
|
||||
if (eclPtr->loc != NULL) {
|
||||
ckfree(eclPtr->loc);
|
||||
}
|
||||
|
||||
Tcl_DeleteHashTable(&eclPtr->litInfo);
|
||||
|
||||
ckfree(eclPtr);
|
||||
Tcl_DeleteHashEntry(hePtr);
|
||||
}
|
||||
}
|
||||
|
||||
if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) {
|
||||
TclFreeLocalCache(interp, codePtr->localCachePtr);
|
||||
}
|
||||
@@ -1044,10 +982,9 @@ Tcl_SubstObj(
|
||||
Tcl_Obj *objPtr, /* The value to be substituted. */
|
||||
int flags) /* What substitutions to do. */
|
||||
{
|
||||
NRE_callback *rootPtr = TOP_CB(interp);
|
||||
|
||||
if (TclNRRunCallbacks(interp, Tcl_NRSubstObj(interp, objPtr, flags),
|
||||
rootPtr) != TCL_OK) {
|
||||
TclNRSetRoot(interp);
|
||||
if (TclNRRunCallbacks(interp, Tcl_NRSubstObj(interp, objPtr, flags))
|
||||
!= TCL_OK) {
|
||||
return NULL;
|
||||
}
|
||||
return Tcl_GetObjResult(interp);
|
||||
@@ -1134,10 +1071,9 @@ CompileSubstObj(
|
||||
int numBytes;
|
||||
const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
|
||||
|
||||
/* TODO: Check for more TIP 280 */
|
||||
TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0);
|
||||
TclInitCompileEnv(interp, &compEnv, bytes, numBytes);
|
||||
|
||||
TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv);
|
||||
TclSubstCompile(interp, bytes, numBytes, flags, &compEnv);
|
||||
|
||||
TclEmitOpcode(INST_DONE, &compEnv);
|
||||
TclInitByteCodeObj(objPtr, &compEnv);
|
||||
@@ -1214,10 +1150,7 @@ TclInitCompileEnv(
|
||||
register CompileEnv *envPtr,/* Points to the CompileEnv structure to
|
||||
* initialize. */
|
||||
const char *stringPtr, /* The source string to be compiled. */
|
||||
int numBytes, /* Number of bytes in source string. */
|
||||
const CmdFrame *invoker, /* Location context invoking the bcc */
|
||||
int word) /* Index of the word in that context getting
|
||||
* compiled */
|
||||
int numBytes) /* Number of bytes in source string. */
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
|
||||
@@ -1253,138 +1186,6 @@ TclInitCompileEnv(
|
||||
envPtr->mallocedCmdMap = 0;
|
||||
envPtr->atCmdStart = 1;
|
||||
|
||||
/*
|
||||
* TIP #280: Set up the extended command location information, based on
|
||||
* the context invoking the byte code compiler. This structure is used to
|
||||
* keep the per-word line information for all compiled commands.
|
||||
*
|
||||
* See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
|
||||
* non-compiling evaluator
|
||||
*/
|
||||
|
||||
envPtr->extCmdMapPtr = ckalloc(sizeof(ExtCmdLoc));
|
||||
envPtr->extCmdMapPtr->loc = NULL;
|
||||
envPtr->extCmdMapPtr->nloc = 0;
|
||||
envPtr->extCmdMapPtr->nuloc = 0;
|
||||
envPtr->extCmdMapPtr->path = NULL;
|
||||
Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS);
|
||||
|
||||
if ((invoker == NULL) || (invoker->type == TCL_LOCATION_EVAL_LIST)) {
|
||||
/*
|
||||
* Initialize the compiler for relative counting in case of a
|
||||
* dynamic context.
|
||||
*/
|
||||
|
||||
envPtr->line = 1;
|
||||
if (iPtr->evalFlags & TCL_EVAL_FILE) {
|
||||
iPtr->evalFlags &= ~TCL_EVAL_FILE;
|
||||
envPtr->extCmdMapPtr->type = TCL_LOCATION_SOURCE;
|
||||
|
||||
if (iPtr->scriptFile) {
|
||||
/*
|
||||
* Normalization here, to have the correct pwd. Should have
|
||||
* negligible impact on performance, as the norm should have
|
||||
* been done already by the 'source' invoking us, and it
|
||||
* caches the result.
|
||||
*/
|
||||
|
||||
Tcl_Obj *norm =
|
||||
Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile);
|
||||
|
||||
if (norm == NULL) {
|
||||
/*
|
||||
* Error message in the interp result. No place to put it.
|
||||
* And no place to serve the error itself to either. Fake
|
||||
* a path, empty string.
|
||||
*/
|
||||
|
||||
TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, "");
|
||||
} else {
|
||||
envPtr->extCmdMapPtr->path = norm;
|
||||
}
|
||||
} else {
|
||||
TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, "");
|
||||
}
|
||||
|
||||
Tcl_IncrRefCount(envPtr->extCmdMapPtr->path);
|
||||
} else {
|
||||
envPtr->extCmdMapPtr->type =
|
||||
(envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC);
|
||||
}
|
||||
} else {
|
||||
/*
|
||||
* Initialize the compiler using the context, making counting absolute
|
||||
* to that context. Note that the context can be byte code execution.
|
||||
* In that case we have to fill out the missing pieces (line, path,
|
||||
* ...) which may make change the type as well.
|
||||
*/
|
||||
|
||||
CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
|
||||
int pc = 0;
|
||||
|
||||
*ctxPtr = *invoker;
|
||||
if (invoker->type == TCL_LOCATION_BC) {
|
||||
/*
|
||||
* Note: Type BC => ctx.data.eval.path is not used.
|
||||
* ctx.data.tebc.codePtr is used instead.
|
||||
*/
|
||||
|
||||
TclGetSrcInfoForPc(ctxPtr);
|
||||
pc = 1;
|
||||
}
|
||||
|
||||
if ((ctxPtr->nline <= word) || (ctxPtr->line[word] < 0)) {
|
||||
/*
|
||||
* Word is not a literal, relative counting.
|
||||
*/
|
||||
|
||||
envPtr->line = 1;
|
||||
envPtr->extCmdMapPtr->type =
|
||||
(envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC);
|
||||
|
||||
if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) {
|
||||
/*
|
||||
* The reference made by 'TclGetSrcInfoForPc' is dead.
|
||||
*/
|
||||
|
||||
Tcl_DecrRefCount(ctxPtr->data.eval.path);
|
||||
}
|
||||
} else {
|
||||
envPtr->line = ctxPtr->line[word];
|
||||
envPtr->extCmdMapPtr->type = ctxPtr->type;
|
||||
|
||||
if (ctxPtr->type == TCL_LOCATION_SOURCE) {
|
||||
envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path;
|
||||
|
||||
if (pc) {
|
||||
/*
|
||||
* The reference 'TclGetSrcInfoForPc' made is transfered.
|
||||
*/
|
||||
|
||||
ctxPtr->data.eval.path = NULL;
|
||||
} else {
|
||||
/*
|
||||
* We have a new reference here.
|
||||
*/
|
||||
|
||||
Tcl_IncrRefCount(envPtr->extCmdMapPtr->path);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
TclStackFree(interp, ctxPtr);
|
||||
}
|
||||
|
||||
envPtr->extCmdMapPtr->start = envPtr->line;
|
||||
|
||||
/*
|
||||
* Initialize the data about invisible continuation lines as empty, i.e.
|
||||
* not used. The caller (TclSetByteCodeFromAny) will set this up, if such
|
||||
* data is available.
|
||||
*/
|
||||
|
||||
envPtr->clLoc = NULL;
|
||||
envPtr->clNext = NULL;
|
||||
|
||||
envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
|
||||
envPtr->auxDataArrayNext = 0;
|
||||
@@ -1437,19 +1238,6 @@ TclFreeCompileEnv(
|
||||
if (envPtr->mallocedAuxDataArray) {
|
||||
ckfree(envPtr->auxDataArrayPtr);
|
||||
}
|
||||
if (envPtr->extCmdMapPtr) {
|
||||
ckfree(envPtr->extCmdMapPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* If we used data about invisible continuation lines, then now is the
|
||||
* time to release on our hold on it. The lock was set in function
|
||||
* TclSetByteCodeFromAny(), found in this file.
|
||||
*/
|
||||
|
||||
if (envPtr->clLoc) {
|
||||
Tcl_Release(envPtr->clLoc);
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -1575,9 +1363,6 @@ TclCompileScript(
|
||||
Tcl_Token *tokenPtr;
|
||||
int bytesLeft, isFirstCmd, wordIdx, currCmdIndex, commandLength, objIndex;
|
||||
Tcl_DString ds;
|
||||
/* TIP #280 */
|
||||
ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
|
||||
int *wlines, wlineat, cmdLine, *clNext;
|
||||
Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
|
||||
|
||||
Tcl_DStringInit(&ds);
|
||||
@@ -1601,8 +1386,6 @@ TclCompileScript(
|
||||
|
||||
p = script;
|
||||
bytesLeft = numBytes;
|
||||
cmdLine = envPtr->line;
|
||||
clNext = envPtr->clNext;
|
||||
do {
|
||||
if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) {
|
||||
/*
|
||||
@@ -1618,18 +1401,6 @@ TclCompileScript(
|
||||
break;
|
||||
}
|
||||
|
||||
/*
|
||||
* TIP #280: We have to count newlines before the command even in the
|
||||
* degenerate case when the command has no words. (See test
|
||||
* info-30.33).
|
||||
* So make that counting here, and not in the (numWords > 0) branch
|
||||
* below.
|
||||
*/
|
||||
|
||||
TclAdvanceLines(&cmdLine, p, parsePtr->commandStart);
|
||||
TclAdvanceContinuations(&cmdLine, &clNext,
|
||||
parsePtr->commandStart - envPtr->source);
|
||||
|
||||
if (parsePtr->numWords > 0) {
|
||||
int expand = 0; /* Set if there are dynamic expansions to
|
||||
* handle */
|
||||
@@ -1706,20 +1477,6 @@ TclCompileScript(
|
||||
TclEmitOpcode(INST_EXPAND_START, envPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* TIP #280. Scan the words and compute the extended location
|
||||
* information. The map first contain full per-word line
|
||||
* information for use by the compiler. This is later replaced by
|
||||
* a reduced form which signals non-literal words, stored in
|
||||
* 'wlines'.
|
||||
*/
|
||||
|
||||
EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
|
||||
parsePtr->tokenPtr, parsePtr->commandStart,
|
||||
parsePtr->commandSize, parsePtr->numWords, cmdLine,
|
||||
clNext, &wlines, envPtr);
|
||||
wlineat = eclPtr->nuloc - 1;
|
||||
|
||||
/*
|
||||
* Each iteration of the following loop compiles one word from the
|
||||
* command.
|
||||
@@ -1729,8 +1486,6 @@ TclCompileScript(
|
||||
wordIdx < parsePtr->numWords; wordIdx++,
|
||||
tokenPtr += tokenPtr->numComponents + 1) {
|
||||
|
||||
envPtr->line = eclPtr->loc[wlineat].line[wordIdx];
|
||||
envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx];
|
||||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||||
/*
|
||||
* The word is not a simple string of characters.
|
||||
@@ -1907,13 +1662,6 @@ TclCompileScript(
|
||||
|
||||
objIndex = TclRegisterNewLiteral(envPtr,
|
||||
tokenPtr[1].start, tokenPtr[1].size);
|
||||
|
||||
if (envPtr->clNext) {
|
||||
TclContinuationsEnterDerived(
|
||||
envPtr->literalArrayPtr[objIndex].objPtr,
|
||||
tokenPtr[1].start - envPtr->source,
|
||||
eclPtr->loc[wlineat].next[wordIdx]);
|
||||
}
|
||||
}
|
||||
TclEmitPush(objIndex, envPtr);
|
||||
} /* for loop */
|
||||
@@ -1943,16 +1691,6 @@ TclCompileScript(
|
||||
TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
|
||||
TclAdjustStackDepth((1-wordIdx), envPtr);
|
||||
} else if (wordIdx > 0) {
|
||||
/*
|
||||
* Save PC -> command map for the TclArgumentBC* functions.
|
||||
*/
|
||||
|
||||
int isnew;
|
||||
Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo,
|
||||
INT2PTR(envPtr->codeNext - envPtr->codeStart),
|
||||
&isnew);
|
||||
|
||||
Tcl_SetHashValue(hePtr, INT2PTR(wlineat));
|
||||
if (wordIdx <= 255) {
|
||||
TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
|
||||
} else {
|
||||
@@ -1970,15 +1708,6 @@ TclCompileScript(
|
||||
(envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
|
||||
isFirstCmd = 0;
|
||||
|
||||
/*
|
||||
* TIP #280: Free full form of per-word line data and insert the
|
||||
* reduced form now
|
||||
*/
|
||||
|
||||
ckfree(eclPtr->loc[wlineat].line);
|
||||
ckfree(eclPtr->loc[wlineat].next);
|
||||
eclPtr->loc[wlineat].line = wlines;
|
||||
eclPtr->loc[wlineat].next = NULL;
|
||||
} /* end if parsePtr->numWords > 0 */
|
||||
|
||||
/*
|
||||
@@ -1988,24 +1717,9 @@ TclCompileScript(
|
||||
next = parsePtr->commandStart + parsePtr->commandSize;
|
||||
bytesLeft -= next - p;
|
||||
p = next;
|
||||
|
||||
/*
|
||||
* TIP #280: Track lines in the just compiled command.
|
||||
*/
|
||||
|
||||
TclAdvanceLines(&cmdLine, parsePtr->commandStart, p);
|
||||
TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source);
|
||||
Tcl_FreeParse(parsePtr);
|
||||
} while (bytesLeft > 0);
|
||||
|
||||
/*
|
||||
* TIP #280: Bring the line counts in the CompEnv up to date.
|
||||
* See tests info-30.33,34,35 .
|
||||
*/
|
||||
|
||||
envPtr->line = cmdLine;
|
||||
envPtr->clNext = clNext;
|
||||
|
||||
/*
|
||||
* If the source script yielded no instructions (e.g., if it was empty),
|
||||
* push an empty string as the command's result.
|
||||
@@ -2088,9 +1802,6 @@ TclCompileVarSubst(
|
||||
* Emit instructions to load the variable.
|
||||
*/
|
||||
|
||||
TclAdvanceLines(&envPtr->line, tokenPtr[1].start,
|
||||
tokenPtr[1].start + tokenPtr[1].size);
|
||||
|
||||
if (tokenPtr->numComponents == 1) {
|
||||
if (localVar < 0) {
|
||||
TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
|
||||
@@ -2123,42 +1834,8 @@ TclCompileTokens(
|
||||
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
|
||||
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
|
||||
char buffer[TCL_UTF_MAX];
|
||||
int i, numObjsToConcat, length;
|
||||
int numObjsToConcat, length;
|
||||
unsigned char *entryCodeNext = envPtr->codeNext;
|
||||
#define NUM_STATIC_POS 20
|
||||
int isLiteral, maxNumCL, numCL;
|
||||
int *clPosition = NULL;
|
||||
|
||||
/*
|
||||
* For the handling of continuation lines in literals we first check if
|
||||
* this is actually a literal. For if not we can forego the additional
|
||||
* processing. Otherwise we pre-allocate a small table to store the
|
||||
* locations of all continuation lines we find in this literal, if any.
|
||||
* The table is extended if needed.
|
||||
*
|
||||
* Note: Different to the equivalent code in function 'TclSubstTokens()'
|
||||
* (see file "tclParse.c") we do not seem to need the 'adjust' variable.
|
||||
* We also do not seem to need code which merges continuation line
|
||||
* information of multiple words which concat'd at runtime. Either that or
|
||||
* I have not managed to find a test case for these two possibilities yet.
|
||||
* It might be a difference between compile- versus run-time processing.
|
||||
*/
|
||||
|
||||
numCL = 0;
|
||||
maxNumCL = 0;
|
||||
isLiteral = 1;
|
||||
for (i=0 ; i < count; i++) {
|
||||
if ((tokenPtr[i].type != TCL_TOKEN_TEXT)
|
||||
&& (tokenPtr[i].type != TCL_TOKEN_BS)) {
|
||||
isLiteral = 0;
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
if (isLiteral) {
|
||||
maxNumCL = NUM_STATIC_POS;
|
||||
clPosition = ckalloc(maxNumCL * sizeof(int));
|
||||
}
|
||||
|
||||
Tcl_DStringInit(&textBuffer);
|
||||
numObjsToConcat = 0;
|
||||
@@ -2166,8 +1843,6 @@ TclCompileTokens(
|
||||
switch (tokenPtr->type) {
|
||||
case TCL_TOKEN_TEXT:
|
||||
TclDStringAppendToken(&textBuffer, tokenPtr);
|
||||
TclAdvanceLines(&envPtr->line, tokenPtr->start,
|
||||
tokenPtr->start + tokenPtr->size);
|
||||
break;
|
||||
|
||||
case TCL_TOKEN_BS:
|
||||
@@ -2175,34 +1850,8 @@ TclCompileTokens(
|
||||
NULL, buffer);
|
||||
Tcl_DStringAppend(&textBuffer, buffer, length);
|
||||
|
||||
/*
|
||||
* If the backslash sequence we found is in a literal, and
|
||||
* represented a continuation line, we compute and store its
|
||||
* location (as char offset to the beginning of the _result_
|
||||
* script). We may have to extend the table of locations.
|
||||
*
|
||||
* Note that the continuation line information is relevant even if
|
||||
* the word we are processing is not a literal, as it can affect
|
||||
* nested commands. See the branch for TCL_TOKEN_COMMAND below,
|
||||
* where the adjustment we are tracking here is taken into
|
||||
* account. The good thing is that we do not need a table of
|
||||
* everything, just the number of lines we have to add as
|
||||
* correction.
|
||||
*/
|
||||
|
||||
if ((length == 1) && (buffer[0] == ' ') &&
|
||||
(tokenPtr->start[1] == '\n')) {
|
||||
if (isLiteral) {
|
||||
int clPos = Tcl_DStringLength(&textBuffer);
|
||||
|
||||
if (numCL >= maxNumCL) {
|
||||
maxNumCL *= 2;
|
||||
clPosition = ckrealloc(clPosition,
|
||||
maxNumCL * sizeof(int));
|
||||
}
|
||||
clPosition[numCL] = clPos;
|
||||
numCL ++;
|
||||
}
|
||||
}
|
||||
break;
|
||||
|
||||
@@ -2217,13 +1866,6 @@ TclCompileTokens(
|
||||
TclEmitPush(literal, envPtr);
|
||||
numObjsToConcat++;
|
||||
Tcl_DStringFree(&textBuffer);
|
||||
|
||||
if (numCL) {
|
||||
TclContinuationsEnter(
|
||||
envPtr->literalArrayPtr[literal].objPtr, numCL,
|
||||
clPosition);
|
||||
}
|
||||
numCL = 0;
|
||||
}
|
||||
|
||||
TclCompileScript(interp, tokenPtr->start+1,
|
||||
@@ -2266,11 +1908,6 @@ TclCompileTokens(
|
||||
|
||||
TclEmitPush(literal, envPtr);
|
||||
numObjsToConcat++;
|
||||
if (numCL) {
|
||||
TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
|
||||
numCL, clPosition);
|
||||
}
|
||||
numCL = 0;
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -2293,15 +1930,6 @@ TclCompileTokens(
|
||||
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
|
||||
}
|
||||
Tcl_DStringFree(&textBuffer);
|
||||
|
||||
/*
|
||||
* Release the temp table we used to collect the locations of continuation
|
||||
* lines, if any.
|
||||
*/
|
||||
|
||||
if (maxNumCL) {
|
||||
ckfree(clPosition);
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -2511,7 +2139,7 @@ TclInitByteCodeObj(
|
||||
#endif
|
||||
int numLitObjects = envPtr->literalArrayNext;
|
||||
Namespace *namespacePtr;
|
||||
int i, isNew;
|
||||
int i;
|
||||
Interp *iPtr;
|
||||
|
||||
iPtr = envPtr->iPtr;
|
||||
@@ -2642,15 +2270,6 @@ TclInitByteCodeObj(
|
||||
objPtr->internalRep.otherValuePtr = codePtr;
|
||||
objPtr->typePtr = &tclByteCodeType;
|
||||
|
||||
/*
|
||||
* TIP #280. Associate the extended per-word line information with the
|
||||
* byte code object (internal rep), for use with the bc compiler.
|
||||
*/
|
||||
|
||||
Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, codePtr,
|
||||
&isNew), envPtr->extCmdMapPtr);
|
||||
envPtr->extCmdMapPtr = NULL;
|
||||
|
||||
codePtr->localCachePtr = NULL;
|
||||
}
|
||||
|
||||
@@ -2958,86 +2577,6 @@ EnterCmdExtentData(
|
||||
cmdLocPtr->numCodeBytes = numCodeBytes;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
* TIP #280
|
||||
*
|
||||
* EnterCmdWordData --
|
||||
*
|
||||
* Registers the lines for the words of a command. This information is
|
||||
* used at runtime by 'info frame'.
|
||||
*
|
||||
* Results:
|
||||
* None.
|
||||
*
|
||||
* Side effects:
|
||||
* Inserts word location information into the compilation environment
|
||||
* envPtr for the command at index cmdIndex. The compilation
|
||||
* environment's ExtCmdLoc.ECL array is grown if necessary.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
static void
|
||||
EnterCmdWordData(
|
||||
ExtCmdLoc *eclPtr, /* Points to the map environment structure in
|
||||
* which to enter command location
|
||||
* information. */
|
||||
int srcOffset, /* Offset of first char of the command. */
|
||||
Tcl_Token *tokenPtr,
|
||||
const char *cmd,
|
||||
int len,
|
||||
int numWords,
|
||||
int line,
|
||||
int *clNext,
|
||||
int **wlines,
|
||||
CompileEnv *envPtr)
|
||||
{
|
||||
ECL *ePtr;
|
||||
const char *last;
|
||||
int wordIdx, wordLine, *wwlines, *wordNext;
|
||||
|
||||
if (eclPtr->nuloc >= eclPtr->nloc) {
|
||||
/*
|
||||
* Expand the ECL array by allocating more storage from the heap. The
|
||||
* currently allocated ECL entries are stored from eclPtr->loc[0] up
|
||||
* to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
|
||||
*/
|
||||
|
||||
size_t currElems = eclPtr->nloc;
|
||||
size_t newElems = (currElems ? 2*currElems : 1);
|
||||
size_t newBytes = newElems * sizeof(ECL);
|
||||
|
||||
eclPtr->loc = ckrealloc(eclPtr->loc, newBytes);
|
||||
eclPtr->nloc = newElems;
|
||||
}
|
||||
|
||||
ePtr = &eclPtr->loc[eclPtr->nuloc];
|
||||
ePtr->srcOffset = srcOffset;
|
||||
ePtr->line = ckalloc(numWords * sizeof(int));
|
||||
ePtr->next = ckalloc(numWords * sizeof(int *));
|
||||
ePtr->nline = numWords;
|
||||
wwlines = ckalloc(numWords * sizeof(int));
|
||||
|
||||
last = cmd;
|
||||
wordLine = line;
|
||||
wordNext = clNext;
|
||||
for (wordIdx=0 ; wordIdx<numWords;
|
||||
wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
|
||||
TclAdvanceLines(&wordLine, last, tokenPtr->start);
|
||||
TclAdvanceContinuations(&wordLine, &wordNext,
|
||||
tokenPtr->start - envPtr->source);
|
||||
wwlines[wordIdx] =
|
||||
(TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1);
|
||||
ePtr->line[wordIdx] = wordLine;
|
||||
ePtr->next[wordIdx] = wordNext;
|
||||
last = tokenPtr->start;
|
||||
}
|
||||
|
||||
*wlines = wwlines;
|
||||
eclPtr->nuloc ++;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
@@ -3468,70 +3007,6 @@ TclFixupForwardJump(
|
||||
rangePtr->type);
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* TIP #280: Adjust the mapping from PC values to the per-command
|
||||
* information about arguments and their line numbers.
|
||||
*
|
||||
* Note: We cannot simply remove an out-of-date entry and then reinsert
|
||||
* with the proper PC, because then we might overwrite another entry which
|
||||
* was at that location. Therefore we pull (copy + delete) all effected
|
||||
* entries (beyond the fixed PC) into an array, update them there, and at
|
||||
* last reinsert them all.
|
||||
*/
|
||||
|
||||
{
|
||||
ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr;
|
||||
|
||||
/* A helper structure */
|
||||
|
||||
typedef struct {
|
||||
int pc;
|
||||
int cmd;
|
||||
} MAP;
|
||||
|
||||
/*
|
||||
* And the helper array. At most the whole hashtable is placed into
|
||||
* this.
|
||||
*/
|
||||
|
||||
MAP *map = (MAP*) ckalloc (sizeof(MAP) * eclPtr->litInfo.numEntries);
|
||||
|
||||
Tcl_HashSearch hSearch;
|
||||
Tcl_HashEntry* hPtr;
|
||||
int n, k, isnew;
|
||||
|
||||
/*
|
||||
* Phase I: Locate the affected entries, and save them in adjusted
|
||||
* form to the array. This removes them from the hash.
|
||||
*/
|
||||
|
||||
for (n = 0, hPtr = Tcl_FirstHashEntry(&eclPtr->litInfo, &hSearch);
|
||||
hPtr != NULL;
|
||||
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
||||
|
||||
map [n].cmd = PTR2INT(Tcl_GetHashValue(hPtr));
|
||||
map [n].pc = PTR2INT(Tcl_GetHashKey (&eclPtr->litInfo,hPtr));
|
||||
|
||||
if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) {
|
||||
Tcl_DeleteHashEntry(hPtr);
|
||||
map [n].pc += 3;
|
||||
n++;
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* Phase II: Re-insert the modified entries into the hash.
|
||||
*/
|
||||
|
||||
for (k=0;k<n;k++) {
|
||||
hPtr = Tcl_CreateHashEntry(&eclPtr->litInfo, INT2PTR(map[k].pc), &isnew);
|
||||
Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd));
|
||||
}
|
||||
|
||||
ckfree (map);
|
||||
}
|
||||
|
||||
return 1; /* the jump was grown */
|
||||
}
|
||||
|
||||
@@ -4459,173 +3934,6 @@ FormatInstruction(
|
||||
return numBytes;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclGetInnerContext --
|
||||
*
|
||||
* If possible, returns a list capturing the inner context. Otherwise
|
||||
* return NULL.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
Tcl_Obj *
|
||||
TclGetInnerContext(
|
||||
Tcl_Interp *interp,
|
||||
const unsigned char *pc,
|
||||
Tcl_Obj **tosPtr)
|
||||
{
|
||||
int objc = 0, off = 0;
|
||||
Tcl_Obj *result;
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
|
||||
switch (*pc) {
|
||||
case INST_STR_LEN:
|
||||
case INST_LNOT:
|
||||
case INST_BITNOT:
|
||||
case INST_UMINUS:
|
||||
case INST_UPLUS:
|
||||
case INST_TRY_CVT_TO_NUMERIC:
|
||||
case INST_EXPAND_STKTOP:
|
||||
case INST_EXPR_STK:
|
||||
objc = 1;
|
||||
break;
|
||||
|
||||
case INST_LIST_IN:
|
||||
case INST_LIST_NOT_IN: /* Basic list containment operators. */
|
||||
case INST_STR_EQ:
|
||||
case INST_STR_NEQ: /* String (in)equality check */
|
||||
case INST_STR_CMP: /* String compare. */
|
||||
case INST_STR_INDEX:
|
||||
case INST_STR_MATCH:
|
||||
case INST_REGEXP:
|
||||
case INST_EQ:
|
||||
case INST_NEQ:
|
||||
case INST_LT:
|
||||
case INST_GT:
|
||||
case INST_LE:
|
||||
case INST_GE:
|
||||
case INST_MOD:
|
||||
case INST_LSHIFT:
|
||||
case INST_RSHIFT:
|
||||
case INST_BITOR:
|
||||
case INST_BITXOR:
|
||||
case INST_BITAND:
|
||||
case INST_EXPON:
|
||||
case INST_ADD:
|
||||
case INST_SUB:
|
||||
case INST_DIV:
|
||||
case INST_MULT:
|
||||
objc = 2;
|
||||
break;
|
||||
|
||||
case INST_RETURN_STK:
|
||||
/* early pop. TODO: dig out opt dict too :/ */
|
||||
objc = 1;
|
||||
break;
|
||||
|
||||
case INST_SYNTAX:
|
||||
case INST_RETURN_IMM:
|
||||
objc = 2;
|
||||
break;
|
||||
|
||||
case INST_INVOKE_STK4:
|
||||
objc = TclGetUInt4AtPtr(pc+1);
|
||||
break;
|
||||
|
||||
case INST_INVOKE_STK1:
|
||||
objc = TclGetUInt1AtPtr(pc+1);
|
||||
break;
|
||||
}
|
||||
|
||||
result = iPtr->innerContext;
|
||||
if (Tcl_IsShared(result)) {
|
||||
Tcl_DecrRefCount(result);
|
||||
iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
|
||||
Tcl_IncrRefCount(result);
|
||||
} else {
|
||||
int len;
|
||||
|
||||
/*
|
||||
* Reset while keeping the list intrep as much as possible.
|
||||
*/
|
||||
|
||||
Tcl_ListObjLength(interp, result, &len);
|
||||
Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
|
||||
}
|
||||
Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));
|
||||
|
||||
for (; objc>0 ; objc--) {
|
||||
Tcl_Obj *objPtr;
|
||||
|
||||
objPtr = tosPtr[1 - objc + off];
|
||||
if (!objPtr) {
|
||||
Tcl_Panic("InnerContext: bad tos -- appending null object");
|
||||
}
|
||||
if (objPtr->refCount<=0 || objPtr->refCount==0x61616161) {
|
||||
Tcl_Panic("InnerContext: bad tos -- appending freed object %p",
|
||||
objPtr);
|
||||
}
|
||||
Tcl_ListObjAppendElement(NULL, result, objPtr);
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclNewInstNameObj --
|
||||
*
|
||||
* Creates a new InstName Tcl_Obj based on the given instruction
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
Tcl_Obj *
|
||||
TclNewInstNameObj(
|
||||
unsigned char inst)
|
||||
{
|
||||
Tcl_Obj *objPtr = Tcl_NewObj();
|
||||
|
||||
objPtr->typePtr = &tclInstNameType;
|
||||
objPtr->internalRep.longValue = (long) inst;
|
||||
objPtr->bytes = NULL;
|
||||
|
||||
return objPtr;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* UpdateStringOfInstName --
|
||||
*
|
||||
* Update the string representation for an instruction name object.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
static void
|
||||
UpdateStringOfInstName(
|
||||
Tcl_Obj *objPtr)
|
||||
{
|
||||
int inst = objPtr->internalRep.longValue;
|
||||
char *s, buf[20];
|
||||
int len;
|
||||
|
||||
if ((inst < 0) || (inst > LAST_INST_OPCODE)) {
|
||||
sprintf(buf, "inst_%d", inst);
|
||||
s = buf;
|
||||
} else {
|
||||
s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name;
|
||||
}
|
||||
len = strlen(s);
|
||||
objPtr->bytes = ckalloc(len + 1);
|
||||
memcpy(objPtr->bytes, s, len + 1);
|
||||
objPtr->length = len;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
|
||||
+2
-64
@@ -114,46 +114,6 @@ typedef struct CmdLocation {
|
||||
int numSrcBytes; /* Number of command source chars. */
|
||||
} CmdLocation;
|
||||
|
||||
/*
|
||||
* TIP #280
|
||||
* Structure to record additional location information for byte code. This
|
||||
* information is internal and not saved. i.e. tbcload'ed code will not have
|
||||
* this information. It records the lines for all words of all commands found
|
||||
* in the byte code. The association with a ByteCode structure BC is done
|
||||
* through the 'lineBCPtr' HashTable in Interp, keyed by the address of BC.
|
||||
* Also recorded is information coming from the context, i.e. type of the
|
||||
* frame and associated information, like the path of a sourced file.
|
||||
*/
|
||||
|
||||
typedef struct ECL {
|
||||
int srcOffset; /* Command location to find the entry. */
|
||||
int nline; /* Number of words in the command */
|
||||
int *line; /* Line information for all words in the
|
||||
* command. */
|
||||
int **next; /* Transient information used by the compiler
|
||||
* for tracking of hidden continuation
|
||||
* lines. */
|
||||
} ECL;
|
||||
|
||||
typedef struct ExtCmdLoc {
|
||||
int type; /* Context type. */
|
||||
int start; /* Starting line for compiled script. Needed
|
||||
* for the extended recompile check in
|
||||
* tclCompileObj. */
|
||||
Tcl_Obj *path; /* Path of the sourced file the command is
|
||||
* in. */
|
||||
ECL *loc; /* Command word locations (lines). */
|
||||
int nloc; /* Number of allocated entries in 'loc'. */
|
||||
int nuloc; /* Number of used entries in 'loc'. */
|
||||
Tcl_HashTable litInfo; /* Indexed by bytecode 'PC', to have the
|
||||
* information accessible per command and
|
||||
* argument, not per whole bytecode. Value is
|
||||
* index of command in 'loc', giving us the
|
||||
* literals to associate with line information
|
||||
* as command argument, see
|
||||
* TclArgumentBCEnter() */
|
||||
} ExtCmdLoc;
|
||||
|
||||
/*
|
||||
* CompileProcs need the ability to record information during compilation that
|
||||
* can be used by bytecode instructions during execution. The AuxData
|
||||
@@ -300,23 +260,10 @@ typedef struct CompileEnv {
|
||||
/* Initial storage for cmd location map. */
|
||||
AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
|
||||
/* Initial storage for aux data array. */
|
||||
/* TIP #280 */
|
||||
ExtCmdLoc *extCmdMapPtr; /* Extended command location information for
|
||||
* 'info frame'. */
|
||||
int line; /* First line of the script, based on the
|
||||
* invoking context, then the line of the
|
||||
* command currently compiled. */
|
||||
int atCmdStart; /* Flag to say whether an INST_START_CMD
|
||||
* should be issued; they should never be
|
||||
* issued repeatedly, as that is significantly
|
||||
* inefficient. */
|
||||
ContLineLoc *clLoc; /* If not NULL, the table holding the
|
||||
* locations of the invisible continuation
|
||||
* lines in the input script, to adjust the
|
||||
* line counter. */
|
||||
int *clNext; /* If not NULL, it refers to the next slot in
|
||||
* clLoc to check for an invisible
|
||||
* continuation line. */
|
||||
} CompileEnv;
|
||||
|
||||
/*
|
||||
@@ -906,8 +853,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine;
|
||||
*----------------------------------------------------------------
|
||||
*/
|
||||
|
||||
MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
|
||||
const CmdFrame *invoker, int word);
|
||||
MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------
|
||||
@@ -970,7 +916,7 @@ MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr,
|
||||
MODULE_SCOPE void TclInitCompilation(void);
|
||||
MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp,
|
||||
CompileEnv *envPtr, const char *string,
|
||||
int numBytes, const CmdFrame *invoker, int word);
|
||||
int numBytes);
|
||||
MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
|
||||
MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr);
|
||||
#ifdef TCL_COMPILE_STATS
|
||||
@@ -1011,14 +957,6 @@ MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr);
|
||||
#endif
|
||||
MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
|
||||
Tcl_Obj *valuePtr);
|
||||
MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp,
|
||||
const char *script,
|
||||
const char *command, int length,
|
||||
const unsigned char *pc, Tcl_Obj **tosPtr);
|
||||
MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp,
|
||||
const unsigned char *pc, Tcl_Obj **tosPtr);
|
||||
MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
|
||||
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------
|
||||
|
||||
+14
-28
@@ -2377,7 +2377,6 @@ DictForNRCmd(
|
||||
int objc,
|
||||
Tcl_Obj *const *objv)
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
|
||||
Tcl_Obj **varv, *keyObj, *valueObj;
|
||||
Tcl_DictSearch *searchPtr;
|
||||
@@ -2445,9 +2444,9 @@ DictForNRCmd(
|
||||
* Run the script.
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
|
||||
Tcl_NRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
|
||||
valueVarObj, scriptObj);
|
||||
return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
|
||||
return TclNREvalObjEx(interp, scriptObj, 0);
|
||||
|
||||
/*
|
||||
* For unwinding everything on error.
|
||||
@@ -2468,7 +2467,6 @@ DictForLoopCallback(
|
||||
Tcl_Interp *interp,
|
||||
int result)
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
Tcl_DictSearch *searchPtr = data[0];
|
||||
Tcl_Obj *keyVarObj = data[1];
|
||||
Tcl_Obj *valueVarObj = data[2];
|
||||
@@ -2527,9 +2525,9 @@ DictForLoopCallback(
|
||||
* Run the script.
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
|
||||
Tcl_NRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
|
||||
valueVarObj, scriptObj);
|
||||
return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
|
||||
return TclNREvalObjEx(interp, scriptObj, 0);
|
||||
|
||||
/*
|
||||
* For unwinding everything once the iterating is done.
|
||||
@@ -2569,7 +2567,6 @@ DictMapNRCmd(
|
||||
int objc,
|
||||
Tcl_Obj *const *objv)
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
Tcl_Obj **varv, *keyObj, *valueObj;
|
||||
DictMapStorage *storagePtr;
|
||||
int varc, done;
|
||||
@@ -2647,9 +2644,8 @@ DictMapNRCmd(
|
||||
* Run the script.
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL);
|
||||
return TclNREvalObjEx(interp, storagePtr->scriptObj, 0,
|
||||
iPtr->cmdFramePtr, 3);
|
||||
Tcl_NRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL);
|
||||
return TclNREvalObjEx(interp, storagePtr->scriptObj, 0);
|
||||
|
||||
/*
|
||||
* For unwinding everything on error.
|
||||
@@ -2671,7 +2667,6 @@ DictMapLoopCallback(
|
||||
Tcl_Interp *interp,
|
||||
int result)
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
DictMapStorage *storagePtr = data[0];
|
||||
Tcl_Obj *keyObj, *valueObj;
|
||||
int done;
|
||||
@@ -2737,9 +2732,8 @@ DictMapLoopCallback(
|
||||
* Run the script.
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL);
|
||||
return TclNREvalObjEx(interp, storagePtr->scriptObj, 0,
|
||||
iPtr->cmdFramePtr, 3);
|
||||
Tcl_NRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL);
|
||||
return TclNREvalObjEx(interp, storagePtr->scriptObj, 0);
|
||||
|
||||
/*
|
||||
* For unwinding everything once the iterating is done.
|
||||
@@ -2899,7 +2893,6 @@ DictFilterCmd(
|
||||
int objc,
|
||||
Tcl_Obj *const *objv)
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
static const char *const filters[] = {
|
||||
"key", "script", "value", NULL
|
||||
};
|
||||
@@ -3083,11 +3076,7 @@ DictFilterCmd(
|
||||
goto abnormalResult;
|
||||
}
|
||||
|
||||
/*
|
||||
* TIP #280. Make invoking context available to loop body.
|
||||
*/
|
||||
|
||||
result = TclEvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 4);
|
||||
result = Tcl_EvalObjEx(interp, scriptObj, 0);
|
||||
switch (result) {
|
||||
case TCL_OK:
|
||||
boolObj = Tcl_GetObjResult(interp);
|
||||
@@ -3186,7 +3175,6 @@ DictUpdateCmd(
|
||||
int objc,
|
||||
Tcl_Obj *const *objv)
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
Tcl_Obj *dictPtr, *objPtr;
|
||||
int i, dummy;
|
||||
|
||||
@@ -3228,9 +3216,9 @@ DictUpdateCmd(
|
||||
objPtr = Tcl_NewListObj(objc-3, objv+2);
|
||||
Tcl_IncrRefCount(objPtr);
|
||||
Tcl_IncrRefCount(objv[1]);
|
||||
TclNRAddCallback(interp, FinalizeDictUpdate, objv[1], objPtr, NULL,NULL);
|
||||
Tcl_NRAddCallback(interp, FinalizeDictUpdate, objv[1], objPtr, NULL,NULL);
|
||||
|
||||
return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
|
||||
return TclNREvalObjEx(interp, objv[objc-1], 0);
|
||||
}
|
||||
|
||||
static int
|
||||
@@ -3345,7 +3333,6 @@ DictWithCmd(
|
||||
int objc,
|
||||
Tcl_Obj *const *objv)
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
Tcl_Obj *dictPtr, *keysPtr, *pathPtr;
|
||||
|
||||
if (objc < 3) {
|
||||
@@ -3369,8 +3356,7 @@ DictWithCmd(
|
||||
Tcl_IncrRefCount(keysPtr);
|
||||
|
||||
/*
|
||||
* Execute the body, while making the invoking context available to the
|
||||
* loop body (TIP#280) and postponing the cleanup until later (NRE).
|
||||
* Execute the body, while postponing the cleanup until later (NRE).
|
||||
*/
|
||||
|
||||
pathPtr = NULL;
|
||||
@@ -3379,10 +3365,10 @@ DictWithCmd(
|
||||
Tcl_IncrRefCount(pathPtr);
|
||||
}
|
||||
Tcl_IncrRefCount(objv[1]);
|
||||
TclNRAddCallback(interp, FinalizeDictWith, objv[1], keysPtr, pathPtr,
|
||||
Tcl_NRAddCallback(interp, FinalizeDictWith, objv[1], keysPtr, pathPtr,
|
||||
NULL);
|
||||
|
||||
return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
|
||||
return TclNREvalObjEx(interp, objv[objc-1], 0);
|
||||
}
|
||||
|
||||
static int
|
||||
|
||||
@@ -0,0 +1,432 @@
|
||||
#ifndef _TCLENGINE
|
||||
#define _TCLENGINE 1
|
||||
|
||||
/*
|
||||
* ClientData type used by the math operator commands.
|
||||
*/
|
||||
|
||||
typedef struct {
|
||||
const char *op; /* Do not call it 'operator': C++ reserved */
|
||||
const char *expected;
|
||||
union {
|
||||
int numArgs;
|
||||
int identity;
|
||||
} i;
|
||||
} TclOpCmdClientData;
|
||||
|
||||
MODULE_SCOPE int TclSingleOpCmd(ClientData clientData,
|
||||
Tcl_Interp *interp, int objc,
|
||||
Tcl_Obj *const objv[]);
|
||||
MODULE_SCOPE int TclSortingOpCmd(ClientData clientData,
|
||||
Tcl_Interp *interp, int objc,
|
||||
Tcl_Obj *const objv[]);
|
||||
MODULE_SCOPE int TclVariadicOpCmd(ClientData clientData,
|
||||
Tcl_Interp *interp, int objc,
|
||||
Tcl_Obj *const objv[]);
|
||||
MODULE_SCOPE int TclNoIdentOpCmd(ClientData clientData,
|
||||
Tcl_Interp *interp, int objc,
|
||||
Tcl_Obj *const objv[]);
|
||||
|
||||
MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
|
||||
MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes,
|
||||
int length, unsigned int hash, int *newPtr,
|
||||
Namespace *nsPtr, int flags,
|
||||
LiteralEntry **globalPtrPtr);
|
||||
|
||||
/*
|
||||
* The structure defining the bytecode instructions resulting from compiling a
|
||||
* Tcl script. Note that this structure is variable length: a single heap
|
||||
* object is allocated to hold the ByteCode structure immediately followed by
|
||||
* the code bytes, the literal object array, the ExceptionRange array, the
|
||||
* CmdLocation map, and the compilation AuxData array.
|
||||
*/
|
||||
|
||||
/*
|
||||
* A PRECOMPILED bytecode struct is one that was generated from a compiled
|
||||
* image rather than implicitly compiled from source
|
||||
*/
|
||||
|
||||
#define TCL_BYTECODE_PRECOMPILED 0x0001
|
||||
|
||||
/*
|
||||
* When a bytecode is compiled, interp or namespace resolvers have not been
|
||||
* applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag.
|
||||
*/
|
||||
|
||||
#define TCL_BYTECODE_RESOLVE_VARS 0x0002
|
||||
|
||||
#define TCL_BYTECODE_RECOMPILE 0x0004
|
||||
|
||||
typedef struct ByteCode {
|
||||
TclHandle interpHandle; /* Handle for interpreter containing the
|
||||
* compiled code. Commands and their compile
|
||||
* procs are specific to an interpreter so the
|
||||
* code emitted will depend on the
|
||||
* interpreter. */
|
||||
int compileEpoch; /* Value of iPtr->compileEpoch when this
|
||||
* ByteCode was compiled. Used to invalidate
|
||||
* code when, e.g., commands with compile
|
||||
* procs are redefined. */
|
||||
Namespace *nsPtr; /* Namespace context in which this code was
|
||||
* compiled. If the code is executed if a
|
||||
* different namespace, it must be
|
||||
* recompiled. */
|
||||
int nsEpoch; /* Value of nsPtr->resolverEpoch when this
|
||||
* ByteCode was compiled. Used to invalidate
|
||||
* code when new namespace resolution rules
|
||||
* are put into effect. */
|
||||
int refCount; /* Reference count: set 1 when created plus 1
|
||||
* for each execution of the code currently
|
||||
* active. This structure can be freed when
|
||||
* refCount becomes zero. */
|
||||
unsigned int flags; /* flags describing state for the codebyte.
|
||||
* this variable holds ORed values from the
|
||||
* TCL_BYTECODE_ masks defined above */
|
||||
const char *source; /* The source string from which this ByteCode
|
||||
* was compiled. Note that this pointer is not
|
||||
* owned by the ByteCode and must not be freed
|
||||
* or modified by it. */
|
||||
Proc *procPtr; /* If the ByteCode was compiled from a
|
||||
* procedure body, this is a pointer to its
|
||||
* Proc structure; otherwise NULL. This
|
||||
* pointer is also not owned by the ByteCode
|
||||
* and must not be freed by it. */
|
||||
LocalCache *localCachePtr; /* Pointer to the start of the cached variable
|
||||
* names and initialisation data for local
|
||||
* variables. */
|
||||
#ifdef TCL_COMPILE_STATS
|
||||
Tcl_Time createTime; /* Absolute time when the ByteCode was
|
||||
* created. */
|
||||
#endif /* TCL_COMPILE_STATS */
|
||||
size_t structureSize; /* Number of bytes in the ByteCode structure
|
||||
* itself. Does not include heap space for
|
||||
* literal Tcl objects or storage referenced
|
||||
* by AuxData entries. */
|
||||
int numCommands; /* Number of commands compiled. */
|
||||
int numSrcBytes; /* Number of source bytes compiled. */
|
||||
int numCodeBytes; /* Number of code bytes. */
|
||||
int numLitObjects; /* Number of objects in literal array. */
|
||||
int numExceptRanges; /* Number of ExceptionRange array elems. */
|
||||
int numAuxDataItems; /* Number of AuxData items. */
|
||||
int numCmdLocBytes; /* Number of bytes needed for encoded command
|
||||
* location information. */
|
||||
int maxExceptDepth; /* Maximum nesting level of ExceptionRanges;
|
||||
* -1 if no ranges were compiled. */
|
||||
int maxStackDepth; /* Maximum number of stack elements needed to
|
||||
* execute the code. */
|
||||
unsigned char *codeStart; /* Points to the first byte of the code. This
|
||||
* is just after the final ByteCode member
|
||||
* cmdMapPtr. */
|
||||
Tcl_Obj **objArrayPtr; /* Points to the start of the literal object
|
||||
* array. This is just after the last code
|
||||
* byte. */
|
||||
struct ExceptionRange *exceptArrayPtr;
|
||||
/* Points to the start of the ExceptionRange
|
||||
* array. This is just after the last object
|
||||
* in the object array. */
|
||||
struct AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data
|
||||
* array. This is just after the last entry in
|
||||
* the ExceptionRange array. */
|
||||
unsigned char *codeDeltaStart;
|
||||
/* Points to the first of a sequence of bytes
|
||||
* that encode the change in the starting
|
||||
* offset of each command's code. If -127 <=
|
||||
* delta <= 127, it is encoded as 1 byte,
|
||||
* otherwise 0xFF (128) appears and the delta
|
||||
* is encoded by the next 4 bytes. Code deltas
|
||||
* are always positive. This sequence is just
|
||||
* after the last entry in the AuxData
|
||||
* array. */
|
||||
unsigned char *codeLengthStart;
|
||||
/* Points to the first of a sequence of bytes
|
||||
* that encode the length of each command's
|
||||
* code. The encoding is the same as for code
|
||||
* deltas. Code lengths are always positive.
|
||||
* This sequence is just after the last entry
|
||||
* in the code delta sequence. */
|
||||
unsigned char *srcDeltaStart;
|
||||
/* Points to the first of a sequence of bytes
|
||||
* that encode the change in the starting
|
||||
* offset of each command's source. The
|
||||
* encoding is the same as for code deltas.
|
||||
* Source deltas can be negative. This
|
||||
* sequence is just after the last byte in the
|
||||
* code length sequence. */
|
||||
unsigned char *srcLengthStart;
|
||||
/* Points to the first of a sequence of bytes
|
||||
* that encode the length of each command's
|
||||
* source. The encoding is the same as for
|
||||
* code deltas. Source lengths are always
|
||||
* positive. This sequence is just after the
|
||||
* last byte in the source delta sequence. */
|
||||
} ByteCode;
|
||||
|
||||
/*
|
||||
* The type of procedure called from the compilation hook point in
|
||||
* SetByteCodeFromAny.
|
||||
*/
|
||||
typedef struct CompileEnv CompileEnv;
|
||||
typedef int (CompileHookProc)(Tcl_Interp *interp,
|
||||
CompileEnv *compEnvPtr, ClientData clientData);
|
||||
|
||||
MODULE_SCOPE int TclCompileToCompiledCommand(Tcl_Interp *interp,
|
||||
Tcl_Parse *parsePtr, int depth, Command *cmdPtr,
|
||||
struct CompileEnv *envPtr);
|
||||
MODULE_SCOPE void TclCompileToInvokedCommand(Tcl_Interp *interp,
|
||||
Tcl_Parse *parsePtr, Tcl_Obj *replacements,
|
||||
Command *cmdPtr, struct CompileEnv *envPtr);
|
||||
MODULE_SCOPE int TclCompileBasicNArgCommand(Tcl_Interp *interp,
|
||||
Tcl_Parse *parsePtr, Command *cmdPtr,
|
||||
struct CompileEnv *envPtr);
|
||||
|
||||
typedef struct ByteCode ByteCode; /* Forward declaration. */
|
||||
|
||||
MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp,
|
||||
ByteCode *codePtr);
|
||||
|
||||
MODULE_SCOPE int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
|
||||
CompileHookProc *hookProc, ClientData clientData);
|
||||
|
||||
MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size);
|
||||
MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp,
|
||||
CompileEnv *envPtr, const char *string,
|
||||
int numBytes);
|
||||
MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr);
|
||||
|
||||
MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp,
|
||||
const char *name, Namespace *nsPtr);
|
||||
MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr);
|
||||
MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp,
|
||||
LiteralTable *tablePtr);
|
||||
/*
|
||||
*----------------------------------------------------------------
|
||||
* Procedures exported by the engine to be used by tclBasic.c
|
||||
*----------------------------------------------------------------
|
||||
*/
|
||||
|
||||
MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
|
||||
|
||||
|
||||
#ifdef TCL_COMPILE_STATS
|
||||
MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr);
|
||||
MODULE_SCOPE int TclLog2(int value);
|
||||
#endif
|
||||
|
||||
/*
|
||||
* DTrace probe macros (NOPs if DTrace support is not enabled).
|
||||
*/
|
||||
|
||||
/*
|
||||
* Define the following macros to enable debug logging of the DTrace proc,
|
||||
* cmd, and inst probes. Note that this does _not_ require a platform with
|
||||
* DTrace, it simply logs all probe output to /tmp/tclDTraceDebug-[pid].log.
|
||||
*
|
||||
* If the second macro is defined, logging to file starts immediately,
|
||||
* otherwise only after the first call to [tcl::dtrace]. Note that the debug
|
||||
* probe data is always computed, even when it is not logged to file.
|
||||
*
|
||||
* Defining the third macro enables debug logging of inst probes (disabled
|
||||
* by default due to the significant performance impact).
|
||||
*/
|
||||
|
||||
/*
|
||||
#define TCL_DTRACE_DEBUG 1
|
||||
#define TCL_DTRACE_DEBUG_LOG_ENABLED 1
|
||||
#define TCL_DTRACE_DEBUG_INST_PROBES 1
|
||||
*/
|
||||
|
||||
#if !(defined(TCL_DTRACE_DEBUG) && defined(__GNUC__))
|
||||
|
||||
#ifdef USE_DTRACE
|
||||
|
||||
#if defined(__GNUC__) && __GNUC__ > 2
|
||||
/*
|
||||
* Use gcc branch prediction hint to minimize cost of DTrace ENABLED checks.
|
||||
*/
|
||||
#define unlikely(x) (__builtin_expect((x), 0))
|
||||
#else
|
||||
#define unlikely(x) (x)
|
||||
#endif
|
||||
|
||||
#define TCL_DTRACE_PROC_ENTRY_ENABLED() unlikely(TCL_PROC_ENTRY_ENABLED())
|
||||
#define TCL_DTRACE_PROC_RETURN_ENABLED() unlikely(TCL_PROC_RETURN_ENABLED())
|
||||
#define TCL_DTRACE_PROC_RESULT_ENABLED() unlikely(TCL_PROC_RESULT_ENABLED())
|
||||
#define TCL_DTRACE_PROC_ARGS_ENABLED() unlikely(TCL_PROC_ARGS_ENABLED())
|
||||
#define TCL_DTRACE_PROC_INFO_ENABLED() unlikely(TCL_PROC_INFO_ENABLED())
|
||||
#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) TCL_PROC_ENTRY(a0, a1, a2)
|
||||
#define TCL_DTRACE_PROC_RETURN(a0, a1) TCL_PROC_RETURN(a0, a1)
|
||||
#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) TCL_PROC_RESULT(a0, a1, a2, a3)
|
||||
#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
|
||||
TCL_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9)
|
||||
#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \
|
||||
TCL_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7)
|
||||
|
||||
#define TCL_DTRACE_CMD_ENTRY_ENABLED() unlikely(TCL_CMD_ENTRY_ENABLED())
|
||||
#define TCL_DTRACE_CMD_RETURN_ENABLED() unlikely(TCL_CMD_RETURN_ENABLED())
|
||||
#define TCL_DTRACE_CMD_RESULT_ENABLED() unlikely(TCL_CMD_RESULT_ENABLED())
|
||||
#define TCL_DTRACE_CMD_ARGS_ENABLED() unlikely(TCL_CMD_ARGS_ENABLED())
|
||||
#define TCL_DTRACE_CMD_INFO_ENABLED() unlikely(TCL_CMD_INFO_ENABLED())
|
||||
#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) TCL_CMD_ENTRY(a0, a1, a2)
|
||||
#define TCL_DTRACE_CMD_RETURN(a0, a1) TCL_CMD_RETURN(a0, a1)
|
||||
#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) TCL_CMD_RESULT(a0, a1, a2, a3)
|
||||
#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
|
||||
TCL_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9)
|
||||
#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \
|
||||
TCL_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7)
|
||||
|
||||
#define TCL_DTRACE_INST_START_ENABLED() unlikely(TCL_INST_START_ENABLED())
|
||||
#define TCL_DTRACE_INST_DONE_ENABLED() unlikely(TCL_INST_DONE_ENABLED())
|
||||
#define TCL_DTRACE_INST_START(a0, a1, a2) TCL_INST_START(a0, a1, a2)
|
||||
#define TCL_DTRACE_INST_DONE(a0, a1, a2) TCL_INST_DONE(a0, a1, a2)
|
||||
|
||||
#define TCL_DTRACE_TCL_PROBE_ENABLED() unlikely(TCL_TCL_PROBE_ENABLED())
|
||||
#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
|
||||
TCL_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9)
|
||||
|
||||
#define TCL_DTRACE_DEBUG_LOG()
|
||||
|
||||
MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args,
|
||||
int *argsi);
|
||||
|
||||
#else /* USE_DTRACE */
|
||||
|
||||
#define TCL_DTRACE_PROC_ENTRY_ENABLED() 0
|
||||
#define TCL_DTRACE_PROC_RETURN_ENABLED() 0
|
||||
#define TCL_DTRACE_PROC_RESULT_ENABLED() 0
|
||||
#define TCL_DTRACE_PROC_ARGS_ENABLED() 0
|
||||
#define TCL_DTRACE_PROC_INFO_ENABLED() 0
|
||||
#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) {if (a0) {}}
|
||||
#define TCL_DTRACE_PROC_RETURN(a0, a1) {if (a0) {}}
|
||||
#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) {if (a0) {}; if (a3) {}}
|
||||
#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {}
|
||||
#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) {}
|
||||
|
||||
#define TCL_DTRACE_CMD_ENTRY_ENABLED() 0
|
||||
#define TCL_DTRACE_CMD_RETURN_ENABLED() 0
|
||||
#define TCL_DTRACE_CMD_RESULT_ENABLED() 0
|
||||
#define TCL_DTRACE_CMD_ARGS_ENABLED() 0
|
||||
#define TCL_DTRACE_CMD_INFO_ENABLED() 0
|
||||
#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) {}
|
||||
#define TCL_DTRACE_CMD_RETURN(a0, a1) {}
|
||||
#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) {}
|
||||
#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {}
|
||||
#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) {}
|
||||
|
||||
#define TCL_DTRACE_INST_START_ENABLED() 0
|
||||
#define TCL_DTRACE_INST_DONE_ENABLED() 0
|
||||
#define TCL_DTRACE_INST_START(a0, a1, a2) {}
|
||||
#define TCL_DTRACE_INST_DONE(a0, a1, a2) {}
|
||||
|
||||
#define TCL_DTRACE_TCL_PROBE_ENABLED() 0
|
||||
#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {}
|
||||
|
||||
#define TclDTraceInfo(info, args, argsi) {*args = ""; *argsi = 0;}
|
||||
|
||||
#endif /* USE_DTRACE */
|
||||
|
||||
#else /* TCL_DTRACE_DEBUG */
|
||||
|
||||
#define USE_DTRACE 1
|
||||
|
||||
#if !defined(TCL_DTRACE_DEBUG_LOG_ENABLED) || !(TCL_DTRACE_DEBUG_LOG_ENABLED)
|
||||
#undef TCL_DTRACE_DEBUG_LOG_ENABLED
|
||||
#define TCL_DTRACE_DEBUG_LOG_ENABLED 0
|
||||
#endif
|
||||
|
||||
#if !defined(TCL_DTRACE_DEBUG_INST_PROBES) || !(TCL_DTRACE_DEBUG_INST_PROBES)
|
||||
#undef TCL_DTRACE_DEBUG_INST_PROBES
|
||||
#define TCL_DTRACE_DEBUG_INST_PROBES 0
|
||||
#endif
|
||||
|
||||
MODULE_SCOPE int tclDTraceDebugEnabled, tclDTraceDebugIndent;
|
||||
MODULE_SCOPE FILE *tclDTraceDebugLog;
|
||||
MODULE_SCOPE void TclDTraceOpenDebugLog(void);
|
||||
MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi);
|
||||
|
||||
#define TCL_DTRACE_DEBUG_LOG() \
|
||||
int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED; \
|
||||
int tclDTraceDebugIndent = 0; \
|
||||
FILE *tclDTraceDebugLog = NULL; \
|
||||
void TclDTraceOpenDebugLog(void) { \
|
||||
char n[35]; \
|
||||
sprintf(n, "/tmp/tclDTraceDebug-%lu.log", \
|
||||
(unsigned long) getpid()); \
|
||||
tclDTraceDebugLog = fopen(n, "a"); \
|
||||
}
|
||||
|
||||
#define TclDTraceDbgMsg(p, m, ...) \
|
||||
do { \
|
||||
if (tclDTraceDebugEnabled) { \
|
||||
int _l, _t = 0; \
|
||||
if (!tclDTraceDebugLog) { TclDTraceOpenDebugLog(); } \
|
||||
fprintf(tclDTraceDebugLog, "%.12s:%.4d:%n", \
|
||||
strrchr(__FILE__, '/')+1, __LINE__, &_l); _t += _l; \
|
||||
fprintf(tclDTraceDebugLog, " %.*s():%n", \
|
||||
(_t < 18 ? 18 - _t : 0) + 18, __func__, &_l); _t += _l; \
|
||||
fprintf(tclDTraceDebugLog, "%*s" p "%n", \
|
||||
(_t < 40 ? 40 - _t : 0) + 2 * tclDTraceDebugIndent, \
|
||||
"", &_l); _t += _l; \
|
||||
fprintf(tclDTraceDebugLog, "%*s" m "\n", \
|
||||
(_t < 64 ? 64 - _t : 1), "", ##__VA_ARGS__); \
|
||||
fflush(tclDTraceDebugLog); \
|
||||
} \
|
||||
} while (0)
|
||||
|
||||
#define TCL_DTRACE_PROC_ENTRY_ENABLED() 1
|
||||
#define TCL_DTRACE_PROC_RETURN_ENABLED() 1
|
||||
#define TCL_DTRACE_PROC_RESULT_ENABLED() 1
|
||||
#define TCL_DTRACE_PROC_ARGS_ENABLED() 1
|
||||
#define TCL_DTRACE_PROC_INFO_ENABLED() 1
|
||||
#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) \
|
||||
tclDTraceDebugIndent++; \
|
||||
TclDTraceDbgMsg("-> proc-entry", "%s %d %p", a0, a1, a2)
|
||||
#define TCL_DTRACE_PROC_RETURN(a0, a1) \
|
||||
TclDTraceDbgMsg("<- proc-return", "%s %d", a0, a1); \
|
||||
tclDTraceDebugIndent--
|
||||
#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) \
|
||||
TclDTraceDbgMsg(" | proc-result", "%s %d %s %p", a0, a1, a2, a3)
|
||||
#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
|
||||
TclDTraceDbgMsg(" | proc-args", "%s %s %s %s %s %s %s %s %s %s", a0, \
|
||||
a1, a2, a3, a4, a5, a6, a7, a8, a9)
|
||||
#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \
|
||||
TclDTraceDbgMsg(" | proc-info", "%s %s %s %s %d %d %s %s", a0, a1, \
|
||||
a2, a3, a4, a5, a6, a7)
|
||||
|
||||
#define TCL_DTRACE_CMD_ENTRY_ENABLED() 1
|
||||
#define TCL_DTRACE_CMD_RETURN_ENABLED() 1
|
||||
#define TCL_DTRACE_CMD_RESULT_ENABLED() 1
|
||||
#define TCL_DTRACE_CMD_ARGS_ENABLED() 1
|
||||
#define TCL_DTRACE_CMD_INFO_ENABLED() 1
|
||||
#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) \
|
||||
tclDTraceDebugIndent++; \
|
||||
TclDTraceDbgMsg("-> cmd-entry", "%s %d %p", a0, a1, a2)
|
||||
#define TCL_DTRACE_CMD_RETURN(a0, a1) \
|
||||
TclDTraceDbgMsg("<- cmd-return", "%s %d", a0, a1); \
|
||||
tclDTraceDebugIndent--
|
||||
#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) \
|
||||
TclDTraceDbgMsg(" | cmd-result", "%s %d %s %p", a0, a1, a2, a3)
|
||||
#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
|
||||
TclDTraceDbgMsg(" | cmd-args", "%s %s %s %s %s %s %s %s %s %s", a0, \
|
||||
a1, a2, a3, a4, a5, a6, a7, a8, a9)
|
||||
#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \
|
||||
TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %d %d %s %s", a0, a1, \
|
||||
a2, a3, a4, a5, a6, a7)
|
||||
|
||||
#define TCL_DTRACE_INST_START_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES
|
||||
#define TCL_DTRACE_INST_DONE_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES
|
||||
#define TCL_DTRACE_INST_START(a0, a1, a2) \
|
||||
TclDTraceDbgMsg(" | inst-start", "%s %d %p", a0, a1, a2)
|
||||
#define TCL_DTRACE_INST_DONE(a0, a1, a2) \
|
||||
TclDTraceDbgMsg(" | inst-end", "%s %d %p", a0, a1, a2)
|
||||
|
||||
#define TCL_DTRACE_TCL_PROBE_ENABLED() 1
|
||||
#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \
|
||||
do { \
|
||||
tclDTraceDebugEnabled = 1; \
|
||||
TclDTraceDbgMsg(" | tcl-probe", "%s %s %s %s %s %s %s %s %s %s", a0, \
|
||||
a1, a2, a3, a4, a5, a6, a7, a8, a9); \
|
||||
} while (0)
|
||||
|
||||
#endif /* TCL_DTRACE_DEBUG */
|
||||
|
||||
#endif
|
||||
File diff suppressed because it is too large
Load Diff
+2
-835
@@ -11,7 +11,6 @@
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
#include "tclCompile.h"
|
||||
|
||||
/*
|
||||
* Declarations for functions local to this file:
|
||||
@@ -35,15 +34,6 @@ static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
|
||||
static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
|
||||
static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
|
||||
static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
|
||||
static int CompileToCompiledCommand(Tcl_Interp *interp,
|
||||
Tcl_Parse *parsePtr, int depth, Command *cmdPtr,
|
||||
CompileEnv *envPtr);
|
||||
static void CompileToInvokedCommand(Tcl_Interp *interp,
|
||||
Tcl_Parse *parsePtr, Tcl_Obj *replacements,
|
||||
Command *cmdPtr, CompileEnv *envPtr);
|
||||
static int CompileBasicNArgCommand(Tcl_Interp *interp,
|
||||
Tcl_Parse *parsePtr, Command *cmdPtr,
|
||||
CompileEnv *envPtr);
|
||||
|
||||
/*
|
||||
* The lists of subcommands and options for the [namespace ensemble] command.
|
||||
@@ -88,16 +78,6 @@ const Tcl_ObjType tclEnsembleCmdType = {
|
||||
NULL /* setFromAnyProc */
|
||||
};
|
||||
|
||||
/*
|
||||
* Copied from tclCompCmds.c
|
||||
*/
|
||||
|
||||
#define DefineLineInformation \
|
||||
ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
|
||||
int eclIndex = mapPtr->nuloc - 1
|
||||
#define SetLineInformation(word) \
|
||||
envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
|
||||
envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
|
||||
|
||||
static inline Tcl_Obj *
|
||||
NewNsObj(
|
||||
@@ -1895,7 +1875,7 @@ NsEnsembleImplementationCmdNR(
|
||||
2 + ensemblePtr->numParameters;
|
||||
iPtr->ensembleRewrite.numInsertedObjs =
|
||||
prefixObjc + ensemblePtr->numParameters;
|
||||
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL,
|
||||
Tcl_NRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL,
|
||||
NULL);
|
||||
} else {
|
||||
register int ni = 2 + ensemblePtr->numParameters
|
||||
@@ -1915,7 +1895,7 @@ NsEnsembleImplementationCmdNR(
|
||||
*/
|
||||
|
||||
TclSkipTailcall(interp);
|
||||
return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN);
|
||||
return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE);
|
||||
}
|
||||
|
||||
unknownOrAmbiguousSubcommand:
|
||||
@@ -2723,819 +2703,6 @@ StringOfEnsembleCmdRep(
|
||||
memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1);
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclCompileEnsemble --
|
||||
*
|
||||
* Procedure called to compile an ensemble command. Note that most
|
||||
* ensembles are not compiled, since modifying a compiled ensemble causes
|
||||
* a invalidation of all existing bytecode (expensive!) which is not
|
||||
* normally warranted.
|
||||
*
|
||||
* Results:
|
||||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||||
* evaluation to runtime.
|
||||
*
|
||||
* Side effects:
|
||||
* Instructions are added to envPtr to execute the subcommands of the
|
||||
* ensemble at runtime if a compile-time mapping is possible.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
int
|
||||
TclCompileEnsemble(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||||
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
|
||||
Tcl_Obj *replaced = Tcl_NewObj(), *replacement;
|
||||
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
|
||||
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
|
||||
int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
|
||||
int ourResult = TCL_ERROR;
|
||||
unsigned numBytes;
|
||||
const char *word;
|
||||
|
||||
Tcl_IncrRefCount(replaced);
|
||||
|
||||
/*
|
||||
* This is where we return to if we are parsing multiple nested compiled
|
||||
* ensembles. [info object] is such a beast.
|
||||
*/
|
||||
|
||||
checkNextWord:
|
||||
if (parsePtr->numWords < depth + 1) {
|
||||
goto failed;
|
||||
}
|
||||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||||
/*
|
||||
* Too hard.
|
||||
*/
|
||||
|
||||
goto failed;
|
||||
}
|
||||
|
||||
word = tokenPtr[1].start;
|
||||
numBytes = tokenPtr[1].size;
|
||||
|
||||
/*
|
||||
* There's a sporting chance we'll be able to compile this. But now we
|
||||
* must check properly. To do that, check that we're compiling an ensemble
|
||||
* that has a compilable command as its appropriate subcommand.
|
||||
*/
|
||||
|
||||
if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
|
||||
|| mapObj == NULL) {
|
||||
/*
|
||||
* Either not an ensemble or a mapping isn't installed. Crud. Too hard
|
||||
* to proceed.
|
||||
*/
|
||||
|
||||
goto failed;
|
||||
}
|
||||
|
||||
/*
|
||||
* Also refuse to compile anything that uses a formal parameter list for
|
||||
* now, on the grounds that it is too complex.
|
||||
*/
|
||||
|
||||
if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK
|
||||
|| listObj != NULL) {
|
||||
/*
|
||||
* Figuring out how to compile this has become too much. Bail out.
|
||||
*/
|
||||
|
||||
goto failed;
|
||||
}
|
||||
|
||||
/*
|
||||
* Next, get the flags. We need them on several code paths so that we can
|
||||
* know whether we're to do prefix matching.
|
||||
*/
|
||||
|
||||
(void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags);
|
||||
|
||||
/*
|
||||
* Check to see if there's also a subcommand list; must check to see if
|
||||
* the subcommand we are calling is in that list if it exists, since that
|
||||
* list filters the entries in the map.
|
||||
*/
|
||||
|
||||
(void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
|
||||
if (listObj != NULL) {
|
||||
int sclen;
|
||||
const char *str;
|
||||
Tcl_Obj *matchObj = NULL;
|
||||
|
||||
if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
|
||||
goto failed;
|
||||
}
|
||||
for (i=0 ; i<len ; i++) {
|
||||
str = Tcl_GetStringFromObj(elems[i], &sclen);
|
||||
if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) {
|
||||
/*
|
||||
* Exact match! Excellent!
|
||||
*/
|
||||
|
||||
result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
|
||||
if (result != TCL_OK || targetCmdObj == NULL) {
|
||||
goto failed;
|
||||
}
|
||||
replacement = elems[i];
|
||||
goto doneMapLookup;
|
||||
}
|
||||
|
||||
/*
|
||||
* Check to see if we've got a prefix match. A single prefix match
|
||||
* is fine, and allows us to refine our dictionary lookup, but
|
||||
* multiple prefix matches is a Bad Thing and will prevent us from
|
||||
* making progress. Note that we cannot do the lookup immediately
|
||||
* in the prefix case; might be another entry later in the list
|
||||
* that causes things to fail.
|
||||
*/
|
||||
|
||||
if ((flags & TCL_ENSEMBLE_PREFIX)
|
||||
&& strncmp(word, str, numBytes) == 0) {
|
||||
if (matchObj != NULL) {
|
||||
goto failed;
|
||||
}
|
||||
matchObj = elems[i];
|
||||
}
|
||||
}
|
||||
if (matchObj == NULL) {
|
||||
goto failed;
|
||||
}
|
||||
result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
|
||||
if (result != TCL_OK || targetCmdObj == NULL) {
|
||||
goto failed;
|
||||
}
|
||||
replacement = matchObj;
|
||||
} else {
|
||||
Tcl_DictSearch s;
|
||||
int done, matched;
|
||||
Tcl_Obj *tmpObj;
|
||||
|
||||
/*
|
||||
* No map, so check the dictionary directly.
|
||||
*/
|
||||
|
||||
TclNewStringObj(subcmdObj, word, (int) numBytes);
|
||||
result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
|
||||
if (result == TCL_OK && targetCmdObj != NULL) {
|
||||
/*
|
||||
* Got it. Skip the fiddling around with prefixes.
|
||||
*/
|
||||
|
||||
replacement = subcmdObj;
|
||||
goto doneMapLookup;
|
||||
}
|
||||
TclDecrRefCount(subcmdObj);
|
||||
|
||||
/*
|
||||
* We've not literally got a valid subcommand. But maybe we have a
|
||||
* prefix. Check if prefix matches are allowed.
|
||||
*/
|
||||
|
||||
if (!(flags & TCL_ENSEMBLE_PREFIX)) {
|
||||
goto failed;
|
||||
}
|
||||
|
||||
/*
|
||||
* Iterate over the keys in the dictionary, checking to see if we're a
|
||||
* prefix.
|
||||
*/
|
||||
|
||||
Tcl_DictObjFirst(NULL, mapObj, &s, &subcmdObj, &tmpObj, &done);
|
||||
matched = 0;
|
||||
replacement = NULL; /* Silence, fool compiler! */
|
||||
while (!done) {
|
||||
if (strncmp(TclGetString(subcmdObj), word, numBytes) == 0) {
|
||||
if (matched++) {
|
||||
/*
|
||||
* Must have matched twice! Not unique, so no point
|
||||
* looking further.
|
||||
*/
|
||||
|
||||
break;
|
||||
}
|
||||
replacement = subcmdObj;
|
||||
targetCmdObj = tmpObj;
|
||||
}
|
||||
Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
|
||||
}
|
||||
Tcl_DictObjDone(&s);
|
||||
|
||||
/*
|
||||
* If we have anything other than a single match, we've failed the
|
||||
* unique prefix check.
|
||||
*/
|
||||
|
||||
if (matched != 1) {
|
||||
invokeAnyway = 1;
|
||||
goto failed;
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* OK, we definitely map to something. But what?
|
||||
*
|
||||
* The command we map to is the first word out of the map element. Note
|
||||
* that we also reject dealing with multi-element rewrites if we are in a
|
||||
* safe interpreter, as there is otherwise a (highly gnarly!) way to make
|
||||
* Tcl crash open to exploit.
|
||||
*/
|
||||
|
||||
doneMapLookup:
|
||||
Tcl_ListObjAppendElement(NULL, replaced, replacement);
|
||||
if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
|
||||
goto failed;
|
||||
} else if (len != 1) {
|
||||
/*
|
||||
* Note that at this point we know we can't issue any special
|
||||
* instruction sequence as the mapping isn't one that we support at
|
||||
* the compiled level.
|
||||
*/
|
||||
|
||||
goto cleanup;
|
||||
}
|
||||
targetCmdObj = elems[0];
|
||||
|
||||
oldCmdPtr = cmdPtr;
|
||||
Tcl_IncrRefCount(targetCmdObj);
|
||||
newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
|
||||
TclDecrRefCount(targetCmdObj);
|
||||
if (newCmdPtr == NULL || Tcl_IsSafe(interp)
|
||||
|| newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
|
||||
|| newCmdPtr->flags & CMD_HAS_EXEC_TRACES
|
||||
|| ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
|
||||
/*
|
||||
* Maps to an undefined command or a command without a compiler.
|
||||
* Cannot compile.
|
||||
*/
|
||||
|
||||
goto cleanup;
|
||||
}
|
||||
cmdPtr = newCmdPtr;
|
||||
depth++;
|
||||
|
||||
/*
|
||||
* See whether we have a nested ensemble. If we do, we can go round the
|
||||
* mulberry bush again, consuming the next word.
|
||||
*/
|
||||
|
||||
if (cmdPtr->compileProc == TclCompileEnsemble) {
|
||||
tokenPtr = TokenAfter(tokenPtr);
|
||||
ensemble = (Tcl_Command) cmdPtr;
|
||||
goto checkNextWord;
|
||||
}
|
||||
|
||||
/*
|
||||
* Now we've done the mapping process, can now actually try to compile.
|
||||
* If there is a subcommand compiler and that successfully produces code,
|
||||
* we'll use that. Otherwise, we fall back to generating opcodes to do the
|
||||
* invoke at runtime.
|
||||
*/
|
||||
|
||||
invokeAnyway = 1;
|
||||
if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr,
|
||||
envPtr) == TCL_OK) {
|
||||
ourResult = TCL_OK;
|
||||
goto cleanup;
|
||||
}
|
||||
|
||||
/*
|
||||
* Failed to do a full compile for some reason. Try to do a direct invoke
|
||||
* instead of going through the ensemble lookup process again.
|
||||
*/
|
||||
|
||||
failed:
|
||||
if (depth < 250) {
|
||||
if (depth > 1) {
|
||||
if (!invokeAnyway) {
|
||||
cmdPtr = oldCmdPtr;
|
||||
depth--;
|
||||
}
|
||||
(void) Tcl_ListObjReplace(NULL, replaced, depth, 2, 0, NULL);
|
||||
}
|
||||
CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr);
|
||||
ourResult = TCL_OK;
|
||||
}
|
||||
|
||||
/*
|
||||
* Release the memory we allocated. If we've got here, we've either done
|
||||
* something useful or we're in a case that we can't compile at all and
|
||||
* we're just giving up.
|
||||
*/
|
||||
|
||||
cleanup:
|
||||
Tcl_DecrRefCount(replaced);
|
||||
return ourResult;
|
||||
}
|
||||
|
||||
/*
|
||||
* How to compile a subcommand using its own command compiler. To do that, we
|
||||
* have to perform some trickery to rewrite the arguments, as compilers *must*
|
||||
* have parse tokens that refer to addresses in the original script.
|
||||
*/
|
||||
|
||||
static int
|
||||
CompileToCompiledCommand(
|
||||
Tcl_Interp *interp,
|
||||
Tcl_Parse *parsePtr,
|
||||
int depth,
|
||||
Command *cmdPtr,
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
Tcl_Parse synthetic;
|
||||
Tcl_Token *tokenPtr;
|
||||
int result, i;
|
||||
int savedNumCmds = envPtr->numCommands;
|
||||
int savedStackDepth = envPtr->currStackDepth;
|
||||
unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
|
||||
|
||||
if (cmdPtr->compileProc == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
TclParseInit(interp, NULL, 0, &synthetic);
|
||||
synthetic.numWords = parsePtr->numWords - depth + 1;
|
||||
TclGrowParseTokenArray(&synthetic, 2);
|
||||
synthetic.numTokens = 2;
|
||||
|
||||
/*
|
||||
* Now we have the space to work in, install something rewritten. The
|
||||
* first word will "officially" be the bytes of the structured ensemble
|
||||
* name. That's technically wrong, but nobody will care; we just need
|
||||
* *something* here...
|
||||
*/
|
||||
|
||||
synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD;
|
||||
synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start;
|
||||
synthetic.tokenPtr[0].numComponents = 1;
|
||||
synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT;
|
||||
synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start;
|
||||
synthetic.tokenPtr[1].numComponents = 0;
|
||||
for (i=0,tokenPtr=parsePtr->tokenPtr ; i<depth ; i++) {
|
||||
int sclen = (tokenPtr->start - synthetic.tokenPtr[0].start)
|
||||
+ tokenPtr->size;
|
||||
|
||||
synthetic.tokenPtr[0].size = sclen;
|
||||
synthetic.tokenPtr[1].size = sclen;
|
||||
tokenPtr = TokenAfter(tokenPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* Copy over the real argument tokens.
|
||||
*/
|
||||
|
||||
for (i=1; i<synthetic.numWords; i++) {
|
||||
int toCopy;
|
||||
|
||||
toCopy = tokenPtr->numComponents + 1;
|
||||
TclGrowParseTokenArray(&synthetic, toCopy);
|
||||
memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr,
|
||||
sizeof(Tcl_Token) * toCopy);
|
||||
synthetic.numTokens += toCopy;
|
||||
tokenPtr = TokenAfter(tokenPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* Hand off compilation to the subcommand compiler. At last!
|
||||
*/
|
||||
|
||||
result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
|
||||
|
||||
/*
|
||||
* If our target fails to compile, revert the number of commands and the
|
||||
* pointer to the place to issue the next instruction. [Bug 3600328]
|
||||
*/
|
||||
|
||||
if (result != TCL_OK) {
|
||||
envPtr->numCommands = savedNumCmds;
|
||||
envPtr->currStackDepth = savedStackDepth;
|
||||
envPtr->codeNext = envPtr->codeStart + savedCodeNext;
|
||||
}
|
||||
|
||||
/*
|
||||
* Clean up if necessary.
|
||||
*/
|
||||
|
||||
Tcl_FreeParse(&synthetic);
|
||||
return result;
|
||||
}
|
||||
|
||||
/*
|
||||
* How to compile a subcommand to a _replacing_ invoke of its implementation
|
||||
* command.
|
||||
*/
|
||||
|
||||
static void
|
||||
CompileToInvokedCommand(
|
||||
Tcl_Interp *interp,
|
||||
Tcl_Parse *parsePtr,
|
||||
Tcl_Obj *replacements,
|
||||
Command *cmdPtr,
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
Tcl_Token *tokPtr;
|
||||
Tcl_Obj *objPtr, **words;
|
||||
char *bytes;
|
||||
int length, i, numWords, cmdLit;
|
||||
DefineLineInformation;
|
||||
|
||||
/*
|
||||
* Push the words of the command. Take care; the command words may be
|
||||
* scripts that have backslashes in them, and [info frame 0] can see the
|
||||
* difference. Hence the call to TclContinuationsEnterDerived...
|
||||
*/
|
||||
|
||||
Tcl_ListObjGetElements(NULL, replacements, &numWords, &words);
|
||||
for (i=0,tokPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
|
||||
if (i > 0 && i < numWords+1) {
|
||||
bytes = Tcl_GetStringFromObj(words[i-1], &length);
|
||||
PushLiteral(envPtr, bytes, length);
|
||||
} else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||||
int literal = TclRegisterNewLiteral(envPtr,
|
||||
tokPtr[1].start, tokPtr[1].size);
|
||||
|
||||
if (envPtr->clNext) {
|
||||
TclContinuationsEnterDerived(
|
||||
envPtr->literalArrayPtr[literal].objPtr,
|
||||
tokPtr[1].start - envPtr->source,
|
||||
mapPtr->loc[eclIndex].next[i]);
|
||||
}
|
||||
TclEmitPush(literal, envPtr);
|
||||
} else {
|
||||
if (envPtr->clNext) {
|
||||
SetLineInformation(i);
|
||||
}
|
||||
CompileTokens(envPtr, tokPtr, interp);
|
||||
}
|
||||
tokPtr = TokenAfter(tokPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* Push the name of the command we're actually dispatching to as part of
|
||||
* the implementation.
|
||||
*/
|
||||
|
||||
objPtr = Tcl_NewObj();
|
||||
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
|
||||
bytes = Tcl_GetStringFromObj(objPtr, &length);
|
||||
cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
|
||||
TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr, cmdPtr);
|
||||
TclEmitPush(cmdLit, envPtr);
|
||||
TclDecrRefCount(objPtr);
|
||||
|
||||
/*
|
||||
* Do the replacing dispatch.
|
||||
*/
|
||||
|
||||
TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr);
|
||||
TclEmitInt1(numWords+1, envPtr);
|
||||
TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */
|
||||
}
|
||||
|
||||
/*
|
||||
* Helpers that do issuing of instructions for commands that "don't have
|
||||
* compilers" (well, they do; these). They all work by just generating base
|
||||
* code to invoke the command; they're intended for ensemble subcommands so
|
||||
* that the costs of INST_INVOKE_REPLACE can be avoided where we can work out
|
||||
* that they're not needed.
|
||||
*
|
||||
* Note that these are NOT suitable for commands where there's an argument
|
||||
* that is a script, as an [info level] or [info frame] in the inner context
|
||||
* can see the difference.
|
||||
*/
|
||||
|
||||
static int
|
||||
CompileBasicNArgCommand(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
Tcl_Token *tokenPtr;
|
||||
Tcl_Obj *objPtr;
|
||||
char *bytes;
|
||||
int length, i, literal;
|
||||
DefineLineInformation;
|
||||
|
||||
/*
|
||||
* Push the name of the command we're actually dispatching to as part of
|
||||
* the implementation.
|
||||
*/
|
||||
|
||||
objPtr = Tcl_NewObj();
|
||||
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
|
||||
bytes = Tcl_GetStringFromObj(objPtr, &length);
|
||||
literal = TclRegisterNewCmdLiteral(envPtr, bytes, length);
|
||||
TclSetCmdNameObj(interp, envPtr->literalArrayPtr[literal].objPtr, cmdPtr);
|
||||
TclEmitPush(literal, envPtr);
|
||||
TclDecrRefCount(objPtr);
|
||||
|
||||
/*
|
||||
* Push the words of the command.
|
||||
*/
|
||||
|
||||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||||
for (i=1 ; i<parsePtr->numWords ; i++) {
|
||||
if (envPtr->clNext) {
|
||||
SetLineInformation(i);
|
||||
}
|
||||
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||||
PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size);
|
||||
} else {
|
||||
CompileTokens(envPtr, tokenPtr, interp);
|
||||
}
|
||||
tokenPtr = TokenAfter(tokenPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* Do the standard dispatch.
|
||||
*/
|
||||
|
||||
if (i <= 255) {
|
||||
TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr);
|
||||
} else {
|
||||
TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr);
|
||||
}
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic0ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 1) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic1ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 2) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic2ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 3) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic3ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 4) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic0Or1ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 1 && parsePtr->numWords != 2) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic1Or2ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic2Or3ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic0To2ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords < 1 || parsePtr->numWords > 3) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasic1To3ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasicMin0ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords < 1) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasicMin1ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords < 2) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
int
|
||||
TclCompileBasicMin2ArgCmd(
|
||||
Tcl_Interp *interp, /* Used for error reporting. */
|
||||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||||
* created by Tcl_ParseCommand. */
|
||||
Command *cmdPtr, /* Points to defintion of command being
|
||||
* compiled. */
|
||||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||||
{
|
||||
/*
|
||||
* Verify that the number of arguments is correct; that's the only case
|
||||
* that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
|
||||
* which is the only code that sees the shenanigans of ensemble dispatch.
|
||||
*/
|
||||
|
||||
if (parsePtr->numWords < 3) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* Local Variables:
|
||||
* mode: c
|
||||
|
||||
+50
-257
@@ -15,16 +15,11 @@
|
||||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
#include "tclCompile.h"
|
||||
#include "tclEngineInt.h"
|
||||
#include "tclOOInt.h"
|
||||
#include "tommath.h"
|
||||
#include <math.h>
|
||||
|
||||
#if NRE_ENABLE_ASSERTS
|
||||
#include <assert.h>
|
||||
#endif
|
||||
|
||||
/*
|
||||
* Hack to determine whether we may expect IEEE floating point. The hack is
|
||||
* formally incorrect in that non-IEEE platforms might have the same precision
|
||||
@@ -179,7 +174,6 @@ typedef struct TEBCdata {
|
||||
int cleanup; /* new codePtr was received for NR */
|
||||
Tcl_Obj *auxObjList; /* execution. */
|
||||
int checkInterp;
|
||||
CmdFrame cmdFrame;
|
||||
void *stack[1]; /* Start of the actual combined catch and obj
|
||||
* stacks; the struct will be expanded as
|
||||
* necessary */
|
||||
@@ -190,7 +184,7 @@ typedef struct TEBCdata {
|
||||
esPtr->tosPtr = tosPtr; \
|
||||
TD->pc = pc; \
|
||||
TD->cleanup = cleanup; \
|
||||
TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \
|
||||
Tcl_NRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \
|
||||
} while (0)
|
||||
|
||||
#define TEBC_DATA_DIG() \
|
||||
@@ -796,6 +790,35 @@ ReleaseDictIterator(
|
||||
|
||||
objPtr->typePtr = NULL;
|
||||
}
|
||||
|
||||
static void UpdateStringOfBcSource(Tcl_Obj *objPtr);
|
||||
|
||||
static const Tcl_ObjType bcSourceType = {
|
||||
"bcSource", /* name */
|
||||
NULL, /* freeIntRepProc */
|
||||
NULL, /* dupIntRepProc */
|
||||
UpdateStringOfBcSource, /* updateStringProc */
|
||||
NULL /* setFromAnyProc */
|
||||
};
|
||||
|
||||
static void
|
||||
UpdateStringOfBcSource(
|
||||
Tcl_Obj *objPtr)
|
||||
{
|
||||
int len;
|
||||
const char *bytes;
|
||||
unsigned char *pc = objPtr->internalRep.twoPtrValue.ptr1;
|
||||
ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr2;
|
||||
|
||||
bytes = GetSrcInfoForPc(pc, codePtr, &len, NULL);
|
||||
objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
|
||||
memcpy(objPtr->bytes, bytes, len);
|
||||
objPtr->bytes[len] = '\0';
|
||||
objPtr->length = len;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
@@ -1365,14 +1388,14 @@ Tcl_ExprObj(
|
||||
Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression
|
||||
* result is stored if no errors occur. */
|
||||
{
|
||||
NRE_callback *rootPtr = TOP_CB(interp);
|
||||
Tcl_Obj *resultPtr;
|
||||
|
||||
TclNRSetRoot(interp);
|
||||
TclNewObj(resultPtr);
|
||||
TclNRAddCallback(interp, CopyCallback, resultPtrPtr, resultPtr,
|
||||
Tcl_NRAddCallback(interp, CopyCallback, resultPtrPtr, resultPtr,
|
||||
NULL, NULL);
|
||||
Tcl_NRExprObj(interp, objPtr, resultPtr);
|
||||
return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
|
||||
return TclNRRunCallbacks(interp, TCL_OK);
|
||||
}
|
||||
|
||||
static int
|
||||
@@ -1504,14 +1527,10 @@ CompileExprObj(
|
||||
}
|
||||
}
|
||||
if (objPtr->typePtr != &exprCodeType) {
|
||||
/*
|
||||
* TIP #280: No invoker (yet) - Expression compilation.
|
||||
*/
|
||||
|
||||
int length;
|
||||
const char *string = TclGetStringFromObj(objPtr, &length);
|
||||
|
||||
TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
|
||||
TclInitCompileEnv(interp, &compEnv, string, length);
|
||||
TclCompileExpr(interp, string, length, &compEnv, 0);
|
||||
|
||||
/*
|
||||
@@ -1635,9 +1654,7 @@ FreeExprCodeInternalRep(
|
||||
ByteCode *
|
||||
TclCompileObj(
|
||||
Tcl_Interp *interp,
|
||||
Tcl_Obj *objPtr,
|
||||
const CmdFrame *invoker,
|
||||
int word)
|
||||
Tcl_Obj *objPtr)
|
||||
{
|
||||
register Interp *iPtr = (Interp *) interp;
|
||||
register ByteCode *codePtr; /* Tcl Internal type of bytecode. */
|
||||
@@ -1692,109 +1709,13 @@ TclCompileObj(
|
||||
goto recompileObj;
|
||||
}
|
||||
|
||||
/*
|
||||
* #280.
|
||||
* Literal sharing fix. This part of the fix is not required by 8.4
|
||||
* nor 8.5, because they eval-direct any literals, so just saving the
|
||||
* argument locations per command in bytecode is enough, embedded
|
||||
* 'eval' commands, etc. get the correct information.
|
||||
*
|
||||
* But in 8.6 all the embedded script are compiled, and the resulting
|
||||
* bytecode stored in the literal. Now the shared literal has bytecode
|
||||
* with location data for _one_ particular location this literal is
|
||||
* found at. If we get executed from a different location the bytecode
|
||||
* has to be recompiled to get the correct locations. Not doing this
|
||||
* will execute the saved bytecode with data for a different location,
|
||||
* causing 'info frame' to point to the wrong place in the sources.
|
||||
*
|
||||
* Future optimizations ...
|
||||
* (1) Save the location data (ExtCmdLoc) keyed by start line. In that
|
||||
* case we recompile once per location of the literal, but not
|
||||
* continously, because the moment we have all locations we do not
|
||||
* need to recompile any longer.
|
||||
*
|
||||
* (2) Alternative: Do not recompile, tell the execution engine the
|
||||
* offset between saved starting line and actual one. Then modify
|
||||
* the users to adjust the locations they have by this offset.
|
||||
*
|
||||
* (3) Alternative 2: Do not fully recompile, adjust just the location
|
||||
* information.
|
||||
*/
|
||||
|
||||
if (invoker == NULL) {
|
||||
return codePtr;
|
||||
} else {
|
||||
Tcl_HashEntry *hePtr =
|
||||
Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
|
||||
ExtCmdLoc *eclPtr;
|
||||
CmdFrame *ctxCopyPtr;
|
||||
int redo;
|
||||
|
||||
if (!hePtr) {
|
||||
return codePtr;
|
||||
}
|
||||
|
||||
eclPtr = Tcl_GetHashValue(hePtr);
|
||||
redo = 0;
|
||||
ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame));
|
||||
*ctxCopyPtr = *invoker;
|
||||
|
||||
if (invoker->type == TCL_LOCATION_BC) {
|
||||
/*
|
||||
* Note: Type BC => ctx.data.eval.path is not used.
|
||||
* ctx.data.tebc.codePtr used instead
|
||||
*/
|
||||
|
||||
TclGetSrcInfoForPc(ctxCopyPtr);
|
||||
if (ctxCopyPtr->type == TCL_LOCATION_SOURCE) {
|
||||
/*
|
||||
* The reference made by 'TclGetSrcInfoForPc' is dead.
|
||||
*/
|
||||
|
||||
Tcl_DecrRefCount(ctxCopyPtr->data.eval.path);
|
||||
ctxCopyPtr->data.eval.path = NULL;
|
||||
}
|
||||
}
|
||||
|
||||
if (word < ctxCopyPtr->nline) {
|
||||
/*
|
||||
* Note: We do not care if the line[word] is -1. This is a
|
||||
* difference and requires a recompile (location changed from
|
||||
* absolute to relative, literal is used fixed and through
|
||||
* variable)
|
||||
*
|
||||
* Example:
|
||||
* test info-32.0 using literal of info-24.8
|
||||
* (dict with ... vs set body ...).
|
||||
*/
|
||||
|
||||
redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
|
||||
&& (eclPtr->start != ctxCopyPtr->line[word]))
|
||||
|| ((eclPtr->type == TCL_LOCATION_BC)
|
||||
&& (ctxCopyPtr->type == TCL_LOCATION_SOURCE));
|
||||
}
|
||||
|
||||
TclStackFree(interp, ctxCopyPtr);
|
||||
if (!redo) {
|
||||
return codePtr;
|
||||
}
|
||||
}
|
||||
return codePtr;
|
||||
}
|
||||
|
||||
recompileObj:
|
||||
iPtr->errorLine = 1;
|
||||
|
||||
/*
|
||||
* TIP #280. Remember the invoker for a moment in the interpreter
|
||||
* structures so that the byte code compiler can pick it up when
|
||||
* initializing the compilation environment, i.e. the extended location
|
||||
* information.
|
||||
*/
|
||||
|
||||
iPtr->invokeCmdFramePtr = invoker;
|
||||
iPtr->invokeWord = word;
|
||||
TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
|
||||
iPtr->invokeCmdFramePtr = NULL;
|
||||
codePtr = objPtr->internalRep.otherValuePtr;
|
||||
if (iPtr->varFramePtr->localCachePtr) {
|
||||
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
|
||||
@@ -1947,7 +1868,6 @@ TclIncrObj(
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
#define bcFramePtr (&TD->cmdFrame)
|
||||
#define initCatchTop ((ptrdiff_t *) (&TD->stack[-1]))
|
||||
#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
|
||||
#define esPtr (iPtr->execEnvPtr->execStackPtr)
|
||||
@@ -1974,7 +1894,7 @@ TclNRExecuteByteCode(
|
||||
* Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame
|
||||
*
|
||||
* The execution uses a unified stack: first a TEBCdata, immediately
|
||||
* above it a CmdFrame, then the catch stack, then the execution stack.
|
||||
* above it the catch stack, then the execution stack.
|
||||
*
|
||||
* Make sure the catch stack is large enough to hold the maximum number of
|
||||
* catch commands that could ever be executing at the same time (this will
|
||||
@@ -1992,25 +1912,6 @@ TclNRExecuteByteCode(
|
||||
TD->auxObjList = NULL;
|
||||
TD->checkInterp = 0;
|
||||
|
||||
/*
|
||||
* TIP #280: Initialize the frame. Do not push it yet: it will be pushed
|
||||
* every time that we call out from this TD, popped when we return to it.
|
||||
*/
|
||||
|
||||
bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
|
||||
? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
|
||||
bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
|
||||
bcFramePtr->numLevels = iPtr->numLevels;
|
||||
bcFramePtr->framePtr = iPtr->framePtr;
|
||||
bcFramePtr->nextPtr = iPtr->cmdFramePtr;
|
||||
bcFramePtr->nline = 0;
|
||||
bcFramePtr->line = NULL;
|
||||
bcFramePtr->litarg = NULL;
|
||||
bcFramePtr->data.tebc.codePtr = codePtr;
|
||||
bcFramePtr->data.tebc.pc = NULL;
|
||||
bcFramePtr->cmd.str.cmd = NULL;
|
||||
bcFramePtr->cmd.str.len = 0;
|
||||
|
||||
#ifdef TCL_COMPILE_STATS
|
||||
iPtr->stats.numExecutions++;
|
||||
#endif
|
||||
@@ -2019,7 +1920,7 @@ TclNRExecuteByteCode(
|
||||
* Push the callback for bytecode execution
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0),
|
||||
Tcl_NRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0),
|
||||
NULL, NULL);
|
||||
return TCL_OK;
|
||||
}
|
||||
@@ -2116,7 +2017,6 @@ TEBCresume(
|
||||
int starting = 1;
|
||||
traceInstructions = (tclTraceExec == 3);
|
||||
#endif
|
||||
|
||||
TEBC_DATA_DIG();
|
||||
|
||||
#ifdef TCL_COMPILE_DEBUG
|
||||
@@ -2131,11 +2031,6 @@ TEBCresume(
|
||||
if (iPtr->execEnvPtr->rewind) {
|
||||
result = TCL_ERROR;
|
||||
}
|
||||
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
|
||||
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
|
||||
if (iPtr->flags & INTERP_DEBUG_FRAME) {
|
||||
TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
|
||||
}
|
||||
if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
|
||||
iPtr->flags |= ERR_ALREADY_LOGGED;
|
||||
codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
|
||||
@@ -2400,24 +2295,13 @@ TEBCresume(
|
||||
fprintf(stdout, "\n");
|
||||
}
|
||||
#endif
|
||||
/* TIP #280: Record the last piece of info needed by
|
||||
* 'TclGetSrcInfoForPc', and push the frame.
|
||||
*/
|
||||
|
||||
bcFramePtr->data.tebc.pc = (char *) pc;
|
||||
iPtr->cmdFramePtr = bcFramePtr;
|
||||
|
||||
if (iPtr->flags & INTERP_DEBUG_FRAME) {
|
||||
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
|
||||
codePtr, bcFramePtr, pc - codePtr->codeStart);
|
||||
}
|
||||
|
||||
pc++;
|
||||
cleanup = 1;
|
||||
TEBC_YIELD();
|
||||
|
||||
Tcl_SetObjResult(interp, OBJ_AT_TOS);
|
||||
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
|
||||
Tcl_NRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
|
||||
INT2PTR(0), NULL, NULL);
|
||||
|
||||
return TCL_OK;
|
||||
@@ -2758,8 +2642,6 @@ TEBCresume(
|
||||
case INST_EXPR_STK: {
|
||||
ByteCode *newCodePtr;
|
||||
|
||||
bcFramePtr->data.tebc.pc = (char *) pc;
|
||||
iPtr->cmdFramePtr = bcFramePtr;
|
||||
DECACHE_STACK_INFO();
|
||||
newCodePtr = CompileExprObj(interp, OBJ_AT_TOS);
|
||||
CACHE_STACK_INFO();
|
||||
@@ -2775,13 +2657,10 @@ TEBCresume(
|
||||
|
||||
instEvalStk:
|
||||
case INST_EVAL_STK:
|
||||
bcFramePtr->data.tebc.pc = (char *) pc;
|
||||
iPtr->cmdFramePtr = bcFramePtr;
|
||||
|
||||
cleanup = 1;
|
||||
pc += 1;
|
||||
TEBC_YIELD();
|
||||
return TclNREvalObjEx(interp, OBJ_AT_TOS, 0, NULL, 0);
|
||||
return TclNREvalObjEx(interp, OBJ_AT_TOS, 0);
|
||||
|
||||
case INST_INVOKE_EXPANDED:
|
||||
CLANG_ASSERT(auxObjList);
|
||||
@@ -2834,21 +2713,15 @@ TEBCresume(
|
||||
|
||||
/*
|
||||
* Finally, let TclEvalObjv handle the command.
|
||||
*
|
||||
* TIP #280: Record the last piece of info needed by
|
||||
* 'TclGetSrcInfoForPc', and push the frame.
|
||||
*/
|
||||
|
||||
bcFramePtr->data.tebc.pc = (char *) pc;
|
||||
iPtr->cmdFramePtr = bcFramePtr;
|
||||
|
||||
if (iPtr->flags & INTERP_DEBUG_FRAME) {
|
||||
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
|
||||
codePtr, bcFramePtr, pc - codePtr->codeStart);
|
||||
if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
|
||||
Tcl_Obj *srcPtr = iPtr->cmdSourcePtr;
|
||||
srcPtr->typePtr = &bcSourceType;
|
||||
srcPtr->internalRep.twoPtrValue.ptr1 = (unsigned char *) pc;
|
||||
srcPtr->internalRep.twoPtrValue.ptr2 = codePtr;
|
||||
}
|
||||
|
||||
DECACHE_STACK_INFO();
|
||||
|
||||
pc += pcAdjustment;
|
||||
TEBC_YIELD();
|
||||
return TclNREvalObjv(interp, objc, objv,
|
||||
@@ -2986,12 +2859,6 @@ TEBCresume(
|
||||
}
|
||||
objPtr = copyPtr;
|
||||
}
|
||||
bcFramePtr->data.tebc.pc = (char *) pc;
|
||||
iPtr->cmdFramePtr = bcFramePtr;
|
||||
if (iPtr->flags & INTERP_DEBUG_FRAME) {
|
||||
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
|
||||
codePtr, bcFramePtr, pc - codePtr->codeStart);
|
||||
}
|
||||
iPtr->ensembleRewrite.sourceObjs = objv;
|
||||
iPtr->ensembleRewrite.numRemovedObjs = opnd;
|
||||
iPtr->ensembleRewrite.numInsertedObjs = 1;
|
||||
@@ -2999,9 +2866,9 @@ TEBCresume(
|
||||
pc += 6;
|
||||
TEBC_YIELD();
|
||||
|
||||
TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
|
||||
Tcl_NRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
|
||||
TclSkipTailcall(interp);
|
||||
return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);
|
||||
return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE);
|
||||
|
||||
/*
|
||||
* -----------------------------------------------------------------
|
||||
@@ -6903,8 +6770,8 @@ TEBCresume(
|
||||
|
||||
bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg);
|
||||
DECACHE_STACK_INFO();
|
||||
TclLogCommandInfo(interp, codePtr->source, bytes,
|
||||
bytes ? length : 0, pcBeg, tosPtr);
|
||||
Tcl_LogCommandInfo(interp, codePtr->source, bytes,
|
||||
bytes ? length : 0);
|
||||
CACHE_STACK_INFO();
|
||||
}
|
||||
iPtr->flags &= ~ERR_ALREADY_LOGGED;
|
||||
@@ -7043,10 +6910,8 @@ TEBCresume(
|
||||
(unsigned) CURR_DEPTH, (unsigned) 0);
|
||||
Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top");
|
||||
}
|
||||
CLANG_ASSERT(bcFramePtr);
|
||||
}
|
||||
|
||||
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
|
||||
if (--codePtr->refCount <= 0) {
|
||||
TclCleanupByteCode(codePtr);
|
||||
}
|
||||
@@ -7094,8 +6959,6 @@ TEBCresume(
|
||||
|
||||
#undef codePtr
|
||||
#undef iPtr
|
||||
#undef bcFramePtr
|
||||
#undef initCatchTop
|
||||
#undef initTosPtr
|
||||
#undef auxObjList
|
||||
#undef catchTop
|
||||
@@ -8682,76 +8545,6 @@ IllegalExprOperandType(
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
const char *
|
||||
TclGetSrcInfoForCmd(
|
||||
Interp *iPtr,
|
||||
int *lenPtr)
|
||||
{
|
||||
CmdFrame *cfPtr = iPtr->cmdFramePtr;
|
||||
ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
|
||||
|
||||
return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc,
|
||||
codePtr, lenPtr, NULL);
|
||||
}
|
||||
|
||||
void
|
||||
TclGetSrcInfoForPc(
|
||||
CmdFrame *cfPtr)
|
||||
{
|
||||
ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
|
||||
|
||||
if (cfPtr->cmd.str.cmd == NULL) {
|
||||
cfPtr->cmd.str.cmd = GetSrcInfoForPc(
|
||||
(unsigned char *) cfPtr->data.tebc.pc, codePtr,
|
||||
&cfPtr->cmd.str.len, NULL);
|
||||
}
|
||||
|
||||
if (cfPtr->cmd.str.cmd != NULL) {
|
||||
/*
|
||||
* We now have the command. We can get the srcOffset back and from
|
||||
* there find the list of word locations for this command.
|
||||
*/
|
||||
|
||||
ExtCmdLoc *eclPtr;
|
||||
ECL *locPtr = NULL;
|
||||
int srcOffset, i;
|
||||
Interp *iPtr = (Interp *) *codePtr->interpHandle;
|
||||
Tcl_HashEntry *hePtr =
|
||||
Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
|
||||
|
||||
if (!hePtr) {
|
||||
return;
|
||||
}
|
||||
|
||||
srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
|
||||
eclPtr = Tcl_GetHashValue(hePtr);
|
||||
|
||||
for (i=0; i < eclPtr->nuloc; i++) {
|
||||
if (eclPtr->loc[i].srcOffset == srcOffset) {
|
||||
locPtr = eclPtr->loc+i;
|
||||
break;
|
||||
}
|
||||
}
|
||||
if (locPtr == NULL) {
|
||||
Tcl_Panic("LocSearch failure");
|
||||
}
|
||||
|
||||
cfPtr->line = locPtr->line;
|
||||
cfPtr->nline = locPtr->nline;
|
||||
cfPtr->type = eclPtr->type;
|
||||
|
||||
if (eclPtr->type == TCL_LOCATION_SOURCE) {
|
||||
cfPtr->data.eval.path = eclPtr->path;
|
||||
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
||||
}
|
||||
|
||||
/*
|
||||
* Do not set cfPtr->data.eval.path NULL for non-SOURCE. Needed for
|
||||
* cfPtr->data.tebc.codePtr.
|
||||
*/
|
||||
}
|
||||
}
|
||||
|
||||
static const char *
|
||||
GetSrcInfoForPc(
|
||||
const unsigned char *pc, /* The program counter value for which to
|
||||
|
||||
+3
-11
@@ -1802,12 +1802,8 @@ Tcl_FSEvalFileEx(
|
||||
Tcl_IncrRefCount(iPtr->scriptFile);
|
||||
string = Tcl_GetStringFromObj(objPtr, &length);
|
||||
|
||||
/*
|
||||
* TIP #280 Force the evaluator to open a frame for a sourced file.
|
||||
*/
|
||||
|
||||
iPtr->evalFlags |= TCL_EVAL_FILE;
|
||||
result = TclEvalEx(interp, string, length, 0, 1, NULL, string);
|
||||
result = Tcl_EvalEx(interp, string, length, 0);
|
||||
|
||||
/*
|
||||
* Now we have to be careful; the script may have changed the
|
||||
@@ -1938,14 +1934,10 @@ TclNREvalFile(
|
||||
iPtr->scriptFile = pathPtr;
|
||||
Tcl_IncrRefCount(iPtr->scriptFile);
|
||||
|
||||
/*
|
||||
* TIP #280: Force the evaluator to open a frame for a sourced file.
|
||||
*/
|
||||
|
||||
iPtr->evalFlags |= TCL_EVAL_FILE;
|
||||
TclNRAddCallback(interp, EvalFileCallback, oldScriptFile, pathPtr, objPtr,
|
||||
Tcl_NRAddCallback(interp, EvalFileCallback, oldScriptFile, pathPtr, objPtr,
|
||||
NULL);
|
||||
return TclNREvalObjEx(interp, objPtr, 0, NULL, INT_MIN);
|
||||
return TclNREvalObjEx(interp, objPtr, 0);
|
||||
}
|
||||
|
||||
static int
|
||||
|
||||
+13
-15
@@ -565,10 +565,10 @@ declare 138 {
|
||||
declare 141 {
|
||||
CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
|
||||
}
|
||||
declare 142 {
|
||||
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
|
||||
CompileHookProc *hookProc, ClientData clientData)
|
||||
}
|
||||
#declare 142 {
|
||||
# int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
|
||||
# CompileHookProc *hookProc, ClientData clientData)
|
||||
#}
|
||||
declare 143 {
|
||||
int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
|
||||
LiteralEntry **litPtrPtr)
|
||||
@@ -922,13 +922,13 @@ declare 231 {
|
||||
}
|
||||
|
||||
# Bits and pieces of TIP#280's guts
|
||||
declare 232 {
|
||||
int TclEvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags,
|
||||
const CmdFrame *invoker, int word)
|
||||
}
|
||||
declare 233 {
|
||||
void TclGetSrcInfoForPc(CmdFrame *contextPtr)
|
||||
}
|
||||
#declare 232 {
|
||||
# int TclEvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags,
|
||||
# const CmdFrame *invoker, int word)
|
||||
#}
|
||||
#declare 233 {
|
||||
# void TclGetSrcInfoForPc(CmdFrame *contextPtr)
|
||||
#}
|
||||
|
||||
# Exports for VarReform compat: Itcl, XOTcl like to peek into our varTables :(
|
||||
declare 234 {
|
||||
@@ -961,12 +961,10 @@ declare 239 {
|
||||
int skip, ProcErrorProc *errorProc)
|
||||
}
|
||||
declare 240 {
|
||||
int TclNRRunCallbacks(Tcl_Interp *interp, int result,
|
||||
struct NRE_callback *rootPtr)
|
||||
int TclNRRunCallbacks(Tcl_Interp *interp, int result)
|
||||
}
|
||||
declare 241 {
|
||||
int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags,
|
||||
const CmdFrame *invoker, int word)
|
||||
int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
|
||||
}
|
||||
declare 242 {
|
||||
int TclNREvalObjv(Tcl_Interp *interp, int objc,
|
||||
|
||||
+86
-450
@@ -19,6 +19,8 @@
|
||||
#ifndef _TCLINT
|
||||
#define _TCLINT
|
||||
|
||||
#include "tclInt.h"
|
||||
|
||||
/*
|
||||
* Some numerics configuration options.
|
||||
*/
|
||||
@@ -1169,192 +1171,6 @@ typedef struct CallFrame {
|
||||
* been confirmed to refer to a class. Part of
|
||||
* TIP#257. */
|
||||
|
||||
/*
|
||||
* TIP #280
|
||||
* The structure below defines a command frame. A command frame provides
|
||||
* location information for all commands executing a tcl script (source, eval,
|
||||
* uplevel, procedure bodies, ...). The runtime structure essentially contains
|
||||
* the stack trace as it would be if the currently executing command were to
|
||||
* throw an error.
|
||||
*
|
||||
* For commands where it makes sense it refers to the associated CallFrame as
|
||||
* well.
|
||||
*
|
||||
* The structures are chained in a single list, with the top of the stack
|
||||
* anchored in the Interp structure.
|
||||
*
|
||||
* Instances can be allocated on the C stack, or the heap, the former making
|
||||
* cleanup a bit simpler.
|
||||
*/
|
||||
|
||||
typedef struct CmdFrame {
|
||||
/*
|
||||
* General data. Always available.
|
||||
*/
|
||||
|
||||
int type; /* Values see below. */
|
||||
int level; /* Number of frames in stack, prevent O(n)
|
||||
* scan of list. */
|
||||
int *line; /* Lines the words of the command start on. */
|
||||
int nline;
|
||||
CallFrame *framePtr; /* Procedure activation record, may be
|
||||
* NULL. */
|
||||
struct CmdFrame *nextPtr; /* Link to calling frame. */
|
||||
/*
|
||||
* Data needed for Eval vs TEBC
|
||||
*
|
||||
* EXECUTION CONTEXTS and usage of CmdFrame
|
||||
*
|
||||
* Field TEBC EvalEx EvalObjEx
|
||||
* ======= ==== ====== =========
|
||||
* level yes yes yes
|
||||
* type BC/PREBC SRC/EVAL EVAL_LIST
|
||||
* line0 yes yes yes
|
||||
* framePtr yes yes yes
|
||||
* ======= ==== ====== =========
|
||||
*
|
||||
* ======= ==== ====== ========= union data
|
||||
* line1 - yes -
|
||||
* line3 - yes -
|
||||
* path - yes -
|
||||
* ------- ---- ------ ---------
|
||||
* codePtr yes - -
|
||||
* pc yes - -
|
||||
* ======= ==== ====== =========
|
||||
*
|
||||
* ======= ==== ====== ========= | union cmd
|
||||
* listPtr - - yes |
|
||||
* ------- ---- ------ --------- |
|
||||
* cmd yes yes - |
|
||||
* cmdlen yes yes - |
|
||||
* ------- ---- ------ --------- |
|
||||
*/
|
||||
|
||||
union {
|
||||
struct {
|
||||
Tcl_Obj *path; /* Path of the sourced file the command is
|
||||
* in. */
|
||||
} eval;
|
||||
struct {
|
||||
const void *codePtr;/* Byte code currently executed... */
|
||||
const char *pc; /* ... and instruction pointer. */
|
||||
} tebc;
|
||||
} data;
|
||||
union {
|
||||
struct {
|
||||
const char *cmd; /* The executed command, if possible... */
|
||||
int len; /* ... and its length. */
|
||||
} str;
|
||||
Tcl_Obj *listPtr; /* Tcl_EvalObjEx, cmd list. */
|
||||
} cmd;
|
||||
int numLevels; /* Value of interp's numLevels when the frame
|
||||
* was pushed. */
|
||||
const struct CFWordBC *litarg;
|
||||
/* Link to set of literal arguments which have
|
||||
* ben pushed on the lineLABCPtr stack by
|
||||
* TclArgumentBCEnter(). These will be removed
|
||||
* by TclArgumentBCRelease. */
|
||||
} CmdFrame;
|
||||
|
||||
typedef struct CFWord {
|
||||
CmdFrame *framePtr; /* CmdFrame to access. */
|
||||
int word; /* Index of the word in the command. */
|
||||
int refCount; /* Number of times the word is on the
|
||||
* stack. */
|
||||
} CFWord;
|
||||
|
||||
typedef struct CFWordBC {
|
||||
CmdFrame *framePtr; /* CmdFrame to access. */
|
||||
int pc; /* Instruction pointer of a command in
|
||||
* ExtCmdLoc.loc[.] */
|
||||
int word; /* Index of word in
|
||||
* ExtCmdLoc.loc[cmd]->line[.] */
|
||||
struct CFWordBC *prevPtr; /* Previous entry in stack for same Tcl_Obj. */
|
||||
struct CFWordBC *nextPtr; /* Next entry for same command call. See
|
||||
* CmdFrame litarg field for the list start. */
|
||||
Tcl_Obj *obj; /* Back reference to hashtable key */
|
||||
} CFWordBC;
|
||||
|
||||
/*
|
||||
* Structure to record the locations of invisible continuation lines in
|
||||
* literal scripts, as character offset from the beginning of the script. Both
|
||||
* compiler and direct evaluator use this information to adjust their line
|
||||
* counters when tracking through the script, because when it is invoked the
|
||||
* continuation line marker as a whole has been removed already, meaning that
|
||||
* the \n which was part of it is gone as well, breaking regular line
|
||||
* tracking.
|
||||
*
|
||||
* These structures are allocated and filled by both the function
|
||||
* TclSubstTokens() in the file "tclParse.c" and its caller TclEvalEx() in the
|
||||
* file "tclBasic.c", and stored in the thread-global hashtable "lineCLPtr" in
|
||||
* file "tclObj.c". They are used by the functions TclSetByteCodeFromAny() and
|
||||
* TclCompileScript(), both found in the file "tclCompile.c". Their memory is
|
||||
* released by the function TclFreeObj(), in the file "tclObj.c", and also by
|
||||
* the function TclThreadFinalizeObjects(), in the same file.
|
||||
*/
|
||||
|
||||
#define CLL_END (-1)
|
||||
|
||||
typedef struct ContLineLoc {
|
||||
int num; /* Number of entries in loc, not counting the
|
||||
* final -1 marker entry. */
|
||||
int loc[1]; /* Table of locations, as character offsets.
|
||||
* The table is allocated as part of the
|
||||
* structure, extending behind the nominal end
|
||||
* of the structure. An entry containing the
|
||||
* value -1 is put after the last location, as
|
||||
* end-marker/sentinel. */
|
||||
} ContLineLoc;
|
||||
|
||||
/*
|
||||
* The following macros define the allowed values for the type field of the
|
||||
* CmdFrame structure above. Some of the values occur only in the extended
|
||||
* location data referenced via the 'baseLocPtr'.
|
||||
*
|
||||
* TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx.
|
||||
* TCL_LOCATION_EVAL_LIST : Frame is for a script evaluated by the list
|
||||
* optimization path of EvalObjEx.
|
||||
* TCL_LOCATION_BC : Frame is for bytecode.
|
||||
* TCL_LOCATION_PREBC : Frame is for precompiled bytecode.
|
||||
* TCL_LOCATION_SOURCE : Frame is for a script evaluated by EvalEx, from a
|
||||
* sourced file.
|
||||
* TCL_LOCATION_PROC : Frame is for bytecode of a procedure.
|
||||
*
|
||||
* A TCL_LOCATION_BC type in a frame can be overridden by _SOURCE and _PROC
|
||||
* types, per the context of the byte code in execution.
|
||||
*/
|
||||
|
||||
#define TCL_LOCATION_EVAL (0) /* Location in a dynamic eval script. */
|
||||
#define TCL_LOCATION_EVAL_LIST (1) /* Location in a dynamic eval script,
|
||||
* list-path. */
|
||||
#define TCL_LOCATION_BC (2) /* Location in byte code. */
|
||||
#define TCL_LOCATION_PREBC (3) /* Location in precompiled byte code, no
|
||||
* location. */
|
||||
#define TCL_LOCATION_SOURCE (4) /* Location in a file. */
|
||||
#define TCL_LOCATION_PROC (5) /* Location in a dynamic proc. */
|
||||
#define TCL_LOCATION_LAST (6) /* Number of values in the enum. */
|
||||
|
||||
/*
|
||||
* Structure passed to describe procedure-like "procedures" that are not
|
||||
* procedures (e.g. a lambda) so that their details can be reported correctly
|
||||
* by [info frame]. Contains a sub-structure for each extra field.
|
||||
*/
|
||||
|
||||
typedef Tcl_Obj * (GetFrameInfoValueProc)(ClientData clientData);
|
||||
typedef struct {
|
||||
const char *name; /* Name of this field. */
|
||||
GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the
|
||||
* clientData, or just use the clientData
|
||||
* directly (after casting) if NULL. */
|
||||
ClientData clientData; /* Context for above function, or Tcl_Obj* if
|
||||
* proc field is NULL. */
|
||||
} ExtraFrameInfoField;
|
||||
typedef struct {
|
||||
int length; /* Length of array. */
|
||||
ExtraFrameInfoField fields[2];
|
||||
/* Really as long as necessary, but this is
|
||||
* long enough for nearly anything. */
|
||||
} ExtraFrameInfo;
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------
|
||||
@@ -1393,80 +1209,9 @@ MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr,
|
||||
#define TCL_TSD_INIT(keyPtr) \
|
||||
(ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------
|
||||
* Data structures related to bytecode compilation and execution. These are
|
||||
* used primarily in tclCompile.c, tclExecute.c, and tclBasic.c.
|
||||
*----------------------------------------------------------------
|
||||
*/
|
||||
|
||||
/*
|
||||
* Forward declaration to prevent errors when the forward references to
|
||||
* Tcl_Parse and CompileEnv are encountered in the procedure type CompileProc
|
||||
* declared below.
|
||||
*/
|
||||
|
||||
struct CompileEnv;
|
||||
|
||||
/*
|
||||
* The type of procedures called by the Tcl bytecode compiler to compile
|
||||
* commands. Pointers to these procedures are kept in the Command structure
|
||||
* describing each command. The integer value returned by a CompileProc must
|
||||
* be one of the following:
|
||||
*
|
||||
* TCL_OK Compilation completed normally.
|
||||
* TCL_ERROR Compilation could not be completed. This can be just a
|
||||
* judgment by the CompileProc that the command is too
|
||||
* complex to compile effectively, or it can indicate
|
||||
* that in the current state of the interp, the command
|
||||
* would raise an error. The bytecode compiler will not
|
||||
* do any error reporting at compiler time. Error
|
||||
* reporting is deferred until the actual runtime,
|
||||
* because by then changes in the interp state may allow
|
||||
* the command to be successfully evaluated.
|
||||
* TCL_OUT_LINE_COMPILE A source-compatible alias for TCL_ERROR, kept for the
|
||||
* sake of old code only.
|
||||
*/
|
||||
|
||||
#define TCL_OUT_LINE_COMPILE TCL_ERROR
|
||||
|
||||
typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr,
|
||||
struct Command *cmdPtr, struct CompileEnv *compEnvPtr);
|
||||
|
||||
/*
|
||||
* The type of procedure called from the compilation hook point in
|
||||
* SetByteCodeFromAny.
|
||||
*/
|
||||
|
||||
typedef int (CompileHookProc)(Tcl_Interp *interp,
|
||||
struct CompileEnv *compEnvPtr, ClientData clientData);
|
||||
|
||||
/*
|
||||
* The data structure for a (linked list of) execution stacks.
|
||||
*/
|
||||
|
||||
typedef struct ExecStack {
|
||||
struct ExecStack *prevPtr;
|
||||
struct ExecStack *nextPtr;
|
||||
Tcl_Obj **markerPtr;
|
||||
Tcl_Obj **endPtr;
|
||||
Tcl_Obj **tosPtr;
|
||||
Tcl_Obj *stackWords[1];
|
||||
} ExecStack;
|
||||
|
||||
/*
|
||||
* The data structure defining the execution environment for ByteCode's.
|
||||
* There is one ExecEnv structure per Tcl interpreter. It holds the evaluation
|
||||
* stack that holds command operands and results. The stack grows towards
|
||||
* increasing addresses. The member stackPtr points to the stackItems of the
|
||||
* currently active execution stack.
|
||||
*/
|
||||
|
||||
typedef struct CorContext {
|
||||
struct CallFrame *framePtr;
|
||||
struct CallFrame *varFramePtr;
|
||||
struct CmdFrame *cmdFramePtr; /* See Interp.cmdFramePtr */
|
||||
Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */
|
||||
} CorContext;
|
||||
|
||||
typedef struct CoroutineData {
|
||||
@@ -1479,7 +1224,6 @@ typedef struct CoroutineData {
|
||||
* coroutine. */
|
||||
CorContext caller;
|
||||
CorContext running;
|
||||
Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */
|
||||
void *stackLevel;
|
||||
int auxNumLevels; /* While the coroutine is running the
|
||||
* numLevels of the create/resume command is
|
||||
@@ -1490,20 +1234,28 @@ typedef struct CoroutineData {
|
||||
* means "any" */
|
||||
} CoroutineData;
|
||||
|
||||
#define COR_IS_SUSPENDED(corPtr) \
|
||||
((corPtr)->stackLevel == NULL)
|
||||
|
||||
/*
|
||||
* The data structure defining the execution environment for ByteCode's.
|
||||
* There is one ExecEnv structure per Tcl interpreter. It holds the evaluation
|
||||
* stack that holds command operands and results. The stack grows towards
|
||||
* increasing addresses. The member stackPtr points to the stackItems of the
|
||||
* currently active execution stack.
|
||||
*/
|
||||
|
||||
typedef struct ExecEnv {
|
||||
ExecStack *execStackPtr; /* Points to the first item in the evaluation
|
||||
* stack on the heap. */
|
||||
Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */
|
||||
struct Tcl_Interp *interp;
|
||||
struct NRE_callback *callbackPtr;
|
||||
/* Top callback in NRE's stack. */
|
||||
struct CoroutineData *corPtr;
|
||||
int rewind;
|
||||
Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */
|
||||
struct ExecStack *execStackPtr; /* Points to the first item in the evaluation
|
||||
* stack on the heap. */
|
||||
} ExecEnv;
|
||||
|
||||
#define COR_IS_SUSPENDED(corPtr) \
|
||||
((corPtr)->stackLevel == NULL)
|
||||
|
||||
/*
|
||||
* The definitions for the LiteralTable and LiteralEntry structures. Each
|
||||
* interpreter contains a LiteralTable. It is used to reduce the storage
|
||||
@@ -1553,49 +1305,14 @@ typedef struct LiteralTable {
|
||||
int mask; /* Mask value used in hashing function. */
|
||||
} LiteralTable;
|
||||
|
||||
/*
|
||||
* The following structure defines for each Tcl interpreter various
|
||||
* statistics-related information about the bytecode compiler and
|
||||
* interpreter's operation in that interpreter.
|
||||
*/
|
||||
|
||||
#ifdef TCL_COMPILE_STATS
|
||||
typedef struct ByteCodeStats {
|
||||
long numExecutions; /* Number of ByteCodes executed. */
|
||||
long numCompilations; /* Number of ByteCodes created. */
|
||||
long numByteCodesFreed; /* Number of ByteCodes destroyed. */
|
||||
long instructionCount[256]; /* Number of times each instruction was
|
||||
* executed. */
|
||||
|
||||
double totalSrcBytes; /* Total source bytes ever compiled. */
|
||||
double totalByteCodeBytes; /* Total bytes for all ByteCodes. */
|
||||
double currentSrcBytes; /* Src bytes for all current ByteCodes. */
|
||||
double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */
|
||||
|
||||
long srcCount[32]; /* Source size distribution: # of srcs of
|
||||
* size [2**(n-1)..2**n), n in [0..32). */
|
||||
long byteCodeCount[32]; /* ByteCode size distribution. */
|
||||
long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */
|
||||
|
||||
double currentInstBytes; /* Instruction bytes-current ByteCodes. */
|
||||
double currentLitBytes; /* Current literal bytes. */
|
||||
double currentExceptBytes; /* Current exception table bytes. */
|
||||
double currentAuxBytes; /* Current auxiliary information bytes. */
|
||||
double currentCmdMapBytes; /* Current src<->code map bytes. */
|
||||
|
||||
long numLiteralsCreated; /* Total literal objects ever compiled. */
|
||||
double totalLitStringBytes; /* Total string bytes in all literals. */
|
||||
double currentLitStringBytes;
|
||||
/* String bytes in current literals. */
|
||||
long literalCount[32]; /* Distribution of literal string sizes. */
|
||||
} ByteCodeStats;
|
||||
#endif /* TCL_COMPILE_STATS */
|
||||
|
||||
/*
|
||||
* Structure used in implementation of those core ensembles which are
|
||||
* partially compiled. Used as an array of these, with a terminating field
|
||||
* whose 'name' is NULL.
|
||||
*/
|
||||
struct CompileEnv;
|
||||
typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr,
|
||||
struct Command *cmdPtr, struct CompileEnv *compEnvPtr);
|
||||
|
||||
typedef struct {
|
||||
const char *name; /* The name of the subcommand. */
|
||||
@@ -2046,54 +1763,6 @@ typedef struct Interp {
|
||||
* NULL), takes precedence over a POSIX error
|
||||
* code returned by a channel operation. */
|
||||
|
||||
/*
|
||||
* Source code origin information (TIP #280).
|
||||
*/
|
||||
|
||||
CmdFrame *cmdFramePtr; /* Points to the command frame containing the
|
||||
* location information for the current
|
||||
* command. */
|
||||
const CmdFrame *invokeCmdFramePtr;
|
||||
/* Points to the command frame which is the
|
||||
* invoking context of the bytecode compiler.
|
||||
* NULL when the byte code compiler is not
|
||||
* active. */
|
||||
int invokeWord; /* Index of the word in the command which
|
||||
* is getting compiled. */
|
||||
Tcl_HashTable *linePBodyPtr;/* This table remembers for each statically
|
||||
* defined procedure the location information
|
||||
* for its body. It is keyed by the address of
|
||||
* the Proc structure for a procedure. The
|
||||
* values are "struct CmdFrame*". */
|
||||
Tcl_HashTable *lineBCPtr; /* This table remembers for each ByteCode
|
||||
* object the location information for its
|
||||
* body. It is keyed by the address of the
|
||||
* Proc structure for a procedure. The values
|
||||
* are "struct ExtCmdLoc*". (See
|
||||
* tclCompile.h) */
|
||||
Tcl_HashTable *lineLABCPtr;
|
||||
Tcl_HashTable *lineLAPtr; /* This table remembers for each argument of a
|
||||
* command on the execution stack the index of
|
||||
* the argument in the command, and the
|
||||
* location data of the command. It is keyed
|
||||
* by the address of the Tcl_Obj containing
|
||||
* the argument. The values are "struct
|
||||
* CFWord*" (See tclBasic.c). This allows
|
||||
* commands like uplevel, eval, etc. to find
|
||||
* location information for their arguments,
|
||||
* if they are a proper literal argument to an
|
||||
* invoking command. Alt view: An index to the
|
||||
* CmdFrame stack keyed by command argument
|
||||
* holders. */
|
||||
ContLineLoc *scriptCLLocPtr;/* This table points to the location data for
|
||||
* invisible continuation lines in the script,
|
||||
* if any. This pointer is set by the function
|
||||
* TclEvalObjEx() in file "tclBasic.c", and
|
||||
* used by function ...() in the same file.
|
||||
* It does for the eval/direct path of script
|
||||
* execution what CompileEnv.clLoc does for
|
||||
* the bytecode compiler.
|
||||
*/
|
||||
/*
|
||||
* TIP #268. The currently active selection mode, i.e. the package require
|
||||
* preferences.
|
||||
@@ -2138,12 +1807,8 @@ typedef struct Interp {
|
||||
* and setup. */
|
||||
|
||||
struct NRE_callback *deferredCallbacks;
|
||||
/* Callbacks that are set previous to a call
|
||||
* to some Eval function but that actually
|
||||
* belong to the command that is about to be
|
||||
* called - i.e., they should be run *before*
|
||||
* any tailcall is invoked. */
|
||||
|
||||
/* First callback deferred for the next
|
||||
* call to EvalObjv */
|
||||
/*
|
||||
* TIP #285, Script cancellation support.
|
||||
*/
|
||||
@@ -2156,17 +1821,6 @@ typedef struct Interp {
|
||||
* (asyncCancelMsg not NULL), takes precedence
|
||||
* over the default error messages returned by
|
||||
* a script cancellation operation. */
|
||||
|
||||
/*
|
||||
* TIP #348 IMPLEMENTATION - Substituted error stack
|
||||
*/
|
||||
Tcl_Obj *errorStack; /* [info errorstack] value (as a Tcl_Obj). */
|
||||
Tcl_Obj *upLiteral; /* "UP" literal for [info errorstack] */
|
||||
Tcl_Obj *callLiteral; /* "CALL" literal for [info errorstack] */
|
||||
Tcl_Obj *innerLiteral; /* "INNER" literal for [info errorstack] */
|
||||
Tcl_Obj *innerContext; /* cached list for fast reallocation */
|
||||
int resetErrorStack; /* controls cleaning up of ::errorStack */
|
||||
|
||||
#ifdef TCL_COMPILE_STATS
|
||||
/*
|
||||
* Statistical information about the bytecode compiler and interpreter's
|
||||
@@ -2176,6 +1830,7 @@ typedef struct Interp {
|
||||
ByteCodeStats stats; /* Holds compilation and execution statistics
|
||||
* for this interpreter. */
|
||||
#endif /* TCL_COMPILE_STATS */
|
||||
Tcl_Obj *cmdSourcePtr; /* Command source obj, used for command traces */
|
||||
} Interp;
|
||||
|
||||
/*
|
||||
@@ -2811,7 +2466,7 @@ MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp);
|
||||
MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp);
|
||||
MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp);
|
||||
|
||||
/*
|
||||
/* //
|
||||
* This structure holds the data for the various iteration callbacks used to
|
||||
* NRE the 'for' and 'while' commands. We need a separate structure because we
|
||||
* have more than the 4 client data entries we can provide directly thorugh
|
||||
@@ -2826,7 +2481,6 @@ typedef struct ForIterData {
|
||||
Tcl_Obj *body; /* Loop body. */
|
||||
Tcl_Obj *next; /* Loop step script, NULL for 'while'. */
|
||||
const char *msg; /* Error message part. */
|
||||
int word; /* Index of the body script in the command */
|
||||
} ForIterData;
|
||||
|
||||
/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile
|
||||
@@ -2884,21 +2538,6 @@ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr,
|
||||
const unsigned char *bytes, int len);
|
||||
MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
|
||||
int flags);
|
||||
MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next,
|
||||
int loc);
|
||||
MODULE_SCOPE void TclAdvanceLines(int *line, const char *start,
|
||||
const char *end);
|
||||
MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp,
|
||||
Tcl_Obj *objv[], int objc, CmdFrame *cf);
|
||||
MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp,
|
||||
Tcl_Obj *objv[], int objc);
|
||||
MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp,
|
||||
Tcl_Obj *objv[], int objc,
|
||||
void *codePtr, CmdFrame *cfPtr, int pc);
|
||||
MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp,
|
||||
CmdFrame *cfPtr);
|
||||
MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
|
||||
CmdFrame **cfPtrPtr, int *wordPtr);
|
||||
MODULE_SCOPE int TclArraySet(Tcl_Interp *interp,
|
||||
Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
|
||||
MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum);
|
||||
@@ -2913,20 +2552,9 @@ MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
|
||||
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
|
||||
MODULE_SCOPE int TclClearRootEnsemble(ClientData data[],
|
||||
Tcl_Interp *interp, int result);
|
||||
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
|
||||
int *loc);
|
||||
MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr,
|
||||
int start, int *clNext);
|
||||
MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr);
|
||||
MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr,
|
||||
Tcl_Obj *originObjPtr);
|
||||
MODULE_SCOPE int TclConvertElement(const char *src, int length,
|
||||
char *dst, int flags);
|
||||
MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr);
|
||||
/* TIP #280 - Modified token based evulation, with line information. */
|
||||
MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script,
|
||||
int numBytes, int flags, int line,
|
||||
int *clNextOuter, const char *outerScript);
|
||||
MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd;
|
||||
MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd;
|
||||
MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd;
|
||||
@@ -2985,7 +2613,6 @@ MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp,
|
||||
const char *modeString, int *seekFlagPtr,
|
||||
int *binaryPtr);
|
||||
MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
|
||||
MODULE_SCOPE const char *TclGetSrcInfoForCmd(Interp *iPtr, int *lenPtr);
|
||||
MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
|
||||
Tcl_Obj *unquotedPrefix, int globFlags,
|
||||
Tcl_GlobTypeData *types);
|
||||
@@ -2997,7 +2624,6 @@ MODULE_SCOPE int TclInfoExistsCmd(ClientData dummy, Tcl_Interp *interp,
|
||||
int objc, Tcl_Obj *const objv[]);
|
||||
MODULE_SCOPE int TclInfoCoroutineCmd(ClientData dummy, Tcl_Interp *interp,
|
||||
int objc, Tcl_Obj *const objv[]);
|
||||
MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr);
|
||||
MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp,
|
||||
int objc, Tcl_Obj *const objv[]);
|
||||
MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp,
|
||||
@@ -3042,7 +2668,6 @@ MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes,
|
||||
MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc,
|
||||
Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr,
|
||||
int *codePtr, int *levelPtr);
|
||||
MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
|
||||
MODULE_SCOPE int TclNokia770Doubles(void);
|
||||
MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr);
|
||||
MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
|
||||
@@ -3148,16 +2773,14 @@ MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj,
|
||||
Tcl_Obj *patternObj, int flags);
|
||||
MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr);
|
||||
MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes,
|
||||
int numBytes, int flags, int line,
|
||||
struct CompileEnv *envPtr);
|
||||
int numBytes, int flags, struct CompileEnv *envPtr);
|
||||
MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts,
|
||||
Tcl_Obj *const opts[], int *flagPtr);
|
||||
MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes,
|
||||
int numBytes, int flags, Tcl_Parse *parsePtr,
|
||||
Tcl_InterpState *statePtr);
|
||||
MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
|
||||
int count, int *tokensLeftPtr, int line,
|
||||
int *clNextOuter, const char *outerScript);
|
||||
int count, int *tokensLeftPtr);
|
||||
MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes,
|
||||
const char *trim, int numTrim);
|
||||
MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes,
|
||||
@@ -3181,15 +2804,12 @@ 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);
|
||||
MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr);
|
||||
MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr);
|
||||
|
||||
MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length);
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------
|
||||
* Command procedures in the generic core:
|
||||
@@ -3256,9 +2876,6 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr,
|
||||
Tcl_Obj *const pathv[], Tcl_Obj *keysPtr);
|
||||
MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr,
|
||||
int pathc, Tcl_Obj *const pathv[]);
|
||||
MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData,
|
||||
Tcl_Interp *interp, int objc,
|
||||
Tcl_Obj *const objv[]);
|
||||
|
||||
/* Assemble command function */
|
||||
MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData,
|
||||
@@ -4776,56 +4393,30 @@ void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn));
|
||||
*----------------------------------------------------------------
|
||||
*/
|
||||
|
||||
#define NRE_USE_SMALL_ALLOC 1 /* Only turn off for debugging purposes. */
|
||||
#define NRE_ENABLE_ASSERTS 1
|
||||
|
||||
/*
|
||||
* This is the main data struct for representing NR commands. It is designed
|
||||
* to fit in sizeof(Tcl_Obj) in order to exploit the fastest memory allocator
|
||||
* available.
|
||||
*/
|
||||
|
||||
typedef struct NRE_callback {
|
||||
Tcl_NRPostProc *procPtr;
|
||||
ClientData data[4];
|
||||
struct NRE_callback *nextPtr;
|
||||
} NRE_callback;
|
||||
|
||||
#define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr)
|
||||
|
||||
/*
|
||||
* Inline version of Tcl_NRAddCallback.
|
||||
*/
|
||||
|
||||
#define TclNRAddCallback(interp,postProcPtr,data0,data1,data2,data3) \
|
||||
do { \
|
||||
NRE_callback *callbackPtr; \
|
||||
TCLNR_ALLOC((interp), (callbackPtr)); \
|
||||
callbackPtr->procPtr = (postProcPtr); \
|
||||
callbackPtr->data[0] = (ClientData)(data0); \
|
||||
callbackPtr->data[1] = (ClientData)(data1); \
|
||||
callbackPtr->data[2] = (ClientData)(data2); \
|
||||
callbackPtr->data[3] = (ClientData)(data3); \
|
||||
callbackPtr->nextPtr = TOP_CB(interp); \
|
||||
TOP_CB(interp) = callbackPtr; \
|
||||
} while (0)
|
||||
|
||||
#if NRE_USE_SMALL_ALLOC
|
||||
#define TCLNR_ALLOC(interp, ptr) \
|
||||
TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr))
|
||||
#define TCLNR_FREE(interp, ptr) TclSmallFreeEx((interp), (ptr))
|
||||
#else
|
||||
#define TCLNR_ALLOC(interp, ptr) \
|
||||
(ptr = ((ClientData) ckalloc(sizeof(NRE_callback))))
|
||||
#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr))
|
||||
#endif
|
||||
|
||||
#if NRE_ENABLE_ASSERTS
|
||||
#include <assert.h>
|
||||
#define NRE_ASSERT(expr) assert((expr))
|
||||
#else
|
||||
#define NRE_ASSERT(expr)
|
||||
#endif
|
||||
|
||||
void TclNRSetRoot(Tcl_Interp *interp);
|
||||
|
||||
/* NOTE: this just needed by tclOOBasic.c for a legit operation that deserves
|
||||
* a better API */
|
||||
|
||||
#ifdef USE_TOP_CB
|
||||
#define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr)
|
||||
|
||||
typedef struct NRE_callback {
|
||||
Tcl_NRPostProc *procPtr;
|
||||
ClientData data[4];
|
||||
} NRE_callback;
|
||||
#endif
|
||||
|
||||
|
||||
#include "tclIntDecls.h"
|
||||
#include "tclIntPlatDecls.h"
|
||||
#include "tclTomMathDecls.h"
|
||||
@@ -4836,6 +4427,51 @@ typedef struct NRE_callback {
|
||||
#define Tcl_Free(ptr) TclpFree(ptr)
|
||||
#endif
|
||||
|
||||
/*
|
||||
* ADDENDA
|
||||
*/
|
||||
|
||||
/*
|
||||
* The following structure defines for each Tcl interpreter various
|
||||
* statistics-related information about the bytecode compiler and
|
||||
* interpreter's operation in that interpreter.
|
||||
*/
|
||||
|
||||
#ifdef TCL_COMPILE_STATS
|
||||
typedef struct ByteCodeStats {
|
||||
long numExecutions; /* Number of ByteCodes executed. */
|
||||
long numCompilations; /* Number of ByteCodes created. */
|
||||
long numByteCodesFreed; /* Number of ByteCodes destroyed. */
|
||||
long instructionCount[256]; /* Number of times each instruction was
|
||||
* executed. */
|
||||
|
||||
double totalSrcBytes; /* Total source bytes ever compiled. */
|
||||
double totalByteCodeBytes; /* Total bytes for all ByteCodes. */
|
||||
double currentSrcBytes; /* Src bytes for all current ByteCodes. */
|
||||
double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */
|
||||
|
||||
long srcCount[32]; /* Source size distribution: # of srcs of
|
||||
* size [2**(n-1)..2**n), n in [0..32). */
|
||||
long byteCodeCount[32]; /* ByteCode size distribution. */
|
||||
long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */
|
||||
|
||||
double currentInstBytes; /* Instruction bytes-current ByteCodes. */
|
||||
double currentLitBytes; /* Current literal bytes. */
|
||||
double currentExceptBytes; /* Current exception table bytes. */
|
||||
double currentAuxBytes; /* Current auxiliary information bytes. */
|
||||
double currentCmdMapBytes; /* Current src<->code map bytes. */
|
||||
|
||||
long numLiteralsCreated; /* Total literal objects ever compiled. */
|
||||
double totalLitStringBytes; /* Total string bytes in all literals. */
|
||||
double currentLitStringBytes;
|
||||
/* String bytes in current literals. */
|
||||
long literalCount[32]; /* Distribution of literal string sizes. */
|
||||
} ByteCodeStats;
|
||||
#endif /* TCL_COMPILE_STATS */
|
||||
|
||||
MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine;
|
||||
MODULE_SCOPE void TclForceBodyNS(Tcl_Obj *bodyPtr, Namespace *nsPtr);
|
||||
|
||||
#endif /* _TCLINT */
|
||||
|
||||
/*
|
||||
|
||||
+13
-23
@@ -359,10 +359,7 @@ EXTERN CONST84_RETURN char * TclGetEnv(const char *name,
|
||||
/* 141 */
|
||||
EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp,
|
||||
Tcl_DString *cwdPtr);
|
||||
/* 142 */
|
||||
EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp,
|
||||
Tcl_Obj *objPtr, CompileHookProc *hookProc,
|
||||
ClientData clientData);
|
||||
/* Slot 142 is reserved */
|
||||
/* 143 */
|
||||
EXTERN int TclAddLiteralObj(struct CompileEnv *envPtr,
|
||||
Tcl_Obj *objPtr, LiteralEntry **litPtrPtr);
|
||||
@@ -550,11 +547,8 @@ EXTERN Var * TclObjLookupVar(Tcl_Interp *interp,
|
||||
/* 231 */
|
||||
EXTERN int TclGetNamespaceFromObj(Tcl_Interp *interp,
|
||||
Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
|
||||
/* 232 */
|
||||
EXTERN int TclEvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr,
|
||||
int flags, const CmdFrame *invoker, int word);
|
||||
/* 233 */
|
||||
EXTERN void TclGetSrcInfoForPc(CmdFrame *contextPtr);
|
||||
/* Slot 232 is reserved */
|
||||
/* Slot 233 is reserved */
|
||||
/* 234 */
|
||||
EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr,
|
||||
const char *key, int *newPtr);
|
||||
@@ -574,11 +568,10 @@ EXTERN int TclNRInterpProcCore(Tcl_Interp *interp,
|
||||
Tcl_Obj *procNameObj, int skip,
|
||||
ProcErrorProc *errorProc);
|
||||
/* 240 */
|
||||
EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result,
|
||||
struct NRE_callback *rootPtr);
|
||||
EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result);
|
||||
/* 241 */
|
||||
EXTERN int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr,
|
||||
int flags, const CmdFrame *invoker, int word);
|
||||
int flags);
|
||||
/* 242 */
|
||||
EXTERN int TclNREvalObjv(Tcl_Interp *interp, int objc,
|
||||
Tcl_Obj *const objv[], int flags,
|
||||
@@ -753,7 +746,7 @@ typedef struct TclIntStubs {
|
||||
void (*reserved139)(void);
|
||||
void (*reserved140)(void);
|
||||
CONST84_RETURN char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
|
||||
int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */
|
||||
void (*reserved142)(void);
|
||||
int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */
|
||||
void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */
|
||||
const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */
|
||||
@@ -843,16 +836,16 @@ typedef struct TclIntStubs {
|
||||
int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */
|
||||
Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */
|
||||
int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */
|
||||
int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */
|
||||
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
|
||||
void (*reserved232)(void);
|
||||
void (*reserved233)(void);
|
||||
Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
|
||||
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
|
||||
void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
|
||||
int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
|
||||
int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */
|
||||
int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */
|
||||
int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */
|
||||
int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */
|
||||
int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result); /* 240 */
|
||||
int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 241 */
|
||||
int (*tclNREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */
|
||||
void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */
|
||||
Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */
|
||||
@@ -1105,8 +1098,7 @@ extern const TclIntStubs *tclIntStubsPtr;
|
||||
/* Slot 140 is reserved */
|
||||
#define TclpGetCwd \
|
||||
(tclIntStubsPtr->tclpGetCwd) /* 141 */
|
||||
#define TclSetByteCodeFromAny \
|
||||
(tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */
|
||||
/* Slot 142 is reserved */
|
||||
#define TclAddLiteralObj \
|
||||
(tclIntStubsPtr->tclAddLiteralObj) /* 143 */
|
||||
#define TclHideLiteral \
|
||||
@@ -1251,10 +1243,8 @@ extern const TclIntStubs *tclIntStubsPtr;
|
||||
(tclIntStubsPtr->tclObjLookupVar) /* 230 */
|
||||
#define TclGetNamespaceFromObj \
|
||||
(tclIntStubsPtr->tclGetNamespaceFromObj) /* 231 */
|
||||
#define TclEvalObjEx \
|
||||
(tclIntStubsPtr->tclEvalObjEx) /* 232 */
|
||||
#define TclGetSrcInfoForPc \
|
||||
(tclIntStubsPtr->tclGetSrcInfoForPc) /* 233 */
|
||||
/* Slot 232 is reserved */
|
||||
/* Slot 233 is reserved */
|
||||
#define TclVarHashCreateVar \
|
||||
(tclIntStubsPtr->tclVarHashCreateVar) /* 234 */
|
||||
#define TclInitVarHashTable \
|
||||
|
||||
+2
-12
@@ -1798,7 +1798,7 @@ AliasNRCmd(
|
||||
*/
|
||||
|
||||
if (isRootEnsemble) {
|
||||
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
|
||||
Tcl_NRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
|
||||
}
|
||||
TclSkipTailcall(interp);
|
||||
return Tcl_NREvalObj(interp, listPtr, flags);
|
||||
@@ -2769,17 +2769,7 @@ SlaveEval(
|
||||
Tcl_AllowExceptions(slaveInterp);
|
||||
|
||||
if (objc == 1) {
|
||||
/*
|
||||
* TIP #280: Make actual argument location available to eval'd script.
|
||||
*/
|
||||
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
CmdFrame *invoker = iPtr->cmdFramePtr;
|
||||
int word = 0;
|
||||
|
||||
TclArgumentGet(interp, objv[0], &invoker, &word);
|
||||
|
||||
result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word);
|
||||
result = Tcl_EvalObjEx(slaveInterp, objv[0], 0);
|
||||
} else {
|
||||
Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv);
|
||||
Tcl_IncrRefCount(objPtr);
|
||||
|
||||
@@ -14,8 +14,7 @@
|
||||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
#include "tclCompile.h"
|
||||
#include "tclEngineInt.h"
|
||||
|
||||
/*
|
||||
* When there are this many entries per bucket, on average, rebuild a
|
||||
|
||||
@@ -0,0 +1,51 @@
|
||||
/* **********************************************
|
||||
* NRE internals
|
||||
* **********************************************
|
||||
*/
|
||||
|
||||
/*
|
||||
* Inline versions of Tcl_NRAddCallback and friends
|
||||
*/
|
||||
|
||||
#define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr)
|
||||
|
||||
#define TclNRAddCallback(interp,postProcPtr,data0,data1,data2,data3) \
|
||||
do { \
|
||||
NRE_callback *cbPtr; \
|
||||
ALLOC_CB(interp, cbPtr); \
|
||||
INIT_CB(cbPtr, postProcPtr,data0,data1,data2,data3); \
|
||||
} while (0)
|
||||
|
||||
#define INIT_CB(cbPtr, postProcPtr,data0,data1,data2,data3) \
|
||||
do { \
|
||||
cbPtr->procPtr = (postProcPtr); \
|
||||
cbPtr->data[0] = (ClientData)(data0); \
|
||||
cbPtr->data[1] = (ClientData)(data1); \
|
||||
cbPtr->data[2] = (ClientData)(data2); \
|
||||
cbPtr->data[3] = (ClientData)(data3); \
|
||||
} while (0)
|
||||
|
||||
typedef struct NRE_callback {
|
||||
Tcl_NRPostProc *procPtr;
|
||||
ClientData data[4];
|
||||
struct NRE_callback *nextPtr;
|
||||
} NRE_callback;
|
||||
|
||||
#define POP_CB(interp, cbPtr) \
|
||||
do { \
|
||||
cbPtr = TOP_CB(interp); \
|
||||
TOP_CB(interp) = cbPtr->nextPtr; \
|
||||
} while (0)
|
||||
|
||||
#define ALLOC_CB(interp, cbPtr) \
|
||||
do { \
|
||||
cbPtr = ckalloc(sizeof(NRE_callback)); \
|
||||
cbPtr->nextPtr = TOP_CB(interp); \
|
||||
TOP_CB(interp) = cbPtr; \
|
||||
} while (0)
|
||||
|
||||
#define FREE_CB(interp, ptr) \
|
||||
ckfree((char *) (ptr))
|
||||
|
||||
#define NEXT_CB(ptr) (ptr)->nextPtr
|
||||
|
||||
+10
-178
@@ -24,7 +24,6 @@
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
#include "tclCompile.h" /* for TclLogCommandInfo visibility */
|
||||
|
||||
/*
|
||||
* Thread-local storage used to avoid having a global lock on data that is not
|
||||
@@ -3239,8 +3238,6 @@ NRNamespaceEvalCmd(
|
||||
Tcl_Obj *const objv[]) /* Argument objects. */
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
CmdFrame *invoker;
|
||||
int word;
|
||||
Tcl_Namespace *namespacePtr;
|
||||
CallFrame *framePtr, **framePtrPtr;
|
||||
Tcl_Obj *objPtr;
|
||||
@@ -3294,14 +3291,7 @@ NRNamespaceEvalCmd(
|
||||
}
|
||||
|
||||
if (objc == 3) {
|
||||
/*
|
||||
* TIP #280: Make actual argument location available to eval'd script.
|
||||
*/
|
||||
|
||||
objPtr = objv[2];
|
||||
invoker = iPtr->cmdFramePtr;
|
||||
word = 3;
|
||||
TclArgumentGet(interp, objPtr, &invoker, &word);
|
||||
} else {
|
||||
/*
|
||||
* More than one argument: concatenate them together with spaces
|
||||
@@ -3310,17 +3300,11 @@ NRNamespaceEvalCmd(
|
||||
*/
|
||||
|
||||
objPtr = Tcl_ConcatObj(objc-2, objv+2);
|
||||
invoker = NULL;
|
||||
word = 0;
|
||||
}
|
||||
|
||||
/*
|
||||
* TIP #280: Make invoking context available to eval'd script.
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "eval",
|
||||
Tcl_NRAddCallback(interp, NsEval_Callback, namespacePtr, "eval",
|
||||
NULL, NULL);
|
||||
return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
|
||||
return TclNREvalObjEx(interp, objPtr, 0);
|
||||
}
|
||||
|
||||
static int
|
||||
@@ -3783,9 +3767,9 @@ NRNamespaceInscopeCmd(
|
||||
Tcl_DecrRefCount(listPtr); /* We're done with the list object. */
|
||||
}
|
||||
|
||||
TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "inscope",
|
||||
Tcl_NRAddCallback(interp, NsEval_Callback, namespacePtr, "inscope",
|
||||
NULL, NULL);
|
||||
return TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
|
||||
return TclNREvalObjEx(interp, cmdObjPtr, 0);
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -4814,37 +4798,31 @@ TclGetNamespaceChildTable(
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclLogCommandInfo --
|
||||
* Tcl_LogCommandInfo --
|
||||
*
|
||||
* This function is invoked after an error occurs in an interpreter. It
|
||||
* adds information to iPtr->errorInfo/errorStack fields to describe the
|
||||
* command that was being executed when the error occurred. When pc and
|
||||
* tosPtr are non-NULL, conveying a bytecode execution "inner context",
|
||||
* and the offending instruction is suitable, that inner context is
|
||||
* recorded in errorStack.
|
||||
* adds information to iPtr->errorInfo fields to describe the
|
||||
* command that was being executed when the error occurred.
|
||||
*
|
||||
* Results:
|
||||
* None.
|
||||
*
|
||||
* Side effects:
|
||||
* Information about the command is added to errorInfo/errorStack and the
|
||||
* Information about the command is added to errorInfo and the
|
||||
* line number stored internally in the interpreter is set.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
void
|
||||
TclLogCommandInfo(
|
||||
Tcl_LogCommandInfo(
|
||||
Tcl_Interp *interp, /* Interpreter in which to log information. */
|
||||
const char *script, /* First character in script containing
|
||||
* command (must be <= command). */
|
||||
const char *command, /* First character in command that generated
|
||||
* the error. */
|
||||
int length, /* Number of bytes in command (-1 means use
|
||||
int length) /* Number of bytes in command (-1 means use
|
||||
* all bytes up to first null byte). */
|
||||
const unsigned char *pc, /* Current pc of bytecode execution context */
|
||||
Tcl_Obj **tosPtr) /* Current stack of bytecode execution
|
||||
* context */
|
||||
{
|
||||
register const char *p;
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
@@ -4911,153 +4889,7 @@ TclLogCommandInfo(
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* TIP #348
|
||||
*/
|
||||
|
||||
if (Tcl_IsShared(iPtr->errorStack)) {
|
||||
Tcl_Obj *newObj;
|
||||
|
||||
newObj = Tcl_DuplicateObj(iPtr->errorStack);
|
||||
Tcl_DecrRefCount(iPtr->errorStack);
|
||||
Tcl_IncrRefCount(newObj);
|
||||
iPtr->errorStack = newObj;
|
||||
}
|
||||
if (iPtr->resetErrorStack) {
|
||||
int len;
|
||||
|
||||
iPtr->resetErrorStack = 0;
|
||||
Tcl_ListObjLength(interp, iPtr->errorStack, &len);
|
||||
|
||||
/*
|
||||
* Reset while keeping the list intrep as much as possible.
|
||||
*/
|
||||
|
||||
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
|
||||
if (pc != NULL) {
|
||||
Tcl_Obj *innerContext;
|
||||
|
||||
innerContext = TclGetInnerContext(interp, pc, tosPtr);
|
||||
if (innerContext != NULL) {
|
||||
Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
|
||||
iPtr->innerLiteral);
|
||||
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext);
|
||||
}
|
||||
} else if (command != NULL) {
|
||||
Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
|
||||
iPtr->innerLiteral);
|
||||
Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
|
||||
Tcl_NewStringObj(command, length));
|
||||
}
|
||||
}
|
||||
|
||||
if (!iPtr->framePtr->objc) {
|
||||
/*
|
||||
* Special frame, nothing to report.
|
||||
*/
|
||||
} else if (iPtr->varFramePtr != iPtr->framePtr) {
|
||||
/*
|
||||
* uplevel case, [lappend errorstack UP $relativelevel]
|
||||
*/
|
||||
|
||||
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
|
||||
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
|
||||
iPtr->framePtr->level - iPtr->varFramePtr->level));
|
||||
} else if (iPtr->framePtr != iPtr->rootFramePtr) {
|
||||
/*
|
||||
* normal case, [lappend errorstack CALL [info level 0]]
|
||||
*/
|
||||
|
||||
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
|
||||
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
|
||||
iPtr->framePtr->objc, iPtr->framePtr->objv));
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclErrorStackResetIf --
|
||||
*
|
||||
* The TIP 348 reset/no-bc part of TLCI, for specific use by
|
||||
* TclCompileSyntaxError.
|
||||
*
|
||||
* Results:
|
||||
* None.
|
||||
*
|
||||
* Side effects:
|
||||
* Reset errorstack if it needs be, and in that case remember the
|
||||
* passed-in error message as inner context.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
void
|
||||
TclErrorStackResetIf(
|
||||
Tcl_Interp *interp,
|
||||
const char *msg,
|
||||
int length)
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
|
||||
if (Tcl_IsShared(iPtr->errorStack)) {
|
||||
Tcl_Obj *newObj;
|
||||
|
||||
newObj = Tcl_DuplicateObj(iPtr->errorStack);
|
||||
Tcl_DecrRefCount(iPtr->errorStack);
|
||||
Tcl_IncrRefCount(newObj);
|
||||
iPtr->errorStack = newObj;
|
||||
}
|
||||
if (iPtr->resetErrorStack) {
|
||||
int len;
|
||||
|
||||
iPtr->resetErrorStack = 0;
|
||||
Tcl_ListObjLength(interp, iPtr->errorStack, &len);
|
||||
|
||||
/*
|
||||
* Reset while keeping the list intrep as much as possible.
|
||||
*/
|
||||
|
||||
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
|
||||
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
|
||||
Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
|
||||
Tcl_NewStringObj(msg, length));
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* Tcl_LogCommandInfo --
|
||||
*
|
||||
* This function is invoked after an error occurs in an interpreter. It
|
||||
* adds information to iPtr->errorInfo/errorStack fields to describe the
|
||||
* command that was being executed when the error occurred.
|
||||
*
|
||||
* Results:
|
||||
* None.
|
||||
*
|
||||
* Side effects:
|
||||
* Information about the command is added to errorInfo/errorStack and the
|
||||
* line number stored internally in the interpreter is set.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
void
|
||||
Tcl_LogCommandInfo(
|
||||
Tcl_Interp *interp, /* Interpreter in which to log information. */
|
||||
const char *script, /* First character in script containing
|
||||
* command (must be <= command). */
|
||||
const char *command, /* First character in command that generated
|
||||
* the error. */
|
||||
int length) /* Number of bytes in command (-1 means use
|
||||
* all bytes up to first null byte). */
|
||||
{
|
||||
TclLogCommandInfo(interp, script, command, length, NULL, NULL);
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* Local Variables:
|
||||
|
||||
+3
-3
@@ -1774,7 +1774,7 @@ TclNRNewObjectInstance(
|
||||
*/
|
||||
|
||||
AddRef(oPtr);
|
||||
TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
|
||||
Tcl_NRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
|
||||
objectPtr);
|
||||
TclPushTailcallPoint(interp);
|
||||
return TclOOInvokeContext(contextPtr, interp, objc, objv);
|
||||
@@ -2578,7 +2578,7 @@ TclOOObjectCmdCore(
|
||||
* for the duration.
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL);
|
||||
Tcl_NRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL);
|
||||
return TclOOInvokeContext(contextPtr, interp, objc, objv);
|
||||
}
|
||||
|
||||
@@ -2731,7 +2731,7 @@ TclNRObjectContextInvokeNext(
|
||||
* all) come through the same code.
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, FinalizeNext, contextPtr,
|
||||
Tcl_NRAddCallback(interp, FinalizeNext, contextPtr,
|
||||
INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip), NULL);
|
||||
contextPtr->index++;
|
||||
contextPtr->skip = skip;
|
||||
|
||||
+10
-11
@@ -13,6 +13,8 @@
|
||||
#ifdef HAVE_CONFIG_H
|
||||
#include "config.h"
|
||||
#endif
|
||||
|
||||
#define USE_TOP_CB 1
|
||||
#include "tclInt.h"
|
||||
#include "tclOOInt.h"
|
||||
|
||||
@@ -33,7 +35,7 @@ static int RestoreFrame(ClientData data[],
|
||||
*
|
||||
* AddCreateCallback, FinalizeConstruction --
|
||||
*
|
||||
* Special version of TclNRAddCallback that allows the caller to splice
|
||||
* Special version of Tcl_NRAddCallback that allows the caller to splice
|
||||
* the object created later on. Always calls FinalizeConstruction, which
|
||||
* converts the object into its name and stores that in the interpreter
|
||||
* result. This is shared by all the construction methods (create,
|
||||
@@ -50,7 +52,7 @@ static inline Tcl_Object *
|
||||
AddConstructionFinalizer(
|
||||
Tcl_Interp *interp)
|
||||
{
|
||||
TclNRAddCallback(interp, FinalizeConstruction, NULL, NULL, NULL, NULL);
|
||||
Tcl_NRAddCallback(interp, FinalizeConstruction, NULL, NULL, NULL, NULL);
|
||||
return (Tcl_Object *) &(TOP_CB(interp)->data[0]);
|
||||
}
|
||||
|
||||
@@ -114,7 +116,7 @@ TclOO_Class_Constructor(
|
||||
Tcl_IncrRefCount(invoke[0]);
|
||||
Tcl_IncrRefCount(invoke[1]);
|
||||
Tcl_IncrRefCount(invoke[2]);
|
||||
TclNRAddCallback(interp, DecrRefsPostClassConstructor,
|
||||
Tcl_NRAddCallback(interp, DecrRefsPostClassConstructor,
|
||||
invoke[0], invoke[1], invoke[2], NULL);
|
||||
|
||||
/*
|
||||
@@ -352,7 +354,7 @@ TclOO_Object_Destroy(
|
||||
if (contextPtr != NULL) {
|
||||
contextPtr->callPtr->flags |= DESTRUCTOR;
|
||||
contextPtr->skip = 0;
|
||||
TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
|
||||
Tcl_NRAddCallback(interp, AfterNRDestructor, contextPtr,
|
||||
NULL, NULL, NULL);
|
||||
TclPushTailcallPoint(interp);
|
||||
return TclOOInvokeContext(contextPtr, interp, 0, NULL);
|
||||
@@ -404,7 +406,6 @@ TclOO_Object_Eval(
|
||||
CallFrame *framePtr, **framePtrPtr = &framePtr;
|
||||
Tcl_Obj *scriptPtr;
|
||||
int result;
|
||||
CmdFrame *invoker;
|
||||
|
||||
if (objc-1 < skip) {
|
||||
Tcl_WrongNumArgs(interp, skip, objv, "arg ?arg ...?");
|
||||
@@ -439,10 +440,8 @@ TclOO_Object_Eval(
|
||||
|
||||
if (objc != skip+1) {
|
||||
scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip);
|
||||
invoker = NULL;
|
||||
} else {
|
||||
scriptPtr = objv[skip];
|
||||
invoker = ((Interp *) interp)->cmdFramePtr;
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -450,8 +449,8 @@ TclOO_Object_Eval(
|
||||
* the script completes.
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, FinalizeEval, object, NULL, NULL, NULL);
|
||||
return TclNREvalObjEx(interp, scriptPtr, 0, invoker, skip);
|
||||
Tcl_NRAddCallback(interp, FinalizeEval, object, NULL, NULL, NULL);
|
||||
return TclNREvalObjEx(interp, scriptPtr, 0);
|
||||
}
|
||||
|
||||
static int
|
||||
@@ -805,7 +804,7 @@ TclOONextObjCmd(
|
||||
* that this is like [uplevel 1] and not [eval].
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, RestoreFrame, framePtr, NULL, NULL, NULL);
|
||||
Tcl_NRAddCallback(interp, RestoreFrame, framePtr, NULL, NULL, NULL);
|
||||
iPtr->varFramePtr = framePtr->callerVarPtr;
|
||||
return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
|
||||
}
|
||||
@@ -874,7 +873,7 @@ TclOONextToObjCmd(
|
||||
* context. Note that this is like [uplevel 1] and not [eval].
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr,
|
||||
Tcl_NRAddCallback(interp, RestoreFrame, framePtr, contextPtr,
|
||||
INT2PTR(contextPtr->index), NULL);
|
||||
contextPtr->index = i-1;
|
||||
iPtr->varFramePtr = framePtr->callerVarPtr;
|
||||
|
||||
+3
-3
@@ -278,7 +278,7 @@ TclOOInvokeContext(
|
||||
* this call is finished.
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, FinalizeMethodRefs, contextPtr, NULL, NULL,
|
||||
Tcl_NRAddCallback(interp, FinalizeMethodRefs, contextPtr, NULL, NULL,
|
||||
NULL);
|
||||
}
|
||||
|
||||
@@ -287,9 +287,9 @@ TclOOInvokeContext(
|
||||
*/
|
||||
|
||||
if (contextPtr->oPtr->flags & FILTER_HANDLING) {
|
||||
TclNRAddCallback(interp, SetFilterFlags, contextPtr, NULL,NULL,NULL);
|
||||
Tcl_NRAddCallback(interp, SetFilterFlags, contextPtr, NULL,NULL,NULL);
|
||||
} else {
|
||||
TclNRAddCallback(interp, ResetFilterFlags,contextPtr,NULL,NULL,NULL);
|
||||
Tcl_NRAddCallback(interp, ResetFilterFlags,contextPtr,NULL,NULL,NULL);
|
||||
}
|
||||
if (isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) {
|
||||
contextPtr->oPtr->flags |= FILTER_HANDLING;
|
||||
|
||||
@@ -841,8 +841,7 @@ TclOODefineObjCmd(
|
||||
Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
|
||||
|
||||
Tcl_IncrRefCount(objNameObj);
|
||||
result = TclEvalObjEx(interp, objv[2], 0,
|
||||
((Interp *)interp)->cmdFramePtr, 2);
|
||||
result = Tcl_EvalObjEx(interp, objv[2], 0);
|
||||
if (result == TCL_ERROR) {
|
||||
GenerateErrorInfo(interp, oPtr, objNameObj, "class");
|
||||
}
|
||||
@@ -955,8 +954,7 @@ TclOOObjDefObjCmd(
|
||||
Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
|
||||
|
||||
Tcl_IncrRefCount(objNameObj);
|
||||
result = TclEvalObjEx(interp, objv[2], 0,
|
||||
((Interp *)interp)->cmdFramePtr, 2);
|
||||
result = Tcl_EvalObjEx(interp, objv[2], 0);
|
||||
if (result == TCL_ERROR) {
|
||||
GenerateErrorInfo(interp, oPtr, objNameObj, "object");
|
||||
}
|
||||
@@ -1069,8 +1067,7 @@ TclOODefineSelfObjCmd(
|
||||
Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
|
||||
|
||||
Tcl_IncrRefCount(objNameObj);
|
||||
result = TclEvalObjEx(interp, objv[1], 0,
|
||||
((Interp *)interp)->cmdFramePtr, 2);
|
||||
result = Tcl_EvalObjEx(interp, objv[1], 0);
|
||||
if (result == TCL_ERROR) {
|
||||
GenerateErrorInfo(interp, oPtr, objNameObj, "class object");
|
||||
}
|
||||
|
||||
@@ -94,9 +94,6 @@ typedef struct ProcedureMethod {
|
||||
TclOO_PostCallProc *postCallProc;
|
||||
/* Callback to allow for additional cleanup
|
||||
* after the method executes. */
|
||||
GetFrameInfoValueProc *gfivProc;
|
||||
/* Callback to allow for fine tuning of how
|
||||
* the method reports itself. */
|
||||
} ProcedureMethod;
|
||||
|
||||
#define TCLOO_PROCEDURE_METHOD_VERSION 0
|
||||
|
||||
+2
-204
@@ -14,18 +14,6 @@
|
||||
#endif
|
||||
#include "tclInt.h"
|
||||
#include "tclOOInt.h"
|
||||
#include "tclCompile.h"
|
||||
|
||||
/*
|
||||
* Structure used to help delay computing names of objects or classes for
|
||||
* [info frame] until needed, making invokation faster in the normal case.
|
||||
*/
|
||||
|
||||
struct PNI {
|
||||
Tcl_Interp *interp; /* Interpreter in which to compute the name of
|
||||
* a method. */
|
||||
Tcl_Method method; /* Method to compute the name of. */
|
||||
};
|
||||
|
||||
/*
|
||||
* Structure used to contain all the information needed about a call frame
|
||||
@@ -38,11 +26,8 @@ typedef struct {
|
||||
ProcErrorProc *errProc; /* The error handler for the body. */
|
||||
Tcl_Obj *nameObj; /* The "name" of the command. */
|
||||
Command cmd; /* The command structure. Mostly bogus. */
|
||||
ExtraFrameInfo efi; /* Extra information used for [info frame]. */
|
||||
Command *oldCmdPtr; /* Saved cmdPtr so that we can be safe after a
|
||||
* recursive call returns. */
|
||||
struct PNI pni; /* Specialist information used in the efi
|
||||
* field for this type of call. */
|
||||
} PMFrameData;
|
||||
|
||||
/*
|
||||
@@ -88,7 +73,6 @@ static void ConstructorErrorHandler(Tcl_Interp *interp,
|
||||
Tcl_Obj *procNameObj);
|
||||
static void DestructorErrorHandler(Tcl_Interp *interp,
|
||||
Tcl_Obj *procNameObj);
|
||||
static Tcl_Obj * RenderDeclarerName(ClientData clientData);
|
||||
static int InvokeForwardMethod(ClientData clientData,
|
||||
Tcl_Interp *interp, Tcl_ObjectContext context,
|
||||
int objc, Tcl_Obj *const *objv);
|
||||
@@ -458,7 +442,6 @@ TclOOMakeProcInstanceMethod(
|
||||
* inside the structure indicated by the
|
||||
* pointer in clientData. */
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
Proc *procPtr;
|
||||
|
||||
if (TclCreateProc(interp, NULL, TclGetString(nameObj), argsObj, bodyObj,
|
||||
@@ -468,69 +451,6 @@ TclOOMakeProcInstanceMethod(
|
||||
procPtr = *procPtrPtr;
|
||||
procPtr->cmdPtr = NULL;
|
||||
|
||||
if (iPtr->cmdFramePtr) {
|
||||
CmdFrame context = *iPtr->cmdFramePtr;
|
||||
|
||||
if (context.type == TCL_LOCATION_BC) {
|
||||
/*
|
||||
* Retrieve source information from the bytecode, if possible. If
|
||||
* the information is retrieved successfully, context.type will be
|
||||
* TCL_LOCATION_SOURCE and the reference held by
|
||||
* context.data.eval.path will be counted.
|
||||
*/
|
||||
|
||||
TclGetSrcInfoForPc(&context);
|
||||
} else if (context.type == TCL_LOCATION_SOURCE) {
|
||||
/*
|
||||
* The copy into 'context' up above has created another reference
|
||||
* to 'context.data.eval.path'; account for it.
|
||||
*/
|
||||
|
||||
Tcl_IncrRefCount(context.data.eval.path);
|
||||
}
|
||||
|
||||
if (context.type == TCL_LOCATION_SOURCE) {
|
||||
/*
|
||||
* We can account for source location within a proc only if the
|
||||
* proc body was not created by substitution.
|
||||
* (FIXME: check that this is sane and correct!)
|
||||
*/
|
||||
|
||||
if (context.line
|
||||
&& (context.nline >= 4) && (context.line[3] >= 0)) {
|
||||
int isNew;
|
||||
CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
|
||||
Tcl_HashEntry *hPtr;
|
||||
|
||||
cfPtr->level = -1;
|
||||
cfPtr->type = context.type;
|
||||
cfPtr->line = ckalloc(sizeof(int));
|
||||
cfPtr->line[0] = context.line[3];
|
||||
cfPtr->nline = 1;
|
||||
cfPtr->framePtr = NULL;
|
||||
cfPtr->nextPtr = NULL;
|
||||
|
||||
cfPtr->data.eval.path = context.data.eval.path;
|
||||
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
||||
|
||||
cfPtr->cmd.str.cmd = NULL;
|
||||
cfPtr->cmd.str.len = 0;
|
||||
|
||||
hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
|
||||
(char *) procPtr, &isNew);
|
||||
Tcl_SetHashValue(hPtr, cfPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* 'context' is going out of scope; account for the reference that
|
||||
* it's holding to the path name.
|
||||
*/
|
||||
|
||||
Tcl_DecrRefCount(context.data.eval.path);
|
||||
context.data.eval.path = NULL;
|
||||
}
|
||||
}
|
||||
|
||||
return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
|
||||
typePtr, clientData);
|
||||
}
|
||||
@@ -571,7 +491,6 @@ TclOOMakeProcMethod(
|
||||
* inside the structure indicated by the
|
||||
* pointer in clientData. */
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
Proc *procPtr;
|
||||
|
||||
if (TclCreateProc(interp, NULL, namePtr, argsObj, bodyObj,
|
||||
@@ -581,69 +500,6 @@ TclOOMakeProcMethod(
|
||||
procPtr = *procPtrPtr;
|
||||
procPtr->cmdPtr = NULL;
|
||||
|
||||
if (iPtr->cmdFramePtr) {
|
||||
CmdFrame context = *iPtr->cmdFramePtr;
|
||||
|
||||
if (context.type == TCL_LOCATION_BC) {
|
||||
/*
|
||||
* Retrieve source information from the bytecode, if possible. If
|
||||
* the information is retrieved successfully, context.type will be
|
||||
* TCL_LOCATION_SOURCE and the reference held by
|
||||
* context.data.eval.path will be counted.
|
||||
*/
|
||||
|
||||
TclGetSrcInfoForPc(&context);
|
||||
} else if (context.type == TCL_LOCATION_SOURCE) {
|
||||
/*
|
||||
* The copy into 'context' up above has created another reference
|
||||
* to 'context.data.eval.path'; account for it.
|
||||
*/
|
||||
|
||||
Tcl_IncrRefCount(context.data.eval.path);
|
||||
}
|
||||
|
||||
if (context.type == TCL_LOCATION_SOURCE) {
|
||||
/*
|
||||
* We can account for source location within a proc only if the
|
||||
* proc body was not created by substitution.
|
||||
* (FIXME: check that this is sane and correct!)
|
||||
*/
|
||||
|
||||
if (context.line
|
||||
&& (context.nline >= 4) && (context.line[3] >= 0)) {
|
||||
int isNew;
|
||||
CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
|
||||
Tcl_HashEntry *hPtr;
|
||||
|
||||
cfPtr->level = -1;
|
||||
cfPtr->type = context.type;
|
||||
cfPtr->line = ckalloc(sizeof(int));
|
||||
cfPtr->line[0] = context.line[3];
|
||||
cfPtr->nline = 1;
|
||||
cfPtr->framePtr = NULL;
|
||||
cfPtr->nextPtr = NULL;
|
||||
|
||||
cfPtr->data.eval.path = context.data.eval.path;
|
||||
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
||||
|
||||
cfPtr->cmd.str.cmd = NULL;
|
||||
cfPtr->cmd.str.len = 0;
|
||||
|
||||
hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
|
||||
(char *) procPtr, &isNew);
|
||||
Tcl_SetHashValue(hPtr, cfPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* 'context' is going out of scope; account for the reference that
|
||||
* it's holding to the path name.
|
||||
*/
|
||||
|
||||
Tcl_DecrRefCount(context.data.eval.path);
|
||||
context.data.eval.path = NULL;
|
||||
}
|
||||
}
|
||||
|
||||
return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
|
||||
clientData);
|
||||
}
|
||||
@@ -732,7 +588,7 @@ InvokeProcedureMethod(
|
||||
* Now invoke the body of the method.
|
||||
*/
|
||||
|
||||
TclNRAddCallback(interp, FinalizePMCall, pmPtr, context, fdPtr, NULL);
|
||||
Tcl_NRAddCallback(interp, FinalizePMCall, pmPtr, context, fdPtr, NULL);
|
||||
return TclNRInterpProcCore(interp, fdPtr->nameObj,
|
||||
Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc);
|
||||
}
|
||||
@@ -845,10 +701,8 @@ PushMethodCallFrame(
|
||||
* Compile the body. This operation may fail.
|
||||
*/
|
||||
|
||||
fdPtr->efi.length = 2;
|
||||
memset(&fdPtr->cmd, 0, sizeof(Command));
|
||||
fdPtr->cmd.nsPtr = nsPtr;
|
||||
fdPtr->cmd.clientData = &fdPtr->efi;
|
||||
pmPtr->procPtr->cmdPtr = &fdPtr->cmd;
|
||||
|
||||
/*
|
||||
@@ -858,12 +712,8 @@ PushMethodCallFrame(
|
||||
* alternative is *so* slow...
|
||||
*/
|
||||
|
||||
if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) {
|
||||
ByteCode *codePtr =
|
||||
pmPtr->procPtr->bodyPtr->internalRep.otherValuePtr;
|
||||
TclForceBodyNS(pmPtr->procPtr->bodyPtr, nsPtr);
|
||||
|
||||
codePtr->nsPtr = nsPtr;
|
||||
}
|
||||
result = TclProcCompileProc(interp, pmPtr->procPtr,
|
||||
pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr);
|
||||
if (result != TCL_OK) {
|
||||
@@ -886,32 +736,6 @@ PushMethodCallFrame(
|
||||
fdPtr->framePtr->objv = objv;
|
||||
fdPtr->framePtr->procPtr = pmPtr->procPtr;
|
||||
|
||||
/*
|
||||
* Finish filling out the extra frame info so that [info frame] works.
|
||||
*/
|
||||
|
||||
fdPtr->efi.fields[0].name = "method";
|
||||
fdPtr->efi.fields[0].proc = NULL;
|
||||
fdPtr->efi.fields[0].clientData = fdPtr->nameObj;
|
||||
if (pmPtr->gfivProc != NULL) {
|
||||
fdPtr->efi.fields[1].name = "";
|
||||
fdPtr->efi.fields[1].proc = pmPtr->gfivProc;
|
||||
fdPtr->efi.fields[1].clientData = pmPtr;
|
||||
} else {
|
||||
register Tcl_Method method =
|
||||
Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr);
|
||||
|
||||
if (Tcl_MethodDeclarerObject(method) != NULL) {
|
||||
fdPtr->efi.fields[1].name = "object";
|
||||
} else {
|
||||
fdPtr->efi.fields[1].name = "class";
|
||||
}
|
||||
fdPtr->efi.fields[1].proc = RenderDeclarerName;
|
||||
fdPtr->efi.fields[1].clientData = &fdPtr->pni;
|
||||
fdPtr->pni.interp = interp;
|
||||
fdPtr->pni.method = method;
|
||||
}
|
||||
|
||||
return TCL_OK;
|
||||
|
||||
/*
|
||||
@@ -1117,32 +941,6 @@ ProcedureMethodCompiledVarResolver(
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
/*
|
||||
* ----------------------------------------------------------------------
|
||||
*
|
||||
* RenderDeclarerName --
|
||||
*
|
||||
* Returns the name of the entity (object or class) which declared a
|
||||
* method. Used for producing information for [info frame] in such a way
|
||||
* that the expensive part of this (generating the object or class name
|
||||
* itself) isn't done until it is needed.
|
||||
*
|
||||
* ----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
static Tcl_Obj *
|
||||
RenderDeclarerName(
|
||||
ClientData clientData)
|
||||
{
|
||||
struct PNI *pni = clientData;
|
||||
Tcl_Object object = Tcl_MethodDeclarerObject(pni->method);
|
||||
|
||||
if (object == NULL) {
|
||||
object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pni->method));
|
||||
}
|
||||
return TclOOObjectName(pni->interp, (Object *) object);
|
||||
}
|
||||
|
||||
/*
|
||||
* ----------------------------------------------------------------------
|
||||
*
|
||||
|
||||
+2
-396
@@ -76,30 +76,15 @@ typedef struct ObjData {
|
||||
* The structure defined below is used in this file only.
|
||||
*/
|
||||
|
||||
typedef struct ThreadSpecificData {
|
||||
Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj
|
||||
* generated by a call to the function
|
||||
* TclSubstTokens() from a literal text
|
||||
* where bs+nl sequences occured in it, if
|
||||
* any. I.e. this table keeps track of
|
||||
* invisible and stripped continuation lines.
|
||||
* Its keys are Tcl_Obj pointers, the values
|
||||
* are ContLineLoc pointers. See the file
|
||||
* tclCompile.h for the definition of this
|
||||
* structure, and for references to all
|
||||
* related places in the core. */
|
||||
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
|
||||
typedef struct ThreadSpecificData {
|
||||
Tcl_HashTable *objThreadMap;/* Thread local table that is used to check
|
||||
* that a Tcl_Obj was not allocated by some
|
||||
* other thread. */
|
||||
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
|
||||
} ThreadSpecificData;
|
||||
|
||||
static Tcl_ThreadDataKey dataKey;
|
||||
|
||||
static void ContLineLocFree(char *clientData);
|
||||
static void TclThreadFinalizeContLines(ClientData clientData);
|
||||
static ThreadSpecificData *TclGetContLineTable(void);
|
||||
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
|
||||
|
||||
/*
|
||||
* Nested Tcl_Obj deletion management support
|
||||
@@ -510,341 +495,6 @@ TclFinalizeObjects(void)
|
||||
Tcl_MutexUnlock(&tclObjMutex);
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclGetContLineTable --
|
||||
*
|
||||
* This procedure is a helper which returns the thread-specific
|
||||
* hash-table used to track continuation line information associated with
|
||||
* Tcl_Obj*, and the objThreadMap, etc.
|
||||
*
|
||||
* Results:
|
||||
* A reference to the thread-data.
|
||||
*
|
||||
* Side effects:
|
||||
* May allocate memory for the thread-data.
|
||||
*
|
||||
* TIP #280
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
static ThreadSpecificData *
|
||||
TclGetContLineTable(void)
|
||||
{
|
||||
/*
|
||||
* Initialize the hashtable tracking invisible continuation lines. For
|
||||
* the release we use a thread exit handler to ensure that this is done
|
||||
* before TSD blocks are made invalid. The TclFinalizeObjects() which
|
||||
* would be the natural place for this is invoked afterwards, meaning that
|
||||
* we try to operate on a data structure already gone.
|
||||
*/
|
||||
|
||||
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
||||
|
||||
if (!tsdPtr->lineCLPtr) {
|
||||
tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable));
|
||||
Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
|
||||
Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL);
|
||||
}
|
||||
return tsdPtr;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclContinuationsEnter --
|
||||
*
|
||||
* This procedure is a helper which saves the continuation line
|
||||
* information associated with a Tcl_Obj*.
|
||||
*
|
||||
* Results:
|
||||
* A reference to the newly created continuation line location table.
|
||||
*
|
||||
* Side effects:
|
||||
* Allocates memory for the table of continuation line locations.
|
||||
*
|
||||
* TIP #280
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
ContLineLoc *
|
||||
TclContinuationsEnter(
|
||||
Tcl_Obj *objPtr,
|
||||
int num,
|
||||
int *loc)
|
||||
{
|
||||
int newEntry;
|
||||
ThreadSpecificData *tsdPtr = TclGetContLineTable();
|
||||
Tcl_HashEntry *hPtr =
|
||||
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
|
||||
ContLineLoc *clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int));
|
||||
|
||||
if (!newEntry) {
|
||||
/*
|
||||
* We're entering ContLineLoc data for the same value more than one
|
||||
* time. Taking care not to leak the old entry.
|
||||
*
|
||||
* This can happen when literals in a proc body are shared. See for
|
||||
* example test info-30.19 where the action (code) for all branches of
|
||||
* the switch command is identical, mapping them all to the same
|
||||
* literal. An interesting result of this is that the number and
|
||||
* locations (offset) of invisible continuation lines in the literal
|
||||
* are the same for all occurences.
|
||||
*
|
||||
* Note that while reusing the existing entry is possible it requires
|
||||
* the same actions as for a new entry because we have to copy the
|
||||
* incoming num/loc data even so. Because we are called from
|
||||
* TclContinuationsEnterDerived for this case, which modified the
|
||||
* stored locations (Rebased to the proper relative offset). Just
|
||||
* returning the stored entry would rebase them a second time, or
|
||||
* more, hosing the data. It is easier to simply replace, as we are
|
||||
* doing.
|
||||
*/
|
||||
|
||||
ckfree(Tcl_GetHashValue(hPtr));
|
||||
}
|
||||
|
||||
clLocPtr->num = num;
|
||||
memcpy(&clLocPtr->loc, loc, num*sizeof(int));
|
||||
clLocPtr->loc[num] = CLL_END; /* Sentinel */
|
||||
Tcl_SetHashValue(hPtr, clLocPtr);
|
||||
|
||||
return clLocPtr;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclContinuationsEnterDerived --
|
||||
*
|
||||
* This procedure is a helper which computes the continuation line
|
||||
* information associated with a Tcl_Obj* cut from the middle of a
|
||||
* script.
|
||||
*
|
||||
* Results:
|
||||
* None.
|
||||
*
|
||||
* Side effects:
|
||||
* Allocates memory for the table of continuation line locations.
|
||||
*
|
||||
* TIP #280
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
void
|
||||
TclContinuationsEnterDerived(
|
||||
Tcl_Obj *objPtr,
|
||||
int start,
|
||||
int *clNext)
|
||||
{
|
||||
int length, end, num;
|
||||
int *wordCLLast = clNext;
|
||||
|
||||
/*
|
||||
* We have to handle invisible continuations lines here as well, despite
|
||||
* the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If
|
||||
* our script is the sole argument to an 'eval' command, for example, the
|
||||
* scriptCLLocPtr we are using was generated by a previous call to TST,
|
||||
* and while the words we have here may contain continuation lines they
|
||||
* are invisible already, and the inner call to TST had no bs+nl sequences
|
||||
* to trigger its code.
|
||||
*
|
||||
* Luckily for us, the table we have to create here for the current word
|
||||
* has to be a slice of the table currently in use, with the locations
|
||||
* suitably modified to be relative to the start of the word instead of
|
||||
* relative to the script.
|
||||
*
|
||||
* That is what we are doing now. Determine the slice we need, and if not
|
||||
* empty, wrap it into a new table, and save the result into our
|
||||
* thread-global hashtable, as usual.
|
||||
*/
|
||||
|
||||
/*
|
||||
* First compute the range of the word within the script. (Is there a
|
||||
* better way which doesn't shimmer?)
|
||||
*/
|
||||
|
||||
Tcl_GetStringFromObj(objPtr, &length);
|
||||
end = start + length; /* First char after the word */
|
||||
|
||||
/*
|
||||
* Then compute the table slice covering the range of the word.
|
||||
*/
|
||||
|
||||
while (*wordCLLast >= 0 && *wordCLLast < end) {
|
||||
wordCLLast++;
|
||||
}
|
||||
|
||||
/*
|
||||
* And generate the table from the slice, if it was not empty.
|
||||
*/
|
||||
|
||||
num = wordCLLast - clNext;
|
||||
if (num) {
|
||||
int i;
|
||||
ContLineLoc *clLocPtr = TclContinuationsEnter(objPtr, num, clNext);
|
||||
|
||||
/*
|
||||
* Re-base the locations.
|
||||
*/
|
||||
|
||||
for (i=0 ; i<num ; i++) {
|
||||
clLocPtr->loc[i] -= start;
|
||||
|
||||
/*
|
||||
* Continuation lines coming before the string and affecting us
|
||||
* should not happen, due to the proper maintenance of clNext
|
||||
* during compilation.
|
||||
*/
|
||||
|
||||
if (clLocPtr->loc[i] < 0) {
|
||||
Tcl_Panic("Derived ICL data for object using offsets from before the script");
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclContinuationsCopy --
|
||||
*
|
||||
* This procedure is a helper which copies the continuation line
|
||||
* information associated with a Tcl_Obj* to another Tcl_Obj*. It is
|
||||
* assumed that both contain the same string/script. Use this when a
|
||||
* script is duplicated because it was shared.
|
||||
*
|
||||
* Results:
|
||||
* None.
|
||||
*
|
||||
* Side effects:
|
||||
* Allocates memory for the table of continuation line locations.
|
||||
*
|
||||
* TIP #280
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
void
|
||||
TclContinuationsCopy(
|
||||
Tcl_Obj *objPtr,
|
||||
Tcl_Obj *originObjPtr)
|
||||
{
|
||||
ThreadSpecificData *tsdPtr = TclGetContLineTable();
|
||||
Tcl_HashEntry *hPtr =
|
||||
Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
|
||||
|
||||
if (hPtr) {
|
||||
ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr);
|
||||
|
||||
TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclContinuationsGet --
|
||||
*
|
||||
* This procedure is a helper which retrieves the continuation line
|
||||
* information associated with a Tcl_Obj*, if it has any.
|
||||
*
|
||||
* Results:
|
||||
* A reference to the continuation line location table, or NULL if the
|
||||
* Tcl_Obj* has no such information associated with it.
|
||||
*
|
||||
* Side effects:
|
||||
* None.
|
||||
*
|
||||
* TIP #280
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
ContLineLoc *
|
||||
TclContinuationsGet(
|
||||
Tcl_Obj *objPtr)
|
||||
{
|
||||
ThreadSpecificData *tsdPtr = TclGetContLineTable();
|
||||
Tcl_HashEntry *hPtr =
|
||||
Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
|
||||
|
||||
if (!hPtr) {
|
||||
return NULL;
|
||||
}
|
||||
return Tcl_GetHashValue(hPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclThreadFinalizeContLines --
|
||||
*
|
||||
* This procedure is a helper which releases all continuation line
|
||||
* information currently known. It is run as a thread exit handler.
|
||||
*
|
||||
* Results:
|
||||
* None.
|
||||
*
|
||||
* Side effects:
|
||||
* Releases memory.
|
||||
*
|
||||
* TIP #280
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
static void
|
||||
TclThreadFinalizeContLines(
|
||||
ClientData clientData)
|
||||
{
|
||||
/*
|
||||
* Release the hashtable tracking invisible continuation lines.
|
||||
*/
|
||||
|
||||
ThreadSpecificData *tsdPtr = TclGetContLineTable();
|
||||
Tcl_HashEntry *hPtr;
|
||||
Tcl_HashSearch hSearch;
|
||||
|
||||
for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
|
||||
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
|
||||
/*
|
||||
* We are not using Tcl_EventuallyFree (as in TclFreeObj()) because
|
||||
* here we can be sure that the compiler will not hold references to
|
||||
* the data in the hashtable, and using TEF might bork the
|
||||
* finalization sequence.
|
||||
*/
|
||||
|
||||
ContLineLocFree(Tcl_GetHashValue(hPtr));
|
||||
Tcl_DeleteHashEntry(hPtr);
|
||||
}
|
||||
Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
|
||||
ckfree(tsdPtr->lineCLPtr);
|
||||
tsdPtr->lineCLPtr = NULL;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* ContLineLocFree --
|
||||
*
|
||||
* The freProc for continuation line location tables.
|
||||
*
|
||||
* Results:
|
||||
* None.
|
||||
*
|
||||
* Side effects:
|
||||
* Releases memory.
|
||||
*
|
||||
* TIP #280
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
static void
|
||||
ContLineLocFree(
|
||||
char *clientData)
|
||||
{
|
||||
ckfree(clientData);
|
||||
}
|
||||
|
||||
/*
|
||||
*--------------------------------------------------------------
|
||||
*
|
||||
@@ -1372,28 +1022,6 @@ TclFreeObj(
|
||||
ObjDeletionUnlock(context);
|
||||
}
|
||||
|
||||
/*
|
||||
* We cannot use TclGetContinuationTable() here, because that may
|
||||
* re-initialize the thread-data for calls coming after the finalization.
|
||||
* We have to access it using the low-level call and then check for
|
||||
* validity. This function can be called after TclFinalizeThreadData() has
|
||||
* already killed the thread-global data structures. Performing
|
||||
* TCL_TSD_INIT will leave us with an un-initialized memory block upon
|
||||
* which we crash (if we where to access the uninitialized hashtable).
|
||||
*/
|
||||
|
||||
{
|
||||
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
||||
Tcl_HashEntry *hPtr;
|
||||
|
||||
if (tsdPtr->lineCLPtr) {
|
||||
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
|
||||
if (hPtr) {
|
||||
Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree);
|
||||
Tcl_DeleteHashEntry(hPtr);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#else /* TCL_MEM_DEBUG */
|
||||
|
||||
@@ -1463,28 +1091,6 @@ TclFreeObj(
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* We cannot use TclGetContinuationTable() here, because that may
|
||||
* re-initialize the thread-data for calls coming after the finalization.
|
||||
* We have to access it using the low-level call and then check for
|
||||
* validity. This function can be called after TclFinalizeThreadData() has
|
||||
* already killed the thread-global data structures. Performing
|
||||
* TCL_TSD_INIT will leave us with an un-initialized memory block upon
|
||||
* which we crash (if we where to access the uninitialized hashtable).
|
||||
*/
|
||||
|
||||
{
|
||||
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
||||
Tcl_HashEntry *hPtr;
|
||||
|
||||
if (tsdPtr->lineCLPtr) {
|
||||
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
|
||||
if (hPtr) {
|
||||
Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree);
|
||||
Tcl_DeleteHashEntry(hPtr);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif /* TCL_MEM_DEBUG */
|
||||
|
||||
|
||||
+5
-117
@@ -1566,7 +1566,7 @@ Tcl_ParseVar(
|
||||
}
|
||||
|
||||
code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens,
|
||||
NULL, 1, NULL, NULL);
|
||||
NULL);
|
||||
TclStackFree(interp, parsePtr);
|
||||
if (code != TCL_OK) {
|
||||
return NULL;
|
||||
@@ -2110,33 +2110,13 @@ TclSubstTokens(
|
||||
* evaluate and concatenate. */
|
||||
int count, /* Number of tokens to consider at tokenPtr.
|
||||
* Must be at least 1. */
|
||||
int *tokensLeftPtr, /* If not NULL, points to memory where an
|
||||
int *tokensLeftPtr) /* If not NULL, points to memory where an
|
||||
* integer representing the number of tokens
|
||||
* left to be substituted will be written */
|
||||
int line, /* The line the script starts on. */
|
||||
int *clNextOuter, /* Information about an outer context for */
|
||||
const char *outerScript) /* continuation line data. This is set by
|
||||
* EvalEx() to properly handle [...]-nested
|
||||
* commands. The 'outerScript' refers to the
|
||||
* most-outer script containing the embedded
|
||||
* command, which is refered to by 'script'.
|
||||
* The 'clNextOuter' refers to the current
|
||||
* entry in the table of continuation lines in
|
||||
* this "master script", and the character
|
||||
* offsets are relative to the 'outerScript'
|
||||
* as well.
|
||||
*
|
||||
* If outerScript == script, then this call is
|
||||
* for words in the outer-most script or
|
||||
* command. See Tcl_EvalEx and TclEvalObjEx
|
||||
* for the places generating arguments for
|
||||
* which this is true. */
|
||||
{
|
||||
Tcl_Obj *result;
|
||||
int code = TCL_OK;
|
||||
#define NUM_STATIC_POS 20
|
||||
int isLiteral, maxNumCL, numCL, i, adjust;
|
||||
int *clPosition = NULL;
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
int inFile = iPtr->evalFlags & TCL_EVAL_FILE;
|
||||
|
||||
@@ -2150,31 +2130,6 @@ TclSubstTokens(
|
||||
* of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) and omit them.
|
||||
*/
|
||||
|
||||
/*
|
||||
* For the handling of continuation lines in literals we first check if
|
||||
* this is actually a literal. For if not we can forego the additional
|
||||
* processing. Otherwise we pre-allocate a small table to store the
|
||||
* locations of all continuation lines we find in this literal, if any.
|
||||
* The table is extended if needed.
|
||||
*/
|
||||
|
||||
numCL = 0;
|
||||
maxNumCL = 0;
|
||||
isLiteral = 1;
|
||||
for (i=0 ; i < count; i++) {
|
||||
if ((tokenPtr[i].type != TCL_TOKEN_TEXT)
|
||||
&& (tokenPtr[i].type != TCL_TOKEN_BS)) {
|
||||
isLiteral = 0;
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
if (isLiteral) {
|
||||
maxNumCL = NUM_STATIC_POS;
|
||||
clPosition = ckalloc(maxNumCL * sizeof(int));
|
||||
}
|
||||
|
||||
adjust = 0;
|
||||
result = NULL;
|
||||
for (; count>0 && code==TCL_OK ; count--, tokenPtr++) {
|
||||
Tcl_Obj *appendObj = NULL;
|
||||
@@ -2192,47 +2147,9 @@ TclSubstTokens(
|
||||
appendByteLength = TclParseBackslash(tokenPtr->start,
|
||||
tokenPtr->size, NULL, utfCharBytes);
|
||||
append = utfCharBytes;
|
||||
|
||||
/*
|
||||
* If the backslash sequence we found is in a literal, and
|
||||
* represented a continuation line, we compute and store its
|
||||
* location (as char offset to the beginning of the _result_
|
||||
* script). We may have to extend the table of locations.
|
||||
*
|
||||
* Note that the continuation line information is relevant even if
|
||||
* the word we are processing is not a literal, as it can affect
|
||||
* nested commands. See the branch for TCL_TOKEN_COMMAND below,
|
||||
* where the adjustment we are tracking here is taken into
|
||||
* account. The good thing is that we do not need a table of
|
||||
* everything, just the number of lines we have to add as
|
||||
* correction.
|
||||
*/
|
||||
|
||||
if ((appendByteLength == 1) && (utfCharBytes[0] == ' ')
|
||||
&& (tokenPtr->start[1] == '\n')) {
|
||||
if (isLiteral) {
|
||||
int clPos;
|
||||
|
||||
if (result == 0) {
|
||||
clPos = 0;
|
||||
} else {
|
||||
Tcl_GetStringFromObj(result, &clPos);
|
||||
}
|
||||
|
||||
if (numCL >= maxNumCL) {
|
||||
maxNumCL *= 2;
|
||||
clPosition = ckrealloc(clPosition,
|
||||
maxNumCL * sizeof(int));
|
||||
}
|
||||
clPosition[numCL] = clPos;
|
||||
numCL++;
|
||||
}
|
||||
adjust++;
|
||||
}
|
||||
break;
|
||||
|
||||
case TCL_TOKEN_COMMAND: {
|
||||
/* TIP #280: Transfer line information to nested command */
|
||||
iPtr->numLevels++;
|
||||
code = TclInterpReady(interp);
|
||||
if (code == TCL_OK) {
|
||||
@@ -2240,16 +2157,8 @@ TclSubstTokens(
|
||||
* Test cases: info-30.{6,8,9}
|
||||
*/
|
||||
|
||||
int theline;
|
||||
|
||||
TclAdvanceContinuations(&line, &clNextOuter,
|
||||
tokenPtr->start - outerScript);
|
||||
theline = line + adjust;
|
||||
code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
|
||||
0, theline, clNextOuter, outerScript);
|
||||
|
||||
TclAdvanceLines(&line, tokenPtr->start+1,
|
||||
tokenPtr->start + tokenPtr->size - 1);
|
||||
code = Tcl_EvalEx(interp, tokenPtr->start+1,
|
||||
tokenPtr->size-2, 0);
|
||||
|
||||
/*
|
||||
* Restore flag reset by nested eval for future bracketed
|
||||
@@ -2276,7 +2185,7 @@ TclSubstTokens(
|
||||
*/
|
||||
|
||||
code = TclSubstTokens(interp, tokenPtr+2,
|
||||
tokenPtr->numComponents - 1, NULL, line, NULL, NULL);
|
||||
tokenPtr->numComponents - 1, NULL);
|
||||
arrayIndex = Tcl_GetObjResult(interp);
|
||||
Tcl_IncrRefCount(arrayIndex);
|
||||
}
|
||||
@@ -2360,27 +2269,6 @@ TclSubstTokens(
|
||||
if (code != TCL_ERROR) { /* Keep error message in result! */
|
||||
if (result != NULL) {
|
||||
Tcl_SetObjResult(interp, result);
|
||||
|
||||
/*
|
||||
* If the code found continuation lines (which implies that this
|
||||
* word is a literal), then we store the accumulated table of
|
||||
* locations in the thread-global data structure for the bytecode
|
||||
* compiler to find later, assuming that the literal is a script
|
||||
* which will be compiled.
|
||||
*/
|
||||
|
||||
if (numCL) {
|
||||
TclContinuationsEnter(result, numCL, clPosition);
|
||||
}
|
||||
|
||||
/*
|
||||
* Release the temp table we used to collect the locations of
|
||||
* continuation lines, if any.
|
||||
*/
|
||||
|
||||
if (maxNumCL) {
|
||||
ckfree(clPosition);
|
||||
}
|
||||
} else {
|
||||
Tcl_ResetResult(interp);
|
||||
}
|
||||
|
||||
+6
-509
@@ -14,7 +14,7 @@
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
#include "tclCompile.h"
|
||||
#include "tclEngine.h"
|
||||
#include "tclOOInt.h"
|
||||
|
||||
/*
|
||||
@@ -25,7 +25,6 @@
|
||||
typedef struct {
|
||||
int isRootEnsemble;
|
||||
Command cmd;
|
||||
ExtraFrameInfo efi;
|
||||
} ApplyExtraData;
|
||||
|
||||
/*
|
||||
@@ -213,101 +212,6 @@ Tcl_ProcObjCmd(
|
||||
|
||||
procPtr->cmdPtr = (Command *) cmd;
|
||||
|
||||
/*
|
||||
* TIP #280: Remember the line the procedure body is starting on. In a
|
||||
* bytecode context we ask the engine to provide us with the necessary
|
||||
* information. This is for the initialization of the byte code compiler
|
||||
* when the body is used for the first time.
|
||||
*
|
||||
* This code is nearly identical to the #280 code in SetLambdaFromAny, see
|
||||
* this file. The differences are the different index of the body in the
|
||||
* line array of the context, and the lamdba code requires some special
|
||||
* processing. Find a way to factor the common elements into a single
|
||||
* function.
|
||||
*/
|
||||
|
||||
if (iPtr->cmdFramePtr) {
|
||||
CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame));
|
||||
|
||||
*contextPtr = *iPtr->cmdFramePtr;
|
||||
if (contextPtr->type == TCL_LOCATION_BC) {
|
||||
/*
|
||||
* Retrieve source information from the bytecode, if possible. If
|
||||
* the information is retrieved successfully, context.type will be
|
||||
* TCL_LOCATION_SOURCE and the reference held by
|
||||
* context.data.eval.path will be counted.
|
||||
*/
|
||||
|
||||
TclGetSrcInfoForPc(contextPtr);
|
||||
} else if (contextPtr->type == TCL_LOCATION_SOURCE) {
|
||||
/*
|
||||
* The copy into 'context' up above has created another reference
|
||||
* to 'context.data.eval.path'; account for it.
|
||||
*/
|
||||
|
||||
Tcl_IncrRefCount(contextPtr->data.eval.path);
|
||||
}
|
||||
|
||||
if (contextPtr->type == TCL_LOCATION_SOURCE) {
|
||||
/*
|
||||
* We can account for source location within a proc only if the
|
||||
* proc body was not created by substitution.
|
||||
*/
|
||||
|
||||
if (contextPtr->line
|
||||
&& (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
|
||||
int isNew;
|
||||
Tcl_HashEntry *hePtr;
|
||||
CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
|
||||
|
||||
cfPtr->level = -1;
|
||||
cfPtr->type = contextPtr->type;
|
||||
cfPtr->line = ckalloc(sizeof(int));
|
||||
cfPtr->line[0] = contextPtr->line[3];
|
||||
cfPtr->nline = 1;
|
||||
cfPtr->framePtr = NULL;
|
||||
cfPtr->nextPtr = NULL;
|
||||
|
||||
cfPtr->data.eval.path = contextPtr->data.eval.path;
|
||||
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
||||
|
||||
cfPtr->cmd.str.cmd = NULL;
|
||||
cfPtr->cmd.str.len = 0;
|
||||
|
||||
hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
|
||||
procPtr, &isNew);
|
||||
if (!isNew) {
|
||||
/*
|
||||
* Get the old command frame and release it. See also
|
||||
* TclProcCleanupProc in this file. Currently it seems as
|
||||
* if only the procbodytest::proc command of the testsuite
|
||||
* is able to trigger this situation.
|
||||
*/
|
||||
|
||||
CmdFrame *cfOldPtr = Tcl_GetHashValue(hePtr);
|
||||
|
||||
if (cfOldPtr->type == TCL_LOCATION_SOURCE) {
|
||||
Tcl_DecrRefCount(cfOldPtr->data.eval.path);
|
||||
cfOldPtr->data.eval.path = NULL;
|
||||
}
|
||||
ckfree(cfOldPtr->line);
|
||||
cfOldPtr->line = NULL;
|
||||
ckfree(cfOldPtr);
|
||||
}
|
||||
Tcl_SetHashValue(hePtr, cfPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* 'contextPtr' is going out of scope; account for the reference
|
||||
* that it's holding to the path name.
|
||||
*/
|
||||
|
||||
Tcl_DecrRefCount(contextPtr->data.eval.path);
|
||||
contextPtr->data.eval.path = NULL;
|
||||
}
|
||||
TclStackFree(interp, contextPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
* Optimize for no-op procs: if the body is not precompiled (like a TclPro
|
||||
* procbody), and the argument list is just "args" and the body is empty,
|
||||
@@ -442,18 +346,8 @@ TclCreateProc(
|
||||
*/
|
||||
|
||||
if (Tcl_IsShared(bodyPtr)) {
|
||||
Tcl_Obj *sharedBodyPtr = bodyPtr;
|
||||
|
||||
bytes = TclGetStringFromObj(bodyPtr, &length);
|
||||
bodyPtr = Tcl_NewStringObj(bytes, length);
|
||||
|
||||
/*
|
||||
* TIP #280.
|
||||
* Ensure that the continuation line data for the original body is
|
||||
* not lost and applies to the new body as well.
|
||||
*/
|
||||
|
||||
TclContinuationsCopy(bodyPtr, sharedBodyPtr);
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -967,8 +861,6 @@ TclNRUplevelObjCmd(
|
||||
{
|
||||
|
||||
register Interp *iPtr = (Interp *) interp;
|
||||
CmdFrame *invoker = NULL;
|
||||
int word = 0;
|
||||
int result;
|
||||
CallFrame *savedVarFramePtr, *framePtr;
|
||||
Tcl_Obj *objPtr;
|
||||
@@ -1005,13 +897,7 @@ TclNRUplevelObjCmd(
|
||||
*/
|
||||
|
||||
if (objc == 1) {
|
||||
/*
|
||||
* TIP #280. Make actual argument location available to eval'd script
|
||||
*/
|
||||
|
||||
TclArgumentGet(interp, objv[0], &invoker, &word);
|
||||
objPtr = objv[0];
|
||||
|
||||
} else {
|
||||
/*
|
||||
* More than one argument: concatenate them together with spaces
|
||||
@@ -1022,9 +908,9 @@ TclNRUplevelObjCmd(
|
||||
objPtr = Tcl_ConcatObj(objc, objv);
|
||||
}
|
||||
|
||||
TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL,
|
||||
Tcl_NRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL,
|
||||
NULL);
|
||||
return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
|
||||
return TclNREvalObjEx(interp, objPtr, 0);
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -1802,14 +1688,6 @@ TclNRInterpProcCore(
|
||||
TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
|
||||
a[8], a[9]);
|
||||
}
|
||||
if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) {
|
||||
Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
|
||||
const char *a[6]; int i[2];
|
||||
|
||||
TclDTraceInfo(info, a, i);
|
||||
TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]);
|
||||
TclDecrRefCount(info);
|
||||
}
|
||||
if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
|
||||
int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
|
||||
|
||||
@@ -1835,7 +1713,7 @@ TclNRInterpProcCore(
|
||||
procPtr->refCount++;
|
||||
codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
|
||||
|
||||
TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
|
||||
Tcl_NRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
|
||||
NULL, NULL);
|
||||
return TclNRExecuteByteCode(interp, codePtr);
|
||||
}
|
||||
@@ -2015,8 +1893,6 @@ TclProcCompileProc(
|
||||
}
|
||||
|
||||
if (bodyPtr->typePtr != &tclByteCodeType) {
|
||||
Tcl_HashEntry *hePtr;
|
||||
|
||||
#ifdef TCL_COMPILE_DEBUG
|
||||
if (tclTraceCompile >= 1) {
|
||||
/*
|
||||
@@ -2082,21 +1958,7 @@ TclProcCompileProc(
|
||||
TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr,
|
||||
/* isProcCallFrame */ 0);
|
||||
|
||||
/*
|
||||
* TIP #280: We get the invoking context from the cmdFrame which
|
||||
* was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
|
||||
*/
|
||||
|
||||
hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
|
||||
|
||||
/*
|
||||
* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
|
||||
*/
|
||||
|
||||
iPtr->invokeWord = 0;
|
||||
iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL);
|
||||
tclByteCodeType.setFromAnyProc(interp, bodyPtr);
|
||||
iPtr->invokeCmdFramePtr = NULL;
|
||||
TclPopStackFrame(interp);
|
||||
} else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
|
||||
/*
|
||||
@@ -2202,9 +2064,6 @@ TclProcCleanupProc(
|
||||
Tcl_Obj *bodyPtr = procPtr->bodyPtr;
|
||||
Tcl_Obj *defPtr;
|
||||
Tcl_ResolvedVarInfo *resVarInfo;
|
||||
Tcl_HashEntry *hePtr = NULL;
|
||||
CmdFrame *cfPtr = NULL;
|
||||
Interp *iPtr = procPtr->iPtr;
|
||||
|
||||
if (bodyPtr != NULL) {
|
||||
Tcl_DecrRefCount(bodyPtr);
|
||||
@@ -2229,34 +2088,6 @@ TclProcCleanupProc(
|
||||
localPtr = nextPtr;
|
||||
}
|
||||
ckfree(procPtr);
|
||||
|
||||
/*
|
||||
* TIP #280: Release the location data associated with this Proc
|
||||
* structure, if any. The interpreter may not exist (For example for
|
||||
* procbody structures created by tbcload.
|
||||
*/
|
||||
|
||||
if (iPtr == NULL) {
|
||||
return;
|
||||
}
|
||||
|
||||
hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
|
||||
if (!hePtr) {
|
||||
return;
|
||||
}
|
||||
|
||||
cfPtr = Tcl_GetHashValue(hePtr);
|
||||
|
||||
if (cfPtr) {
|
||||
if (cfPtr->type == TCL_LOCATION_SOURCE) {
|
||||
Tcl_DecrRefCount(cfPtr->data.eval.path);
|
||||
cfPtr->data.eval.path = NULL;
|
||||
}
|
||||
ckfree(cfPtr->line);
|
||||
cfPtr->line = NULL;
|
||||
ckfree(cfPtr);
|
||||
}
|
||||
Tcl_DeleteHashEntry(hePtr);
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -2484,11 +2315,9 @@ SetLambdaFromAny(
|
||||
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
|
||||
register Tcl_Obj *objPtr) /* The object to convert. */
|
||||
{
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
const char *name;
|
||||
Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
|
||||
int isNew, objc, result;
|
||||
CmdFrame *cfPtr = NULL;
|
||||
int objc, result;
|
||||
Proc *procPtr;
|
||||
|
||||
if (interp == NULL) {
|
||||
@@ -2533,93 +2362,6 @@ SetLambdaFromAny(
|
||||
|
||||
procPtr->cmdPtr = NULL;
|
||||
|
||||
/*
|
||||
* TIP #280: Remember the line the apply body is starting on. In a Byte
|
||||
* code context we ask the engine to provide us with the necessary
|
||||
* information. This is for the initialization of the byte code compiler
|
||||
* when the body is used for the first time.
|
||||
*
|
||||
* NOTE: The body is the second word in the 'objPtr'. Its location,
|
||||
* accessible through 'context.line[1]' (see below) is therefore only the
|
||||
* first approximation of the actual line the body is on. We have to use
|
||||
* the string rep of the 'objPtr' to determine the exact line. This is
|
||||
* available already through 'name'. Use 'TclListLines', see 'switch'
|
||||
* (tclCmdMZ.c).
|
||||
*
|
||||
* This code is nearly identical to the #280 code in Tcl_ProcObjCmd, see
|
||||
* this file. The differences are the different index of the body in the
|
||||
* line array of the context, and the special processing mentioned in the
|
||||
* previous paragraph to track into the list. Find a way to factor the
|
||||
* common elements into a single function.
|
||||
*/
|
||||
|
||||
if (iPtr->cmdFramePtr) {
|
||||
CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame));
|
||||
|
||||
*contextPtr = *iPtr->cmdFramePtr;
|
||||
if (contextPtr->type == TCL_LOCATION_BC) {
|
||||
/*
|
||||
* Retrieve the source context from the bytecode. This call
|
||||
* accounts for the reference to the source file, if any, held in
|
||||
* 'context.data.eval.path'.
|
||||
*/
|
||||
|
||||
TclGetSrcInfoForPc(contextPtr);
|
||||
} else if (contextPtr->type == TCL_LOCATION_SOURCE) {
|
||||
/*
|
||||
* We created a new reference to the source file path name when we
|
||||
* created 'context' above. Account for the reference.
|
||||
*/
|
||||
|
||||
Tcl_IncrRefCount(contextPtr->data.eval.path);
|
||||
|
||||
}
|
||||
|
||||
if (contextPtr->type == TCL_LOCATION_SOURCE) {
|
||||
/*
|
||||
* We can record source location within a lambda only if the body
|
||||
* was not created by substitution.
|
||||
*/
|
||||
|
||||
if (contextPtr->line
|
||||
&& (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) {
|
||||
int buf[2];
|
||||
|
||||
/*
|
||||
* Move from approximation (line of list cmd word) to actual
|
||||
* location (line of 2nd list element).
|
||||
*/
|
||||
|
||||
cfPtr = ckalloc(sizeof(CmdFrame));
|
||||
TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL);
|
||||
|
||||
cfPtr->level = -1;
|
||||
cfPtr->type = contextPtr->type;
|
||||
cfPtr->line = ckalloc(sizeof(int));
|
||||
cfPtr->line[0] = buf[1];
|
||||
cfPtr->nline = 1;
|
||||
cfPtr->framePtr = NULL;
|
||||
cfPtr->nextPtr = NULL;
|
||||
|
||||
cfPtr->data.eval.path = contextPtr->data.eval.path;
|
||||
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
||||
|
||||
cfPtr->cmd.str.cmd = NULL;
|
||||
cfPtr->cmd.str.len = 0;
|
||||
}
|
||||
|
||||
/*
|
||||
* 'contextPtr' is going out of scope. Release the reference that
|
||||
* it's holding to the source file path
|
||||
*/
|
||||
|
||||
Tcl_DecrRefCount(contextPtr->data.eval.path);
|
||||
}
|
||||
TclStackFree(interp, contextPtr);
|
||||
}
|
||||
Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr,
|
||||
&isNew), cfPtr);
|
||||
|
||||
/*
|
||||
* Set the namespace for this lambda: given by objv[2] understood as a
|
||||
* global reference, or else global per default.
|
||||
@@ -2759,22 +2501,6 @@ TclNRApplyObjCmd(
|
||||
procPtr->cmdPtr = &extraPtr->cmd;
|
||||
extraPtr->cmd.nsPtr = (Namespace *) nsPtr;
|
||||
|
||||
/*
|
||||
* TIP#280 (semi-)HACK!
|
||||
*
|
||||
* Using cmd.clientData to tell [info frame] how to render the lambdaPtr.
|
||||
* The InfoFrameCmd will detect this case by testing cmd.hPtr for NULL.
|
||||
* This condition holds here because of the memset() above, and nowhere
|
||||
* else (in the core). Regular commands always have a valid hPtr, and
|
||||
* lambda's never.
|
||||
*/
|
||||
|
||||
extraPtr->efi.length = 1;
|
||||
extraPtr->efi.fields[0].name = "lambda";
|
||||
extraPtr->efi.fields[0].proc = NULL;
|
||||
extraPtr->efi.fields[0].clientData = lambdaPtr;
|
||||
extraPtr->cmd.clientData = &extraPtr->efi;
|
||||
|
||||
isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
|
||||
if (isRootEnsemble) {
|
||||
iPtr->ensembleRewrite.sourceObjs = objv;
|
||||
@@ -2787,7 +2513,7 @@ TclNRApplyObjCmd(
|
||||
|
||||
result = PushProcCallFrame(procPtr, interp, objc, objv, 1);
|
||||
if (result == TCL_OK) {
|
||||
TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL);
|
||||
Tcl_NRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL);
|
||||
result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
|
||||
}
|
||||
return result;
|
||||
@@ -2844,235 +2570,6 @@ MakeLambdaError(
|
||||
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* Tcl_DisassembleObjCmd --
|
||||
*
|
||||
* Implementation of the "::tcl::unsupported::disassemble" command. This
|
||||
* command is not documented, but will disassemble procedures, lambda
|
||||
* terms and general scripts. Note that will compile terms if necessary
|
||||
* in order to disassemble them.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
int
|
||||
Tcl_DisassembleObjCmd(
|
||||
ClientData dummy, /* Not used. */
|
||||
Tcl_Interp *interp, /* Current interpreter. */
|
||||
int objc, /* Number of arguments. */
|
||||
Tcl_Obj *const objv[]) /* Argument objects. */
|
||||
{
|
||||
static const char *const types[] = {
|
||||
"lambda", "method", "objmethod", "proc", "script", NULL
|
||||
};
|
||||
enum Types {
|
||||
DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC,
|
||||
DISAS_SCRIPT
|
||||
};
|
||||
int idx, result;
|
||||
Tcl_Obj *codeObjPtr = NULL;
|
||||
Proc *procPtr = NULL;
|
||||
Tcl_HashEntry *hPtr;
|
||||
Object *oPtr;
|
||||
|
||||
if (objc < 2) {
|
||||
Tcl_WrongNumArgs(interp, 1, objv, "type ...");
|
||||
return TCL_ERROR;
|
||||
}
|
||||
if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
switch ((enum Types) idx) {
|
||||
case DISAS_LAMBDA: {
|
||||
Command cmd;
|
||||
Tcl_Obj *nsObjPtr;
|
||||
Tcl_Namespace *nsPtr;
|
||||
|
||||
/*
|
||||
* Compile (if uncompiled) and disassemble a lambda term.
|
||||
*/
|
||||
|
||||
if (objc != 3) {
|
||||
Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm");
|
||||
return TCL_ERROR;
|
||||
}
|
||||
if (objv[2]->typePtr == &lambdaType) {
|
||||
procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
|
||||
}
|
||||
if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) {
|
||||
result = SetLambdaFromAny(interp, objv[2]);
|
||||
if (result != TCL_OK) {
|
||||
return result;
|
||||
}
|
||||
procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
|
||||
}
|
||||
|
||||
memset(&cmd, 0, sizeof(Command));
|
||||
nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2;
|
||||
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
|
||||
if (result != TCL_OK) {
|
||||
return result;
|
||||
}
|
||||
cmd.nsPtr = (Namespace *) nsPtr;
|
||||
procPtr->cmdPtr = &cmd;
|
||||
result = PushProcCallFrame(procPtr, interp, objc, objv, 1);
|
||||
if (result != TCL_OK) {
|
||||
return result;
|
||||
}
|
||||
TclPopStackFrame(interp);
|
||||
codeObjPtr = procPtr->bodyPtr;
|
||||
break;
|
||||
}
|
||||
case DISAS_PROC:
|
||||
if (objc != 3) {
|
||||
Tcl_WrongNumArgs(interp, 2, objv, "procName");
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
|
||||
if (procPtr == NULL) {
|
||||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||||
"\"%s\" isn't a procedure", TclGetString(objv[2])));
|
||||
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
|
||||
TclGetString(objv[2]), NULL);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
/*
|
||||
* Compile (if uncompiled) and disassemble a procedure.
|
||||
*/
|
||||
|
||||
result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1);
|
||||
if (result != TCL_OK) {
|
||||
return result;
|
||||
}
|
||||
TclPopStackFrame(interp);
|
||||
codeObjPtr = procPtr->bodyPtr;
|
||||
break;
|
||||
case DISAS_SCRIPT:
|
||||
/*
|
||||
* Compile and disassemble a script.
|
||||
*/
|
||||
|
||||
if (objc != 3) {
|
||||
Tcl_WrongNumArgs(interp, 2, objv, "script");
|
||||
return TCL_ERROR;
|
||||
}
|
||||
if (objv[2]->typePtr != &tclByteCodeType) {
|
||||
if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){
|
||||
return TCL_ERROR;
|
||||
}
|
||||
}
|
||||
codeObjPtr = objv[2];
|
||||
break;
|
||||
|
||||
case DISAS_CLASS_METHOD:
|
||||
if (objc != 4) {
|
||||
Tcl_WrongNumArgs(interp, 2, objv, "className methodName");
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
/*
|
||||
* Look up the body of a class method.
|
||||
*/
|
||||
|
||||
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
|
||||
if (oPtr == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
if (oPtr->classPtr == NULL) {
|
||||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||||
"\"%s\" is not a class", TclGetString(objv[2])));
|
||||
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
|
||||
TclGetString(objv[2]), NULL);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
|
||||
(char *) objv[3]);
|
||||
goto methodBody;
|
||||
case DISAS_OBJECT_METHOD:
|
||||
if (objc != 4) {
|
||||
Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName");
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
/*
|
||||
* Look up the body of an instance method.
|
||||
*/
|
||||
|
||||
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
|
||||
if (oPtr == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
if (oPtr->methodsPtr == NULL) {
|
||||
goto unknownMethod;
|
||||
}
|
||||
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]);
|
||||
|
||||
/*
|
||||
* Compile (if necessary) and disassemble a method body.
|
||||
*/
|
||||
|
||||
methodBody:
|
||||
if (hPtr == NULL) {
|
||||
unknownMethod:
|
||||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||||
"unknown method \"%s\"", TclGetString(objv[3])));
|
||||
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
|
||||
TclGetString(objv[3]), NULL);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
|
||||
if (procPtr == NULL) {
|
||||
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
||||
"body not available for this kind of method", -1));
|
||||
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
|
||||
"METHODTYPE", NULL);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
|
||||
Command cmd;
|
||||
|
||||
/*
|
||||
* Yes, this is ugly, but we need to pass the namespace in to the
|
||||
* compiler in two places.
|
||||
*/
|
||||
|
||||
cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
|
||||
procPtr->cmdPtr = &cmd;
|
||||
result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
|
||||
(Namespace *) oPtr->namespacePtr, "body of method",
|
||||
TclGetString(objv[3]));
|
||||
procPtr->cmdPtr = NULL;
|
||||
if (result != TCL_OK) {
|
||||
return result;
|
||||
}
|
||||
}
|
||||
codeObjPtr = procPtr->bodyPtr;
|
||||
break;
|
||||
default:
|
||||
CLANG_ASSERT(0);
|
||||
}
|
||||
|
||||
/*
|
||||
* Do the actual disassembly.
|
||||
*/
|
||||
|
||||
if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags
|
||||
& TCL_BYTECODE_PRECOMPILED) {
|
||||
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
||||
"may not disassemble prebuilt bytecode", -1));
|
||||
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
|
||||
"BYTECODE", NULL);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
/*
|
||||
* Local Variables:
|
||||
* mode: c
|
||||
|
||||
+1
-115
@@ -17,7 +17,7 @@
|
||||
|
||||
enum returnKeys {
|
||||
KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE,
|
||||
KEY_LEVEL, KEY_OPTIONS, KEY_ERRORSTACK, KEY_LAST
|
||||
KEY_LEVEL, KEY_OPTIONS, KEY_LAST
|
||||
};
|
||||
|
||||
/*
|
||||
@@ -44,8 +44,6 @@ typedef struct InterpState {
|
||||
Tcl_Obj *errorCode;
|
||||
Tcl_Obj *returnOpts;
|
||||
Tcl_Obj *objResult;
|
||||
Tcl_Obj *errorStack;
|
||||
int resetErrorStack;
|
||||
} InterpState;
|
||||
|
||||
/*
|
||||
@@ -82,8 +80,6 @@ Tcl_SaveInterpState(
|
||||
statePtr->returnLevel = iPtr->returnLevel;
|
||||
statePtr->returnCode = iPtr->returnCode;
|
||||
statePtr->errorInfo = iPtr->errorInfo;
|
||||
statePtr->errorStack = iPtr->errorStack;
|
||||
statePtr->resetErrorStack = iPtr->resetErrorStack;
|
||||
if (statePtr->errorInfo) {
|
||||
Tcl_IncrRefCount(statePtr->errorInfo);
|
||||
}
|
||||
@@ -95,9 +91,6 @@ Tcl_SaveInterpState(
|
||||
if (statePtr->returnOpts) {
|
||||
Tcl_IncrRefCount(statePtr->returnOpts);
|
||||
}
|
||||
if (statePtr->errorStack) {
|
||||
Tcl_IncrRefCount(statePtr->errorStack);
|
||||
}
|
||||
statePtr->objResult = Tcl_GetObjResult(interp);
|
||||
Tcl_IncrRefCount(statePtr->objResult);
|
||||
return (Tcl_InterpState) statePtr;
|
||||
@@ -135,7 +128,6 @@ Tcl_RestoreInterpState(
|
||||
|
||||
iPtr->returnLevel = statePtr->returnLevel;
|
||||
iPtr->returnCode = statePtr->returnCode;
|
||||
iPtr->resetErrorStack = statePtr->resetErrorStack;
|
||||
if (iPtr->errorInfo) {
|
||||
Tcl_DecrRefCount(iPtr->errorInfo);
|
||||
}
|
||||
@@ -150,13 +142,6 @@ Tcl_RestoreInterpState(
|
||||
if (iPtr->errorCode) {
|
||||
Tcl_IncrRefCount(iPtr->errorCode);
|
||||
}
|
||||
if (iPtr->errorStack) {
|
||||
Tcl_DecrRefCount(iPtr->errorStack);
|
||||
}
|
||||
iPtr->errorStack = statePtr->errorStack;
|
||||
if (iPtr->errorStack) {
|
||||
Tcl_IncrRefCount(iPtr->errorStack);
|
||||
}
|
||||
if (iPtr->returnOpts) {
|
||||
Tcl_DecrRefCount(iPtr->returnOpts);
|
||||
}
|
||||
@@ -201,9 +186,6 @@ Tcl_DiscardInterpState(
|
||||
if (statePtr->returnOpts) {
|
||||
Tcl_DecrRefCount(statePtr->returnOpts);
|
||||
}
|
||||
if (statePtr->errorStack) {
|
||||
Tcl_DecrRefCount(statePtr->errorStack);
|
||||
}
|
||||
Tcl_DecrRefCount(statePtr->objResult);
|
||||
ckfree(statePtr);
|
||||
}
|
||||
@@ -938,7 +920,6 @@ Tcl_ResetResult(
|
||||
Tcl_DecrRefCount(iPtr->errorInfo);
|
||||
iPtr->errorInfo = NULL;
|
||||
}
|
||||
iPtr->resetErrorStack = 1;
|
||||
iPtr->returnLevel = 1;
|
||||
iPtr->returnCode = TCL_OK;
|
||||
if (iPtr->returnOpts) {
|
||||
@@ -1173,7 +1154,6 @@ GetKeys(void)
|
||||
TclNewLiteralStringObj(keys[KEY_ERRORCODE], "-errorcode");
|
||||
TclNewLiteralStringObj(keys[KEY_ERRORINFO], "-errorinfo");
|
||||
TclNewLiteralStringObj(keys[KEY_ERRORLINE], "-errorline");
|
||||
TclNewLiteralStringObj(keys[KEY_ERRORSTACK],"-errorstack");
|
||||
TclNewLiteralStringObj(keys[KEY_LEVEL], "-level");
|
||||
TclNewLiteralStringObj(keys[KEY_OPTIONS], "-options");
|
||||
|
||||
@@ -1280,40 +1260,6 @@ TclProcessReturn(
|
||||
iPtr->flags |= ERR_ALREADY_LOGGED;
|
||||
}
|
||||
}
|
||||
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
|
||||
&valuePtr);
|
||||
if (valuePtr != NULL) {
|
||||
int len, valueObjc;
|
||||
Tcl_Obj **valueObjv;
|
||||
|
||||
if (Tcl_IsShared(iPtr->errorStack)) {
|
||||
Tcl_Obj *newObj;
|
||||
|
||||
newObj = Tcl_DuplicateObj(iPtr->errorStack);
|
||||
Tcl_DecrRefCount(iPtr->errorStack);
|
||||
Tcl_IncrRefCount(newObj);
|
||||
iPtr->errorStack = newObj;
|
||||
}
|
||||
|
||||
/*
|
||||
* List extraction done after duplication to avoid moving the rug
|
||||
* if someone does [return -errorstack [info errorstack]]
|
||||
*/
|
||||
|
||||
if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc,
|
||||
&valueObjv) == TCL_ERROR) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
iPtr->resetErrorStack = 0;
|
||||
Tcl_ListObjLength(interp, iPtr->errorStack, &len);
|
||||
|
||||
/*
|
||||
* Reset while keeping the list intrep as much as possible.
|
||||
*/
|
||||
|
||||
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
|
||||
valueObjv);
|
||||
}
|
||||
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE],
|
||||
&valuePtr);
|
||||
if (valuePtr != NULL) {
|
||||
@@ -1477,40 +1423,6 @@ TclMergeReturnOptions(
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* Check for bogus -errorstack value.
|
||||
*/
|
||||
|
||||
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr);
|
||||
if (valuePtr != NULL) {
|
||||
int length;
|
||||
|
||||
if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) {
|
||||
/*
|
||||
* Value is not a list, which is illegal for -errorstack.
|
||||
*/
|
||||
|
||||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||||
"bad -errorstack value: expected a list but got \"%s\"",
|
||||
TclGetString(valuePtr)));
|
||||
Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK",
|
||||
NULL);
|
||||
goto error;
|
||||
}
|
||||
if (length % 2) {
|
||||
/*
|
||||
* Errorstack must always be an even-sized list
|
||||
*/
|
||||
|
||||
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
||||
"forbidden odd-sized list for -errorstack: \"%s\"",
|
||||
TclGetString(valuePtr)));
|
||||
Tcl_SetErrorCode(interp, "TCL", "RESULT",
|
||||
"ODDSIZEDLIST_ERRORSTACK", NULL);
|
||||
goto error;
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* Convert [return -code return -level X] to [return -code ok -level X+1]
|
||||
*/
|
||||
@@ -1588,7 +1500,6 @@ Tcl_GetReturnOptions(
|
||||
|
||||
if (result == TCL_ERROR) {
|
||||
Tcl_AddObjErrorInfo(interp, "", -1);
|
||||
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack);
|
||||
}
|
||||
if (iPtr->errorCode) {
|
||||
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode);
|
||||
@@ -1601,31 +1512,6 @@ Tcl_GetReturnOptions(
|
||||
return options;
|
||||
}
|
||||
|
||||
/*
|
||||
*-------------------------------------------------------------------------
|
||||
*
|
||||
* TclNoErrorStack --
|
||||
*
|
||||
* Removes the -errorstack entry from an options dict to avoid reference
|
||||
* cycles.
|
||||
*
|
||||
* Results:
|
||||
* The (unshared) argument options dict, modified in -place.
|
||||
*
|
||||
*-------------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
Tcl_Obj *
|
||||
TclNoErrorStack(
|
||||
Tcl_Interp *interp,
|
||||
Tcl_Obj *options)
|
||||
{
|
||||
Tcl_Obj **keys = GetKeys();
|
||||
|
||||
Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]);
|
||||
return options;
|
||||
}
|
||||
|
||||
/*
|
||||
*-------------------------------------------------------------------------
|
||||
*
|
||||
|
||||
@@ -332,7 +332,7 @@ static const TclIntStubs tclIntStubs = {
|
||||
0, /* 139 */
|
||||
0, /* 140 */
|
||||
TclpGetCwd, /* 141 */
|
||||
TclSetByteCodeFromAny, /* 142 */
|
||||
0, /* 142 */
|
||||
TclAddLiteralObj, /* 143 */
|
||||
TclHideLiteral, /* 144 */
|
||||
TclGetAuxDataType, /* 145 */
|
||||
@@ -422,8 +422,8 @@ static const TclIntStubs tclIntStubs = {
|
||||
TclPtrMakeUpvar, /* 229 */
|
||||
TclObjLookupVar, /* 230 */
|
||||
TclGetNamespaceFromObj, /* 231 */
|
||||
TclEvalObjEx, /* 232 */
|
||||
TclGetSrcInfoForPc, /* 233 */
|
||||
0, /* 232 */
|
||||
0, /* 233 */
|
||||
TclVarHashCreateVar, /* 234 */
|
||||
TclInitVarHashTable, /* 235 */
|
||||
TclBackgroundException, /* 236 */
|
||||
|
||||
+8
-8
@@ -20,9 +20,10 @@
|
||||
# define USE_TCL_STUBS
|
||||
#endif
|
||||
#include <sys/stat.h>
|
||||
#include "tclInt.h"
|
||||
#include "tclEngineInt.h"
|
||||
#include "tclOO.h"
|
||||
#include <math.h>
|
||||
#include "tclNRE.h"
|
||||
|
||||
/*
|
||||
* Required for Testregexp*Cmd
|
||||
@@ -6785,7 +6786,7 @@ TestNRELevels(
|
||||
Interp *iPtr = (Interp *) interp;
|
||||
static ptrdiff_t *refDepth = NULL;
|
||||
ptrdiff_t depth;
|
||||
Tcl_Obj *levels[6];
|
||||
Tcl_Obj *levels[5];
|
||||
int i = 0;
|
||||
NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr;
|
||||
|
||||
@@ -6797,18 +6798,17 @@ TestNRELevels(
|
||||
|
||||
levels[0] = Tcl_NewIntObj(depth);
|
||||
levels[1] = Tcl_NewIntObj(iPtr->numLevels);
|
||||
levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level);
|
||||
levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level);
|
||||
levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr
|
||||
levels[2] = Tcl_NewIntObj(iPtr->varFramePtr->level);
|
||||
levels[3] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr
|
||||
- iPtr->execEnvPtr->execStackPtr->stackWords);
|
||||
|
||||
while (cbPtr) {
|
||||
i++;
|
||||
cbPtr = cbPtr->nextPtr;
|
||||
cbPtr = NEXT_CB(cbPtr);
|
||||
}
|
||||
levels[5] = Tcl_NewIntObj(i);
|
||||
levels[4] = Tcl_NewIntObj(i);
|
||||
|
||||
Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels));
|
||||
Tcl_SetObjResult(interp, Tcl_NewListObj(5, levels));
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
|
||||
@@ -1914,9 +1914,6 @@ TclPtrSetVar(
|
||||
} else {
|
||||
if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */
|
||||
varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
|
||||
|
||||
TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr);
|
||||
|
||||
TclDecrRefCount(oldValuePtr);
|
||||
oldValuePtr = varPtr->value.objPtr;
|
||||
Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */
|
||||
|
||||
+5
-5
@@ -151,7 +151,7 @@ test cmdMZ-return-2.10 {return option handling} -body {
|
||||
list [catch {return -level 0 -code error} -> foo] [dictSort $foo]
|
||||
} -match glob -result {1 {-code 1 -errorcode NONE -errorinfo {
|
||||
while executing
|
||||
"return -level 0 -code error"} -errorline 1 -errorstack * -level 0}}
|
||||
"return -level 0 -code error"} -errorline 1 -level 0}}
|
||||
test cmdMZ-return-2.11 {return option handling} {
|
||||
list [catch {return -level 0 -code break} -> foo] [dictSort $foo]
|
||||
} {3 {-code 3 -level 0}}
|
||||
@@ -187,9 +187,9 @@ test cmdMZ-return-2.17 {return opton handling} {
|
||||
} {1 c {a b}}
|
||||
test cmdMZ-return-2.18 {return option handling} {
|
||||
list [catch {
|
||||
return -code error -errorstack [list CALL a CALL b] yo
|
||||
} -> foo] [dictSort $foo] [info errorstack]
|
||||
} {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL b}}
|
||||
return -code error yo
|
||||
} -> foo] [dictSort $foo]
|
||||
} {2 {-code 1 -errorcode NONE -level 1}}
|
||||
|
||||
# Check that the result of a [return -options $opts $result] is
|
||||
# indistinguishable from that of the originally caught script, no matter what
|
||||
@@ -208,7 +208,7 @@ foreach {testid script} {
|
||||
cmdMZ-return-3.10 {return -code error -errorinfo foo}
|
||||
cmdMZ-return-3.11 {return -code error -errorinfo foo -errorcode bar}
|
||||
cmdMZ-return-3.12 {return -code error -errorinfo foo -errorcode bar -errorline 10}
|
||||
cmdMZ-return-3.12.1 {return -code error -errorinfo foo -errorcode bar -errorline 10 -errorstack baz}
|
||||
cmdMZ-return-3.12.1 {return -code error -errorinfo foo -errorcode bar -errorline 10}
|
||||
cmdMZ-return-3.13 {return -options {x y z 2}}
|
||||
cmdMZ-return-3.14 {return -level 3 -code break sdf}
|
||||
} {
|
||||
|
||||
@@ -624,90 +624,6 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup
|
||||
interp delete $i
|
||||
} -result substituted
|
||||
|
||||
# This tests the supported parts of the unsupported [disassemble] command. It
|
||||
# does not check the format of disassembled bytecode though; that's liable to
|
||||
# change without warning.
|
||||
|
||||
test compile-18.1 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble
|
||||
} -match glob -result {wrong # args: should be "*"}
|
||||
test compile-18.2 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble ?
|
||||
} -match glob -result {bad type "?": must be *}
|
||||
test compile-18.3 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble lambda
|
||||
} -match glob -result {wrong # args: should be "* lambda lambdaTerm"}
|
||||
test compile-18.4 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble lambda \{
|
||||
} -result "can't interpret \"\{\" as a lambda expression"
|
||||
test compile-18.5 {disassembler - basics} -body {
|
||||
# Allow any string: the result format is not defined anywhere!
|
||||
tcl::unsupported::disassemble lambda {{} {}}
|
||||
} -match glob -result *
|
||||
test compile-18.6 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble proc
|
||||
} -match glob -result {wrong # args: should be "* proc procName"}
|
||||
test compile-18.7 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble proc nosuchproc
|
||||
} -result {"nosuchproc" isn't a procedure}
|
||||
test compile-18.8 {disassembler - basics} -setup {
|
||||
proc chewonthis {} {}
|
||||
} -body {
|
||||
# Allow any string: the result format is not defined anywhere!
|
||||
tcl::unsupported::disassemble proc chewonthis
|
||||
} -cleanup {
|
||||
rename chewonthis {}
|
||||
} -match glob -result *
|
||||
test compile-18.9 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble script
|
||||
} -match glob -result {wrong # args: should be "* script script"}
|
||||
test compile-18.10 {disassembler - basics} -body {
|
||||
# Allow any string: the result format is not defined anywhere!
|
||||
tcl::unsupported::disassemble script {}
|
||||
} -match glob -result *
|
||||
test compile-18.11 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble method
|
||||
} -match glob -result {wrong # args: should be "* method className methodName"}
|
||||
test compile-18.12 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble method nosuchclass foo
|
||||
} -result {nosuchclass does not refer to an object}
|
||||
test compile-18.13 {disassembler - basics} -returnCodes error -setup {
|
||||
oo::object create justanobject
|
||||
} -body {
|
||||
tcl::unsupported::disassemble method justanobject foo
|
||||
} -cleanup {
|
||||
justanobject destroy
|
||||
} -result {"justanobject" is not a class}
|
||||
test compile-18.14 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble method oo::object nosuchmethod
|
||||
} -result {unknown method "nosuchmethod"}
|
||||
test compile-18.15 {disassembler - basics} -setup {
|
||||
oo::class create foo {method bar {} {}}
|
||||
} -body {
|
||||
# Allow any string: the result format is not defined anywhere!
|
||||
tcl::unsupported::disassemble method foo bar
|
||||
} -cleanup {
|
||||
foo destroy
|
||||
} -match glob -result *
|
||||
test compile-18.16 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble objmethod
|
||||
} -match glob -result {wrong # args: should be "* objmethod objectName methodName"}
|
||||
test compile-18.17 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble objmethod nosuchobject foo
|
||||
} -result {nosuchobject does not refer to an object}
|
||||
test compile-18.18 {disassembler - basics} -returnCodes error -body {
|
||||
tcl::unsupported::disassemble objmethod oo::object nosuchmethod
|
||||
} -result {unknown method "nosuchmethod"}
|
||||
test compile-18.19 {disassembler - basics} -setup {
|
||||
oo::object create foo
|
||||
oo::objdefine foo {method bar {} {}}
|
||||
} -body {
|
||||
# Allow any string: the result format is not defined anywhere!
|
||||
tcl::unsupported::disassemble objmethod foo bar
|
||||
} -cleanup {
|
||||
foo destroy
|
||||
} -match glob -result *
|
||||
# TODO sometime - check that bytecode from tbcload is *not* disassembled.
|
||||
|
||||
# cleanup
|
||||
catch {rename p ""}
|
||||
|
||||
@@ -19,6 +19,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testnrelevels [llength [info commands testnrelevels]]
|
||||
testConstraint memory [llength [info commands memory]]
|
||||
testConstraint infoframe [expr ![catch {info frame 0}]]
|
||||
|
||||
set lambda [list {{start 0} {stop 10}} {
|
||||
# init
|
||||
@@ -296,7 +297,7 @@ test coroutine-3.2 {info frame computation} -setup {
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
rename b {}
|
||||
} -result 1
|
||||
} -result 1 -constraints infoframe
|
||||
test coroutine-3.3 {info coroutine} -setup {
|
||||
proc a {} {info coroutine}
|
||||
proc b {} a
|
||||
@@ -341,7 +342,7 @@ test coroutine-3.6 {info frame, bug #2910094} -setup {
|
||||
} -cleanup {
|
||||
rename stack {}
|
||||
rename a {}
|
||||
} -result {}
|
||||
} -result {} -constraints infoframe
|
||||
|
||||
test coroutine-4.1 {bug #2093188} -setup {
|
||||
proc foo {} {
|
||||
@@ -483,7 +484,7 @@ test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels}
|
||||
}
|
||||
set res {}
|
||||
} -body {
|
||||
set base [getNumLevel]
|
||||
set base [relativeLevel 0]
|
||||
lappend res [relativeLevel $base]
|
||||
eval {coroutine a foo}
|
||||
# back to base level
|
||||
|
||||
@@ -1568,6 +1568,8 @@ test dict-22.23 {dict with: compiled} {
|
||||
}}
|
||||
} 1,2
|
||||
|
||||
if 0 {
|
||||
# TEST REMOVED: uses [info frame]
|
||||
proc linenumber {} {
|
||||
dict get [info frame -1] line
|
||||
}
|
||||
@@ -1586,6 +1588,7 @@ test dict-23.1 {dict compilation crash: Bug 3487626} {
|
||||
}
|
||||
}} [linenumber]}}
|
||||
} 5
|
||||
|
||||
test dict-23.2 {dict compilation crash: Bug 3487626} knownBug {
|
||||
# Something isn't quite right in line number and continuation line
|
||||
# tracking; at time of writing, this test produces 7, not 5, which
|
||||
@@ -1618,6 +1621,7 @@ j
|
||||
}} [linenumber]}}
|
||||
} 5
|
||||
rename linenumber {}
|
||||
}
|
||||
|
||||
test dict-24.1 {dict map command: syntax} -returnCodes error -body {
|
||||
dict map
|
||||
@@ -1802,6 +1806,9 @@ test dict-24.20 {dict map stack space compilation: 'dict for' bug 1903325} {
|
||||
concat "c=$y,$args"
|
||||
}} {} 1 2 3
|
||||
} {c=1,2 3}
|
||||
|
||||
if 0 {
|
||||
# TEST REMOVED: uses [info frame]
|
||||
proc linenumber {} {
|
||||
dict get [info frame -1] line
|
||||
}
|
||||
@@ -1820,6 +1827,7 @@ test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} {
|
||||
}
|
||||
}} [linenumber]}}
|
||||
} 5
|
||||
|
||||
test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug {
|
||||
apply {{} {apply {n {
|
||||
set e {}
|
||||
@@ -1848,6 +1856,8 @@ j
|
||||
}} [linenumber]}}
|
||||
} 5
|
||||
rename linenumber {}
|
||||
}
|
||||
|
||||
test dict-24.22 {dict map results (non-compiled)} {
|
||||
dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] {
|
||||
return -level 0 "$k,$v"
|
||||
|
||||
@@ -167,19 +167,6 @@ test error-4.5 {errorInfo and errorCode variables} {
|
||||
list [catch {error msg1 msg2 {}} msg] $msg $::errorInfo $::errorCode
|
||||
} {1 msg1 msg2 {}}
|
||||
|
||||
test error-4.6 {errorstack via info } -body {
|
||||
proc f x {g $x$x}
|
||||
proc g x {error G:$x}
|
||||
catch {f 12}
|
||||
info errorstack
|
||||
} -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1}
|
||||
test error-4.7 {errorstack via options dict } -body {
|
||||
proc f x {g $x$x}
|
||||
proc g x {error G:$x}
|
||||
catch {f 12} m d
|
||||
dict get $d -errorstack
|
||||
} -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1}
|
||||
|
||||
# Errors in error command itself
|
||||
|
||||
test error-5.1 {errors in error command} {
|
||||
@@ -234,16 +221,6 @@ test error-6.9 {catch must reset error state} {
|
||||
catch foo
|
||||
list $::errorCode
|
||||
} {NONE}
|
||||
test error-6.10 {catch must reset errorstack} -body {
|
||||
proc f x {g $x$x}
|
||||
proc g x {error G:$x}
|
||||
catch {f 12}
|
||||
set e1 [info errorstack]
|
||||
catch {f 13}
|
||||
set e2 [info errorstack]
|
||||
list $e1 $e2
|
||||
} -match glob -result {{INNER * CALL {g 1212} CALL {f 12} UP 1} {INNER * CALL {g 1313} CALL {f 13} UP 1}}
|
||||
|
||||
test error-7.1 {Bug 1397843} -body {
|
||||
variable cmds
|
||||
proc EIWrite args {
|
||||
|
||||
+1
-1
@@ -972,7 +972,7 @@ test execute-8.5 {Bug 2038069} -setup {
|
||||
demo
|
||||
} -cleanup {
|
||||
rename demo {}
|
||||
} -match glob -result {-code 1 -level 0 -errorstack * -errorcode NONE -errorinfo {FOO
|
||||
} -match glob -result {-code 1 -level 0 -errorcode NONE -errorinfo {FOO
|
||||
while executing
|
||||
"error FOO"
|
||||
invoked from within
|
||||
|
||||
+12
-4
@@ -678,16 +678,24 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body {
|
||||
} -result {wrong # args: should be "info subcommand ?arg ...?"}
|
||||
test info-21.2 {miscellaneous error conditions} -returnCodes error -body {
|
||||
info gorp
|
||||
} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
|
||||
} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
|
||||
test info-21.3 {miscellaneous error conditions} -returnCodes error -body {
|
||||
info c
|
||||
} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
|
||||
} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
|
||||
test info-21.4 {miscellaneous error conditions} -returnCodes error -body {
|
||||
info l
|
||||
} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
|
||||
} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
|
||||
test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
|
||||
info s
|
||||
} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
|
||||
} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
|
||||
|
||||
## DONE!! The rest is [info frame]
|
||||
|
||||
# cleanup
|
||||
catch {namespace delete test_ns_info1 test_ns_info2}
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
|
||||
##
|
||||
# ### ### ### ######### ######### #########
|
||||
|
||||
+1
-2
@@ -44,7 +44,6 @@ set helperscript {
|
||||
# This forces the return options to be in the order that the test expects!
|
||||
variable optorder {
|
||||
-code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?!
|
||||
-errorstack !?!
|
||||
}
|
||||
proc noteOpts opts {
|
||||
variable optorder
|
||||
@@ -1088,7 +1087,7 @@ proc inthread {chan script args} {
|
||||
proc noteOpts opts {
|
||||
lappend ::notes [dict merge {
|
||||
-code !?! -level !?! -errorcode !?! -errorline !?!
|
||||
-errorinfo !?! -errorstack !?!
|
||||
-errorinfo !?!
|
||||
} $opts]
|
||||
}
|
||||
}
|
||||
|
||||
+28
-27
@@ -28,8 +28,8 @@ if {[testConstraint testnrelevels]} {
|
||||
namespace eval testnre {
|
||||
namespace path ::tcl::mathop
|
||||
#
|
||||
# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
|
||||
# cmdFrame level, callFrame level, tosPtr and callback depth
|
||||
# [testnrelevels] returns a 5-list with: C-stack depth, iPtr->numlevels,
|
||||
# callFrame level, tosPtr and callback depth
|
||||
#
|
||||
variable last [testnrelevels]
|
||||
proc depthDiff {} {
|
||||
@@ -52,7 +52,7 @@ if {[testConstraint testnrelevels]} {
|
||||
namespace upvar [namespace qualifiers \
|
||||
[namespace origin depthDiff]] abs abs
|
||||
incr abs [lindex [testnrelevels] 0]
|
||||
return [list [lrange $x 0 3] $abs]
|
||||
return [list [lrange $x 0 2] $abs]
|
||||
}
|
||||
}
|
||||
proc makebody txt {
|
||||
@@ -63,7 +63,7 @@ if {[testConstraint testnrelevels]} {
|
||||
}
|
||||
namespace import testnre::*
|
||||
}
|
||||
|
||||
|
||||
test nre-1.1 {self-recursive procs} -setup {
|
||||
proc a i [makebody {a $i}]
|
||||
} -body {
|
||||
@@ -73,7 +73,7 @@ test nre-1.1 {self-recursive procs} -setup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 1 1 1} 0}
|
||||
} -result {{0 1 1} 0}
|
||||
test nre-1.2 {self-recursive lambdas} -setup {
|
||||
set a [list i [makebody {apply $::a $i}]]
|
||||
} -body {
|
||||
@@ -83,7 +83,7 @@ test nre-1.2 {self-recursive lambdas} -setup {
|
||||
unset a
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 1 1 1} 0}
|
||||
} -result {{0 1 1} 0}
|
||||
test nre-1.3 {mutually recursive procs and lambdas} -setup {
|
||||
proc a i {
|
||||
apply $::b [incr i]
|
||||
@@ -97,7 +97,7 @@ test nre-1.3 {mutually recursive procs and lambdas} -setup {
|
||||
unset b
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 2} 0}
|
||||
} -result {{0 2 2} 0}
|
||||
|
||||
#
|
||||
# Test that aliases are non-recursive
|
||||
@@ -114,7 +114,7 @@ test nre-2.1 {alias is not recursive} -setup {
|
||||
rename b {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 1 1} 0}
|
||||
} -result {{0 2 1} 0}
|
||||
|
||||
#
|
||||
# Test that imports are non-recursive
|
||||
@@ -134,7 +134,7 @@ test nre-3.1 {imports are not recursive} -setup {
|
||||
namespace delete ::foo
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 1 1} 0}
|
||||
} -result {{0 2 1} 0}
|
||||
|
||||
test nre-4.1 {ensembles are not recursive} -setup {
|
||||
proc a i [makebody {b foo $i}]
|
||||
@@ -149,7 +149,7 @@ test nre-4.1 {ensembles are not recursive} -setup {
|
||||
rename b {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 1 1} 0}
|
||||
} -result {{0 2 1} 0}
|
||||
|
||||
test nre-5.1 {[namespace eval] is not recursive} -setup {
|
||||
namespace eval ::foo {
|
||||
@@ -162,7 +162,8 @@ test nre-5.1 {[namespace eval] is not recursive} -setup {
|
||||
namespace delete ::foo
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 2} 0}
|
||||
} -result {{0 2 2} 0}
|
||||
|
||||
test nre-5.2 {[namespace eval] is not recursive} -setup {
|
||||
namespace eval ::foo {
|
||||
setabs
|
||||
@@ -174,7 +175,7 @@ test nre-5.2 {[namespace eval] is not recursive} -setup {
|
||||
namespace delete ::foo
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 2} 0}
|
||||
} -result {{0 2 2} 0}
|
||||
|
||||
test nre-6.1 {[uplevel] is not recursive} -setup {
|
||||
proc a i [makebody {uplevel 1 [list a $i]}]
|
||||
@@ -185,7 +186,7 @@ test nre-6.1 {[uplevel] is not recursive} -setup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 0} 0}
|
||||
} -result {{0 2 0} 0}
|
||||
test nre-6.2 {[uplevel] is not recursive} -setup {
|
||||
setabs
|
||||
proc a i [makebody {uplevel 1 "set x $i; a $i"}]
|
||||
@@ -195,7 +196,7 @@ test nre-6.2 {[uplevel] is not recursive} -setup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 0} 0}
|
||||
} -result {{0 2 0} 0}
|
||||
|
||||
test nre-7.1 {[catch] is not recursive} -setup {
|
||||
setabs
|
||||
@@ -206,7 +207,7 @@ test nre-7.1 {[catch] is not recursive} -setup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 3 3 0} 0}
|
||||
} -result {{0 3 0} 0}
|
||||
test nre-7.2 {[if] is not recursive} -setup {
|
||||
setabs
|
||||
proc a i [makebody {uplevel 1 "if 1 {a $i}"}]
|
||||
@@ -216,7 +217,7 @@ test nre-7.2 {[if] is not recursive} -setup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 0} 0}
|
||||
} -result {{0 2 0} 0}
|
||||
test nre-7.3 {[while] is not recursive} -setup {
|
||||
setabs
|
||||
proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}]
|
||||
@@ -226,7 +227,7 @@ test nre-7.3 {[while] is not recursive} -setup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 0} 0}
|
||||
} -result {{0 2 0} 0}
|
||||
test nre-7.4 {[for] is not recursive} -setup {
|
||||
setabs
|
||||
proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}]
|
||||
@@ -236,7 +237,7 @@ test nre-7.4 {[for] is not recursive} -setup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 0} 0}
|
||||
} -result {{0 2 0} 0}
|
||||
test nre-7.5 {[foreach] is not recursive} -setup {
|
||||
#
|
||||
# Enable once [foreach] is NR-enabled
|
||||
@@ -249,7 +250,7 @@ test nre-7.5 {[foreach] is not recursive} -setup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 3 3 0} 0}
|
||||
} -result {{0 3 0} 0}
|
||||
test nre-7.6 {[eval] is not recursive} -setup {
|
||||
proc a i [makebody {eval [list a $i]}]
|
||||
} -body {
|
||||
@@ -259,7 +260,7 @@ test nre-7.6 {[eval] is not recursive} -setup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 1} 0}
|
||||
} -result {{0 2 1} 0}
|
||||
test nre-7.7 {[eval] is not recursive} -setup {
|
||||
proc a i [makebody {eval "a $i"}]
|
||||
} -body {
|
||||
@@ -269,7 +270,7 @@ test nre-7.7 {[eval] is not recursive} -setup {
|
||||
rename a {}
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 2 1} 0}
|
||||
} -result {{0 2 1} 0}
|
||||
test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup {
|
||||
proc foo args {}
|
||||
foo
|
||||
@@ -333,7 +334,7 @@ test nre-oo.1 {really deep calls in oo - direct} -setup {
|
||||
foo destroy
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 1 1 1} 0}
|
||||
} -result {{0 1 1} 0}
|
||||
test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
|
||||
oo::object create foo
|
||||
oo::objdefine foo method bar i [makebody {[self] bar $i}]
|
||||
@@ -344,7 +345,7 @@ test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
|
||||
foo destroy
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 1 1 1} 0}
|
||||
} -result {{0 1 1} 0}
|
||||
test nre-oo.3 {really deep calls in oo - private calls} -setup {
|
||||
oo::object create foo
|
||||
oo::objdefine foo method bar i [makebody {my bar $i}]
|
||||
@@ -355,7 +356,7 @@ test nre-oo.3 {really deep calls in oo - private calls} -setup {
|
||||
foo destroy
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 1 1 1} 0}
|
||||
} -result {{0 1 1} 0}
|
||||
test nre-oo.4 {really deep calls in oo - overriding} -setup {
|
||||
oo::class create foo {
|
||||
method bar i [makebody {my bar $i}]
|
||||
@@ -371,7 +372,7 @@ test nre-oo.4 {really deep calls in oo - overriding} -setup {
|
||||
foo destroy
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 1 1 1} 0}
|
||||
} -result {{0 1 1} 0}
|
||||
test nre-oo.5 {really deep calls in oo - forwards} -setup {
|
||||
oo::object create foo
|
||||
set body [makebody {my boo $i}]
|
||||
@@ -386,7 +387,7 @@ test nre-oo.5 {really deep calls in oo - forwards} -setup {
|
||||
foo destroy
|
||||
} -constraints {
|
||||
testnrelevels
|
||||
} -result {{0 2 1 1} 0}
|
||||
} -result {{0 2 1} 0}
|
||||
|
||||
#
|
||||
# NASTY BUG found by tcllib's interp package
|
||||
@@ -409,7 +410,7 @@ test nre-X.1 {eval in wrong interp} -setup {
|
||||
} -cleanup {
|
||||
interp delete $i
|
||||
} -result {::foo ::foo {} {}}
|
||||
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
|
||||
|
||||
+4
-2
@@ -13,6 +13,8 @@ if {"::tcltest" in [namespace children]} {
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint infoframe [expr ![catch {info frame 0}]]
|
||||
|
||||
testConstraint memory [llength [info commands memory]]
|
||||
if {[testConstraint memory]} {
|
||||
proc getbytes {} {
|
||||
@@ -2591,7 +2593,7 @@ test oo-22.1 {OO and info frame} -setup {
|
||||
}
|
||||
}
|
||||
list [i level] [i frames] [dict get [c frame] object]
|
||||
} -cleanup {
|
||||
} -constraints infoframe -cleanup {
|
||||
c destroy
|
||||
} -result {1 {{* cmd {info frame 0} method frames class ::c level 0} {* cmd {info frame 0} method frames object ::i level 0}} ::c}
|
||||
test oo-22.2 {OO and info frame: Bug 3001438} -setup {
|
||||
@@ -2603,7 +2605,7 @@ test oo-22.2 {OO and info frame: Bug 3001438} -setup {
|
||||
info frame 0
|
||||
}
|
||||
[c new] test
|
||||
} -match glob -cleanup {
|
||||
} -match glob -constraints infoframe -cleanup {
|
||||
c destroy
|
||||
} -result {* cmd {info frame 0} method test class ::c level 0}
|
||||
|
||||
|
||||
@@ -830,12 +830,12 @@ test regexpComp-21.5 {regexp command compiling tests} {
|
||||
} 0
|
||||
test regexpComp-21.6 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
regexp -n foo dogfoOd
|
||||
regexp -nocase foo dogfoOd
|
||||
}
|
||||
} 1
|
||||
test regexpComp-21.7 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
regexp -no -- FoO dogfood
|
||||
regexp -nocase -- FoO dogfood
|
||||
}
|
||||
} 1
|
||||
test regexpComp-21.8 {regexp command compiling tests} {
|
||||
@@ -945,13 +945,13 @@ test regexpComp-24.5 {regexp command compiling tests} {
|
||||
test regexpComp-24.6 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
set re foo
|
||||
regexp -n $re dogfoOd
|
||||
regexp -nocase $re dogfoOd
|
||||
}
|
||||
} 1
|
||||
test regexpComp-24.7 {regexp command compiling tests} {
|
||||
evalInProc {
|
||||
set re FoO
|
||||
regexp -no -- $re dogfood
|
||||
regexp -nocase -- $re dogfood
|
||||
}
|
||||
} 1
|
||||
test regexpComp-24.8 {regexp command compiling tests} {
|
||||
@@ -982,7 +982,7 @@ test regexpComp-24.11 {regexp command compiling tests} {
|
||||
regexp -- $re $text
|
||||
}
|
||||
} 1
|
||||
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
@@ -136,14 +136,6 @@ test result-6.3 {Bug 2383005} {
|
||||
catch {return -code error -errorcode {{}a} eek} m
|
||||
set m
|
||||
} {bad -errorcode value: expected a list but got "{}a"}
|
||||
test result-6.4 {non-list -errorstack} -body {
|
||||
catch {return -code error -errorstack {{}a} eek} m o
|
||||
list $m [dict get $o -errorcode] [dict get $o -errorstack]
|
||||
} -match glob -result {{bad -errorstack value: expected a list but got "{}a"} {TCL RESULT NONLIST_ERRORSTACK} {INNER * UP 1}}
|
||||
test result-6.5 {odd-sized-list -errorstack} -body {
|
||||
catch {return -code error -errorstack a eek} m o
|
||||
list $m [dict get $o -errorcode] [dict get $o -errorstack]
|
||||
} -match glob -result {{forbidden odd-sized list for -errorstack: "a"} {TCL RESULT ODDSIZEDLIST_ERRORSTACK} {INNER * UP 1}}
|
||||
# cleanup
|
||||
cleanupTests
|
||||
return
|
||||
|
||||
+28
-38
@@ -27,13 +27,17 @@ testConstraint testnrelevels [llength [info commands testnrelevels]]
|
||||
if {[testConstraint testnrelevels]} {
|
||||
namespace eval testnre {
|
||||
#
|
||||
# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
|
||||
# cmdFrame level, callFrame level, tosPtr and callback depth
|
||||
# [testnrelevels] returns a 5-list with: C-stack depth, iPtr->numlevels,
|
||||
# callFrame level, tosPtr and callback depth
|
||||
#
|
||||
variable last [testnrelevels]
|
||||
|
||||
proc depthDiff {} {
|
||||
variable last
|
||||
set depth [testnrelevels]
|
||||
if {![info exists last]} {
|
||||
set last $depth
|
||||
return $last
|
||||
}
|
||||
set res {}
|
||||
foreach t $depth l $last {
|
||||
lappend res [expr {$t-$l}]
|
||||
@@ -57,11 +61,9 @@ test tailcall-0.1 {tailcall is constant space} -constraints testnrelevels -setup
|
||||
# ($i==0) due to the fact that the first is from an eval. Successive
|
||||
# calls should add nothing to any stack depths.
|
||||
#
|
||||
if {$i == 1} {
|
||||
depthDiff
|
||||
}
|
||||
set x [depthDiff]
|
||||
if {[incr i] > 10} {
|
||||
return [depthDiff]
|
||||
return $x
|
||||
}
|
||||
tailcall a $i
|
||||
}
|
||||
@@ -69,15 +71,13 @@ test tailcall-0.1 {tailcall is constant space} -constraints testnrelevels -setup
|
||||
a 0
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -result {0 0 0 0 0 0}
|
||||
} -result {0 0 0 0 0}
|
||||
|
||||
test tailcall-0.2 {tailcall is constant space} -constraints testnrelevels -setup {
|
||||
set a { i {
|
||||
if {$i == 1} {
|
||||
depthDiff
|
||||
}
|
||||
set x [depthDiff]
|
||||
if {[incr i] > 10} {
|
||||
return [depthDiff]
|
||||
return $x
|
||||
}
|
||||
upvar 1 a a
|
||||
tailcall apply $a $i
|
||||
@@ -86,15 +86,13 @@ test tailcall-0.2 {tailcall is constant space} -constraints testnrelevels -setup
|
||||
apply $a 0
|
||||
} -cleanup {
|
||||
unset a
|
||||
} -result {0 0 0 0 0 0}
|
||||
} -result {0 0 0 0 0}
|
||||
|
||||
test tailcall-0.3 {tailcall is constant space} -constraints testnrelevels -setup {
|
||||
proc a i {
|
||||
if {$i == 1} {
|
||||
depthDiff
|
||||
}
|
||||
set x [depthDiff]
|
||||
if {[incr i] > 10} {
|
||||
return [depthDiff]
|
||||
return $x
|
||||
}
|
||||
tailcall b $i
|
||||
}
|
||||
@@ -104,18 +102,16 @@ test tailcall-0.3 {tailcall is constant space} -constraints testnrelevels -setup
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
rename b {}
|
||||
} -result {0 0 0 0 0 0}
|
||||
} -result {0 0 0 0 0}
|
||||
|
||||
test tailcall-0.4 {tailcall is constant space} -constraints testnrelevels -setup {
|
||||
namespace eval ::ns {
|
||||
namespace export *
|
||||
}
|
||||
proc ::ns::a i {
|
||||
if {$i == 1} {
|
||||
depthDiff
|
||||
}
|
||||
set x [depthDiff]
|
||||
if {[incr i] > 10} {
|
||||
return [depthDiff]
|
||||
return $x
|
||||
}
|
||||
set b [uplevel 1 [list namespace which b]]
|
||||
tailcall $b $i
|
||||
@@ -127,15 +123,13 @@ test tailcall-0.4 {tailcall is constant space} -constraints testnrelevels -setup
|
||||
} -cleanup {
|
||||
rename b {}
|
||||
namespace delete ::ns
|
||||
} -result {0 0 0 0 0 0}
|
||||
} -result {0 0 0 0 0}
|
||||
|
||||
test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup {
|
||||
proc b i {
|
||||
if {$i == 1} {
|
||||
depthDiff
|
||||
}
|
||||
set x [depthDiff]
|
||||
if {[incr i] > 10} {
|
||||
return [depthDiff]
|
||||
return $x
|
||||
}
|
||||
tailcall a b $i
|
||||
}
|
||||
@@ -145,18 +139,16 @@ test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
rename b {}
|
||||
} -result {0 0 0 0 0 0}
|
||||
} -result {0 0 0 0 0}
|
||||
|
||||
test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels knownBug} -setup {
|
||||
#
|
||||
# This test fails because ns-unknown is not NR-enabled
|
||||
#
|
||||
proc c i {
|
||||
if {$i == 1} {
|
||||
depthDiff
|
||||
}
|
||||
set x [depthDiff]
|
||||
if {[incr i] > 10} {
|
||||
return [depthDiff]
|
||||
return $x
|
||||
}
|
||||
tailcall a b $i
|
||||
}
|
||||
@@ -170,17 +162,15 @@ test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels known
|
||||
rename a {}
|
||||
rename c {}
|
||||
rename d {}
|
||||
} -result {0 0 0 0 0 0}
|
||||
} -result {0 0 0 0 0}
|
||||
|
||||
test tailcall-0.7 {tailcall is constant space} -constraints testnrelevels -setup {
|
||||
catch {rename foo {}}
|
||||
oo::class create foo {
|
||||
method b i {
|
||||
if {$i == 1} {
|
||||
depthDiff
|
||||
}
|
||||
set x [depthDiff]
|
||||
if {[incr i] > 10} {
|
||||
return [depthDiff]
|
||||
return $x
|
||||
}
|
||||
tailcall [self] b $i
|
||||
}
|
||||
@@ -191,7 +181,7 @@ test tailcall-0.7 {tailcall is constant space} -constraints testnrelevels -setup
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
rename foo {}
|
||||
} -result {0 0 0 0 0 0}
|
||||
} -result {0 0 0 0 0}
|
||||
|
||||
test tailcall-1 {tailcall} -body {
|
||||
namespace eval a {
|
||||
|
||||
+21
-16
@@ -294,7 +294,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
|
||||
tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o tclClock.o \
|
||||
tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompCmds.o tclCompCmdsSZ.o \
|
||||
tclCompExpr.o tclCompile.o tclConfig.o tclDate.o tclDictObj.o \
|
||||
tclEncoding.o tclEnsemble.o \
|
||||
tclEncoding.o tclEnsemble.o tclCompEnsemble.o\
|
||||
tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
|
||||
tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \
|
||||
tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \
|
||||
@@ -403,6 +403,7 @@ GENERIC_SRCS = \
|
||||
$(GENERIC_DIR)/tclDictObj.c \
|
||||
$(GENERIC_DIR)/tclEncoding.c \
|
||||
$(GENERIC_DIR)/tclEnsemble.c \
|
||||
$(GENERIC_DIR)/tclCompEnsemble.c \
|
||||
$(GENERIC_DIR)/tclEnv.c \
|
||||
$(GENERIC_DIR)/tclEvent.c \
|
||||
$(GENERIC_DIR)/tclExecute.c \
|
||||
@@ -996,12 +997,13 @@ xtTestInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE}
|
||||
REGHDRS=$(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \
|
||||
$(GENERIC_DIR)/regcustom.h
|
||||
TCLREHDRS=$(GENERIC_DIR)/tclRegexp.h
|
||||
COMPILEHDR=$(GENERIC_DIR)/tclCompile.h
|
||||
ENGINEHDR=$(GENERIC_DIR)/tclEngine.h
|
||||
ENGINEINTHDR=$(ENGINEHDR) $(GENERIC_DIR)/tclEngineInt.h
|
||||
NREHDR=$(GENERIC_DIR)/tclNRE.h
|
||||
FSHDR=$(GENERIC_DIR)/tclFileSystem.h
|
||||
IOHDR=$(GENERIC_DIR)/tclIO.h
|
||||
MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h
|
||||
PARSEHDR=$(GENERIC_DIR)/tclParse.h
|
||||
NREHDR=$(GENERIC_DIR)/tclInt.h
|
||||
|
||||
regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \
|
||||
$(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \
|
||||
@@ -1023,13 +1025,13 @@ tclAppInit.o: $(UNIX_DIR)/tclAppInit.c
|
||||
tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAlloc.c
|
||||
|
||||
tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR)
|
||||
tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(ENGINEINTHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAssembly.c
|
||||
|
||||
tclAsync.o: $(GENERIC_DIR)/tclAsync.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c
|
||||
|
||||
tclBasic.o: $(GENERIC_DIR)/tclBasic.c $(COMPILEHDR) $(MATHHDRS) $(NREHDR)
|
||||
tclBasic.o: $(GENERIC_DIR)/tclBasic.c $(ENGINEHDR) $(MATHHDRS) $(NREHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBasic.c
|
||||
|
||||
tclBinary.o: $(GENERIC_DIR)/tclBinary.c
|
||||
@@ -1053,16 +1055,16 @@ tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c $(TCLREHDRS)
|
||||
tclDate.o: $(GENERIC_DIR)/tclDate.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c
|
||||
|
||||
tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR)
|
||||
tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(ENGINEINTHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmds.c
|
||||
|
||||
tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR)
|
||||
tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(ENGINEINTHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsSZ.c
|
||||
|
||||
tclCompExpr.o: $(GENERIC_DIR)/tclCompExpr.c $(COMPILEHDR)
|
||||
tclCompExpr.o: $(GENERIC_DIR)/tclCompExpr.c $(ENGINEINTHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompExpr.c
|
||||
|
||||
tclCompile.o: $(GENERIC_DIR)/tclCompile.c $(COMPILEHDR)
|
||||
tclCompile.o: $(GENERIC_DIR)/tclCompile.c $(ENGINEINTHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompile.c
|
||||
|
||||
tclConfig.o: $(GENERIC_DIR)/tclConfig.c
|
||||
@@ -1074,16 +1076,19 @@ tclDictObj.o: $(GENERIC_DIR)/tclDictObj.c $(MATHHDRS)
|
||||
tclEncoding.o: $(GENERIC_DIR)/tclEncoding.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEncoding.c
|
||||
|
||||
tclEnsemble.o: $(GENERIC_DIR)/tclEnsemble.c $(COMPILEHDR)
|
||||
tclEnsemble.o: $(GENERIC_DIR)/tclEnsemble.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnsemble.c
|
||||
|
||||
tclCompEnsemble.o: $(GENERIC_DIR)/tclCompEnsemble.c $(ENGINEINTHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompEnsemble.c
|
||||
|
||||
tclEnv.o: $(GENERIC_DIR)/tclEnv.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnv.c
|
||||
|
||||
tclEvent.o: $(GENERIC_DIR)/tclEvent.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEvent.c
|
||||
|
||||
tclExecute.o: $(GENERIC_DIR)/tclExecute.c $(COMPILEHDR) $(MATHHDRS) $(NREHDR)
|
||||
tclExecute.o: $(GENERIC_DIR)/tclExecute.c $(ENGINEINTHDR) $(MATHHDRS)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclExecute.c
|
||||
|
||||
tclFCmd.o: $(GENERIC_DIR)/tclFCmd.c
|
||||
@@ -1134,10 +1139,10 @@ tclLink.o: $(GENERIC_DIR)/tclLink.c
|
||||
tclListObj.o: $(GENERIC_DIR)/tclListObj.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c
|
||||
|
||||
tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(COMPILEHDR)
|
||||
tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(ENGINEINTHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c
|
||||
|
||||
tclObj.o: $(GENERIC_DIR)/tclObj.c $(COMPILEHDR) $(MATHHDRS)
|
||||
tclObj.o: $(GENERIC_DIR)/tclObj.c $(MATHHDRS)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c
|
||||
|
||||
tclLoad.o: $(GENERIC_DIR)/tclLoad.c
|
||||
@@ -1170,7 +1175,7 @@ tclLoadShl.o: $(UNIX_DIR)/tclLoadShl.c
|
||||
tclMain.o: $(GENERIC_DIR)/tclMain.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclMain.c
|
||||
|
||||
tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR)
|
||||
tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c
|
||||
|
||||
tclNotify.o: $(GENERIC_DIR)/tclNotify.c
|
||||
@@ -1242,7 +1247,7 @@ tclPosixStr.o: $(GENERIC_DIR)/tclPosixStr.c
|
||||
tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPreserve.c
|
||||
|
||||
tclProc.o: $(GENERIC_DIR)/tclProc.c $(COMPILEHDR) $(NREHDR)
|
||||
tclProc.o: $(GENERIC_DIR)/tclProc.c $(ENGINEHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c
|
||||
|
||||
tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c $(TCLREHDRS)
|
||||
@@ -1281,7 +1286,7 @@ tclVar.o: $(GENERIC_DIR)/tclVar.c
|
||||
tclZlib.o: $(GENERIC_DIR)/tclZlib.c
|
||||
$(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c
|
||||
|
||||
tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS)
|
||||
tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(NREHDR) $(ENGINEINTHDR)
|
||||
$(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c
|
||||
|
||||
tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS)
|
||||
|
||||
Reference in New Issue
Block a user