Tcl Source Code

Check-in [9b04dd8ea0]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Added a script-readable bytecode disassembler in tcl::unsupported.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 9b04dd8ea0771e71333753c60820215e51f46a7e
User & Date: dkf 2014-09-20 12:37:19
Context
2014-09-29
11:49
Merge new disassembler. DOES NOT BUILD! tclDisassemble.c still needs conversion. check-in: 16dfcd4ff8 user: dgp tags: dgp-refactor
2014-09-25
18:47
comment fix check-in: 39d3ca2cad user: dgp tags: trunk
2014-09-22
18:27
Merge with trunk check-in: aa4f784295 user: hypnotoad tags: core_zip_vfs
2014-09-20
12:37
Added a script-readable bytecode disassembler in tcl::unsupported. check-in: 9b04dd8ea0 user: dkf tags: trunk
11:40
Tidy things up a bit more. Closed-Leaf check-in: e31506063b user: dkf tags: dkf-improved-disassembler
2014-09-17
10:47
merge-mark check-in: c3abb5be5a user: jan.nijtmans tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclBasic.c.

836
837
838
839
840
841
842
843


844
845
846
847
848
849
850
	    TclDefaultBgErrorHandlerObjCmd, NULL, NULL);

    /*
     * Create unsupported commands for debugging bytecode and objects.
     */

    Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
	    Tcl_DisassembleObjCmd, NULL, NULL);


    Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
	    Tcl_RepresentationCmd, NULL, NULL);

    /* Adding the bytecode assembler command */
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);






|
>
>







836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
	    TclDefaultBgErrorHandlerObjCmd, NULL, NULL);

    /*
     * Create unsupported commands for debugging bytecode and objects.
     */

    Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
	    Tcl_DisassembleObjCmd, INT2PTR(0), NULL);
    Tcl_CreateObjCommand(interp, "::tcl::unsupported::getbytecode",
	    Tcl_DisassembleObjCmd, INT2PTR(1), NULL);
    Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
	    Tcl_RepresentationCmd, NULL, NULL);

    /* Adding the bytecode assembler command */
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);

Changes to generic/tclCompCmds.c.

21
22
23
24
25
26
27



28
29
30
31
32



33
34
35



36
37
38
39
40
41
42
..
45
46
47
48
49
50
51
52

53
54
55
56
57
58
59

60
61
62
63
64
65
66

67
68
69
70
71
72
73
....
2080
2081
2082
2083
2084
2085
2086

2087
2088
2089
2090
2091

2092
2093
2094
2095
2096
2097
2098
....
2127
2128
2129
2130
2131
2132
2133



















2134
2135
2136
2137
2138
2139
2140
....
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
....
2888
2889
2890
2891
2892
2893
2894



















































































2895
2896
2897
2898
2899
2900
2901
 * Prototypes for procedures defined later in this file:
 */

static ClientData	DupDictUpdateInfo(ClientData clientData);
static void		FreeDictUpdateInfo(ClientData clientData);
static void		PrintDictUpdateInfo(ClientData clientData,
			    Tcl_Obj *appendObj, ByteCode *codePtr,



			    unsigned int pcOffset);
static ClientData	DupForeachInfo(ClientData clientData);
static void		FreeForeachInfo(ClientData clientData);
static void		PrintForeachInfo(ClientData clientData,
			    Tcl_Obj *appendObj, ByteCode *codePtr,



			    unsigned int pcOffset);
static void		PrintNewForeachInfo(ClientData clientData,
			    Tcl_Obj *appendObj, ByteCode *codePtr,



			    unsigned int pcOffset);
static int		CompileEachloopCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    CompileEnv *envPtr, int collect);
static int		CompileDictEachCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr, int collect);
................................................................................
 * The structures below define the AuxData types defined in this file.
 */

const AuxDataType tclForeachInfoType = {
    "ForeachInfo",		/* name */
    DupForeachInfo,		/* dupProc */
    FreeForeachInfo,		/* freeProc */
    PrintForeachInfo		/* printProc */

};

const AuxDataType tclNewForeachInfoType = {
    "NewForeachInfo",		/* name */
    DupForeachInfo,		/* dupProc */
    FreeForeachInfo,		/* freeProc */
    PrintNewForeachInfo		/* printProc */

};

const AuxDataType tclDictUpdateInfoType = {
    "DictUpdateInfo",		/* name */
    DupDictUpdateInfo,		/* dupProc */
    FreeDictUpdateInfo,		/* freeProc */
    PrintDictUpdateInfo		/* printProc */

};
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileAppendCmd --
 *
................................................................................
 *	Functions to duplicate, release and print the aux data created for use
 *	with the INST_DICT_UPDATE_START and INST_DICT_UPDATE_END instructions.
 *
 * Results:
 *	DupDictUpdateInfo: a copy of the auxiliary data
 *	FreeDictUpdateInfo: none
 *	PrintDictUpdateInfo: none

 *
 * Side effects:
 *	DupDictUpdateInfo: allocates memory
 *	FreeDictUpdateInfo: releases memory
 *	PrintDictUpdateInfo: none

 *
 *----------------------------------------------------------------------
 */

static ClientData
DupDictUpdateInfo(
    ClientData clientData)
................................................................................
    for (i=0 ; i<duiPtr->length ; i++) {
	if (i) {
	    Tcl_AppendToObj(appendObj, ", ", -1);
	}
	Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
    }
}



















 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileErrorCmd --
 *
 *	Procedure called to compile the "error" command.
................................................................................
    }
    ckfree(infoPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * PrintForeachInfo --
 *
 *	Function to write a human-readable representation of a ForeachInfo
 *	structure to stdout for debugging.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
................................................................................
	    }
	    Tcl_AppendPrintfToObj(appendObj, "%%v%u",
		    (unsigned) varsPtr->varIndexes[j]);
	}
	Tcl_AppendToObj(appendObj, "]", -1);
    }
}



















































































 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileFormatCmd --
 *
 *	Procedure called to compile the "format" command. Handles cases that






>
>
>





>
>
>



>
>
>







 







|
>






|
>






|
>







 







>





>







 







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







 







|

|
|







 







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







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
..
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
....
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
....
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
....
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
....
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
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
 * Prototypes for procedures defined later in this file:
 */

static ClientData	DupDictUpdateInfo(ClientData clientData);
static void		FreeDictUpdateInfo(ClientData clientData);
static void		PrintDictUpdateInfo(ClientData clientData,
			    Tcl_Obj *appendObj, ByteCode *codePtr,
			    unsigned int pcOffset);
static void		DisassembleDictUpdateInfo(ClientData clientData,
			    Tcl_Obj *dictObj, ByteCode *codePtr,
			    unsigned int pcOffset);
static ClientData	DupForeachInfo(ClientData clientData);
static void		FreeForeachInfo(ClientData clientData);
static void		PrintForeachInfo(ClientData clientData,
			    Tcl_Obj *appendObj, ByteCode *codePtr,
			    unsigned int pcOffset);
static void		DisassembleForeachInfo(ClientData clientData,
			    Tcl_Obj *dictObj, ByteCode *codePtr,
			    unsigned int pcOffset);
static void		PrintNewForeachInfo(ClientData clientData,
			    Tcl_Obj *appendObj, ByteCode *codePtr,
			    unsigned int pcOffset);
static void		DisassembleNewForeachInfo(ClientData clientData,
			    Tcl_Obj *dictObj, ByteCode *codePtr,
			    unsigned int pcOffset);
static int		CompileEachloopCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    CompileEnv *envPtr, int collect);
static int		CompileDictEachCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr, int collect);
................................................................................
 * The structures below define the AuxData types defined in this file.
 */

const AuxDataType tclForeachInfoType = {
    "ForeachInfo",		/* name */
    DupForeachInfo,		/* dupProc */
    FreeForeachInfo,		/* freeProc */
    PrintForeachInfo,		/* printProc */
    DisassembleForeachInfo	/* disassembleProc */
};

const AuxDataType tclNewForeachInfoType = {
    "NewForeachInfo",		/* name */
    DupForeachInfo,		/* dupProc */
    FreeForeachInfo,		/* freeProc */
    PrintNewForeachInfo,	/* printProc */
    DisassembleNewForeachInfo	/* disassembleProc */
};

const AuxDataType tclDictUpdateInfoType = {
    "DictUpdateInfo",		/* name */
    DupDictUpdateInfo,		/* dupProc */
    FreeDictUpdateInfo,		/* freeProc */
    PrintDictUpdateInfo,	/* printProc */
    DisassembleDictUpdateInfo	/* disassembleProc */
};
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileAppendCmd --
 *
................................................................................
 *	Functions to duplicate, release and print the aux data created for use
 *	with the INST_DICT_UPDATE_START and INST_DICT_UPDATE_END instructions.
 *
 * Results:
 *	DupDictUpdateInfo: a copy of the auxiliary data
 *	FreeDictUpdateInfo: none
 *	PrintDictUpdateInfo: none
 *	DisassembleDictUpdateInfo: none
 *
 * Side effects:
 *	DupDictUpdateInfo: allocates memory
 *	FreeDictUpdateInfo: releases memory
 *	PrintDictUpdateInfo: none
 *	DisassembleDictUpdateInfo: none
 *
 *----------------------------------------------------------------------
 */

static ClientData
DupDictUpdateInfo(
    ClientData clientData)
................................................................................
    for (i=0 ; i<duiPtr->length ; i++) {
	if (i) {
	    Tcl_AppendToObj(appendObj, ", ", -1);
	}
	Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
    }
}

static void
DisassembleDictUpdateInfo(
    ClientData clientData,
    Tcl_Obj *dictObj,
    ByteCode *codePtr,
    unsigned int pcOffset)
{
    DictUpdateInfo *duiPtr = clientData;
    int i;
    Tcl_Obj *variables = Tcl_NewObj();

    for (i=0 ; i<duiPtr->length ; i++) {
	Tcl_ListObjAppendElement(NULL, variables,
		Tcl_NewIntObj(duiPtr->varIndices[i]));
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1),
	    variables);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileErrorCmd --
 *
 *	Procedure called to compile the "error" command.
................................................................................
    }
    ckfree(infoPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * PrintForeachInfo, DisassembleForeachInfo --
 *
 *	Functions to write a human-readable or script-readablerepresentation
 *	of a ForeachInfo structure to a Tcl_Obj for debugging.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
................................................................................
	    }
	    Tcl_AppendPrintfToObj(appendObj, "%%v%u",
		    (unsigned) varsPtr->varIndexes[j]);
	}
	Tcl_AppendToObj(appendObj, "]", -1);
    }
}

static void
DisassembleForeachInfo(
    ClientData clientData,
    Tcl_Obj *dictObj,
    ByteCode *codePtr,
    unsigned int pcOffset)
{
    register ForeachInfo *infoPtr = clientData;
    register ForeachVarList *varsPtr;
    int i, j;
    Tcl_Obj *objPtr, *innerPtr;

    /*
     * Data stores.
     */

    objPtr = Tcl_NewObj();
    for (i=0 ; i<infoPtr->numLists ; i++) {
	Tcl_ListObjAppendElement(NULL, objPtr,
		Tcl_NewIntObj(infoPtr->firstValueTemp + i));
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr);

    /*
     * Loop counter.
     */

    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1),
	   Tcl_NewIntObj(infoPtr->loopCtTemp));

    /*
     * Assignment targets.
     */

    objPtr = Tcl_NewObj();
    for (i=0 ; i<infoPtr->numLists ; i++) {
	innerPtr = Tcl_NewObj();
	varsPtr = infoPtr->varLists[i];
	for (j=0 ; j<varsPtr->numVars ; j++) {
	    Tcl_ListObjAppendElement(NULL, innerPtr,
		    Tcl_NewIntObj(varsPtr->varIndexes[j]));
	}
	Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
}

static void
DisassembleNewForeachInfo(
    ClientData clientData,
    Tcl_Obj *dictObj,
    ByteCode *codePtr,
    unsigned int pcOffset)
{
    register ForeachInfo *infoPtr = clientData;
    register ForeachVarList *varsPtr;
    int i, j;
    Tcl_Obj *objPtr, *innerPtr;

    /*
     * Jump offset.
     */

    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1),
	   Tcl_NewIntObj(infoPtr->loopCtTemp));

    /*
     * Assignment targets.
     */

    objPtr = Tcl_NewObj();
    for (i=0 ; i<infoPtr->numLists ; i++) {
	innerPtr = Tcl_NewObj();
	varsPtr = infoPtr->varLists[i];
	for (j=0 ; j<varsPtr->numVars ; j++) {
	    Tcl_ListObjAppendElement(NULL, innerPtr,
		    Tcl_NewIntObj(varsPtr->varIndexes[j]));
	}
	Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileFormatCmd --
 *
 *	Procedure called to compile the "format" command. Handles cases that

Changes to generic/tclCompCmdsSZ.c.

23
24
25
26
27
28
29



30
31
32
33
34
35
36
..
68
69
70
71
72
73
74
75

76
77
78
79
80
81
82
....
2437
2438
2439
2440
2441
2442
2443

2444
2445
2446
2447
2448

2449
2450
2451
2452
2453
2454
2455
....
2504
2505
2506
2507
2508
2509
2510
























2511
2512
2513
2514
2515
2516
2517
 * Prototypes for procedures defined later in this file:
 */

static ClientData	DupJumptableInfo(ClientData clientData);
static void		FreeJumptableInfo(ClientData clientData);
static void		PrintJumptableInfo(ClientData clientData,
			    Tcl_Obj *appendObj, ByteCode *codePtr,



			    unsigned int pcOffset);
static int		CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, const char *identity,
			    int instruction, CompileEnv *envPtr);
static int		CompileComparisonOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, int instruction,
			    CompileEnv *envPtr);
................................................................................
 * The structures below define the AuxData types defined in this file.
 */

const AuxDataType tclJumptableInfoType = {
    "JumptableInfo",		/* name */
    DupJumptableInfo,		/* dupProc */
    FreeJumptableInfo,		/* freeProc */
    PrintJumptableInfo		/* printProc */

};

/*
 * Shorthand macros for instruction issuing.
 */

#define OP(name)	TclEmitOpcode(INST_##name, envPtr)
................................................................................
 *	Functions to duplicate, release and print a jump-table created for use
 *	with the INST_JUMP_TABLE instruction.
 *
 * Results:
 *	DupJumptableInfo: a copy of the jump-table
 *	FreeJumptableInfo: none
 *	PrintJumptableInfo: none

 *
 * Side effects:
 *	DupJumptableInfo: allocates memory
 *	FreeJumptableInfo: releases memory
 *	PrintJumptableInfo: none

 *
 *----------------------------------------------------------------------
 */

static ClientData
DupJumptableInfo(
    ClientData clientData)
................................................................................
		Tcl_AppendToObj(appendObj, "\n\t\t", -1);
	    }
	}
	Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
		keyPtr, pcOffset + offset);
    }
}
























 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileTailcallCmd --
 *
 *	Procedure called to compile the "tailcall" command.






>
>
>







 







|
>







 







>





>







 







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







23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
..
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
....
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
....
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
 * Prototypes for procedures defined later in this file:
 */

static ClientData	DupJumptableInfo(ClientData clientData);
static void		FreeJumptableInfo(ClientData clientData);
static void		PrintJumptableInfo(ClientData clientData,
			    Tcl_Obj *appendObj, ByteCode *codePtr,
			    unsigned int pcOffset);
static void		DisassembleJumptableInfo(ClientData clientData,
			    Tcl_Obj *dictObj, ByteCode *codePtr,
			    unsigned int pcOffset);
static int		CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, const char *identity,
			    int instruction, CompileEnv *envPtr);
static int		CompileComparisonOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, int instruction,
			    CompileEnv *envPtr);
................................................................................
 * The structures below define the AuxData types defined in this file.
 */

const AuxDataType tclJumptableInfoType = {
    "JumptableInfo",		/* name */
    DupJumptableInfo,		/* dupProc */
    FreeJumptableInfo,		/* freeProc */
    PrintJumptableInfo,		/* printProc */
    DisassembleJumptableInfo	/* disassembleProc */
};

/*
 * Shorthand macros for instruction issuing.
 */

#define OP(name)	TclEmitOpcode(INST_##name, envPtr)
................................................................................
 *	Functions to duplicate, release and print a jump-table created for use
 *	with the INST_JUMP_TABLE instruction.
 *
 * Results:
 *	DupJumptableInfo: a copy of the jump-table
 *	FreeJumptableInfo: none
 *	PrintJumptableInfo: none
 *	DisassembleJumptableInfo: none
 *
 * Side effects:
 *	DupJumptableInfo: allocates memory
 *	FreeJumptableInfo: releases memory
 *	PrintJumptableInfo: none
 *	DisassembleJumptableInfo: none
 *
 *----------------------------------------------------------------------
 */

static ClientData
DupJumptableInfo(
    ClientData clientData)
................................................................................
		Tcl_AppendToObj(appendObj, "\n\t\t", -1);
	    }
	}
	Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
		keyPtr, pcOffset + offset);
    }
}

static void
DisassembleJumptableInfo(
    ClientData clientData,
    Tcl_Obj *dictObj,
    ByteCode *codePtr,
    unsigned int pcOffset)
{
    register JumptableInfo *jtPtr = clientData;
    Tcl_Obj *mapping = Tcl_NewObj();
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    const char *keyPtr;
    int offset;

    hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
    for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
	keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
	offset = PTR2INT(Tcl_GetHashValue(hPtr));
	Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1),
		Tcl_NewIntObj(offset));
    }
    Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCompileTailcallCmd --
 *
 *	Procedure called to compile the "tailcall" command.

Changes to generic/tclCompile.c.

51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
...
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
...
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
...
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
...
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
....
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
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
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
 * existence of a procedure call frame to distinguish these.
 */

InstructionDesc const tclInstructionTable[] = {
    /* Name	      Bytes stackEffect #Opnds  Operand types */
    {"done",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Finish ByteCode execution and return stktop (top stack item) */
    {"push1",		  2,   +1,         1,	{OPERAND_UINT1}},
	/* Push object at ByteCode objArray[op1] */
    {"push4",		  5,   +1,         1,	{OPERAND_UINT4}},
	/* Push object at ByteCode objArray[op4] */
    {"pop",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Pop the topmost stack object */
    {"dup",		  1,   +1,         0,	{OPERAND_NONE}},
	/* Duplicate the topmost stack object and push the result */
    {"strcat",		  2,   INT_MIN,    1,	{OPERAND_UINT1}},
	/* Concatenate the top op1 items and push result */
................................................................................
	/* Incr array elem; array at slot op1 <= 255, elem is stktop,
	 * amount is 2nd operand byte */
    {"incrArrayStkImm",	  2,   -1,         1,	{OPERAND_INT1}},
	/* Incr array element; elem is top then array name, amount is op1 */
    {"incrStkImm",	  2,   0,	   1,	{OPERAND_INT1}},
	/* Incr general variable; unparsed name is top, amount is op1 */

    {"jump1",		  2,   0,          1,	{OPERAND_INT1}},
	/* Jump relative to (pc + op1) */
    {"jump4",		  5,   0,          1,	{OPERAND_INT4}},
	/* Jump relative to (pc + op4) */
    {"jumpTrue1",	  2,   -1,         1,	{OPERAND_INT1}},
	/* Jump relative to (pc + op1) if stktop expr object is true */
    {"jumpTrue4",	  5,   -1,         1,	{OPERAND_INT4}},
	/* Jump relative to (pc + op4) if stktop expr object is true */
    {"jumpFalse1",	  2,   -1,         1,	{OPERAND_INT1}},
	/* Jump relative to (pc + op1) if stktop expr object is false */
    {"jumpFalse4",	  5,   -1,         1,	{OPERAND_INT4}},
	/* Jump relative to (pc + op4) if stktop expr object is false */

    {"lor",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Logical or:	push (stknext || stktop) */
    {"land",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Logical and:	push (stknext && stktop) */
    {"bitor",		  1,   -1,         0,	{OPERAND_NONE}},
................................................................................
    {"invokeExpanded",    1,    0,          0,	{OPERAND_NONE}},
	/* Invoke the command marked by the last 'expandStart' */

    {"listIndexImm",	  5,	0,	   1,	{OPERAND_IDX4}},
	/* List Index:	push (lindex stktop op4) */
    {"listRangeImm",	  9,	0,	   2,	{OPERAND_IDX4, OPERAND_IDX4}},
	/* List Range:	push (lrange stktop op4 op4) */
    {"startCommand",	  9,	0,	   2,	{OPERAND_INT4,OPERAND_UINT4}},
	/* Start of bytecoded command: op is the length of the cmd's code, op2
	 * is number of commands here */

    {"listIn",		  1,	-1,	   0,	{OPERAND_NONE}},
	/* List containment: push [lsearch stktop stknext]>=0) */
    {"listNotIn",	  1,	-1,	   0,	{OPERAND_NONE}},
	/* List negated containment: push [lsearch stktop stknext]<0) */
................................................................................
#ifdef TCL_COMPILE_STATS
static void		RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
static void		RegisterAuxDataType(const AuxDataType *typePtr);
static int		SetByteCodeFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
static void		StartExpanding(CompileEnv *envPtr);
static int		FormatInstruction(ByteCode *codePtr,
			    const unsigned char *pc, Tcl_Obj *bufferObj);
static void		PrintSourceToObj(Tcl_Obj *appendObj,
			    const char *stringPtr, int maxChars);
static void		UpdateStringOfInstName(Tcl_Obj *objPtr);

/*
 * TIP #280: Helper for building the per-word line information of all compiled
 * commands.
 */
static void		EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset,
			    Tcl_Token *tokenPtr, const char *cmd, int len,
................................................................................
    "substcode",		/* name */
    FreeSubstCodeInternalRep,	/* freeIntRepProc */
    DupByteCodeInternalRep,	/* dupIntRepProc - shared with bytecode */
    NULL,			/* updateStringProc */
    NULL,			/* setFromAnyProc */
};

/*
 * The structure below defines an instruction name Tcl object to allow
 * reporting of inner contexts in errorstack without string allocation.
 */

static const Tcl_ObjType tclInstNameType = {
    "instname",			/* name */
    NULL,			/* freeIntRepProc */
    NULL,			/* dupIntRepProc */
    UpdateStringOfInstName,	/* updateStringProc */
    NULL,			/* setFromAnyProc */
};

/*
 * Helper macros.
 */

#define TclIncrUInt4AtPtr(ptr, delta) \
    TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr));
 
................................................................................
	    TclStoreInt4AtPtr(srcLen, p);
	    p += 4;
	}
    }

    return p;
}
 
#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * TclPrintByteCodeObj --
 *
 *	This procedure prints ("disassembles") the instructions of a bytecode
 *	object to stdout.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclPrintByteCodeObj(
    Tcl_Interp *interp,		/* Used only for Tcl_GetStringFromObj. */
    Tcl_Obj *objPtr)		/* The bytecode object to disassemble. */
{
    Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr);

    fprintf(stdout, "\n%s", TclGetString(bufPtr));
    Tcl_DecrRefCount(bufPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPrintInstruction --
 *
 *	This procedure prints ("disassembles") one instruction from a bytecode
 *	object to stdout.
 *
 * Results:
 *	Returns the length in bytes of the current instruiction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclPrintInstruction(
    ByteCode *codePtr,		/* Bytecode containing the instruction. */
    const unsigned char *pc)	/* Points to first byte of instruction. */
{
    Tcl_Obj *bufferObj;
    int numBytes;

    TclNewObj(bufferObj);
    numBytes = FormatInstruction(codePtr, pc, bufferObj);
    fprintf(stdout, "%s", TclGetString(bufferObj));
    Tcl_DecrRefCount(bufferObj);
    return numBytes;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPrintObject --
 *
 *	This procedure prints up to a specified number of characters from the
 *	argument Tcl object's string representation to a specified file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Outputs characters to the specified file.
 *
 *----------------------------------------------------------------------
 */

void
TclPrintObject(
    FILE *outFile,		/* The file to print the source to. */
    Tcl_Obj *objPtr,		/* Points to the Tcl object whose string
				 * representation should be printed. */
    int maxChars)		/* Maximum number of chars to print. */
{
    char *bytes;
    int length;

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPrintSource --
 *
 *	This procedure prints up to a specified number of characters from the
 *	argument string to a specified file. It tries to produce legible
 *	output by adding backslashes as necessary.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Outputs characters to the specified file.
 *
 *----------------------------------------------------------------------
 */

void
TclPrintSource(
    FILE *outFile,		/* The file to print the source to. */
    const char *stringPtr,	/* The string to print. */
    int maxChars)		/* Maximum number of chars to print. */
{
    Tcl_Obj *bufferObj;

    TclNewObj(bufferObj);
    PrintSourceToObj(bufferObj, stringPtr, maxChars);
    fprintf(outFile, "%s", TclGetString(bufferObj));
    Tcl_DecrRefCount(bufferObj);
}
#endif /* TCL_COMPILE_DEBUG */
 
/*
 *----------------------------------------------------------------------
 *
 * TclDisassembleByteCodeObj --
 *
 *	Given an object which is of bytecode type, return a disassembled
 *	version of the bytecode (in a new refcount 0 object). No guarantees
 *	are made about the details of the contents of the result.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclDisassembleByteCodeObj(
    Tcl_Obj *objPtr)		/* The bytecode object to disassemble. */
{
    ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
    unsigned char *codeStart, *codeLimit, *pc;
    unsigned char *codeDeltaNext, *codeLengthNext;
    unsigned char *srcDeltaNext, *srcLengthNext;
    int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;
    Interp *iPtr = (Interp *) *codePtr->interpHandle;
    Tcl_Obj *bufferObj;
    char ptrBuf1[20], ptrBuf2[20];

    TclNewObj(bufferObj);
    if (codePtr->refCount <= 0) {
	return bufferObj;	/* Already freed. */
    }

    codeStart = codePtr->codeStart;
    codeLimit = codeStart + codePtr->numCodeBytes;
    numCmds = codePtr->numCommands;

    /*
     * Print header lines describing the ByteCode.
     */

    sprintf(ptrBuf1, "%p", codePtr);
    sprintf(ptrBuf2, "%p", iPtr);
    Tcl_AppendPrintfToObj(bufferObj,
	    "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n",
	    ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2,
	    iPtr->compileEpoch);
    Tcl_AppendToObj(bufferObj, "  Source ", -1);
    PrintSourceToObj(bufferObj, codePtr->source,
	    TclMin(codePtr->numSrcBytes, 55));
    Tcl_AppendPrintfToObj(bufferObj,
	    "\n  Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
	    numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
	    codePtr->numLitObjects, codePtr->numAuxDataItems,
	    codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
	    codePtr->numSrcBytes?
		    codePtr->structureSize/(float)codePtr->numSrcBytes :
#endif
	    0.0);

#ifdef TCL_COMPILE_STATS
    Tcl_AppendPrintfToObj(bufferObj,
	    "  Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
	    (unsigned long) codePtr->structureSize,
	    (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)),
	    codePtr->numCodeBytes,
	    (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
	    (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
	    (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
	    codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */

    /*
     * If the ByteCode is the compiled body of a Tcl procedure, print
     * information about that procedure. Note that we don't know the
     * procedure's name since ByteCode's can be shared among procedures.
     */

    if (codePtr->procPtr != NULL) {
	Proc *procPtr = codePtr->procPtr;
	int numCompiledLocals = procPtr->numCompiledLocals;

	sprintf(ptrBuf1, "%p", procPtr);
	Tcl_AppendPrintfToObj(bufferObj,
		"  Proc 0x%s, refCt %d, args %d, compiled locals %d\n",
		ptrBuf1, procPtr->refCount, procPtr->numArgs,
		numCompiledLocals);
	if (numCompiledLocals > 0) {
	    CompiledLocal *localPtr = procPtr->firstLocalPtr;

	    for (i = 0;  i < numCompiledLocals;  i++) {
		Tcl_AppendPrintfToObj(bufferObj,
			"      slot %d%s%s%s%s%s%s", i,
			(localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar",
			(localPtr->flags & VAR_ARRAY) ? ", array" : "",
			(localPtr->flags & VAR_LINK) ? ", link" : "",
			(localPtr->flags & VAR_ARGUMENT) ? ", arg" : "",
			(localPtr->flags & VAR_TEMPORARY) ? ", temp" : "",
			(localPtr->flags & VAR_RESOLVED) ? ", resolved" : "");
		if (TclIsVarTemporary(localPtr)) {
		    Tcl_AppendToObj(bufferObj, "\n", -1);
		} else {
		    Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n",
			    localPtr->name);
		}
		localPtr = localPtr->nextPtr;
	    }
	}
    }

    /*
     * Print the ExceptionRange array.
     */

    if (codePtr->numExceptRanges > 0) {
	Tcl_AppendPrintfToObj(bufferObj, "  Exception ranges %d, depth %d:\n",
		codePtr->numExceptRanges, codePtr->maxExceptDepth);
	for (i = 0;  i < codePtr->numExceptRanges;  i++) {
	    ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i];

	    Tcl_AppendPrintfToObj(bufferObj,
		    "      %d: level %d, %s, pc %d-%d, ",
		    i, rangePtr->nestingLevel,
		    (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"),
		    rangePtr->codeOffset,
		    (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
	    switch (rangePtr->type) {
	    case LOOP_EXCEPTION_RANGE:
		Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n",
			rangePtr->continueOffset, rangePtr->breakOffset);
		break;
	    case CATCH_EXCEPTION_RANGE:
		Tcl_AppendPrintfToObj(bufferObj, "catch %d\n",
			rangePtr->catchOffset);
		break;
	    default:
		Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d",
			rangePtr->type);
	    }
	}
    }

    /*
     * If there were no commands (e.g., an expression or an empty string was
     * compiled), just print all instructions and return.
     */

    if (numCmds == 0) {
	pc = codeStart;
	while (pc < codeLimit) {
	    Tcl_AppendToObj(bufferObj, "    ", -1);
	    pc += FormatInstruction(codePtr, pc, bufferObj);
	}
	return bufferObj;
    }

    /*
     * Print table showing the code offset, source offset, and source length
     * for each command. These are encoded as a sequence of bytes.
     */

    Tcl_AppendPrintfToObj(bufferObj, "  Commands %d:", numCmds);
    codeDeltaNext = codePtr->codeDeltaStart;
    codeLengthNext = codePtr->codeLengthStart;
    srcDeltaNext = codePtr->srcDeltaStart;
    srcLengthNext = codePtr->srcLengthStart;
    codeOffset = srcOffset = 0;
    for (i = 0;  i < numCmds;  i++) {
	if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
	    codeDeltaNext++;
	    delta = TclGetInt4AtPtr(codeDeltaNext);
	    codeDeltaNext += 4;
	} else {
	    delta = TclGetInt1AtPtr(codeDeltaNext);
	    codeDeltaNext++;
	}
	codeOffset += delta;

	if ((unsigned) *codeLengthNext == (unsigned) 0xFF) {
	    codeLengthNext++;
	    codeLen = TclGetInt4AtPtr(codeLengthNext);
	    codeLengthNext += 4;
	} else {
	    codeLen = TclGetInt1AtPtr(codeLengthNext);
	    codeLengthNext++;
	}

	if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
	    srcDeltaNext++;
	    delta = TclGetInt4AtPtr(srcDeltaNext);
	    srcDeltaNext += 4;
	} else {
	    delta = TclGetInt1AtPtr(srcDeltaNext);
	    srcDeltaNext++;
	}
	srcOffset += delta;

	if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
	    srcLengthNext++;
	    srcLen = TclGetInt4AtPtr(srcLengthNext);
	    srcLengthNext += 4;
	} else {
	    srcLen = TclGetInt1AtPtr(srcLengthNext);
	    srcLengthNext++;
	}

	Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d",
		((i % 2)? "     " : "\n   "),
		(i+1), codeOffset, (codeOffset + codeLen - 1),
		srcOffset, (srcOffset + srcLen - 1));
    }
    if (numCmds > 0) {
	Tcl_AppendToObj(bufferObj, "\n", -1);
    }

    /*
     * Print each instruction. If the instruction corresponds to the start of
     * a command, print the command's source. Note that we don't need the code
     * length here.
     */

    codeDeltaNext = codePtr->codeDeltaStart;
    srcDeltaNext = codePtr->srcDeltaStart;
    srcLengthNext = codePtr->srcLengthStart;
    codeOffset = srcOffset = 0;
    pc = codeStart;
    for (i = 0;  i < numCmds;  i++) {
	if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
	    codeDeltaNext++;
	    delta = TclGetInt4AtPtr(codeDeltaNext);
	    codeDeltaNext += 4;
	} else {
	    delta = TclGetInt1AtPtr(codeDeltaNext);
	    codeDeltaNext++;
	}
	codeOffset += delta;

	if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
	    srcDeltaNext++;
	    delta = TclGetInt4AtPtr(srcDeltaNext);
	    srcDeltaNext += 4;
	} else {
	    delta = TclGetInt1AtPtr(srcDeltaNext);
	    srcDeltaNext++;
	}
	srcOffset += delta;

	if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
	    srcLengthNext++;
	    srcLen = TclGetInt4AtPtr(srcLengthNext);
	    srcLengthNext += 4;
	} else {
	    srcLen = TclGetInt1AtPtr(srcLengthNext);
	    srcLengthNext++;
	}

	/*
	 * Print instructions before command i.
	 */

	while ((pc-codeStart) < codeOffset) {
	    Tcl_AppendToObj(bufferObj, "    ", -1);
	    pc += FormatInstruction(codePtr, pc, bufferObj);
	}

	Tcl_AppendPrintfToObj(bufferObj, "  Command %d: ", i+1);
	PrintSourceToObj(bufferObj, (codePtr->source + srcOffset),
		TclMin(srcLen, 55));
	Tcl_AppendToObj(bufferObj, "\n", -1);
    }
    if (pc < codeLimit) {
	/*
	 * Print instructions after the last command.
	 */

	while (pc < codeLimit) {
	    Tcl_AppendToObj(bufferObj, "    ", -1);
	    pc += FormatInstruction(codePtr, pc, bufferObj);
	}
    }
    return bufferObj;
}
 
