/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcompexpr.c

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcompexpr.c

Parent Directory | Revision Log | View Patch Patch

-revision 67 by dashley,
Mon Oct 31 00:57:34 2016 UTC
+revision 71 by dashley,
Sat Nov  5 11:07:06 2016 UTC
 Line 1
  /* $Header$ */
  /*
   * tclCompExpr.c --
   *
   *      This file contains the code to compile Tcl expressions.
   *
   * Copyright (c) 1997 Sun Microsystems, Inc.
   *
   * See the file "license.terms" for information on usage and redistribution
   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
   *
   * RCS: @(#) $Id: tclcompexpr.c,v 1.1.1.1 2001/06/13 04:35:43 dtashley Exp $
   */
  #include "tclInt.h"
  #include "tclCompile.h"
  /*
   * The stuff below is a bit of a hack so that this file can be used in
   * environments that include no UNIX, i.e. no errno: just arrange to use
   * the errno from tclExecute.c here.
   */
  #ifndef TCL_GENERIC_ONLY
  #include "tclPort.h"
  #else
  #define NO_ERRNO_H
  #endif
  #ifdef NO_ERRNO_H
  extern int errno;                       /* Use errno from tclExecute.c. */
  #define ERANGE 34
  #endif
  /*
   * Boolean variable that controls whether expression compilation tracing
   * is enabled.
   */
  #ifdef TCL_COMPILE_DEBUG
  static int traceExprComp = 0;
  #endif /* TCL_COMPILE_DEBUG */
  /*
   * The ExprInfo structure describes the state of compiling an expression.
   * A pointer to an ExprInfo record is passed among the routines in
   * this module.
   */
  typedef struct ExprInfo {
      Tcl_Interp *interp;         /* Used for error reporting. */
      Tcl_Parse *parsePtr;        /* Structure filled with information about
                                   * the parsed expression. */
      char *expr;                 /* The expression that was originally passed
                                   * to TclCompileExpr. */
      char *lastChar;             /* Points just after last byte of expr. */
      int hasOperators;           /* Set 1 if the expr has operators; 0 if
                                   * expr is only a primary. If 1 after
                                   * compiling an expr, a tryCvtToNumeric
                                   * instruction is emitted to convert the
                                   * primary to a number if possible. */
      int exprIsJustVarRef;       /* Set 1 if the expr consists of just a
                                   * variable reference as in the expression
                                   * of "if $b then...". Otherwise 0. If 1 the
                                   * expr is compiled out-of-line in order to
                                   * implement expr's 2 level substitution
                                   * semantics properly. */
      int exprIsComparison;       /* Set 1 if the top-level operator in the
                                   * expr is a comparison. Otherwise 0. If 1,
                                   * because the operands might be strings,
                                   * the expr is compiled out-of-line in order
                                   * to implement expr's 2 level substitution
                                   * semantics properly. */
  } ExprInfo;
  /*
   * Definitions of numeric codes representing each expression operator.
   * The order of these must match the entries in the operatorTable below.
   * Also the codes for the relational operators (OP_LESS, OP_GREATER,
   * OP_LE, OP_GE, OP_EQ, and OP_NE) must be consecutive and in that order.
   * Note that OP_PLUS and OP_MINUS represent both unary and binary operators.
   */
  #define OP_MULT         0
  #define OP_DIVIDE       1
  #define OP_MOD          2
  #define OP_PLUS         3
  #define OP_MINUS        4
  #define OP_LSHIFT       5
  #define OP_RSHIFT       6
  #define OP_LESS         7
  #define OP_GREATER      8
  #define OP_LE           9
  #define OP_GE           10
  #define OP_EQ           11
  #define OP_NEQ          12
  #define OP_BITAND       13
  #define OP_BITXOR       14
  #define OP_BITOR        15
  #define OP_LAND         16
  #define OP_LOR          17
  #define OP_QUESTY       18
  #define OP_LNOT         19
  #define OP_BITNOT       20
  /*
   * Table describing the expression operators. Entries in this table must
   * correspond to the definitions of numeric codes for operators just above.
   */
  static int opTableInitialized = 0; /* 0 means not yet initialized. */
  TCL_DECLARE_MUTEX(opMutex)
  typedef struct OperatorDesc {
      char *name;                 /* Name of the operator. */
      int numOperands;            /* Number of operands. 0 if the operator
                                   * requires special handling. */
      int instruction;            /* Instruction opcode for the operator.
                                   * Ignored if numOperands is 0. */
  } OperatorDesc;
  OperatorDesc operatorTable[] = {
      {"*",   2,  INST_MULT},
      {"/",   2,  INST_DIV},
      {"%",   2,  INST_MOD},
      {"+",   0},
      {"-",   0},
      {"<<",  2,  INST_LSHIFT},
      {">>",  2,  INST_RSHIFT},
      {"<",   2,  INST_LT},
      {">",   2,  INST_GT},
      {"<=",  2,  INST_LE},
      {">=",  2,  INST_GE},
      {"==",  2,  INST_EQ},
      {"!=",  2,  INST_NEQ},
      {"&",   2,  INST_BITAND},
      {"^",   2,  INST_BITXOR},
      {"|",   2,  INST_BITOR},
      {"&&",  0},
      {"||",  0},
      {"?",   0},
      {"!",   1,  INST_LNOT},
      {"~",   1,  INST_BITNOT},
      {NULL}
  };
  /*
   * Hashtable used to map the names of expression operators to the index
   * of their OperatorDesc description.
   */
  static Tcl_HashTable opHashTable;
  /*
   * Declarations for local procedures to this file:
   */
  static int              CompileCondExpr _ANSI_ARGS_((
                              Tcl_Token *exprTokenPtr, ExprInfo *infoPtr,
                              CompileEnv *envPtr, Tcl_Token **endPtrPtr));
  static int              CompileLandOrLorExpr _ANSI_ARGS_((
                              Tcl_Token *exprTokenPtr, int opIndex,
                              ExprInfo *infoPtr, CompileEnv *envPtr,
                              Tcl_Token **endPtrPtr));
  static int              CompileMathFuncCall _ANSI_ARGS_((
                              Tcl_Token *exprTokenPtr, char *funcName,
                              ExprInfo *infoPtr, CompileEnv *envPtr,
                              Tcl_Token **endPtrPtr));
  static int              CompileSubExpr _ANSI_ARGS_((
                              Tcl_Token *exprTokenPtr, ExprInfo *infoPtr,
                              CompileEnv *envPtr));
  static void             LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr));
  /*
   * Macro used to debug the execution of the expression compiler.
   */
  #ifdef TCL_COMPILE_DEBUG
  #define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \
      if (traceExprComp) { \
          fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \
                  (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \
      }
  #else
  #define TRACE(exprBytes, exprLength, tokenBytes, tokenLength)
  #endif /* TCL_COMPILE_DEBUG */
  /*
   *----------------------------------------------------------------------
   *
   * TclCompileExpr --
   *
   *      This procedure compiles a string containing a Tcl expression into
   *      Tcl bytecodes. This procedure is the top-level interface to the
   *      the expression compilation module, and is used by such public
   *      procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong,
   *      Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj.
   *
   * Results:
   *      The return value is TCL_OK on a successful compilation and TCL_ERROR
   *      on failure. If TCL_ERROR is returned, then the interpreter's result
   *      contains an error message.
   *
   *      envPtr->maxStackDepth is updated with the maximum number of stack
   *      elements needed to execute the expression.
   *
   *      envPtr->exprIsJustVarRef is set 1 if the expression consisted of
   *      a single variable reference as in the expression of "if $b then...".
   *      Otherwise it is set 0. This is used to implement Tcl's two level
   *      expression substitution semantics properly.
   *
   *      envPtr->exprIsComparison is set 1 if the top-level operator in the
   *      expr is a comparison. Otherwise it is set 0. If 1, because the
   *      operands might be strings, the expr is compiled out-of-line in order
   *      to implement expr's 2 level substitution semantics properly.
   *
   * Side effects:
   *      Adds instructions to envPtr to evaluate the expression at runtime.
   *
   *----------------------------------------------------------------------
   */
  int
  TclCompileExpr(interp, script, numBytes, envPtr)
      Tcl_Interp *interp;         /* Used for error reporting. */
      char *script;               /* The source script to compile. */
      int numBytes;               /* Number of bytes in script. If < 0, the
                                   * string consists of all bytes up to the
                                   * first null character. */
      CompileEnv *envPtr;         /* Holds resulting instructions. */
  {
      ExprInfo info;
      Tcl_Parse parse;
      Tcl_HashEntry *hPtr;
      int maxDepth, new, i, code;
      /*
       * If this is the first time we've been called, initialize the table
       * of expression operators.
       */
      if (numBytes < 0) {
          numBytes = (script? strlen(script) : 0);
      }
      if (!opTableInitialized) {
          Tcl_MutexLock(&opMutex);
          if (!opTableInitialized) {
              Tcl_InitHashTable(&opHashTable, TCL_STRING_KEYS);
              for (i = 0;  operatorTable[i].name != NULL;  i++) {
                  hPtr = Tcl_CreateHashEntry(&opHashTable,
                          operatorTable[i].name, &new);
                  if (new) {
                      Tcl_SetHashValue(hPtr, (ClientData) i);
                  }
              }
              opTableInitialized = 1;
          }
          Tcl_MutexUnlock(&opMutex);
      }
      /*
       * Initialize the structure containing information abvout this
       * expression compilation.
       */
      info.interp = interp;
      info.parsePtr = &parse;
      info.expr = script;
      info.lastChar = (script + numBytes);
      info.hasOperators = 0;
      info.exprIsJustVarRef = 1;  /* will be set 0 if anything else is seen */
      info.exprIsComparison = 0;
      /*
       * Parse the expression then compile it.
       */
      maxDepth = 0;
      code = Tcl_ParseExpr(interp, script, numBytes, &parse);
      if (code != TCL_OK) {
          goto done;
      }
      code = CompileSubExpr(parse.tokenPtr, &info, envPtr);
      if (code != TCL_OK) {
          Tcl_FreeParse(&parse);
          goto done;
      }
      maxDepth = envPtr->maxStackDepth;
      if (!info.hasOperators) {
          /*
           * Attempt to convert the primary's object to an int or double.
           * This is done in order to support Tcl's policy of interpreting
           * operands if at all possible as first integers, else
           * floating-point numbers.
           */
          TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
      }
      Tcl_FreeParse(&parse);
      done:
      envPtr->maxStackDepth = maxDepth;
      envPtr->exprIsJustVarRef = info.exprIsJustVarRef;
      envPtr->exprIsComparison = info.exprIsComparison;
      return code;
  }
  /*
   *----------------------------------------------------------------------
   *
   * TclFinalizeCompilation --
   *
   *      Clean up the compilation environment so it can later be
   *      properly reinitialized. This procedure is called by
   *      TclFinalizeCompExecEnv() in tclObj.c, which in turn is called
   *      by Tcl_Finalize().
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      Cleans up the compilation environment. At the moment, just the
   *      table of expression operators is freed.
   *
   *----------------------------------------------------------------------
   */
  void
  TclFinalizeCompilation()
  {
      Tcl_MutexLock(&opMutex);
      if (opTableInitialized) {
          Tcl_DeleteHashTable(&opHashTable);
          opTableInitialized = 0;
      }
      Tcl_MutexUnlock(&opMutex);
  }
  /*
   *----------------------------------------------------------------------
   *
   * CompileSubExpr --
   *
   *      Given a pointer to a TCL_TOKEN_SUB_EXPR token describing a
   *      subexpression, this procedure emits instructions to evaluate the
   *      subexpression at runtime.
   *
   * Results:
   *      The return value is TCL_OK on a successful compilation and TCL_ERROR
   *      on failure. If TCL_ERROR is returned, then the interpreter's result
   *      contains an error message.
   *
   *      envPtr->maxStackDepth is updated with the maximum number of stack
   *      elements needed to execute the subexpression.
   *
   *      envPtr->exprIsJustVarRef is set 1 if the subexpression consisted of
   *      a single variable reference as in the expression of "if $b then...".
   *      Otherwise it is set 0. This is used to implement Tcl's two level
   *      expression substitution semantics properly.
   *
   *      envPtr->exprIsComparison is set 1 if the top-level operator in the
   *      subexpression is a comparison. Otherwise it is set 0. If 1, because
   *      the operands might be strings, the expr is compiled out-of-line in
   *      order to implement expr's 2 level substitution semantics properly.
   *
   * Side effects:
   *      Adds instructions to envPtr to evaluate the subexpression.
   *
   *----------------------------------------------------------------------
   */
  static int
  CompileSubExpr(exprTokenPtr, infoPtr, envPtr)
      Tcl_Token *exprTokenPtr;    /* Points to TCL_TOKEN_SUB_EXPR token
                                   * to compile. */
      ExprInfo *infoPtr;          /* Describes the compilation state for the
                                   * expression being compiled. */
      CompileEnv *envPtr;         /* Holds resulting instructions. */
  {
      Tcl_Interp *interp = infoPtr->interp;
      Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr;
      OperatorDesc *opDescPtr;
      Tcl_HashEntry *hPtr;
      char *operator;
      char savedChar;
      int maxDepth, objIndex, opIndex, length, code;
      char buffer[TCL_UTF_MAX];
      if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) {
          panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n",
                  exprTokenPtr->type);
      }
      maxDepth = 0;
      code = TCL_OK;
      /*
       * Switch on the type of the first token after the subexpression token.
       * After processing it, advance tokenPtr to point just after the
       * subexpression's last token.
       */
      tokenPtr = exprTokenPtr+1;
      TRACE(exprTokenPtr->start, exprTokenPtr->size,
              tokenPtr->start, tokenPtr->size);
      switch (tokenPtr->type) {
          case TCL_TOKEN_WORD:
              code = TclCompileTokens(interp, tokenPtr+1,
                      tokenPtr->numComponents, envPtr);
              if (code != TCL_OK) {
                  goto done;
              }
              maxDepth = envPtr->maxStackDepth;
              tokenPtr += (tokenPtr->numComponents + 1);
              infoPtr->exprIsJustVarRef = 0;
              break;
          case TCL_TOKEN_TEXT:
              if (tokenPtr->size > 0) {
                  objIndex = TclRegisterLiteral(envPtr, tokenPtr->start,
                          tokenPtr->size, /*onHeap*/ 0);
              } else {
                  objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0);
              }
              TclEmitPush(objIndex, envPtr);
              maxDepth = 1;
              tokenPtr += 1;
              infoPtr->exprIsJustVarRef = 0;
              break;
          case TCL_TOKEN_BS:
              length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
                      buffer);
              if (length > 0) {
                  objIndex = TclRegisterLiteral(envPtr, buffer, length,
                          /*onHeap*/ 0);
              } else {
                  objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0);
              }
              TclEmitPush(objIndex, envPtr);
              maxDepth = 1;
              tokenPtr += 1;
              infoPtr->exprIsJustVarRef = 0;
              break;
          case TCL_TOKEN_COMMAND:
              code = TclCompileScript(interp, tokenPtr->start+1,
                      tokenPtr->size-2, /*nested*/ 1, envPtr);
              if (code != TCL_OK) {
                  goto done;
              }
              maxDepth = envPtr->maxStackDepth;
              tokenPtr += 1;
              infoPtr->exprIsJustVarRef = 0;
              break;
          case TCL_TOKEN_VARIABLE:
              code = TclCompileTokens(interp, tokenPtr, 1, envPtr);
              if (code != TCL_OK) {
                  goto done;
              }
              maxDepth = envPtr->maxStackDepth;
              tokenPtr += (tokenPtr->numComponents + 1);
              break;
          case TCL_TOKEN_SUB_EXPR:
              infoPtr->exprIsComparison = 0;
              code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
              if (code != TCL_OK) {
                  goto done;
              }
              maxDepth = envPtr->maxStackDepth;
              tokenPtr += (tokenPtr->numComponents + 1);
              break;
          case TCL_TOKEN_OPERATOR:
              /*
               * Look up the operator. Temporarily overwrite the character
               * just after the end of the operator with a 0 byte. If the
               * operator isn't found, treat it as a math function.
               */
              /*
               * TODO: Note that the string is modified in place.  This is unsafe
               * and will break if any of the routines called while the string is
               * modified have side effects that depend on the original string
               * being unmodified (e.g. adding an entry to the literal table).
               */
              operator = tokenPtr->start;
              savedChar = operator[tokenPtr->size];
              operator[tokenPtr->size] = 0;
              hPtr = Tcl_FindHashEntry(&opHashTable, operator);
              if (hPtr == NULL) {
                  code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr,
                          envPtr, &endPtr);
                  operator[tokenPtr->size] = (char) savedChar;
                  if (code != TCL_OK) {
                      goto done;
                  }
                  maxDepth = envPtr->maxStackDepth;
                  tokenPtr = endPtr;
                  infoPtr->exprIsJustVarRef = 0;
                  infoPtr->exprIsComparison = 0;
                  break;
              }
              operator[tokenPtr->size] = (char) savedChar;
              opIndex = (int) Tcl_GetHashValue(hPtr);
              opDescPtr = &(operatorTable[opIndex]);
              /*
               * If the operator is "normal", compile it using information
               * from the operator table.
               */
              if (opDescPtr->numOperands > 0) {
                  tokenPtr++;
                  code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
                  if (code != TCL_OK) {
                      goto done;
                  }
                  maxDepth = envPtr->maxStackDepth;
                  tokenPtr += (tokenPtr->numComponents + 1);
                  if (opDescPtr->numOperands == 2) {
                      code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
                      if (code != TCL_OK) {
                          goto done;
                      }
                      maxDepth = TclMax((envPtr->maxStackDepth + 1),
                              maxDepth);
                      tokenPtr += (tokenPtr->numComponents + 1);
                  }
                  TclEmitOpcode(opDescPtr->instruction, envPtr);
                  infoPtr->hasOperators = 1;
                  infoPtr->exprIsJustVarRef = 0;
                  infoPtr->exprIsComparison =
                          ((opIndex >= OP_LESS) && (opIndex <= OP_NEQ));
                  break;
              }
              /*
               * The operator requires special treatment, and is either
               * "+" or "-", or one of "&&", "||" or "?".
               */
              switch (opIndex) {
                  case OP_PLUS:
                  case OP_MINUS:
                      tokenPtr++;
                      code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
                      if (code != TCL_OK) {
                          goto done;
                      }
                      maxDepth = envPtr->maxStackDepth;
                      tokenPtr += (tokenPtr->numComponents + 1);
                      /*
                       * Check whether the "+" or "-" is unary.
                       */
                      afterSubexprPtr = exprTokenPtr
                              + exprTokenPtr->numComponents+1;
                      if (tokenPtr == afterSubexprPtr) {
                          TclEmitOpcode(((opIndex==OP_PLUS)?
                                  INST_UPLUS : INST_UMINUS),
                                  envPtr);
                          break;
                      }
                      /*
                       * The "+" or "-" is binary.
                       */
                      code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
                      if (code != TCL_OK) {
                          goto done;
                      }
                      maxDepth = TclMax((envPtr->maxStackDepth + 1),
                              maxDepth);
                      tokenPtr += (tokenPtr->numComponents + 1);
                      TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB),
                              envPtr);
                      break;
                  case OP_LAND:
                  case OP_LOR:
                      code = CompileLandOrLorExpr(exprTokenPtr, opIndex,
                              infoPtr, envPtr, &endPtr);
                      if (code != TCL_OK) {
                          goto done;
                      }
                      maxDepth = envPtr->maxStackDepth;
                      tokenPtr = endPtr;
                      break;
                  case OP_QUESTY:
                      code = CompileCondExpr(exprTokenPtr, infoPtr,
                              envPtr, &endPtr);
                      if (code != TCL_OK) {
                          goto done;
                      }
                      maxDepth = envPtr->maxStackDepth;
                      tokenPtr = endPtr;
                      break;
                  default:
                      panic("CompileSubExpr: unexpected operator %d requiring special treatment\n",
                          opIndex);
              } /* end switch on operator requiring special treatment */
              infoPtr->hasOperators = 1;
              infoPtr->exprIsJustVarRef = 0;
              infoPtr->exprIsComparison = 0;
              break;
          default:
              panic("CompileSubExpr: unexpected token type %d\n",
                      tokenPtr->type);
      }
      /*
       * Verify that the subexpression token had the required number of
       * subtokens: that we've advanced tokenPtr just beyond the
       * subexpression's last token. For example, a "*" subexpression must
       * contain the tokens for exactly two operands.
       */
      if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) {
          LogSyntaxError(infoPtr);
          code = TCL_ERROR;
      }
      done:
      envPtr->maxStackDepth = maxDepth;
      return code;
  }
  /*
   *----------------------------------------------------------------------
   *
   * CompileLandOrLorExpr --
   *
   *      This procedure compiles a Tcl logical and ("&&") or logical or
   *      ("||") subexpression.
   *
   * Results:
   *      The return value is TCL_OK on a successful compilation and TCL_ERROR
   *      on failure. If TCL_OK is returned, a pointer to the token just after
   *      the last one in the subexpression is stored at the address in
   *      endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
   *      contains an error message.
   *
   *      envPtr->maxStackDepth is updated with the maximum number of stack
   *      elements needed to execute the expression.
   *
   * Side effects:
   *      Adds instructions to envPtr to evaluate the expression at runtime.
   *
   *----------------------------------------------------------------------
   */
  static int
  CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr)
      Tcl_Token *exprTokenPtr;     /* Points to TCL_TOKEN_SUB_EXPR token
                                    * containing the "&&" or "||" operator. */
      int opIndex;                 /* A code describing the expression
                                    * operator: either OP_LAND or OP_LOR. */
      ExprInfo *infoPtr;           /* Describes the compilation state for the
                                    * expression being compiled. */
      CompileEnv *envPtr;          /* Holds resulting instructions. */
      Tcl_Token **endPtrPtr;       /* If successful, a pointer to the token
                                    * just after the last token in the
                                    * subexpression is stored here. */
  {
      JumpFixup shortCircuitFixup; /* Used to fix up the short circuit jump
                                    * after the first subexpression. */
      JumpFixup lhsTrueFixup, lhsEndFixup;
                                   /* Used to fix up jumps used to convert the
                                    * first operand to 0 or 1. */
      Tcl_Token *tokenPtr;
      int dist, maxDepth, code;
      /*
       * Emit code for the first operand.
       */
      maxDepth = 0;
      tokenPtr = exprTokenPtr+2;
      code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
      if (code != TCL_OK) {
          goto done;
      }
      maxDepth = envPtr->maxStackDepth;
      tokenPtr += (tokenPtr->numComponents + 1);
      /*
       * Convert the first operand to the result that Tcl requires:
       * "0" or "1". Eventually we'll use a new instruction for this.
       */
      TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup);
      TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), envPtr);
      TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup);
      dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset;
      if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) {
          badDist:
          panic("CompileLandOrLorExpr: bad jump distance %d\n", dist);
      }
      TclEmitPush(TclRegisterLiteral(envPtr, "1", 1, /*onHeap*/ 0), envPtr);
      dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset;
      if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) {
          goto badDist;
      }
      /*
       * Emit the "short circuit" jump around the rest of the expression.
       * Duplicate the "0" or "1" on top of the stack first to keep the
       * jump from consuming it.
       */
      TclEmitOpcode(INST_DUP, envPtr);
      TclEmitForwardJump(envPtr,
              ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP),
              &shortCircuitFixup);
      /*
       * Emit code for the second operand.
       */
      code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
      if (code != TCL_OK) {
          goto done;
      }
      maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
      tokenPtr += (tokenPtr->numComponents + 1);
      /*
       * Emit a "logical and" or "logical or" instruction. This does not try
       * to "short- circuit" the evaluation of both operands, but instead
       * ensures that we either have a "1" or a "0" result.
       */
      TclEmitOpcode(((opIndex==OP_LAND)? INST_LAND : INST_LOR), envPtr);
      /*
       * Now that we know the target of the forward jump, update it with the
       * correct distance.
       */
      dist = (envPtr->codeNext - envPtr->codeStart)
              - shortCircuitFixup.codeOffset;
      TclFixupForwardJump(envPtr, &shortCircuitFixup, dist, 127);
      *endPtrPtr = tokenPtr;
      done:
      envPtr->maxStackDepth = maxDepth;
      return code;
  }
  /*
   *----------------------------------------------------------------------
   *
   * CompileCondExpr --
   *
   *      This procedure compiles a Tcl conditional expression:
   *      condExpr ::= lorExpr ['?' condExpr ':' condExpr]
   *
   * Results:
   *      The return value is TCL_OK on a successful compilation and TCL_ERROR
   *      on failure. If TCL_OK is returned, a pointer to the token just after
   *      the last one in the subexpression is stored at the address in
   *      endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
   *      contains an error message.
   *
   *      envPtr->maxStackDepth is updated with the maximum number of stack
   *      elements needed to execute the expression.
   *
   * Side effects:
   *      Adds instructions to envPtr to evaluate the expression at runtime.
   *
   *----------------------------------------------------------------------
   */
  static int
  CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr)
      Tcl_Token *exprTokenPtr;    /* Points to TCL_TOKEN_SUB_EXPR token
                                   * containing the "?" operator. */
      ExprInfo *infoPtr;          /* Describes the compilation state for the
                                   * expression being compiled. */
      CompileEnv *envPtr;         /* Holds resulting instructions. */
      Tcl_Token **endPtrPtr;      /* If successful, a pointer to the token
                                   * just after the last token in the
                                   * subexpression is stored here. */
  {
      JumpFixup jumpAroundThenFixup, jumpAroundElseFixup;
                                  /* Used to update or replace one-byte jumps
                                   * around the then and else expressions when
                                   * their target PCs are determined. */
      Tcl_Token *tokenPtr;
      int elseCodeOffset, dist, maxDepth, code;
      /*
       * Emit code for the test.
       */
      maxDepth = 0;
      tokenPtr = exprTokenPtr+2;
      code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
      if (code != TCL_OK) {
          goto done;
      }
      maxDepth = envPtr->maxStackDepth;
      tokenPtr += (tokenPtr->numComponents + 1);
      /*
       * Emit the jump to the "else" expression if the test was false.
       */
      TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup);
      /*
       * Compile the "then" expression. Note that if a subexpression is only
       * a primary, we need to try to convert it to numeric. We do this to
       * support Tcl's policy of interpreting operands if at all possible as
       * first integers, else floating-point numbers.
       */
      infoPtr->hasOperators = 0;
      code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
      if (code != TCL_OK) {
          goto done;
      }
      maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
      tokenPtr += (tokenPtr->numComponents + 1);
      if (!infoPtr->hasOperators) {
          TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
      }
      /*
       * Emit an unconditional jump around the "else" condExpr.
       */
      TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
              &jumpAroundElseFixup);
      /*
       * Compile the "else" expression.
       */
      elseCodeOffset = (envPtr->codeNext - envPtr->codeStart);
      infoPtr->hasOperators = 0;
      code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
      if (code != TCL_OK) {
          goto done;
      }
      maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
      tokenPtr += (tokenPtr->numComponents + 1);
      if (!infoPtr->hasOperators) {
          TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
      }
      /*
       * Fix up the second jump around the "else" expression.
       */
      dist = (envPtr->codeNext - envPtr->codeStart)
              - jumpAroundElseFixup.codeOffset;
      if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) {
          /*
           * Update the else expression's starting code offset since it
           * moved down 3 bytes too.
           */
          elseCodeOffset += 3;
      }
      /*
       * Fix up the first jump to the "else" expression if the test was false.
       */
      dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset);
      TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127);
      *endPtrPtr = tokenPtr;
      done:
      envPtr->maxStackDepth = maxDepth;
      return code;
  }
  /*
   *----------------------------------------------------------------------
   *
   * CompileMathFuncCall --
   *
   *      This procedure compiles a call on a math function in an expression:
   *      mathFuncCall ::= funcName '(' [condExpr {',' condExpr}] ')'
   *
   * Results:
   *      The return value is TCL_OK on a successful compilation and TCL_ERROR
   *      on failure. If TCL_OK is returned, a pointer to the token just after
   *      the last one in the subexpression is stored at the address in
   *      endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
   *      contains an error message.
   *
   *      envPtr->maxStackDepth is updated with the maximum number of stack
   *      elements needed to execute the function.
   *
   * Side effects:
   *      Adds instructions to envPtr to evaluate the math function at
   *      runtime.
   *
   *----------------------------------------------------------------------
   */
  static int
  CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr)
      Tcl_Token *exprTokenPtr;    /* Points to TCL_TOKEN_SUB_EXPR token
                                   * containing the math function call. */
      char *funcName;             /* Name of the math function. */
      ExprInfo *infoPtr;          /* Describes the compilation state for the
                                   * expression being compiled. */
      CompileEnv *envPtr;         /* Holds resulting instructions. */
      Tcl_Token **endPtrPtr;      /* If successful, a pointer to the token
                                   * just after the last token in the
                                   * subexpression is stored here. */
  {
      Tcl_Interp *interp = infoPtr->interp;
      Interp *iPtr = (Interp *) interp;
      MathFunc *mathFuncPtr;
      Tcl_HashEntry *hPtr;
      Tcl_Token *tokenPtr, *afterSubexprPtr;
      int maxDepth, code, i;
      /*
       * Look up the MathFunc record for the function.
       */
      code = TCL_OK;
      maxDepth = 0;
      hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
      if (hPtr == NULL) {
          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                  "unknown math function \"", funcName, "\"", (char *) NULL);
          code = TCL_ERROR;
          goto done;
      }
      mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
      /*
       * If not a builtin function, push an object with the function's name.
       */
      if (mathFuncPtr->builtinFuncIndex < 0) {
          TclEmitPush(TclRegisterLiteral(envPtr, funcName, -1, /*onHeap*/ 0),
                  envPtr);
          maxDepth = 1;
      }
      /*
       * Compile any arguments for the function.
       */
      tokenPtr = exprTokenPtr+2;
      afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1);
      if (mathFuncPtr->numArgs > 0) {
          for (i = 0;  i < mathFuncPtr->numArgs;  i++) {
              if (tokenPtr == afterSubexprPtr) {
                  Tcl_ResetResult(interp);
                  Tcl_AppendToObj(Tcl_GetObjResult(interp),
                          "too few arguments for math function", -1);
                  code = TCL_ERROR;
                  goto done;
              }
              infoPtr->exprIsComparison = 0;
              code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
              if (code != TCL_OK) {
                  goto done;
              }
              tokenPtr += (tokenPtr->numComponents + 1);
              maxDepth++;
          }
          if (tokenPtr != afterSubexprPtr) {
              Tcl_ResetResult(interp);
              Tcl_AppendToObj(Tcl_GetObjResult(interp),
                      "too many arguments for math function", -1);
              code = TCL_ERROR;
              goto done;
          }
      } else if (tokenPtr != afterSubexprPtr) {
          Tcl_ResetResult(interp);
          Tcl_AppendToObj(Tcl_GetObjResult(interp),
                  "too many arguments for math function", -1);
          code = TCL_ERROR;
          goto done;
      }
      /*
       * Compile the call on the math function. Note that the "objc" argument
       * count for non-builtin functions is incremented by 1 to include the
       * function name itself.
       */
      if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */
          TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1,
                  mathFuncPtr->builtinFuncIndex, envPtr);
      } else {
          TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr);
      }
      *endPtrPtr = afterSubexprPtr;
      done:
      envPtr->maxStackDepth = maxDepth;
      return code;
  }
  /*
   *----------------------------------------------------------------------
   *
   * LogSyntaxError --
   *
   *      This procedure is invoked after an error occurs when compiling an
   *      expression. It sets the interpreter result to an error message
   *      describing the error.
   *
   * Results:
   *      None.
   *
   * Side effects:
   *      Sets the interpreter result to an error message describing the
   *      expression that was being compiled when the error occurred.
   *
   *----------------------------------------------------------------------
   */
  static void
  LogSyntaxError(infoPtr)
      ExprInfo *infoPtr;          /* Describes the compilation state for the
                                   * expression being compiled. */
  {
      int numBytes = (infoPtr->lastChar - infoPtr->expr);
      char buffer[100];
      sprintf(buffer, "syntax error in expression \"%.*s\"",
              ((numBytes > 60)? 60 : numBytes), infoPtr->expr);
      Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
              buffer, (char *) NULL);
  }
  /* End of tclcompexpr.c */

 Legend:



Removed from v.67
 


changed lines


 
Added in v.71
 Legend:



Removed from v.67
 


changed lines


 
Added in v.71
-Removed from v.67
+Added in v.71

dashley@gmail.com	ViewVC Help
Powered by ViewVC 1.1.25