tclbasic.c

CMX990 demonstration board (DE9901)

  while (*src != termChar) {
    iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET);
    
    /*
     * Skim off leading white space and semi-colons, and skip
     * comments.
     */
    
    while (1) {
      register char c = *src;
      
      if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) {
        break;
      }
      src += 1;
    }
    if (*src == '#') {
      for (src++; *src != 0; src++) {
        if ((*src == '\n') && (src[-1] != '\\')) {
          src++;
          break;
        }
      }
      continue;
    }
    cmdStart = src;
    
    /*
     * Parse the words of the command, generating the argc and
     * argv for the command procedure.  May have to call
     * TclParseWords several times, expanding the argv array
     * between calls.
     */
    
    pv.next = oldBuffer = pv.buffer;
    argc = 0;
    while (1) {
      int newArgs, maxArgs;
      char **newArgv;
      int i;
      
      /*
       * Note:  the "- 2" below guarantees that we won't use the
       * last two argv slots here.  One is for a NULL pointer to
       * mark the end of the list, and the other is to leave room
       * for inserting the command name "unknown" as the first
       * argument (see below).
       */
      
      maxArgs = argSize - argc - 2;
      result = TclParseWords((Tcl_Interp *) iPtr, src, flags,
                             maxArgs, termPtr, &newArgs, &argv[argc], &pv);
      src = *termPtr;
      if (result != TCL_OK) {
        ellipsis = "...";
        goto done;
      }
      
      /*
       * Careful!  Buffer space may have gotten reallocated while
       * parsing words.  If this happened, be sure to update all
       * of the older argv pointers to refer to the new space.
       */
      
      if (oldBuffer != pv.buffer) {
        int i;
        
        for (i = 0; i < argc; i++) {
          argv[i] = pv.buffer + (argv[i] - oldBuffer);
        }
        oldBuffer = pv.buffer;
      }
      argc += newArgs;
      if (newArgs < maxArgs) {
        argv[argc] = (char *) NULL;
        break;
      }
      
      /*
       * Args didn't all fit in the current array.  Make it bigger.
       */
      
      argSize *= 2;
      newArgv = (char **)
        ckalloc((unsigned) argSize * sizeof(char *));
      for (i = 0; i < argc; i++) {
        newArgv[i] = argv[i];
      }
      if (argv != argStorage) {
        ckfree((char *) argv);
      }
      argv = newArgv;
    }
    
    /*
     * If this is an empty command (or if we're just parsing
     * commands without evaluating them), then just skip to the
     * next command.
     */
    
    if ((argc == 0) || iPtr->noEval) {
      continue;
    }
    argv[argc] = NULL;
    
    /*
     * Save information for the history module, if needed.
     */
    
    if (flags & TCL_RECORD_BOUNDS) {
      iPtr->evalFirst = cmdStart;
      iPtr->evalLast = src-1;
    }
    
    /*
     * Find the procedure to execute this command.  If there isn't
     * one, then see if there is a command "unknown".  If so,
     * invoke it instead, passing it the words of the original
     * command as arguments.
     */
    
    hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]);
    if (hPtr == NULL) {
      int i;
      
      hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown");
      if (hPtr == NULL) {
        Tcl_ResetResult(interp);
        Tcl_AppendResult(interp, "invalid command name: \"",
                         argv[0], "\"", (char *) NULL);
        result = TCL_ERROR;
        goto done;
      }
      for (i = argc; i >= 0; i--) {
        argv[i+1] = argv[i];
      }
      argv[0] = "unknown";
      argc++;
    }
    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
    
    /*
     * Call trace procedures, if any.
     */
    
    for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
         tracePtr = tracePtr->nextPtr) {
      char saved;
      
      if (tracePtr->level < iPtr->numLevels) {
        continue;
      }
      saved = *src;
      *src = 0;
      (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
                        cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv);
      *src = saved;
    }
    
    /*
     * At long last, invoke the command procedure.  Reset the
     * result to its default empty value first (it could have
     * gotten changed by earlier commands in the same command
     * string).
     */
    
    iPtr->cmdCount++;
    Tcl_FreeResult(iPtr);
    iPtr->result = iPtr->resultSpace;
    iPtr->resultSpace[0] = 0;
    result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv);
    if (result != TCL_OK) {
      break;
    }
  }
  
  /*
   * Free up any extra resources that were allocated.
   */
  
 done:
  if (pv.buffer != copyStorage) {
    ckfree((char *) pv.buffer);
  }
  if (argv != argStorage) {
    ckfree((char *) argv);
  }
  iPtr->numLevels--;
  if (iPtr->numLevels == 0) {
    if (result == TCL_RETURN) {
      result = TCL_OK;
    }
    if ((result != TCL_OK) && (result != TCL_ERROR)) {
      Tcl_ResetResult(interp);
      if (result == TCL_BREAK) {
        iPtr->result = "invoked \"break\" outside of a loop";
      } else if (result == TCL_CONTINUE) {
        iPtr->result = "invoked \"continue\" outside of a loop";
      } else {
        iPtr->result = iPtr->resultSpace;
        sprintf(iPtr->resultSpace, "command returned bad code: %d",
                result);
      }
      result = TCL_ERROR;
    }
    if (iPtr->flags & DELETED) {
      Tcl_DeleteInterp(interp);
    }
  }
  
  /*
   * If an error occurred, record information about what was being
   * executed when the error occurred.
   */
  
  if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
    int numChars;
    register char *p;
    
    /*
     * Compute the line number where the error occurred.
     */
    
    iPtr->errorLine = 1;
    for (p = cmd; p != cmdStart; p++) {
      if (*p == '\n') {
        iPtr->errorLine++;
      }
    }
    for ( ; isspace(*p) || (*p == ';'); p++) {
      if (*p == '\n') {
        iPtr->errorLine++;
      }
    }
    
    /*
     * Figure out how much of the command to print in the error
     * message (up to a certain number of characters, or up to
     * the first new-line).
     */
    
    numChars = src - cmdStart;
    if (numChars > (NUM_CHARS-50)) {
      numChars = NUM_CHARS-50;
      ellipsis = " ...";
    }
    
    if (!(iPtr->flags & ERR_IN_PROGRESS)) {
      sprintf(copyStorage, "\n    while executing\n\"%.*s%s\"",
              numChars, cmdStart, ellipsis);
    } else {
      sprintf(copyStorage, "\n    invoked from within\n\"%.*s%s\"",
              numChars, cmdStart, ellipsis);
    }
    Tcl_AddErrorInfo(interp, copyStorage);
    iPtr->flags &= ~ERR_ALREADY_LOGGED;
  } else {
    iPtr->flags &= ~ERR_ALREADY_LOGGED;
  }
  return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateTrace --
 *
 *	Arrange for a procedure to be called to trace command execution.
 *
 * Results:
 *	The return value is a token for the trace, which may be passed
 *	to Tcl_DeleteTrace to eliminate the trace.
 *
 * Side effects:
 *	From now on, proc will be called just before a command procedure
 *	is called to execute a Tcl command.  Calls to proc will have the
 *	following form:
 *
 *	void
 *	proc(clientData, interp, level, command, cmdProc, cmdClientData,
 *		argc, argv)
 *	    ClientData clientData;
 *	    Tcl_Interp *interp;
 *	    int level;
 *	    char *command;
 *	    int (*cmdProc)();
 *	    ClientData cmdClientData;
 *	    int argc;
 *	    char **argv;
 *	{
 *	}
 *
 *	The clientData and interp arguments to proc will be the same
 *	as the corresponding arguments to this procedure.  Level gives
 *	the nesting level of command interpretation for this interpreter
 *	(0 corresponds to top level).  Command gives the ASCII text of
 *	the raw command, cmdProc and cmdClientData give the procedure that
 *	will be called to process the command and the ClientData value it
 *	will receive, and argc and argv give the arguments to the
 *	command, after any argument parsing and substitution.  Proc
 *	does not return a value.
 *
 *----------------------------------------------------------------------
 */

Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData)
  //    Tcl_Interp *interp;		/* Interpreter in which to create the trace. */
  //    int level;			/* Only call proc for commands at nesting level
  //				 * <= level (1 => top level). */
  //    Tcl_CmdTraceProc *proc;	/* Procedure to call before executing each
  //			 * command. */
  //    ClientData clientData;	/* Arbitrary one-word value to pass to proc. */
{
  register Trace *tracePtr;
  register Interp *iPtr = (Interp *) interp;
    
  tracePtr = (Trace *) ckalloc(sizeof(Trace));
  tracePtr->level = level;
  tracePtr->proc = proc;
  tracePtr->clientData = clientData;
  tracePtr->nextPtr = iPtr->tracePtr;
  iPtr->tracePtr = tracePtr;

  return (Tcl_Trace) tracePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteTrace --
 *
 *	Remove a trace.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	From now on there will be no more calls to the procedure given
 *	in trace.
 *
 *----------------------------------------------------------------------
 */

void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace)
  //  Tcl_Interp *interp;		/* Interpreter that contains trace. */
  //Tcl_Trace trace;		/* Token for trace (returned previously by
  //				 * Tcl_CreateTrace). */
{
  register Interp *iPtr = (Interp *) interp;
  register Trace *tracePtr = (Trace *) trace;
  register Trace *tracePtr2;

  if (iPtr->tracePtr == tracePtr) {
    iPtr->tracePtr = tracePtr->nextPtr;
    ckfree((char *) tracePtr);
  } else {
    for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
         tracePtr2 = tracePtr2->nextPtr) {
      if (tracePtr2->nextPtr == tracePtr) {
        tracePtr2->nextPtr = tracePtr->nextPtr;
        ckfree((char *) tracePtr);
        return;
      }
    }
  }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AddErrorInfo --
 *
 *	Add information to a message being accumulated that describes
 *	the current error.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The contents of message are added to the "errorInfo" variable.
 *	If Tcl_Eval has been called since the current value of errorInfo
 *	was set, errorInfo is cleared before adding the new message.
 *
 *----------------------------------------------------------------------
 */