/*
 *----------------------------------------------------------------------
 *
 * FormatInstruction --
 *
 *	Appends a representation of a bytecode instruction to a Tcl_Obj.
 *
 *----------------------------------------------------------------------
 */

static int
FormatInstruction(
    ByteCode *codePtr,		/* Bytecode containing the instruction. */
    const unsigned char *pc,	/* Points to first byte of instruction. */
    Tcl_Obj *bufferObj)		/* Object to append instruction info to. */
{
    Proc *procPtr = codePtr->procPtr;
    unsigned char opCode = *pc;
    register const InstructionDesc *instDesc = &tclInstructionTable[opCode];
    unsigned char *codeStart = codePtr->codeStart;
    unsigned pcOffset = pc - codeStart;
    int opnd = 0, i, j, numBytes = 1;
    int localCt = procPtr ? procPtr->numCompiledLocals : 0;
    CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;
    char suffixBuffer[128];	/* Additional info to print after main opcode
				 * and immediates. */
    char *suffixSrc = NULL;
    Tcl_Obj *suffixObj = NULL;
    AuxData *auxPtr = NULL;

    suffixBuffer[0] = '\0';
    Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name);
    for (i = 0;  i < instDesc->numOperands;  i++) {
	switch (instDesc->opTypes[i]) {
	case OPERAND_INT1:
	    opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++;
	    if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1
		    || opCode == INST_JUMP_FALSE1) {
		sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
	    }
	    Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
	    break;
	case OPERAND_INT4:
	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
	    if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4
		    || opCode == INST_JUMP_FALSE4) {
		sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
	    } else if (opCode == INST_START_CMD) {
		sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);
	    }
	    Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
	    break;
	case OPERAND_UINT1:
	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
	    if (opCode == INST_PUSH1) {
		suffixObj = codePtr->objArrayPtr[opnd];
	    }
	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
	    break;
	case OPERAND_AUX4:
	case OPERAND_UINT4:
	    opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
	    if (opCode == INST_PUSH4) {
		suffixObj = codePtr->objArrayPtr[opnd];
	    } else if (opCode == INST_START_CMD && opnd != 1) {
		sprintf(suffixBuffer+strlen(suffixBuffer),
			", %u cmds start here", opnd);
	    }
	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
	    if (instDesc->opTypes[i] == OPERAND_AUX4) {
		auxPtr = &codePtr->auxDataArrayPtr[opnd];
	    }
	    break;
	case OPERAND_IDX4:
	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
	    if (opnd >= -1) {
		Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd);
	    } else if (opnd == -2) {
		Tcl_AppendPrintfToObj(bufferObj, "end ");
	    } else {
		Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd);
	    }
	    break;
	case OPERAND_LVT1:
	    opnd = TclGetUInt1AtPtr(pc+numBytes);
	    numBytes++;
	    goto printLVTindex;
	case OPERAND_LVT4:
	    opnd = TclGetUInt4AtPtr(pc+numBytes);
	    numBytes += 4;
	printLVTindex:
	    if (localPtr != NULL) {
		if (opnd >= localCt) {
		    Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)",
			    (unsigned) opnd, localCt);
		}
		for (j = 0;  j < opnd;  j++) {
		    localPtr = localPtr->nextPtr;
		}
		if (TclIsVarTemporary(localPtr)) {
		    sprintf(suffixBuffer, "temp var %u", (unsigned) opnd);
		} else {
		    sprintf(suffixBuffer, "var ");
		    suffixSrc = localPtr->name;
		}
	    }
	    Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
	    break;
	case OPERAND_SCLS1:
	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
	    Tcl_AppendPrintfToObj(bufferObj, "%s ",
		    tclStringClassTable[opnd].name);
	    break;
	case OPERAND_NONE:
	default:
	    break;
	}
    }
    if (suffixObj) {
	const char *bytes;
	int length;

	Tcl_AppendToObj(bufferObj, "\t# ", -1);
	bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length);
	PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
    } else if (suffixBuffer[0]) {
	Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
	if (suffixSrc) {
	    PrintSourceToObj(bufferObj, suffixSrc, 40);
	}
    }
    Tcl_AppendToObj(bufferObj, "\n", -1);
    if (auxPtr && auxPtr->type->printProc) {
	Tcl_AppendToObj(bufferObj, "\t\t[", -1);
	auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr,
		pcOffset);
	Tcl_AppendToObj(bufferObj, "]\n", -1);
    }
    return numBytes;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclGetInnerContext --
 *
 *	If possible, returns a list capturing the inner context. Otherwise
 *	return NULL.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclGetInnerContext(
    Tcl_Interp *interp,
    const unsigned char *pc,
    Tcl_Obj **tosPtr)
{
    int objc = 0, off = 0;
    Tcl_Obj *result;
    Interp *iPtr = (Interp *) interp;

    switch (*pc) {
    case INST_STR_LEN:
    case INST_LNOT:
    case INST_BITNOT:
    case INST_UMINUS:
    case INST_UPLUS:
    case INST_TRY_CVT_TO_NUMERIC:
    case INST_EXPAND_STKTOP:
    case INST_EXPR_STK:
        objc = 1;
        break;

    case INST_LIST_IN:
    case INST_LIST_NOT_IN:	/* Basic list containment operators. */
    case INST_STR_EQ:
    case INST_STR_NEQ:		/* String (in)equality check */
    case INST_STR_CMP:		/* String compare. */
    case INST_STR_INDEX:
    case INST_STR_MATCH:
    case INST_REGEXP:
    case INST_EQ:
    case INST_NEQ:
    case INST_LT:
    case INST_GT:
    case INST_LE:
    case INST_GE:
    case INST_MOD:
    case INST_LSHIFT:
    case INST_RSHIFT:
    case INST_BITOR:
    case INST_BITXOR:
    case INST_BITAND:
    case INST_EXPON:
    case INST_ADD:
    case INST_SUB:
    case INST_DIV:
    case INST_MULT:
        objc = 2;
        break;

    case INST_RETURN_STK:
        /* early pop. TODO: dig out opt dict too :/ */
        objc = 1;
        break;

    case INST_SYNTAX:
    case INST_RETURN_IMM:
        objc = 2;
        break;

    case INST_INVOKE_STK4:
	objc = TclGetUInt4AtPtr(pc+1);
        break;

    case INST_INVOKE_STK1:
	objc = TclGetUInt1AtPtr(pc+1);
	break;
    }

    result = iPtr->innerContext;
    if (Tcl_IsShared(result)) {
        Tcl_DecrRefCount(result);
        iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
        Tcl_IncrRefCount(result);
    } else {
        int len;

        /*
         * Reset while keeping the list intrep as much as possible.
         */

	Tcl_ListObjLength(interp, result, &len);
        Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
    }
    Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));

    for (; objc>0 ; objc--) {
        Tcl_Obj *objPtr;

        objPtr = tosPtr[1 - objc + off];
        if (!objPtr) {
            Tcl_Panic("InnerContext: bad tos -- appending null object");
        }
        if ((objPtr->refCount<=0)
#ifdef TCL_MEM_DEBUG
                || (objPtr->refCount==0x61616161)
#endif
        ) {
            Tcl_Panic("InnerContext: bad tos -- appending freed object %p",
                    objPtr);
        }
        Tcl_ListObjAppendElement(NULL, result, objPtr);
    }

    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclNewInstNameObj --
 *
 *	Creates a new InstName Tcl_Obj based on the given instruction
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclNewInstNameObj(
    unsigned char inst)
{
    Tcl_Obj *objPtr = Tcl_NewObj();

    objPtr->typePtr = &tclInstNameType;
    objPtr->internalRep.longValue = (long) inst;
    objPtr->bytes = NULL;

    return objPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfInstName --
 *
 *	Update the string representation for an instruction name object.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfInstName(
    Tcl_Obj *objPtr)
{
    int inst = objPtr->internalRep.longValue;
    char *s, buf[20];
    int len;

    if ((inst < 0) || (inst > LAST_INST_OPCODE)) {
        sprintf(buf, "inst_%d", inst);
        s = buf;
    } else {
        s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name;
    }
    len = strlen(s);
    objPtr->bytes = ckalloc(len + 1);
    memcpy(objPtr->bytes, s, len + 1);
    objPtr->length = len;
}
 
/*
 *----------------------------------------------------------------------
 *
 * PrintSourceToObj --
 *
 *	Appends a quoted representation of a string to a Tcl_Obj.
 *
 *----------------------------------------------------------------------
 */

static void
PrintSourceToObj(
    Tcl_Obj *appendObj,		/* The object to print the source to. */
    const char *stringPtr,	/* The string to print. */
    int maxChars)		/* Maximum number of chars to print. */
{
    register const char *p;
    register int i = 0, len;

    if (stringPtr == NULL) {
	Tcl_AppendToObj(appendObj, "\"\"", -1);
	return;
    }

    Tcl_AppendToObj(appendObj, "\"", -1);
    p = stringPtr;
    for (;  (*p != '\0') && (i < maxChars);  p+=len) {
	Tcl_UniChar ch;

	len = TclUtfToUniChar(p, &ch);
	switch (ch) {
	case '"':
	    Tcl_AppendToObj(appendObj, "\\\"", -1);
	    i += 2;
	    continue;
	case '\f':
	    Tcl_AppendToObj(appendObj, "\\f", -1);
	    i += 2;
	    continue;
	case '\n':
	    Tcl_AppendToObj(appendObj, "\\n", -1);
	    i += 2;
	    continue;
	case '\r':
	    Tcl_AppendToObj(appendObj, "\\r", -1);
	    i += 2;
	    continue;
	case '\t':
	    Tcl_AppendToObj(appendObj, "\\t", -1);
	    i += 2;
	    continue;
	case '\v':
	    Tcl_AppendToObj(appendObj, "\\v", -1);
	    i += 2;
	    continue;
	default:
	    if (ch < 0x20 || ch >= 0x7f) {
		Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ch);
		i += 6;
	    } else {
		Tcl_AppendPrintfToObj(appendObj, "%c", ch);
		i++;
	    }
	    continue;
	}
    }
    Tcl_AppendToObj(appendObj, "\"", -1);
    if (*p != '\0') {
	Tcl_AppendToObj(appendObj, "...", -1);
    }
}
 
#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *
 * RecordByteCodeStats --
 *






|

|







 







|

|

|

|

|

|







 







|







 







<
<
<
<
<







 







<
<
<
<
<
<
<
<
<
<
<
<
<







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
...
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
...
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
...
688
689
690
691
692
693
694





695
696
697
698
699
700
701
...
725
726
727
728
729
730
731













732
733
734
735
736
737
738
....
4573
4574
4575
4576
4577
4578
4579






















































































































































































































































































































































































































































































































































































































































































































































































































4580
4581
4582
4583
4584
4585
4586
 * existence of a procedure call frame to distinguish these.
 */

