diff options
| -rw-r--r-- | generic/tclAssembly.c | 9 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 4 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 102 | ||||
| -rw-r--r-- | generic/tclCompile.c | 21 | ||||
| -rw-r--r-- | generic/tclCompile.h | 8 | ||||
| -rw-r--r-- | generic/tclExecute.c | 64 | ||||
| -rw-r--r-- | generic/tclInt.h | 9 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 275 | ||||
| -rw-r--r-- | tests/info.test | 6 |
9 files changed, 344 insertions, 154 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 83f4fe9..a266350 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -369,6 +369,7 @@ static const 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 @@ static const 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 @@ static const 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 const 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 14e0092..14e9f0e 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 61f7988..64417c5 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2961,22 +2961,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 @@ -3027,6 +3052,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; +} /* *---------------------------------------------------------------------- @@ -3875,11 +3936,11 @@ TclCompileLmapCmd( /* *---------------------------------------------------------------------- * - * 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 @@ -3893,6 +3954,31 @@ TclCompileLmapCmd( */ 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 d4ca284..4c84953 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 @@ -4620,6 +4634,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 ba78c36..4e039a2 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 3c0b472..1041f65 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 c716ed2..0b84914 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3550,9 +3550,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); @@ -3583,6 +3589,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 3c93400..d98de97 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); } } @@ -689,8 +689,8 @@ Tcl_CreateNamespace( } else if (*name == '\0') { Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace" " \"\": only global namespace can have empty name", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", - "CREATEGLOBAL", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEGLOBAL", NULL); return NULL; } else { /* @@ -726,8 +726,8 @@ Tcl_CreateNamespace( ) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create namespace \"%s\": already exists", name)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", - "CREATEEXISTING", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEEXISTING", NULL); return NULL; } } @@ -1337,7 +1337,7 @@ Tcl_Export( if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern" " \"%s\": pattern can't specify a namespace", pattern)); - Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); + Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); return TCL_ERROR; } @@ -1542,7 +1542,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, @@ -1560,12 +1560,12 @@ Tcl_Import( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no namespace specified in import pattern \"%s\"", pattern)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "import pattern \"%s\" tries to import from namespace" " \"%s\" into itself", pattern, importNsPtr->name)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); } return TCL_ERROR; } @@ -1688,7 +1688,7 @@ DoImport( " containing command \"%s\"", pattern, Tcl_DStringValue(&ds))); Tcl_DStringFree(&ds); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; } } @@ -1728,7 +1728,7 @@ DoImport( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't import command \"%s\": already exists", cmdName)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); return TCL_ERROR; } return TCL_OK; @@ -3285,12 +3285,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) { @@ -3748,12 +3748,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; } /* @@ -3958,15 +3958,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; } @@ -4843,8 +4843,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; @@ -4861,55 +4861,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); - } - } + } + } } /* @@ -4917,60 +4917,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)); } } @@ -4980,8 +4980,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. @@ -5002,27 +5002,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)); } } @@ -5065,6 +5065,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 7dd63b7..5078e11 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 |