tclparse.c

CMX990 demonstration board (DE9901)

 *
 * Results:
 *	The buffer space in *pvPtr is reallocated to something
 *	larger, and if pvPtr->clientData is non-zero the old
 *	buffer is freed.  Information is copied from the old
 *	buffer to the new one.
 *
 * Side effects:
 *	None.
 *
 *--------------------------------------------------------------
 */
void TclExpandParseValue(ParseValue *pvPtr, int needed)
  //  register ParseValue *pvPtr;	/* Information about buffer that
  //					 * must be expanded.  If the clientData
  //					 * in the structure is non-zero, it
  //					 * means that the current buffer is
  //					 * dynamically allocated. */
  //int needed;				/* Minimum amount of additional space
  //					 * to allocate. */
{
  int newSpace;
  char *new;

  /*
   * Either double the size of the buffer or add enough new space
   * to meet the demand, whichever produces a larger new buffer.
   */

  newSpace = (pvPtr->end - pvPtr->buffer) + 1;
  if (newSpace < needed) {
    newSpace += needed;
  } else {
    newSpace += newSpace;
  }
  new = (char *) ckalloc((unsigned) newSpace);

  /*
   * Copy from old buffer to new, free old buffer if needed, and
   * mark new buffer as malloc-ed.
   */

  memcpy((VOID *) new, (VOID *) pvPtr->buffer, pvPtr->next - pvPtr->buffer);
  pvPtr->next = new + (pvPtr->next - pvPtr->buffer);
  if (pvPtr->clientData != 0) {
    ckfree(pvPtr->buffer);
  }
  pvPtr->buffer = new;
  pvPtr->end = new + newSpace - 1;
  pvPtr->clientData = (ClientData) 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWordEnd --
 *
 *	Given a pointer into a Tcl command, find the end of the next
 *	word of the command.
 *
 * Results:
 *	The return value is a pointer to the last character that's part
 *	of the word pointed to by "start".  If the word doesn't end
 *	properly within the string then the return value is the address
 *	of the null character at the end of the string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
char *TclWordEnd(char *start, int nested)
  //  char *start;		/* Beginning of a word of a Tcl command. */
  //int nested;			/* Zero means this is a top-level command.
  //				 * One means this is a nested command (close
  //				 * brace is a word terminator). */
{
  register char *p;
  int count;

  p = start;
  while (isspace(*p)) {
    p++;
  }

  /*
   * Handle words beginning with a double-quote or a brace.
   */

  if (*p == '"') {
    p = QuoteEnd(p+1, '"');
    if (*p == 0) {
      return p;
    }
    p++;
  } else if (*p == '{') {
    int braces = 1;
    while (braces != 0) {
      p++;
      while (*p == '\\') {
        (void) Tcl_Backslash(p, &count);
        p += count;
      }
      if (*p == '}') {
        braces--;
      } else if (*p == '{') {
        braces++;
      } else if (*p == 0) {
        return p;
      }
    }
    p++;
  }

  /*
   * Handle words that don't start with a brace or double-quote.
   * This code is also invoked if the word starts with a brace or
   * double-quote and there is garbage after the closing brace or
   * quote.  This is an error as far as Tcl_Eval is concerned, but
   * for here the garbage is treated as part of the word.
   */

  while (1) {
    if (*p == '[') {
      for (p++; *p != ']'; p++) {
        p = TclWordEnd(p, 1);
        if (*p == 0) {
          return p;
        }
      }
      p++;
    } else if (*p == '\\') {
      (void) Tcl_Backslash(p, &count);
      p += count;
      if ((*p == 0) && (count == 2) && (p[-1] == '\n')) {
        return p;
      }
    } else if (*p == '$') {
      p = VarNameEnd(p);
      if (*p == 0) {
        return p;
      }
      p++;
    } else if (*p == ';') {
      /*
       * Include the semi-colon in the word that is returned.
       */

      return p;
    } else if (isspace(*p)) {
      return p-1;
    } else if ((*p == ']') && nested) {
      return p-1;
    } else if (*p == 0) {
      if (nested) {
        /*
         * Nested commands can't end because of the end of the
         * string.
         */
        return p;
      }
      return p-1;
    } else {
      p++;
    }
  }
}

/*
 *----------------------------------------------------------------------
 *
 * QuoteEnd --
 *
 *	Given a pointer to a string that obeys the parsing conventions
 *	for quoted things in Tcl, find the end of that quoted thing.
 *	The actual thing may be a quoted argument or a parenthesized
 *	index name.
 *
 * Results:
 *	The return value is a pointer to the last character that is
 *	part of the quoted string (i.e the character that's equal to
 *	term).  If the quoted string doesn't terminate properly then
 *	the return value is a pointer to the null character at the
 *	end of the string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
static char *QuoteEnd(char *string, int term)
  //  char *string;		/* Pointer to character just after opening
  //                             * "quote". */
  //int term;			/* This character will terminate the
  //				 * quoted string (e.g. '"' or ')'). */
{
  register char *p = string;
  int count;

  while (*p != term) {
    if (*p == '\\') {
      (void) Tcl_Backslash(p, &count);
      p += count;
    } else if (*p == '[') {
      for (p++; *p != ']'; p++) {
        p = TclWordEnd(p, 1);
        if (*p == 0) {
          return p;
        }
      }
      p++;
    } else if (*p == '$') {
      p = VarNameEnd(p);
      if (*p == 0) {
        return p;
      }
      p++;
    } else if (*p == 0) {
      return p;
    } else {
      p++;
    }
  }
  return p-1;
}

/*
 *----------------------------------------------------------------------
 *
 * VarNameEnd --
 *
 *	Given a pointer to a variable reference using $-notation, find
 *	the end of the variable name spec.
 *
 * Results:
 *	The return value is a pointer to the last character that
 *	is part of the variable name.  If the variable name doesn't
 *	terminate properly then the return value is a pointer to the
 *	null character at the end of the string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
static char *VarNameEnd(char *string)
  //  char *string;		/* Pointer to dollar-sign character. */
{
  register char *p = string+1;

  if (*p == '{') {
    for (p++; (*p != '}') && (*p != 0); p++) {
      /* Empty loop body. */
    }
    return p;
  }
  while (isalnum(*p) || (*p == '_')) {
    p++;
  }
  if ((*p == '(') && (p != string+1)) {
    return QuoteEnd(p+1, ')');
  }
  return p-1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseVar --
 *
 *	Given a string starting with a $ sign, parse off a variable
 *	name and return its value.
 *
 * Results:
 *	The return value is the contents of the variable given by
 *	the leading characters of string.  If termPtr isn't NULL,
 *	*termPtr gets filled in with the address of the character
 *	just after the last one in the variable specifier.  If the
 *	variable doesn't exist, then the return value is NULL and
 *	an error message will be left in interp->result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
char *Tcl_ParseVar(Tcl_Interp *interp, char *string, char **termPtr)
  //  Tcl_Interp *interp;		/* Context for looking up variable. */
  //register char *string;		/* String containing variable name.
  //                                     * First character must be "$". */
  //char **termPtr;			/* If non-NULL, points to word to fill
  //                                     * in with character just after last
  //                                     * one in the variable specifier. */
{
  char *name1, *name1End, c, *result;
  register char *name2;
#define NUM_CHARS 200
  char copyStorage[NUM_CHARS];
  ParseValue pv;

  /*
   * There are three cases:
   * 1. The $ sign is followed by an open curly brace.  Then the variable
   *    name is everything up to the next close curly brace, and the
   *    variable is a scalar variable.
   * 2. The $ sign is not followed by an open curly brace.  Then the
   *    variable name is everything up to the next character that isn't
   *    a letter, digit, or underscore.  If the following character is an
   *    open parenthesis, then the information between parentheses is
   *    the array element name, which can include any of the substitutions
   *    permissible between quotes.
   * 3. The $ sign is followed by something that isn't a letter, digit,
   *    or underscore:  in this case, there is no variable name, and "$"
   *    is returned.
   */

  name2 = NULL;
  string++;
  if (*string == '{') {
    string++;
    name1 = string;
    while (*string != '}') {
      if (*string == 0) {
        Tcl_SetResult(interp, "missing close-brace for variable name",
                      TCL_STATIC);
        if (termPtr != 0) {
          *termPtr = string;
        }
        return NULL;
      }
      string++;
    }
    name1End = string;
    string++;
  } else {
    name1 = string;
    while (isalnum(*string) || (*string == '_')) {
      string++;
    }
    if (string == name1) {
      if (termPtr != 0) {
        *termPtr = string;
      }
      return "$";
    }
    name1End = string;
    if (*string == '(') {
      char *end;

      /*
       * Perform substitutions on the array element name, just as
       * is done for quotes.
       */

      pv.buffer = pv.next = copyStorage;
      pv.end = copyStorage + NUM_CHARS - 1;
      pv.expandProc = TclExpandParseValue;
      pv.clientData = (ClientData) NULL;
      if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv)
          != TCL_OK) {
        char msg[100];
        sprintf(msg, "\n    (parsing index for array \"%.*s\")",
                (int)(string-name1), name1);
        Tcl_AddErrorInfo(interp, msg);
        result = NULL;
        name2 = pv.buffer;
        if (termPtr != 0) {
          *termPtr = end;
        }
        goto done;
      }
      string = end;
      name2 = pv.buffer;
    }
  }
  if (termPtr != 0) {
    *termPtr = string;
  }

  if (((Interp *) interp)->noEval) {
    return "";
  }
  c = *name1End;
  *name1End = 0;
  result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG);
  *name1End = c;

 done:
  if ((name2 != NULL) && (pv.buffer != copyStorage)) {
    ckfree(pv.buffer);
  }
  return result;
}