InstructionDesc const tclInstructionTable[] = {
    /* Name	      Bytes stackEffect #Opnds  Operand types */
    {"done",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Finish ByteCode execution and return stktop (top stack item) */
    {"push1",		  2,   +1,         1,	{OPERAND_LIT1}},
	/* Push object at ByteCode objArray[op1] */
    {"push4",		  5,   +1,         1,	{OPERAND_LIT4}},
	/* Push object at ByteCode objArray[op4] */
    {"pop",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Pop the topmost stack object */
    {"dup",		  1,   +1,         0,	{OPERAND_NONE}},
	/* Duplicate the topmost stack object and push the result */
    {"strcat",		  2,   INT_MIN,    1,	{OPERAND_UINT1}},
	/* Concatenate the top op1 items and push result */
................................................................................
	/* Incr array elem; array at slot op1 <= 255, elem is stktop,
	 * amount is 2nd operand byte */
    {"incrArrayStkImm",	  2,   -1,         1,	{OPERAND_INT1}},
	/* Incr array element; elem is top then array name, amount is op1 */
    {"incrStkImm",	  2,   0,	   1,	{OPERAND_INT1}},
	/* Incr general variable; unparsed name is top, amount is op1 */

    {"jump1",		  2,   0,          1,	{OPERAND_OFFSET1}},
	/* Jump relative to (pc + op1) */
    {"jump4",		  5,   0,          1,	{OPERAND_OFFSET4}},
	/* Jump relative to (pc + op4) */
    {"jumpTrue1",	  2,   -1,         1,	{OPERAND_OFFSET1}},
	/* Jump relative to (pc + op1) if stktop expr object is true */
    {"jumpTrue4",	  5,   -1,         1,	{OPERAND_OFFSET4}},
	/* Jump relative to (pc + op4) if stktop expr object is true */
    {"jumpFalse1",	  2,   -1,         1,	{OPERAND_OFFSET1}},
	/* Jump relative to (pc + op1) if stktop expr object is false */
    {"jumpFalse4",	  5,   -1,         1,	{OPERAND_OFFSET4}},
	/* Jump relative to (pc + op4) if stktop expr object is false */

    {"lor",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Logical or:	push (stknext || stktop) */
    {"land",		  1,   -1,         0,	{OPERAND_NONE}},
	/* Logical and:	push (stknext && stktop) */
    {"bitor",		  1,   -1,         0,	{OPERAND_NONE}},
................................................................................
    {"invokeExpanded",    1,    0,          0,	{OPERAND_NONE}},
	/* Invoke the command marked by the last 'expandStart' */

    {"listIndexImm",	  5,	0,	   1,	{OPERAND_IDX4}},
	/* List Index:	push (lindex stktop op4) */
    {"listRangeImm",	  9,	0,	   2,	{OPERAND_IDX4, OPERAND_IDX4}},
	/* List Range:	push (lrange stktop op4 op4) */
    {"startCommand",	  9,	0,	   2,	{OPERAND_OFFSET4, OPERAND_UINT4}},
	/* Start of bytecoded command: op is the length of the cmd's code, op2
	 * is number of commands here */

    {"listIn",		  1,	-1,	   0,	{OPERAND_NONE}},
	/* List containment: push [lsearch stktop stknext]>=0) */
    {"listNotIn",	  1,	-1,	   0,	{OPERAND_NONE}},
	/* List negated containment: push [lsearch stktop stknext]<0) */
................................................................................
#ifdef TCL_COMPILE_STATS
static void		RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
static void		RegisterAuxDataType(const AuxDataType *typePtr);
static int		SetByteCodeFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
static void		StartExpanding(CompileEnv *envPtr);






/*
 * TIP #280: Helper for building the per-word line information of all compiled
 * commands.
 */
static void		EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset,
			    Tcl_Token *tokenPtr, const char *cmd, int len,
................................................................................
    "substcode",		/* name */
    FreeSubstCodeInternalRep,	/* freeIntRepProc */
    DupByteCodeInternalRep,	/* dupIntRepProc - shared with bytecode */
    NULL,			/* updateStringProc */
    NULL,			/* setFromAnyProc */
};














/*
 * Helper macros.
 */

#define TclIncrUInt4AtPtr(ptr, delta) \
    TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr));
 
................................................................................
	    TclStoreInt4AtPtr(srcLen, p);
	    p += 4;
	}
    }

    return p;
}






















































































































































































































































































































































































































































































































































































































































































































































































































 
#ifdef TCL_COMPILE_STATS
/*
 *----------------------------------------------------------------------
 *
 * RecordByteCodeStats --
 *

Changes to generic/tclCompile.h.

44
45
46
47
48
49
50







51
52
53
54
55
56
57
...
234
235
236
237
238
239
240










241
242
243
244
245
246
247
...
828
829
830
831
832
833
834






835
836
837
838
839
840
841
....
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173



1174
1175
1176
1177
1178
1179
1180
 *    2: trace invocations of all (not compiled away) commands
 *    3: display each instruction executed
 * This variable is linked to the Tcl variable "tcl_traceExec".
 */

MODULE_SCOPE int 	tclTraceExec;
#endif







 
/*
 *------------------------------------------------------------------------
 * Data structures related to compilation.
 *------------------------------------------------------------------------
 */

................................................................................
				 * called. */
    AuxDataFreeProc *freeProc;	/* Callback procedure to invoke when the aux
				 * data is freed. NULL means no proc need be
				 * called. */
    AuxDataPrintProc *printProc;/* Callback function to invoke when printing
				 * the aux data as part of debugging. NULL
				 * means that the data can't be printed. */










} AuxDataType;

/*
 * The definition of the AuxData structure that holds information created
 * during compilation by CompileProcs and used by instructions during
 * execution.
 */
................................................................................
				 * integer, but displayed differently.) */
    OPERAND_LVT1,		/* One byte unsigned index into the local
				 * variable table. */
    OPERAND_LVT4,		/* Four byte unsigned index into the local
				 * variable table. */
    OPERAND_AUX4,		/* Four byte unsigned index into the aux data
				 * table. */






    OPERAND_SCLS1		/* Index into tclStringClassTable. */
} InstOperandType;

typedef struct InstructionDesc {
    const char *name;		/* Name of instruction. */
    int numBytes;		/* Total number of bytes for instruction. */
    int stackEffect;		/* The worst-case balance stack effect of the
................................................................................
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void	TclVerifyGlobalLiteralTable(Interp *iPtr);
MODULE_SCOPE void	TclVerifyLocalLiteralTable(CompileEnv *envPtr);
#endif
MODULE_SCOPE int	TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
			    Tcl_Obj *valuePtr);
MODULE_SCOPE void	TclLogCommandInfo(Tcl_Interp *interp,
					  const char *script,
					  const char *command, int length,
					  const unsigned char *pc, Tcl_Obj **tosPtr); 
MODULE_SCOPE Tcl_Obj	*TclGetInnerContext(Tcl_Interp *interp,
					    const unsigned char *pc, Tcl_Obj **tosPtr);
MODULE_SCOPE Tcl_Obj	*TclNewInstNameObj(unsigned char inst);




 
/*
 *----------------------------------------------------------------
 * Macros and flag values used by Tcl bytecode compilation and execution
 * modules inside the Tcl core but not used outside.
 *----------------------------------------------------------------






>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>







 







|
|
|

|

>
>
>







44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
...
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
...
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
....
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
 *    2: trace invocations of all (not compiled away) commands
 *    3: display each instruction executed
 * This variable is linked to the Tcl variable "tcl_traceExec".
 */

MODULE_SCOPE int 	tclTraceExec;
#endif

/*
 * The type of lambda expressions. Note that every lambda will *always* have a
 * string representation.
 */

MODULE_SCOPE const Tcl_ObjType tclLambdaType;
 
/*
 *------------------------------------------------------------------------
 * Data structures related to compilation.
 *------------------------------------------------------------------------
 */

................................................................................
				 * called. */
    AuxDataFreeProc *freeProc;	/* Callback procedure to invoke when the aux
				 * data is freed. NULL means no proc need be
				 * called. */
    AuxDataPrintProc *printProc;/* Callback function to invoke when printing
				 * the aux data as part of debugging. NULL
				 * means that the data can't be printed. */
    AuxDataPrintProc *disassembleProc;
				/* Callback function to invoke when doing a
				 * disassembly of the aux data (like the
				 * printProc, except that the output is
				 * intended to be script-readable). The
				 * appendObj argument should be filled in with
				 * a descriptive dictionary; it will start out
				 * with "name" mapped to the content of the
				 * name field. NULL means that the printProc
				 * should be used instead. */
} AuxDataType;

/*
 * The definition of the AuxData structure that holds information created
 * during compilation by CompileProcs and used by instructions during
 * execution.
 */
................................................................................
				 * integer, but displayed differently.) */
    OPERAND_LVT1,		/* One byte unsigned index into the local
				 * variable table. */
    OPERAND_LVT4,		/* Four byte unsigned index into the local
				 * variable table. */
    OPERAND_AUX4,		/* Four byte unsigned index into the aux data
				 * table. */
    OPERAND_OFFSET1,		/* One byte signed jump offset. */
    OPERAND_OFFSET4,		/* Four byte signed jump offset. */
    OPERAND_LIT1,		/* One byte unsigned index into table of
				 * literals. */
    OPERAND_LIT4,		/* Four byte unsigned index into table of
				 * literals. */
    OPERAND_SCLS1		/* Index into tclStringClassTable. */
} InstOperandType;

typedef struct InstructionDesc {
    const char *name;		/* Name of instruction. */
    int numBytes;		/* Total number of bytes for instruction. */
    int stackEffect;		/* The worst-case balance stack effect of the
................................................................................
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void	TclVerifyGlobalLiteralTable(Interp *iPtr);
MODULE_SCOPE void	TclVerifyLocalLiteralTable(CompileEnv *envPtr);
#endif
MODULE_SCOPE int	TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
			    Tcl_Obj *valuePtr);
MODULE_SCOPE void	TclLogCommandInfo(Tcl_Interp *interp,
			    const char *script, const char *command,
			    int length, const unsigned char *pc,
			    Tcl_Obj **tosPtr); 
MODULE_SCOPE Tcl_Obj	*TclGetInnerContext(Tcl_Interp *interp,
			    const unsigned char *pc, Tcl_Obj **tosPtr);
MODULE_SCOPE Tcl_Obj	*TclNewInstNameObj(unsigned char inst);
MODULE_SCOPE int	TclPushProcCallFrame(ClientData clientData,
			    register Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[], int isLambda);

 
/*
 *----------------------------------------------------------------
 * Macros and flag values used by Tcl bytecode compilation and execution
 * modules inside the Tcl core but not used outside.
 *----------------------------------------------------------------

Added generic/tclDisassemble.c.






















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
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
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
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
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
/*
 * tclDisassemble.c --
 *
 *	This file contains procedures that disassemble bytecode into either
 *	human-readable or Tcl-processable forms.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
 * Copyright (c) 2013 Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"
#include <assert.h>

/*
 * Prototypes for procedures defined later in this file:
 */

static Tcl_Obj *	DisassembleByteCodeAsDicts(Tcl_Obj *objPtr);
static int		FormatInstruction(ByteCode *codePtr,
			    const unsigned char *pc, Tcl_Obj *bufferObj);
static void		PrintSourceToObj(Tcl_Obj *appendObj,
			    const char *stringPtr, int maxChars);
static void		UpdateStringOfInstName(Tcl_Obj *objPtr);

/*
 * The structure below defines an instruction name Tcl object to allow
 * reporting of inner contexts in errorstack without string allocation.
 */

static const Tcl_ObjType tclInstNameType = {
    "instname",			/* name */
    NULL,			/* freeIntRepProc */
    NULL,			/* dupIntRepProc */
    UpdateStringOfInstName,	/* updateStringProc */
    NULL,			/* setFromAnyProc */
};

/*
 * How to get the bytecode out of a Tcl_Obj.
 */

#define BYTECODE(objPtr)					\
    ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1)
 