void Tcl_AddErrorInfo(Tcl_Interp *interp, char *message)
  // Tcl_Interp *interp;		/* Interpreter to which error information
  //				 * pertains. */
  //char *message;		/* Message to record. */
{
  register Interp *iPtr = (Interp *) interp;

  /*
   * If an error is already being logged, then the new errorInfo
   * is the concatenation of the old info and the new message.
   * If this is the first piece of info for the error, then the
   * new errorInfo is the concatenation of the message in
   * interp->result and the new message.
   */

  if (!(iPtr->flags & ERR_IN_PROGRESS)) {
    Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
		TCL_GLOBAL_ONLY);
    iPtr->flags |= ERR_IN_PROGRESS;

    /*
     * If the errorCode variable wasn't set by the code that generated
     * the error, set it to "NONE".
     */

    if (!(iPtr->flags & ERROR_CODE_SET)) {
      (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
                         TCL_GLOBAL_ONLY);
    }
  }
  Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message,
              TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_VarEval --
 *
 *	Given a variable number of string arguments, concatenate them
 *	all together and execute the result as a Tcl command.
 *
 * Results:
 *	A standard Tcl return result.  An error message or other
 *	result may be left in interp->result.
 *
 * Side effects:
 *	Depends on what was done by the command.
 *
 *----------------------------------------------------------------------
 */
