summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2012-03-04 16:52:01 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2012-03-04 16:52:01 (GMT)
commite3a722221577f7aaeaa942bb59bbe67306b61229 (patch)
tree52c20b244136cfda64102e6d08625cd9dd99b6b8
parente7d0f5ecae05758ef91de4a3c1e6422bd82953ed (diff)
downloadtcl-e3a722221577f7aaeaa942bb59bbe67306b61229.zip
tcl-e3a722221577f7aaeaa942bb59bbe67306b61229.tar.gz
tcl-e3a722221577f7aaeaa942bb59bbe67306b61229.tar.bz2
Compilation of misc info sometimes used in high-performance code.
-rw-r--r--generic/tclAssembly.c9
-rw-r--r--generic/tclCmdIL.c4
-rw-r--r--generic/tclCompCmds.c102
-rw-r--r--generic/tclCompile.c21
-rw-r--r--generic/tclCompile.h8
-rw-r--r--generic/tclExecute.c64
-rw-r--r--generic/tclInt.h9
-rw-r--r--generic/tclNamesp.c275
-rw-r--r--tests/info.test6
9 files changed, 344 insertions, 154 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 5b32ab0..7bfaac1 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -369,6 +369,7 @@ TalInstDesc TalInstructionTable[] = {
{"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1},
{"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1},
{"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1},
+ {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1},
{"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1},
{"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1},
{"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1},
@@ -406,6 +407,8 @@ TalInstDesc TalInstructionTable[] = {
{"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1},
{"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM,
1, 1},
+ {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1},
+ {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1},
{"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8
| INST_INVOKE_STK4), INT_MIN,1},
{"jump", ASSEM_JUMP, INST_JUMP1, 0, 0},
@@ -449,6 +452,7 @@ TalInstDesc TalInstructionTable[] = {
{"neq", ASSEM_1BYTE, INST_NEQ, 2, 1},
{"nop", ASSEM_1BYTE, INST_NOP, 0, 0},
{"not", ASSEM_1BYTE, INST_LNOT, 1, 1},
+ {"nscurrent", ASSEM_1BYTE, INST_NS_CURRENT, 0, 1},
{"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1},
{"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1},
{"pop", ASSEM_1BYTE, INST_POP, 1, 0},
@@ -499,7 +503,10 @@ static unsigned char NonThrowingByteCodes[] = {
INST_OVER, /* 95 */
INST_PUSH_RETURN_OPTIONS, /* 108 */
INST_REVERSE, /* 126 */
- INST_NOP /* 132 */
+ INST_NOP, /* 132 */
+ INST_NS_CURRENT, /* 141 */
+ INST_COROUTINE_NAME, /* 142 */
+ INST_INFO_LEVEL_NUM /* 143 */
};
/*
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index b312026..3af577b 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -166,7 +166,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0},
{"commands", InfoCommandsCmd, NULL, NULL, NULL, 0},
{"complete", InfoCompleteCmd, NULL, NULL, NULL, 0},
- {"coroutine", TclInfoCoroutineCmd, NULL, NULL, NULL, 0},
+ {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
{"default", InfoDefaultCmd, NULL, NULL, NULL, 0},
{"errorstack", InfoErrorStackCmd, NULL, NULL, NULL, 0},
{"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0},
@@ -174,7 +174,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"functions", InfoFunctionsCmd, NULL, NULL, NULL, 0},
{"globals", TclInfoGlobalsCmd, NULL, NULL, NULL, 0},
{"hostname", InfoHostnameCmd, NULL, NULL, NULL, 0},
- {"level", InfoLevelCmd, NULL, NULL, NULL, 0},
+ {"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0},
{"library", InfoLibraryCmd, NULL, NULL, NULL, 0},
{"loaded", InfoLoadedCmd, NULL, NULL, NULL, 0},
{"locals", TclInfoLocalsCmd, NULL, NULL, NULL, 0},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 5b7e0a5..79d29e9 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -2817,22 +2817,47 @@ TclCompileIncrCmd(
/*
*----------------------------------------------------------------------
*
- * TclCompileInfoExistsCmd --
+ * TclCompileInfo*Cmd --
*
- * Procedure called to compile the "info exists" subcommand.
+ * Procedures called to compile "info" subcommands.
*
* 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 "info exists"
- * subcommand at runtime.
+ * Instructions are added to envPtr to execute the "info" subcommand at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
+TclCompileInfoCoroutineCmd(
+ 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. */
+{
+ /*
+ * Only compile [info coroutine] without arguments.
+ */
+
+ if (parsePtr->numWords != 1) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Not much to do; we compile to a single instruction...
+ */
+
+ TclEmitOpcode( INST_COROUTINE_NAME, envPtr);
+ return TCL_OK;
+}
+
+int
TclCompileInfoExistsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
@@ -2883,6 +2908,42 @@ TclCompileInfoExistsCmd(
return TCL_OK;
}
+
+int
+TclCompileInfoLevelCmd(
+ 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. */
+{
+ /*
+ * Only compile [info level] without arguments or with a single argument.
+ */
+
+ if (parsePtr->numWords == 1) {
+ /*
+ * Not much to do; we compile to a single instruction...
+ */
+
+ TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr);
+ } else if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ } else {
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Compile the argument, then add the instruction to convert it into a
+ * list of arguments.
+ */
+
+ SetLineInformation(1);
+ CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp);
+ TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr);
+ }
+ return TCL_OK;
+}
/*
*----------------------------------------------------------------------
@@ -3700,11 +3761,11 @@ TclCompileLsetCmd(
/*
*----------------------------------------------------------------------
*
- * TclCompileNamespaceCmd --
+ * TclCompileNamespace*Cmd --
*
- * Procedure called to compile the "namespace" command; currently, only
- * the subcommand "namespace upvar" is compiled to bytecodes, and then
- * only inside a procedure(-like) context.
+ * Procedures called to compile the "namespace" command; currently, only
+ * the subcommands "namespace current" and "namespace upvar" are compiled
+ * to bytecodes, and the latter only inside a procedure(-like) context.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
@@ -3718,6 +3779,31 @@ TclCompileLsetCmd(
*/
int
+TclCompileNamespaceCurrentCmd(
+ 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. */
+{
+ /*
+ * Only compile [namespace current] without arguments.
+ */
+
+ if (parsePtr->numWords != 1) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Not much to do; we compile to a single instruction...
+ */
+
+ TclEmitOpcode( INST_NS_CURRENT, envPtr);
+ return TCL_OK;
+}
+
+int
TclCompileNamespaceUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 1d88e11..6f3f778 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -37,7 +37,7 @@ TCL_DECLARE_MUTEX(tableMutex)
int tclTraceCompile = 0;
static int traceInitialized = 0;
#endif
-
+
/*
* A table describing the Tcl bytecode instructions. Entries in this table
* must correspond to the instruction opcode definitions in tclCompile.h. The
@@ -435,6 +435,20 @@ InstructionDesc const tclInstructionTable[] = {
* indicated by the LVT index. Part of [dict with].
* Stack: ... path keyList => ... */
+ {"nscurrent", 1, +1, 0, {OPERAND_NONE}},
+ /* Push the name of the interpreter's current namespace as an object
+ * on the stack. */
+ {"coroName", 1, +1, 0, {OPERAND_NONE}},
+ /* Push the name of the interpreter's current coroutine as an object
+ * on the stack. */
+ {"infoLevelNumber", 1, +1, 0, {OPERAND_NONE}},
+ /* Push the stack depth (i.e., [info level]) of the interpreter as an
+ * object on the stack. */
+ {"infoLevelArgs", 1, 0, 0, {OPERAND_NONE}},
+ /* Push the argument words to a stack depth (i.e., [info level <n>])
+ * of the interpreter as an object on the stack.
+ * Stack: ... depth => ... argList */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
@@ -1673,10 +1687,10 @@ TclCompileScript(
&& !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION)
&& !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
&& !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
- int savedNumCmds = envPtr->numCommands;
+ int code, savedNumCmds = envPtr->numCommands;
unsigned savedCodeNext =
envPtr->codeNext - envPtr->codeStart;
- int update = 0, code;
+ int update = 0;
/*
* Mark the start of the command; the proper bytecode
@@ -4627,6 +4641,5 @@ RecordByteCodeStats(
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
- * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 58663fd..e12debf 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -681,8 +681,14 @@ typedef struct ByteCode {
#define INST_DICT_RECOMBINE_STK 139
#define INST_DICT_RECOMBINE_IMM 140
+/* For compilation of basic information operations */
+#define INST_NS_CURRENT 141
+#define INST_COROUTINE_NAME 142
+#define INST_INFO_LEVEL_NUM 143
+#define INST_INFO_LEVEL_ARGS 144
+
/* The last opcode */
-#define LAST_INST_OPCODE 140
+#define LAST_INST_OPCODE 144
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index e402634..0c0de20 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4045,6 +4045,70 @@ TEBCresume(
/*
* -----------------------------------------------------------------
+ * Start of general introspector instructions.
+ */
+
+ case INST_NS_CURRENT: {
+ Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
+
+ if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
+ TclNewLiteralStringObj(objResultPtr, "::");
+ } else {
+ TclNewStringObj(objResultPtr, currNsPtr->fullName,
+ strlen(currNsPtr->fullName));
+ }
+ TRACE_WITH_OBJ(("=> "), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+ }
+ case INST_COROUTINE_NAME: {
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
+ TclNewObj(objResultPtr);
+ if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
+ Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
+ objResultPtr);
+ }
+ TRACE_WITH_OBJ(("=> "), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+ }
+ case INST_INFO_LEVEL_NUM:
+ TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
+ TRACE_WITH_OBJ(("=> "), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+ case INST_INFO_LEVEL_ARGS: {
+ int level;
+ register CallFrame *framePtr = iPtr->varFramePtr;
+ register CallFrame *rootFramePtr = iPtr->rootFramePtr;
+
+ valuePtr = OBJ_AT_TOS;
+ if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) {
+ TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
+ Tcl_GetObjResult(interp));
+ goto gotError;
+ }
+ TRACE(("%d => ", level));
+ if (level <= 0) {
+ level += framePtr->level;
+ }
+ for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ;
+ framePtr = framePtr->callerVarPtr) {
+ /* Empty loop body */
+ }
+ if (framePtr == rootFramePtr) {
+ Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr),
+ "\"", NULL);
+ TRACE_APPEND(("ERROR: bad level\n"));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
+ TclGetString(valuePtr), NULL);
+ goto gotError;
+ }
+ objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+ }
+
+ /*
+ * -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 08b3f70..bc7cd9f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3526,9 +3526,15 @@ MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoCoroutineCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3556,6 +3562,9 @@ MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 73bc644..cdaba3d 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -104,7 +104,7 @@ static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp,
static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int NRNamespaceEvalCmd(ClientData dummy,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
+ Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp,
@@ -160,25 +160,25 @@ static const Tcl_ObjType nsNameType = {
*/
static const EnsembleImplMap defaultNamespaceMap[] = {
- {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0},
- {"code", NamespaceCodeCmd, NULL, NULL, NULL, 0},
- {"current", NamespaceCurrentCmd, NULL, NULL, NULL, 0},
- {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0},
- {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
- {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0},
- {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0},
- {"export", NamespaceExportCmd, NULL, NULL, NULL, 0},
- {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0},
- {"import", NamespaceImportCmd, NULL, NULL, NULL, 0},
- {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0},
- {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0},
- {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0},
- {"path", NamespacePathCmd, NULL, NULL, NULL, 0},
- {"qualifiers", NamespaceQualifiersCmd, NULL, NULL, NULL, 0},
- {"tail", NamespaceTailCmd, NULL, NULL, NULL, 0},
- {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0},
- {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
- {"which", NamespaceWhichCmd, NULL, NULL, NULL, 0},
+ {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0},
+ {"code", NamespaceCodeCmd, NULL, NULL, NULL, 0},
+ {"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0},
+ {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0},
+ {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
+ {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0},
+ {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0},
+ {"export", NamespaceExportCmd, NULL, NULL, NULL, 0},
+ {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0},
+ {"import", NamespaceImportCmd, NULL, NULL, NULL, 0},
+ {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0},
+ {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0},
+ {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0},
+ {"path", NamespacePathCmd, NULL, NULL, NULL, 0},
+ {"qualifiers", NamespaceQualifiersCmd, NULL, NULL, NULL, 0},
+ {"tail", NamespaceTailCmd, NULL, NULL, NULL, 0},
+ {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0},
+ {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
+ {"which", NamespaceWhichCmd, NULL, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -423,7 +423,7 @@ Tcl_PopCallFrame(
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
- TclSpliceTailcall(interp, framePtr->tailcallPtr);
+ TclSpliceTailcall(interp, framePtr->tailcallPtr);
}
}
@@ -690,8 +690,8 @@ Tcl_CreateNamespace(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't create namespace \"\": "
"only global namespace can have empty name", NULL);
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
- "CREATEGLOBAL", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
+ "CREATEGLOBAL", NULL);
return NULL;
} else {
/*
@@ -727,8 +727,8 @@ Tcl_CreateNamespace(
) {
Tcl_AppendResult(interp, "can't create namespace \"", name,
"\": already exists", NULL);
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
- "CREATEEXISTING", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
+ "CREATEEXISTING", NULL);
return NULL;
}
}
@@ -1339,7 +1339,7 @@ Tcl_Export(
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_AppendResult(interp, "invalid export pattern \"", pattern,
"\": pattern can't specify a namespace", NULL);
- Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
return TCL_ERROR;
}
@@ -1544,7 +1544,7 @@ Tcl_Import(
if (strlen(pattern) == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr,
@@ -1562,12 +1562,12 @@ Tcl_Import(
Tcl_AppendResult(interp,
"no namespace specified in import pattern \"", pattern,
"\"", NULL);
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
} else {
Tcl_AppendResult(interp, "import pattern \"", pattern,
"\" tries to import from namespace \"",
importNsPtr->name, "\" into itself", NULL);
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
}
return TCL_ERROR;
}
@@ -1689,7 +1689,7 @@ DoImport(
"\" would create a loop containing command \"",
Tcl_DStringValue(&ds), "\"", NULL);
Tcl_DStringFree(&ds);
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
return TCL_ERROR;
}
}
@@ -1729,7 +1729,7 @@ DoImport(
}
Tcl_AppendResult(interp, "can't import command \"", cmdName,
"\": already exists", NULL);
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -3286,12 +3286,12 @@ NRNamespaceEvalCmd(
}
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
- framePtr->objc = objc;
- framePtr->objv = objv;
+ framePtr->objc = objc;
+ framePtr->objv = objv;
} else {
- framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
- - iPtr->ensembleRewrite.numInsertedObjs;
- framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
+ framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
+ - iPtr->ensembleRewrite.numInsertedObjs;
+ framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
}
if (objc == 3) {
@@ -3749,12 +3749,12 @@ NRNamespaceInscopeCmd(
}
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
- framePtr->objc = objc;
- framePtr->objv = objv;
+ framePtr->objc = objc;
+ framePtr->objv = objv;
} else {
- framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
- - iPtr->ensembleRewrite.numInsertedObjs;
- framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
+ framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
+ - iPtr->ensembleRewrite.numInsertedObjs;
+ framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
}
/*
@@ -3959,15 +3959,15 @@ NamespacePathCmd(
*/
if (objc == 1) {
- Tcl_Obj *resultObj = Tcl_NewObj();
+ Tcl_Obj *resultObj = Tcl_NewObj();
for (i=0 ; i<nsPtr->commandPathLength ; i++) {
if (nsPtr->commandPathArray[i].nsPtr != NULL) {
- Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
- nsPtr->commandPathArray[i].nsPtr->fullName, -1));
+ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
+ nsPtr->commandPathArray[i].nsPtr->fullName, -1));
}
}
- Tcl_SetObjResult(interp, resultObj);
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
@@ -4844,8 +4844,8 @@ TclLogCommandInfo(
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 */
+ Tcl_Obj **tosPtr) /* Current stack of bytecode execution
+ * context */
{
register const char *p;
Interp *iPtr = (Interp *) interp;
@@ -4862,55 +4862,55 @@ TclLogCommandInfo(
}
if (command != NULL) {
- /*
- * Compute the line number where the error occurred.
- */
-
- iPtr->errorLine = 1;
- for (p = script; p != command; p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
-
- if (length < 0) {
- length = strlen(command);
- }
- overflow = (length > limit);
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ /*
+ * Compute the line number where the error occurred.
+ */
+
+ iPtr->errorLine = 1;
+ for (p = script; p != command; p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+
+ if (length < 0) {
+ length = strlen(command);
+ }
+ overflow = (length > limit);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
? "while executing" : "invoked from within"),
(overflow ? limit : length), command,
(overflow ? "..." : "")));
- varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
+ varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
NULL, 0, 0, &arrayPtr);
- if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
- /*
- * Should not happen.
- */
-
- return;
- } else {
- Tcl_HashEntry *hPtr
+ if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
+ /*
+ * Should not happen.
+ */
+
+ return;
+ } else {
+ Tcl_HashEntry *hPtr
= Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
- VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
+ VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
- if (tracePtr->traceProc != EstablishErrorInfoTraces) {
- /*
- * The most recent trace set on ::errorInfo is not the one the
- * core itself puts on last. This means some other code is
+ if (tracePtr->traceProc != EstablishErrorInfoTraces) {
+ /*
+ * The most recent trace set on ::errorInfo is not the one the
+ * core itself puts on last. This means some other code is
* tracing the variable, and the additional trace(s) might be
* write traces that expect the timing of writes to
* ::errorInfo that existed Tcl releases before 8.5. To
* satisfy that compatibility need, we write the current
* -errorinfo value to the ::errorInfo variable.
- */
+ */
- Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
+ Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
TCL_GLOBAL_ONLY);
- }
- }
+ }
+ }
}
/*
@@ -4918,60 +4918,60 @@ TclLogCommandInfo(
*/
if (Tcl_IsShared(iPtr->errorStack)) {
- Tcl_Obj *newObj;
-
- newObj = Tcl_DuplicateObj(iPtr->errorStack);
- Tcl_DecrRefCount(iPtr->errorStack);
- Tcl_IncrRefCount(newObj);
- iPtr->errorStack = newObj;
+ 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;
+ 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));
- }
+ /*
+ * 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.
- */
+ /*
+ * Special frame, nothing to report.
+ */
} else if (iPtr->varFramePtr != iPtr->framePtr) {
- /*
- * uplevel case, [lappend errorstack UP $relativelevel]
- */
+ /*
+ * uplevel case, [lappend errorstack UP $relativelevel]
+ */
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
+ 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]]
- */
+ /*
+ * normal case, [lappend errorstack CALL [info level 0]]
+ */
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
iPtr->framePtr->objc, iPtr->framePtr->objv));
}
}
@@ -4981,8 +4981,8 @@ TclLogCommandInfo(
*
* TclErrorStackResetIf --
*
- * The TIP 348 reset/no-bc part of TLCI, for specific use by
- * TclCompileSyntaxError.
+ * The TIP 348 reset/no-bc part of TLCI, for specific use by
+ * TclCompileSyntaxError.
*
* Results:
* None.
@@ -5003,27 +5003,27 @@ TclErrorStackResetIf(
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;
+ 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;
+ iPtr->resetErrorStack = 0;
Tcl_ListObjLength(interp, iPtr->errorStack, &len);
- /*
- * Reset while keeping the list intrep as much as possible.
- */
+ /*
+ * 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_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+ Tcl_NewStringObj(msg, length));
}
}
@@ -5066,6 +5066,5 @@ Tcl_LogCommandInfo(
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
- * indent-tabs-mode: nil
* End:
*/
diff --git a/tests/info.test b/tests/info.test
index 3323281..a9f740e 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -1955,6 +1955,12 @@ test info-38.2 {location information for uplevel, dl, direct-literal} -match glo
* {type source line 1951 file info.test cmd etrace level 1}
* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
+# This test at the end of this file _only_ to avoid disturbing above line
+# numbers. It _belongs_ after info-9.12
+test info-9.13 {info level option, value in global context} -body {
+ uplevel #0 {info level 2}
+} -returnCodes error -result {bad level "2"}
+
# -------------------------------------------------------------------------
unset -nocomplain res