#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * TclPrintByteCodeObj --
 *
 *	This procedure prints ("disassembles") the instructions of a bytecode
 *	object to stdout.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclPrintByteCodeObj(
    Tcl_Interp *interp,		/* Used only for Tcl_GetStringFromObj. */
    Tcl_Obj *objPtr)		/* The bytecode object to disassemble. */
{
    Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr);

    fprintf(stdout, "\n%s", TclGetString(bufPtr));
    Tcl_DecrRefCount(bufPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPrintInstruction --
 *
 *	This procedure prints ("disassembles") one instruction from a bytecode
 *	object to stdout.
 *
 * Results:
 *	Returns the length in bytes of the current instruiction.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclPrintInstruction(
    ByteCode *codePtr,		/* Bytecode containing the instruction. */
    const unsigned char *pc)	/* Points to first byte of instruction. */
{
    Tcl_Obj *bufferObj;
    int numBytes;

    TclNewObj(bufferObj);
    numBytes = FormatInstruction(codePtr, pc, bufferObj);
    fprintf(stdout, "%s", TclGetString(bufferObj));
    Tcl_DecrRefCount(bufferObj);
    return numBytes;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPrintObject --
 *
 *	This procedure prints up to a specified number of characters from the
 *	argument Tcl object's string representation to a specified file.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Outputs characters to the specified file.
 *
 *----------------------------------------------------------------------
 */

void
TclPrintObject(
    FILE *outFile,		/* The file to print the source to. */
    Tcl_Obj *objPtr,		/* Points to the Tcl object whose string
				 * representation should be printed. */
    int maxChars)		/* Maximum number of chars to print. */
{
    char *bytes;
    int length;

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPrintSource --
 *
 *	This procedure prints up to a specified number of characters from the
 *	argument string to a specified file. It tries to produce legible
 *	output by adding backslashes as necessary.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Outputs characters to the specified file.
 *
 *----------------------------------------------------------------------
 */

void
TclPrintSource(
    FILE *outFile,		/* The file to print the source to. */
    const char *stringPtr,	/* The string to print. */
    int maxChars)		/* Maximum number of chars to print. */
{
    Tcl_Obj *bufferObj;

    TclNewObj(bufferObj);
    PrintSourceToObj(bufferObj, stringPtr, maxChars);
    fprintf(outFile, "%s", TclGetString(bufferObj));
    Tcl_DecrRefCount(bufferObj);
}
#endif /* TCL_COMPILE_DEBUG */
 
/*
 *----------------------------------------------------------------------
 *
 * TclDisassembleByteCodeObj --
 *
 *	Given an object which is of bytecode type, return a disassembled
 *	version of the bytecode (in a new refcount 0 object). No guarantees
 *	are made about the details of the contents of the result.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclDisassembleByteCodeObj(
    Tcl_Obj *objPtr)		/* The bytecode object to disassemble. */
{
    ByteCode *codePtr = BYTECODE(objPtr);
    unsigned char *codeStart, *codeLimit, *pc;
    unsigned char *codeDeltaNext, *codeLengthNext;
    unsigned char *srcDeltaNext, *srcLengthNext;
    int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;
    Interp *iPtr = (Interp *) *codePtr->interpHandle;
    Tcl_Obj *bufferObj;
    char ptrBuf1[20], ptrBuf2[20];

    TclNewObj(bufferObj);
    if (codePtr->refCount <= 0) {
	return bufferObj;	/* Already freed. */
    }

    codeStart = codePtr->codeStart;
    codeLimit = codeStart + codePtr->numCodeBytes;
    numCmds = codePtr->numCommands;

    /*
     * Print header lines describing the ByteCode.
     */

    sprintf(ptrBuf1, "%p", codePtr);
    sprintf(ptrBuf2, "%p", iPtr);
    Tcl_AppendPrintfToObj(bufferObj,
	    "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n",
	    ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2,
	    iPtr->compileEpoch);
    Tcl_AppendToObj(bufferObj, "  Source ", -1);
    PrintSourceToObj(bufferObj, codePtr->source,
	    TclMin(codePtr->numSrcBytes, 55));
    Tcl_AppendPrintfToObj(bufferObj,
	    "\n  Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
	    numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
	    codePtr->numLitObjects, codePtr->numAuxDataItems,
	    codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
	    codePtr->numSrcBytes?
		    codePtr->structureSize/(float)codePtr->numSrcBytes :
#endif
	    0.0);

#ifdef TCL_COMPILE_STATS
    Tcl_AppendPrintfToObj(bufferObj,
	    "  Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
	    (unsigned long) codePtr->structureSize,
	    (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)),
	    codePtr->numCodeBytes,
	    (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
	    (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
	    (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
	    codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */

    /*
     * If the ByteCode is the compiled body of a Tcl procedure, print
     * information about that procedure. Note that we don't know the
     * procedure's name since ByteCode's can be shared among procedures.
     */

    if (codePtr->procPtr != NULL) {
	Proc *procPtr = codePtr->procPtr;
	int numCompiledLocals = procPtr->numCompiledLocals;

	sprintf(ptrBuf1, "%p", procPtr);
	Tcl_AppendPrintfToObj(bufferObj,
		"  Proc 0x%s, refCt %d, args %d, compiled locals %d\n",
		ptrBuf1, procPtr->refCount, procPtr->numArgs,
		numCompiledLocals);
	if (numCompiledLocals > 0) {
	    CompiledLocal *localPtr = procPtr->firstLocalPtr;

	    for (i = 0;  i < numCompiledLocals;  i++) {
		Tcl_AppendPrintfToObj(bufferObj,
			"      slot %d%s%s%s%s%s%s", i,
			(localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar",
			(localPtr->flags & VAR_ARRAY) ? ", array" : "",
			(localPtr->flags & VAR_LINK) ? ", link" : "",
			(localPtr->flags & VAR_ARGUMENT) ? ", arg" : "",
			(localPtr->flags & VAR_TEMPORARY) ? ", temp" : "",
			(localPtr->flags & VAR_RESOLVED) ? ", resolved" : "");
		if (TclIsVarTemporary(localPtr)) {
		    Tcl_AppendToObj(bufferObj, "\n", -1);
		} else {
		    Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n",
			    localPtr->name);
		}
		localPtr = localPtr->nextPtr;
	    }
	}
    }

    /*
     * Print the ExceptionRange array.
     */

    if (codePtr->numExceptRanges > 0) {
	Tcl_AppendPrintfToObj(bufferObj, "  Exception ranges %d, depth %d:\n",
		codePtr->numExceptRanges, codePtr->maxExceptDepth);
	for (i = 0;  i < codePtr->numExceptRanges;  i++) {
	    ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i];

	    Tcl_AppendPrintfToObj(bufferObj,
		    "      %d: level %d, %s, pc %d-%d, ",
		    i, rangePtr->nestingLevel,
		    (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"),
		    rangePtr->codeOffset,
		    (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
	    switch (rangePtr->type) {
	    case LOOP_EXCEPTION_RANGE:
		Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n",
			rangePtr->continueOffset, rangePtr->breakOffset);
		break;
	    case CATCH_EXCEPTION_RANGE:
		Tcl_AppendPrintfToObj(bufferObj, "catch %d\n",
			rangePtr->catchOffset);
		break;
	    default:
		Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d",
			rangePtr->type);
	    }
	}
    }

    /*
     * If there were no commands (e.g., an expression or an empty string was
     * compiled), just print all instructions and return.
     */

    if (numCmds == 0) {
	pc = codeStart;
	while (pc < codeLimit) {
	    Tcl_AppendToObj(bufferObj, "    ", -1);
	    pc += FormatInstruction(codePtr, pc, bufferObj);
	}
	return bufferObj;
    }

    /*
     * Print table showing the code offset, source offset, and source length
     * for each command. These are encoded as a sequence of bytes.
     */

    Tcl_AppendPrintfToObj(bufferObj, "  Commands %d:", numCmds);
    codeDeltaNext = codePtr->codeDeltaStart;
    codeLengthNext = codePtr->codeLengthStart;
    srcDeltaNext = codePtr->srcDeltaStart;
    srcLengthNext = codePtr->srcLengthStart;
    codeOffset = srcOffset = 0;
    for (i = 0;  i < numCmds;  i++) {
	if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
	    codeDeltaNext++;
	    delta = TclGetInt4AtPtr(codeDeltaNext);
	    codeDeltaNext += 4;
	} else {
	    delta = TclGetInt1AtPtr(codeDeltaNext);
	    codeDeltaNext++;
	}
	codeOffset += delta;

	if ((unsigned) *codeLengthNext == (unsigned) 0xFF) {
	    codeLengthNext++;
	    codeLen = TclGetInt4AtPtr(codeLengthNext);
	    codeLengthNext += 4;
	} else {
	    codeLen = TclGetInt1AtPtr(codeLengthNext);
	    codeLengthNext++;
	}

	if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
	    srcDeltaNext++;
	    delta = TclGetInt4AtPtr(srcDeltaNext);
	    srcDeltaNext += 4;
	} else {
	    delta = TclGetInt1AtPtr(srcDeltaNext);
	    srcDeltaNext++;
	}
	srcOffset += delta;

	if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
	    srcLengthNext++;
	    srcLen = TclGetInt4AtPtr(srcLengthNext);
	    srcLengthNext += 4;
	} else {
	    srcLen = TclGetInt1AtPtr(srcLengthNext);
	    srcLengthNext++;
	}

	Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d",
		((i % 2)? "     " : "\n   "),
		(i+1), codeOffset, (codeOffset + codeLen - 1),
		srcOffset, (srcOffset + srcLen - 1));
    }
    if (numCmds > 0) {
	Tcl_AppendToObj(bufferObj, "\n", -1);
    }

    /*
     * Print each instruction. If the instruction corresponds to the start of
     * a command, print the command's source. Note that we don't need the code
     * length here.
     */

    codeDeltaNext = codePtr->codeDeltaStart;
    srcDeltaNext = codePtr->srcDeltaStart;
    srcLengthNext = codePtr->srcLengthStart;
    codeOffset = srcOffset = 0;
    pc = codeStart;
    for (i = 0;  i < numCmds;  i++) {
	if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
	    codeDeltaNext++;
	    delta = TclGetInt4AtPtr(codeDeltaNext);
	    codeDeltaNext += 4;
	} else {
	    delta = TclGetInt1AtPtr(codeDeltaNext);
	    codeDeltaNext++;
	}
	codeOffset += delta;

	if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
	    srcDeltaNext++;
	    delta = TclGetInt4AtPtr(srcDeltaNext);
	    srcDeltaNext += 4;
	} else {
	    delta = TclGetInt1AtPtr(srcDeltaNext);
	    srcDeltaNext++;
	}
	srcOffset += delta;

	if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
	    srcLengthNext++;
	    srcLen = TclGetInt4AtPtr(srcLengthNext);
	    srcLengthNext += 4;
	} else {
	    srcLen = TclGetInt1AtPtr(srcLengthNext);
	    srcLengthNext++;
	}

	/*
	 * Print instructions before command i.
	 */

	while ((pc-codeStart) < codeOffset) {
	    Tcl_AppendToObj(bufferObj, "    ", -1);
	    pc += FormatInstruction(codePtr, pc, bufferObj);
	}

	Tcl_AppendPrintfToObj(bufferObj, "  Command %d: ", i+1);
	PrintSourceToObj(bufferObj, (codePtr->source + srcOffset),
		TclMin(srcLen, 55));
	Tcl_AppendToObj(bufferObj, "\n", -1);
    }
    if (pc < codeLimit) {
	/*
	 * Print instructions after the last command.
	 */

	while (pc < codeLimit) {
	    Tcl_AppendToObj(bufferObj, "    ", -1);
	    pc += FormatInstruction(codePtr, pc, bufferObj);
	}
    }
    return bufferObj;
}
 
/*
 *----------------------------------------------------------------------
 *
 * FormatInstruction --
 *
 *	Appends a representation of a bytecode instruction to a Tcl_Obj.
 *
 *----------------------------------------------------------------------
 */

static int
FormatInstruction(
    ByteCode *codePtr,		/* Bytecode containing the instruction. */
    const unsigned char *pc,	/* Points to first byte of instruction. */
    Tcl_Obj *bufferObj)		/* Object to append instruction info to. */
{
    Proc *procPtr = codePtr->procPtr;
    unsigned char opCode = *pc;
    register const InstructionDesc *instDesc = &tclInstructionTable[opCode];
    unsigned char *codeStart = codePtr->codeStart;
    unsigned pcOffset = pc - codeStart;
    int opnd = 0, i, j, numBytes = 1;
    int localCt = procPtr ? procPtr->numCompiledLocals : 0;
    CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;
    char suffixBuffer[128];	/* Additional info to print after main opcode
				 * and immediates. */
    char *suffixSrc = NULL;
    Tcl_Obj *suffixObj = NULL;
    AuxData *auxPtr = NULL;

    suffixBuffer[0] = '\0';
    Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name);
    for (i = 0;  i < instDesc->numOperands;  i++) {
	switch (instDesc->opTypes[i]) {
	case OPERAND_INT1:
	    opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++;
	    Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
	    break;
	case OPERAND_INT4:
	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
	    Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
	    break;
	case OPERAND_UINT1:
	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
	    break;
	case OPERAND_UINT4:
	    opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
	    if (opCode == INST_START_CMD) {
		sprintf(suffixBuffer+strlen(suffixBuffer),
			", %u cmds start here", opnd);
	    }
	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
	    break;
	case OPERAND_OFFSET1:
	    opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++;
	    sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
	    Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
	    break;
	case OPERAND_OFFSET4:
	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
	    if (opCode == INST_START_CMD) {
		sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);
	    } else {
		sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
	    }
	    Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
	    break;
	case OPERAND_LIT1:
	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
	    suffixObj = codePtr->objArrayPtr[opnd];
	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
	    break;
	case OPERAND_LIT4:
	    opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
	    suffixObj = codePtr->objArrayPtr[opnd];
	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
	    break;
	case OPERAND_AUX4:
	    opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
	    Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
	    auxPtr = &codePtr->auxDataArrayPtr[opnd];
	    break;
	case OPERAND_IDX4:
	    opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
	    if (opnd >= -1) {
		Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd);
	    } else if (opnd == -2) {
		Tcl_AppendPrintfToObj(bufferObj, "end ");
	    } else {
		Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd);
	    }
	    break;
	case OPERAND_LVT1:
	    opnd = TclGetUInt1AtPtr(pc+numBytes);
	    numBytes++;
	    goto printLVTindex;
	case OPERAND_LVT4:
	    opnd = TclGetUInt4AtPtr(pc+numBytes);
	    numBytes += 4;
	printLVTindex:
	    if (localPtr != NULL) {
		if (opnd >= localCt) {
		    Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)",
			    (unsigned) opnd, localCt);
		}
		for (j = 0;  j < opnd;  j++) {
		    localPtr = localPtr->nextPtr;
		}
		if (TclIsVarTemporary(localPtr)) {
		    sprintf(suffixBuffer, "temp var %u", (unsigned) opnd);
		} else {
		    sprintf(suffixBuffer, "var ");
		    suffixSrc = localPtr->name;
		}
	    }
	    Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
	    break;
	case OPERAND_SCLS1:
	    opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
	    Tcl_AppendPrintfToObj(bufferObj, "%s ",
		    tclStringClassTable[opnd].name);
	    break;
	case OPERAND_NONE:
	default:
	    break;
	}
    }
    if (suffixObj) {
	const char *bytes;
	int length;

	Tcl_AppendToObj(bufferObj, "\t# ", -1);
	bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length);
	PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
    } else if (suffixBuffer[0]) {
	Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
	if (suffixSrc) {
	    PrintSourceToObj(bufferObj, suffixSrc, 40);
	}
    }
    Tcl_AppendToObj(bufferObj, "\n", -1);
    if (auxPtr && auxPtr->type->printProc) {
	Tcl_AppendToObj(bufferObj, "\t\t[", -1);
	auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr,
		pcOffset);
	Tcl_AppendToObj(bufferObj, "]\n", -1);
    }
    return numBytes;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclGetInnerContext --
 *
 *	If possible, returns a list capturing the inner context. Otherwise
 *	return NULL.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclGetInnerContext(
    Tcl_Interp *interp,
    const unsigned char *pc,
    Tcl_Obj **tosPtr)
{
    int objc = 0, off = 0;
    Tcl_Obj *result;
    Interp *iPtr = (Interp *) interp;

    switch (*pc) {
    case INST_STR_LEN:
    case INST_LNOT:
    case INST_BITNOT:
    case INST_UMINUS:
    case INST_UPLUS:
    case INST_TRY_CVT_TO_NUMERIC:
    case INST_EXPAND_STKTOP:
    case INST_EXPR_STK:
        objc = 1;
        break;

    case INST_LIST_IN:
    case INST_LIST_NOT_IN:	/* Basic list containment operators. */
    case INST_STR_EQ:
    case INST_STR_NEQ:		/* String (in)equality check */
    case INST_STR_CMP:		/* String compare. */
    case INST_STR_INDEX:
    case INST_STR_MATCH:
    case INST_REGEXP:
    case INST_EQ:
    case INST_NEQ:
    case INST_LT:
    case INST_GT:
    case INST_LE:
    case INST_GE:
    case INST_MOD:
    case INST_LSHIFT:
    case INST_RSHIFT:
    case INST_BITOR:
    case INST_BITXOR:
    case INST_BITAND:
    case INST_EXPON:
    case INST_ADD:
    case INST_SUB:
    case INST_DIV:
    case INST_MULT:
        objc = 2;
        break;

    case INST_RETURN_STK:
        /* early pop. TODO: dig out opt dict too :/ */
        objc = 1;
        break;

    case INST_SYNTAX:
    case INST_RETURN_IMM:
        objc = 2;
        break;

    case INST_INVOKE_STK4:
	objc = TclGetUInt4AtPtr(pc+1);
        break;

    case INST_INVOKE_STK1:
	objc = TclGetUInt1AtPtr(pc+1);
	break;
    }

    result = iPtr->innerContext;
    if (Tcl_IsShared(result)) {
        Tcl_DecrRefCount(result);
        iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
        Tcl_IncrRefCount(result);
    } else {
        int len;

        /*
         * Reset while keeping the list intrep as much as possible.
         */

	Tcl_ListObjLength(interp, result, &len);
        Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
    }
    Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));

    for (; objc>0 ; objc--) {
        Tcl_Obj *objPtr;

        objPtr = tosPtr[1 - objc + off];
        if (!objPtr) {
            Tcl_Panic("InnerContext: bad tos -- appending null object");
        }
        if ((objPtr->refCount<=0)
#ifdef TCL_MEM_DEBUG
                || (objPtr->refCount==0x61616161)
#endif
        ) {
            Tcl_Panic("InnerContext: bad tos -- appending freed object %p",
                    objPtr);
        }
        Tcl_ListObjAppendElement(NULL, result, objPtr);
    }

    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclNewInstNameObj --
 *
 *	Creates a new InstName Tcl_Obj based on the given instruction
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclNewInstNameObj(
    unsigned char inst)
{
    Tcl_Obj *objPtr = Tcl_NewObj();

    objPtr->typePtr = &tclInstNameType;
    objPtr->internalRep.longValue = (long) inst;
    objPtr->bytes = NULL;

    return objPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfInstName --
 *
 *	Update the string representation for an instruction name object.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfInstName(
    Tcl_Obj *objPtr)
{
    int inst = objPtr->internalRep.longValue;
    char *s, buf[20];
    int len;

    if ((inst < 0) || (inst > LAST_INST_OPCODE)) {
        sprintf(buf, "inst_%d", inst);
        s = buf;
    } else {
        s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name;
    }
    len = strlen(s);
    objPtr->bytes = ckalloc(len + 1);
    memcpy(objPtr->bytes, s, len + 1);
    objPtr->length = len;
}
 
/*
 *----------------------------------------------------------------------
 *
 * PrintSourceToObj --
 *
 *	Appends a quoted representation of a string to a Tcl_Obj.
 *
 *----------------------------------------------------------------------
 */

static void
PrintSourceToObj(
    Tcl_Obj *appendObj,		/* The object to print the source to. */
    const char *stringPtr,	/* The string to print. */
    int maxChars)		/* Maximum number of chars to print. */
{
    register const char *p;
    register int i = 0, len;

    if (stringPtr == NULL) {
	Tcl_AppendToObj(appendObj, "\"\"", -1);
	return;
    }

    Tcl_AppendToObj(appendObj, "\"", -1);
    p = stringPtr;
    for (;  (*p != '\0') && (i < maxChars);  p+=len) {
	Tcl_UniChar ch;

	len = TclUtfToUniChar(p, &ch);
	switch (ch) {
	case '"':
	    Tcl_AppendToObj(appendObj, "\\\"", -1);
	    i += 2;
	    continue;
	case '\f':
	    Tcl_AppendToObj(appendObj, "\\f", -1);
	    i += 2;
	    continue;
	case '\n':
	    Tcl_AppendToObj(appendObj, "\\n", -1);
	    i += 2;
	    continue;
	case '\r':
	    Tcl_AppendToObj(appendObj, "\\r", -1);
	    i += 2;
	    continue;
	case '\t':
	    Tcl_AppendToObj(appendObj, "\\t", -1);
	    i += 2;
	    continue;
	case '\v':
	    Tcl_AppendToObj(appendObj, "\\v", -1);
	    i += 2;
	    continue;
	default:
	    if (ch < 0x20 || ch >= 0x7f) {
		Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ch);
		i += 6;
	    } else {
		Tcl_AppendPrintfToObj(appendObj, "%c", ch);
		i++;
	    }
	    continue;
	}
    }
    Tcl_AppendToObj(appendObj, "\"", -1);
    if (*p != '\0') {
	Tcl_AppendToObj(appendObj, "...", -1);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * DisassembleByteCodeAsDicts --
 *
 *	Given an object which is of bytecode type, return a disassembled
 *	version of the bytecode (in a new refcount 0 object) in a dictionary.
 *	No guarantees are made about the details of the contents of the
 *	result, but it is intended to be more readable than the old output
 *	format.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
DisassembleByteCodeAsDicts(
    Tcl_Obj *objPtr)		/* The bytecode-holding value to take apart */
{
    ByteCode *codePtr = BYTECODE(objPtr);
    Tcl_Obj *description, *literals, *variables, *instructions, *inst;
    Tcl_Obj *aux, *exn, *commands;
    unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr;
    int codeOffset, codeLength, sourceOffset, sourceLength;
    int i, val;

    /*
     * Get the literals from the bytecode.
     */

    literals = Tcl_NewObj();
    for (i=0 ; i<codePtr->numLitObjects ; i++) {
	Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]);
    }

    /*
     * Get the variables from the bytecode.
     */

    variables = Tcl_NewObj();
    if (codePtr->procPtr) {
	int localCount = codePtr->procPtr->numCompiledLocals;
	CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr;

	for (i=0 ; i<localCount ; i++,localPtr=localPtr->nextPtr) {
	    Tcl_Obj *descriptor[2];

	    descriptor[0] = Tcl_NewObj();
	    if (!(localPtr->flags & (VAR_ARRAY|VAR_LINK))) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("scalar", -1));
	    }
	    if (localPtr->flags & VAR_ARRAY) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("array", -1));
	    }
	    if (localPtr->flags & VAR_LINK) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("link", -1));
	    }
	    if (localPtr->flags & VAR_ARGUMENT) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("arg", -1));
	    }
	    if (localPtr->flags & VAR_TEMPORARY) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("temp", -1));
	    }
	    if (localPtr->flags & VAR_RESOLVED) {
		Tcl_ListObjAppendElement(NULL, descriptor[0],
			Tcl_NewStringObj("resolved", -1));
	    }
	    if (localPtr->flags & VAR_TEMPORARY) {
		Tcl_ListObjAppendElement(NULL, variables,
			Tcl_NewListObj(1, descriptor));
	    } else {
		descriptor[1] = Tcl_NewStringObj(localPtr->name, -1);
		Tcl_ListObjAppendElement(NULL, variables,
			Tcl_NewListObj(2, descriptor));
	    }
	}
    }

    /*
     * Get the instructions from the bytecode.
     */

    instructions = Tcl_NewObj();
    for (pc=codePtr->codeStart; pc<codePtr->codeStart+codePtr->numCodeBytes;){
	const InstructionDesc *instDesc = &tclInstructionTable[*pc];
	int address = pc - codePtr->codeStart;

	inst = Tcl_NewObj();
	Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj(
		instDesc->name, -1));
	opnd = pc + 1;
	for (i=0 ; i<instDesc->numOperands ; i++) {
	    switch (instDesc->opTypes[i]) {
	    case OPERAND_INT1:
		val = TclGetInt1AtPtr(opnd);
		opnd += 1;
		goto formatNumber;
	    case OPERAND_UINT1:
		val = TclGetUInt1AtPtr(opnd);
		opnd += 1;
		goto formatNumber;
	    case OPERAND_INT4:
		val = TclGetInt4AtPtr(opnd);
		opnd += 4;
		goto formatNumber;
	    case OPERAND_UINT4:
		val = TclGetUInt4AtPtr(opnd);
		opnd += 4;
	    formatNumber:
		Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val));
		break;

	    case OPERAND_OFFSET1:
		val = TclGetInt1AtPtr(opnd);
		opnd += 1;
		goto formatAddress;
	    case OPERAND_OFFSET4:
		val = TclGetInt4AtPtr(opnd);
		opnd += 4;
	    formatAddress:
		Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
			"pc %d", address + val));
		break;

	    case OPERAND_LIT1:
		val = TclGetUInt1AtPtr(opnd);
		opnd += 1;
		goto formatLiteral;
	    case OPERAND_LIT4:
		val = TclGetUInt4AtPtr(opnd);
		opnd += 4;
	    formatLiteral:
		Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
			"@%d", val));
		break;

	    case OPERAND_LVT1:
		val = TclGetUInt1AtPtr(opnd);
		opnd += 1;
		goto formatVariable;
	    case OPERAND_LVT4:
		val = TclGetUInt4AtPtr(opnd);
		opnd += 4;
	    formatVariable:
		Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
			"%%%d", val));
		break;
	    case OPERAND_IDX4:
		val = TclGetInt4AtPtr(opnd);
		opnd += 4;
		if (val >= -1) {
		    Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
			    ".%d", val));
		} else if (val == -2) {
		    Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj(
			    ".end", -1));
		} else {
		    Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
			    ".end-%d", -2-val));
		}
		break;
	    case OPERAND_AUX4:
		val = TclGetInt4AtPtr(opnd);
		opnd += 4;
		Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
			"?%d", val));
		break;
	    case OPERAND_SCLS1:
		val = TclGetUInt1AtPtr(opnd);
		opnd++;
		Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
			"=%s", tclStringClassTable[val].name));
		break;
	    case OPERAND_NONE:
		Tcl_Panic("opcode %d with more than zero 'no' operands", *pc);
	    }
	}
	Tcl_DictObjPut(NULL, instructions, Tcl_NewIntObj(address), inst);
	pc += instDesc->numBytes;
    }

    /*
     * Get the auxiliary data from the bytecode.
     */

    aux = Tcl_NewObj();
    for (i=0 ; i<codePtr->numAuxDataItems ; i++) {
	AuxData *auxData = &codePtr->auxDataArrayPtr[i];
	Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1);

	if (auxData->type->disassembleProc) {
	    Tcl_Obj *desc = Tcl_NewObj();

	    Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc);
	    auxDesc = desc;
	    auxData->type->disassembleProc(auxData->clientData, auxDesc,
		    codePtr, 0);
	} else if (auxData->type->printProc) {
	    Tcl_Obj *desc = Tcl_NewObj();

	    auxData->type->printProc(auxData->clientData, desc, codePtr, 0);
	    Tcl_ListObjAppendElement(NULL, auxDesc, desc);
	}
	Tcl_ListObjAppendElement(NULL, aux, auxDesc);
    }

    /*
     * Get the exception ranges from the bytecode.
     */

    exn = Tcl_NewObj();
    for (i=0 ; i<codePtr->numExceptRanges ; i++) {
	ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i];

	switch (rangePtr->type) {
	case LOOP_EXCEPTION_RANGE:
	    Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf(
		    "type %s level %d from %d to %d break %d continue %d",
		    "loop", rangePtr->nestingLevel, rangePtr->codeOffset,
		    rangePtr->codeOffset + rangePtr->numCodeBytes - 1,
		    rangePtr->breakOffset, rangePtr->continueOffset));
	    break;
	case CATCH_EXCEPTION_RANGE:
	    Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf(
		    "type %s level %d from %d to %d catch %d",
		    "catch", rangePtr->nestingLevel, rangePtr->codeOffset,
		    rangePtr->codeOffset + rangePtr->numCodeBytes - 1,
		    rangePtr->catchOffset));
	    break;
	}
    }

    /*
     * Get the command information from the bytecode.
     *
     * The way these are encoded in the bytecode is non-trivial; the Decode
     * macro (which updates its argument and returns the next decoded value)
     * handles this so that the rest of the code does not.
     */

