os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCompCmds.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCompCmds.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,3650 @@
1.4 +/*
1.5 + * tclCompCmds.c --
1.6 + *
1.7 + * This file contains compilation procedures that compile various
1.8 + * Tcl commands into a sequence of instructions ("bytecodes").
1.9 + *
1.10 + * Copyright (c) 1997-1998 Sun Microsystems, Inc.
1.11 + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
1.12 + * Copyright (c) 2002 ActiveState Corporation.
1.13 + *
1.14 + * See the file "license.terms" for information on usage and redistribution
1.15 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 + *
1.17 + * RCS: @(#) $Id: tclCompCmds.c,v 1.39.2.6 2007/03/01 16:06:19 dkf Exp $
1.18 + */
1.19 +
1.20 +#include "tclInt.h"
1.21 +#include "tclCompile.h"
1.22 +
1.23 +/*
1.24 + * Prototypes for procedures defined later in this file:
1.25 + */
1.26 +
1.27 +static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
1.28 +static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData));
1.29 +#ifndef TCL_TIP280
1.30 +static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
1.31 + Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
1.32 + int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr));
1.33 +#else
1.34 +static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
1.35 + Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
1.36 + int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr,
1.37 + int line));
1.38 +#endif
1.39 +
1.40 +/*
1.41 + * Flags bits used by TclPushVarName.
1.42 + */
1.43 +
1.44 +#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */
1.45 +#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */
1.46 +
1.47 +/*
1.48 + * The structures below define the AuxData types defined in this file.
1.49 + */
1.50 +
1.51 +AuxDataType tclForeachInfoType = {
1.52 + "ForeachInfo", /* name */
1.53 + DupForeachInfo, /* dupProc */
1.54 + FreeForeachInfo /* freeProc */
1.55 +};
1.56 +
1.57 +/*
1.58 + *----------------------------------------------------------------------
1.59 + *
1.60 + * TclCompileAppendCmd --
1.61 + *
1.62 + * Procedure called to compile the "append" command.
1.63 + *
1.64 + * Results:
1.65 + * The return value is a standard Tcl result, which is normally TCL_OK
1.66 + * unless there was an error while parsing string. If an error occurs
1.67 + * then the interpreter's result contains a standard error message. If
1.68 + * complation fails because the command requires a second level of
1.69 + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
1.70 + * command should be compiled "out of line" by emitting code to
1.71 + * invoke its command procedure (Tcl_AppendObjCmd) at runtime.
1.72 + *
1.73 + * Side effects:
1.74 + * Instructions are added to envPtr to execute the "append" command
1.75 + * at runtime.
1.76 + *
1.77 + *----------------------------------------------------------------------
1.78 + */
1.79 +
1.80 +int
1.81 +TclCompileAppendCmd(interp, parsePtr, envPtr)
1.82 + Tcl_Interp *interp; /* Used for error reporting. */
1.83 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.84 + * command created by Tcl_ParseCommand. */
1.85 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.86 +{
1.87 + Tcl_Token *varTokenPtr, *valueTokenPtr;
1.88 + int simpleVarName, isScalar, localIndex, numWords;
1.89 + int code = TCL_OK;
1.90 +
1.91 +#ifdef TCL_TIP280
1.92 + /* TIP #280 : Remember the per-word line information of the current
1.93 + * command. An index is used instead of a pointer as recursive compilation
1.94 + * may reallocate, i.e. move, the array. This is also the reason to save
1.95 + * the nuloc now, it may change during the course of the function.
1.96 + */
1.97 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.98 + int eclIndex = mapPtr->nuloc - 1;
1.99 +#endif
1.100 +
1.101 + numWords = parsePtr->numWords;
1.102 + if (numWords == 1) {
1.103 + Tcl_ResetResult(interp);
1.104 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.105 + "wrong # args: should be \"append varName ?value value ...?\"",
1.106 + -1);
1.107 + return TCL_ERROR;
1.108 + } else if (numWords == 2) {
1.109 + /*
1.110 + * append varName === set varName
1.111 + */
1.112 + return TclCompileSetCmd(interp, parsePtr, envPtr);
1.113 + } else if (numWords > 3) {
1.114 + /*
1.115 + * APPEND instructions currently only handle one value
1.116 + */
1.117 + return TCL_OUT_LINE_COMPILE;
1.118 + }
1.119 +
1.120 + /*
1.121 + * Decide if we can use a frame slot for the var/array name or if we
1.122 + * need to emit code to compute and push the name at runtime. We use a
1.123 + * frame slot (entry in the array of local vars) if we are compiling a
1.124 + * procedure body and if the name is simple text that does not include
1.125 + * namespace qualifiers.
1.126 + */
1.127 +
1.128 + varTokenPtr = parsePtr->tokenPtr
1.129 + + (parsePtr->tokenPtr->numComponents + 1);
1.130 +
1.131 + code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
1.132 +#ifndef TCL_TIP280
1.133 + &localIndex, &simpleVarName, &isScalar);
1.134 +#else
1.135 + &localIndex, &simpleVarName, &isScalar,
1.136 + mapPtr->loc [eclIndex].line [1]);
1.137 +#endif
1.138 + if (code != TCL_OK) {
1.139 + goto done;
1.140 + }
1.141 +
1.142 + /*
1.143 + * We are doing an assignment, otherwise TclCompileSetCmd was called,
1.144 + * so push the new value. This will need to be extended to push a
1.145 + * value for each argument.
1.146 + */
1.147 +
1.148 + if (numWords > 2) {
1.149 + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.150 + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.151 + TclEmitPush(TclRegisterNewLiteral(envPtr,
1.152 + valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
1.153 + } else {
1.154 +#ifdef TCL_TIP280
1.155 + envPtr->line = mapPtr->loc [eclIndex].line [2];
1.156 +#endif
1.157 + code = TclCompileTokens(interp, valueTokenPtr+1,
1.158 + valueTokenPtr->numComponents, envPtr);
1.159 + if (code != TCL_OK) {
1.160 + goto done;
1.161 + }
1.162 + }
1.163 + }
1.164 +
1.165 + /*
1.166 + * Emit instructions to set/get the variable.
1.167 + */
1.168 +
1.169 + if (simpleVarName) {
1.170 + if (isScalar) {
1.171 + if (localIndex >= 0) {
1.172 + if (localIndex <= 255) {
1.173 + TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
1.174 + } else {
1.175 + TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
1.176 + }
1.177 + } else {
1.178 + TclEmitOpcode(INST_APPEND_STK, envPtr);
1.179 + }
1.180 + } else {
1.181 + if (localIndex >= 0) {
1.182 + if (localIndex <= 255) {
1.183 + TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
1.184 + } else {
1.185 + TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
1.186 + }
1.187 + } else {
1.188 + TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
1.189 + }
1.190 + }
1.191 + } else {
1.192 + TclEmitOpcode(INST_APPEND_STK, envPtr);
1.193 + }
1.194 +
1.195 + done:
1.196 + return code;
1.197 +}
1.198 +
1.199 +/*
1.200 + *----------------------------------------------------------------------
1.201 + *
1.202 + * TclCompileBreakCmd --
1.203 + *
1.204 + * Procedure called to compile the "break" command.
1.205 + *
1.206 + * Results:
1.207 + * The return value is a standard Tcl result, which is TCL_OK unless
1.208 + * there was an error during compilation. If an error occurs then
1.209 + * the interpreter's result contains a standard error message.
1.210 + *
1.211 + * Side effects:
1.212 + * Instructions are added to envPtr to execute the "break" command
1.213 + * at runtime.
1.214 + *
1.215 + *----------------------------------------------------------------------
1.216 + */
1.217 +
1.218 +int
1.219 +TclCompileBreakCmd(interp, parsePtr, envPtr)
1.220 + Tcl_Interp *interp; /* Used for error reporting. */
1.221 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.222 + * command created by Tcl_ParseCommand. */
1.223 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.224 +{
1.225 + if (parsePtr->numWords != 1) {
1.226 + Tcl_ResetResult(interp);
1.227 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.228 + "wrong # args: should be \"break\"", -1);
1.229 + return TCL_ERROR;
1.230 + }
1.231 +
1.232 + /*
1.233 + * Emit a break instruction.
1.234 + */
1.235 +
1.236 + TclEmitOpcode(INST_BREAK, envPtr);
1.237 + return TCL_OK;
1.238 +}
1.239 +
1.240 +/*
1.241 + *----------------------------------------------------------------------
1.242 + *
1.243 + * TclCompileCatchCmd --
1.244 + *
1.245 + * Procedure called to compile the "catch" command.
1.246 + *
1.247 + * Results:
1.248 + * The return value is a standard Tcl result, which is TCL_OK if
1.249 + * compilation was successful. If an error occurs then the
1.250 + * interpreter's result contains a standard error message and TCL_ERROR
1.251 + * is returned. If the command is too complex for TclCompileCatchCmd,
1.252 + * TCL_OUT_LINE_COMPILE is returned indicating that the catch command
1.253 + * should be compiled "out of line" by emitting code to invoke its
1.254 + * command procedure at runtime.
1.255 + *
1.256 + * Side effects:
1.257 + * Instructions are added to envPtr to execute the "catch" command
1.258 + * at runtime.
1.259 + *
1.260 + *----------------------------------------------------------------------
1.261 + */
1.262 +
1.263 +int
1.264 +TclCompileCatchCmd(interp, parsePtr, envPtr)
1.265 + Tcl_Interp *interp; /* Used for error reporting. */
1.266 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.267 + * command created by Tcl_ParseCommand. */
1.268 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.269 +{
1.270 + JumpFixup jumpFixup;
1.271 + Tcl_Token *cmdTokenPtr, *nameTokenPtr;
1.272 + CONST char *name;
1.273 + int localIndex, nameChars, range, startOffset, jumpDist;
1.274 + int code;
1.275 + int savedStackDepth = envPtr->currStackDepth;
1.276 +
1.277 +#ifdef TCL_TIP280
1.278 + /* TIP #280 : Remember the per-word line information of the current
1.279 + * command. An index is used instead of a pointer as recursive compilation
1.280 + * may reallocate, i.e. move, the array. This is also the reason to save
1.281 + * the nuloc now, it may change during the course of the function.
1.282 + */
1.283 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.284 + int eclIndex = mapPtr->nuloc - 1;
1.285 +#endif
1.286 +
1.287 + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
1.288 + Tcl_ResetResult(interp);
1.289 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.290 + "wrong # args: should be \"catch command ?varName?\"", -1);
1.291 + return TCL_ERROR;
1.292 + }
1.293 +
1.294 + /*
1.295 + * If a variable was specified and the catch command is at global level
1.296 + * (not in a procedure), don't compile it inline: the payoff is
1.297 + * too small.
1.298 + */
1.299 +
1.300 + if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) {
1.301 + return TCL_OUT_LINE_COMPILE;
1.302 + }
1.303 +
1.304 + /*
1.305 + * Make sure the variable name, if any, has no substitutions and just
1.306 + * refers to a local scaler.
1.307 + */
1.308 +
1.309 + localIndex = -1;
1.310 + cmdTokenPtr = parsePtr->tokenPtr
1.311 + + (parsePtr->tokenPtr->numComponents + 1);
1.312 + if (parsePtr->numWords == 3) {
1.313 + nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1);
1.314 + if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.315 + name = nameTokenPtr[1].start;
1.316 + nameChars = nameTokenPtr[1].size;
1.317 + if (!TclIsLocalScalar(name, nameChars)) {
1.318 + return TCL_OUT_LINE_COMPILE;
1.319 + }
1.320 + localIndex = TclFindCompiledLocal(nameTokenPtr[1].start,
1.321 + nameTokenPtr[1].size, /*create*/ 1,
1.322 + /*flags*/ VAR_SCALAR, envPtr->procPtr);
1.323 + } else {
1.324 + return TCL_OUT_LINE_COMPILE;
1.325 + }
1.326 + }
1.327 +
1.328 + /*
1.329 + * We will compile the catch command. Emit a beginCatch instruction at
1.330 + * the start of the catch body: the subcommand it controls.
1.331 + */
1.332 +
1.333 + envPtr->exceptDepth++;
1.334 + envPtr->maxExceptDepth =
1.335 + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
1.336 + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
1.337 + TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
1.338 +
1.339 + /*
1.340 + * If the body is a simple word, compile the instructions to
1.341 + * eval it. Otherwise, compile instructions to substitute its
1.342 + * text without catching, a catch instruction that resets the
1.343 + * stack to what it was before substituting the body, and then
1.344 + * an instruction to eval the body. Care has to be taken to
1.345 + * register the correct startOffset for the catch range so that
1.346 + * errors in the substitution are not catched [Bug 219184]
1.347 + */
1.348 +
1.349 +#ifdef TCL_TIP280
1.350 + envPtr->line = mapPtr->loc [eclIndex].line [1];
1.351 +#endif
1.352 + if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.353 + startOffset = (envPtr->codeNext - envPtr->codeStart);
1.354 + code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr);
1.355 + } else {
1.356 + code = TclCompileTokens(interp, cmdTokenPtr+1,
1.357 + cmdTokenPtr->numComponents, envPtr);
1.358 + startOffset = (envPtr->codeNext - envPtr->codeStart);
1.359 + TclEmitOpcode(INST_EVAL_STK, envPtr);
1.360 + }
1.361 + envPtr->exceptArrayPtr[range].codeOffset = startOffset;
1.362 +
1.363 + if (code != TCL_OK) {
1.364 + code = TCL_OUT_LINE_COMPILE;
1.365 + goto done;
1.366 + }
1.367 + envPtr->exceptArrayPtr[range].numCodeBytes =
1.368 + (envPtr->codeNext - envPtr->codeStart) - startOffset;
1.369 +
1.370 + /*
1.371 + * The "no errors" epilogue code: store the body's result into the
1.372 + * variable (if any), push "0" (TCL_OK) as the catch's "no error"
1.373 + * result, and jump around the "error case" code.
1.374 + */
1.375 +
1.376 + if (localIndex != -1) {
1.377 + if (localIndex <= 255) {
1.378 + TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
1.379 + } else {
1.380 + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
1.381 + }
1.382 + }
1.383 + TclEmitOpcode(INST_POP, envPtr);
1.384 + TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
1.385 + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
1.386 +
1.387 + /*
1.388 + * The "error case" code: store the body's result into the variable (if
1.389 + * any), then push the error result code. The initial PC offset here is
1.390 + * the catch's error target.
1.391 + */
1.392 +
1.393 + envPtr->currStackDepth = savedStackDepth;
1.394 + envPtr->exceptArrayPtr[range].catchOffset =
1.395 + (envPtr->codeNext - envPtr->codeStart);
1.396 + if (localIndex != -1) {
1.397 + TclEmitOpcode(INST_PUSH_RESULT, envPtr);
1.398 + if (localIndex <= 255) {
1.399 + TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
1.400 + } else {
1.401 + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
1.402 + }
1.403 + TclEmitOpcode(INST_POP, envPtr);
1.404 + }
1.405 + TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
1.406 +
1.407 +
1.408 + /*
1.409 + * Update the target of the jump after the "no errors" code, then emit
1.410 + * an endCatch instruction at the end of the catch command.
1.411 + */
1.412 +
1.413 + jumpDist = (envPtr->codeNext - envPtr->codeStart)
1.414 + - jumpFixup.codeOffset;
1.415 + if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
1.416 + panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);
1.417 + }
1.418 + TclEmitOpcode(INST_END_CATCH, envPtr);
1.419 +
1.420 + done:
1.421 + envPtr->currStackDepth = savedStackDepth + 1;
1.422 + envPtr->exceptDepth--;
1.423 + return code;
1.424 +}
1.425 +
1.426 +/*
1.427 + *----------------------------------------------------------------------
1.428 + *
1.429 + * TclCompileContinueCmd --
1.430 + *
1.431 + * Procedure called to compile the "continue" command.
1.432 + *
1.433 + * Results:
1.434 + * The return value is a standard Tcl result, which is TCL_OK unless
1.435 + * there was an error while parsing string. If an error occurs then
1.436 + * the interpreter's result contains a standard error message.
1.437 + *
1.438 + * Side effects:
1.439 + * Instructions are added to envPtr to execute the "continue" command
1.440 + * at runtime.
1.441 + *
1.442 + *----------------------------------------------------------------------
1.443 + */
1.444 +
1.445 +int
1.446 +TclCompileContinueCmd(interp, parsePtr, envPtr)
1.447 + Tcl_Interp *interp; /* Used for error reporting. */
1.448 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.449 + * command created by Tcl_ParseCommand. */
1.450 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.451 +{
1.452 + /*
1.453 + * There should be no argument after the "continue".
1.454 + */
1.455 +
1.456 + if (parsePtr->numWords != 1) {
1.457 + Tcl_ResetResult(interp);
1.458 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.459 + "wrong # args: should be \"continue\"", -1);
1.460 + return TCL_ERROR;
1.461 + }
1.462 +
1.463 + /*
1.464 + * Emit a continue instruction.
1.465 + */
1.466 +
1.467 + TclEmitOpcode(INST_CONTINUE, envPtr);
1.468 + return TCL_OK;
1.469 +}
1.470 +
1.471 +/*
1.472 + *----------------------------------------------------------------------
1.473 + *
1.474 + * TclCompileExprCmd --
1.475 + *
1.476 + * Procedure called to compile the "expr" command.
1.477 + *
1.478 + * Results:
1.479 + * The return value is a standard Tcl result, which is TCL_OK
1.480 + * unless there was an error while parsing string. If an error occurs
1.481 + * then the interpreter's result contains a standard error message.
1.482 + *
1.483 + * Side effects:
1.484 + * Instructions are added to envPtr to execute the "expr" command
1.485 + * at runtime.
1.486 + *
1.487 + *----------------------------------------------------------------------
1.488 + */
1.489 +
1.490 +int
1.491 +TclCompileExprCmd(interp, parsePtr, envPtr)
1.492 + Tcl_Interp *interp; /* Used for error reporting. */
1.493 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.494 + * command created by Tcl_ParseCommand. */
1.495 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.496 +{
1.497 + Tcl_Token *firstWordPtr;
1.498 +
1.499 + if (parsePtr->numWords == 1) {
1.500 + Tcl_ResetResult(interp);
1.501 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.502 + "wrong # args: should be \"expr arg ?arg ...?\"", -1);
1.503 + return TCL_ERROR;
1.504 + }
1.505 +
1.506 +#ifdef TCL_TIP280
1.507 + /* TIP #280 : Use the per-word line information of the current command.
1.508 + */
1.509 + envPtr->line = envPtr->extCmdMapPtr->loc [envPtr->extCmdMapPtr->nuloc - 1].line [1];
1.510 +#endif
1.511 + firstWordPtr = parsePtr->tokenPtr
1.512 + + (parsePtr->tokenPtr->numComponents + 1);
1.513 + return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1),
1.514 + envPtr);
1.515 +}
1.516 +
1.517 +/*
1.518 + *----------------------------------------------------------------------
1.519 + *
1.520 + * TclCompileForCmd --
1.521 + *
1.522 + * Procedure called to compile the "for" command.
1.523 + *
1.524 + * Results:
1.525 + * The return value is a standard Tcl result, which is TCL_OK unless
1.526 + * there was an error while parsing string. If an error occurs then
1.527 + * the interpreter's result contains a standard error message.
1.528 + *
1.529 + * Side effects:
1.530 + * Instructions are added to envPtr to execute the "for" command
1.531 + * at runtime.
1.532 + *
1.533 + *----------------------------------------------------------------------
1.534 + */
1.535 +int
1.536 +TclCompileForCmd(interp, parsePtr, envPtr)
1.537 + Tcl_Interp *interp; /* Used for error reporting. */
1.538 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.539 + * command created by Tcl_ParseCommand. */
1.540 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.541 +{
1.542 + Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
1.543 + JumpFixup jumpEvalCondFixup;
1.544 + int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
1.545 + int bodyRange, nextRange, code;
1.546 + char buffer[32 + TCL_INTEGER_SPACE];
1.547 + int savedStackDepth = envPtr->currStackDepth;
1.548 +
1.549 +#ifdef TCL_TIP280
1.550 + /* TIP #280 : Remember the per-word line information of the current
1.551 + * command. An index is used instead of a pointer as recursive compilation
1.552 + * may reallocate, i.e. move, the array. This is also the reason to save
1.553 + * the nuloc now, it may change during the course of the function.
1.554 + */
1.555 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.556 + int eclIndex = mapPtr->nuloc - 1;
1.557 +#endif
1.558 +
1.559 + if (parsePtr->numWords != 5) {
1.560 + Tcl_ResetResult(interp);
1.561 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.562 + "wrong # args: should be \"for start test next command\"", -1);
1.563 + return TCL_ERROR;
1.564 + }
1.565 +
1.566 + /*
1.567 + * If the test expression requires substitutions, don't compile the for
1.568 + * command inline. E.g., the expression might cause the loop to never
1.569 + * execute or execute forever, as in "for {} "$x > 5" {incr x} {}".
1.570 + */
1.571 +
1.572 + startTokenPtr = parsePtr->tokenPtr
1.573 + + (parsePtr->tokenPtr->numComponents + 1);
1.574 + testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1);
1.575 + if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1.576 + return TCL_OUT_LINE_COMPILE;
1.577 + }
1.578 +
1.579 + /*
1.580 + * Bail out also if the body or the next expression require substitutions
1.581 + * in order to insure correct behaviour [Bug 219166]
1.582 + */
1.583 +
1.584 + nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
1.585 + bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1);
1.586 + if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
1.587 + || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
1.588 + return TCL_OUT_LINE_COMPILE;
1.589 + }
1.590 +
1.591 + /*
1.592 + * Create ExceptionRange records for the body and the "next" command.
1.593 + * The "next" command's ExceptionRange supports break but not continue
1.594 + * (and has a -1 continueOffset).
1.595 + */
1.596 +
1.597 + envPtr->exceptDepth++;
1.598 + envPtr->maxExceptDepth =
1.599 + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
1.600 + bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
1.601 + nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
1.602 +
1.603 + /*
1.604 + * Inline compile the initial command.
1.605 + */
1.606 +
1.607 +#ifdef TCL_TIP280
1.608 + envPtr->line = mapPtr->loc [eclIndex].line [1];
1.609 +#endif
1.610 + code = TclCompileCmdWord(interp, startTokenPtr+1,
1.611 + startTokenPtr->numComponents, envPtr);
1.612 + if (code != TCL_OK) {
1.613 + if (code == TCL_ERROR) {
1.614 + Tcl_AddObjErrorInfo(interp,
1.615 + "\n (\"for\" initial command)", -1);
1.616 + }
1.617 + goto done;
1.618 + }
1.619 + TclEmitOpcode(INST_POP, envPtr);
1.620 +
1.621 + /*
1.622 + * Jump to the evaluation of the condition. This code uses the "loop
1.623 + * rotation" optimisation (which eliminates one branch from the loop).
1.624 + * "for start cond next body" produces then:
1.625 + * start
1.626 + * goto A
1.627 + * B: body : bodyCodeOffset
1.628 + * next : nextCodeOffset, continueOffset
1.629 + * A: cond -> result : testCodeOffset
1.630 + * if (result) goto B
1.631 + */
1.632 +
1.633 + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
1.634 +
1.635 + /*
1.636 + * Compile the loop body.
1.637 + */
1.638 +
1.639 + bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
1.640 +
1.641 +#ifdef TCL_TIP280
1.642 + envPtr->line = mapPtr->loc [eclIndex].line [4];
1.643 +#endif
1.644 + code = TclCompileCmdWord(interp, bodyTokenPtr+1,
1.645 + bodyTokenPtr->numComponents, envPtr);
1.646 + envPtr->currStackDepth = savedStackDepth + 1;
1.647 + if (code != TCL_OK) {
1.648 + if (code == TCL_ERROR) {
1.649 + sprintf(buffer, "\n (\"for\" body line %d)",
1.650 + interp->errorLine);
1.651 + Tcl_AddObjErrorInfo(interp, buffer, -1);
1.652 + }
1.653 + goto done;
1.654 + }
1.655 + envPtr->exceptArrayPtr[bodyRange].numCodeBytes =
1.656 + (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
1.657 + TclEmitOpcode(INST_POP, envPtr);
1.658 +
1.659 +
1.660 + /*
1.661 + * Compile the "next" subcommand.
1.662 + */
1.663 +
1.664 + nextCodeOffset = (envPtr->codeNext - envPtr->codeStart);
1.665 +
1.666 +#ifdef TCL_TIP280
1.667 + envPtr->line = mapPtr->loc [eclIndex].line [3];
1.668 +#endif
1.669 + envPtr->currStackDepth = savedStackDepth;
1.670 + code = TclCompileCmdWord(interp, nextTokenPtr+1,
1.671 + nextTokenPtr->numComponents, envPtr);
1.672 + envPtr->currStackDepth = savedStackDepth + 1;
1.673 + if (code != TCL_OK) {
1.674 + if (code == TCL_ERROR) {
1.675 + Tcl_AddObjErrorInfo(interp,
1.676 + "\n (\"for\" loop-end command)", -1);
1.677 + }
1.678 + goto done;
1.679 + }
1.680 + envPtr->exceptArrayPtr[nextRange].numCodeBytes =
1.681 + (envPtr->codeNext - envPtr->codeStart)
1.682 + - nextCodeOffset;
1.683 + TclEmitOpcode(INST_POP, envPtr);
1.684 + envPtr->currStackDepth = savedStackDepth;
1.685 +
1.686 + /*
1.687 + * Compile the test expression then emit the conditional jump that
1.688 + * terminates the for.
1.689 + */
1.690 +
1.691 + testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
1.692 +
1.693 + jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
1.694 + if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
1.695 + bodyCodeOffset += 3;
1.696 + nextCodeOffset += 3;
1.697 + testCodeOffset += 3;
1.698 + }
1.699 +#ifdef TCL_TIP280
1.700 + envPtr->line = mapPtr->loc [eclIndex].line [2];
1.701 +#endif
1.702 + envPtr->currStackDepth = savedStackDepth;
1.703 + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
1.704 + if (code != TCL_OK) {
1.705 + if (code == TCL_ERROR) {
1.706 + Tcl_AddObjErrorInfo(interp,
1.707 + "\n (\"for\" test expression)", -1);
1.708 + }
1.709 + goto done;
1.710 + }
1.711 + envPtr->currStackDepth = savedStackDepth + 1;
1.712 +
1.713 + jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
1.714 + if (jumpDist > 127) {
1.715 + TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
1.716 + } else {
1.717 + TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
1.718 + }
1.719 +
1.720 + /*
1.721 + * Set the loop's offsets and break target.
1.722 + */
1.723 +
1.724 + envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset;
1.725 + envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset;
1.726 +
1.727 + envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset;
1.728 +
1.729 + envPtr->exceptArrayPtr[bodyRange].breakOffset =
1.730 + envPtr->exceptArrayPtr[nextRange].breakOffset =
1.731 + (envPtr->codeNext - envPtr->codeStart);
1.732 +
1.733 + /*
1.734 + * The for command's result is an empty string.
1.735 + */
1.736 +
1.737 + envPtr->currStackDepth = savedStackDepth;
1.738 + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
1.739 + code = TCL_OK;
1.740 +
1.741 + done:
1.742 + envPtr->exceptDepth--;
1.743 + return code;
1.744 +}
1.745 +
1.746 +/*
1.747 + *----------------------------------------------------------------------
1.748 + *
1.749 + * TclCompileForeachCmd --
1.750 + *
1.751 + * Procedure called to compile the "foreach" command.
1.752 + *
1.753 + * Results:
1.754 + * The return value is a standard Tcl result, which is TCL_OK if
1.755 + * compilation was successful. If an error occurs then the
1.756 + * interpreter's result contains a standard error message and TCL_ERROR
1.757 + * is returned. If the command is too complex for TclCompileForeachCmd,
1.758 + * TCL_OUT_LINE_COMPILE is returned indicating that the foreach command
1.759 + * should be compiled "out of line" by emitting code to invoke its
1.760 + * command procedure at runtime.
1.761 + *
1.762 + * Side effects:
1.763 + * Instructions are added to envPtr to execute the "foreach" command
1.764 + * at runtime.
1.765 + *
1.766 +n*----------------------------------------------------------------------
1.767 + */
1.768 +
1.769 +int
1.770 +TclCompileForeachCmd(interp, parsePtr, envPtr)
1.771 + Tcl_Interp *interp; /* Used for error reporting. */
1.772 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.773 + * command created by Tcl_ParseCommand. */
1.774 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.775 +{
1.776 + Proc *procPtr = envPtr->procPtr;
1.777 + ForeachInfo *infoPtr; /* Points to the structure describing this
1.778 + * foreach command. Stored in a AuxData
1.779 + * record in the ByteCode. */
1.780 + int firstValueTemp; /* Index of the first temp var in the frame
1.781 + * used to point to a value list. */
1.782 + int loopCtTemp; /* Index of temp var holding the loop's
1.783 + * iteration count. */
1.784 + Tcl_Token *tokenPtr, *bodyTokenPtr;
1.785 + unsigned char *jumpPc;
1.786 + JumpFixup jumpFalseFixup;
1.787 + int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range;
1.788 + int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
1.789 + char buffer[32 + TCL_INTEGER_SPACE];
1.790 + int savedStackDepth = envPtr->currStackDepth;
1.791 +
1.792 +#ifdef TCL_TIP280
1.793 + /* TIP #280 : Remember the per-word line information of the current
1.794 + * command. An index is used instead of a pointer as recursive compilation
1.795 + * may reallocate, i.e. move, the array. This is also the reason to save
1.796 + * the nuloc now, it may change during the course of the function.
1.797 + */
1.798 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.799 + int eclIndex = mapPtr->nuloc - 1;
1.800 + int bodyIndex;
1.801 +#endif
1.802 +
1.803 + /*
1.804 + * We parse the variable list argument words and create two arrays:
1.805 + * varcList[i] is number of variables in i-th var list
1.806 + * varvList[i] points to array of var names in i-th var list
1.807 + */
1.808 +
1.809 +#define STATIC_VAR_LIST_SIZE 5
1.810 + int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
1.811 + CONST char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
1.812 + int *varcList = varcListStaticSpace;
1.813 + CONST char ***varvList = varvListStaticSpace;
1.814 +
1.815 + /*
1.816 + * If the foreach command isn't in a procedure, don't compile it inline:
1.817 + * the payoff is too small.
1.818 + */
1.819 +
1.820 + if (procPtr == NULL) {
1.821 + return TCL_OUT_LINE_COMPILE;
1.822 + }
1.823 +
1.824 + numWords = parsePtr->numWords;
1.825 + if ((numWords < 4) || (numWords%2 != 0)) {
1.826 + Tcl_ResetResult(interp);
1.827 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.828 + "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);
1.829 + return TCL_ERROR;
1.830 + }
1.831 +
1.832 + /*
1.833 + * Bail out if the body requires substitutions
1.834 + * in order to insure correct behaviour [Bug 219166]
1.835 + */
1.836 + for (i = 0, tokenPtr = parsePtr->tokenPtr;
1.837 + i < numWords-1;
1.838 + i++, tokenPtr += (tokenPtr->numComponents + 1)) {
1.839 + }
1.840 + bodyTokenPtr = tokenPtr;
1.841 + if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1.842 + return TCL_OUT_LINE_COMPILE;
1.843 + }
1.844 +#ifdef TCL_TIP280
1.845 + bodyIndex = i-1;
1.846 +#endif
1.847 +
1.848 + /*
1.849 + * Allocate storage for the varcList and varvList arrays if necessary.
1.850 + */
1.851 +
1.852 + numLists = (numWords - 2)/2;
1.853 + if (numLists > STATIC_VAR_LIST_SIZE) {
1.854 + varcList = (int *) ckalloc(numLists * sizeof(int));
1.855 + varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **));
1.856 + }
1.857 + for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
1.858 + varcList[loopIndex] = 0;
1.859 + varvList[loopIndex] = NULL;
1.860 + }
1.861 +
1.862 + /*
1.863 + * Set the exception stack depth.
1.864 + */
1.865 +
1.866 + envPtr->exceptDepth++;
1.867 + envPtr->maxExceptDepth =
1.868 + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
1.869 +
1.870 + /*
1.871 + * Break up each var list and set the varcList and varvList arrays.
1.872 + * Don't compile the foreach inline if any var name needs substitutions
1.873 + * or isn't a scalar, or if any var list needs substitutions.
1.874 + */
1.875 +
1.876 + loopIndex = 0;
1.877 + for (i = 0, tokenPtr = parsePtr->tokenPtr;
1.878 + i < numWords-1;
1.879 + i++, tokenPtr += (tokenPtr->numComponents + 1)) {
1.880 + if (i%2 == 1) {
1.881 + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1.882 + code = TCL_OUT_LINE_COMPILE;
1.883 + goto done;
1.884 + } else {
1.885 + /* Lots of copying going on here. Need a ListObj wizard
1.886 + * to show a better way. */
1.887 +
1.888 + Tcl_DString varList;
1.889 +
1.890 + Tcl_DStringInit(&varList);
1.891 + Tcl_DStringAppend(&varList, tokenPtr[1].start,
1.892 + tokenPtr[1].size);
1.893 + code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
1.894 + &varcList[loopIndex], &varvList[loopIndex]);
1.895 + Tcl_DStringFree(&varList);
1.896 + if (code != TCL_OK) {
1.897 + goto done;
1.898 + }
1.899 + numVars = varcList[loopIndex];
1.900 +
1.901 + /*
1.902 + * If the variable list is empty, we can enter an infinite
1.903 + * loop when the interpreted version would not. Take care to
1.904 + * ensure this does not happen. [Bug 1671138]
1.905 + */
1.906 +
1.907 + if (numVars == 0) {
1.908 + code = TCL_OUT_LINE_COMPILE;
1.909 + goto done;
1.910 + }
1.911 +
1.912 + for (j = 0; j < numVars; j++) {
1.913 + CONST char *varName = varvList[loopIndex][j];
1.914 + if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
1.915 + code = TCL_OUT_LINE_COMPILE;
1.916 + goto done;
1.917 + }
1.918 + }
1.919 + }
1.920 + loopIndex++;
1.921 + }
1.922 + }
1.923 +
1.924 + /*
1.925 + * We will compile the foreach command.
1.926 + * Reserve (numLists + 1) temporary variables:
1.927 + * - numLists temps to hold each value list
1.928 + * - 1 temp for the loop counter (index of next element in each list)
1.929 + * At this time we don't try to reuse temporaries; if there are two
1.930 + * nonoverlapping foreach loops, they don't share any temps.
1.931 + */
1.932 +
1.933 + firstValueTemp = -1;
1.934 + for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
1.935 + tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
1.936 + /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
1.937 + if (loopIndex == 0) {
1.938 + firstValueTemp = tempVar;
1.939 + }
1.940 + }
1.941 + loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
1.942 + /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
1.943 +
1.944 + /*
1.945 + * Create and initialize the ForeachInfo and ForeachVarList data
1.946 + * structures describing this command. Then create a AuxData record
1.947 + * pointing to the ForeachInfo structure.
1.948 + */
1.949 +
1.950 + infoPtr = (ForeachInfo *) ckalloc((unsigned)
1.951 + (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
1.952 + infoPtr->numLists = numLists;
1.953 + infoPtr->firstValueTemp = firstValueTemp;
1.954 + infoPtr->loopCtTemp = loopCtTemp;
1.955 + for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
1.956 + ForeachVarList *varListPtr;
1.957 + numVars = varcList[loopIndex];
1.958 + varListPtr = (ForeachVarList *) ckalloc((unsigned)
1.959 + sizeof(ForeachVarList) + (numVars * sizeof(int)));
1.960 + varListPtr->numVars = numVars;
1.961 + for (j = 0; j < numVars; j++) {
1.962 + CONST char *varName = varvList[loopIndex][j];
1.963 + int nameChars = strlen(varName);
1.964 + varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
1.965 + nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
1.966 + }
1.967 + infoPtr->varLists[loopIndex] = varListPtr;
1.968 + }
1.969 + infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr);
1.970 +
1.971 + /*
1.972 + * Evaluate then store each value list in the associated temporary.
1.973 + */
1.974 +
1.975 + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
1.976 +
1.977 + loopIndex = 0;
1.978 + for (i = 0, tokenPtr = parsePtr->tokenPtr;
1.979 + i < numWords-1;
1.980 + i++, tokenPtr += (tokenPtr->numComponents + 1)) {
1.981 + if ((i%2 == 0) && (i > 0)) {
1.982 +#ifdef TCL_TIP280
1.983 + envPtr->line = mapPtr->loc [eclIndex].line [i];
1.984 +#endif
1.985 + code = TclCompileTokens(interp, tokenPtr+1,
1.986 + tokenPtr->numComponents, envPtr);
1.987 + if (code != TCL_OK) {
1.988 + goto done;
1.989 + }
1.990 +
1.991 + tempVar = (firstValueTemp + loopIndex);
1.992 + if (tempVar <= 255) {
1.993 + TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
1.994 + } else {
1.995 + TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
1.996 + }
1.997 + TclEmitOpcode(INST_POP, envPtr);
1.998 + loopIndex++;
1.999 + }
1.1000 + }
1.1001 +
1.1002 + /*
1.1003 + * Initialize the temporary var that holds the count of loop iterations.
1.1004 + */
1.1005 +
1.1006 + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
1.1007 +
1.1008 + /*
1.1009 + * Top of loop code: assign each loop variable and check whether
1.1010 + * to terminate the loop.
1.1011 + */
1.1012 +
1.1013 + envPtr->exceptArrayPtr[range].continueOffset =
1.1014 + (envPtr->codeNext - envPtr->codeStart);
1.1015 + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
1.1016 + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
1.1017 +
1.1018 + /*
1.1019 + * Inline compile the loop body.
1.1020 + */
1.1021 +
1.1022 +#ifdef TCL_TIP280
1.1023 + envPtr->line = mapPtr->loc [eclIndex].line [bodyIndex];
1.1024 +#endif
1.1025 + envPtr->exceptArrayPtr[range].codeOffset =
1.1026 + (envPtr->codeNext - envPtr->codeStart);
1.1027 + code = TclCompileCmdWord(interp, bodyTokenPtr+1,
1.1028 + bodyTokenPtr->numComponents, envPtr);
1.1029 + envPtr->currStackDepth = savedStackDepth + 1;
1.1030 + if (code != TCL_OK) {
1.1031 + if (code == TCL_ERROR) {
1.1032 + sprintf(buffer, "\n (\"foreach\" body line %d)",
1.1033 + interp->errorLine);
1.1034 + Tcl_AddObjErrorInfo(interp, buffer, -1);
1.1035 + }
1.1036 + goto done;
1.1037 + }
1.1038 + envPtr->exceptArrayPtr[range].numCodeBytes =
1.1039 + (envPtr->codeNext - envPtr->codeStart)
1.1040 + - envPtr->exceptArrayPtr[range].codeOffset;
1.1041 + TclEmitOpcode(INST_POP, envPtr);
1.1042 +
1.1043 + /*
1.1044 + * Jump back to the test at the top of the loop. Generate a 4 byte jump
1.1045 + * if the distance to the test is > 120 bytes. This is conservative and
1.1046 + * ensures that we won't have to replace this jump if we later need to
1.1047 + * replace the ifFalse jump with a 4 byte jump.
1.1048 + */
1.1049 +
1.1050 + jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
1.1051 + jumpBackDist =
1.1052 + (jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset);
1.1053 + if (jumpBackDist > 120) {
1.1054 + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
1.1055 + } else {
1.1056 + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
1.1057 + }
1.1058 +
1.1059 + /*
1.1060 + * Fix the target of the jump after the foreach_step test.
1.1061 + */
1.1062 +
1.1063 + jumpDist = (envPtr->codeNext - envPtr->codeStart)
1.1064 + - jumpFalseFixup.codeOffset;
1.1065 + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
1.1066 + /*
1.1067 + * Update the loop body's starting PC offset since it moved down.
1.1068 + */
1.1069 +
1.1070 + envPtr->exceptArrayPtr[range].codeOffset += 3;
1.1071 +
1.1072 + /*
1.1073 + * Update the jump back to the test at the top of the loop since it
1.1074 + * also moved down 3 bytes.
1.1075 + */
1.1076 +
1.1077 + jumpBackOffset += 3;
1.1078 + jumpPc = (envPtr->codeStart + jumpBackOffset);
1.1079 + jumpBackDist += 3;
1.1080 + if (jumpBackDist > 120) {
1.1081 + TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
1.1082 + } else {
1.1083 + TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
1.1084 + }
1.1085 + }
1.1086 +
1.1087 + /*
1.1088 + * Set the loop's break target.
1.1089 + */
1.1090 +
1.1091 + envPtr->exceptArrayPtr[range].breakOffset =
1.1092 + (envPtr->codeNext - envPtr->codeStart);
1.1093 +
1.1094 + /*
1.1095 + * The foreach command's result is an empty string.
1.1096 + */
1.1097 +
1.1098 + envPtr->currStackDepth = savedStackDepth;
1.1099 + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
1.1100 + envPtr->currStackDepth = savedStackDepth + 1;
1.1101 +
1.1102 + done:
1.1103 + for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
1.1104 + if (varvList[loopIndex] != (CONST char **) NULL) {
1.1105 + ckfree((char *) varvList[loopIndex]);
1.1106 + }
1.1107 + }
1.1108 + if (varcList != varcListStaticSpace) {
1.1109 + ckfree((char *) varcList);
1.1110 + ckfree((char *) varvList);
1.1111 + }
1.1112 + envPtr->exceptDepth--;
1.1113 + return code;
1.1114 +}
1.1115 +
1.1116 +/*
1.1117 + *----------------------------------------------------------------------
1.1118 + *
1.1119 + * DupForeachInfo --
1.1120 + *
1.1121 + * This procedure duplicates a ForeachInfo structure created as
1.1122 + * auxiliary data during the compilation of a foreach command.
1.1123 + *
1.1124 + * Results:
1.1125 + * A pointer to a newly allocated copy of the existing ForeachInfo
1.1126 + * structure is returned.
1.1127 + *
1.1128 + * Side effects:
1.1129 + * Storage for the copied ForeachInfo record is allocated. If the
1.1130 + * original ForeachInfo structure pointed to any ForeachVarList
1.1131 + * records, these structures are also copied and pointers to them
1.1132 + * are stored in the new ForeachInfo record.
1.1133 + *
1.1134 + *----------------------------------------------------------------------
1.1135 + */
1.1136 +
1.1137 +static ClientData
1.1138 +DupForeachInfo(clientData)
1.1139 + ClientData clientData; /* The foreach command's compilation
1.1140 + * auxiliary data to duplicate. */
1.1141 +{
1.1142 + register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
1.1143 + ForeachInfo *dupPtr;
1.1144 + register ForeachVarList *srcListPtr, *dupListPtr;
1.1145 + int numLists = srcPtr->numLists;
1.1146 + int numVars, i, j;
1.1147 +
1.1148 + dupPtr = (ForeachInfo *) ckalloc((unsigned)
1.1149 + (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
1.1150 + dupPtr->numLists = numLists;
1.1151 + dupPtr->firstValueTemp = srcPtr->firstValueTemp;
1.1152 + dupPtr->loopCtTemp = srcPtr->loopCtTemp;
1.1153 +
1.1154 + for (i = 0; i < numLists; i++) {
1.1155 + srcListPtr = srcPtr->varLists[i];
1.1156 + numVars = srcListPtr->numVars;
1.1157 + dupListPtr = (ForeachVarList *) ckalloc((unsigned)
1.1158 + sizeof(ForeachVarList) + numVars*sizeof(int));
1.1159 + dupListPtr->numVars = numVars;
1.1160 + for (j = 0; j < numVars; j++) {
1.1161 + dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
1.1162 + }
1.1163 + dupPtr->varLists[i] = dupListPtr;
1.1164 + }
1.1165 + return (ClientData) dupPtr;
1.1166 +}
1.1167 +
1.1168 +/*
1.1169 + *----------------------------------------------------------------------
1.1170 + *
1.1171 + * FreeForeachInfo --
1.1172 + *
1.1173 + * Procedure to free a ForeachInfo structure created as auxiliary data
1.1174 + * during the compilation of a foreach command.
1.1175 + *
1.1176 + * Results:
1.1177 + * None.
1.1178 + *
1.1179 + * Side effects:
1.1180 + * Storage for the ForeachInfo structure pointed to by the ClientData
1.1181 + * argument is freed as is any ForeachVarList record pointed to by the
1.1182 + * ForeachInfo structure.
1.1183 + *
1.1184 + *----------------------------------------------------------------------
1.1185 + */
1.1186 +
1.1187 +static void
1.1188 +FreeForeachInfo(clientData)
1.1189 + ClientData clientData; /* The foreach command's compilation
1.1190 + * auxiliary data to free. */
1.1191 +{
1.1192 + register ForeachInfo *infoPtr = (ForeachInfo *) clientData;
1.1193 + register ForeachVarList *listPtr;
1.1194 + int numLists = infoPtr->numLists;
1.1195 + register int i;
1.1196 +
1.1197 + for (i = 0; i < numLists; i++) {
1.1198 + listPtr = infoPtr->varLists[i];
1.1199 + ckfree((char *) listPtr);
1.1200 + }
1.1201 + ckfree((char *) infoPtr);
1.1202 +}
1.1203 +
1.1204 +/*
1.1205 + *----------------------------------------------------------------------
1.1206 + *
1.1207 + * TclCompileIfCmd --
1.1208 + *
1.1209 + * Procedure called to compile the "if" command.
1.1210 + *
1.1211 + * Results:
1.1212 + * The return value is a standard Tcl result, which is TCL_OK if
1.1213 + * compilation was successful. If an error occurs then the
1.1214 + * interpreter's result contains a standard error message and TCL_ERROR
1.1215 + * is returned. If the command is too complex for TclCompileIfCmd,
1.1216 + * TCL_OUT_LINE_COMPILE is returned indicating that the if command
1.1217 + * should be compiled "out of line" by emitting code to invoke its
1.1218 + * command procedure at runtime.
1.1219 + *
1.1220 + * Side effects:
1.1221 + * Instructions are added to envPtr to execute the "if" command
1.1222 + * at runtime.
1.1223 + *
1.1224 + *----------------------------------------------------------------------
1.1225 + */
1.1226 +int
1.1227 +TclCompileIfCmd(interp, parsePtr, envPtr)
1.1228 + Tcl_Interp *interp; /* Used for error reporting. */
1.1229 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.1230 + * command created by Tcl_ParseCommand. */
1.1231 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.1232 +{
1.1233 + JumpFixupArray jumpFalseFixupArray;
1.1234 + /* Used to fix the ifFalse jump after each
1.1235 + * test when its target PC is determined. */
1.1236 + JumpFixupArray jumpEndFixupArray;
1.1237 + /* Used to fix the jump after each "then"
1.1238 + * body to the end of the "if" when that PC
1.1239 + * is determined. */
1.1240 + Tcl_Token *tokenPtr, *testTokenPtr;
1.1241 + int jumpDist, jumpFalseDist;
1.1242 + int jumpIndex = 0; /* avoid compiler warning. */
1.1243 + int numWords, wordIdx, numBytes, j, code;
1.1244 + CONST char *word;
1.1245 + char buffer[100];
1.1246 + int savedStackDepth = envPtr->currStackDepth;
1.1247 + /* Saved stack depth at the start of the first
1.1248 + * test; the envPtr current depth is restored
1.1249 + * to this value at the start of each test. */
1.1250 + int realCond = 1; /* set to 0 for static conditions: "if 0 {..}" */
1.1251 + int boolVal; /* value of static condition */
1.1252 + int compileScripts = 1;
1.1253 +
1.1254 +#ifdef TCL_TIP280
1.1255 + /* TIP #280 : Remember the per-word line information of the current
1.1256 + * command. An index is used instead of a pointer as recursive compilation
1.1257 + * may reallocate, i.e. move, the array. This is also the reason to save
1.1258 + * the nuloc now, it may change during the course of the function.
1.1259 + */
1.1260 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.1261 + int eclIndex = mapPtr->nuloc - 1;
1.1262 +#endif
1.1263 +
1.1264 + /*
1.1265 + * Only compile the "if" command if all arguments are simple
1.1266 + * words, in order to insure correct substitution [Bug 219166]
1.1267 + */
1.1268 +
1.1269 + tokenPtr = parsePtr->tokenPtr;
1.1270 + wordIdx = 0;
1.1271 + numWords = parsePtr->numWords;
1.1272 +
1.1273 + for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
1.1274 + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1.1275 + return TCL_OUT_LINE_COMPILE;
1.1276 + }
1.1277 + tokenPtr += 2;
1.1278 + }
1.1279 +
1.1280 +
1.1281 + TclInitJumpFixupArray(&jumpFalseFixupArray);
1.1282 + TclInitJumpFixupArray(&jumpEndFixupArray);
1.1283 + code = TCL_OK;
1.1284 +
1.1285 + /*
1.1286 + * Each iteration of this loop compiles one "if expr ?then? body"
1.1287 + * or "elseif expr ?then? body" clause.
1.1288 + */
1.1289 +
1.1290 + tokenPtr = parsePtr->tokenPtr;
1.1291 + wordIdx = 0;
1.1292 + while (wordIdx < numWords) {
1.1293 + /*
1.1294 + * Stop looping if the token isn't "if" or "elseif".
1.1295 + */
1.1296 +
1.1297 + word = tokenPtr[1].start;
1.1298 + numBytes = tokenPtr[1].size;
1.1299 + if ((tokenPtr == parsePtr->tokenPtr)
1.1300 + || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
1.1301 + tokenPtr += (tokenPtr->numComponents + 1);
1.1302 + wordIdx++;
1.1303 + } else {
1.1304 + break;
1.1305 + }
1.1306 + if (wordIdx >= numWords) {
1.1307 + sprintf(buffer,
1.1308 + "wrong # args: no expression after \"%.*s\" argument",
1.1309 + (numBytes > 50 ? 50 : numBytes), word);
1.1310 + Tcl_ResetResult(interp);
1.1311 + Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
1.1312 + code = TCL_ERROR;
1.1313 + goto done;
1.1314 + }
1.1315 +
1.1316 + /*
1.1317 + * Compile the test expression then emit the conditional jump
1.1318 + * around the "then" part.
1.1319 + */
1.1320 +
1.1321 + envPtr->currStackDepth = savedStackDepth;
1.1322 + testTokenPtr = tokenPtr;
1.1323 +
1.1324 +
1.1325 + if (realCond) {
1.1326 + /*
1.1327 + * Find out if the condition is a constant.
1.1328 + */
1.1329 +
1.1330 + Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
1.1331 + testTokenPtr[1].size);
1.1332 + Tcl_IncrRefCount(boolObj);
1.1333 + code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
1.1334 + Tcl_DecrRefCount(boolObj);
1.1335 + if (code == TCL_OK) {
1.1336 + /*
1.1337 + * A static condition
1.1338 + */
1.1339 + realCond = 0;
1.1340 + if (!boolVal) {
1.1341 + compileScripts = 0;
1.1342 + }
1.1343 + } else {
1.1344 + Tcl_ResetResult(interp);
1.1345 +#ifdef TCL_TIP280
1.1346 + envPtr->line = mapPtr->loc [eclIndex].line [wordIdx];
1.1347 +#endif
1.1348 + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
1.1349 + if (code != TCL_OK) {
1.1350 + if (code == TCL_ERROR) {
1.1351 + Tcl_AddObjErrorInfo(interp,
1.1352 + "\n (\"if\" test expression)", -1);
1.1353 + }
1.1354 + goto done;
1.1355 + }
1.1356 + if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
1.1357 + TclExpandJumpFixupArray(&jumpFalseFixupArray);
1.1358 + }
1.1359 + jumpIndex = jumpFalseFixupArray.next;
1.1360 + jumpFalseFixupArray.next++;
1.1361 + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
1.1362 + &(jumpFalseFixupArray.fixup[jumpIndex]));
1.1363 + }
1.1364 + }
1.1365 +
1.1366 +
1.1367 + /*
1.1368 + * Skip over the optional "then" before the then clause.
1.1369 + */
1.1370 +
1.1371 + tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
1.1372 + wordIdx++;
1.1373 + if (wordIdx >= numWords) {
1.1374 + sprintf(buffer,
1.1375 + "wrong # args: no script following \"%.*s\" argument",
1.1376 + (testTokenPtr->size > 50 ? 50 : testTokenPtr->size),
1.1377 + testTokenPtr->start);
1.1378 + Tcl_ResetResult(interp);
1.1379 + Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
1.1380 + code = TCL_ERROR;
1.1381 + goto done;
1.1382 + }
1.1383 + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.1384 + word = tokenPtr[1].start;
1.1385 + numBytes = tokenPtr[1].size;
1.1386 + if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
1.1387 + tokenPtr += (tokenPtr->numComponents + 1);
1.1388 + wordIdx++;
1.1389 + if (wordIdx >= numWords) {
1.1390 + Tcl_ResetResult(interp);
1.1391 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.1392 + "wrong # args: no script following \"then\" argument", -1);
1.1393 + code = TCL_ERROR;
1.1394 + goto done;
1.1395 + }
1.1396 + }
1.1397 + }
1.1398 +
1.1399 + /*
1.1400 + * Compile the "then" command body.
1.1401 + */
1.1402 +
1.1403 + if (compileScripts) {
1.1404 +#ifdef TCL_TIP280
1.1405 + envPtr->line = mapPtr->loc [eclIndex].line [wordIdx];
1.1406 +#endif
1.1407 + envPtr->currStackDepth = savedStackDepth;
1.1408 + code = TclCompileCmdWord(interp, tokenPtr+1,
1.1409 + tokenPtr->numComponents, envPtr);
1.1410 + if (code != TCL_OK) {
1.1411 + if (code == TCL_ERROR) {
1.1412 + sprintf(buffer, "\n (\"if\" then script line %d)",
1.1413 + interp->errorLine);
1.1414 + Tcl_AddObjErrorInfo(interp, buffer, -1);
1.1415 + }
1.1416 + goto done;
1.1417 + }
1.1418 + }
1.1419 +
1.1420 + if (realCond) {
1.1421 + /*
1.1422 + * Jump to the end of the "if" command. Both jumpFalseFixupArray and
1.1423 + * jumpEndFixupArray are indexed by "jumpIndex".
1.1424 + */
1.1425 +
1.1426 + if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
1.1427 + TclExpandJumpFixupArray(&jumpEndFixupArray);
1.1428 + }
1.1429 + jumpEndFixupArray.next++;
1.1430 + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
1.1431 + &(jumpEndFixupArray.fixup[jumpIndex]));
1.1432 +
1.1433 + /*
1.1434 + * Fix the target of the jumpFalse after the test. Generate a 4 byte
1.1435 + * jump if the distance is > 120 bytes. This is conservative, and
1.1436 + * ensures that we won't have to replace this jump if we later also
1.1437 + * need to replace the proceeding jump to the end of the "if" with a
1.1438 + * 4 byte jump.
1.1439 + */
1.1440 +
1.1441 + jumpDist = (envPtr->codeNext - envPtr->codeStart)
1.1442 + - jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
1.1443 + if (TclFixupForwardJump(envPtr,
1.1444 + &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
1.1445 + /*
1.1446 + * Adjust the code offset for the proceeding jump to the end
1.1447 + * of the "if" command.
1.1448 + */
1.1449 +
1.1450 + jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
1.1451 + }
1.1452 + } else if (boolVal) {
1.1453 + /*
1.1454 + *We were processing an "if 1 {...}"; stop compiling
1.1455 + * scripts
1.1456 + */
1.1457 +
1.1458 + compileScripts = 0;
1.1459 + } else {
1.1460 + /*
1.1461 + *We were processing an "if 0 {...}"; reset so that
1.1462 + * the rest (elseif, else) is compiled correctly
1.1463 + */
1.1464 +
1.1465 + realCond = 1;
1.1466 + compileScripts = 1;
1.1467 + }
1.1468 +
1.1469 + tokenPtr += (tokenPtr->numComponents + 1);
1.1470 + wordIdx++;
1.1471 + }
1.1472 +
1.1473 + /*
1.1474 + * Restore the current stack depth in the environment; the
1.1475 + * "else" clause (or its default) will add 1 to this.
1.1476 + */
1.1477 +
1.1478 + envPtr->currStackDepth = savedStackDepth;
1.1479 +
1.1480 + /*
1.1481 + * Check for the optional else clause. Do not compile
1.1482 + * anything if this was an "if 1 {...}" case.
1.1483 + */
1.1484 +
1.1485 + if ((wordIdx < numWords)
1.1486 + && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
1.1487 + /*
1.1488 + * There is an else clause. Skip over the optional "else" word.
1.1489 + */
1.1490 +
1.1491 + word = tokenPtr[1].start;
1.1492 + numBytes = tokenPtr[1].size;
1.1493 + if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
1.1494 + tokenPtr += (tokenPtr->numComponents + 1);
1.1495 + wordIdx++;
1.1496 + if (wordIdx >= numWords) {
1.1497 + Tcl_ResetResult(interp);
1.1498 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.1499 + "wrong # args: no script following \"else\" argument", -1);
1.1500 + code = TCL_ERROR;
1.1501 + goto done;
1.1502 + }
1.1503 + }
1.1504 +
1.1505 + if (compileScripts) {
1.1506 + /*
1.1507 + * Compile the else command body.
1.1508 + */
1.1509 +#ifdef TCL_TIP280
1.1510 + envPtr->line = mapPtr->loc [eclIndex].line [wordIdx];
1.1511 +#endif
1.1512 + code = TclCompileCmdWord(interp, tokenPtr+1,
1.1513 + tokenPtr->numComponents, envPtr);
1.1514 + if (code != TCL_OK) {
1.1515 + if (code == TCL_ERROR) {
1.1516 + sprintf(buffer, "\n (\"if\" else script line %d)",
1.1517 + interp->errorLine);
1.1518 + Tcl_AddObjErrorInfo(interp, buffer, -1);
1.1519 + }
1.1520 + goto done;
1.1521 + }
1.1522 + }
1.1523 +
1.1524 + /*
1.1525 + * Make sure there are no words after the else clause.
1.1526 + */
1.1527 +
1.1528 + wordIdx++;
1.1529 + if (wordIdx < numWords) {
1.1530 + Tcl_ResetResult(interp);
1.1531 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.1532 + "wrong # args: extra words after \"else\" clause in \"if\" command", -1);
1.1533 + code = TCL_ERROR;
1.1534 + goto done;
1.1535 + }
1.1536 + } else {
1.1537 + /*
1.1538 + * No else clause: the "if" command's result is an empty string.
1.1539 + */
1.1540 +
1.1541 + if (compileScripts) {
1.1542 + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
1.1543 + }
1.1544 + }
1.1545 +
1.1546 + /*
1.1547 + * Fix the unconditional jumps to the end of the "if" command.
1.1548 + */
1.1549 +
1.1550 + for (j = jumpEndFixupArray.next; j > 0; j--) {
1.1551 + jumpIndex = (j - 1); /* i.e. process the closest jump first */
1.1552 + jumpDist = (envPtr->codeNext - envPtr->codeStart)
1.1553 + - jumpEndFixupArray.fixup[jumpIndex].codeOffset;
1.1554 + if (TclFixupForwardJump(envPtr,
1.1555 + &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {
1.1556 + /*
1.1557 + * Adjust the immediately preceeding "ifFalse" jump. We moved
1.1558 + * it's target (just after this jump) down three bytes.
1.1559 + */
1.1560 +
1.1561 + unsigned char *ifFalsePc = envPtr->codeStart
1.1562 + + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
1.1563 + unsigned char opCode = *ifFalsePc;
1.1564 + if (opCode == INST_JUMP_FALSE1) {
1.1565 + jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
1.1566 + jumpFalseDist += 3;
1.1567 + TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
1.1568 + } else if (opCode == INST_JUMP_FALSE4) {
1.1569 + jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
1.1570 + jumpFalseDist += 3;
1.1571 + TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
1.1572 + } else {
1.1573 + panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
1.1574 + }
1.1575 + }
1.1576 + }
1.1577 +
1.1578 + /*
1.1579 + * Free the jumpFixupArray array if malloc'ed storage was used.
1.1580 + */
1.1581 +
1.1582 + done:
1.1583 + envPtr->currStackDepth = savedStackDepth + 1;
1.1584 + TclFreeJumpFixupArray(&jumpFalseFixupArray);
1.1585 + TclFreeJumpFixupArray(&jumpEndFixupArray);
1.1586 + return code;
1.1587 +}
1.1588 +
1.1589 +/*
1.1590 + *----------------------------------------------------------------------
1.1591 + *
1.1592 + * TclCompileIncrCmd --
1.1593 + *
1.1594 + * Procedure called to compile the "incr" command.
1.1595 + *
1.1596 + * Results:
1.1597 + * The return value is a standard Tcl result, which is TCL_OK if
1.1598 + * compilation was successful. If an error occurs then the
1.1599 + * interpreter's result contains a standard error message and TCL_ERROR
1.1600 + * is returned. If the command is too complex for TclCompileIncrCmd,
1.1601 + * TCL_OUT_LINE_COMPILE is returned indicating that the incr command
1.1602 + * should be compiled "out of line" by emitting code to invoke its
1.1603 + * command procedure at runtime.
1.1604 + *
1.1605 + * Side effects:
1.1606 + * Instructions are added to envPtr to execute the "incr" command
1.1607 + * at runtime.
1.1608 + *
1.1609 + *----------------------------------------------------------------------
1.1610 + */
1.1611 +
1.1612 +int
1.1613 +TclCompileIncrCmd(interp, parsePtr, envPtr)
1.1614 + Tcl_Interp *interp; /* Used for error reporting. */
1.1615 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.1616 + * command created by Tcl_ParseCommand. */
1.1617 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.1618 +{
1.1619 + Tcl_Token *varTokenPtr, *incrTokenPtr;
1.1620 + int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
1.1621 + int code = TCL_OK;
1.1622 +
1.1623 +#ifdef TCL_TIP280
1.1624 + /* TIP #280 : Remember the per-word line information of the current
1.1625 + * command. An index is used instead of a pointer as recursive compilation
1.1626 + * may reallocate, i.e. move, the array. This is also the reason to save
1.1627 + * the nuloc now, it may change during the course of the function.
1.1628 + */
1.1629 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.1630 + int eclIndex = mapPtr->nuloc - 1;
1.1631 +#endif
1.1632 +
1.1633 + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
1.1634 + Tcl_ResetResult(interp);
1.1635 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.1636 + "wrong # args: should be \"incr varName ?increment?\"", -1);
1.1637 + return TCL_ERROR;
1.1638 + }
1.1639 +
1.1640 + varTokenPtr = parsePtr->tokenPtr
1.1641 + + (parsePtr->tokenPtr->numComponents + 1);
1.1642 +
1.1643 + code = TclPushVarName(interp, varTokenPtr, envPtr,
1.1644 + (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR),
1.1645 +#ifndef TCL_TIP280
1.1646 + &localIndex, &simpleVarName, &isScalar);
1.1647 +#else
1.1648 + &localIndex, &simpleVarName, &isScalar,
1.1649 + mapPtr->loc [eclIndex].line [1]);
1.1650 +#endif
1.1651 + if (code != TCL_OK) {
1.1652 + goto done;
1.1653 + }
1.1654 +
1.1655 + /*
1.1656 + * If an increment is given, push it, but see first if it's a small
1.1657 + * integer.
1.1658 + */
1.1659 +
1.1660 + haveImmValue = 0;
1.1661 + immValue = 1;
1.1662 + if (parsePtr->numWords == 3) {
1.1663 + incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.1664 + if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.1665 + CONST char *word = incrTokenPtr[1].start;
1.1666 + int numBytes = incrTokenPtr[1].size;
1.1667 +
1.1668 + /*
1.1669 + * Note there is a danger that modifying the string could have
1.1670 + * undesirable side effects. In this case, TclLooksLikeInt has
1.1671 + * no dependencies on shared strings so we should be safe.
1.1672 + */
1.1673 +
1.1674 + if (TclLooksLikeInt(word, numBytes)) {
1.1675 + int code;
1.1676 + Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
1.1677 + Tcl_IncrRefCount(intObj);
1.1678 + code = Tcl_GetIntFromObj(NULL, intObj, &immValue);
1.1679 + Tcl_DecrRefCount(intObj);
1.1680 + if ((code == TCL_OK)
1.1681 + && (-127 <= immValue) && (immValue <= 127)) {
1.1682 + haveImmValue = 1;
1.1683 + }
1.1684 + }
1.1685 + if (!haveImmValue) {
1.1686 + TclEmitPush(
1.1687 + TclRegisterNewLiteral(envPtr, word, numBytes), envPtr);
1.1688 + }
1.1689 + } else {
1.1690 +#ifdef TCL_TIP280
1.1691 + envPtr->line = mapPtr->loc [eclIndex].line [2];
1.1692 +#endif
1.1693 + code = TclCompileTokens(interp, incrTokenPtr+1,
1.1694 + incrTokenPtr->numComponents, envPtr);
1.1695 + if (code != TCL_OK) {
1.1696 + goto done;
1.1697 + }
1.1698 + }
1.1699 + } else { /* no incr amount given so use 1 */
1.1700 + haveImmValue = 1;
1.1701 + }
1.1702 +
1.1703 + /*
1.1704 + * Emit the instruction to increment the variable.
1.1705 + */
1.1706 +
1.1707 + if (simpleVarName) {
1.1708 + if (isScalar) {
1.1709 + if (localIndex >= 0) {
1.1710 + if (haveImmValue) {
1.1711 + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
1.1712 + TclEmitInt1(immValue, envPtr);
1.1713 + } else {
1.1714 + TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
1.1715 + }
1.1716 + } else {
1.1717 + if (haveImmValue) {
1.1718 + TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
1.1719 + } else {
1.1720 + TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
1.1721 + }
1.1722 + }
1.1723 + } else {
1.1724 + if (localIndex >= 0) {
1.1725 + if (haveImmValue) {
1.1726 + TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
1.1727 + TclEmitInt1(immValue, envPtr);
1.1728 + } else {
1.1729 + TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
1.1730 + }
1.1731 + } else {
1.1732 + if (haveImmValue) {
1.1733 + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
1.1734 + } else {
1.1735 + TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
1.1736 + }
1.1737 + }
1.1738 + }
1.1739 + } else { /* non-simple variable name */
1.1740 + if (haveImmValue) {
1.1741 + TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
1.1742 + } else {
1.1743 + TclEmitOpcode(INST_INCR_STK, envPtr);
1.1744 + }
1.1745 + }
1.1746 +
1.1747 + done:
1.1748 + return code;
1.1749 +}
1.1750 +
1.1751 +/*
1.1752 + *----------------------------------------------------------------------
1.1753 + *
1.1754 + * TclCompileLappendCmd --
1.1755 + *
1.1756 + * Procedure called to compile the "lappend" command.
1.1757 + *
1.1758 + * Results:
1.1759 + * The return value is a standard Tcl result, which is normally TCL_OK
1.1760 + * unless there was an error while parsing string. If an error occurs
1.1761 + * then the interpreter's result contains a standard error message. If
1.1762 + * complation fails because the command requires a second level of
1.1763 + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
1.1764 + * command should be compiled "out of line" by emitting code to
1.1765 + * invoke its command procedure (Tcl_LappendObjCmd) at runtime.
1.1766 + *
1.1767 + * Side effects:
1.1768 + * Instructions are added to envPtr to execute the "lappend" command
1.1769 + * at runtime.
1.1770 + *
1.1771 + *----------------------------------------------------------------------
1.1772 + */
1.1773 +
1.1774 +int
1.1775 +TclCompileLappendCmd(interp, parsePtr, envPtr)
1.1776 + Tcl_Interp *interp; /* Used for error reporting. */
1.1777 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.1778 + * command created by Tcl_ParseCommand. */
1.1779 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.1780 +{
1.1781 + Tcl_Token *varTokenPtr, *valueTokenPtr;
1.1782 + int simpleVarName, isScalar, localIndex, numWords;
1.1783 + int code = TCL_OK;
1.1784 +
1.1785 +#ifdef TCL_TIP280
1.1786 + /* TIP #280 : Remember the per-word line information of the current
1.1787 + * command. An index is used instead of a pointer as recursive compilation
1.1788 + * may reallocate, i.e. move, the array. This is also the reason to save
1.1789 + * the nuloc now, it may change during the course of the function.
1.1790 + */
1.1791 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.1792 + int eclIndex = mapPtr->nuloc - 1;
1.1793 +#endif
1.1794 +
1.1795 + /*
1.1796 + * If we're not in a procedure, don't compile.
1.1797 + */
1.1798 + if (envPtr->procPtr == NULL) {
1.1799 + return TCL_OUT_LINE_COMPILE;
1.1800 + }
1.1801 +
1.1802 + numWords = parsePtr->numWords;
1.1803 + if (numWords == 1) {
1.1804 + Tcl_ResetResult(interp);
1.1805 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.1806 + "wrong # args: should be \"lappend varName ?value value ...?\"", -1);
1.1807 + return TCL_ERROR;
1.1808 + }
1.1809 + if (numWords != 3) {
1.1810 + /*
1.1811 + * LAPPEND instructions currently only handle one value appends
1.1812 + */
1.1813 + return TCL_OUT_LINE_COMPILE;
1.1814 + }
1.1815 +
1.1816 + /*
1.1817 + * Decide if we can use a frame slot for the var/array name or if we
1.1818 + * need to emit code to compute and push the name at runtime. We use a
1.1819 + * frame slot (entry in the array of local vars) if we are compiling a
1.1820 + * procedure body and if the name is simple text that does not include
1.1821 + * namespace qualifiers.
1.1822 + */
1.1823 +
1.1824 + varTokenPtr = parsePtr->tokenPtr
1.1825 + + (parsePtr->tokenPtr->numComponents + 1);
1.1826 +
1.1827 + code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
1.1828 +#ifndef TCL_TIP280
1.1829 + &localIndex, &simpleVarName, &isScalar);
1.1830 +#else
1.1831 + &localIndex, &simpleVarName, &isScalar,
1.1832 + mapPtr->loc [eclIndex].line [1]);
1.1833 +#endif
1.1834 + if (code != TCL_OK) {
1.1835 + goto done;
1.1836 + }
1.1837 +
1.1838 + /*
1.1839 + * If we are doing an assignment, push the new value.
1.1840 + * In the no values case, create an empty object.
1.1841 + */
1.1842 +
1.1843 + if (numWords > 2) {
1.1844 + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.1845 + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.1846 + TclEmitPush(TclRegisterNewLiteral(envPtr,
1.1847 + valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
1.1848 + } else {
1.1849 +#ifdef TCL_TIP280
1.1850 + envPtr->line = mapPtr->loc [eclIndex].line [2];
1.1851 +#endif
1.1852 + code = TclCompileTokens(interp, valueTokenPtr+1,
1.1853 + valueTokenPtr->numComponents, envPtr);
1.1854 + if (code != TCL_OK) {
1.1855 + goto done;
1.1856 + }
1.1857 + }
1.1858 + }
1.1859 +
1.1860 + /*
1.1861 + * Emit instructions to set/get the variable.
1.1862 + */
1.1863 +
1.1864 + /*
1.1865 + * The *_STK opcodes should be refactored to make better use of existing
1.1866 + * LOAD/STORE instructions.
1.1867 + */
1.1868 + if (simpleVarName) {
1.1869 + if (isScalar) {
1.1870 + if (localIndex >= 0) {
1.1871 + if (localIndex <= 255) {
1.1872 + TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
1.1873 + } else {
1.1874 + TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
1.1875 + }
1.1876 + } else {
1.1877 + TclEmitOpcode(INST_LAPPEND_STK, envPtr);
1.1878 + }
1.1879 + } else {
1.1880 + if (localIndex >= 0) {
1.1881 + if (localIndex <= 255) {
1.1882 + TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
1.1883 + } else {
1.1884 + TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
1.1885 + }
1.1886 + } else {
1.1887 + TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
1.1888 + }
1.1889 + }
1.1890 + } else {
1.1891 + TclEmitOpcode(INST_LAPPEND_STK, envPtr);
1.1892 + }
1.1893 +
1.1894 + done:
1.1895 + return code;
1.1896 +}
1.1897 +
1.1898 +/*
1.1899 + *----------------------------------------------------------------------
1.1900 + *
1.1901 + * TclCompileLindexCmd --
1.1902 + *
1.1903 + * Procedure called to compile the "lindex" command.
1.1904 + *
1.1905 + * Results:
1.1906 + * The return value is a standard Tcl result, which is TCL_OK if the
1.1907 + * compilation was successful. If the command cannot be byte-compiled,
1.1908 + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
1.1909 + * interpreter's result contains an error message, and TCL_ERROR is
1.1910 + * returned.
1.1911 + *
1.1912 + * Side effects:
1.1913 + * Instructions are added to envPtr to execute the "lindex" command
1.1914 + * at runtime.
1.1915 + *
1.1916 + *----------------------------------------------------------------------
1.1917 + */
1.1918 +
1.1919 +int
1.1920 +TclCompileLindexCmd(interp, parsePtr, envPtr)
1.1921 + Tcl_Interp *interp; /* Used for error reporting. */
1.1922 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.1923 + * command created by Tcl_ParseCommand. */
1.1924 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.1925 +{
1.1926 + Tcl_Token *varTokenPtr;
1.1927 + int code, i;
1.1928 +
1.1929 +#ifdef TCL_TIP280
1.1930 + /* TIP #280 : Remember the per-word line information of the current
1.1931 + * command. An index is used instead of a pointer as recursive compilation
1.1932 + * may reallocate, i.e. move, the array. This is also the reason to save
1.1933 + * the nuloc now, it may change during the course of the function.
1.1934 + */
1.1935 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.1936 + int eclIndex = mapPtr->nuloc - 1;
1.1937 +#endif
1.1938 +
1.1939 + int numWords;
1.1940 + numWords = parsePtr->numWords;
1.1941 +
1.1942 + /*
1.1943 + * Quit if too few args
1.1944 + */
1.1945 +
1.1946 + if ( numWords <= 1 ) {
1.1947 + return TCL_OUT_LINE_COMPILE;
1.1948 + }
1.1949 +
1.1950 + varTokenPtr = parsePtr->tokenPtr
1.1951 + + (parsePtr->tokenPtr->numComponents + 1);
1.1952 +
1.1953 + /*
1.1954 + * Push the operands onto the stack.
1.1955 + */
1.1956 +
1.1957 + for ( i = 1 ; i < numWords ; i++ ) {
1.1958 + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.1959 + TclEmitPush(
1.1960 + TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
1.1961 + varTokenPtr[1].size), envPtr);
1.1962 + } else {
1.1963 +#ifdef TCL_TIP280
1.1964 + envPtr->line = mapPtr->loc [eclIndex].line [i];
1.1965 +#endif
1.1966 + code = TclCompileTokens(interp, varTokenPtr+1,
1.1967 + varTokenPtr->numComponents, envPtr);
1.1968 + if (code != TCL_OK) {
1.1969 + return code;
1.1970 + }
1.1971 + }
1.1972 + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.1973 + }
1.1974 +
1.1975 + /*
1.1976 + * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI
1.1977 + * if there are multiple index args.
1.1978 + */
1.1979 +
1.1980 + if ( numWords == 3 ) {
1.1981 + TclEmitOpcode( INST_LIST_INDEX, envPtr );
1.1982 + } else {
1.1983 + TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr );
1.1984 + }
1.1985 +
1.1986 + return TCL_OK;
1.1987 +}
1.1988 +
1.1989 +/*
1.1990 + *----------------------------------------------------------------------
1.1991 + *
1.1992 + * TclCompileListCmd --
1.1993 + *
1.1994 + * Procedure called to compile the "list" command.
1.1995 + *
1.1996 + * Results:
1.1997 + * The return value is a standard Tcl result, which is normally TCL_OK
1.1998 + * unless there was an error while parsing string. If an error occurs
1.1999 + * then the interpreter's result contains a standard error message. If
1.2000 + * complation fails because the command requires a second level of
1.2001 + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
1.2002 + * command should be compiled "out of line" by emitting code to
1.2003 + * invoke its command procedure (Tcl_ListObjCmd) at runtime.
1.2004 + *
1.2005 + * Side effects:
1.2006 + * Instructions are added to envPtr to execute the "list" command
1.2007 + * at runtime.
1.2008 + *
1.2009 + *----------------------------------------------------------------------
1.2010 + */
1.2011 +
1.2012 +int
1.2013 +TclCompileListCmd(interp, parsePtr, envPtr)
1.2014 + Tcl_Interp *interp; /* Used for error reporting. */
1.2015 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.2016 + * command created by Tcl_ParseCommand. */
1.2017 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.2018 +{
1.2019 +#ifdef TCL_TIP280
1.2020 + /* TIP #280 : Remember the per-word line information of the current
1.2021 + * command. An index is used instead of a pointer as recursive compilation
1.2022 + * may reallocate, i.e. move, the array. This is also the reason to save
1.2023 + * the nuloc now, it may change during the course of the function.
1.2024 + */
1.2025 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.2026 + int eclIndex = mapPtr->nuloc - 1;
1.2027 +#endif
1.2028 +
1.2029 + /*
1.2030 + * If we're not in a procedure, don't compile.
1.2031 + */
1.2032 + if (envPtr->procPtr == NULL) {
1.2033 + return TCL_OUT_LINE_COMPILE;
1.2034 + }
1.2035 +
1.2036 + if (parsePtr->numWords == 1) {
1.2037 + /*
1.2038 + * Empty args case
1.2039 + */
1.2040 +
1.2041 + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
1.2042 + } else {
1.2043 + /*
1.2044 + * Push the all values onto the stack.
1.2045 + */
1.2046 + Tcl_Token *valueTokenPtr;
1.2047 + int i, code, numWords;
1.2048 +
1.2049 + numWords = parsePtr->numWords;
1.2050 +
1.2051 + valueTokenPtr = parsePtr->tokenPtr
1.2052 + + (parsePtr->tokenPtr->numComponents + 1);
1.2053 + for (i = 1; i < numWords; i++) {
1.2054 + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.2055 + TclEmitPush(TclRegisterNewLiteral(envPtr,
1.2056 + valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
1.2057 + } else {
1.2058 +#ifdef TCL_TIP280
1.2059 + envPtr->line = mapPtr->loc [eclIndex].line [i];
1.2060 +#endif
1.2061 + code = TclCompileTokens(interp, valueTokenPtr+1,
1.2062 + valueTokenPtr->numComponents, envPtr);
1.2063 + if (code != TCL_OK) {
1.2064 + return code;
1.2065 + }
1.2066 + }
1.2067 + valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1);
1.2068 + }
1.2069 + TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
1.2070 + }
1.2071 +
1.2072 + return TCL_OK;
1.2073 +}
1.2074 +
1.2075 +/*
1.2076 + *----------------------------------------------------------------------
1.2077 + *
1.2078 + * TclCompileLlengthCmd --
1.2079 + *
1.2080 + * Procedure called to compile the "llength" command.
1.2081 + *
1.2082 + * Results:
1.2083 + * The return value is a standard Tcl result, which is TCL_OK if the
1.2084 + * compilation was successful. If the command cannot be byte-compiled,
1.2085 + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
1.2086 + * interpreter's result contains an error message, and TCL_ERROR is
1.2087 + * returned.
1.2088 + *
1.2089 + * Side effects:
1.2090 + * Instructions are added to envPtr to execute the "llength" command
1.2091 + * at runtime.
1.2092 + *
1.2093 + *----------------------------------------------------------------------
1.2094 + */
1.2095 +
1.2096 +int
1.2097 +TclCompileLlengthCmd(interp, parsePtr, envPtr)
1.2098 + Tcl_Interp *interp; /* Used for error reporting. */
1.2099 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.2100 + * command created by Tcl_ParseCommand. */
1.2101 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.2102 +{
1.2103 + Tcl_Token *varTokenPtr;
1.2104 + int code;
1.2105 +
1.2106 +#ifdef TCL_TIP280
1.2107 + /* TIP #280 : Remember the per-word line information of the current
1.2108 + * command. An index is used instead of a pointer as recursive compilation
1.2109 + * may reallocate, i.e. move, the array. This is also the reason to save
1.2110 + * the nuloc now, it may change during the course of the function.
1.2111 + */
1.2112 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.2113 + int eclIndex = mapPtr->nuloc - 1;
1.2114 +#endif
1.2115 +
1.2116 + if (parsePtr->numWords != 2) {
1.2117 + Tcl_SetResult(interp, "wrong # args: should be \"llength list\"",
1.2118 + TCL_STATIC);
1.2119 + return TCL_ERROR;
1.2120 + }
1.2121 + varTokenPtr = parsePtr->tokenPtr
1.2122 + + (parsePtr->tokenPtr->numComponents + 1);
1.2123 +
1.2124 + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.2125 + /*
1.2126 + * We could simply count the number of elements here and push
1.2127 + * that value, but that is too rare a case to waste the code space.
1.2128 + */
1.2129 + TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
1.2130 + varTokenPtr[1].size), envPtr);
1.2131 + } else {
1.2132 +#ifdef TCL_TIP280
1.2133 + envPtr->line = mapPtr->loc [eclIndex].line [1];
1.2134 +#endif
1.2135 + code = TclCompileTokens(interp, varTokenPtr+1,
1.2136 + varTokenPtr->numComponents, envPtr);
1.2137 + if (code != TCL_OK) {
1.2138 + return code;
1.2139 + }
1.2140 + }
1.2141 + TclEmitOpcode(INST_LIST_LENGTH, envPtr);
1.2142 + return TCL_OK;
1.2143 +}
1.2144 +
1.2145 +/*
1.2146 + *----------------------------------------------------------------------
1.2147 + *
1.2148 + * TclCompileLsetCmd --
1.2149 + *
1.2150 + * Procedure called to compile the "lset" command.
1.2151 + *
1.2152 + * Results:
1.2153 + * The return value is a standard Tcl result, which is TCL_OK if
1.2154 + * the compilation was successful. If the "lset" command is too
1.2155 + * complex for this function, then TCL_OUT_LINE_COMPILE is returned,
1.2156 + * indicating that the command should be compiled "out of line"
1.2157 + * (that is, not byte-compiled). If an error occurs, TCL_ERROR is
1.2158 + * returned, and the interpreter result contains an error message.
1.2159 + *
1.2160 + * Side effects:
1.2161 + * Instructions are added to envPtr to execute the "lset" command
1.2162 + * at runtime.
1.2163 + *
1.2164 + * The general template for execution of the "lset" command is:
1.2165 + * (1) Instructions to push the variable name, unless the
1.2166 + * variable is local to the stack frame.
1.2167 + * (2) If the variable is an array element, instructions
1.2168 + * to push the array element name.
1.2169 + * (3) Instructions to push each of zero or more "index" arguments
1.2170 + * to the stack, followed with the "newValue" element.
1.2171 + * (4) Instructions to duplicate the variable name and/or array
1.2172 + * element name onto the top of the stack, if either was
1.2173 + * pushed at steps (1) and (2).
1.2174 + * (5) The appropriate INST_LOAD_* instruction to place the
1.2175 + * original value of the list variable at top of stack.
1.2176 + * (6) At this point, the stack contains:
1.2177 + * varName? arrayElementName? index1 index2 ... newValue oldList
1.2178 + * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
1.2179 + * according as whether there is exactly one index element (LIST)
1.2180 + * or either zero or else two or more (FLAT). This instruction
1.2181 + * removes everything from the stack except for the two names
1.2182 + * and pushes the new value of the variable.
1.2183 + * (7) Finally, INST_STORE_* stores the new value in the variable
1.2184 + * and cleans up the stack.
1.2185 + *
1.2186 + *----------------------------------------------------------------------
1.2187 + */
1.2188 +
1.2189 +int
1.2190 +TclCompileLsetCmd( interp, parsePtr, envPtr )
1.2191 + Tcl_Interp* interp; /* Tcl interpreter for error reporting */
1.2192 + Tcl_Parse* parsePtr; /* Points to a parse structure for
1.2193 + * the command */
1.2194 + CompileEnv* envPtr; /* Holds the resulting instructions */
1.2195 +{
1.2196 +
1.2197 + int tempDepth; /* Depth used for emitting one part
1.2198 + * of the code burst. */
1.2199 + Tcl_Token* varTokenPtr; /* Pointer to the Tcl_Token representing
1.2200 + * the parse of the variable name */
1.2201 +
1.2202 + int result; /* Status return from library calls */
1.2203 +
1.2204 + int localIndex; /* Index of var in local var table */
1.2205 + int simpleVarName; /* Flag == 1 if var name is simple */
1.2206 + int isScalar; /* Flag == 1 if scalar, 0 if array */
1.2207 +
1.2208 + int i;
1.2209 +
1.2210 +#ifdef TCL_TIP280
1.2211 + /* TIP #280 : Remember the per-word line information of the current
1.2212 + * command. An index is used instead of a pointer as recursive compilation
1.2213 + * may reallocate, i.e. move, the array. This is also the reason to save
1.2214 + * the nuloc now, it may change during the course of the function.
1.2215 + */
1.2216 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.2217 + int eclIndex = mapPtr->nuloc - 1;
1.2218 +#endif
1.2219 +
1.2220 + /* Check argument count */
1.2221 +
1.2222 + if ( parsePtr->numWords < 3 ) {
1.2223 + /* Fail at run time, not in compilation */
1.2224 + return TCL_OUT_LINE_COMPILE;
1.2225 + }
1.2226 +
1.2227 + /*
1.2228 + * Decide if we can use a frame slot for the var/array name or if we
1.2229 + * need to emit code to compute and push the name at runtime. We use a
1.2230 + * frame slot (entry in the array of local vars) if we are compiling a
1.2231 + * procedure body and if the name is simple text that does not include
1.2232 + * namespace qualifiers.
1.2233 + */
1.2234 +
1.2235 + varTokenPtr = parsePtr->tokenPtr
1.2236 + + (parsePtr->tokenPtr->numComponents + 1);
1.2237 + result = TclPushVarName( interp, varTokenPtr, envPtr,
1.2238 +#ifndef TCL_TIP280
1.2239 + TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar );
1.2240 +#else
1.2241 + TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar,
1.2242 + mapPtr->loc [eclIndex].line [1]);
1.2243 +#endif
1.2244 + if (result != TCL_OK) {
1.2245 + return result;
1.2246 + }
1.2247 +
1.2248 + /* Push the "index" args and the new element value. */
1.2249 +
1.2250 + for ( i = 2; i < parsePtr->numWords; ++i ) {
1.2251 +
1.2252 + /* Advance to next arg */
1.2253 +
1.2254 + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.2255 +
1.2256 + /* Push an arg */
1.2257 +
1.2258 + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.2259 + TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
1.2260 + varTokenPtr[1].size), envPtr);
1.2261 + } else {
1.2262 +#ifdef TCL_TIP280
1.2263 + envPtr->line = mapPtr->loc [eclIndex].line [i];
1.2264 +#endif
1.2265 + result = TclCompileTokens(interp, varTokenPtr+1,
1.2266 + varTokenPtr->numComponents, envPtr);
1.2267 + if ( result != TCL_OK ) {
1.2268 + return result;
1.2269 + }
1.2270 + }
1.2271 + }
1.2272 +
1.2273 + /*
1.2274 + * Duplicate the variable name if it's been pushed.
1.2275 + */
1.2276 +
1.2277 + if ( !simpleVarName || localIndex < 0 ) {
1.2278 + if ( !simpleVarName || isScalar ) {
1.2279 + tempDepth = parsePtr->numWords - 2;
1.2280 + } else {
1.2281 + tempDepth = parsePtr->numWords - 1;
1.2282 + }
1.2283 + TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
1.2284 + }
1.2285 +
1.2286 + /*
1.2287 + * Duplicate an array index if one's been pushed
1.2288 + */
1.2289 +
1.2290 + if ( simpleVarName && !isScalar ) {
1.2291 + if ( localIndex < 0 ) {
1.2292 + tempDepth = parsePtr->numWords - 1;
1.2293 + } else {
1.2294 + tempDepth = parsePtr->numWords - 2;
1.2295 + }
1.2296 + TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
1.2297 + }
1.2298 +
1.2299 + /*
1.2300 + * Emit code to load the variable's value.
1.2301 + */
1.2302 +
1.2303 + if ( !simpleVarName ) {
1.2304 + TclEmitOpcode( INST_LOAD_STK, envPtr );
1.2305 + } else if ( isScalar ) {
1.2306 + if ( localIndex < 0 ) {
1.2307 + TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr );
1.2308 + } else if ( localIndex < 0x100 ) {
1.2309 + TclEmitInstInt1( INST_LOAD_SCALAR1, localIndex, envPtr );
1.2310 + } else {
1.2311 + TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr );
1.2312 + }
1.2313 + } else {
1.2314 + if ( localIndex < 0 ) {
1.2315 + TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr );
1.2316 + } else if ( localIndex < 0x100 ) {
1.2317 + TclEmitInstInt1( INST_LOAD_ARRAY1, localIndex, envPtr );
1.2318 + } else {
1.2319 + TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr );
1.2320 + }
1.2321 + }
1.2322 +
1.2323 + /*
1.2324 + * Emit the correct variety of 'lset' instruction
1.2325 + */
1.2326 +
1.2327 + if ( parsePtr->numWords == 4 ) {
1.2328 + TclEmitOpcode( INST_LSET_LIST, envPtr );
1.2329 + } else {
1.2330 + TclEmitInstInt4( INST_LSET_FLAT, (parsePtr->numWords - 1), envPtr );
1.2331 + }
1.2332 +
1.2333 + /*
1.2334 + * Emit code to put the value back in the variable
1.2335 + */
1.2336 +
1.2337 + if ( !simpleVarName ) {
1.2338 + TclEmitOpcode( INST_STORE_STK, envPtr );
1.2339 + } else if ( isScalar ) {
1.2340 + if ( localIndex < 0 ) {
1.2341 + TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr );
1.2342 + } else if ( localIndex < 0x100 ) {
1.2343 + TclEmitInstInt1( INST_STORE_SCALAR1, localIndex, envPtr );
1.2344 + } else {
1.2345 + TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr );
1.2346 + }
1.2347 + } else {
1.2348 + if ( localIndex < 0 ) {
1.2349 + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr );
1.2350 + } else if ( localIndex < 0x100 ) {
1.2351 + TclEmitInstInt1( INST_STORE_ARRAY1, localIndex, envPtr );
1.2352 + } else {
1.2353 + TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr );
1.2354 + }
1.2355 + }
1.2356 +
1.2357 + return TCL_OK;
1.2358 +
1.2359 +}
1.2360 +
1.2361 +/*
1.2362 + *----------------------------------------------------------------------
1.2363 + *
1.2364 + * TclCompileRegexpCmd --
1.2365 + *
1.2366 + * Procedure called to compile the "regexp" command.
1.2367 + *
1.2368 + * Results:
1.2369 + * The return value is a standard Tcl result, which is TCL_OK if
1.2370 + * the compilation was successful. If the "regexp" command is too
1.2371 + * complex for this function, then TCL_OUT_LINE_COMPILE is returned,
1.2372 + * indicating that the command should be compiled "out of line"
1.2373 + * (that is, not byte-compiled). If an error occurs, TCL_ERROR is
1.2374 + * returned, and the interpreter result contains an error message.
1.2375 + *
1.2376 + * Side effects:
1.2377 + * Instructions are added to envPtr to execute the "regexp" command
1.2378 + * at runtime.
1.2379 + *
1.2380 + *----------------------------------------------------------------------
1.2381 + */
1.2382 +
1.2383 +int
1.2384 +TclCompileRegexpCmd(interp, parsePtr, envPtr)
1.2385 + Tcl_Interp* interp; /* Tcl interpreter for error reporting */
1.2386 + Tcl_Parse* parsePtr; /* Points to a parse structure for
1.2387 + * the command */
1.2388 + CompileEnv* envPtr; /* Holds the resulting instructions */
1.2389 +{
1.2390 + Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing
1.2391 + * the parse of the RE or string */
1.2392 + int i, len, code, nocase, anchorLeft, anchorRight, start;
1.2393 + char *str;
1.2394 +
1.2395 +#ifdef TCL_TIP280
1.2396 + /* TIP #280 : Remember the per-word line information of the current
1.2397 + * command. An index is used instead of a pointer as recursive compilation
1.2398 + * may reallocate, i.e. move, the array. This is also the reason to save
1.2399 + * the nuloc now, it may change during the course of the function.
1.2400 + */
1.2401 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.2402 + int eclIndex = mapPtr->nuloc - 1;
1.2403 +#endif
1.2404 +
1.2405 + /*
1.2406 + * We are only interested in compiling simple regexp cases.
1.2407 + * Currently supported compile cases are:
1.2408 + * regexp ?-nocase? ?--? staticString $var
1.2409 + * regexp ?-nocase? ?--? {^staticString$} $var
1.2410 + */
1.2411 + if (parsePtr->numWords < 3) {
1.2412 + return TCL_OUT_LINE_COMPILE;
1.2413 + }
1.2414 +
1.2415 + nocase = 0;
1.2416 + varTokenPtr = parsePtr->tokenPtr;
1.2417 +
1.2418 + /*
1.2419 + * We only look for -nocase and -- as options. Everything else
1.2420 + * gets pushed to runtime execution. This is different than regexp's
1.2421 + * runtime option handling, but satisfies our stricter needs.
1.2422 + */
1.2423 + for (i = 1; i < parsePtr->numWords - 2; i++) {
1.2424 + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.2425 + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1.2426 + /* Not a simple string - punt to runtime. */
1.2427 + return TCL_OUT_LINE_COMPILE;
1.2428 + }
1.2429 + str = (char *) varTokenPtr[1].start;
1.2430 + len = varTokenPtr[1].size;
1.2431 + if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
1.2432 + i++;
1.2433 + break;
1.2434 + } else if ((len > 1)
1.2435 + && (strncmp(str, "-nocase", (unsigned) len) == 0)) {
1.2436 + nocase = 1;
1.2437 + } else {
1.2438 + /* Not an option we recognize. */
1.2439 + return TCL_OUT_LINE_COMPILE;
1.2440 + }
1.2441 + }
1.2442 +
1.2443 + if ((parsePtr->numWords - i) != 2) {
1.2444 + /* We don't support capturing to variables */
1.2445 + return TCL_OUT_LINE_COMPILE;
1.2446 + }
1.2447 +
1.2448 + /*
1.2449 + * Get the regexp string. If it is not a simple string, punt to runtime.
1.2450 + * If it has a '-', it could be an incorrectly formed regexp command.
1.2451 + */
1.2452 + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.2453 + str = (char *) varTokenPtr[1].start;
1.2454 + len = varTokenPtr[1].size;
1.2455 + if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) {
1.2456 + return TCL_OUT_LINE_COMPILE;
1.2457 + }
1.2458 +
1.2459 + if (len == 0) {
1.2460 + /*
1.2461 + * The semantics of regexp are always match on re == "".
1.2462 + */
1.2463 + TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
1.2464 + return TCL_OK;
1.2465 + }
1.2466 +
1.2467 + /*
1.2468 + * Make a copy of the string that is null-terminated for checks which
1.2469 + * require such.
1.2470 + */
1.2471 + str = (char *) ckalloc((unsigned) len + 1);
1.2472 + strncpy(str, varTokenPtr[1].start, (size_t) len);
1.2473 + str[len] = '\0';
1.2474 + start = 0;
1.2475 +
1.2476 + /*
1.2477 + * Check for anchored REs (ie ^foo$), so we can use string equal if
1.2478 + * possible. Do not alter the start of str so we can free it correctly.
1.2479 + */
1.2480 + if (str[0] == '^') {
1.2481 + start++;
1.2482 + anchorLeft = 1;
1.2483 + } else {
1.2484 + anchorLeft = 0;
1.2485 + }
1.2486 + if ((str[len-1] == '$') && ((len == 1) || (str[len-2] != '\\'))) {
1.2487 + anchorRight = 1;
1.2488 + str[--len] = '\0';
1.2489 + } else {
1.2490 + anchorRight = 0;
1.2491 + }
1.2492 +
1.2493 + /*
1.2494 + * On the first (pattern) arg, check to see if any RE special characters
1.2495 + * are in the word. If not, this is the same as 'string equal'.
1.2496 + */
1.2497 + if ((len > (1+start)) && (str[start] == '.') && (str[start+1] == '*')) {
1.2498 + start += 2;
1.2499 + anchorLeft = 0;
1.2500 + }
1.2501 + if ((len > (2+start)) && (str[len-3] != '\\')
1.2502 + && (str[len-2] == '.') && (str[len-1] == '*')) {
1.2503 + len -= 2;
1.2504 + str[len] = '\0';
1.2505 + anchorRight = 0;
1.2506 + }
1.2507 +
1.2508 + /*
1.2509 + * Don't do anything with REs with other special chars. Also check if
1.2510 + * this is a bad RE (do this at the end because it can be expensive).
1.2511 + * If so, let it complain at runtime.
1.2512 + */
1.2513 + if ((strpbrk(str + start, "*+?{}()[].\\|^$") != NULL)
1.2514 + || (Tcl_RegExpCompile(NULL, str) == NULL)) {
1.2515 + ckfree((char *) str);
1.2516 + return TCL_OUT_LINE_COMPILE;
1.2517 + }
1.2518 +
1.2519 + if (anchorLeft && anchorRight) {
1.2520 + TclEmitPush(TclRegisterNewLiteral(envPtr, str+start, len-start),
1.2521 + envPtr);
1.2522 + } else {
1.2523 + /*
1.2524 + * This needs to find the substring anywhere in the string, so
1.2525 + * use string match and *foo*, with appropriate anchoring.
1.2526 + */
1.2527 + char *newStr = ckalloc((unsigned) len + 3);
1.2528 + len -= start;
1.2529 + if (anchorLeft) {
1.2530 + strncpy(newStr, str + start, (size_t) len);
1.2531 + } else {
1.2532 + newStr[0] = '*';
1.2533 + strncpy(newStr + 1, str + start, (size_t) len++);
1.2534 + }
1.2535 + if (!anchorRight) {
1.2536 + newStr[len++] = '*';
1.2537 + }
1.2538 + newStr[len] = '\0';
1.2539 + TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len), envPtr);
1.2540 + ckfree((char *) newStr);
1.2541 + }
1.2542 + ckfree((char *) str);
1.2543 +
1.2544 + /*
1.2545 + * Push the string arg
1.2546 + */
1.2547 + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.2548 + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.2549 + TclEmitPush(TclRegisterNewLiteral(envPtr,
1.2550 + varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
1.2551 + } else {
1.2552 +#ifdef TCL_TIP280
1.2553 + envPtr->line = mapPtr->loc [eclIndex].line [parsePtr->numWords-1];
1.2554 +#endif
1.2555 + code = TclCompileTokens(interp, varTokenPtr+1,
1.2556 + varTokenPtr->numComponents, envPtr);
1.2557 + if (code != TCL_OK) {
1.2558 + return code;
1.2559 + }
1.2560 + }
1.2561 +
1.2562 + if (anchorLeft && anchorRight && !nocase) {
1.2563 + TclEmitOpcode(INST_STR_EQ, envPtr);
1.2564 + } else {
1.2565 + TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
1.2566 + }
1.2567 +
1.2568 + return TCL_OK;
1.2569 +}
1.2570 +
1.2571 +/*
1.2572 + *----------------------------------------------------------------------
1.2573 + *
1.2574 + * TclCompileReturnCmd --
1.2575 + *
1.2576 + * Procedure called to compile the "return" command.
1.2577 + *
1.2578 + * Results:
1.2579 + * The return value is a standard Tcl result, which is TCL_OK if the
1.2580 + * compilation was successful. If the particular return command is
1.2581 + * too complex for this function (ie, return with any flags like "-code"
1.2582 + * or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that
1.2583 + * the command should be compiled "out of line" (eg, not byte compiled).
1.2584 + * If an error occurs then the interpreter's result contains a standard
1.2585 + * error message.
1.2586 + *
1.2587 + * Side effects:
1.2588 + * Instructions are added to envPtr to execute the "return" command
1.2589 + * at runtime.
1.2590 + *
1.2591 + *----------------------------------------------------------------------
1.2592 + */
1.2593 +
1.2594 +int
1.2595 +TclCompileReturnCmd(interp, parsePtr, envPtr)
1.2596 + Tcl_Interp *interp; /* Used for error reporting. */
1.2597 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.2598 + * command created by Tcl_ParseCommand. */
1.2599 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.2600 +{
1.2601 + Tcl_Token *varTokenPtr;
1.2602 + int code;
1.2603 + int index = envPtr->exceptArrayNext - 1;
1.2604 +
1.2605 +#ifdef TCL_TIP280
1.2606 + /* TIP #280 : Remember the per-word line information of the current
1.2607 + * command. An index is used instead of a pointer as recursive compilation
1.2608 + * may reallocate, i.e. move, the array. This is also the reason to save
1.2609 + * the nuloc now, it may change during the course of the function.
1.2610 + */
1.2611 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.2612 + int eclIndex = mapPtr->nuloc - 1;
1.2613 +#endif
1.2614 +
1.2615 + /*
1.2616 + * If we're not in a procedure, don't compile.
1.2617 + */
1.2618 +
1.2619 + if (envPtr->procPtr == NULL) {
1.2620 + return TCL_OUT_LINE_COMPILE;
1.2621 + }
1.2622 +
1.2623 + /*
1.2624 + * Look back through the ExceptionRanges of the current CompileEnv,
1.2625 + * from exceptArrayPtr[(exceptArrayNext - 1)] down to
1.2626 + * exceptArrayPtr[0] to see if any of them is an enclosing [catch].
1.2627 + * If there's an enclosing [catch], don't compile.
1.2628 + */
1.2629 +
1.2630 + while (index >= 0) {
1.2631 + ExceptionRange range = envPtr->exceptArrayPtr[index];
1.2632 + if ((range.type == CATCH_EXCEPTION_RANGE)
1.2633 + && (range.catchOffset == -1)) {
1.2634 + return TCL_OUT_LINE_COMPILE;
1.2635 + }
1.2636 + index--;
1.2637 + }
1.2638 +
1.2639 + switch (parsePtr->numWords) {
1.2640 + case 1: {
1.2641 + /*
1.2642 + * Simple case: [return]
1.2643 + * Just push the literal string "".
1.2644 + */
1.2645 + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
1.2646 + break;
1.2647 + }
1.2648 + case 2: {
1.2649 + /*
1.2650 + * More complex cases:
1.2651 + * [return "foo"]
1.2652 + * [return $value]
1.2653 + * [return [otherCmd]]
1.2654 + */
1.2655 + varTokenPtr = parsePtr->tokenPtr
1.2656 + + (parsePtr->tokenPtr->numComponents + 1);
1.2657 + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.2658 + /*
1.2659 + * [return "foo"] case: the parse token is a simple word,
1.2660 + * so just push it.
1.2661 + */
1.2662 + TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
1.2663 + varTokenPtr[1].size), envPtr);
1.2664 + } else {
1.2665 + /*
1.2666 + * Parse token is more complex, so compile it; this handles the
1.2667 + * variable reference and nested command cases. If the
1.2668 + * parse token can be byte-compiled, then this instance of
1.2669 + * "return" will be byte-compiled; otherwise it will be
1.2670 + * out line compiled.
1.2671 + */
1.2672 +#ifdef TCL_TIP280
1.2673 + envPtr->line = mapPtr->loc [eclIndex].line [1];
1.2674 +#endif
1.2675 + code = TclCompileTokens(interp, varTokenPtr+1,
1.2676 + varTokenPtr->numComponents, envPtr);
1.2677 + if (code != TCL_OK) {
1.2678 + return code;
1.2679 + }
1.2680 + }
1.2681 + break;
1.2682 + }
1.2683 + default: {
1.2684 + /*
1.2685 + * Most complex return cases: everything else, including
1.2686 + * [return -code error], etc.
1.2687 + */
1.2688 + return TCL_OUT_LINE_COMPILE;
1.2689 + }
1.2690 + }
1.2691 +
1.2692 + /*
1.2693 + * The INST_DONE opcode actually causes the branching out of the
1.2694 + * subroutine, and takes the top stack item as the return result
1.2695 + * (which is why we pushed the value above).
1.2696 + */
1.2697 + TclEmitOpcode(INST_DONE, envPtr);
1.2698 + return TCL_OK;
1.2699 +}
1.2700 +
1.2701 +/*
1.2702 + *----------------------------------------------------------------------
1.2703 + *
1.2704 + * TclCompileSetCmd --
1.2705 + *
1.2706 + * Procedure called to compile the "set" command.
1.2707 + *
1.2708 + * Results:
1.2709 + * The return value is a standard Tcl result, which is normally TCL_OK
1.2710 + * unless there was an error while parsing string. If an error occurs
1.2711 + * then the interpreter's result contains a standard error message. If
1.2712 + * complation fails because the set command requires a second level of
1.2713 + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
1.2714 + * set command should be compiled "out of line" by emitting code to
1.2715 + * invoke its command procedure (Tcl_SetCmd) at runtime.
1.2716 + *
1.2717 + * Side effects:
1.2718 + * Instructions are added to envPtr to execute the "set" command
1.2719 + * at runtime.
1.2720 + *
1.2721 + *----------------------------------------------------------------------
1.2722 + */
1.2723 +
1.2724 +int
1.2725 +TclCompileSetCmd(interp, parsePtr, envPtr)
1.2726 + Tcl_Interp *interp; /* Used for error reporting. */
1.2727 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.2728 + * command created by Tcl_ParseCommand. */
1.2729 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.2730 +{
1.2731 + Tcl_Token *varTokenPtr, *valueTokenPtr;
1.2732 + int isAssignment, isScalar, simpleVarName, localIndex, numWords;
1.2733 + int code = TCL_OK;
1.2734 +
1.2735 +#ifdef TCL_TIP280
1.2736 + /* TIP #280 : Remember the per-word line information of the current
1.2737 + * command. An index is used instead of a pointer as recursive compilation
1.2738 + * may reallocate, i.e. move, the array. This is also the reason to save
1.2739 + * the nuloc now, it may change during the course of the function.
1.2740 + */
1.2741 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.2742 + int eclIndex = mapPtr->nuloc - 1;
1.2743 +#endif
1.2744 +
1.2745 + numWords = parsePtr->numWords;
1.2746 + if ((numWords != 2) && (numWords != 3)) {
1.2747 + Tcl_ResetResult(interp);
1.2748 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.2749 + "wrong # args: should be \"set varName ?newValue?\"", -1);
1.2750 + return TCL_ERROR;
1.2751 + }
1.2752 + isAssignment = (numWords == 3);
1.2753 +
1.2754 + /*
1.2755 + * Decide if we can use a frame slot for the var/array name or if we
1.2756 + * need to emit code to compute and push the name at runtime. We use a
1.2757 + * frame slot (entry in the array of local vars) if we are compiling a
1.2758 + * procedure body and if the name is simple text that does not include
1.2759 + * namespace qualifiers.
1.2760 + */
1.2761 +
1.2762 + varTokenPtr = parsePtr->tokenPtr
1.2763 + + (parsePtr->tokenPtr->numComponents + 1);
1.2764 +
1.2765 + code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
1.2766 +#ifndef TCL_TIP280
1.2767 + &localIndex, &simpleVarName, &isScalar);
1.2768 +#else
1.2769 + &localIndex, &simpleVarName, &isScalar,
1.2770 + mapPtr->loc [eclIndex].line [1]);
1.2771 +#endif
1.2772 + if (code != TCL_OK) {
1.2773 + goto done;
1.2774 + }
1.2775 +
1.2776 + /*
1.2777 + * If we are doing an assignment, push the new value.
1.2778 + */
1.2779 +
1.2780 + if (isAssignment) {
1.2781 + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.2782 + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.2783 + TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
1.2784 + valueTokenPtr[1].size), envPtr);
1.2785 + } else {
1.2786 +#ifdef TCL_TIP280
1.2787 + envPtr->line = mapPtr->loc [eclIndex].line [2];
1.2788 +#endif
1.2789 + code = TclCompileTokens(interp, valueTokenPtr+1,
1.2790 + valueTokenPtr->numComponents, envPtr);
1.2791 + if (code != TCL_OK) {
1.2792 + goto done;
1.2793 + }
1.2794 + }
1.2795 + }
1.2796 +
1.2797 + /*
1.2798 + * Emit instructions to set/get the variable.
1.2799 + */
1.2800 +
1.2801 + if (simpleVarName) {
1.2802 + if (isScalar) {
1.2803 + if (localIndex >= 0) {
1.2804 + if (localIndex <= 255) {
1.2805 + TclEmitInstInt1((isAssignment?
1.2806 + INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
1.2807 + localIndex, envPtr);
1.2808 + } else {
1.2809 + TclEmitInstInt4((isAssignment?
1.2810 + INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
1.2811 + localIndex, envPtr);
1.2812 + }
1.2813 + } else {
1.2814 + TclEmitOpcode((isAssignment?
1.2815 + INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr);
1.2816 + }
1.2817 + } else {
1.2818 + if (localIndex >= 0) {
1.2819 + if (localIndex <= 255) {
1.2820 + TclEmitInstInt1((isAssignment?
1.2821 + INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
1.2822 + localIndex, envPtr);
1.2823 + } else {
1.2824 + TclEmitInstInt4((isAssignment?
1.2825 + INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
1.2826 + localIndex, envPtr);
1.2827 + }
1.2828 + } else {
1.2829 + TclEmitOpcode((isAssignment?
1.2830 + INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);
1.2831 + }
1.2832 + }
1.2833 + } else {
1.2834 + TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
1.2835 + }
1.2836 +
1.2837 + done:
1.2838 + return code;
1.2839 +}
1.2840 +
1.2841 +/*
1.2842 + *----------------------------------------------------------------------
1.2843 + *
1.2844 + * TclCompileStringCmd --
1.2845 + *
1.2846 + * Procedure called to compile the "string" command.
1.2847 + *
1.2848 + * Results:
1.2849 + * The return value is a standard Tcl result, which is TCL_OK if the
1.2850 + * compilation was successful. If the command cannot be byte-compiled,
1.2851 + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
1.2852 + * interpreter's result contains an error message, and TCL_ERROR is
1.2853 + * returned.
1.2854 + *
1.2855 + * Side effects:
1.2856 + * Instructions are added to envPtr to execute the "string" command
1.2857 + * at runtime.
1.2858 + *
1.2859 + *----------------------------------------------------------------------
1.2860 + */
1.2861 +
1.2862 +int
1.2863 +TclCompileStringCmd(interp, parsePtr, envPtr)
1.2864 + Tcl_Interp *interp; /* Used for error reporting. */
1.2865 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.2866 + * command created by Tcl_ParseCommand. */
1.2867 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.2868 +{
1.2869 + Tcl_Token *opTokenPtr, *varTokenPtr;
1.2870 + Tcl_Obj *opObj;
1.2871 + int index;
1.2872 + int code;
1.2873 +
1.2874 + static CONST char *options[] = {
1.2875 + "bytelength", "compare", "equal", "first",
1.2876 + "index", "is", "last", "length",
1.2877 + "map", "match", "range", "repeat",
1.2878 + "replace", "tolower", "toupper", "totitle",
1.2879 + "trim", "trimleft", "trimright",
1.2880 + "wordend", "wordstart", (char *) NULL
1.2881 + };
1.2882 + enum options {
1.2883 + STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
1.2884 + STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
1.2885 + STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
1.2886 + STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
1.2887 + STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
1.2888 + STR_WORDEND, STR_WORDSTART
1.2889 + };
1.2890 +
1.2891 +#ifdef TCL_TIP280
1.2892 + /* TIP #280 : Remember the per-word line information of the current
1.2893 + * command. An index is used instead of a pointer as recursive compilation
1.2894 + * may reallocate, i.e. move, the array. This is also the reason to save
1.2895 + * the nuloc now, it may change during the course of the function.
1.2896 + */
1.2897 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.2898 + int eclIndex = mapPtr->nuloc - 1;
1.2899 +#endif
1.2900 +
1.2901 + if (parsePtr->numWords < 2) {
1.2902 + /* Fail at run time, not in compilation */
1.2903 + return TCL_OUT_LINE_COMPILE;
1.2904 + }
1.2905 + opTokenPtr = parsePtr->tokenPtr
1.2906 + + (parsePtr->tokenPtr->numComponents + 1);
1.2907 +
1.2908 + opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size);
1.2909 + if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0,
1.2910 + &index) != TCL_OK) {
1.2911 + Tcl_DecrRefCount(opObj);
1.2912 + Tcl_ResetResult(interp);
1.2913 + return TCL_OUT_LINE_COMPILE;
1.2914 + }
1.2915 + Tcl_DecrRefCount(opObj);
1.2916 +
1.2917 + varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1);
1.2918 +
1.2919 + switch ((enum options) index) {
1.2920 + case STR_BYTELENGTH:
1.2921 + case STR_FIRST:
1.2922 + case STR_IS:
1.2923 + case STR_LAST:
1.2924 + case STR_MAP:
1.2925 + case STR_RANGE:
1.2926 + case STR_REPEAT:
1.2927 + case STR_REPLACE:
1.2928 + case STR_TOLOWER:
1.2929 + case STR_TOUPPER:
1.2930 + case STR_TOTITLE:
1.2931 + case STR_TRIM:
1.2932 + case STR_TRIMLEFT:
1.2933 + case STR_TRIMRIGHT:
1.2934 + case STR_WORDEND:
1.2935 + case STR_WORDSTART:
1.2936 + /*
1.2937 + * All other cases: compile out of line.
1.2938 + */
1.2939 + return TCL_OUT_LINE_COMPILE;
1.2940 +
1.2941 + case STR_COMPARE:
1.2942 + case STR_EQUAL: {
1.2943 + int i;
1.2944 + /*
1.2945 + * If there are any flags to the command, we can't byte compile it
1.2946 + * because the INST_STR_EQ bytecode doesn't support flags.
1.2947 + */
1.2948 +
1.2949 + if (parsePtr->numWords != 4) {
1.2950 + return TCL_OUT_LINE_COMPILE;
1.2951 + }
1.2952 +
1.2953 + /*
1.2954 + * Push the two operands onto the stack.
1.2955 + */
1.2956 +
1.2957 + for (i = 0; i < 2; i++) {
1.2958 + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.2959 + TclEmitPush(TclRegisterNewLiteral(envPtr,
1.2960 + varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
1.2961 + } else {
1.2962 +#ifdef TCL_TIP280
1.2963 + envPtr->line = mapPtr->loc [eclIndex].line [i];
1.2964 +#endif
1.2965 + code = TclCompileTokens(interp, varTokenPtr+1,
1.2966 + varTokenPtr->numComponents, envPtr);
1.2967 + if (code != TCL_OK) {
1.2968 + return code;
1.2969 + }
1.2970 + }
1.2971 + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.2972 + }
1.2973 +
1.2974 + TclEmitOpcode(((((enum options) index) == STR_COMPARE) ?
1.2975 + INST_STR_CMP : INST_STR_EQ), envPtr);
1.2976 + return TCL_OK;
1.2977 + }
1.2978 + case STR_INDEX: {
1.2979 + int i;
1.2980 +
1.2981 + if (parsePtr->numWords != 4) {
1.2982 + /* Fail at run time, not in compilation */
1.2983 + return TCL_OUT_LINE_COMPILE;
1.2984 + }
1.2985 +
1.2986 + /*
1.2987 + * Push the two operands onto the stack.
1.2988 + */
1.2989 +
1.2990 + for (i = 0; i < 2; i++) {
1.2991 + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.2992 + TclEmitPush(TclRegisterNewLiteral(envPtr,
1.2993 + varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
1.2994 + } else {
1.2995 +#ifdef TCL_TIP280
1.2996 + envPtr->line = mapPtr->loc [eclIndex].line [i];
1.2997 +#endif
1.2998 + code = TclCompileTokens(interp, varTokenPtr+1,
1.2999 + varTokenPtr->numComponents, envPtr);
1.3000 + if (code != TCL_OK) {
1.3001 + return code;
1.3002 + }
1.3003 + }
1.3004 + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.3005 + }
1.3006 +
1.3007 + TclEmitOpcode(INST_STR_INDEX, envPtr);
1.3008 + return TCL_OK;
1.3009 + }
1.3010 + case STR_LENGTH: {
1.3011 + if (parsePtr->numWords != 3) {
1.3012 + /* Fail at run time, not in compilation */
1.3013 + return TCL_OUT_LINE_COMPILE;
1.3014 + }
1.3015 +
1.3016 + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.3017 + /*
1.3018 + * Here someone is asking for the length of a static string.
1.3019 + * Just push the actual character (not byte) length.
1.3020 + */
1.3021 + char buf[TCL_INTEGER_SPACE];
1.3022 + int len = Tcl_NumUtfChars(varTokenPtr[1].start,
1.3023 + varTokenPtr[1].size);
1.3024 + len = sprintf(buf, "%d", len);
1.3025 + TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr);
1.3026 + return TCL_OK;
1.3027 + } else {
1.3028 +#ifdef TCL_TIP280
1.3029 + envPtr->line = mapPtr->loc [eclIndex].line [2];
1.3030 +#endif
1.3031 + code = TclCompileTokens(interp, varTokenPtr+1,
1.3032 + varTokenPtr->numComponents, envPtr);
1.3033 + if (code != TCL_OK) {
1.3034 + return code;
1.3035 + }
1.3036 + }
1.3037 + TclEmitOpcode(INST_STR_LEN, envPtr);
1.3038 + return TCL_OK;
1.3039 + }
1.3040 + case STR_MATCH: {
1.3041 + int i, length, exactMatch = 0, nocase = 0;
1.3042 + CONST char *str;
1.3043 +
1.3044 + if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
1.3045 + /* Fail at run time, not in compilation */
1.3046 + return TCL_OUT_LINE_COMPILE;
1.3047 + }
1.3048 +
1.3049 + if (parsePtr->numWords == 5) {
1.3050 + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1.3051 + return TCL_OUT_LINE_COMPILE;
1.3052 + }
1.3053 + str = varTokenPtr[1].start;
1.3054 + length = varTokenPtr[1].size;
1.3055 + if ((length > 1) &&
1.3056 + strncmp(str, "-nocase", (size_t) length) == 0) {
1.3057 + nocase = 1;
1.3058 + } else {
1.3059 + /* Fail at run time, not in compilation */
1.3060 + return TCL_OUT_LINE_COMPILE;
1.3061 + }
1.3062 + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.3063 + }
1.3064 +
1.3065 + for (i = 0; i < 2; i++) {
1.3066 + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.3067 + str = varTokenPtr[1].start;
1.3068 + length = varTokenPtr[1].size;
1.3069 + if (!nocase && (i == 0)) {
1.3070 + /*
1.3071 + * On the first (pattern) arg, check to see if any
1.3072 + * glob special characters are in the word '*[]?\\'.
1.3073 + * If not, this is the same as 'string equal'. We
1.3074 + * can use strpbrk here because the glob chars are all
1.3075 + * in the ascii-7 range. If -nocase was specified,
1.3076 + * we can't do this because INST_STR_EQ has no support
1.3077 + * for nocase.
1.3078 + */
1.3079 + Tcl_Obj *copy = Tcl_NewStringObj(str, length);
1.3080 + Tcl_IncrRefCount(copy);
1.3081 + exactMatch = (strpbrk(Tcl_GetString(copy),
1.3082 + "*[]?\\") == NULL);
1.3083 + Tcl_DecrRefCount(copy);
1.3084 + }
1.3085 + TclEmitPush(
1.3086 + TclRegisterNewLiteral(envPtr, str, length), envPtr);
1.3087 + } else {
1.3088 +#ifdef TCL_TIP280
1.3089 + envPtr->line = mapPtr->loc [eclIndex].line [i];
1.3090 +#endif
1.3091 + code = TclCompileTokens(interp, varTokenPtr+1,
1.3092 + varTokenPtr->numComponents, envPtr);
1.3093 + if (code != TCL_OK) {
1.3094 + return code;
1.3095 + }
1.3096 + }
1.3097 + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.3098 + }
1.3099 +
1.3100 + if (exactMatch) {
1.3101 + TclEmitOpcode(INST_STR_EQ, envPtr);
1.3102 + } else {
1.3103 + TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
1.3104 + }
1.3105 + return TCL_OK;
1.3106 + }
1.3107 + }
1.3108 +
1.3109 + return TCL_OK;
1.3110 +}
1.3111 +
1.3112 +/*
1.3113 + *----------------------------------------------------------------------
1.3114 + *
1.3115 + * TclCompileVariableCmd --
1.3116 + *
1.3117 + * Procedure called to reserve the local variables for the
1.3118 + * "variable" command. The command itself is *not* compiled.
1.3119 + *
1.3120 + * Results:
1.3121 + * Always returns TCL_OUT_LINE_COMPILE.
1.3122 + *
1.3123 + * Side effects:
1.3124 + * Indexed local variables are added to the environment.
1.3125 + *
1.3126 + *----------------------------------------------------------------------
1.3127 + */
1.3128 +int
1.3129 +TclCompileVariableCmd(interp, parsePtr, envPtr)
1.3130 + Tcl_Interp *interp; /* Used for error reporting. */
1.3131 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.3132 + * command created by Tcl_ParseCommand. */
1.3133 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.3134 +{
1.3135 + Tcl_Token *varTokenPtr;
1.3136 + int i, numWords;
1.3137 + CONST char *varName, *tail;
1.3138 +
1.3139 + if (envPtr->procPtr == NULL) {
1.3140 + return TCL_OUT_LINE_COMPILE;
1.3141 + }
1.3142 +
1.3143 + numWords = parsePtr->numWords;
1.3144 +
1.3145 + varTokenPtr = parsePtr->tokenPtr
1.3146 + + (parsePtr->tokenPtr->numComponents + 1);
1.3147 + for (i = 1; i < numWords; i += 2) {
1.3148 + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.3149 + varName = varTokenPtr[1].start;
1.3150 + tail = varName + varTokenPtr[1].size - 1;
1.3151 + if ((*tail == ')') || (tail < varName)) continue;
1.3152 + while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
1.3153 + tail--;
1.3154 + }
1.3155 + if ((*tail == ':') && (tail > varName)) {
1.3156 + tail++;
1.3157 + }
1.3158 + (void) TclFindCompiledLocal(tail, (tail-varName+1),
1.3159 + /*create*/ 1, /*flags*/ 0, envPtr->procPtr);
1.3160 + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
1.3161 + }
1.3162 + }
1.3163 + return TCL_OUT_LINE_COMPILE;
1.3164 +}
1.3165 +
1.3166 +/*
1.3167 + *----------------------------------------------------------------------
1.3168 + *
1.3169 + * TclCompileWhileCmd --
1.3170 + *
1.3171 + * Procedure called to compile the "while" command.
1.3172 + *
1.3173 + * Results:
1.3174 + * The return value is a standard Tcl result, which is TCL_OK if
1.3175 + * compilation was successful. If an error occurs then the
1.3176 + * interpreter's result contains a standard error message and TCL_ERROR
1.3177 + * is returned. If compilation failed because the command is too
1.3178 + * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned
1.3179 + * indicating that the while command should be compiled "out of line"
1.3180 + * by emitting code to invoke its command procedure at runtime.
1.3181 + *
1.3182 + * Side effects:
1.3183 + * Instructions are added to envPtr to execute the "while" command
1.3184 + * at runtime.
1.3185 + *
1.3186 + *----------------------------------------------------------------------
1.3187 + */
1.3188 +
1.3189 +int
1.3190 +TclCompileWhileCmd(interp, parsePtr, envPtr)
1.3191 + Tcl_Interp *interp; /* Used for error reporting. */
1.3192 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.3193 + * command created by Tcl_ParseCommand. */
1.3194 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.3195 +{
1.3196 + Tcl_Token *testTokenPtr, *bodyTokenPtr;
1.3197 + JumpFixup jumpEvalCondFixup;
1.3198 + int testCodeOffset, bodyCodeOffset, jumpDist;
1.3199 + int range, code;
1.3200 + char buffer[32 + TCL_INTEGER_SPACE];
1.3201 + int savedStackDepth = envPtr->currStackDepth;
1.3202 + int loopMayEnd = 1; /* This is set to 0 if it is recognized as
1.3203 + * an infinite loop. */
1.3204 + Tcl_Obj *boolObj;
1.3205 + int boolVal;
1.3206 +
1.3207 +#ifdef TCL_TIP280
1.3208 + /* TIP #280 : Remember the per-word line information of the current
1.3209 + * command. An index is used instead of a pointer as recursive compilation
1.3210 + * may reallocate, i.e. move, the array. This is also the reason to save
1.3211 + * the nuloc now, it may change during the course of the function.
1.3212 + */
1.3213 + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
1.3214 + int eclIndex = mapPtr->nuloc - 1;
1.3215 +#endif
1.3216 +
1.3217 + if (parsePtr->numWords != 3) {
1.3218 + Tcl_ResetResult(interp);
1.3219 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.3220 + "wrong # args: should be \"while test command\"", -1);
1.3221 + return TCL_ERROR;
1.3222 + }
1.3223 +
1.3224 + /*
1.3225 + * If the test expression requires substitutions, don't compile the
1.3226 + * while command inline. E.g., the expression might cause the loop to
1.3227 + * never execute or execute forever, as in "while "$x < 5" {}".
1.3228 + *
1.3229 + * Bail out also if the body expression requires substitutions
1.3230 + * in order to insure correct behaviour [Bug 219166]
1.3231 + */
1.3232 +
1.3233 + testTokenPtr = parsePtr->tokenPtr
1.3234 + + (parsePtr->tokenPtr->numComponents + 1);
1.3235 + bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
1.3236 + if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
1.3237 + || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
1.3238 + return TCL_OUT_LINE_COMPILE;
1.3239 + }
1.3240 +
1.3241 + /*
1.3242 + * Find out if the condition is a constant.
1.3243 + */
1.3244 +
1.3245 + boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
1.3246 + Tcl_IncrRefCount(boolObj);
1.3247 + code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
1.3248 + Tcl_DecrRefCount(boolObj);
1.3249 + if (code == TCL_OK) {
1.3250 + if (boolVal) {
1.3251 + /*
1.3252 + * it is an infinite loop
1.3253 + */
1.3254 +
1.3255 + loopMayEnd = 0;
1.3256 + } else {
1.3257 + /*
1.3258 + * This is an empty loop: "while 0 {...}" or such.
1.3259 + * Compile no bytecodes.
1.3260 + */
1.3261 +
1.3262 + goto pushResult;
1.3263 + }
1.3264 + }
1.3265 +
1.3266 + /*
1.3267 + * Create a ExceptionRange record for the loop body. This is used to
1.3268 + * implement break and continue.
1.3269 + */
1.3270 +
1.3271 + envPtr->exceptDepth++;
1.3272 + envPtr->maxExceptDepth =
1.3273 + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
1.3274 + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
1.3275 +
1.3276 + /*
1.3277 + * Jump to the evaluation of the condition. This code uses the "loop
1.3278 + * rotation" optimisation (which eliminates one branch from the loop).
1.3279 + * "while cond body" produces then:
1.3280 + * goto A
1.3281 + * B: body : bodyCodeOffset
1.3282 + * A: cond -> result : testCodeOffset, continueOffset
1.3283 + * if (result) goto B
1.3284 + *
1.3285 + * The infinite loop "while 1 body" produces:
1.3286 + * B: body : all three offsets here
1.3287 + * goto B
1.3288 + */
1.3289 +
1.3290 + if (loopMayEnd) {
1.3291 + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
1.3292 + testCodeOffset = 0; /* avoid compiler warning */
1.3293 + } else {
1.3294 + testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
1.3295 + }
1.3296 +
1.3297 +
1.3298 + /*
1.3299 + * Compile the loop body.
1.3300 + */
1.3301 +
1.3302 +#ifdef TCL_TIP280
1.3303 + envPtr->line = mapPtr->loc [eclIndex].line [2];
1.3304 +#endif
1.3305 + bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
1.3306 + code = TclCompileCmdWord(interp, bodyTokenPtr+1,
1.3307 + bodyTokenPtr->numComponents, envPtr);
1.3308 + envPtr->currStackDepth = savedStackDepth + 1;
1.3309 + if (code != TCL_OK) {
1.3310 + if (code == TCL_ERROR) {
1.3311 + sprintf(buffer, "\n (\"while\" body line %d)",
1.3312 + interp->errorLine);
1.3313 + Tcl_AddObjErrorInfo(interp, buffer, -1);
1.3314 + }
1.3315 + goto error;
1.3316 + }
1.3317 + envPtr->exceptArrayPtr[range].numCodeBytes =
1.3318 + (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
1.3319 + TclEmitOpcode(INST_POP, envPtr);
1.3320 +
1.3321 + /*
1.3322 + * Compile the test expression then emit the conditional jump that
1.3323 + * terminates the while. We already know it's a simple word.
1.3324 + */
1.3325 +
1.3326 + if (loopMayEnd) {
1.3327 + testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
1.3328 + jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
1.3329 + if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
1.3330 + bodyCodeOffset += 3;
1.3331 + testCodeOffset += 3;
1.3332 + }
1.3333 + envPtr->currStackDepth = savedStackDepth;
1.3334 +#ifdef TCL_TIP280
1.3335 + envPtr->line = mapPtr->loc [eclIndex].line [1];
1.3336 +#endif
1.3337 + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
1.3338 + if (code != TCL_OK) {
1.3339 + if (code == TCL_ERROR) {
1.3340 + Tcl_AddObjErrorInfo(interp,
1.3341 + "\n (\"while\" test expression)", -1);
1.3342 + }
1.3343 + goto error;
1.3344 + }
1.3345 + envPtr->currStackDepth = savedStackDepth + 1;
1.3346 +
1.3347 + jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
1.3348 + if (jumpDist > 127) {
1.3349 + TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
1.3350 + } else {
1.3351 + TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
1.3352 + }
1.3353 + } else {
1.3354 + jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
1.3355 + if (jumpDist > 127) {
1.3356 + TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
1.3357 + } else {
1.3358 + TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
1.3359 + }
1.3360 + }
1.3361 +
1.3362 +
1.3363 + /*
1.3364 + * Set the loop's body, continue and break offsets.
1.3365 + */
1.3366 +
1.3367 + envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
1.3368 + envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
1.3369 + envPtr->exceptArrayPtr[range].breakOffset =
1.3370 + (envPtr->codeNext - envPtr->codeStart);
1.3371 +
1.3372 + /*
1.3373 + * The while command's result is an empty string.
1.3374 + */
1.3375 +
1.3376 + pushResult:
1.3377 + envPtr->currStackDepth = savedStackDepth;
1.3378 + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
1.3379 + envPtr->exceptDepth--;
1.3380 + return TCL_OK;
1.3381 +
1.3382 + error:
1.3383 + envPtr->exceptDepth--;
1.3384 + return code;
1.3385 +}
1.3386 +
1.3387 +/*
1.3388 + *----------------------------------------------------------------------
1.3389 + *
1.3390 + * TclPushVarName --
1.3391 + *
1.3392 + * Procedure used in the compiling where pushing a variable name
1.3393 + * is necessary (append, lappend, set).
1.3394 + *
1.3395 + * Results:
1.3396 + * The return value is a standard Tcl result, which is normally TCL_OK
1.3397 + * unless there was an error while parsing string. If an error occurs
1.3398 + * then the interpreter's result contains a standard error message.
1.3399 + *
1.3400 + * Side effects:
1.3401 + * Instructions are added to envPtr to execute the "set" command
1.3402 + * at runtime.
1.3403 + *
1.3404 + *----------------------------------------------------------------------
1.3405 + */
1.3406 +
1.3407 +static int
1.3408 +TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
1.3409 +#ifndef TCL_TIP280
1.3410 + simpleVarNamePtr, isScalarPtr)
1.3411 +#else
1.3412 + simpleVarNamePtr, isScalarPtr, line)
1.3413 +#endif
1.3414 + Tcl_Interp *interp; /* Used for error reporting. */
1.3415 + Tcl_Token *varTokenPtr; /* Points to a variable token. */
1.3416 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.3417 + int flags; /* takes TCL_CREATE_VAR or
1.3418 + * TCL_NO_LARGE_INDEX */
1.3419 + int *localIndexPtr; /* must not be NULL */
1.3420 + int *simpleVarNamePtr; /* must not be NULL */
1.3421 + int *isScalarPtr; /* must not be NULL */
1.3422 +#ifdef TCL_TIP280
1.3423 + int line; /* line the token starts on */
1.3424 +#endif
1.3425 +{
1.3426 + register CONST char *p;
1.3427 + CONST char *name, *elName;
1.3428 + register int i, n;
1.3429 + int nameChars, elNameChars, simpleVarName, localIndex;
1.3430 + int code = TCL_OK;
1.3431 +
1.3432 + Tcl_Token *elemTokenPtr = NULL;
1.3433 + int elemTokenCount = 0;
1.3434 + int allocedTokens = 0;
1.3435 + int removedParen = 0;
1.3436 +
1.3437 + /*
1.3438 + * Decide if we can use a frame slot for the var/array name or if we
1.3439 + * need to emit code to compute and push the name at runtime. We use a
1.3440 + * frame slot (entry in the array of local vars) if we are compiling a
1.3441 + * procedure body and if the name is simple text that does not include
1.3442 + * namespace qualifiers.
1.3443 + */
1.3444 +
1.3445 + simpleVarName = 0;
1.3446 + name = elName = NULL;
1.3447 + nameChars = elNameChars = 0;
1.3448 + localIndex = -1;
1.3449 +
1.3450 + /*
1.3451 + * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
1.3452 + * curly braces surround the variable name.
1.3453 + * This really matters for array elements to handle things like
1.3454 + * set {x($foo)} 5
1.3455 + * which raises an undefined var error if we are not careful here.
1.3456 + */
1.3457 +
1.3458 + if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
1.3459 + (varTokenPtr->start[0] != '{')) {
1.3460 + /*
1.3461 + * A simple variable name. Divide it up into "name" and "elName"
1.3462 + * strings. If it is not a local variable, look it up at runtime.
1.3463 + */
1.3464 + simpleVarName = 1;
1.3465 +
1.3466 + name = varTokenPtr[1].start;
1.3467 + nameChars = varTokenPtr[1].size;
1.3468 + if ( *(name + nameChars - 1) == ')') {
1.3469 + /*
1.3470 + * last char is ')' => potential array reference.
1.3471 + */
1.3472 +
1.3473 + for (i = 0, p = name; i < nameChars; i++, p++) {
1.3474 + if (*p == '(') {
1.3475 + elName = p + 1;
1.3476 + elNameChars = nameChars - i - 2;
1.3477 + nameChars = i ;
1.3478 + break;
1.3479 + }
1.3480 + }
1.3481 +
1.3482 + if ((elName != NULL) && elNameChars) {
1.3483 + /*
1.3484 + * An array element, the element name is a simple
1.3485 + * string: assemble the corresponding token.
1.3486 + */
1.3487 +
1.3488 + elemTokenPtr = (Tcl_Token *) ckalloc(sizeof(Tcl_Token));
1.3489 + allocedTokens = 1;
1.3490 + elemTokenPtr->type = TCL_TOKEN_TEXT;
1.3491 + elemTokenPtr->start = elName;
1.3492 + elemTokenPtr->size = elNameChars;
1.3493 + elemTokenPtr->numComponents = 0;
1.3494 + elemTokenCount = 1;
1.3495 + }
1.3496 + }
1.3497 + } else if (((n = varTokenPtr->numComponents) > 1)
1.3498 + && (varTokenPtr[1].type == TCL_TOKEN_TEXT)
1.3499 + && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
1.3500 + && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
1.3501 +
1.3502 + /*
1.3503 + * Check for parentheses inside first token
1.3504 + */
1.3505 +
1.3506 + simpleVarName = 0;
1.3507 + for (i = 0, p = varTokenPtr[1].start;
1.3508 + i < varTokenPtr[1].size; i++, p++) {
1.3509 + if (*p == '(') {
1.3510 + simpleVarName = 1;
1.3511 + break;
1.3512 + }
1.3513 + }
1.3514 + if (simpleVarName) {
1.3515 + int remainingChars;
1.3516 +
1.3517 + /*
1.3518 + * Check the last token: if it is just ')', do not count
1.3519 + * it. Otherwise, remove the ')' and flag so that it is
1.3520 + * restored at the end.
1.3521 + */
1.3522 +
1.3523 + if (varTokenPtr[n].size == 1) {
1.3524 + --n;
1.3525 + } else {
1.3526 + --varTokenPtr[n].size;
1.3527 + removedParen = n;
1.3528 + }
1.3529 +
1.3530 + name = varTokenPtr[1].start;
1.3531 + nameChars = p - varTokenPtr[1].start;
1.3532 + elName = p + 1;
1.3533 + remainingChars = (varTokenPtr[2].start - p) - 1;
1.3534 + elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;
1.3535 +
1.3536 + if (remainingChars) {
1.3537 + /*
1.3538 + * Make a first token with the extra characters in the first
1.3539 + * token.
1.3540 + */
1.3541 +
1.3542 + elemTokenPtr = (Tcl_Token *) ckalloc(n * sizeof(Tcl_Token));
1.3543 + allocedTokens = 1;
1.3544 + elemTokenPtr->type = TCL_TOKEN_TEXT;
1.3545 + elemTokenPtr->start = elName;
1.3546 + elemTokenPtr->size = remainingChars;
1.3547 + elemTokenPtr->numComponents = 0;
1.3548 + elemTokenCount = n;
1.3549 +
1.3550 + /*
1.3551 + * Copy the remaining tokens.
1.3552 + */
1.3553 +
1.3554 + memcpy((void *) (elemTokenPtr+1), (void *) (&varTokenPtr[2]),
1.3555 + ((n-1) * sizeof(Tcl_Token)));
1.3556 + } else {
1.3557 + /*
1.3558 + * Use the already available tokens.
1.3559 + */
1.3560 +
1.3561 + elemTokenPtr = &varTokenPtr[2];
1.3562 + elemTokenCount = n - 1;
1.3563 + }
1.3564 + }
1.3565 + }
1.3566 +
1.3567 + if (simpleVarName) {
1.3568 + /*
1.3569 + * See whether name has any namespace separators (::'s).
1.3570 + */
1.3571 +
1.3572 + int hasNsQualifiers = 0;
1.3573 + for (i = 0, p = name; i < nameChars; i++, p++) {
1.3574 + if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
1.3575 + hasNsQualifiers = 1;
1.3576 + break;
1.3577 + }
1.3578 + }
1.3579 +
1.3580 + /*
1.3581 + * Look up the var name's index in the array of local vars in the
1.3582 + * proc frame. If retrieving the var's value and it doesn't already
1.3583 + * exist, push its name and look it up at runtime.
1.3584 + */
1.3585 +
1.3586 + if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
1.3587 + localIndex = TclFindCompiledLocal(name, nameChars,
1.3588 + /*create*/ (flags & TCL_CREATE_VAR),
1.3589 + /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
1.3590 + envPtr->procPtr);
1.3591 + if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
1.3592 + /* we'll push the name */
1.3593 + localIndex = -1;
1.3594 + }
1.3595 + }
1.3596 + if (localIndex < 0) {
1.3597 + TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr);
1.3598 + }
1.3599 +
1.3600 + /*
1.3601 + * Compile the element script, if any.
1.3602 + */
1.3603 +
1.3604 + if (elName != NULL) {
1.3605 + if (elNameChars) {
1.3606 +#ifdef TCL_TIP280
1.3607 + envPtr->line = line;
1.3608 +#endif
1.3609 + code = TclCompileTokens(interp, elemTokenPtr,
1.3610 + elemTokenCount, envPtr);
1.3611 + if (code != TCL_OK) {
1.3612 + goto done;
1.3613 + }
1.3614 + } else {
1.3615 + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
1.3616 + }
1.3617 + }
1.3618 + } else {
1.3619 + /*
1.3620 + * The var name isn't simple: compile and push it.
1.3621 + */
1.3622 +
1.3623 +#ifdef TCL_TIP280
1.3624 + envPtr->line = line;
1.3625 +#endif
1.3626 + code = TclCompileTokens(interp, varTokenPtr+1,
1.3627 + varTokenPtr->numComponents, envPtr);
1.3628 + if (code != TCL_OK) {
1.3629 + goto done;
1.3630 + }
1.3631 + }
1.3632 +
1.3633 + done:
1.3634 + if (removedParen) {
1.3635 + ++varTokenPtr[removedParen].size;
1.3636 + }
1.3637 + if (allocedTokens) {
1.3638 + ckfree((char *) elemTokenPtr);
1.3639 + }
1.3640 + *localIndexPtr = localIndex;
1.3641 + *simpleVarNamePtr = simpleVarName;
1.3642 + *isScalarPtr = (elName == NULL);
1.3643 + return code;
1.3644 +}
1.3645 +
1.3646 +/*
1.3647 + * Local Variables:
1.3648 + * mode: c
1.3649 + * c-basic-offset: 4
1.3650 + * fill-column: 78
1.3651 + * End:
1.3652 + */
1.3653 +