int Tcl_VarEval(Tcl_Interp *iPtr, ...)
  /* Interpreter in which to execute command. */
  /* One or more strings to concatenate,
   * terminated with a NULL string. */
{
  va_list argList;
#define FIXED_SIZE 200
  char fixedSpace[FIXED_SIZE+1];
  int spaceAvl, spaceUsed, length;
  char *string, *cmd;
  Tcl_Interp *interp;
  int result;

  /*
   * Copy the strings one after the other into a single larger
   * string.  Use stack-allocated space for small commands, but if
   * the commands gets too large than call ckalloc to create the
   * space.
   */

  va_start(argList, iPtr);
  interp = iPtr;
  spaceAvl = FIXED_SIZE;
  spaceUsed = 0;
  cmd = fixedSpace;
  while (1) {
    string = va_arg(argList, char *);
    if (string == NULL) {
      break;
    }
    length = strlen(string);
    if ((spaceUsed + length) > spaceAvl) {
      char *new;

      spaceAvl = spaceUsed + length;
      spaceAvl += spaceAvl/2;
      new = ckalloc((unsigned) spaceAvl);
      memcpy((VOID *) new, (VOID *) cmd, spaceUsed);
      if (cmd != fixedSpace) {
        ckfree(cmd);
      }
      cmd = new;
    }
    strcpy(cmd + spaceUsed, string);
    spaceUsed += length;
  }
  va_end(argList);
  cmd[spaceUsed] = '\0';

  result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
  if (cmd != fixedSpace) {
    ckfree(cmd);
  }
  return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GlobalEval --
 *
 *	Evaluate a command at global level in an interpreter.
 *
 * Results:
 *	A standard Tcl result is returned, and interp->result is
 *	modified accordingly.
 *
 * Side effects:
 *	The command string is executed in interp, and the execution
 *	is carried out in the variable context of global level (no
 *	procedures active), just as if an "uplevel #0" command were
 *	being executed.
 *
 *----------------------------------------------------------------------
 */

int Tcl_GlobalEval(Tcl_Interp *interp, char *command)
  // Tcl_Interp *interp;		/* Interpreter in which to evaluate command. */
  //char *command;		/* Command to evaluate. */
{
  register Interp *iPtr = (Interp *) interp;
  int result;
  CallFrame *savedVarFramePtr;

  savedVarFramePtr = iPtr->varFramePtr;
  iPtr->varFramePtr = NULL;
  result = Tcl_Eval(interp, command, 0, (char **) NULL);
  iPtr->varFramePtr = savedVarFramePtr;
  return result;
}