#define Decode(ptr) \
    ((TclGetUInt1AtPtr(ptr) == 0xFF)			\
	? ((ptr)+=5 , TclGetInt4AtPtr((ptr)-4))		\
	: ((ptr)+=1 , TclGetInt1AtPtr((ptr)-1)))

    commands = Tcl_NewObj();
    codeOffPtr = codePtr->codeDeltaStart;
    codeLenPtr = codePtr->codeLengthStart;
    srcOffPtr = codePtr->srcDeltaStart;
    srcLenPtr = codePtr->srcLengthStart;
    codeOffset = sourceOffset = 0;
    for (i=0 ; i<codePtr->numCommands ; i++) {
	Tcl_Obj *cmd;

	codeOffset += Decode(codeOffPtr);
	codeLength = Decode(codeLenPtr);
	sourceOffset += Decode(srcOffPtr);
	sourceLength = Decode(srcLenPtr);
	cmd = Tcl_NewObj();
	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1),
		Tcl_NewIntObj(codeOffset));
	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1),
		Tcl_NewIntObj(codeOffset + codeLength - 1));

	/*
	 * Convert byte offsets to character offsets; important if multibyte
	 * characters are present in the source!
	 */

	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1),
		Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source,
			sourceOffset)));
	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1),
		Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source,
			sourceOffset + sourceLength - 1)));
	Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1),
		Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength));
	Tcl_ListObjAppendElement(NULL, commands, cmd);
    }

#undef Decode

    /*
     * Build the overall result.
     */

    description = Tcl_NewObj();
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1),
	    literals);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1),
	    variables);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exception", -1), exn);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1),
	    instructions);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", -1),
	    commands);
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", -1),
	    Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes));
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1),
	    Tcl_NewStringObj(codePtr->nsPtr->fullName, -1));
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1),
	    Tcl_NewIntObj(codePtr->maxStackDepth));
    Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1),
	    Tcl_NewIntObj(codePtr->maxExceptDepth));
    return description;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DisassembleObjCmd --
 *
 *	Implementation of the "::tcl::unsupported::disassemble" command. This
 *	command is not documented, but will disassemble procedures, lambda
 *	terms and general scripts. Note that will compile terms if necessary
 *	in order to disassemble them.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DisassembleObjCmd(
    ClientData clientData,	/* What type of operation. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    static const char *const types[] = {
	"lambda", "method", "objmethod", "proc", "script", NULL
    };
    enum Types {
	DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC,
	DISAS_SCRIPT
    };
    int idx, result;
    Tcl_Obj *codeObjPtr = NULL;
    Proc *procPtr = NULL;
    Tcl_HashEntry *hPtr;
    Object *oPtr;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "type ...");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){
	return TCL_ERROR;
    }

    switch ((enum Types) idx) {
    case DISAS_LAMBDA: {
	Command cmd;
	Tcl_Obj *nsObjPtr;
	Tcl_Namespace *nsPtr;

	/*
	 * Compile (if uncompiled) and disassemble a lambda term.
	 *
	 * WARNING! Pokes inside the lambda objtype.
	 */

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm");
	    return TCL_ERROR;
	}
	if (objv[2]->typePtr == &tclLambdaType) {
	    procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
	}
	if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) {
	    result = tclLambdaType.setFromAnyProc(interp, objv[2]);
	    if (result != TCL_OK) {
		return result;
	    }
	    procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
	}

	memset(&cmd, 0, sizeof(Command));
	nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2;
	result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
	if (result != TCL_OK) {
	    return result;
	}
	cmd.nsPtr = (Namespace *) nsPtr;
	procPtr->cmdPtr = &cmd;
	result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1);
	if (result != TCL_OK) {
	    return result;
	}
	TclPopStackFrame(interp);
	codeObjPtr = procPtr->bodyPtr;
	break;
    }
    case DISAS_PROC:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "procName");
	    return TCL_ERROR;
	}

	procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
	if (procPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "\"%s\" isn't a procedure", TclGetString(objv[2])));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
		    TclGetString(objv[2]), NULL);
	    return TCL_ERROR;
	}

	/*
	 * Compile (if uncompiled) and disassemble a procedure.
	 */

	result = TclPushProcCallFrame(procPtr, interp, 2, objv+1, 1);
	if (result != TCL_OK) {
	    return result;
	}
	TclPopStackFrame(interp);
	codeObjPtr = procPtr->bodyPtr;
	break;
    case DISAS_SCRIPT:
	/*
	 * Compile and disassemble a script.
	 */

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "script");
	    return TCL_ERROR;
	}
	if ((objv[2]->typePtr != &tclByteCodeType)
		&& (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) {
	    return TCL_ERROR;
	}
	codeObjPtr = objv[2];
	break;

    case DISAS_CLASS_METHOD:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "className methodName");
	    return TCL_ERROR;
	}

	/*
	 * Look up the body of a class method.
	 */

	oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
	if (oPtr == NULL) {
	    return TCL_ERROR;
	}
	if (oPtr->classPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "\"%s\" is not a class", TclGetString(objv[2])));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
		    TclGetString(objv[2]), NULL);
	    return TCL_ERROR;
	}
	hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
		(char *) objv[3]);
	goto methodBody;
    case DISAS_OBJECT_METHOD:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName");
	    return TCL_ERROR;
	}

	/*
	 * Look up the body of an instance method.
	 */

	oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
	if (oPtr == NULL) {
	    return TCL_ERROR;
	}
	if (oPtr->methodsPtr == NULL) {
	    goto unknownMethod;
	}
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]);

	/*
	 * Compile (if necessary) and disassemble a method body.
	 */

    methodBody:
	if (hPtr == NULL) {
	unknownMethod:
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "unknown method \"%s\"", TclGetString(objv[3])));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		    TclGetString(objv[3]), NULL);
	    return TCL_ERROR;
	}
	procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
	if (procPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "body not available for this kind of method", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		    "METHODTYPE", NULL);
	    return TCL_ERROR;
	}
	if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
	    Command cmd;

	    /*
	     * Yes, this is ugly, but we need to pass the namespace in to the
	     * compiler in two places.
	     */

	    cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
	    procPtr->cmdPtr = &cmd;
	    result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
		    (Namespace *) oPtr->namespacePtr, "body of method",
		    TclGetString(objv[3]));
	    procPtr->cmdPtr = NULL;
	    if (result != TCL_OK) {
		return result;
	    }
	}
	codeObjPtr = procPtr->bodyPtr;
	break;
    default:
	CLANG_ASSERT(0);
    }

    /*
     * Do the actual disassembly.
     */

    if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not disassemble prebuilt bytecode", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		"BYTECODE", NULL);
	return TCL_ERROR;
    }
    if (PTR2INT(clientData)) {
	Tcl_SetObjResult(interp, DisassembleByteCodeAsDicts(codeObjPtr));
    } else {
	Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
    }
    return TCL_OK;
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * tab-width: 8
 * End:
 */

Changes to generic/tclProc.c.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
..
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
..
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
...
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
....
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
....
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
....
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
....
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
....
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
....
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
....
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
....
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
....
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
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
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
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"

/*
 * Variables that are part of the [apply] command implementation and which
 * have to be passed to the other side of the NRE call.
 */

typedef struct {
................................................................................
static void		FreeLambdaInternalRep(Tcl_Obj *objPtr);
static int		InitArgsAndLocals(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj, int skip);
static void		InitResolvedLocals(Tcl_Interp *interp,
			    ByteCode *codePtr, Var *defPtr,
			    Namespace *nsPtr);
static void		InitLocalCache(Proc *procPtr);
static int		PushProcCallFrame(ClientData clientData,
			    register Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[], int isLambda);
static void		ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void		ProcBodyFree(Tcl_Obj *objPtr);
static int		ProcWrongNumArgs(Tcl_Interp *interp, int skip);
static void		MakeProcError(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj);
static void		MakeLambdaError(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj);
................................................................................

/*
 * The type of lambdas. Note that every lambda will *always* have a string
 * representation.
 *
 * Internally, ptr1 is a pointer to a Proc instance that is not bound to a
 * command name, and ptr2 is a pointer to the namespace that the Proc instance
 * will execute within.
 */

static const Tcl_ObjType lambdaType = {
    "lambdaExpr",		/* name */
    FreeLambdaInternalRep,	/* freeIntRepProc */
    DupLambdaInternalRep,	/* dupIntRepProc */
    NULL,			/* updateStringProc */
    SetLambdaFromAny		/* setFromAnyProc */
};
 
................................................................................
     * TIP #280: Remember the line the procedure body is starting on. In a
     * bytecode context we ask the engine to provide us with the necessary
     * information. This is for the initialization of the byte code compiler
     * when the body is used for the first time.
     *
     * This code is nearly identical to the #280 code in SetLambdaFromAny, see
     * this file. The differences are the different index of the body in the
     * line array of the context, and the lamdba code requires some special
     * processing. Find a way to factor the common elements into a single
     * function.
     */

    if (iPtr->cmdFramePtr) {
	CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame));

