sl@0: /*
sl@0: * tclCompCmds.c --
sl@0: *
sl@0: * This file contains compilation procedures that compile various
sl@0: * Tcl commands into a sequence of instructions ("bytecodes").
sl@0: *
sl@0: * Copyright (c) 1997-1998 Sun Microsystems, Inc.
sl@0: * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
sl@0: * Copyright (c) 2002 ActiveState Corporation.
sl@0: *
sl@0: * See the file "license.terms" for information on usage and redistribution
sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0: *
sl@0: * RCS: @(#) $Id: tclCompCmds.c,v 1.39.2.6 2007/03/01 16:06:19 dkf Exp $
sl@0: */
sl@0:
sl@0: #include "tclInt.h"
sl@0: #include "tclCompile.h"
sl@0:
sl@0: /*
sl@0: * Prototypes for procedures defined later in this file:
sl@0: */
sl@0:
sl@0: static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
sl@0: static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData));
sl@0: #ifndef TCL_TIP280
sl@0: static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
sl@0: int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr));
sl@0: #else
sl@0: static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
sl@0: int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr,
sl@0: int line));
sl@0: #endif
sl@0:
sl@0: /*
sl@0: * Flags bits used by TclPushVarName.
sl@0: */
sl@0:
sl@0: #define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */
sl@0: #define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */
sl@0:
sl@0: /*
sl@0: * The structures below define the AuxData types defined in this file.
sl@0: */
sl@0:
sl@0: AuxDataType tclForeachInfoType = {
sl@0: "ForeachInfo", /* name */
sl@0: DupForeachInfo, /* dupProc */
sl@0: FreeForeachInfo /* freeProc */
sl@0: };
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileAppendCmd --
sl@0: *
sl@0: * Procedure called to compile the "append" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is normally TCL_OK
sl@0: * unless there was an error while parsing string. If an error occurs
sl@0: * then the interpreter's result contains a standard error message. If
sl@0: * complation fails because the command requires a second level of
sl@0: * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
sl@0: * command should be compiled "out of line" by emitting code to
sl@0: * invoke its command procedure (Tcl_AppendObjCmd) at runtime.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "append" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileAppendCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Tcl_Token *varTokenPtr, *valueTokenPtr;
sl@0: int simpleVarName, isScalar, localIndex, numWords;
sl@0: int code = TCL_OK;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: numWords = parsePtr->numWords;
sl@0: if (numWords == 1) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: should be \"append varName ?value value ...?\"",
sl@0: -1);
sl@0: return TCL_ERROR;
sl@0: } else if (numWords == 2) {
sl@0: /*
sl@0: * append varName === set varName
sl@0: */
sl@0: return TclCompileSetCmd(interp, parsePtr, envPtr);
sl@0: } else if (numWords > 3) {
sl@0: /*
sl@0: * APPEND instructions currently only handle one value
sl@0: */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Decide if we can use a frame slot for the var/array name or if we
sl@0: * need to emit code to compute and push the name at runtime. We use a
sl@0: * frame slot (entry in the array of local vars) if we are compiling a
sl@0: * procedure body and if the name is simple text that does not include
sl@0: * namespace qualifiers.
sl@0: */
sl@0:
sl@0: varTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0:
sl@0: code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
sl@0: #ifndef TCL_TIP280
sl@0: &localIndex, &simpleVarName, &isScalar);
sl@0: #else
sl@0: &localIndex, &simpleVarName, &isScalar,
sl@0: mapPtr->loc [eclIndex].line [1]);
sl@0: #endif
sl@0: if (code != TCL_OK) {
sl@0: goto done;
sl@0: }
sl@0:
sl@0: /*
sl@0: * We are doing an assignment, otherwise TclCompileSetCmd was called,
sl@0: * so push the new value. This will need to be extended to push a
sl@0: * value for each argument.
sl@0: */
sl@0:
sl@0: if (numWords > 2) {
sl@0: valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr,
sl@0: valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, valueTokenPtr+1,
sl@0: valueTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: goto done;
sl@0: }
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Emit instructions to set/get the variable.
sl@0: */
sl@0:
sl@0: if (simpleVarName) {
sl@0: if (isScalar) {
sl@0: if (localIndex >= 0) {
sl@0: if (localIndex <= 255) {
sl@0: TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
sl@0: }
sl@0: } else {
sl@0: TclEmitOpcode(INST_APPEND_STK, envPtr);
sl@0: }
sl@0: } else {
sl@0: if (localIndex >= 0) {
sl@0: if (localIndex <= 255) {
sl@0: TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
sl@0: }
sl@0: } else {
sl@0: TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
sl@0: }
sl@0: }
sl@0: } else {
sl@0: TclEmitOpcode(INST_APPEND_STK, envPtr);
sl@0: }
sl@0:
sl@0: done:
sl@0: return code;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileBreakCmd --
sl@0: *
sl@0: * Procedure called to compile the "break" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK unless
sl@0: * there was an error during compilation. If an error occurs then
sl@0: * the interpreter's result contains a standard error message.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "break" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileBreakCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: if (parsePtr->numWords != 1) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: should be \"break\"", -1);
sl@0: return TCL_ERROR;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Emit a break instruction.
sl@0: */
sl@0:
sl@0: TclEmitOpcode(INST_BREAK, envPtr);
sl@0: return TCL_OK;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileCatchCmd --
sl@0: *
sl@0: * Procedure called to compile the "catch" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK if
sl@0: * compilation was successful. If an error occurs then the
sl@0: * interpreter's result contains a standard error message and TCL_ERROR
sl@0: * is returned. If the command is too complex for TclCompileCatchCmd,
sl@0: * TCL_OUT_LINE_COMPILE is returned indicating that the catch command
sl@0: * should be compiled "out of line" by emitting code to invoke its
sl@0: * command procedure at runtime.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "catch" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileCatchCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: JumpFixup jumpFixup;
sl@0: Tcl_Token *cmdTokenPtr, *nameTokenPtr;
sl@0: CONST char *name;
sl@0: int localIndex, nameChars, range, startOffset, jumpDist;
sl@0: int code;
sl@0: int savedStackDepth = envPtr->currStackDepth;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: should be \"catch command ?varName?\"", -1);
sl@0: return TCL_ERROR;
sl@0: }
sl@0:
sl@0: /*
sl@0: * If a variable was specified and the catch command is at global level
sl@0: * (not in a procedure), don't compile it inline: the payoff is
sl@0: * too small.
sl@0: */
sl@0:
sl@0: if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Make sure the variable name, if any, has no substitutions and just
sl@0: * refers to a local scaler.
sl@0: */
sl@0:
sl@0: localIndex = -1;
sl@0: cmdTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0: if (parsePtr->numWords == 3) {
sl@0: nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1);
sl@0: if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: name = nameTokenPtr[1].start;
sl@0: nameChars = nameTokenPtr[1].size;
sl@0: if (!TclIsLocalScalar(name, nameChars)) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0: localIndex = TclFindCompiledLocal(nameTokenPtr[1].start,
sl@0: nameTokenPtr[1].size, /*create*/ 1,
sl@0: /*flags*/ VAR_SCALAR, envPtr->procPtr);
sl@0: } else {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * We will compile the catch command. Emit a beginCatch instruction at
sl@0: * the start of the catch body: the subcommand it controls.
sl@0: */
sl@0:
sl@0: envPtr->exceptDepth++;
sl@0: envPtr->maxExceptDepth =
sl@0: TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
sl@0: range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
sl@0: TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
sl@0:
sl@0: /*
sl@0: * If the body is a simple word, compile the instructions to
sl@0: * eval it. Otherwise, compile instructions to substitute its
sl@0: * text without catching, a catch instruction that resets the
sl@0: * stack to what it was before substituting the body, and then
sl@0: * an instruction to eval the body. Care has to be taken to
sl@0: * register the correct startOffset for the catch range so that
sl@0: * errors in the substitution are not catched [Bug 219184]
sl@0: */
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [1];
sl@0: #endif
sl@0: if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: startOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0: code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr);
sl@0: } else {
sl@0: code = TclCompileTokens(interp, cmdTokenPtr+1,
sl@0: cmdTokenPtr->numComponents, envPtr);
sl@0: startOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0: TclEmitOpcode(INST_EVAL_STK, envPtr);
sl@0: }
sl@0: envPtr->exceptArrayPtr[range].codeOffset = startOffset;
sl@0:
sl@0: if (code != TCL_OK) {
sl@0: code = TCL_OUT_LINE_COMPILE;
sl@0: goto done;
sl@0: }
sl@0: envPtr->exceptArrayPtr[range].numCodeBytes =
sl@0: (envPtr->codeNext - envPtr->codeStart) - startOffset;
sl@0:
sl@0: /*
sl@0: * The "no errors" epilogue code: store the body's result into the
sl@0: * variable (if any), push "0" (TCL_OK) as the catch's "no error"
sl@0: * result, and jump around the "error case" code.
sl@0: */
sl@0:
sl@0: if (localIndex != -1) {
sl@0: if (localIndex <= 255) {
sl@0: TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
sl@0: }
sl@0: }
sl@0: TclEmitOpcode(INST_POP, envPtr);
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
sl@0: TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
sl@0:
sl@0: /*
sl@0: * The "error case" code: store the body's result into the variable (if
sl@0: * any), then push the error result code. The initial PC offset here is
sl@0: * the catch's error target.
sl@0: */
sl@0:
sl@0: envPtr->currStackDepth = savedStackDepth;
sl@0: envPtr->exceptArrayPtr[range].catchOffset =
sl@0: (envPtr->codeNext - envPtr->codeStart);
sl@0: if (localIndex != -1) {
sl@0: TclEmitOpcode(INST_PUSH_RESULT, envPtr);
sl@0: if (localIndex <= 255) {
sl@0: TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
sl@0: }
sl@0: TclEmitOpcode(INST_POP, envPtr);
sl@0: }
sl@0: TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
sl@0:
sl@0:
sl@0: /*
sl@0: * Update the target of the jump after the "no errors" code, then emit
sl@0: * an endCatch instruction at the end of the catch command.
sl@0: */
sl@0:
sl@0: jumpDist = (envPtr->codeNext - envPtr->codeStart)
sl@0: - jumpFixup.codeOffset;
sl@0: if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
sl@0: panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);
sl@0: }
sl@0: TclEmitOpcode(INST_END_CATCH, envPtr);
sl@0:
sl@0: done:
sl@0: envPtr->currStackDepth = savedStackDepth + 1;
sl@0: envPtr->exceptDepth--;
sl@0: return code;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileContinueCmd --
sl@0: *
sl@0: * Procedure called to compile the "continue" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK unless
sl@0: * there was an error while parsing string. If an error occurs then
sl@0: * the interpreter's result contains a standard error message.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "continue" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileContinueCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: /*
sl@0: * There should be no argument after the "continue".
sl@0: */
sl@0:
sl@0: if (parsePtr->numWords != 1) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: should be \"continue\"", -1);
sl@0: return TCL_ERROR;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Emit a continue instruction.
sl@0: */
sl@0:
sl@0: TclEmitOpcode(INST_CONTINUE, envPtr);
sl@0: return TCL_OK;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileExprCmd --
sl@0: *
sl@0: * Procedure called to compile the "expr" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK
sl@0: * unless there was an error while parsing string. If an error occurs
sl@0: * then the interpreter's result contains a standard error message.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "expr" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileExprCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Tcl_Token *firstWordPtr;
sl@0:
sl@0: if (parsePtr->numWords == 1) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: should be \"expr arg ?arg ...?\"", -1);
sl@0: return TCL_ERROR;
sl@0: }
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Use the per-word line information of the current command.
sl@0: */
sl@0: envPtr->line = envPtr->extCmdMapPtr->loc [envPtr->extCmdMapPtr->nuloc - 1].line [1];
sl@0: #endif
sl@0: firstWordPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0: return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1),
sl@0: envPtr);
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileForCmd --
sl@0: *
sl@0: * Procedure called to compile the "for" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK unless
sl@0: * there was an error while parsing string. If an error occurs then
sl@0: * the interpreter's result contains a standard error message.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "for" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0: int
sl@0: TclCompileForCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
sl@0: JumpFixup jumpEvalCondFixup;
sl@0: int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
sl@0: int bodyRange, nextRange, code;
sl@0: char buffer[32 + TCL_INTEGER_SPACE];
sl@0: int savedStackDepth = envPtr->currStackDepth;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: if (parsePtr->numWords != 5) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: should be \"for start test next command\"", -1);
sl@0: return TCL_ERROR;
sl@0: }
sl@0:
sl@0: /*
sl@0: * If the test expression requires substitutions, don't compile the for
sl@0: * command inline. E.g., the expression might cause the loop to never
sl@0: * execute or execute forever, as in "for {} "$x > 5" {incr x} {}".
sl@0: */
sl@0:
sl@0: startTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0: testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1);
sl@0: if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Bail out also if the body or the next expression require substitutions
sl@0: * in order to insure correct behaviour [Bug 219166]
sl@0: */
sl@0:
sl@0: nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
sl@0: bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1);
sl@0: if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
sl@0: || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Create ExceptionRange records for the body and the "next" command.
sl@0: * The "next" command's ExceptionRange supports break but not continue
sl@0: * (and has a -1 continueOffset).
sl@0: */
sl@0:
sl@0: envPtr->exceptDepth++;
sl@0: envPtr->maxExceptDepth =
sl@0: TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
sl@0: bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
sl@0: nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
sl@0:
sl@0: /*
sl@0: * Inline compile the initial command.
sl@0: */
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [1];
sl@0: #endif
sl@0: code = TclCompileCmdWord(interp, startTokenPtr+1,
sl@0: startTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: if (code == TCL_ERROR) {
sl@0: Tcl_AddObjErrorInfo(interp,
sl@0: "\n (\"for\" initial command)", -1);
sl@0: }
sl@0: goto done;
sl@0: }
sl@0: TclEmitOpcode(INST_POP, envPtr);
sl@0:
sl@0: /*
sl@0: * Jump to the evaluation of the condition. This code uses the "loop
sl@0: * rotation" optimisation (which eliminates one branch from the loop).
sl@0: * "for start cond next body" produces then:
sl@0: * start
sl@0: * goto A
sl@0: * B: body : bodyCodeOffset
sl@0: * next : nextCodeOffset, continueOffset
sl@0: * A: cond -> result : testCodeOffset
sl@0: * if (result) goto B
sl@0: */
sl@0:
sl@0: TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
sl@0:
sl@0: /*
sl@0: * Compile the loop body.
sl@0: */
sl@0:
sl@0: bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [4];
sl@0: #endif
sl@0: code = TclCompileCmdWord(interp, bodyTokenPtr+1,
sl@0: bodyTokenPtr->numComponents, envPtr);
sl@0: envPtr->currStackDepth = savedStackDepth + 1;
sl@0: if (code != TCL_OK) {
sl@0: if (code == TCL_ERROR) {
sl@0: sprintf(buffer, "\n (\"for\" body line %d)",
sl@0: interp->errorLine);
sl@0: Tcl_AddObjErrorInfo(interp, buffer, -1);
sl@0: }
sl@0: goto done;
sl@0: }
sl@0: envPtr->exceptArrayPtr[bodyRange].numCodeBytes =
sl@0: (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
sl@0: TclEmitOpcode(INST_POP, envPtr);
sl@0:
sl@0:
sl@0: /*
sl@0: * Compile the "next" subcommand.
sl@0: */
sl@0:
sl@0: nextCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [3];
sl@0: #endif
sl@0: envPtr->currStackDepth = savedStackDepth;
sl@0: code = TclCompileCmdWord(interp, nextTokenPtr+1,
sl@0: nextTokenPtr->numComponents, envPtr);
sl@0: envPtr->currStackDepth = savedStackDepth + 1;
sl@0: if (code != TCL_OK) {
sl@0: if (code == TCL_ERROR) {
sl@0: Tcl_AddObjErrorInfo(interp,
sl@0: "\n (\"for\" loop-end command)", -1);
sl@0: }
sl@0: goto done;
sl@0: }
sl@0: envPtr->exceptArrayPtr[nextRange].numCodeBytes =
sl@0: (envPtr->codeNext - envPtr->codeStart)
sl@0: - nextCodeOffset;
sl@0: TclEmitOpcode(INST_POP, envPtr);
sl@0: envPtr->currStackDepth = savedStackDepth;
sl@0:
sl@0: /*
sl@0: * Compile the test expression then emit the conditional jump that
sl@0: * terminates the for.
sl@0: */
sl@0:
sl@0: testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0:
sl@0: jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
sl@0: if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
sl@0: bodyCodeOffset += 3;
sl@0: nextCodeOffset += 3;
sl@0: testCodeOffset += 3;
sl@0: }
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0: #endif
sl@0: envPtr->currStackDepth = savedStackDepth;
sl@0: code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: if (code == TCL_ERROR) {
sl@0: Tcl_AddObjErrorInfo(interp,
sl@0: "\n (\"for\" test expression)", -1);
sl@0: }
sl@0: goto done;
sl@0: }
sl@0: envPtr->currStackDepth = savedStackDepth + 1;
sl@0:
sl@0: jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
sl@0: if (jumpDist > 127) {
sl@0: TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
sl@0: }
sl@0:
sl@0: /*
sl@0: * Set the loop's offsets and break target.
sl@0: */
sl@0:
sl@0: envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset;
sl@0: envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset;
sl@0:
sl@0: envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset;
sl@0:
sl@0: envPtr->exceptArrayPtr[bodyRange].breakOffset =
sl@0: envPtr->exceptArrayPtr[nextRange].breakOffset =
sl@0: (envPtr->codeNext - envPtr->codeStart);
sl@0:
sl@0: /*
sl@0: * The for command's result is an empty string.
sl@0: */
sl@0:
sl@0: envPtr->currStackDepth = savedStackDepth;
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0: code = TCL_OK;
sl@0:
sl@0: done:
sl@0: envPtr->exceptDepth--;
sl@0: return code;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileForeachCmd --
sl@0: *
sl@0: * Procedure called to compile the "foreach" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK if
sl@0: * compilation was successful. If an error occurs then the
sl@0: * interpreter's result contains a standard error message and TCL_ERROR
sl@0: * is returned. If the command is too complex for TclCompileForeachCmd,
sl@0: * TCL_OUT_LINE_COMPILE is returned indicating that the foreach command
sl@0: * should be compiled "out of line" by emitting code to invoke its
sl@0: * command procedure at runtime.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "foreach" command
sl@0: * at runtime.
sl@0: *
sl@0: n*----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileForeachCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Proc *procPtr = envPtr->procPtr;
sl@0: ForeachInfo *infoPtr; /* Points to the structure describing this
sl@0: * foreach command. Stored in a AuxData
sl@0: * record in the ByteCode. */
sl@0: int firstValueTemp; /* Index of the first temp var in the frame
sl@0: * used to point to a value list. */
sl@0: int loopCtTemp; /* Index of temp var holding the loop's
sl@0: * iteration count. */
sl@0: Tcl_Token *tokenPtr, *bodyTokenPtr;
sl@0: unsigned char *jumpPc;
sl@0: JumpFixup jumpFalseFixup;
sl@0: int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range;
sl@0: int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
sl@0: char buffer[32 + TCL_INTEGER_SPACE];
sl@0: int savedStackDepth = envPtr->currStackDepth;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: int bodyIndex;
sl@0: #endif
sl@0:
sl@0: /*
sl@0: * We parse the variable list argument words and create two arrays:
sl@0: * varcList[i] is number of variables in i-th var list
sl@0: * varvList[i] points to array of var names in i-th var list
sl@0: */
sl@0:
sl@0: #define STATIC_VAR_LIST_SIZE 5
sl@0: int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
sl@0: CONST char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
sl@0: int *varcList = varcListStaticSpace;
sl@0: CONST char ***varvList = varvListStaticSpace;
sl@0:
sl@0: /*
sl@0: * If the foreach command isn't in a procedure, don't compile it inline:
sl@0: * the payoff is too small.
sl@0: */
sl@0:
sl@0: if (procPtr == NULL) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: numWords = parsePtr->numWords;
sl@0: if ((numWords < 4) || (numWords%2 != 0)) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);
sl@0: return TCL_ERROR;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Bail out if the body requires substitutions
sl@0: * in order to insure correct behaviour [Bug 219166]
sl@0: */
sl@0: for (i = 0, tokenPtr = parsePtr->tokenPtr;
sl@0: i < numWords-1;
sl@0: i++, tokenPtr += (tokenPtr->numComponents + 1)) {
sl@0: }
sl@0: bodyTokenPtr = tokenPtr;
sl@0: if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0: #ifdef TCL_TIP280
sl@0: bodyIndex = i-1;
sl@0: #endif
sl@0:
sl@0: /*
sl@0: * Allocate storage for the varcList and varvList arrays if necessary.
sl@0: */
sl@0:
sl@0: numLists = (numWords - 2)/2;
sl@0: if (numLists > STATIC_VAR_LIST_SIZE) {
sl@0: varcList = (int *) ckalloc(numLists * sizeof(int));
sl@0: varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **));
sl@0: }
sl@0: for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
sl@0: varcList[loopIndex] = 0;
sl@0: varvList[loopIndex] = NULL;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Set the exception stack depth.
sl@0: */
sl@0:
sl@0: envPtr->exceptDepth++;
sl@0: envPtr->maxExceptDepth =
sl@0: TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
sl@0:
sl@0: /*
sl@0: * Break up each var list and set the varcList and varvList arrays.
sl@0: * Don't compile the foreach inline if any var name needs substitutions
sl@0: * or isn't a scalar, or if any var list needs substitutions.
sl@0: */
sl@0:
sl@0: loopIndex = 0;
sl@0: for (i = 0, tokenPtr = parsePtr->tokenPtr;
sl@0: i < numWords-1;
sl@0: i++, tokenPtr += (tokenPtr->numComponents + 1)) {
sl@0: if (i%2 == 1) {
sl@0: if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0: code = TCL_OUT_LINE_COMPILE;
sl@0: goto done;
sl@0: } else {
sl@0: /* Lots of copying going on here. Need a ListObj wizard
sl@0: * to show a better way. */
sl@0:
sl@0: Tcl_DString varList;
sl@0:
sl@0: Tcl_DStringInit(&varList);
sl@0: Tcl_DStringAppend(&varList, tokenPtr[1].start,
sl@0: tokenPtr[1].size);
sl@0: code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
sl@0: &varcList[loopIndex], &varvList[loopIndex]);
sl@0: Tcl_DStringFree(&varList);
sl@0: if (code != TCL_OK) {
sl@0: goto done;
sl@0: }
sl@0: numVars = varcList[loopIndex];
sl@0:
sl@0: /*
sl@0: * If the variable list is empty, we can enter an infinite
sl@0: * loop when the interpreted version would not. Take care to
sl@0: * ensure this does not happen. [Bug 1671138]
sl@0: */
sl@0:
sl@0: if (numVars == 0) {
sl@0: code = TCL_OUT_LINE_COMPILE;
sl@0: goto done;
sl@0: }
sl@0:
sl@0: for (j = 0; j < numVars; j++) {
sl@0: CONST char *varName = varvList[loopIndex][j];
sl@0: if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
sl@0: code = TCL_OUT_LINE_COMPILE;
sl@0: goto done;
sl@0: }
sl@0: }
sl@0: }
sl@0: loopIndex++;
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * We will compile the foreach command.
sl@0: * Reserve (numLists + 1) temporary variables:
sl@0: * - numLists temps to hold each value list
sl@0: * - 1 temp for the loop counter (index of next element in each list)
sl@0: * At this time we don't try to reuse temporaries; if there are two
sl@0: * nonoverlapping foreach loops, they don't share any temps.
sl@0: */
sl@0:
sl@0: firstValueTemp = -1;
sl@0: for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
sl@0: tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
sl@0: /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
sl@0: if (loopIndex == 0) {
sl@0: firstValueTemp = tempVar;
sl@0: }
sl@0: }
sl@0: loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
sl@0: /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
sl@0:
sl@0: /*
sl@0: * Create and initialize the ForeachInfo and ForeachVarList data
sl@0: * structures describing this command. Then create a AuxData record
sl@0: * pointing to the ForeachInfo structure.
sl@0: */
sl@0:
sl@0: infoPtr = (ForeachInfo *) ckalloc((unsigned)
sl@0: (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
sl@0: infoPtr->numLists = numLists;
sl@0: infoPtr->firstValueTemp = firstValueTemp;
sl@0: infoPtr->loopCtTemp = loopCtTemp;
sl@0: for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
sl@0: ForeachVarList *varListPtr;
sl@0: numVars = varcList[loopIndex];
sl@0: varListPtr = (ForeachVarList *) ckalloc((unsigned)
sl@0: sizeof(ForeachVarList) + (numVars * sizeof(int)));
sl@0: varListPtr->numVars = numVars;
sl@0: for (j = 0; j < numVars; j++) {
sl@0: CONST char *varName = varvList[loopIndex][j];
sl@0: int nameChars = strlen(varName);
sl@0: varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
sl@0: nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
sl@0: }
sl@0: infoPtr->varLists[loopIndex] = varListPtr;
sl@0: }
sl@0: infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr);
sl@0:
sl@0: /*
sl@0: * Evaluate then store each value list in the associated temporary.
sl@0: */
sl@0:
sl@0: range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
sl@0:
sl@0: loopIndex = 0;
sl@0: for (i = 0, tokenPtr = parsePtr->tokenPtr;
sl@0: i < numWords-1;
sl@0: i++, tokenPtr += (tokenPtr->numComponents + 1)) {
sl@0: if ((i%2 == 0) && (i > 0)) {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, tokenPtr+1,
sl@0: tokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: goto done;
sl@0: }
sl@0:
sl@0: tempVar = (firstValueTemp + loopIndex);
sl@0: if (tempVar <= 255) {
sl@0: TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
sl@0: }
sl@0: TclEmitOpcode(INST_POP, envPtr);
sl@0: loopIndex++;
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Initialize the temporary var that holds the count of loop iterations.
sl@0: */
sl@0:
sl@0: TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
sl@0:
sl@0: /*
sl@0: * Top of loop code: assign each loop variable and check whether
sl@0: * to terminate the loop.
sl@0: */
sl@0:
sl@0: envPtr->exceptArrayPtr[range].continueOffset =
sl@0: (envPtr->codeNext - envPtr->codeStart);
sl@0: TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
sl@0: TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
sl@0:
sl@0: /*
sl@0: * Inline compile the loop body.
sl@0: */
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [bodyIndex];
sl@0: #endif
sl@0: envPtr->exceptArrayPtr[range].codeOffset =
sl@0: (envPtr->codeNext - envPtr->codeStart);
sl@0: code = TclCompileCmdWord(interp, bodyTokenPtr+1,
sl@0: bodyTokenPtr->numComponents, envPtr);
sl@0: envPtr->currStackDepth = savedStackDepth + 1;
sl@0: if (code != TCL_OK) {
sl@0: if (code == TCL_ERROR) {
sl@0: sprintf(buffer, "\n (\"foreach\" body line %d)",
sl@0: interp->errorLine);
sl@0: Tcl_AddObjErrorInfo(interp, buffer, -1);
sl@0: }
sl@0: goto done;
sl@0: }
sl@0: envPtr->exceptArrayPtr[range].numCodeBytes =
sl@0: (envPtr->codeNext - envPtr->codeStart)
sl@0: - envPtr->exceptArrayPtr[range].codeOffset;
sl@0: TclEmitOpcode(INST_POP, envPtr);
sl@0:
sl@0: /*
sl@0: * Jump back to the test at the top of the loop. Generate a 4 byte jump
sl@0: * if the distance to the test is > 120 bytes. This is conservative and
sl@0: * ensures that we won't have to replace this jump if we later need to
sl@0: * replace the ifFalse jump with a 4 byte jump.
sl@0: */
sl@0:
sl@0: jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0: jumpBackDist =
sl@0: (jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset);
sl@0: if (jumpBackDist > 120) {
sl@0: TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
sl@0: }
sl@0:
sl@0: /*
sl@0: * Fix the target of the jump after the foreach_step test.
sl@0: */
sl@0:
sl@0: jumpDist = (envPtr->codeNext - envPtr->codeStart)
sl@0: - jumpFalseFixup.codeOffset;
sl@0: if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
sl@0: /*
sl@0: * Update the loop body's starting PC offset since it moved down.
sl@0: */
sl@0:
sl@0: envPtr->exceptArrayPtr[range].codeOffset += 3;
sl@0:
sl@0: /*
sl@0: * Update the jump back to the test at the top of the loop since it
sl@0: * also moved down 3 bytes.
sl@0: */
sl@0:
sl@0: jumpBackOffset += 3;
sl@0: jumpPc = (envPtr->codeStart + jumpBackOffset);
sl@0: jumpBackDist += 3;
sl@0: if (jumpBackDist > 120) {
sl@0: TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
sl@0: } else {
sl@0: TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Set the loop's break target.
sl@0: */
sl@0:
sl@0: envPtr->exceptArrayPtr[range].breakOffset =
sl@0: (envPtr->codeNext - envPtr->codeStart);
sl@0:
sl@0: /*
sl@0: * The foreach command's result is an empty string.
sl@0: */
sl@0:
sl@0: envPtr->currStackDepth = savedStackDepth;
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0: envPtr->currStackDepth = savedStackDepth + 1;
sl@0:
sl@0: done:
sl@0: for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
sl@0: if (varvList[loopIndex] != (CONST char **) NULL) {
sl@0: ckfree((char *) varvList[loopIndex]);
sl@0: }
sl@0: }
sl@0: if (varcList != varcListStaticSpace) {
sl@0: ckfree((char *) varcList);
sl@0: ckfree((char *) varvList);
sl@0: }
sl@0: envPtr->exceptDepth--;
sl@0: return code;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * DupForeachInfo --
sl@0: *
sl@0: * This procedure duplicates a ForeachInfo structure created as
sl@0: * auxiliary data during the compilation of a foreach command.
sl@0: *
sl@0: * Results:
sl@0: * A pointer to a newly allocated copy of the existing ForeachInfo
sl@0: * structure is returned.
sl@0: *
sl@0: * Side effects:
sl@0: * Storage for the copied ForeachInfo record is allocated. If the
sl@0: * original ForeachInfo structure pointed to any ForeachVarList
sl@0: * records, these structures are also copied and pointers to them
sl@0: * are stored in the new ForeachInfo record.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: static ClientData
sl@0: DupForeachInfo(clientData)
sl@0: ClientData clientData; /* The foreach command's compilation
sl@0: * auxiliary data to duplicate. */
sl@0: {
sl@0: register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
sl@0: ForeachInfo *dupPtr;
sl@0: register ForeachVarList *srcListPtr, *dupListPtr;
sl@0: int numLists = srcPtr->numLists;
sl@0: int numVars, i, j;
sl@0:
sl@0: dupPtr = (ForeachInfo *) ckalloc((unsigned)
sl@0: (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
sl@0: dupPtr->numLists = numLists;
sl@0: dupPtr->firstValueTemp = srcPtr->firstValueTemp;
sl@0: dupPtr->loopCtTemp = srcPtr->loopCtTemp;
sl@0:
sl@0: for (i = 0; i < numLists; i++) {
sl@0: srcListPtr = srcPtr->varLists[i];
sl@0: numVars = srcListPtr->numVars;
sl@0: dupListPtr = (ForeachVarList *) ckalloc((unsigned)
sl@0: sizeof(ForeachVarList) + numVars*sizeof(int));
sl@0: dupListPtr->numVars = numVars;
sl@0: for (j = 0; j < numVars; j++) {
sl@0: dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
sl@0: }
sl@0: dupPtr->varLists[i] = dupListPtr;
sl@0: }
sl@0: return (ClientData) dupPtr;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * FreeForeachInfo --
sl@0: *
sl@0: * Procedure to free a ForeachInfo structure created as auxiliary data
sl@0: * during the compilation of a foreach command.
sl@0: *
sl@0: * Results:
sl@0: * None.
sl@0: *
sl@0: * Side effects:
sl@0: * Storage for the ForeachInfo structure pointed to by the ClientData
sl@0: * argument is freed as is any ForeachVarList record pointed to by the
sl@0: * ForeachInfo structure.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: static void
sl@0: FreeForeachInfo(clientData)
sl@0: ClientData clientData; /* The foreach command's compilation
sl@0: * auxiliary data to free. */
sl@0: {
sl@0: register ForeachInfo *infoPtr = (ForeachInfo *) clientData;
sl@0: register ForeachVarList *listPtr;
sl@0: int numLists = infoPtr->numLists;
sl@0: register int i;
sl@0:
sl@0: for (i = 0; i < numLists; i++) {
sl@0: listPtr = infoPtr->varLists[i];
sl@0: ckfree((char *) listPtr);
sl@0: }
sl@0: ckfree((char *) infoPtr);
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileIfCmd --
sl@0: *
sl@0: * Procedure called to compile the "if" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK if
sl@0: * compilation was successful. If an error occurs then the
sl@0: * interpreter's result contains a standard error message and TCL_ERROR
sl@0: * is returned. If the command is too complex for TclCompileIfCmd,
sl@0: * TCL_OUT_LINE_COMPILE is returned indicating that the if command
sl@0: * should be compiled "out of line" by emitting code to invoke its
sl@0: * command procedure at runtime.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "if" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0: int
sl@0: TclCompileIfCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: JumpFixupArray jumpFalseFixupArray;
sl@0: /* Used to fix the ifFalse jump after each
sl@0: * test when its target PC is determined. */
sl@0: JumpFixupArray jumpEndFixupArray;
sl@0: /* Used to fix the jump after each "then"
sl@0: * body to the end of the "if" when that PC
sl@0: * is determined. */
sl@0: Tcl_Token *tokenPtr, *testTokenPtr;
sl@0: int jumpDist, jumpFalseDist;
sl@0: int jumpIndex = 0; /* avoid compiler warning. */
sl@0: int numWords, wordIdx, numBytes, j, code;
sl@0: CONST char *word;
sl@0: char buffer[100];
sl@0: int savedStackDepth = envPtr->currStackDepth;
sl@0: /* Saved stack depth at the start of the first
sl@0: * test; the envPtr current depth is restored
sl@0: * to this value at the start of each test. */
sl@0: int realCond = 1; /* set to 0 for static conditions: "if 0 {..}" */
sl@0: int boolVal; /* value of static condition */
sl@0: int compileScripts = 1;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: /*
sl@0: * Only compile the "if" command if all arguments are simple
sl@0: * words, in order to insure correct substitution [Bug 219166]
sl@0: */
sl@0:
sl@0: tokenPtr = parsePtr->tokenPtr;
sl@0: wordIdx = 0;
sl@0: numWords = parsePtr->numWords;
sl@0:
sl@0: for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
sl@0: if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0: tokenPtr += 2;
sl@0: }
sl@0:
sl@0:
sl@0: TclInitJumpFixupArray(&jumpFalseFixupArray);
sl@0: TclInitJumpFixupArray(&jumpEndFixupArray);
sl@0: code = TCL_OK;
sl@0:
sl@0: /*
sl@0: * Each iteration of this loop compiles one "if expr ?then? body"
sl@0: * or "elseif expr ?then? body" clause.
sl@0: */
sl@0:
sl@0: tokenPtr = parsePtr->tokenPtr;
sl@0: wordIdx = 0;
sl@0: while (wordIdx < numWords) {
sl@0: /*
sl@0: * Stop looping if the token isn't "if" or "elseif".
sl@0: */
sl@0:
sl@0: word = tokenPtr[1].start;
sl@0: numBytes = tokenPtr[1].size;
sl@0: if ((tokenPtr == parsePtr->tokenPtr)
sl@0: || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
sl@0: tokenPtr += (tokenPtr->numComponents + 1);
sl@0: wordIdx++;
sl@0: } else {
sl@0: break;
sl@0: }
sl@0: if (wordIdx >= numWords) {
sl@0: sprintf(buffer,
sl@0: "wrong # args: no expression after \"%.*s\" argument",
sl@0: (numBytes > 50 ? 50 : numBytes), word);
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
sl@0: code = TCL_ERROR;
sl@0: goto done;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Compile the test expression then emit the conditional jump
sl@0: * around the "then" part.
sl@0: */
sl@0:
sl@0: envPtr->currStackDepth = savedStackDepth;
sl@0: testTokenPtr = tokenPtr;
sl@0:
sl@0:
sl@0: if (realCond) {
sl@0: /*
sl@0: * Find out if the condition is a constant.
sl@0: */
sl@0:
sl@0: Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
sl@0: testTokenPtr[1].size);
sl@0: Tcl_IncrRefCount(boolObj);
sl@0: code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
sl@0: Tcl_DecrRefCount(boolObj);
sl@0: if (code == TCL_OK) {
sl@0: /*
sl@0: * A static condition
sl@0: */
sl@0: realCond = 0;
sl@0: if (!boolVal) {
sl@0: compileScripts = 0;
sl@0: }
sl@0: } else {
sl@0: Tcl_ResetResult(interp);
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [wordIdx];
sl@0: #endif
sl@0: code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: if (code == TCL_ERROR) {
sl@0: Tcl_AddObjErrorInfo(interp,
sl@0: "\n (\"if\" test expression)", -1);
sl@0: }
sl@0: goto done;
sl@0: }
sl@0: if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
sl@0: TclExpandJumpFixupArray(&jumpFalseFixupArray);
sl@0: }
sl@0: jumpIndex = jumpFalseFixupArray.next;
sl@0: jumpFalseFixupArray.next++;
sl@0: TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
sl@0: &(jumpFalseFixupArray.fixup[jumpIndex]));
sl@0: }
sl@0: }
sl@0:
sl@0:
sl@0: /*
sl@0: * Skip over the optional "then" before the then clause.
sl@0: */
sl@0:
sl@0: tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
sl@0: wordIdx++;
sl@0: if (wordIdx >= numWords) {
sl@0: sprintf(buffer,
sl@0: "wrong # args: no script following \"%.*s\" argument",
sl@0: (testTokenPtr->size > 50 ? 50 : testTokenPtr->size),
sl@0: testTokenPtr->start);
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
sl@0: code = TCL_ERROR;
sl@0: goto done;
sl@0: }
sl@0: if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: word = tokenPtr[1].start;
sl@0: numBytes = tokenPtr[1].size;
sl@0: if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
sl@0: tokenPtr += (tokenPtr->numComponents + 1);
sl@0: wordIdx++;
sl@0: if (wordIdx >= numWords) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: no script following \"then\" argument", -1);
sl@0: code = TCL_ERROR;
sl@0: goto done;
sl@0: }
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Compile the "then" command body.
sl@0: */
sl@0:
sl@0: if (compileScripts) {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [wordIdx];
sl@0: #endif
sl@0: envPtr->currStackDepth = savedStackDepth;
sl@0: code = TclCompileCmdWord(interp, tokenPtr+1,
sl@0: tokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: if (code == TCL_ERROR) {
sl@0: sprintf(buffer, "\n (\"if\" then script line %d)",
sl@0: interp->errorLine);
sl@0: Tcl_AddObjErrorInfo(interp, buffer, -1);
sl@0: }
sl@0: goto done;
sl@0: }
sl@0: }
sl@0:
sl@0: if (realCond) {
sl@0: /*
sl@0: * Jump to the end of the "if" command. Both jumpFalseFixupArray and
sl@0: * jumpEndFixupArray are indexed by "jumpIndex".
sl@0: */
sl@0:
sl@0: if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
sl@0: TclExpandJumpFixupArray(&jumpEndFixupArray);
sl@0: }
sl@0: jumpEndFixupArray.next++;
sl@0: TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
sl@0: &(jumpEndFixupArray.fixup[jumpIndex]));
sl@0:
sl@0: /*
sl@0: * Fix the target of the jumpFalse after the test. Generate a 4 byte
sl@0: * jump if the distance is > 120 bytes. This is conservative, and
sl@0: * ensures that we won't have to replace this jump if we later also
sl@0: * need to replace the proceeding jump to the end of the "if" with a
sl@0: * 4 byte jump.
sl@0: */
sl@0:
sl@0: jumpDist = (envPtr->codeNext - envPtr->codeStart)
sl@0: - jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
sl@0: if (TclFixupForwardJump(envPtr,
sl@0: &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
sl@0: /*
sl@0: * Adjust the code offset for the proceeding jump to the end
sl@0: * of the "if" command.
sl@0: */
sl@0:
sl@0: jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
sl@0: }
sl@0: } else if (boolVal) {
sl@0: /*
sl@0: *We were processing an "if 1 {...}"; stop compiling
sl@0: * scripts
sl@0: */
sl@0:
sl@0: compileScripts = 0;
sl@0: } else {
sl@0: /*
sl@0: *We were processing an "if 0 {...}"; reset so that
sl@0: * the rest (elseif, else) is compiled correctly
sl@0: */
sl@0:
sl@0: realCond = 1;
sl@0: compileScripts = 1;
sl@0: }
sl@0:
sl@0: tokenPtr += (tokenPtr->numComponents + 1);
sl@0: wordIdx++;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Restore the current stack depth in the environment; the
sl@0: * "else" clause (or its default) will add 1 to this.
sl@0: */
sl@0:
sl@0: envPtr->currStackDepth = savedStackDepth;
sl@0:
sl@0: /*
sl@0: * Check for the optional else clause. Do not compile
sl@0: * anything if this was an "if 1 {...}" case.
sl@0: */
sl@0:
sl@0: if ((wordIdx < numWords)
sl@0: && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
sl@0: /*
sl@0: * There is an else clause. Skip over the optional "else" word.
sl@0: */
sl@0:
sl@0: word = tokenPtr[1].start;
sl@0: numBytes = tokenPtr[1].size;
sl@0: if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
sl@0: tokenPtr += (tokenPtr->numComponents + 1);
sl@0: wordIdx++;
sl@0: if (wordIdx >= numWords) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: no script following \"else\" argument", -1);
sl@0: code = TCL_ERROR;
sl@0: goto done;
sl@0: }
sl@0: }
sl@0:
sl@0: if (compileScripts) {
sl@0: /*
sl@0: * Compile the else command body.
sl@0: */
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [wordIdx];
sl@0: #endif
sl@0: code = TclCompileCmdWord(interp, tokenPtr+1,
sl@0: tokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: if (code == TCL_ERROR) {
sl@0: sprintf(buffer, "\n (\"if\" else script line %d)",
sl@0: interp->errorLine);
sl@0: Tcl_AddObjErrorInfo(interp, buffer, -1);
sl@0: }
sl@0: goto done;
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Make sure there are no words after the else clause.
sl@0: */
sl@0:
sl@0: wordIdx++;
sl@0: if (wordIdx < numWords) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: extra words after \"else\" clause in \"if\" command", -1);
sl@0: code = TCL_ERROR;
sl@0: goto done;
sl@0: }
sl@0: } else {
sl@0: /*
sl@0: * No else clause: the "if" command's result is an empty string.
sl@0: */
sl@0:
sl@0: if (compileScripts) {
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Fix the unconditional jumps to the end of the "if" command.
sl@0: */
sl@0:
sl@0: for (j = jumpEndFixupArray.next; j > 0; j--) {
sl@0: jumpIndex = (j - 1); /* i.e. process the closest jump first */
sl@0: jumpDist = (envPtr->codeNext - envPtr->codeStart)
sl@0: - jumpEndFixupArray.fixup[jumpIndex].codeOffset;
sl@0: if (TclFixupForwardJump(envPtr,
sl@0: &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {
sl@0: /*
sl@0: * Adjust the immediately preceeding "ifFalse" jump. We moved
sl@0: * it's target (just after this jump) down three bytes.
sl@0: */
sl@0:
sl@0: unsigned char *ifFalsePc = envPtr->codeStart
sl@0: + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
sl@0: unsigned char opCode = *ifFalsePc;
sl@0: if (opCode == INST_JUMP_FALSE1) {
sl@0: jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
sl@0: jumpFalseDist += 3;
sl@0: TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
sl@0: } else if (opCode == INST_JUMP_FALSE4) {
sl@0: jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
sl@0: jumpFalseDist += 3;
sl@0: TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
sl@0: } else {
sl@0: panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
sl@0: }
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Free the jumpFixupArray array if malloc'ed storage was used.
sl@0: */
sl@0:
sl@0: done:
sl@0: envPtr->currStackDepth = savedStackDepth + 1;
sl@0: TclFreeJumpFixupArray(&jumpFalseFixupArray);
sl@0: TclFreeJumpFixupArray(&jumpEndFixupArray);
sl@0: return code;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileIncrCmd --
sl@0: *
sl@0: * Procedure called to compile the "incr" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK if
sl@0: * compilation was successful. If an error occurs then the
sl@0: * interpreter's result contains a standard error message and TCL_ERROR
sl@0: * is returned. If the command is too complex for TclCompileIncrCmd,
sl@0: * TCL_OUT_LINE_COMPILE is returned indicating that the incr command
sl@0: * should be compiled "out of line" by emitting code to invoke its
sl@0: * command procedure at runtime.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "incr" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileIncrCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Tcl_Token *varTokenPtr, *incrTokenPtr;
sl@0: int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
sl@0: int code = TCL_OK;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: should be \"incr varName ?increment?\"", -1);
sl@0: return TCL_ERROR;
sl@0: }
sl@0:
sl@0: varTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0:
sl@0: code = TclPushVarName(interp, varTokenPtr, envPtr,
sl@0: (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR),
sl@0: #ifndef TCL_TIP280
sl@0: &localIndex, &simpleVarName, &isScalar);
sl@0: #else
sl@0: &localIndex, &simpleVarName, &isScalar,
sl@0: mapPtr->loc [eclIndex].line [1]);
sl@0: #endif
sl@0: if (code != TCL_OK) {
sl@0: goto done;
sl@0: }
sl@0:
sl@0: /*
sl@0: * If an increment is given, push it, but see first if it's a small
sl@0: * integer.
sl@0: */
sl@0:
sl@0: haveImmValue = 0;
sl@0: immValue = 1;
sl@0: if (parsePtr->numWords == 3) {
sl@0: incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: CONST char *word = incrTokenPtr[1].start;
sl@0: int numBytes = incrTokenPtr[1].size;
sl@0:
sl@0: /*
sl@0: * Note there is a danger that modifying the string could have
sl@0: * undesirable side effects. In this case, TclLooksLikeInt has
sl@0: * no dependencies on shared strings so we should be safe.
sl@0: */
sl@0:
sl@0: if (TclLooksLikeInt(word, numBytes)) {
sl@0: int code;
sl@0: Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
sl@0: Tcl_IncrRefCount(intObj);
sl@0: code = Tcl_GetIntFromObj(NULL, intObj, &immValue);
sl@0: Tcl_DecrRefCount(intObj);
sl@0: if ((code == TCL_OK)
sl@0: && (-127 <= immValue) && (immValue <= 127)) {
sl@0: haveImmValue = 1;
sl@0: }
sl@0: }
sl@0: if (!haveImmValue) {
sl@0: TclEmitPush(
sl@0: TclRegisterNewLiteral(envPtr, word, numBytes), envPtr);
sl@0: }
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, incrTokenPtr+1,
sl@0: incrTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: goto done;
sl@0: }
sl@0: }
sl@0: } else { /* no incr amount given so use 1 */
sl@0: haveImmValue = 1;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Emit the instruction to increment the variable.
sl@0: */
sl@0:
sl@0: if (simpleVarName) {
sl@0: if (isScalar) {
sl@0: if (localIndex >= 0) {
sl@0: if (haveImmValue) {
sl@0: TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
sl@0: TclEmitInt1(immValue, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
sl@0: }
sl@0: } else {
sl@0: if (haveImmValue) {
sl@0: TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
sl@0: } else {
sl@0: TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
sl@0: }
sl@0: }
sl@0: } else {
sl@0: if (localIndex >= 0) {
sl@0: if (haveImmValue) {
sl@0: TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
sl@0: TclEmitInt1(immValue, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
sl@0: }
sl@0: } else {
sl@0: if (haveImmValue) {
sl@0: TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
sl@0: } else {
sl@0: TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
sl@0: }
sl@0: }
sl@0: }
sl@0: } else { /* non-simple variable name */
sl@0: if (haveImmValue) {
sl@0: TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
sl@0: } else {
sl@0: TclEmitOpcode(INST_INCR_STK, envPtr);
sl@0: }
sl@0: }
sl@0:
sl@0: done:
sl@0: return code;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileLappendCmd --
sl@0: *
sl@0: * Procedure called to compile the "lappend" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is normally TCL_OK
sl@0: * unless there was an error while parsing string. If an error occurs
sl@0: * then the interpreter's result contains a standard error message. If
sl@0: * complation fails because the command requires a second level of
sl@0: * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
sl@0: * command should be compiled "out of line" by emitting code to
sl@0: * invoke its command procedure (Tcl_LappendObjCmd) at runtime.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "lappend" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileLappendCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Tcl_Token *varTokenPtr, *valueTokenPtr;
sl@0: int simpleVarName, isScalar, localIndex, numWords;
sl@0: int code = TCL_OK;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: /*
sl@0: * If we're not in a procedure, don't compile.
sl@0: */
sl@0: if (envPtr->procPtr == NULL) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: numWords = parsePtr->numWords;
sl@0: if (numWords == 1) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: should be \"lappend varName ?value value ...?\"", -1);
sl@0: return TCL_ERROR;
sl@0: }
sl@0: if (numWords != 3) {
sl@0: /*
sl@0: * LAPPEND instructions currently only handle one value appends
sl@0: */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Decide if we can use a frame slot for the var/array name or if we
sl@0: * need to emit code to compute and push the name at runtime. We use a
sl@0: * frame slot (entry in the array of local vars) if we are compiling a
sl@0: * procedure body and if the name is simple text that does not include
sl@0: * namespace qualifiers.
sl@0: */
sl@0:
sl@0: varTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0:
sl@0: code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
sl@0: #ifndef TCL_TIP280
sl@0: &localIndex, &simpleVarName, &isScalar);
sl@0: #else
sl@0: &localIndex, &simpleVarName, &isScalar,
sl@0: mapPtr->loc [eclIndex].line [1]);
sl@0: #endif
sl@0: if (code != TCL_OK) {
sl@0: goto done;
sl@0: }
sl@0:
sl@0: /*
sl@0: * If we are doing an assignment, push the new value.
sl@0: * In the no values case, create an empty object.
sl@0: */
sl@0:
sl@0: if (numWords > 2) {
sl@0: valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr,
sl@0: valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, valueTokenPtr+1,
sl@0: valueTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: goto done;
sl@0: }
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Emit instructions to set/get the variable.
sl@0: */
sl@0:
sl@0: /*
sl@0: * The *_STK opcodes should be refactored to make better use of existing
sl@0: * LOAD/STORE instructions.
sl@0: */
sl@0: if (simpleVarName) {
sl@0: if (isScalar) {
sl@0: if (localIndex >= 0) {
sl@0: if (localIndex <= 255) {
sl@0: TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
sl@0: }
sl@0: } else {
sl@0: TclEmitOpcode(INST_LAPPEND_STK, envPtr);
sl@0: }
sl@0: } else {
sl@0: if (localIndex >= 0) {
sl@0: if (localIndex <= 255) {
sl@0: TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
sl@0: }
sl@0: } else {
sl@0: TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
sl@0: }
sl@0: }
sl@0: } else {
sl@0: TclEmitOpcode(INST_LAPPEND_STK, envPtr);
sl@0: }
sl@0:
sl@0: done:
sl@0: return code;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileLindexCmd --
sl@0: *
sl@0: * Procedure called to compile the "lindex" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK if the
sl@0: * compilation was successful. If the command cannot be byte-compiled,
sl@0: * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
sl@0: * interpreter's result contains an error message, and TCL_ERROR is
sl@0: * returned.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "lindex" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileLindexCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Tcl_Token *varTokenPtr;
sl@0: int code, i;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: int numWords;
sl@0: numWords = parsePtr->numWords;
sl@0:
sl@0: /*
sl@0: * Quit if too few args
sl@0: */
sl@0:
sl@0: if ( numWords <= 1 ) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: varTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0:
sl@0: /*
sl@0: * Push the operands onto the stack.
sl@0: */
sl@0:
sl@0: for ( i = 1 ; i < numWords ; i++ ) {
sl@0: if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: TclEmitPush(
sl@0: TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
sl@0: varTokenPtr[1].size), envPtr);
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, varTokenPtr+1,
sl@0: varTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: return code;
sl@0: }
sl@0: }
sl@0: varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: }
sl@0:
sl@0: /*
sl@0: * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI
sl@0: * if there are multiple index args.
sl@0: */
sl@0:
sl@0: if ( numWords == 3 ) {
sl@0: TclEmitOpcode( INST_LIST_INDEX, envPtr );
sl@0: } else {
sl@0: TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr );
sl@0: }
sl@0:
sl@0: return TCL_OK;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileListCmd --
sl@0: *
sl@0: * Procedure called to compile the "list" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is normally TCL_OK
sl@0: * unless there was an error while parsing string. If an error occurs
sl@0: * then the interpreter's result contains a standard error message. If
sl@0: * complation fails because the command requires a second level of
sl@0: * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
sl@0: * command should be compiled "out of line" by emitting code to
sl@0: * invoke its command procedure (Tcl_ListObjCmd) at runtime.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "list" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileListCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: /*
sl@0: * If we're not in a procedure, don't compile.
sl@0: */
sl@0: if (envPtr->procPtr == NULL) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: if (parsePtr->numWords == 1) {
sl@0: /*
sl@0: * Empty args case
sl@0: */
sl@0:
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0: } else {
sl@0: /*
sl@0: * Push the all values onto the stack.
sl@0: */
sl@0: Tcl_Token *valueTokenPtr;
sl@0: int i, code, numWords;
sl@0:
sl@0: numWords = parsePtr->numWords;
sl@0:
sl@0: valueTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0: for (i = 1; i < numWords; i++) {
sl@0: if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr,
sl@0: valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, valueTokenPtr+1,
sl@0: valueTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: return code;
sl@0: }
sl@0: }
sl@0: valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1);
sl@0: }
sl@0: TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
sl@0: }
sl@0:
sl@0: return TCL_OK;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileLlengthCmd --
sl@0: *
sl@0: * Procedure called to compile the "llength" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK if the
sl@0: * compilation was successful. If the command cannot be byte-compiled,
sl@0: * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
sl@0: * interpreter's result contains an error message, and TCL_ERROR is
sl@0: * returned.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "llength" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileLlengthCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Tcl_Token *varTokenPtr;
sl@0: int code;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: if (parsePtr->numWords != 2) {
sl@0: Tcl_SetResult(interp, "wrong # args: should be \"llength list\"",
sl@0: TCL_STATIC);
sl@0: return TCL_ERROR;
sl@0: }
sl@0: varTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0:
sl@0: if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: /*
sl@0: * We could simply count the number of elements here and push
sl@0: * that value, but that is too rare a case to waste the code space.
sl@0: */
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
sl@0: varTokenPtr[1].size), envPtr);
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [1];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, varTokenPtr+1,
sl@0: varTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: return code;
sl@0: }
sl@0: }
sl@0: TclEmitOpcode(INST_LIST_LENGTH, envPtr);
sl@0: return TCL_OK;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileLsetCmd --
sl@0: *
sl@0: * Procedure called to compile the "lset" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK if
sl@0: * the compilation was successful. If the "lset" command is too
sl@0: * complex for this function, then TCL_OUT_LINE_COMPILE is returned,
sl@0: * indicating that the command should be compiled "out of line"
sl@0: * (that is, not byte-compiled). If an error occurs, TCL_ERROR is
sl@0: * returned, and the interpreter result contains an error message.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "lset" command
sl@0: * at runtime.
sl@0: *
sl@0: * The general template for execution of the "lset" command is:
sl@0: * (1) Instructions to push the variable name, unless the
sl@0: * variable is local to the stack frame.
sl@0: * (2) If the variable is an array element, instructions
sl@0: * to push the array element name.
sl@0: * (3) Instructions to push each of zero or more "index" arguments
sl@0: * to the stack, followed with the "newValue" element.
sl@0: * (4) Instructions to duplicate the variable name and/or array
sl@0: * element name onto the top of the stack, if either was
sl@0: * pushed at steps (1) and (2).
sl@0: * (5) The appropriate INST_LOAD_* instruction to place the
sl@0: * original value of the list variable at top of stack.
sl@0: * (6) At this point, the stack contains:
sl@0: * varName? arrayElementName? index1 index2 ... newValue oldList
sl@0: * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
sl@0: * according as whether there is exactly one index element (LIST)
sl@0: * or either zero or else two or more (FLAT). This instruction
sl@0: * removes everything from the stack except for the two names
sl@0: * and pushes the new value of the variable.
sl@0: * (7) Finally, INST_STORE_* stores the new value in the variable
sl@0: * and cleans up the stack.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileLsetCmd( interp, parsePtr, envPtr )
sl@0: Tcl_Interp* interp; /* Tcl interpreter for error reporting */
sl@0: Tcl_Parse* parsePtr; /* Points to a parse structure for
sl@0: * the command */
sl@0: CompileEnv* envPtr; /* Holds the resulting instructions */
sl@0: {
sl@0:
sl@0: int tempDepth; /* Depth used for emitting one part
sl@0: * of the code burst. */
sl@0: Tcl_Token* varTokenPtr; /* Pointer to the Tcl_Token representing
sl@0: * the parse of the variable name */
sl@0:
sl@0: int result; /* Status return from library calls */
sl@0:
sl@0: int localIndex; /* Index of var in local var table */
sl@0: int simpleVarName; /* Flag == 1 if var name is simple */
sl@0: int isScalar; /* Flag == 1 if scalar, 0 if array */
sl@0:
sl@0: int i;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: /* Check argument count */
sl@0:
sl@0: if ( parsePtr->numWords < 3 ) {
sl@0: /* Fail at run time, not in compilation */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Decide if we can use a frame slot for the var/array name or if we
sl@0: * need to emit code to compute and push the name at runtime. We use a
sl@0: * frame slot (entry in the array of local vars) if we are compiling a
sl@0: * procedure body and if the name is simple text that does not include
sl@0: * namespace qualifiers.
sl@0: */
sl@0:
sl@0: varTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0: result = TclPushVarName( interp, varTokenPtr, envPtr,
sl@0: #ifndef TCL_TIP280
sl@0: TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar );
sl@0: #else
sl@0: TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar,
sl@0: mapPtr->loc [eclIndex].line [1]);
sl@0: #endif
sl@0: if (result != TCL_OK) {
sl@0: return result;
sl@0: }
sl@0:
sl@0: /* Push the "index" args and the new element value. */
sl@0:
sl@0: for ( i = 2; i < parsePtr->numWords; ++i ) {
sl@0:
sl@0: /* Advance to next arg */
sl@0:
sl@0: varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0:
sl@0: /* Push an arg */
sl@0:
sl@0: if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
sl@0: varTokenPtr[1].size), envPtr);
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0: #endif
sl@0: result = TclCompileTokens(interp, varTokenPtr+1,
sl@0: varTokenPtr->numComponents, envPtr);
sl@0: if ( result != TCL_OK ) {
sl@0: return result;
sl@0: }
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Duplicate the variable name if it's been pushed.
sl@0: */
sl@0:
sl@0: if ( !simpleVarName || localIndex < 0 ) {
sl@0: if ( !simpleVarName || isScalar ) {
sl@0: tempDepth = parsePtr->numWords - 2;
sl@0: } else {
sl@0: tempDepth = parsePtr->numWords - 1;
sl@0: }
sl@0: TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
sl@0: }
sl@0:
sl@0: /*
sl@0: * Duplicate an array index if one's been pushed
sl@0: */
sl@0:
sl@0: if ( simpleVarName && !isScalar ) {
sl@0: if ( localIndex < 0 ) {
sl@0: tempDepth = parsePtr->numWords - 1;
sl@0: } else {
sl@0: tempDepth = parsePtr->numWords - 2;
sl@0: }
sl@0: TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
sl@0: }
sl@0:
sl@0: /*
sl@0: * Emit code to load the variable's value.
sl@0: */
sl@0:
sl@0: if ( !simpleVarName ) {
sl@0: TclEmitOpcode( INST_LOAD_STK, envPtr );
sl@0: } else if ( isScalar ) {
sl@0: if ( localIndex < 0 ) {
sl@0: TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr );
sl@0: } else if ( localIndex < 0x100 ) {
sl@0: TclEmitInstInt1( INST_LOAD_SCALAR1, localIndex, envPtr );
sl@0: } else {
sl@0: TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr );
sl@0: }
sl@0: } else {
sl@0: if ( localIndex < 0 ) {
sl@0: TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr );
sl@0: } else if ( localIndex < 0x100 ) {
sl@0: TclEmitInstInt1( INST_LOAD_ARRAY1, localIndex, envPtr );
sl@0: } else {
sl@0: TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr );
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Emit the correct variety of 'lset' instruction
sl@0: */
sl@0:
sl@0: if ( parsePtr->numWords == 4 ) {
sl@0: TclEmitOpcode( INST_LSET_LIST, envPtr );
sl@0: } else {
sl@0: TclEmitInstInt4( INST_LSET_FLAT, (parsePtr->numWords - 1), envPtr );
sl@0: }
sl@0:
sl@0: /*
sl@0: * Emit code to put the value back in the variable
sl@0: */
sl@0:
sl@0: if ( !simpleVarName ) {
sl@0: TclEmitOpcode( INST_STORE_STK, envPtr );
sl@0: } else if ( isScalar ) {
sl@0: if ( localIndex < 0 ) {
sl@0: TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr );
sl@0: } else if ( localIndex < 0x100 ) {
sl@0: TclEmitInstInt1( INST_STORE_SCALAR1, localIndex, envPtr );
sl@0: } else {
sl@0: TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr );
sl@0: }
sl@0: } else {
sl@0: if ( localIndex < 0 ) {
sl@0: TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr );
sl@0: } else if ( localIndex < 0x100 ) {
sl@0: TclEmitInstInt1( INST_STORE_ARRAY1, localIndex, envPtr );
sl@0: } else {
sl@0: TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr );
sl@0: }
sl@0: }
sl@0:
sl@0: return TCL_OK;
sl@0:
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileRegexpCmd --
sl@0: *
sl@0: * Procedure called to compile the "regexp" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK if
sl@0: * the compilation was successful. If the "regexp" command is too
sl@0: * complex for this function, then TCL_OUT_LINE_COMPILE is returned,
sl@0: * indicating that the command should be compiled "out of line"
sl@0: * (that is, not byte-compiled). If an error occurs, TCL_ERROR is
sl@0: * returned, and the interpreter result contains an error message.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "regexp" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileRegexpCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp* interp; /* Tcl interpreter for error reporting */
sl@0: Tcl_Parse* parsePtr; /* Points to a parse structure for
sl@0: * the command */
sl@0: CompileEnv* envPtr; /* Holds the resulting instructions */
sl@0: {
sl@0: Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing
sl@0: * the parse of the RE or string */
sl@0: int i, len, code, nocase, anchorLeft, anchorRight, start;
sl@0: char *str;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: /*
sl@0: * We are only interested in compiling simple regexp cases.
sl@0: * Currently supported compile cases are:
sl@0: * regexp ?-nocase? ?--? staticString $var
sl@0: * regexp ?-nocase? ?--? {^staticString$} $var
sl@0: */
sl@0: if (parsePtr->numWords < 3) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: nocase = 0;
sl@0: varTokenPtr = parsePtr->tokenPtr;
sl@0:
sl@0: /*
sl@0: * We only look for -nocase and -- as options. Everything else
sl@0: * gets pushed to runtime execution. This is different than regexp's
sl@0: * runtime option handling, but satisfies our stricter needs.
sl@0: */
sl@0: for (i = 1; i < parsePtr->numWords - 2; i++) {
sl@0: varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0: /* Not a simple string - punt to runtime. */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0: str = (char *) varTokenPtr[1].start;
sl@0: len = varTokenPtr[1].size;
sl@0: if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
sl@0: i++;
sl@0: break;
sl@0: } else if ((len > 1)
sl@0: && (strncmp(str, "-nocase", (unsigned) len) == 0)) {
sl@0: nocase = 1;
sl@0: } else {
sl@0: /* Not an option we recognize. */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0: }
sl@0:
sl@0: if ((parsePtr->numWords - i) != 2) {
sl@0: /* We don't support capturing to variables */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Get the regexp string. If it is not a simple string, punt to runtime.
sl@0: * If it has a '-', it could be an incorrectly formed regexp command.
sl@0: */
sl@0: varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: str = (char *) varTokenPtr[1].start;
sl@0: len = varTokenPtr[1].size;
sl@0: if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: if (len == 0) {
sl@0: /*
sl@0: * The semantics of regexp are always match on re == "".
sl@0: */
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
sl@0: return TCL_OK;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Make a copy of the string that is null-terminated for checks which
sl@0: * require such.
sl@0: */
sl@0: str = (char *) ckalloc((unsigned) len + 1);
sl@0: strncpy(str, varTokenPtr[1].start, (size_t) len);
sl@0: str[len] = '\0';
sl@0: start = 0;
sl@0:
sl@0: /*
sl@0: * Check for anchored REs (ie ^foo$), so we can use string equal if
sl@0: * possible. Do not alter the start of str so we can free it correctly.
sl@0: */
sl@0: if (str[0] == '^') {
sl@0: start++;
sl@0: anchorLeft = 1;
sl@0: } else {
sl@0: anchorLeft = 0;
sl@0: }
sl@0: if ((str[len-1] == '$') && ((len == 1) || (str[len-2] != '\\'))) {
sl@0: anchorRight = 1;
sl@0: str[--len] = '\0';
sl@0: } else {
sl@0: anchorRight = 0;
sl@0: }
sl@0:
sl@0: /*
sl@0: * On the first (pattern) arg, check to see if any RE special characters
sl@0: * are in the word. If not, this is the same as 'string equal'.
sl@0: */
sl@0: if ((len > (1+start)) && (str[start] == '.') && (str[start+1] == '*')) {
sl@0: start += 2;
sl@0: anchorLeft = 0;
sl@0: }
sl@0: if ((len > (2+start)) && (str[len-3] != '\\')
sl@0: && (str[len-2] == '.') && (str[len-1] == '*')) {
sl@0: len -= 2;
sl@0: str[len] = '\0';
sl@0: anchorRight = 0;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Don't do anything with REs with other special chars. Also check if
sl@0: * this is a bad RE (do this at the end because it can be expensive).
sl@0: * If so, let it complain at runtime.
sl@0: */
sl@0: if ((strpbrk(str + start, "*+?{}()[].\\|^$") != NULL)
sl@0: || (Tcl_RegExpCompile(NULL, str) == NULL)) {
sl@0: ckfree((char *) str);
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: if (anchorLeft && anchorRight) {
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, str+start, len-start),
sl@0: envPtr);
sl@0: } else {
sl@0: /*
sl@0: * This needs to find the substring anywhere in the string, so
sl@0: * use string match and *foo*, with appropriate anchoring.
sl@0: */
sl@0: char *newStr = ckalloc((unsigned) len + 3);
sl@0: len -= start;
sl@0: if (anchorLeft) {
sl@0: strncpy(newStr, str + start, (size_t) len);
sl@0: } else {
sl@0: newStr[0] = '*';
sl@0: strncpy(newStr + 1, str + start, (size_t) len++);
sl@0: }
sl@0: if (!anchorRight) {
sl@0: newStr[len++] = '*';
sl@0: }
sl@0: newStr[len] = '\0';
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len), envPtr);
sl@0: ckfree((char *) newStr);
sl@0: }
sl@0: ckfree((char *) str);
sl@0:
sl@0: /*
sl@0: * Push the string arg
sl@0: */
sl@0: varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr,
sl@0: varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [parsePtr->numWords-1];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, varTokenPtr+1,
sl@0: varTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: return code;
sl@0: }
sl@0: }
sl@0:
sl@0: if (anchorLeft && anchorRight && !nocase) {
sl@0: TclEmitOpcode(INST_STR_EQ, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
sl@0: }
sl@0:
sl@0: return TCL_OK;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileReturnCmd --
sl@0: *
sl@0: * Procedure called to compile the "return" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK if the
sl@0: * compilation was successful. If the particular return command is
sl@0: * too complex for this function (ie, return with any flags like "-code"
sl@0: * or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that
sl@0: * the command should be compiled "out of line" (eg, not byte compiled).
sl@0: * If an error occurs then the interpreter's result contains a standard
sl@0: * error message.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "return" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileReturnCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Tcl_Token *varTokenPtr;
sl@0: int code;
sl@0: int index = envPtr->exceptArrayNext - 1;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: /*
sl@0: * If we're not in a procedure, don't compile.
sl@0: */
sl@0:
sl@0: if (envPtr->procPtr == NULL) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Look back through the ExceptionRanges of the current CompileEnv,
sl@0: * from exceptArrayPtr[(exceptArrayNext - 1)] down to
sl@0: * exceptArrayPtr[0] to see if any of them is an enclosing [catch].
sl@0: * If there's an enclosing [catch], don't compile.
sl@0: */
sl@0:
sl@0: while (index >= 0) {
sl@0: ExceptionRange range = envPtr->exceptArrayPtr[index];
sl@0: if ((range.type == CATCH_EXCEPTION_RANGE)
sl@0: && (range.catchOffset == -1)) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0: index--;
sl@0: }
sl@0:
sl@0: switch (parsePtr->numWords) {
sl@0: case 1: {
sl@0: /*
sl@0: * Simple case: [return]
sl@0: * Just push the literal string "".
sl@0: */
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0: break;
sl@0: }
sl@0: case 2: {
sl@0: /*
sl@0: * More complex cases:
sl@0: * [return "foo"]
sl@0: * [return $value]
sl@0: * [return [otherCmd]]
sl@0: */
sl@0: varTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0: if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: /*
sl@0: * [return "foo"] case: the parse token is a simple word,
sl@0: * so just push it.
sl@0: */
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
sl@0: varTokenPtr[1].size), envPtr);
sl@0: } else {
sl@0: /*
sl@0: * Parse token is more complex, so compile it; this handles the
sl@0: * variable reference and nested command cases. If the
sl@0: * parse token can be byte-compiled, then this instance of
sl@0: * "return" will be byte-compiled; otherwise it will be
sl@0: * out line compiled.
sl@0: */
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [1];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, varTokenPtr+1,
sl@0: varTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: return code;
sl@0: }
sl@0: }
sl@0: break;
sl@0: }
sl@0: default: {
sl@0: /*
sl@0: * Most complex return cases: everything else, including
sl@0: * [return -code error], etc.
sl@0: */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * The INST_DONE opcode actually causes the branching out of the
sl@0: * subroutine, and takes the top stack item as the return result
sl@0: * (which is why we pushed the value above).
sl@0: */
sl@0: TclEmitOpcode(INST_DONE, envPtr);
sl@0: return TCL_OK;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileSetCmd --
sl@0: *
sl@0: * Procedure called to compile the "set" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is normally TCL_OK
sl@0: * unless there was an error while parsing string. If an error occurs
sl@0: * then the interpreter's result contains a standard error message. If
sl@0: * complation fails because the set command requires a second level of
sl@0: * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
sl@0: * set command should be compiled "out of line" by emitting code to
sl@0: * invoke its command procedure (Tcl_SetCmd) at runtime.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "set" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileSetCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Tcl_Token *varTokenPtr, *valueTokenPtr;
sl@0: int isAssignment, isScalar, simpleVarName, localIndex, numWords;
sl@0: int code = TCL_OK;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: numWords = parsePtr->numWords;
sl@0: if ((numWords != 2) && (numWords != 3)) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: should be \"set varName ?newValue?\"", -1);
sl@0: return TCL_ERROR;
sl@0: }
sl@0: isAssignment = (numWords == 3);
sl@0:
sl@0: /*
sl@0: * Decide if we can use a frame slot for the var/array name or if we
sl@0: * need to emit code to compute and push the name at runtime. We use a
sl@0: * frame slot (entry in the array of local vars) if we are compiling a
sl@0: * procedure body and if the name is simple text that does not include
sl@0: * namespace qualifiers.
sl@0: */
sl@0:
sl@0: varTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0:
sl@0: code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
sl@0: #ifndef TCL_TIP280
sl@0: &localIndex, &simpleVarName, &isScalar);
sl@0: #else
sl@0: &localIndex, &simpleVarName, &isScalar,
sl@0: mapPtr->loc [eclIndex].line [1]);
sl@0: #endif
sl@0: if (code != TCL_OK) {
sl@0: goto done;
sl@0: }
sl@0:
sl@0: /*
sl@0: * If we are doing an assignment, push the new value.
sl@0: */
sl@0:
sl@0: if (isAssignment) {
sl@0: valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
sl@0: valueTokenPtr[1].size), envPtr);
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, valueTokenPtr+1,
sl@0: valueTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: goto done;
sl@0: }
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Emit instructions to set/get the variable.
sl@0: */
sl@0:
sl@0: if (simpleVarName) {
sl@0: if (isScalar) {
sl@0: if (localIndex >= 0) {
sl@0: if (localIndex <= 255) {
sl@0: TclEmitInstInt1((isAssignment?
sl@0: INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
sl@0: localIndex, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt4((isAssignment?
sl@0: INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
sl@0: localIndex, envPtr);
sl@0: }
sl@0: } else {
sl@0: TclEmitOpcode((isAssignment?
sl@0: INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr);
sl@0: }
sl@0: } else {
sl@0: if (localIndex >= 0) {
sl@0: if (localIndex <= 255) {
sl@0: TclEmitInstInt1((isAssignment?
sl@0: INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
sl@0: localIndex, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt4((isAssignment?
sl@0: INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
sl@0: localIndex, envPtr);
sl@0: }
sl@0: } else {
sl@0: TclEmitOpcode((isAssignment?
sl@0: INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);
sl@0: }
sl@0: }
sl@0: } else {
sl@0: TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
sl@0: }
sl@0:
sl@0: done:
sl@0: return code;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileStringCmd --
sl@0: *
sl@0: * Procedure called to compile the "string" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK if the
sl@0: * compilation was successful. If the command cannot be byte-compiled,
sl@0: * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
sl@0: * interpreter's result contains an error message, and TCL_ERROR is
sl@0: * returned.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "string" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileStringCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Tcl_Token *opTokenPtr, *varTokenPtr;
sl@0: Tcl_Obj *opObj;
sl@0: int index;
sl@0: int code;
sl@0:
sl@0: static CONST char *options[] = {
sl@0: "bytelength", "compare", "equal", "first",
sl@0: "index", "is", "last", "length",
sl@0: "map", "match", "range", "repeat",
sl@0: "replace", "tolower", "toupper", "totitle",
sl@0: "trim", "trimleft", "trimright",
sl@0: "wordend", "wordstart", (char *) NULL
sl@0: };
sl@0: enum options {
sl@0: STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
sl@0: STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
sl@0: STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
sl@0: STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
sl@0: STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
sl@0: STR_WORDEND, STR_WORDSTART
sl@0: };
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: if (parsePtr->numWords < 2) {
sl@0: /* Fail at run time, not in compilation */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0: opTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0:
sl@0: opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size);
sl@0: if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0,
sl@0: &index) != TCL_OK) {
sl@0: Tcl_DecrRefCount(opObj);
sl@0: Tcl_ResetResult(interp);
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0: Tcl_DecrRefCount(opObj);
sl@0:
sl@0: varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1);
sl@0:
sl@0: switch ((enum options) index) {
sl@0: case STR_BYTELENGTH:
sl@0: case STR_FIRST:
sl@0: case STR_IS:
sl@0: case STR_LAST:
sl@0: case STR_MAP:
sl@0: case STR_RANGE:
sl@0: case STR_REPEAT:
sl@0: case STR_REPLACE:
sl@0: case STR_TOLOWER:
sl@0: case STR_TOUPPER:
sl@0: case STR_TOTITLE:
sl@0: case STR_TRIM:
sl@0: case STR_TRIMLEFT:
sl@0: case STR_TRIMRIGHT:
sl@0: case STR_WORDEND:
sl@0: case STR_WORDSTART:
sl@0: /*
sl@0: * All other cases: compile out of line.
sl@0: */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0:
sl@0: case STR_COMPARE:
sl@0: case STR_EQUAL: {
sl@0: int i;
sl@0: /*
sl@0: * If there are any flags to the command, we can't byte compile it
sl@0: * because the INST_STR_EQ bytecode doesn't support flags.
sl@0: */
sl@0:
sl@0: if (parsePtr->numWords != 4) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Push the two operands onto the stack.
sl@0: */
sl@0:
sl@0: for (i = 0; i < 2; i++) {
sl@0: if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr,
sl@0: varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, varTokenPtr+1,
sl@0: varTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: return code;
sl@0: }
sl@0: }
sl@0: varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: }
sl@0:
sl@0: TclEmitOpcode(((((enum options) index) == STR_COMPARE) ?
sl@0: INST_STR_CMP : INST_STR_EQ), envPtr);
sl@0: return TCL_OK;
sl@0: }
sl@0: case STR_INDEX: {
sl@0: int i;
sl@0:
sl@0: if (parsePtr->numWords != 4) {
sl@0: /* Fail at run time, not in compilation */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Push the two operands onto the stack.
sl@0: */
sl@0:
sl@0: for (i = 0; i < 2; i++) {
sl@0: if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr,
sl@0: varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, varTokenPtr+1,
sl@0: varTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: return code;
sl@0: }
sl@0: }
sl@0: varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: }
sl@0:
sl@0: TclEmitOpcode(INST_STR_INDEX, envPtr);
sl@0: return TCL_OK;
sl@0: }
sl@0: case STR_LENGTH: {
sl@0: if (parsePtr->numWords != 3) {
sl@0: /* Fail at run time, not in compilation */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: /*
sl@0: * Here someone is asking for the length of a static string.
sl@0: * Just push the actual character (not byte) length.
sl@0: */
sl@0: char buf[TCL_INTEGER_SPACE];
sl@0: int len = Tcl_NumUtfChars(varTokenPtr[1].start,
sl@0: varTokenPtr[1].size);
sl@0: len = sprintf(buf, "%d", len);
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr);
sl@0: return TCL_OK;
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, varTokenPtr+1,
sl@0: varTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: return code;
sl@0: }
sl@0: }
sl@0: TclEmitOpcode(INST_STR_LEN, envPtr);
sl@0: return TCL_OK;
sl@0: }
sl@0: case STR_MATCH: {
sl@0: int i, length, exactMatch = 0, nocase = 0;
sl@0: CONST char *str;
sl@0:
sl@0: if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
sl@0: /* Fail at run time, not in compilation */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: if (parsePtr->numWords == 5) {
sl@0: if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0: str = varTokenPtr[1].start;
sl@0: length = varTokenPtr[1].size;
sl@0: if ((length > 1) &&
sl@0: strncmp(str, "-nocase", (size_t) length) == 0) {
sl@0: nocase = 1;
sl@0: } else {
sl@0: /* Fail at run time, not in compilation */
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0: varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: }
sl@0:
sl@0: for (i = 0; i < 2; i++) {
sl@0: if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: str = varTokenPtr[1].start;
sl@0: length = varTokenPtr[1].size;
sl@0: if (!nocase && (i == 0)) {
sl@0: /*
sl@0: * On the first (pattern) arg, check to see if any
sl@0: * glob special characters are in the word '*[]?\\'.
sl@0: * If not, this is the same as 'string equal'. We
sl@0: * can use strpbrk here because the glob chars are all
sl@0: * in the ascii-7 range. If -nocase was specified,
sl@0: * we can't do this because INST_STR_EQ has no support
sl@0: * for nocase.
sl@0: */
sl@0: Tcl_Obj *copy = Tcl_NewStringObj(str, length);
sl@0: Tcl_IncrRefCount(copy);
sl@0: exactMatch = (strpbrk(Tcl_GetString(copy),
sl@0: "*[]?\\") == NULL);
sl@0: Tcl_DecrRefCount(copy);
sl@0: }
sl@0: TclEmitPush(
sl@0: TclRegisterNewLiteral(envPtr, str, length), envPtr);
sl@0: } else {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0: #endif
sl@0: code = TclCompileTokens(interp, varTokenPtr+1,
sl@0: varTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: return code;
sl@0: }
sl@0: }
sl@0: varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: }
sl@0:
sl@0: if (exactMatch) {
sl@0: TclEmitOpcode(INST_STR_EQ, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
sl@0: }
sl@0: return TCL_OK;
sl@0: }
sl@0: }
sl@0:
sl@0: return TCL_OK;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileVariableCmd --
sl@0: *
sl@0: * Procedure called to reserve the local variables for the
sl@0: * "variable" command. The command itself is *not* compiled.
sl@0: *
sl@0: * Results:
sl@0: * Always returns TCL_OUT_LINE_COMPILE.
sl@0: *
sl@0: * Side effects:
sl@0: * Indexed local variables are added to the environment.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0: int
sl@0: TclCompileVariableCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Tcl_Token *varTokenPtr;
sl@0: int i, numWords;
sl@0: CONST char *varName, *tail;
sl@0:
sl@0: if (envPtr->procPtr == NULL) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: numWords = parsePtr->numWords;
sl@0:
sl@0: varTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0: for (i = 1; i < numWords; i += 2) {
sl@0: if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0: varName = varTokenPtr[1].start;
sl@0: tail = varName + varTokenPtr[1].size - 1;
sl@0: if ((*tail == ')') || (tail < varName)) continue;
sl@0: while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
sl@0: tail--;
sl@0: }
sl@0: if ((*tail == ':') && (tail > varName)) {
sl@0: tail++;
sl@0: }
sl@0: (void) TclFindCompiledLocal(tail, (tail-varName+1),
sl@0: /*create*/ 1, /*flags*/ 0, envPtr->procPtr);
sl@0: varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0: }
sl@0: }
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclCompileWhileCmd --
sl@0: *
sl@0: * Procedure called to compile the "while" command.
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is TCL_OK if
sl@0: * compilation was successful. If an error occurs then the
sl@0: * interpreter's result contains a standard error message and TCL_ERROR
sl@0: * is returned. If compilation failed because the command is too
sl@0: * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned
sl@0: * indicating that the while command should be compiled "out of line"
sl@0: * by emitting code to invoke its command procedure at runtime.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "while" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: int
sl@0: TclCompileWhileCmd(interp, parsePtr, envPtr)
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Parse *parsePtr; /* Points to a parse structure for the
sl@0: * command created by Tcl_ParseCommand. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: {
sl@0: Tcl_Token *testTokenPtr, *bodyTokenPtr;
sl@0: JumpFixup jumpEvalCondFixup;
sl@0: int testCodeOffset, bodyCodeOffset, jumpDist;
sl@0: int range, code;
sl@0: char buffer[32 + TCL_INTEGER_SPACE];
sl@0: int savedStackDepth = envPtr->currStackDepth;
sl@0: int loopMayEnd = 1; /* This is set to 0 if it is recognized as
sl@0: * an infinite loop. */
sl@0: Tcl_Obj *boolObj;
sl@0: int boolVal;
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: /* TIP #280 : Remember the per-word line information of the current
sl@0: * command. An index is used instead of a pointer as recursive compilation
sl@0: * may reallocate, i.e. move, the array. This is also the reason to save
sl@0: * the nuloc now, it may change during the course of the function.
sl@0: */
sl@0: ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0: int eclIndex = mapPtr->nuloc - 1;
sl@0: #endif
sl@0:
sl@0: if (parsePtr->numWords != 3) {
sl@0: Tcl_ResetResult(interp);
sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: "wrong # args: should be \"while test command\"", -1);
sl@0: return TCL_ERROR;
sl@0: }
sl@0:
sl@0: /*
sl@0: * If the test expression requires substitutions, don't compile the
sl@0: * while command inline. E.g., the expression might cause the loop to
sl@0: * never execute or execute forever, as in "while "$x < 5" {}".
sl@0: *
sl@0: * Bail out also if the body expression requires substitutions
sl@0: * in order to insure correct behaviour [Bug 219166]
sl@0: */
sl@0:
sl@0: testTokenPtr = parsePtr->tokenPtr
sl@0: + (parsePtr->tokenPtr->numComponents + 1);
sl@0: bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
sl@0: if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
sl@0: || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
sl@0: return TCL_OUT_LINE_COMPILE;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Find out if the condition is a constant.
sl@0: */
sl@0:
sl@0: boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
sl@0: Tcl_IncrRefCount(boolObj);
sl@0: code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
sl@0: Tcl_DecrRefCount(boolObj);
sl@0: if (code == TCL_OK) {
sl@0: if (boolVal) {
sl@0: /*
sl@0: * it is an infinite loop
sl@0: */
sl@0:
sl@0: loopMayEnd = 0;
sl@0: } else {
sl@0: /*
sl@0: * This is an empty loop: "while 0 {...}" or such.
sl@0: * Compile no bytecodes.
sl@0: */
sl@0:
sl@0: goto pushResult;
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Create a ExceptionRange record for the loop body. This is used to
sl@0: * implement break and continue.
sl@0: */
sl@0:
sl@0: envPtr->exceptDepth++;
sl@0: envPtr->maxExceptDepth =
sl@0: TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
sl@0: range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
sl@0:
sl@0: /*
sl@0: * Jump to the evaluation of the condition. This code uses the "loop
sl@0: * rotation" optimisation (which eliminates one branch from the loop).
sl@0: * "while cond body" produces then:
sl@0: * goto A
sl@0: * B: body : bodyCodeOffset
sl@0: * A: cond -> result : testCodeOffset, continueOffset
sl@0: * if (result) goto B
sl@0: *
sl@0: * The infinite loop "while 1 body" produces:
sl@0: * B: body : all three offsets here
sl@0: * goto B
sl@0: */
sl@0:
sl@0: if (loopMayEnd) {
sl@0: TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
sl@0: testCodeOffset = 0; /* avoid compiler warning */
sl@0: } else {
sl@0: testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0: }
sl@0:
sl@0:
sl@0: /*
sl@0: * Compile the loop body.
sl@0: */
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0: #endif
sl@0: bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0: code = TclCompileCmdWord(interp, bodyTokenPtr+1,
sl@0: bodyTokenPtr->numComponents, envPtr);
sl@0: envPtr->currStackDepth = savedStackDepth + 1;
sl@0: if (code != TCL_OK) {
sl@0: if (code == TCL_ERROR) {
sl@0: sprintf(buffer, "\n (\"while\" body line %d)",
sl@0: interp->errorLine);
sl@0: Tcl_AddObjErrorInfo(interp, buffer, -1);
sl@0: }
sl@0: goto error;
sl@0: }
sl@0: envPtr->exceptArrayPtr[range].numCodeBytes =
sl@0: (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
sl@0: TclEmitOpcode(INST_POP, envPtr);
sl@0:
sl@0: /*
sl@0: * Compile the test expression then emit the conditional jump that
sl@0: * terminates the while. We already know it's a simple word.
sl@0: */
sl@0:
sl@0: if (loopMayEnd) {
sl@0: testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0: jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
sl@0: if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
sl@0: bodyCodeOffset += 3;
sl@0: testCodeOffset += 3;
sl@0: }
sl@0: envPtr->currStackDepth = savedStackDepth;
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = mapPtr->loc [eclIndex].line [1];
sl@0: #endif
sl@0: code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: if (code == TCL_ERROR) {
sl@0: Tcl_AddObjErrorInfo(interp,
sl@0: "\n (\"while\" test expression)", -1);
sl@0: }
sl@0: goto error;
sl@0: }
sl@0: envPtr->currStackDepth = savedStackDepth + 1;
sl@0:
sl@0: jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
sl@0: if (jumpDist > 127) {
sl@0: TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
sl@0: }
sl@0: } else {
sl@0: jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
sl@0: if (jumpDist > 127) {
sl@0: TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
sl@0: } else {
sl@0: TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
sl@0: }
sl@0: }
sl@0:
sl@0:
sl@0: /*
sl@0: * Set the loop's body, continue and break offsets.
sl@0: */
sl@0:
sl@0: envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
sl@0: envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
sl@0: envPtr->exceptArrayPtr[range].breakOffset =
sl@0: (envPtr->codeNext - envPtr->codeStart);
sl@0:
sl@0: /*
sl@0: * The while command's result is an empty string.
sl@0: */
sl@0:
sl@0: pushResult:
sl@0: envPtr->currStackDepth = savedStackDepth;
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0: envPtr->exceptDepth--;
sl@0: return TCL_OK;
sl@0:
sl@0: error:
sl@0: envPtr->exceptDepth--;
sl@0: return code;
sl@0: }
sl@0:
sl@0: /*
sl@0: *----------------------------------------------------------------------
sl@0: *
sl@0: * TclPushVarName --
sl@0: *
sl@0: * Procedure used in the compiling where pushing a variable name
sl@0: * is necessary (append, lappend, set).
sl@0: *
sl@0: * Results:
sl@0: * The return value is a standard Tcl result, which is normally TCL_OK
sl@0: * unless there was an error while parsing string. If an error occurs
sl@0: * then the interpreter's result contains a standard error message.
sl@0: *
sl@0: * Side effects:
sl@0: * Instructions are added to envPtr to execute the "set" command
sl@0: * at runtime.
sl@0: *
sl@0: *----------------------------------------------------------------------
sl@0: */
sl@0:
sl@0: static int
sl@0: TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
sl@0: #ifndef TCL_TIP280
sl@0: simpleVarNamePtr, isScalarPtr)
sl@0: #else
sl@0: simpleVarNamePtr, isScalarPtr, line)
sl@0: #endif
sl@0: Tcl_Interp *interp; /* Used for error reporting. */
sl@0: Tcl_Token *varTokenPtr; /* Points to a variable token. */
sl@0: CompileEnv *envPtr; /* Holds resulting instructions. */
sl@0: int flags; /* takes TCL_CREATE_VAR or
sl@0: * TCL_NO_LARGE_INDEX */
sl@0: int *localIndexPtr; /* must not be NULL */
sl@0: int *simpleVarNamePtr; /* must not be NULL */
sl@0: int *isScalarPtr; /* must not be NULL */
sl@0: #ifdef TCL_TIP280
sl@0: int line; /* line the token starts on */
sl@0: #endif
sl@0: {
sl@0: register CONST char *p;
sl@0: CONST char *name, *elName;
sl@0: register int i, n;
sl@0: int nameChars, elNameChars, simpleVarName, localIndex;
sl@0: int code = TCL_OK;
sl@0:
sl@0: Tcl_Token *elemTokenPtr = NULL;
sl@0: int elemTokenCount = 0;
sl@0: int allocedTokens = 0;
sl@0: int removedParen = 0;
sl@0:
sl@0: /*
sl@0: * Decide if we can use a frame slot for the var/array name or if we
sl@0: * need to emit code to compute and push the name at runtime. We use a
sl@0: * frame slot (entry in the array of local vars) if we are compiling a
sl@0: * procedure body and if the name is simple text that does not include
sl@0: * namespace qualifiers.
sl@0: */
sl@0:
sl@0: simpleVarName = 0;
sl@0: name = elName = NULL;
sl@0: nameChars = elNameChars = 0;
sl@0: localIndex = -1;
sl@0:
sl@0: /*
sl@0: * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
sl@0: * curly braces surround the variable name.
sl@0: * This really matters for array elements to handle things like
sl@0: * set {x($foo)} 5
sl@0: * which raises an undefined var error if we are not careful here.
sl@0: */
sl@0:
sl@0: if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
sl@0: (varTokenPtr->start[0] != '{')) {
sl@0: /*
sl@0: * A simple variable name. Divide it up into "name" and "elName"
sl@0: * strings. If it is not a local variable, look it up at runtime.
sl@0: */
sl@0: simpleVarName = 1;
sl@0:
sl@0: name = varTokenPtr[1].start;
sl@0: nameChars = varTokenPtr[1].size;
sl@0: if ( *(name + nameChars - 1) == ')') {
sl@0: /*
sl@0: * last char is ')' => potential array reference.
sl@0: */
sl@0:
sl@0: for (i = 0, p = name; i < nameChars; i++, p++) {
sl@0: if (*p == '(') {
sl@0: elName = p + 1;
sl@0: elNameChars = nameChars - i - 2;
sl@0: nameChars = i ;
sl@0: break;
sl@0: }
sl@0: }
sl@0:
sl@0: if ((elName != NULL) && elNameChars) {
sl@0: /*
sl@0: * An array element, the element name is a simple
sl@0: * string: assemble the corresponding token.
sl@0: */
sl@0:
sl@0: elemTokenPtr = (Tcl_Token *) ckalloc(sizeof(Tcl_Token));
sl@0: allocedTokens = 1;
sl@0: elemTokenPtr->type = TCL_TOKEN_TEXT;
sl@0: elemTokenPtr->start = elName;
sl@0: elemTokenPtr->size = elNameChars;
sl@0: elemTokenPtr->numComponents = 0;
sl@0: elemTokenCount = 1;
sl@0: }
sl@0: }
sl@0: } else if (((n = varTokenPtr->numComponents) > 1)
sl@0: && (varTokenPtr[1].type == TCL_TOKEN_TEXT)
sl@0: && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
sl@0: && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
sl@0:
sl@0: /*
sl@0: * Check for parentheses inside first token
sl@0: */
sl@0:
sl@0: simpleVarName = 0;
sl@0: for (i = 0, p = varTokenPtr[1].start;
sl@0: i < varTokenPtr[1].size; i++, p++) {
sl@0: if (*p == '(') {
sl@0: simpleVarName = 1;
sl@0: break;
sl@0: }
sl@0: }
sl@0: if (simpleVarName) {
sl@0: int remainingChars;
sl@0:
sl@0: /*
sl@0: * Check the last token: if it is just ')', do not count
sl@0: * it. Otherwise, remove the ')' and flag so that it is
sl@0: * restored at the end.
sl@0: */
sl@0:
sl@0: if (varTokenPtr[n].size == 1) {
sl@0: --n;
sl@0: } else {
sl@0: --varTokenPtr[n].size;
sl@0: removedParen = n;
sl@0: }
sl@0:
sl@0: name = varTokenPtr[1].start;
sl@0: nameChars = p - varTokenPtr[1].start;
sl@0: elName = p + 1;
sl@0: remainingChars = (varTokenPtr[2].start - p) - 1;
sl@0: elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;
sl@0:
sl@0: if (remainingChars) {
sl@0: /*
sl@0: * Make a first token with the extra characters in the first
sl@0: * token.
sl@0: */
sl@0:
sl@0: elemTokenPtr = (Tcl_Token *) ckalloc(n * sizeof(Tcl_Token));
sl@0: allocedTokens = 1;
sl@0: elemTokenPtr->type = TCL_TOKEN_TEXT;
sl@0: elemTokenPtr->start = elName;
sl@0: elemTokenPtr->size = remainingChars;
sl@0: elemTokenPtr->numComponents = 0;
sl@0: elemTokenCount = n;
sl@0:
sl@0: /*
sl@0: * Copy the remaining tokens.
sl@0: */
sl@0:
sl@0: memcpy((void *) (elemTokenPtr+1), (void *) (&varTokenPtr[2]),
sl@0: ((n-1) * sizeof(Tcl_Token)));
sl@0: } else {
sl@0: /*
sl@0: * Use the already available tokens.
sl@0: */
sl@0:
sl@0: elemTokenPtr = &varTokenPtr[2];
sl@0: elemTokenCount = n - 1;
sl@0: }
sl@0: }
sl@0: }
sl@0:
sl@0: if (simpleVarName) {
sl@0: /*
sl@0: * See whether name has any namespace separators (::'s).
sl@0: */
sl@0:
sl@0: int hasNsQualifiers = 0;
sl@0: for (i = 0, p = name; i < nameChars; i++, p++) {
sl@0: if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
sl@0: hasNsQualifiers = 1;
sl@0: break;
sl@0: }
sl@0: }
sl@0:
sl@0: /*
sl@0: * Look up the var name's index in the array of local vars in the
sl@0: * proc frame. If retrieving the var's value and it doesn't already
sl@0: * exist, push its name and look it up at runtime.
sl@0: */
sl@0:
sl@0: if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
sl@0: localIndex = TclFindCompiledLocal(name, nameChars,
sl@0: /*create*/ (flags & TCL_CREATE_VAR),
sl@0: /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
sl@0: envPtr->procPtr);
sl@0: if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
sl@0: /* we'll push the name */
sl@0: localIndex = -1;
sl@0: }
sl@0: }
sl@0: if (localIndex < 0) {
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr);
sl@0: }
sl@0:
sl@0: /*
sl@0: * Compile the element script, if any.
sl@0: */
sl@0:
sl@0: if (elName != NULL) {
sl@0: if (elNameChars) {
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = line;
sl@0: #endif
sl@0: code = TclCompileTokens(interp, elemTokenPtr,
sl@0: elemTokenCount, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: goto done;
sl@0: }
sl@0: } else {
sl@0: TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0: }
sl@0: }
sl@0: } else {
sl@0: /*
sl@0: * The var name isn't simple: compile and push it.
sl@0: */
sl@0:
sl@0: #ifdef TCL_TIP280
sl@0: envPtr->line = line;
sl@0: #endif
sl@0: code = TclCompileTokens(interp, varTokenPtr+1,
sl@0: varTokenPtr->numComponents, envPtr);
sl@0: if (code != TCL_OK) {
sl@0: goto done;
sl@0: }
sl@0: }
sl@0:
sl@0: done:
sl@0: if (removedParen) {
sl@0: ++varTokenPtr[removedParen].size;
sl@0: }
sl@0: if (allocedTokens) {
sl@0: ckfree((char *) elemTokenPtr);
sl@0: }
sl@0: *localIndexPtr = localIndex;
sl@0: *simpleVarNamePtr = simpleVarName;
sl@0: *isScalarPtr = (elName == NULL);
sl@0: return code;
sl@0: }
sl@0:
sl@0: /*
sl@0: * Local Variables:
sl@0: * mode: c
sl@0: * c-basic-offset: 4
sl@0: * fill-column: 78
sl@0: * End:
sl@0: */
sl@0: