summaryrefslogtreecommitdiffstats
path: root/generic/tclCompile.c
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2007-09-25 20:27:17 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2007-09-25 20:27:17 (GMT)
commit672cb039e55156194700decdd3ab48d444249b4a (patch)
tree8f3fb850f2394af6bdd6ca36cb82dc3506cabe47 /generic/tclCompile.c
parent07010d008140290042f0c4f42cc7892cd4ddf12e (diff)
downloadtcl-672cb039e55156194700decdd3ab48d444249b4a.zip
tcl-672cb039e55156194700decdd3ab48d444249b4a.tar.gz
tcl-672cb039e55156194700decdd3ab48d444249b4a.tar.bz2
Add a new command, ::tcl::unsupported::disassemble
Diffstat (limited to 'generic/tclCompile.c')
-rw-r--r--generic/tclCompile.c354
1 files changed, 224 insertions, 130 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 6ae3aaf..d4c5d9e 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.133 2007/09/11 14:47:42 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.134 2007/09/25 20:27:17 dkf Exp $
*/
#include "tclInt.h"
@@ -376,10 +376,10 @@ InstructionDesc tclInstructionTable[] = {
/* finds level and otherName in stack, links to local variable at
* index op1. Leaves the level on stack. */
{"nsupvar", 5, 0, 1, {OPERAND_LVT4}},
- /* finds namespace and otherName in stack, links to local variable at
+ /* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
{"variable", 5, 0, 1, {OPERAND_LVT4}},
- /* finds namespace and otherName in stack, links to local variable at
+ /* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
{"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
/* Compiled bytecodes to signal syntax error. */
@@ -407,6 +407,10 @@ static void RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
static int SetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
+static int FormatInstruction(ByteCode *codePtr,
+ unsigned char *pc, Tcl_Obj *bufferObj);
+static void PrintSourceToObj(Tcl_Obj *appendObj,
+ const char *stringPtr, int maxChars);
/*
* TIP #280: Helper for building the per-word line information of all compiled
* commands.
@@ -720,7 +724,7 @@ TclCleanupByteCode(
* 1) decrement the ref counts of the LiteralEntry's in its literal array,
* 2) call the free procs for the auxiliary data items, 3) free the
* localCache if it is unused, and finally 4) free the ByteCode
- * structure's heap object.
+ * structure's heap object.
*
* The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like
* those generated from tbcload) is special, as they doesn't make use of
@@ -916,7 +920,7 @@ TclInitCompileEnv(
ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
*ctxPtr = *invoker;
-
+
if (invoker->type == TCL_LOCATION_BC) {
/*
* Note: Type BC => ctx.data.eval.path is not used.
@@ -1162,7 +1166,7 @@ TclCompileScript(
if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) {
/* Compile bytecodes to report the parse error at runtime. */
- Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
+ Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
/* Drop the command terminator (";","]") if appropriate */
(parsePtr->term ==
parsePtr->commandStart + parsePtr->commandSize - 1)?
@@ -1330,7 +1334,7 @@ TclCompileScript(
* case. [Bug 1752146]
* Note that the environment is initialised with
* atCmdStart=1 to avoid emitting ISC for the first
- * command.
+ * command.
*/
if (envPtr->atCmdStart) {
@@ -1341,9 +1345,9 @@ TclCompileScript(
* this depends on the exact layout of the
* INST_START_CMD's operands, so be careful!
*/
-
+
unsigned char *fixPtr = envPtr->codeNext - 4;
-
+
TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1,
fixPtr);
}
@@ -1828,7 +1832,7 @@ TclCompileExprWords(
* Side effects:
* Instructions are added to envPtr to execute a no-op at runtime. No
* result is pushed onto the stack: the compiler has to take care of this
- * itself if the last compiled command is a NoOp.
+ * itself if the last compiled command is a NoOp.
*
*----------------------------------------------------------------------
*/
@@ -3207,15 +3211,135 @@ TclPrintByteCodeObj(
Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ 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. */
+ unsigned char *pc) /* Points to first byte of instruction. */
+{
+ Tcl_Obj *bufferObj;
+
+ TclNewObj(bufferObj);
+ 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, 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.otherValuePtr;
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; /* already freed */
+ return bufferObj; /* Already freed. */
}
codeStart = codePtr->codeStart;
@@ -3226,14 +3350,17 @@ TclPrintByteCodeObj(
* Print header lines describing the ByteCode.
*/
- fprintf(stdout,
- "\nByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n",
- codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
+ 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);
- fprintf(stdout, " Source ");
- TclPrintSource(stdout, codePtr->source,
+ Tcl_AppendToObj(bufferObj, " Source ", -1);
+ PrintSourceToObj(bufferObj, codePtr->source,
TclMin(codePtr->numSrcBytes, 55));
- fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
+ 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,
@@ -3244,7 +3371,7 @@ TclPrintByteCodeObj(
0.0);
#ifdef TCL_COMPILE_STATS
- fprintf(stdout,
+ 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))),
@@ -3264,14 +3391,18 @@ TclPrintByteCodeObj(
if (codePtr->procPtr != NULL) {
Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
- fprintf(stdout,
- " Proc 0x%p, refCt %d, args %d, compiled locals %d\n",
- procPtr, procPtr->refCount, procPtr->numArgs,
+
+ 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++) {
- fprintf(stdout, " slot %d%s%s%s%s%s%s", 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" : "",
@@ -3279,9 +3410,10 @@ TclPrintByteCodeObj(
(localPtr->flags & VAR_TEMPORARY) ? ", temp" : "",
(localPtr->flags & VAR_RESOLVED) ? ", resolved" : "");
if (TclIsVarTemporary(localPtr)) {
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
} else {
- fprintf(stdout, ", \"%s\"\n", localPtr->name);
+ Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n",
+ localPtr->name);
}
localPtr = localPtr->nextPtr;
}
@@ -3293,25 +3425,28 @@ TclPrintByteCodeObj(
*/
if (codePtr->numExceptRanges > 0) {
- fprintf(stdout, " Exception ranges %d, depth %d:\n",
+ 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]);
- fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
+
+ 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:
- fprintf(stdout, "continue %d, break %d\n",
+ Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n",
rangePtr->continueOffset, rangePtr->breakOffset);
break;
case CATCH_EXCEPTION_RANGE:
- fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
+ Tcl_AppendPrintfToObj(bufferObj, "catch %d\n",
+ rangePtr->catchOffset);
break;
default:
- Tcl_Panic("TclPrintByteCodeObj: bad ExceptionRange type %d",
+ Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d",
rangePtr->type);
}
}
@@ -3325,10 +3460,10 @@ TclPrintByteCodeObj(
if (numCmds == 0) {
pc = codeStart;
while (pc < codeLimit) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
+ Tcl_AppendToObj(bufferObj, " ", -1);
+ pc += FormatInstruction(codePtr, pc, bufferObj);
}
- return;
+ return bufferObj;
}
/*
@@ -3336,7 +3471,7 @@ TclPrintByteCodeObj(
* for each command. These are encoded as a sequence of bytes.
*/
- fprintf(stdout, " Commands %d:", numCmds);
+ Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds);
codeDeltaNext = codePtr->codeDeltaStart;
codeLengthNext = codePtr->codeLengthStart;
srcDeltaNext = codePtr->srcDeltaStart;
@@ -3381,13 +3516,13 @@ TclPrintByteCodeObj(
srcLengthNext++;
}
- fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d",
+ 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) {
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
}
/*
@@ -3436,14 +3571,14 @@ TclPrintByteCodeObj(
*/
while ((pc-codeStart) < codeOffset) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
+ Tcl_AppendToObj(bufferObj, " ", -1);
+ pc += FormatInstruction(codePtr, pc, bufferObj);
}
- fprintf(stdout, " Command %d: ", (i+1));
- TclPrintSource(stdout, (codePtr->source + srcOffset),
+ Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1);
+ PrintSourceToObj(bufferObj, (codePtr->source + srcOffset),
TclMin(srcLen, 55));
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
}
if (pc < codeLimit) {
/*
@@ -3451,43 +3586,37 @@ TclPrintByteCodeObj(
*/
while (pc < codeLimit) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
+ Tcl_AppendToObj(bufferObj, " ", -1);
+ pc += FormatInstruction(codePtr, pc, bufferObj);
}
}
+ return bufferObj;
}
/*
*----------------------------------------------------------------------
*
- * TclPrintInstruction --
+ * FormatInstruction --
*
- * 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.
+ * Appends a representation of a bytecode instruction to a Tcl_Obj.
*
*----------------------------------------------------------------------
*/
-int
-TclPrintInstruction(
+static int
+FormatInstruction(
ByteCode *codePtr, /* Bytecode containing the instruction. */
- unsigned char *pc) /* Points to first byte of instruction. */
+ 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 InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
unsigned int pcOffset = (pc - codeStart);
- int opnd, i, j, numBytes = 1;
+ int opnd = 0, i, j, numBytes = 1;
int localCt = procPtr ? procPtr->numCompiledLocals : 0;
CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;
-
char suffixBuffer[64]; /* Additional info to print after main opcode
* and immediates. */
char *suffixSrc = NULL;
@@ -3495,7 +3624,7 @@ TclPrintInstruction(
AuxData *auxPtr = NULL;
suffixBuffer[0] = '\0';
- fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
+ Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name);
for (i = 0; i < instDesc->numOperands; i++) {
switch (instDesc->opTypes[i]) {
case OPERAND_INT1:
@@ -3504,7 +3633,7 @@ TclPrintInstruction(
|| opCode == INST_JUMP_FALSE1) {
sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
}
- fprintf(stdout, "%+d ", opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_INT4:
opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
@@ -3514,14 +3643,14 @@ TclPrintInstruction(
} else if (opCode == INST_START_CMD) {
sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);
}
- fprintf(stdout, "%+d ", opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_UINT1:
opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
if (opCode == INST_PUSH1) {
suffixObj = codePtr->objArrayPtr[opnd];
}
- fprintf(stdout, "%u ", (unsigned int) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned int) opnd);
break;
case OPERAND_AUX4:
case OPERAND_UINT4:
@@ -3531,7 +3660,7 @@ TclPrintInstruction(
} else if (opCode == INST_START_CMD && opnd != 1) {
sprintf(suffixBuffer, ", %u cmds start here", opnd);
}
- fprintf(stdout, "%u ", (unsigned int) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned int) opnd);
if (instDesc->opTypes[i] == OPERAND_AUX4) {
auxPtr = &codePtr->auxDataArrayPtr[opnd];
}
@@ -3539,11 +3668,11 @@ TclPrintInstruction(
case OPERAND_IDX4:
opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
if (opnd >= -1) {
- fprintf(stdout, "%d ", opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd);
} else if (opnd == -2) {
- fprintf(stdout, "end ");
+ Tcl_AppendPrintfToObj(bufferObj, "end ");
} else {
- fprintf(stdout, "end-%d ", -2-opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd);
}
break;
case OPERAND_LVT1:
@@ -3556,7 +3685,7 @@ TclPrintInstruction(
printLVTindex:
if (localPtr != NULL) {
if (opnd >= localCt) {
- Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)",
+ Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)",
(unsigned int) opnd, localCt);
}
for (j = 0; j < opnd; j++) {
@@ -3569,7 +3698,7 @@ TclPrintInstruction(
suffixSrc = localPtr->name;
}
}
- fprintf(stdout, "%%v%u ", (unsigned) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
break;
case OPERAND_NONE:
default:
@@ -3577,19 +3706,24 @@ TclPrintInstruction(
}
}
if (suffixObj) {
- fprintf(stdout, "\t# ");
- TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
+ 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]) {
- fprintf(stdout, "\t# %s", suffixBuffer);
+ Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
if (suffixSrc) {
- TclPrintSource(stdout, suffixSrc, 40);
+ PrintSourceToObj(bufferObj, suffixSrc, 40);
}
}
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
if (auxPtr && auxPtr->type->printProc) {
- fprintf(stdout, "\t\t[");
- auxPtr->type->printProc(auxPtr->clientData, codePtr, pcOffset);
- fprintf(stdout, "]\n");
+ Tcl_AppendToObj(bufferObj, "\t\t[", -1);
+ auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr,
+ pcOffset);
+ Tcl_AppendToObj(bufferObj, "]\n", -1);
}
return numBytes;
}
@@ -3597,55 +3731,16 @@ TclPrintInstruction(
/*
*----------------------------------------------------------------------
*
- * TclPrintObject --
+ * PrintSourceToObj --
*
- * 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.
+ * Appends a quoted representation of a string to a Tcl_Obj.
*
*----------------------------------------------------------------------
*/
-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. */
+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. */
{
@@ -3653,40 +3748,39 @@ TclPrintSource(
register int i = 0;
if (stringPtr == NULL) {
- fprintf(outFile, "\"\"");
+ Tcl_AppendToObj(appendObj, "\"\"", -1);
return;
}
- fprintf(outFile, "\"");
+ Tcl_AppendToObj(appendObj, "\"", -1);
p = stringPtr;
for (; (*p != '\0') && (i < maxChars); p++, i++) {
switch (*p) {
case '"':
- fprintf(outFile, "\\\"");
+ Tcl_AppendToObj(appendObj, "\\\"", -1);
continue;
case '\f':
- fprintf(outFile, "\\f");
+ Tcl_AppendToObj(appendObj, "\\f", -1);
continue;
case '\n':
- fprintf(outFile, "\\n");
+ Tcl_AppendToObj(appendObj, "\\n", -1);
continue;
case '\r':
- fprintf(outFile, "\\r");
+ Tcl_AppendToObj(appendObj, "\\r", -1);
continue;
case '\t':
- fprintf(outFile, "\\t");
+ Tcl_AppendToObj(appendObj, "\\t", -1);
continue;
case '\v':
- fprintf(outFile, "\\v");
+ Tcl_AppendToObj(appendObj, "\\v", -1);
continue;
default:
- fprintf(outFile, "%c", *p);
+ Tcl_AppendPrintfToObj(appendObj, "%c", *p);
continue;
}
}
- fprintf(outFile, "\"");
+ Tcl_AppendToObj(appendObj, "\"", -1);
}
-#endif /* TCL_COMPILE_DEBUG */
#ifdef TCL_COMPILE_STATS
/*