................................................................................
	    ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var));
    return ProcWrongNumArgs(interp, skip);
}
 
/*
 *----------------------------------------------------------------------
 *
 * PushProcCallFrame --
 *
 *	Compiles a proc body if necessary, then pushes a CallFrame suitable
 *	for executing it.
 *
 * Results:
 *	A standard Tcl object result value.
 *
................................................................................
 * Side effects:
 *	The proc's body may be recompiled. A CallFrame is pushed, it will have
 *	to be popped by the caller.
 *
 *----------------------------------------------------------------------
 */

static int
PushProcCallFrame(
    ClientData clientData,	/* Record describing procedure to be
				 * interpreted. */
    register Tcl_Interp *interp,/* Interpreter in which procedure was
				 * invoked. */
    int objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[],	/* Argument value objects. */
................................................................................
				 * interpreted. */
    register Tcl_Interp *interp,/* Interpreter in which procedure was
				 * invoked. */
    int objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[])	/* Argument value objects. */
{
    int result = PushProcCallFrame(clientData, interp, objc, objv,
	    /*isLambda*/ 0);

    if (result != TCL_OK) {
	return TCL_ERROR;
    }
    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}
................................................................................
    Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2;

    copyPtr->internalRep.twoPtrValue.ptr1 = procPtr;
    copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;

    procPtr->refCount++;
    Tcl_IncrRefCount(nsObjPtr);
    copyPtr->typePtr = &lambdaType;
}

static void
FreeLambdaInternalRep(
    register Tcl_Obj *objPtr)	/* CmdName object with internal representation
				 * to free. */
{
................................................................................

    if (interp == NULL) {
	return TCL_ERROR;
    }

    /*
     * Convert objPtr to list type first; if it cannot be converted, or if its
     * length is not 2, then it cannot be converted to lambdaType.
     */

    result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
    if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"can't interpret \"%s\" as a lambda expression",
		Tcl_GetString(objPtr)));
................................................................................
    }

    Tcl_IncrRefCount(nsObjPtr);

    /*
     * Free the list internalrep of objPtr - this will free argsPtr, but
     * bodyPtr retains a reference from the Proc structure. Then finish the
     * conversion to lambdaType.
     */

    TclFreeIntRep(objPtr);

    objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
    objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
    objPtr->typePtr = &lambdaType;
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ApplyObjCmd --
................................................................................

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * Set lambdaPtr, convert it to lambdaType in the current interp if
     * necessary.
     */

    lambdaPtr = objv[1];
    if (lambdaPtr->typePtr == &lambdaType) {
	procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
    }

#define JOE_EXTENSION 0
/*
 * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT
 * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt
................................................................................
	iPtr->ensembleRewrite.numRemovedObjs = 1;
	iPtr->ensembleRewrite.numInsertedObjs = 0;
    } else {
	iPtr->ensembleRewrite.numInsertedObjs -= 1;
    }
    extraPtr->isRootEnsemble = isRootEnsemble;

    result = PushProcCallFrame(procPtr, interp, objc, objv, 1);
    if (result == TCL_OK) {
	TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL);
	result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
    }
    return result;
}

................................................................................

    overflow = (nameLen > limit);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (lambda term \"%.*s%s\" line %d)",
	    (overflow ? limit : nameLen), procName,
	    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DisassembleObjCmd --
 *
 *	Implementation of the "::tcl::unsupported::disassemble" command. This
 *	command is not documented, but will disassemble procedures, lambda
 *	terms and general scripts. Note that will compile terms if necessary
 *	in order to disassemble them.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DisassembleObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    static const char *const types[] = {
	"lambda", "method", "objmethod", "proc", "script", NULL
    };
    enum Types {
	DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC,
	DISAS_SCRIPT
    };
    int idx, result;
    Tcl_Obj *codeObjPtr = NULL;
    Proc *procPtr = NULL;
    Tcl_HashEntry *hPtr;
    Object *oPtr;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "type ...");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){
	return TCL_ERROR;
    }

    switch ((enum Types) idx) {
    case DISAS_LAMBDA: {
	Command cmd;
	Tcl_Obj *nsObjPtr;
	Tcl_Namespace *nsPtr;

	/*
	 * Compile (if uncompiled) and disassemble a lambda term.
	 */

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm");
	    return TCL_ERROR;
	}
	if (objv[2]->typePtr == &lambdaType) {
	    procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
	}
	if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) {
	    result = SetLambdaFromAny(interp, objv[2]);
	    if (result != TCL_OK) {
		return result;
	    }
	    procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
	}

	memset(&cmd, 0, sizeof(Command));
	nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2;
	result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
	if (result != TCL_OK) {
	    return result;
	}
	cmd.nsPtr = (Namespace *) nsPtr;
	procPtr->cmdPtr = &cmd;
	result = PushProcCallFrame(procPtr, interp, objc, objv, 1);
	if (result != TCL_OK) {
	    return result;
	}
	TclPopStackFrame(interp);
	codeObjPtr = procPtr->bodyPtr;
	break;
    }
    case DISAS_PROC:
	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "procName");
	    return TCL_ERROR;
	}

	procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
	if (procPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "\"%s\" isn't a procedure", TclGetString(objv[2])));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
		    TclGetString(objv[2]), NULL);
	    return TCL_ERROR;
	}

	/*
	 * Compile (if uncompiled) and disassemble a procedure.
	 */

	result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1);
	if (result != TCL_OK) {
	    return result;
	}
	TclPopStackFrame(interp);
	codeObjPtr = procPtr->bodyPtr;
	break;
    case DISAS_SCRIPT:
	/*
	 * Compile and disassemble a script.
	 */

	if (objc != 3) {
	    Tcl_WrongNumArgs(interp, 2, objv, "script");
	    return TCL_ERROR;
	}
	if ((objv[2]->typePtr != &tclByteCodeType)
		&& (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) {
	    return TCL_ERROR;
	}
	codeObjPtr = objv[2];
	break;

    case DISAS_CLASS_METHOD:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "className methodName");
	    return TCL_ERROR;
	}

	/*
	 * Look up the body of a class method.
	 */

	oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
	if (oPtr == NULL) {
	    return TCL_ERROR;
	}
	if (oPtr->classPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "\"%s\" is not a class", TclGetString(objv[2])));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
		    TclGetString(objv[2]), NULL);
	    return TCL_ERROR;
	}
	hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
		(char *) objv[3]);
	goto methodBody;
    case DISAS_OBJECT_METHOD:
	if (objc != 4) {
	    Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName");
	    return TCL_ERROR;
	}

	/*
	 * Look up the body of an instance method.
	 */

	oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
	if (oPtr == NULL) {
	    return TCL_ERROR;
	}
	if (oPtr->methodsPtr == NULL) {
	    goto unknownMethod;
	}
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]);

	/*
	 * Compile (if necessary) and disassemble a method body.
	 */

    methodBody:
	if (hPtr == NULL) {
	unknownMethod:
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "unknown method \"%s\"", TclGetString(objv[3])));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		    TclGetString(objv[3]), NULL);
	    return TCL_ERROR;
	}
	procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
	if (procPtr == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "body not available for this kind of method", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		    "METHODTYPE", NULL);
	    return TCL_ERROR;
	}
	if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
	    Command cmd;

	    /*
	     * Yes, this is ugly, but we need to pass the namespace in to the
	     * compiler in two places.
	     */

	    cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
	    procPtr->cmdPtr = &cmd;
	    result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
		    (Namespace *) oPtr->namespacePtr, "body of method",
		    TclGetString(objv[3]));
	    procPtr->cmdPtr = NULL;
	    if (result != TCL_OK) {
		return result;
	    }
	}
	codeObjPtr = procPtr->bodyPtr;
	break;
    default:
	CLANG_ASSERT(0);
    }

    /*
     * Do the actual disassembly.
     */

    if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags
	    & TCL_BYTECODE_PRECOMPILED) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not disassemble prebuilt bytecode", -1));
	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
		"BYTECODE", NULL);
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
    return TCL_OK;
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */






<







 







<
<
<







 







|


|







 







|







 







|







 







|
|







 







|







 







|







 







|







 







|






|







 







|




|







 







|







 









<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






11
12
13
14
15
16
17

18
19
20
21
22
23
24
..
36
37
38
39
40
41
42



43
44
45
46
47
48
49
..
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
...
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
....
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
....
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
....
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
....
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
....
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
....
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
....
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
....
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
....
2817
2818
2819
2820
2821
2822
2823
2824
2825




































































































































































































































2826
2827
2828
2829
2830
2831
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclCompile.h"


/*
 * Variables that are part of the [apply] command implementation and which
 * have to be passed to the other side of the NRE call.
 */

typedef struct {
................................................................................
static void		FreeLambdaInternalRep(Tcl_Obj *objPtr);
static int		InitArgsAndLocals(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj, int skip);
static void		InitResolvedLocals(Tcl_Interp *interp,
			    ByteCode *codePtr, Var *defPtr,
			    Namespace *nsPtr);
static void		InitLocalCache(Proc *procPtr);



static void		ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void		ProcBodyFree(Tcl_Obj *objPtr);
static int		ProcWrongNumArgs(Tcl_Interp *interp, int skip);
static void		MakeProcError(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj);
static void		MakeLambdaError(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj);
................................................................................

/*
 * The type of lambdas. Note that every lambda will *always* have a string
 * representation.
 *
 * Internally, ptr1 is a pointer to a Proc instance that is not bound to a
 * command name, and ptr2 is a pointer to the namespace that the Proc instance
 * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO.
 */

const Tcl_ObjType tclLambdaType = {
    "lambdaExpr",		/* name */
    FreeLambdaInternalRep,	/* freeIntRepProc */
    DupLambdaInternalRep,	/* dupIntRepProc */
    NULL,			/* updateStringProc */
    SetLambdaFromAny		/* setFromAnyProc */
};
 
................................................................................
     * TIP #280: Remember the line the procedure body is starting on. In a
     * bytecode context we ask the engine to provide us with the necessary
     * information. This is for the initialization of the byte code compiler
     * when the body is used for the first time.
     *
     * This code is nearly identical to the #280 code in SetLambdaFromAny, see
     * this file. The differences are the different index of the body in the
     * line array of the context, and the lambda code requires some special
     * processing. Find a way to factor the common elements into a single
     * function.
     */

    if (iPtr->cmdFramePtr) {
	CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame));

................................................................................
	    ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var));
    return ProcWrongNumArgs(interp, skip);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPushProcCallFrame --
 *
 *	Compiles a proc body if necessary, then pushes a CallFrame suitable
 *	for executing it.
 *
 * Results:
 *	A standard Tcl object result value.
 *
................................................................................
 * Side effects:
 *	The proc's body may be recompiled. A CallFrame is pushed, it will have
 *	to be popped by the caller.
 *
 *----------------------------------------------------------------------
 */

int
TclPushProcCallFrame(
    ClientData clientData,	/* Record describing procedure to be
				 * interpreted. */
    register Tcl_Interp *interp,/* Interpreter in which procedure was
				 * invoked. */
    int objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[],	/* Argument value objects. */
................................................................................
				 * interpreted. */
    register Tcl_Interp *interp,/* Interpreter in which procedure was
				 * invoked. */
    int objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[])	/* Argument value objects. */
{
    int result = TclPushProcCallFrame(clientData, interp, objc, objv,
	    /*isLambda*/ 0);

    if (result != TCL_OK) {
	return TCL_ERROR;
    }
    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}
................................................................................
    Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2;

    copyPtr->internalRep.twoPtrValue.ptr1 = procPtr;
    copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;

    procPtr->refCount++;
    Tcl_IncrRefCount(nsObjPtr);
    copyPtr->typePtr = &tclLambdaType;
}

static void
FreeLambdaInternalRep(
    register Tcl_Obj *objPtr)	/* CmdName object with internal representation
				 * to free. */
{
................................................................................

    if (interp == NULL) {
	return TCL_ERROR;
    }

    /*
     * Convert objPtr to list type first; if it cannot be converted, or if its
     * length is not 2, then it cannot be converted to tclLambdaType.
     */

    result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
    if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"can't interpret \"%s\" as a lambda expression",
		Tcl_GetString(objPtr)));
................................................................................
    }

    Tcl_IncrRefCount(nsObjPtr);

    /*
     * Free the list internalrep of objPtr - this will free argsPtr, but
     * bodyPtr retains a reference from the Proc structure. Then finish the
     * conversion to tclLambdaType.
     */

    TclFreeIntRep(objPtr);

    objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
    objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
    objPtr->typePtr = &tclLambdaType;
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ApplyObjCmd --
................................................................................

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * Set lambdaPtr, convert it to tclLambdaType in the current interp if
     * necessary.
     */

    lambdaPtr = objv[1];
    if (lambdaPtr->typePtr == &tclLambdaType) {
	procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
    }

