Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Compilation of misc info sometimes used in high-performance code. |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | dkf-bytecode-8.6-main |
Files: | files | file ages | folders |
SHA1: |
2eebfcc371a209c65fe57a07c8fa6149 |
User & Date: | dkf 2012-03-04 16:52:01 |
Context
2012-03-08
| ||
09:01 | merge from trunk check-in: 198464a9f4 user: dkf tags: dkf-bytecode-8.6-main | |
2012-03-04
| ||
16:52 | Compilation of misc info sometimes used in high-performance code. check-in: 2eebfcc371 user: dkf tags: dkf-bytecode-8.6-main | |
2012-03-02
| ||
10:07 | Add bug number. check-in: a17072b253 user: dkf tags: trunk | |
Changes
Changes to generic/tclAssembly.c.
︙ | ︙ | |||
365 366 367 368 369 370 371 372 373 374 375 376 377 378 | {"beginCatch", ASSEM_BEGIN_CATCH, INST_BEGIN_CATCH4, 0, 0}, {"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1}, {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,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}, {"dictIncrImm", ASSEM_SINT4_LVT4, INST_DICT_INCR_IMM, 1, 1}, {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, {"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0}, | > | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 | {"beginCatch", ASSEM_BEGIN_CATCH, INST_BEGIN_CATCH4, 0, 0}, {"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1}, {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, {"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}, {"dictIncrImm", ASSEM_SINT4_LVT4, INST_DICT_INCR_IMM, 1, 1}, {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, {"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0}, |
︙ | ︙ | |||
402 403 404 405 406 407 408 409 410 411 412 413 414 415 | {"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 3, 1}, {"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1}, {"incrImm", ASSEM_LVT1_SINT1, INST_INCR_SCALAR1_IMM, 0, 1}, {"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1}, {"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM, 1, 1}, {"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8 | INST_INVOKE_STK4), INT_MIN,1}, {"jump", ASSEM_JUMP, INST_JUMP1, 0, 0}, {"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0}, {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0}, {"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0}, {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0}, | > > | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 | {"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 3, 1}, {"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1}, {"incrImm", ASSEM_LVT1_SINT1, INST_INCR_SCALAR1_IMM, 0, 1}, {"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}, {"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0}, {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0}, {"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0}, {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0}, |
︙ | ︙ | |||
445 446 447 448 449 450 451 452 453 454 455 456 457 458 | {"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1}, {"lt", ASSEM_1BYTE, INST_LT, 2, 1}, {"mod", ASSEM_1BYTE, INST_MOD, 2, 1}, {"mult", ASSEM_1BYTE, INST_MULT, 2, 1}, {"neq", ASSEM_1BYTE, INST_NEQ, 2, 1}, {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, {"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1}, {"pushReturnOpts", ASSEM_1BYTE, INST_PUSH_RETURN_OPTIONS, 0, 1}, {"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1}, | > | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 | {"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1}, {"lt", ASSEM_1BYTE, INST_LT, 2, 1}, {"mod", ASSEM_1BYTE, INST_MOD, 2, 1}, {"mult", ASSEM_1BYTE, INST_MULT, 2, 1}, {"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}, {"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1}, {"pushReturnOpts", ASSEM_1BYTE, INST_PUSH_RETURN_OPTIONS, 0, 1}, {"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1}, |
︙ | ︙ | |||
495 496 497 498 499 500 501 | static unsigned char NonThrowingByteCodes[] = { INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ INST_JUMP1, INST_JUMP4, /* 34-35 */ INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ INST_OVER, /* 95 */ INST_PUSH_RETURN_OPTIONS, /* 108 */ INST_REVERSE, /* 126 */ | | > > > | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 | static unsigned char NonThrowingByteCodes[] = { INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ INST_JUMP1, INST_JUMP4, /* 34-35 */ INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ INST_OVER, /* 95 */ INST_PUSH_RETURN_OPTIONS, /* 108 */ INST_REVERSE, /* 126 */ INST_NOP, /* 132 */ INST_NS_CURRENT, /* 141 */ INST_COROUTINE_NAME, /* 142 */ INST_INFO_LEVEL_NUM /* 143 */ }; /* * Helper macros. */ #if defined(TCL_DEBUG_ASSEMBLY) && defined(__GNUC__) && __GNUC__ > 2 |
︙ | ︙ |
Changes to generic/tclCmdIL.c.
︙ | ︙ | |||
162 163 164 165 166 167 168 | static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, NULL, NULL, NULL, 0}, {"body", InfoBodyCmd, NULL, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0}, {"commands", InfoCommandsCmd, NULL, NULL, NULL, 0}, {"complete", InfoCompleteCmd, NULL, NULL, NULL, 0}, | | | | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 | static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, NULL, NULL, NULL, 0}, {"body", InfoBodyCmd, NULL, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0}, {"commands", InfoCommandsCmd, NULL, NULL, NULL, 0}, {"complete", InfoCompleteCmd, 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}, {"frame", InfoFrameCmd, NULL, NULL, NULL, 0}, {"functions", InfoFunctionsCmd, NULL, NULL, NULL, 0}, {"globals", TclInfoGlobalsCmd, NULL, NULL, NULL, 0}, {"hostname", InfoHostnameCmd, 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}, {"nameofexecutable", InfoNameOfExecutableCmd, NULL, NULL, NULL, 0}, {"patchlevel", InfoPatchLevelCmd, NULL, NULL, NULL, 0}, {"procs", InfoProcsCmd, NULL, NULL, NULL, 0}, {"script", InfoScriptCmd, NULL, NULL, NULL, 0}, |
︙ | ︙ |
Changes to generic/tclCompCmds.c.
︙ | ︙ | |||
2813 2814 2815 2816 2817 2818 2819 | return TCL_OK; } /* *---------------------------------------------------------------------- * | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > | 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 | return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileInfo*Cmd -- * * 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" 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 * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being |
︙ | ︙ | |||
2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 | } else { TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLappendCmd -- * * Procedure called to compile the "lappend" command. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 | } else { TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr); } } 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; } /* *---------------------------------------------------------------------- * * TclCompileLappendCmd -- * * Procedure called to compile the "lappend" command. |
︙ | ︙ | |||
3696 3697 3698 3699 3700 3701 3702 | return TCL_OK; } /* *---------------------------------------------------------------------- * | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > | 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 | return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileNamespace*Cmd -- * * 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 * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "namespace upvar" * command at runtime. * *---------------------------------------------------------------------- */ 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 * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being |
︙ | ︙ |
Changes to generic/tclCompile.c.
︙ | ︙ | |||
33 34 35 36 37 38 39 | * This variable is linked to the Tcl variable "tcl_traceCompile". */ #ifdef TCL_COMPILE_DEBUG int tclTraceCompile = 0; static int traceInitialized = 0; #endif | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | * This variable is linked to the Tcl variable "tcl_traceCompile". */ #ifdef TCL_COMPILE_DEBUG 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 * names "op1" and "op4" refer to an instruction's one or four byte first * operand. Similarly, "stktop" and "stknext" refer to the topmost and next to * topmost stack elements. * |
︙ | ︙ | |||
430 431 432 433 434 435 436 437 438 439 440 441 442 443 | /* Map variable contents back into a dictionary in a variable. Part of * [dict with]. * Stack: ... dictVarName path keyList => ... */ {"dictRecombineImm", 1, -2, 1, {OPERAND_LVT4}}, /* Map variable contents back into a dictionary in the local variable * indicated by the LVT index. Part of [dict with]. * Stack: ... path keyList => ... */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; /* * Prototypes for procedures defined later in this file: */ | > > > > > > > > > > > > > > | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 | /* Map variable contents back into a dictionary in a variable. Part of * [dict with]. * Stack: ... dictVarName path keyList => ... */ {"dictRecombineImm", 1, -2, 1, {OPERAND_LVT4}}, /* Map variable contents back into a dictionary in the local variable * 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}} }; /* * Prototypes for procedures defined later in this file: */ |
︙ | ︙ | |||
1669 1670 1671 1672 1673 1674 1675 | (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL) && !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { | | | | 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 | (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL) && !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { int code, savedNumCmds = envPtr->numCommands; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; int update = 0; /* * Mark the start of the command; the proper bytecode * length will be updated later. There is no need to * do this for the first bytecode in the compile env, * as the check is done before calling * TclNRExecuteByteCode(). Do emit an INST_START_CMD in |
︙ | ︙ | |||
4623 4624 4625 4626 4627 4628 4629 | /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 | < | 4637 4638 4639 4640 4641 4642 4643 4644 4645 | /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 * End: */ |
Changes to generic/tclCompile.h.
︙ | ︙ | |||
677 678 679 680 681 682 683 684 | #define INST_UNSET_STK 137 /* For [dict with] compilation */ #define INST_DICT_EXPAND 138 #define INST_DICT_RECOMBINE_STK 139 #define INST_DICT_RECOMBINE_IMM 140 /* The last opcode */ | > > > > > > | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 | #define INST_UNSET_STK 137 /* For [dict with] compilation */ #define INST_DICT_EXPAND 138 #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 144 /* * Table describing the Tcl bytecode instructions: their name (for displaying * code), total number of code bytes required (including operand bytes), and a * description of the type of each operand. These operand types include signed * and unsigned integers of length one and four bytes. The unsigned integers * are used for indexes or for, e.g., the count of objects to push in a "push" |
︙ | ︙ |
Changes to generic/tclExecute.c.
︙ | ︙ | |||
4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 | } else { iResult = (i1 && i2); } objResultPtr = TCONST(iResult); TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); NEXT_INST_F(1, 2, 1); } /* * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ { | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 | } else { iResult = (i1 && i2); } objResultPtr = TCONST(iResult); TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); NEXT_INST_F(1, 2, 1); } /* * ----------------------------------------------------------------- * 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. */ { |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIfCmd(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 TclCompileIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); | > > > > > > | 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); 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); MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); |
︙ | ︙ | |||
3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLsetCmd(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); MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); | > > > | 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); 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); MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); |
︙ | ︙ |
Changes to generic/tclNamesp.c.
︙ | ︙ | |||
100 101 102 103 104 105 106 | static int NamespaceCurrentCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NRNamespaceEvalCmd(ClientData dummy, | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | static int NamespaceCurrentCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); 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[]); static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void NamespaceFree(Namespace *nsPtr); |
︙ | ︙ | |||
156 157 158 159 160 161 162 | /* * Array of values describing how to implement each standard subcommand of the * "namespace" command. */ static const EnsembleImplMap defaultNamespaceMap[] = { | | | | | | | | | | | | | | | | | | | | | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 | /* * Array of values describing how to implement each standard subcommand of the * "namespace" command. */ static const EnsembleImplMap defaultNamespaceMap[] = { {"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} }; /* *---------------------------------------------------------------------- * * TclInitNamespaceSubsystem -- |
︙ | ︙ | |||
419 420 421 422 423 424 425 | if ((nsPtr->flags & NS_DYING) && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) { Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } framePtr->nsPtr = NULL; if (framePtr->tailcallPtr) { | | | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 | if ((nsPtr->flags & NS_DYING) && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) { Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } framePtr->nsPtr = NULL; if (framePtr->tailcallPtr) { TclSpliceTailcall(interp, framePtr->tailcallPtr); } } /* *---------------------------------------------------------------------- * * TclPushStackFrame -- |
︙ | ︙ | |||
686 687 688 689 690 691 692 | parentPtr = NULL; simpleName = ""; } else if (*name == '\0') { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't create namespace \"\": " "only global namespace can have empty name", NULL); | | | | 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 | parentPtr = NULL; simpleName = ""; } else if (*name == '\0') { 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); return NULL; } else { /* * Find the parent for the new namespace. */ TclGetNamespaceForQualName(interp, name, NULL, |
︙ | ︙ | |||
723 724 725 726 727 728 729 | #else parentPtr->childTablePtr != NULL && Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL #endif ) { Tcl_AppendResult(interp, "can't create namespace \"", name, "\": already exists", NULL); | | | | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 | #else parentPtr->childTablePtr != NULL && Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL #endif ) { Tcl_AppendResult(interp, "can't create namespace \"", name, "\": already exists", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", "CREATEEXISTING", NULL); return NULL; } } /* * Create the new namespace and root it in its parent. Increment the count * of namespaces created. |
︙ | ︙ | |||
1335 1336 1337 1338 1339 1340 1341 | TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_AppendResult(interp, "invalid export pattern \"", pattern, "\": pattern can't specify a namespace", NULL); | | | 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 | TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); 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); return TCL_ERROR; } /* * Make sure that we don't already have the pattern in the array */ |
︙ | ︙ | |||
1540 1541 1542 1543 1544 1545 1546 | /* * From the pattern, find the namespace from which we are importing and * get the simple pattern (no namespace qualifiers or ::'s) at the end. */ if (strlen(pattern) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1)); | | | | | 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 | /* * From the pattern, find the namespace from which we are importing and * get the simple pattern (no namespace qualifiers or ::'s) at the end. */ if (strlen(pattern) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1)); Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { Tcl_AppendResult(interp, "unknown namespace in import pattern \"", pattern, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } if (importNsPtr == nsPtr) { if (pattern == simplePattern) { Tcl_AppendResult(interp, "no namespace specified in import pattern \"", pattern, "\"", 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); } return TCL_ERROR; } /* * Scan through the command table in the source namespace and look for * exported commands that match the string pattern. Create an "imported |
︙ | ︙ | |||
1685 1686 1687 1688 1689 1690 1691 | dataPtr = linkCmd->objClientData; linkCmd = dataPtr->realCmdPtr; if (overwrite == linkCmd) { Tcl_AppendResult(interp, "import pattern \"", pattern, "\" would create a loop containing command \"", Tcl_DStringValue(&ds), "\"", NULL); Tcl_DStringFree(&ds); | | | 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 | dataPtr = linkCmd->objClientData; linkCmd = dataPtr->realCmdPtr; if (overwrite == linkCmd) { Tcl_AppendResult(interp, "import pattern \"", pattern, "\" would create a loop containing command \"", Tcl_DStringValue(&ds), "\"", NULL); Tcl_DStringFree(&ds); Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; } } } dataPtr = ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), |
︙ | ︙ | |||
1725 1726 1727 1728 1729 1730 1731 | */ return TCL_OK; } } Tcl_AppendResult(interp, "can't import command \"", cmdName, "\": already exists", NULL); | | | 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 | */ return TCL_OK; } } Tcl_AppendResult(interp, "can't import command \"", cmdName, "\": already exists", NULL); Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
3282 3283 3284 3285 3286 3287 3288 | result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return TCL_ERROR; } if (iPtr->ensembleRewrite.sourceObjs == NULL) { | | | | | | | 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 | result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return TCL_ERROR; } if (iPtr->ensembleRewrite.sourceObjs == NULL) { framePtr->objc = objc; framePtr->objv = objv; } else { framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs - iPtr->ensembleRewrite.numInsertedObjs; framePtr->objv = iPtr->ensembleRewrite.sourceObjs; } if (objc == 3) { /* * TIP #280: Make actual argument location available to eval'd script. */ |
︙ | ︙ | |||
3745 3746 3747 3748 3749 3750 3751 | result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; } if (iPtr->ensembleRewrite.sourceObjs == NULL) { | | | | | | | 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 | result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; } if (iPtr->ensembleRewrite.sourceObjs == NULL) { framePtr->objc = objc; framePtr->objv = objv; } else { framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs - iPtr->ensembleRewrite.numInsertedObjs; framePtr->objv = iPtr->ensembleRewrite.sourceObjs; } /* * Execute the command. If there is just one argument, just treat it as a * script and evaluate it. Otherwise, create a list from the arguments * after the first one, then concatenate the first argument and the list * of extra arguments to form the command to evaluate. |
︙ | ︙ | |||
3955 3956 3957 3958 3959 3960 3961 | } /* * If no path is given, return the current path. */ if (objc == 1) { | | | | | | 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 | } /* * If no path is given, return the current path. */ if (objc == 1) { 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_SetObjResult(interp, resultObj); return TCL_OK; } /* * There is a path given, so parse it into an array of namespace pointers. */ |
︙ | ︙ | |||
4840 4841 4842 4843 4844 4845 4846 | 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). */ const unsigned char *pc, /* Current pc of bytecode execution context */ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 | 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). */ 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; int overflow, limit = 150; Var *varPtr, *arrayPtr; if (iPtr->flags & ERR_ALREADY_LOGGED) { /* * Someone else has already logged error information for this command; * we shouldn't add anything more. */ return; } 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( "\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, NULL, 0, 0, &arrayPtr); if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { /* * Should not happen. */ return; } else { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); 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 * 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_GLOBAL_ONLY); } } } /* * 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 -- |
︙ | ︙ | |||
5062 5063 5064 5065 5066 5067 5068 | /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 | < | 5062 5063 5064 5065 5066 5067 5068 5069 5070 | /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 * End: */ |
Changes to tests/info.test.
︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 | set y DL. etrace }] 0 2] \n } } -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0} * {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} # ------------------------------------------------------------------------- unset -nocomplain res # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests | > > > > > > | 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 | set y DL. etrace }] 0 2] \n } } -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0} * {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 # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests |
︙ | ︙ |