Tcl Source Code

Check-in [e31506063b]
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:Tidy things up a bit more.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | dkf-improved-disassembler
Files: files | file ages | folders
SHA1: e31506063bff3443b9ed885875a174850f3f4776
User & Date: dkf 2014-09-20 11:40:35
Context
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-14
17:11
whitespace tweak check-in: 61b66a0f21 user: dkf tags: dkf-improved-disassembler
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclDisassemble.c.

17
18
19
20
21
22
23

24
25
26
27
28
29
30
..
35
36
37
38
39
40
41







42
43
44
45
46
47
48
...
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
...
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
....
1197
1198
1199
1200
1201
1202
1203


1204
1205
1206
1207
1208
1209
1210
....
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
#include "tclOOInt.h"
#include <assert.h>

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


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

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







 
#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * TclPrintByteCodeObj --
 *
................................................................................
 *----------------------------------------------------------------------
 */

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

static Tcl_Obj *
DisassembleByteCodeAsDicts(
    Tcl_Obj *objPtr)		/* The bytecode-holding value to take apart */
{
    ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
    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;

    /*
................................................................................
    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 == &tclLambdaType) {
................................................................................
	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;
    }
    if (PTR2INT(clientData)) {






>







 







>
>
>
>
>
>
>







 







|







 







|







 







>
>







 







<
|







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
..
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
...
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
...
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
....
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
....
1374
1375
1376
1377
1378
1379
1380

1381
1382
1383
1384
1385
1386
1387
1388
#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);

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

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

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;

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

Changes to generic/tclProc.c.

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
/*
 * 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.
 */

const Tcl_ObjType tclLambdaType = {
    "lambdaExpr",		/* name */
    FreeLambdaInternalRep,	/* freeIntRepProc */
    DupLambdaInternalRep,	/* dupIntRepProc */
    NULL,			/* updateStringProc */






|







84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
/*
 * 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 */