#define JOE_EXTENSION 0
/*
 * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT
 * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt
................................................................................
	iPtr->ensembleRewrite.numRemovedObjs = 1;
	iPtr->ensembleRewrite.numInsertedObjs = 0;
    } else {
	iPtr->ensembleRewrite.numInsertedObjs -= 1;
    }
    extraPtr->isRootEnsemble = isRootEnsemble;

    result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1);
    if (result == TCL_OK) {
	TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL);
	result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
    }
    return result;
}

................................................................................

    overflow = (nameLen > limit);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (lambda term \"%.*s%s\" line %d)",
	    (overflow ? limit : nameLen), procName,
	    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
 
/*




































































































































































































































 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to tests/compile.test.

654
655
656
657
658
659
660



661
662
663
664
665
666
667
668
669
670
671
672
673
...
733
734
735
736
737
738
739













































































740
741
742
743
744
745
746
    interp delete $i
} -result substituted

# This tests the supported parts of the unsupported [disassemble] command. It
# does not check the format of disassembled bytecode though; that's liable to
# change without warning.




test compile-18.1 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::disassemble
} -match glob -result {wrong # args: should be "*"}
test compile-18.2 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::disassemble ?
} -match glob -result {bad type "?": must be *}
test compile-18.3 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::disassemble lambda
} -match glob -result {wrong # args: should be "* lambda lambdaTerm"}
test compile-18.4 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::disassemble lambda \{
} -result "can't interpret \"\{\" as a lambda expression"
test compile-18.5 {disassembler - basics} -body {
................................................................................
    oo::objdefine foo {method bar {} {}}
} -body {
    # Allow any string: the result format is not defined anywhere!
    tcl::unsupported::disassemble objmethod foo bar
} -cleanup {
    foo destroy
} -match glob -result *














































































test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
    # This will panic in a --enable-symbols=compile build, unless bug is fixed.
    apply {{} {list [if 1]}}
} -returnCodes error -match glob -result *

test compile-20.1 {ensure there are no infinite loops in optimizing} {






>
>
>





|







 







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







654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
...
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
    interp delete $i
} -result substituted

# This tests the supported parts of the unsupported [disassemble] command. It
# does not check the format of disassembled bytecode though; that's liable to
# change without warning.

set disassemblables [linsert [join {
    lambda method objmethod proc script
} ", "] end-1 or]
test compile-18.1 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::disassemble
} -match glob -result {wrong # args: should be "*"}
test compile-18.2 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::disassemble ?
} -result "bad type \"?\": must be $disassemblables"
test compile-18.3 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::disassemble lambda
} -match glob -result {wrong # args: should be "* lambda lambdaTerm"}
test compile-18.4 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::disassemble lambda \{
} -result "can't interpret \"\{\" as a lambda expression"
test compile-18.5 {disassembler - basics} -body {
................................................................................
    oo::objdefine foo {method bar {} {}}
} -body {
    # Allow any string: the result format is not defined anywhere!
    tcl::unsupported::disassemble objmethod foo bar
} -cleanup {
    foo destroy
} -match glob -result *
# There never was a compile-18.20.
# The keys of the dictionary produced by [getbytecode] are defined.
set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth exceptdepth}
test compile-18.21 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode
} -match glob -result {wrong # args: should be "*"}
test compile-18.22 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode ?
} -result "bad type \"?\": must be $disassemblables"
test compile-18.23 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode lambda
} -match glob -result {wrong # args: should be "* lambda lambdaTerm"}
test compile-18.24 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode lambda \{
} -result "can't interpret \"\{\" as a lambda expression"
test compile-18.25 {disassembler - basics} -body {
    dict keys [tcl::unsupported::getbytecode lambda {{} {}}]
} -result $bytecodekeys
test compile-18.26 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode proc
} -match glob -result {wrong # args: should be "* proc procName"}
test compile-18.27 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode proc nosuchproc
} -result {"nosuchproc" isn't a procedure}
test compile-18.28 {disassembler - basics} -setup {
    proc chewonthis {} {}
} -body {
    dict keys [tcl::unsupported::getbytecode proc chewonthis]
} -cleanup {
    rename chewonthis {}
} -result $bytecodekeys
test compile-18.29 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode script
} -match glob -result {wrong # args: should be "* script script"}
test compile-18.30 {disassembler - basics} -body {
    dict keys [tcl::unsupported::getbytecode script {}]
} -result $bytecodekeys
test compile-18.31 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode method
} -match glob -result {wrong # args: should be "* method className methodName"}
test compile-18.32 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode method nosuchclass foo
} -result {nosuchclass does not refer to an object}
test compile-18.33 {disassembler - basics} -returnCodes error -setup {
    oo::object create justanobject
} -body {
    tcl::unsupported::getbytecode method justanobject foo
} -cleanup {
    justanobject destroy
} -result {"justanobject" is not a class}
test compile-18.34 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode method oo::object nosuchmethod
} -result {unknown method "nosuchmethod"}
test compile-18.35 {disassembler - basics} -setup {
    oo::class create foo {method bar {} {}}
} -body {
    dict keys [tcl::unsupported::getbytecode method foo bar]
} -cleanup {
    foo destroy
} -result $bytecodekeys
test compile-18.36 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode objmethod
} -match glob -result {wrong # args: should be "* objmethod objectName methodName"}
test compile-18.37 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode objmethod nosuchobject foo
} -result {nosuchobject does not refer to an object}
test compile-18.38 {disassembler - basics} -returnCodes error -body {
    tcl::unsupported::getbytecode objmethod oo::object nosuchmethod
} -result {unknown method "nosuchmethod"}
test compile-18.39 {disassembler - basics} -setup {
    oo::object create foo
    oo::objdefine foo {method bar {} {}}
} -body {
    dict keys [tcl::unsupported::getbytecode objmethod foo bar]
} -cleanup {
    foo destroy
} -result $bytecodekeys

test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
    # This will panic in a --enable-symbols=compile build, unless bug is fixed.
    apply {{} {list [if 1]}}
} -returnCodes error -match glob -result *

test compile-20.1 {ensure there are no infinite loops in optimizing} {

Changes to unix/Makefile.in.

290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
...
403
404
405
406
407
408
409

410
411
412
413
414
415
416
....
1104
1105
1106
1107
1108
1109
1110



1111
1112
1113
1114
1115
1116
1117
....
1570
1571
1572
1573
1574
1575
1576

1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
	tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o

GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
	tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \
	tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \
	tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \
	tclCompile.o tclConfig.o tclDate.o tclDictObj.o \
	tclEncoding.o tclEnsemble.o \
	tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
	tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \
	tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \
	tclLink.o tclListObj.o \
	tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
	tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
................................................................................
	$(GENERIC_DIR)/tclCompCmdsGR.c \
	$(GENERIC_DIR)/tclCompCmdsSZ.c \
	$(GENERIC_DIR)/tclCompExpr.c \
	$(GENERIC_DIR)/tclCompile.c \
	$(GENERIC_DIR)/tclConfig.c \
	$(GENERIC_DIR)/tclDate.c \
	$(GENERIC_DIR)/tclDictObj.c \

	$(GENERIC_DIR)/tclEncoding.c \
	$(GENERIC_DIR)/tclEnsemble.c \
	$(GENERIC_DIR)/tclEnv.c \
	$(GENERIC_DIR)/tclEvent.c \
	$(GENERIC_DIR)/tclExecute.c \
	$(GENERIC_DIR)/tclFCmd.c \
	$(GENERIC_DIR)/tclFileName.c \
................................................................................

tclConfig.o: $(GENERIC_DIR)/tclConfig.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclConfig.c

tclDictObj.o: $(GENERIC_DIR)/tclDictObj.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDictObj.c




tclEncoding.o: $(GENERIC_DIR)/tclEncoding.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEncoding.c

tclEnsemble.o: $(GENERIC_DIR)/tclEnsemble.c $(COMPILEHDR)
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnsemble.c

tclEnv.o: $(GENERIC_DIR)/tclEnv.c
................................................................................

tclUnixThrd.o: $(UNIX_DIR)/tclUnixThrd.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixThrd.c

tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c


tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh
	$(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
		-DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \
		$(UNIX_DIR)/tclUnixInit.c

tclUnixCompat.o: $(UNIX_DIR)/tclUnixCompat.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixCompat.c

# The following are Mac OS X only sources:
tclMacOSXBundle.o: $(MAC_OSX_DIR)/tclMacOSXBundle.c
	$(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXBundle.c






|







 







>







 







>
>
>







 







>

<
<
|







290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
...
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
....
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
....
1574
1575
1576
1577
1578
1579
1580
1581
1582


1583
1584
1585
1586
1587
1588
1589
1590
XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
	tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o

GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
	tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \
	tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \
	tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \
	tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \
	tclEncoding.o tclEnsemble.o \
	tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
	tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \
	tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \
	tclLink.o tclListObj.o \
	tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
	tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
................................................................................
	$(GENERIC_DIR)/tclCompCmdsGR.c \
	$(GENERIC_DIR)/tclCompCmdsSZ.c \
	$(GENERIC_DIR)/tclCompExpr.c \
	$(GENERIC_DIR)/tclCompile.c \
	$(GENERIC_DIR)/tclConfig.c \
	$(GENERIC_DIR)/tclDate.c \
	$(GENERIC_DIR)/tclDictObj.c \
	$(GENERIC_DIR)/tclDisassemble.c \
	$(GENERIC_DIR)/tclEncoding.c \
	$(GENERIC_DIR)/tclEnsemble.c \
	$(GENERIC_DIR)/tclEnv.c \
	$(GENERIC_DIR)/tclEvent.c \
	$(GENERIC_DIR)/tclExecute.c \
	$(GENERIC_DIR)/tclFCmd.c \
	$(GENERIC_DIR)/tclFileName.c \
................................................................................

tclConfig.o: $(GENERIC_DIR)/tclConfig.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclConfig.c

tclDictObj.o: $(GENERIC_DIR)/tclDictObj.c $(MATHHDRS)
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDictObj.c

tclDisassemble.o: $(GENERIC_DIR)/tclDisassemble.c $(COMPILEHDR)
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDisassemble.c

tclEncoding.o: $(GENERIC_DIR)/tclEncoding.c
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEncoding.c

tclEnsemble.o: $(GENERIC_DIR)/tclEnsemble.c $(COMPILEHDR)
	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnsemble.c

tclEnv.o: $(GENERIC_DIR)/tclEnv.c
................................................................................

tclUnixThrd.o: $(UNIX_DIR)/tclUnixThrd.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixThrd.c

tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c

TCL_LOCATIONS=-DTCL_LIBRARY="\"${TCL_LIBRARY}\"" -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\""
tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh


	$(CC) -c $(CC_SWITCHES) $(TCL_LOCATIONS) $(UNIX_DIR)/tclUnixInit.c

tclUnixCompat.o: $(UNIX_DIR)/tclUnixCompat.c
	$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixCompat.c

# The following are Mac OS X only sources:
tclMacOSXBundle.o: $(MAC_OSX_DIR)/tclMacOSXBundle.c
	$(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXBundle.c

Changes to win/Makefile.in.

228
229
230
231
232
233
234

235
236
237
238
239
240
241
	tclCompCmdsGR.$(OBJEXT) \
	tclCompCmdsSZ.$(OBJEXT) \
	tclCompExpr.$(OBJEXT) \
	tclCompile.$(OBJEXT) \
	tclConfig.$(OBJEXT) \
	tclDate.$(OBJEXT) \
	tclDictObj.$(OBJEXT) \

	tclEncoding.$(OBJEXT) \
	tclEnsemble.$(OBJEXT) \
	tclEnv.$(OBJEXT) \
	tclEvent.$(OBJEXT) \
	tclExecute.$(OBJEXT) \
	tclFCmd.$(OBJEXT) \
	tclFileName.$(OBJEXT) \






>







228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
	tclCompCmdsGR.$(OBJEXT) \
	tclCompCmdsSZ.$(OBJEXT) \
	tclCompExpr.$(OBJEXT) \
	tclCompile.$(OBJEXT) \
	tclConfig.$(OBJEXT) \
	tclDate.$(OBJEXT) \
	tclDictObj.$(OBJEXT) \
	tclDisassemble.$(OBJEXT) \
	tclEncoding.$(OBJEXT) \
	tclEnsemble.$(OBJEXT) \
	tclEnv.$(OBJEXT) \
	tclEvent.$(OBJEXT) \
	tclExecute.$(OBJEXT) \
	tclFCmd.$(OBJEXT) \
	tclFileName.$(OBJEXT) \

Changes to win/makefile.bc.

203
204
205
206
207
208
209

210
211
212
213
214
215
216
...
583
584
585
586
587
588
589




	$(TMPDIR)\tclCompCmdsGR.obj \
	$(TMPDIR)\tclCompCmdsSZ.obj \
	$(TMPDIR)\tclCompExpr.obj \
	$(TMPDIR)\tclCompile.obj \
	$(TMPDIR)\tclConfig.obj \
	$(TMPDIR)\tclDate.obj \
	$(TMPDIR)\tclDictObj.obj \

	$(TMPDIR)\tclEncoding.obj \
	$(TMPDIR)\tclEnsemble.obj \
	$(TMPDIR)\tclEnv.obj \
	$(TMPDIR)\tclEvent.obj \
	$(TMPDIR)\tclExecute.obj \
	$(TMPDIR)\tclFCmd.obj \
	$(TMPDIR)\tclFileName.obj \
................................................................................
	[email protected]$(RM) $(OUTDIR)\*.pdb
	[email protected]$(RM) $(TMPDIR)\*.pch
	[email protected]$(RM) $(TMPDIR)\*.obj
	[email protected]$(RM) $(TMPDIR)\*.res
	[email protected]$(RM) $(TMPDIR)\*.exe
	[email protected]$(RMDIR) $(OUTDIR)
	[email protected]$(RMDIR) $(TMPDIR)










>







 







>
>
>
>
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
...
584
585
586
587
588
589
590
591
592
593
594
	$(TMPDIR)\tclCompCmdsGR.obj \
	$(TMPDIR)\tclCompCmdsSZ.obj \
	$(TMPDIR)\tclCompExpr.obj \
	$(TMPDIR)\tclCompile.obj \
	$(TMPDIR)\tclConfig.obj \
	$(TMPDIR)\tclDate.obj \
	$(TMPDIR)\tclDictObj.obj \
	$(TMPDIR)\tclDisassemble.obj \
	$(TMPDIR)\tclEncoding.obj \
	$(TMPDIR)\tclEnsemble.obj \
	$(TMPDIR)\tclEnv.obj \
	$(TMPDIR)\tclEvent.obj \
	$(TMPDIR)\tclExecute.obj \
	$(TMPDIR)\tclFCmd.obj \
	$(TMPDIR)\tclFileName.obj \
................................................................................
	[email protected]$(RM) $(OUTDIR)\*.pdb
	[email protected]$(RM) $(TMPDIR)\*.pch
	[email protected]$(RM) $(TMPDIR)\*.obj
	[email protected]$(RM) $(TMPDIR)\*.res
	[email protected]$(RM) $(TMPDIR)\*.exe
	[email protected]$(RMDIR) $(OUTDIR)
	[email protected]$(RMDIR) $(TMPDIR)

# Local Variables:
# mode: makefile
# End:

Changes to win/makefile.vc.

1
2
3
4
5
6
7
8
...
277
278
279
280
281
282
283

284
285
286
287
288
289
290
....
1225
1226
1227
1228
1229
1230
1231




#------------------------------------------------------------- -*- makefile -*-
# makefile.vc --
#
#	Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
................................................................................
	$(TMP_DIR)\tclCompCmdsGR.obj \
	$(TMP_DIR)\tclCompCmdsSZ.obj \
	$(TMP_DIR)\tclCompExpr.obj \
	$(TMP_DIR)\tclCompile.obj \
	$(TMP_DIR)\tclConfig.obj \
	$(TMP_DIR)\tclDate.obj \
	$(TMP_DIR)\tclDictObj.obj \

	$(TMP_DIR)\tclEncoding.obj \
	$(TMP_DIR)\tclEnsemble.obj \
	$(TMP_DIR)\tclEnv.obj \
	$(TMP_DIR)\tclEvent.obj \
	$(TMP_DIR)\tclExecute.obj \
	$(TMP_DIR)\tclFCmd.obj \
	$(TMP_DIR)\tclFileName.obj \
................................................................................
	@if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc

realclean: hose

hose:
	@echo Hosing $(OUT_DIR)\* ...
	@if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR)




|







 







>







 







>
>
>
>
1
2
3
4
5
6
7
8
...
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
....
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
#-------------------------------------------------------------
# makefile.vc --
#
#	Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
................................................................................
	$(TMP_DIR)\tclCompCmdsGR.obj \
	$(TMP_DIR)\tclCompCmdsSZ.obj \
	$(TMP_DIR)\tclCompExpr.obj \
	$(TMP_DIR)\tclCompile.obj \
	$(TMP_DIR)\tclConfig.obj \
	$(TMP_DIR)\tclDate.obj \
	$(TMP_DIR)\tclDictObj.obj \
	$(TMP_DIR)\tclDisassemble.obj \
	$(TMP_DIR)\tclEncoding.obj \
	$(TMP_DIR)\tclEnsemble.obj \
	$(TMP_DIR)\tclEnv.obj \
	$(TMP_DIR)\tclEvent.obj \
	$(TMP_DIR)\tclExecute.obj \
	$(TMP_DIR)\tclFCmd.obj \
	$(TMP_DIR)\tclFileName.obj \
................................................................................
	@if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc

realclean: hose

hose:
	@echo Hosing $(OUT_DIR)\* ...
	@if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR)

# Local Variables:
# mode: makefile
# End: