tclutil.c

CMX990 demonstration board (DE9901)

  iPtr->freeProc = freeProc;
  if (string == NULL) {
    iPtr->resultSpace[0] = 0;
    iPtr->result = iPtr->resultSpace;
    iPtr->freeProc = 0;
  } else if (freeProc == TCL_VOLATILE) {
    length = strlen(string);
    if (length > TCL_RESULT_SIZE) {
      iPtr->result = (char *) ckalloc((unsigned) length+1);
      iPtr->freeProc = (Tcl_FreeProc *) free;
    } else {
      iPtr->result = iPtr->resultSpace;
      iPtr->freeProc = 0;
    }
    strcpy(iPtr->result, string);
  } else {
    iPtr->result = string;
  }

  /*
   * If the old result was dynamically-allocated, free it up.  Do it
   * here, rather than at the beginning, in case the new result value
   * was part of the old result value.
   */

  if (oldFreeProc != 0) {
    if (oldFreeProc == (Tcl_FreeProc *) free) {
      ckfree(oldResult);
    } else {
      (*oldFreeProc)(oldResult);
    }
  }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendResult --
 *
 *	Append a variable number of strings onto the result already
 *	present for an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The result in the interpreter given by the first argument
 *	is extended by the strings given by the second and following
 *	arguments (up to a terminating NULL argument).
 *
 *----------------------------------------------------------------------
 */
void Tcl_AppendResult(Tcl_Interp *interp, ...)
  /* Interpreter whose result is to be
   * extended. */
  /* One or more strings to add to the
   * result, terminated with NULL. */
{
  va_list argList;
  register Interp *iPtr;
  char *string;
  int newSpace;

  /*
   * First, scan through all the arguments to see how much space is
   * needed.
   */

  va_start(argList, interp);
  iPtr = (Interp*)interp;
  newSpace = 0;
  while (1) {
    string = va_arg(argList, char *);
    if (string == NULL) {
      break;
    }
    newSpace += strlen(string);
  }
  va_end(argList);

  /*
   * If the append buffer isn't already setup and large enough
   * to hold the new data, set it up.
   */

  if ((iPtr->result != iPtr->appendResult)
      || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
    SetupAppendBuffer(iPtr, newSpace);
  }

  /*
   * Final step:  go through all the argument strings again, copying
   * them into the buffer.
   */

  va_start(argList, interp);
  //(void) va_arg(argList, Tcl_Interp *);
  while (1) {
    string = va_arg(argList, char *);
    if (string == NULL) {
      break;
    }
    strcpy(iPtr->appendResult + iPtr->appendUsed, string);
    iPtr->appendUsed += strlen(string);
  }
  va_end(argList);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendElement --
 *
 *	Convert a string to a valid Tcl list element and append it
 *	to the current result (which is ostensibly a list).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The result in the interpreter given by the first argument
 *	is extended with a list element converted from string.  If
 *	the original result wasn't empty, then a blank is added before
 *	the converted list element.
 *
 *----------------------------------------------------------------------
 */
void Tcl_AppendElement(Tcl_Interp *interp, char *string, int noSep)
  //  Tcl_Interp *interp;		/* Interpreter whose result is to be
  //				 * extended. */
  //char *string;		/* String to convert to list element and
  //                         * add to result. */
  //int noSep;			/* If non-zero, then don't output a
  //				 * space character before this element,
  //				 * even if the element isn't the first
  //				 * thing in the output buffer. */
{
  register Interp *iPtr = (Interp *) interp;
  int size, flags;
  char *dst;

  /*
   * See how much space is needed, and grow the append buffer if
   * needed to accommodate the list element.
   */

  size = Tcl_ScanElement(string, &flags) + 1;
  if ((iPtr->result != iPtr->appendResult)
      || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
    SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
  }

  /*
   * Convert the string into a list element and copy it to the
   * buffer that's forming.
   */

  dst = iPtr->appendResult + iPtr->appendUsed;
  if (!noSep && (iPtr->appendUsed != 0)) {
    iPtr->appendUsed++;
    *dst = ' ';
    dst++;
  }
  iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * SetupAppendBuffer --
 *
 *	This procedure makes sure that there is an append buffer
 *	properly initialized for interp, and that it has at least
 *	enough room to accommodate newSpace new bytes of information.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
static void SetupAppendBuffer(Interp *iPtr, int newSpace)
  //  register Interp *iPtr;	/* Interpreter whose result is being set up. */
  //int newSpace;		/* Make sure that at least this many bytes
  //                         * of new information may be added. */
{
  int totalSpace;

  /*
   * Make the append buffer larger, if that's necessary, then
   * copy the current result into the append buffer and make the
   * append buffer the official Tcl result.
   */

  if (iPtr->result != iPtr->appendResult) {
    /*
     * If an oversized buffer was used recently, then free it up
     * so we go back to a smaller buffer.  This avoids tying up
     * memory forever after a large operation.
     */

    if (iPtr->appendAvl > 500) {
      ckfree(iPtr->appendResult);
      iPtr->appendResult = NULL;
      iPtr->appendAvl = 0;
    }
    iPtr->appendUsed = strlen(iPtr->result);
  }
  totalSpace = newSpace + iPtr->appendUsed;
  if (totalSpace >= iPtr->appendAvl) {
    char *new;

    if (totalSpace < 100) {
      totalSpace = 200;
    } else {
      totalSpace *= 2;
    }
    new = (char *) ckalloc((unsigned) totalSpace);
    strcpy(new, iPtr->result);
    if (iPtr->appendResult != NULL) {
      ckfree(iPtr->appendResult);
    }
    iPtr->appendResult = new;
    iPtr->appendAvl = totalSpace;
  } else if (iPtr->result != iPtr->appendResult) {
    strcpy(iPtr->appendResult, iPtr->result);
  }
  Tcl_FreeResult(iPtr);
  iPtr->result = iPtr->appendResult;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ResetResult --
 *
 *	This procedure restores the result area for an interpreter
 *	to its default initialized state, freeing up any memory that
 *	may have been allocated for the result and clearing any
 *	error information for the interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
void Tcl_ResetResult(Tcl_Interp *interp)
  //  Tcl_Interp *interp;		/* Interpreter for which to clear result. */
{
  register Interp *iPtr = (Interp *) interp;

  Tcl_FreeResult(iPtr);
  iPtr->result = iPtr->resultSpace;
  iPtr->resultSpace[0] = 0;
  iPtr->flags &=
    ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetErrorCode --
 *
 *	This procedure is called to record machine-readable information
 *	about an error that is about to be returned.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The errorCode global variable is modified to hold all of the
 *	arguments to this procedure, in a list form with each argument
 *	becoming one element of the list.  A flag is set internally
 *	to remember that errorCode has been set, so the variable doesn't
 *	get set automatically when the error is returned.
 *
 *----------------------------------------------------------------------
 */
void Tcl_SetErrorCode(Tcl_Interp *interp, ...)
  /* Interpreter whose errorCode variable is
   * to be set. */
  /* One or more elements to add to errorCode,
   * terminated with NULL. */
{
  va_list argList;
  char *string;
  int flags;
  Interp *iPtr;

  /*
   * Scan through the arguments one at a time, appending them to
   * $errorCode as list elements.
   */

  va_start(argList, interp);
  iPtr = (Interp*)interp;
  flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
  while (1) {
    string = va_arg(argList, char *);
    if (string == NULL) {
      break;
    }
    (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
                       (char *) NULL, string, flags);
    flags |= TCL_APPEND_VALUE;
  }
  va_end(argList);
  iPtr->flags |= ERROR_CODE_SET;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetListIndex --
 *
 *	Parse a list index, which may be either an integer or the
 *	value "end".
 *
 * Results:
 *	The return value is either TCL_OK or TCL_ERROR.  If it is
 *	TCL_OK, then the index corresponding to string is left in
 *	*indexPtr.  If the return value is TCL_ERROR, then string
 *	was bogus;  an error message is returned in interp->result.
 *	If a negative index is specified, it is rounded up to 0.
 *	The index value may be larger than the size of the list
 *	(this happens when "end" is specified).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
int TclGetListIndex(Tcl_Interp *interp, char *string, int *indexPtr)
  //  Tcl_Interp *interp;      		/* Interpreter for error reporting. */
  //char *string;			/* String containing list index. */
  //int *indexPtr;			/* Where to store index. */
{
  if (isdigit(*string) || (*string == '-')) {
    if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) {
      return TCL_ERROR;
    }
    if (*indexPtr < 0) {
      *indexPtr = 0;
    }
  } else if (strncmp(string, "end", strlen(string)) == 0) {
    *indexPtr = 1<<30;
  } else {
    Tcl_AppendResult(interp, "bad index \"", string,
                     "\": must be integer or \"end\"", (char *) NULL);
    return TCL_ERROR;
  }
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileRegexp --
 *
 *	Compile a regular expression into a form suitable for fast
 *	matching.  This procedure retains a small cache of pre-compiled
 *	regular expressions in the interpreter, in order to avoid
 *	compilation costs as much as possible.
 *
 * Results:
 *	The return value is a pointer to the compiled form of string,
 *	suitable for passing to regexec.  If an error occurred while
 *	compiling the pattern, then NULL is returned and an error
 *	message is left in interp->result.
 *
 * Side effects:
 *	The cache of compiled regexp's in interp will be modified to
 *	hold information for string, if such information isn't already
 *	present in the cache.
 *
 *----------------------------------------------------------------------
 */
regexp *TclCompileRegexp(Tcl_Interp *interp, char *string)
  //  Tcl_Interp *interp;      		/* For use in error reporting. */
  //char *string;			/* String for which to produce
  //                                     * compiled regular expression. */
{
  register Interp *iPtr = (Interp *) interp;
  int i, length;
  regexp *result;

  length = strlen(string);
  for (i = 0; i < NUM_REGEXPS; i++) {
    if ((length == iPtr->patLengths[i])
        && (strcmp(string, iPtr->patterns[i]) == 0)) {
      /*
       * Move the matched pattern to the first slot in the
       * cache and shift the other patterns down one position.
       */

      if (i != 0) {
        int j;
        char *cachedString;

        cachedString = iPtr->patterns[i];
        result = iPtr->regexps[i];
        for (j = i-1; j >= 0; j--) {
          iPtr->patterns[j+1] = iPtr->patterns[j];
          iPtr->patLengths[j+1] = iPtr->patLengths[j];
          iPtr->regexps[j+1] = iPtr->regexps[j];
        }
        iPtr->patterns[0] = cachedString;
        iPtr->patLengths[0] = length;
        iPtr->regexps[0] = result;
      }
      return iPtr->regexps[0];
    }
  }

  /*
   * No match in the cache.  Compile the string and add it to the
   * cache.
   */

  tclRegexpError = NULL;
  result = regcomp(string);
  if (tclRegexpError != NULL) {
    Tcl_AppendResult(interp,
                     "couldn't compile regular expression pattern: ",
                     tclRegexpError, (char *) NULL);
    return NULL;
  }
  if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
    ckfree(iPtr->patterns[NUM_REGEXPS-1]);
    ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
  }
  for (i = NUM_REGEXPS - 2; i >= 0; i--) {
    iPtr->patterns[i+1] = iPtr->patterns[i];
    iPtr->patLengths[i+1] = iPtr->patLengths[i];
    iPtr->regexps[i+1] = iPtr->regexps[i];
  }
  iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
  strcpy(iPtr->patterns[0], string);
  iPtr->patLengths[0] = length;
  iPtr->regexps[0] = result;
  return result;
}

/*
 *----------------------------------------------------------------------
 *
 * regerror --
 *
 *	This procedure is invoked by the Henry Spencer's regexp code
 *	when an error occurs.  It saves the error message so it can
 *	be seen by the code that called Spencer's code.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The value of "string" is saved in "tclRegexpError".
 *
 *----------------------------------------------------------------------
 */
void regerror(char *string)
  //  char *string;			/* Error message. */
{
  tclRegexpError = string;
}