summaryrefslogtreecommitdiffstats
path: root/generic/tclCompile.c
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2003-11-14 20:44:43 (GMT)
committerdgp <dgp@users.sourceforge.net>2003-11-14 20:44:43 (GMT)
commit17f540b256d78b8a6fc8bd9121a633dac6c23b19 (patch)
tree1abdc7a020d4095171e8cb7f16def9be025cb664 /generic/tclCompile.c
parentf745c9aa31bbdf8f71589fa25d30ce50cad94652 (diff)
downloadtcl-17f540b256d78b8a6fc8bd9121a633dac6c23b19.zip
tcl-17f540b256d78b8a6fc8bd9121a633dac6c23b19.tar.gz
tcl-17f540b256d78b8a6fc8bd9121a633dac6c23b19.tar.bz2
* doc/ParseCmd.3: Implementation of TIP 157. Adds recognition
* doc/Tcl.n: of the new leading {expand} syntax on words. * generic/tcl.h: Parses such words as the new Tcl_Token type * generic/tclBasic.c: TCL_TOKEN_EXPAND_WORD. Updated Tcl_EvalEx * generic/tclCompile.c: and the bytecode compiler/execution engine * generic/tclCompile.h: to recognize the new token type. New opcodes * generic/tclExecute.c: INST_LIST_VERIFY and INST_INVOKE_EXP and a new * generic/tclParse.c: operand type OPERAND_ULIST1 are defined. Docs * generic/tclTest.c: and tests are included. * tests/basic.test: * tests/compile.test: * tests/parse.test: * library/auto.tcl: Replaced several [eval]s used to perform * library/package.tcl: argument expansion with the new syntax. * library/safe.tcl: In the test files lindex.test and lset.test, * tests/cmdInfo.test: replaced use of [eval] to force direct * tests/encoding.test: string evaluation with use of [testevalex] * tests/execute.test: which more directly and robustly serves the * tests/fCmd.test: same purpose. * tests/http.test: * tests/init.test: * tests/interp.test: * tests/io.test: * tests/ioUtil.test: * tests/iogt.test: * tests/lindex.test: * tests/lset.test: * tests/namespace-old.test: * tests/namespace.test: * tests/pkg.test: * tests/pkgMkIndex.test: * tests/proc.test: * tests/reg.test: * tests/trace.test: * tests/upvar.test: * tests/winConsole.test: * tests/winFCmd.test:
Diffstat (limited to 'generic/tclCompile.c')
-rw-r--r--generic/tclCompile.c117
1 files changed, 99 insertions, 18 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 66d4bea..ee1a8a9 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.51 2003/10/14 15:44:52 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.52 2003/11/14 20:44:44 dgp Exp $
*/
#include "tclInt.h"
@@ -273,6 +273,10 @@ InstructionDesc tclInstructionTable[] = {
/* return TCL_RETURN code. */
{"expon", 1, -1, 0, {OPERAND_NONE}},
/* Binary exponentiation operator: push (stknext ** stktop) */
+ {"listverify", 1, 0, 0, {OPERAND_NONE}},
+ /* Test that top of stack is a valid list; error if not */
+ {"invokeExp", INT_MIN, INT_MIN, 2, {OPERAND_UINT4, OPERAND_ULIST1}},
+ /* Invoke with expansion: <objc,objv> = expanded <op1,top op1> */
{0}
};
@@ -843,6 +847,10 @@ TclCompileScript(interp, script, numBytes, envPtr)
}
gotParse = 1;
if (parse.numWords > 0) {
+ int expand = 0;
+ unsigned char delta = 1;
+ Tcl_DString deltaList;
+
/*
* If not the first command, pop the previous command's result
* and, if we're compiling a top level command, update the last
@@ -883,28 +891,57 @@ TclCompileScript(interp, script, numBytes, envPtr)
fprintf(stdout, "\n");
}
#endif
+
/*
- * Each iteration of the following loop compiles one word
- * from the command.
+ * Check whether expansion has been requested for any of
+ * the words
*/
-
+
+ for (wordIdx = 0, tokenPtr = parse.tokenPtr;
+ wordIdx < parse.numWords;
+ wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
+ expand = 1;
+ Tcl_DStringInit(&deltaList);
+ break;
+ }
+ }
+
envPtr->numCommands++;
currCmdIndex = (envPtr->numCommands - 1);
lastTopLevelCmdIndex = currCmdIndex;
startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
EnterCmdStartData(envPtr, currCmdIndex,
(parse.commandStart - envPtr->source), startCodeOffset);
+
+ /*
+ * Each iteration of the following loop compiles one word
+ * from the command.
+ */
for (wordIdx = 0, tokenPtr = parse.tokenPtr;
- wordIdx < parse.numWords;
- wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ wordIdx < parse.numWords; delta++, wordIdx++,
+ tokenPtr += (tokenPtr->numComponents + 1)) {
+
+ if ((delta == 255)
+ && (tokenPtr->type != TCL_TOKEN_EXPAND_WORD)) {
+ /*
+ * Push an empty list for expansion so our delta
+ * between expanded words doesn't overflow a byte
+ */
+ objIndex = TclRegisterNewLiteral(envPtr, "", 0);
+ TclEmitPush(objIndex, envPtr);
+ Tcl_DStringAppend(&deltaList, &delta, 1);
+ delta = 1;
+ }
+
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
* If this is the first word and the command has a
* compile procedure, let it compile the command.
*/
- if (wordIdx == 0) {
+ if ((wordIdx == 0) && !expand) {
if (envPtr->procPtr != NULL) {
cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
} else {
@@ -987,20 +1024,55 @@ TclCompileScript(interp, script, numBytes, envPtr)
goto log;
}
}
+ if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
+
+ if ((tokenPtr->numComponents == 1)
+ && (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
+ /*
+ * The value to be expanded is fully known
+ * now at compile time. We can check list
+ * validity, so we do not have to do so at
+ * runtime
+ */
+ int length;
+ Tcl_Obj *testObj = Tcl_NewStringObj(tokenPtr[1].start,
+ tokenPtr[1].size);
+ if (TCL_OK !=
+ Tcl_ListObjLength(NULL, testObj, &length)) {
+ /*
+ * Not a valid list, so emit instructions to
+ * test list validity (and fail) at runtime
+ */
+ TclEmitOpcode(INST_LIST_VERIFY, envPtr);
+ }
+ } else {
+ /*
+ * Value to expand unknown until runtime, so
+ * include a runtime check for valid list
+ */
+ TclEmitOpcode(INST_LIST_VERIFY, envPtr);
+ }
+ Tcl_DStringAppend(&deltaList, (char *)&delta, 1);
+ delta = 0;
+ }
}
/*
* Emit an invoke instruction for the command. We skip this
* if a compile procedure was found for the command.
*/
-
- if (wordIdx > 0) {
+
+ if (expand) {
+ TclEmitInstInt4(INST_INVOKE_EXP, wordIdx, envPtr);
+ TclEmitImmDeltaList1(&deltaList, envPtr);
+ Tcl_DStringFree(&deltaList);
+ } else if (wordIdx > 0) {
if (wordIdx <= 255) {
TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
} else {
TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
}
- }
+ }
/*
* Update the compilation environment structure and record the
@@ -3146,13 +3218,13 @@ TclPrintInstruction(codePtr, pc)
register InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
unsigned int pcOffset = (pc - codeStart);
- int opnd, i, j;
+ int opnd, i, j, numBytes = 1;
fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
for (i = 0; i < instDesc->numOperands; i++) {
switch (instDesc->opTypes[i]) {
case OPERAND_INT1:
- opnd = TclGetInt1AtPtr(pc+1+i);
+ opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++;
if ((i == 0) && ((opCode == INST_JUMP1)
|| (opCode == INST_JUMP_TRUE1)
|| (opCode == INST_JUMP_FALSE1))) {
@@ -3162,7 +3234,7 @@ TclPrintInstruction(codePtr, pc)
}
break;
case OPERAND_INT4:
- opnd = TclGetInt4AtPtr(pc+1+i);
+ opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
if ((i == 0) && ((opCode == INST_JUMP4)
|| (opCode == INST_JUMP_TRUE4)
|| (opCode == INST_JUMP_FALSE4))) {
@@ -3172,7 +3244,7 @@ TclPrintInstruction(codePtr, pc)
}
break;
case OPERAND_UINT1:
- opnd = TclGetUInt1AtPtr(pc+1+i);
+ opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
if ((i == 0) && (opCode == INST_PUSH1)) {
fprintf(stdout, "%u # ", (unsigned int) opnd);
TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
@@ -3185,7 +3257,6 @@ TclPrintInstruction(codePtr, pc)
if (opnd >= localCt) {
panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
(unsigned int) opnd, localCt);
- return instDesc->numBytes;
}
for (j = 0; j < opnd; j++) {
localPtr = localPtr->nextPtr;
@@ -3202,7 +3273,7 @@ TclPrintInstruction(codePtr, pc)
}
break;
case OPERAND_UINT4:
- opnd = TclGetUInt4AtPtr(pc+1+i);
+ opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
if (opCode == INST_PUSH4) {
fprintf(stdout, "%u # ", opnd);
TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
@@ -3215,7 +3286,6 @@ TclPrintInstruction(codePtr, pc)
if (opnd >= localCt) {
panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
(unsigned int) opnd, localCt);
- return instDesc->numBytes;
}
for (j = 0; j < opnd; j++) {
localPtr = localPtr->nextPtr;
@@ -3231,13 +3301,24 @@ TclPrintInstruction(codePtr, pc)
fprintf(stdout, "%u ", (unsigned int) opnd);
}
break;
+
+ case OPERAND_ULIST1:
+ opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
+ fprintf(stdout, "{");
+ while (opnd) {
+ fprintf(stdout, "%u ", opnd);
+ opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
+ }
+ fprintf(stdout, "0}");
+ break;
+
case OPERAND_NONE:
default:
break;
}
}
fprintf(stdout, "\n");
- return instDesc->numBytes;
+ return numBytes;
}
/*