Tcl Source Code

Check-in [2eebfcc371]
Login

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: 2eebfcc371a209c65fe57a07c8fa6149e5603967
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
Hide Diffs Unified Diffs Ignore Whitespace Patch

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
502



503
504
505
506
507
508
509
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 */



};

/*
 * Helper macros.
 */

#if defined(TCL_DEBUG_ASSEMBLY) && defined(__GNUC__) && __GNUC__ > 2







|
>
>
>







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
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,     NULL, 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,	    NULL, 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},







|







|







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
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833

























2834
2835
2836
2837
2838
2839
2840

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileInfoExistsCmd --
 *
 *	Procedure called to compile the "info exists" subcommand.
 *
 * 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.
 *
 *----------------------------------------------------------------------
 */


























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







|

|






|
|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718

























3719
3720
3721
3722
3723
3724
3725

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileNamespaceCmd --
 *
 *	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.
 *
 * 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
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







|

|
|
|











>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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
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.
 *







|







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
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
			    (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 savedNumCmds = envPtr->numCommands;
			unsigned savedCodeNext =
				envPtr->codeNext - envPtr->codeStart;
			int update = 0, code;

			/*
			 * 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







|


|







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
4630
4631
4632

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * tab-width: 8
 * indent-tabs-mode: nil
 * End:
 */







<


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
685
686
687
688
689
690
691
692
#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 */
#define LAST_INST_OPCODE		140

/*
 * 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"







>
>
>
>
>
>

|







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
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);







|







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
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, 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},
    {NULL, NULL, NULL, NULL, NULL, 0}
};

/*
 *----------------------------------------------------------------------
 *
 * TclInitNamespaceSubsystem --







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







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
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 --







|







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
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,







|
|







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
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.







|
|







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
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
     */








|







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
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







|

















|




|







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
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),







|







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
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;
}

/*
 *----------------------------------------------------------------------







|







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
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.
	 */








|
|

|
|
|







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
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.







|
|

|
|
|







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
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.
     */








|



|
|


|







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
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 --







|
|
















|
|
|

|
|
|
|
|
|

|
|
|
|
|





|

|
|
|
|

|
|
|

|

|
|
|
|





|

|

|
|







|
|
|
|
|
|




|


|
|
|

|
|
|

|
|
|
|
|
|
|
|
|
|
|
|



|
|
|

|
|
|

|
|


|
|
|

|
|









|
|




















|
|
|
|
|
|




|


|
|
|

|
|
|
|







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
5069
5070
5071

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * tab-width: 8
 * indent-tabs-mode: nil
 * End:
 */







<


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