tclbasic.c

CMX990 demonstration board (DE9901)

/* 
 * tclBasic.c --
 *
 *	Contains the basic facilities for TCL command interpretation,
 *	including interpreter creation and deletion, command creation
 *	and deletion, and command parsing and execution.
 *
 * Copyright 1987-1992 Regents of the University of California
 * Permission to use, copy, modify, and distribute this
 * software and its documentation for any purpose and without
 * fee is hereby granted, provided that the above copyright
 * notice appear in all copies.  The University of California
 * makes no representations about the suitability of this
 * software for any purpose.  It is provided "as is" without
 * express or implied warranty.
 *
 * $Id: tclBasic.c,v 1.1.1.1 2001/04/29 20:34:23 karll Exp $
 *
 */

#include "tclInt.h"
//#include <varargs.h>
#include <stdarg.h>

/*
 * The following structure defines all of the commands in the Tcl core,
 * and the C procedures that execute them.
 */

typedef struct {
  char *name;			/* Name of command. */
  Tcl_CmdProc *proc;		/* Procedure that executes command. */
} CmdInfo;

/*
 * Built-in commands, and the procedures associated with them:
 */

static CmdInfo builtInCmds[] = {
  /*
   * Commands in the generic core:
   */
  
  {"append",		Tcl_AppendCmd},
  {"array",		Tcl_ArrayCmd},
  {"break",		Tcl_BreakCmd},
  {"case",		Tcl_CaseCmd},
  {"catch",		Tcl_CatchCmd},
  {"concat",		Tcl_ConcatCmd},
  {"continue",	Tcl_ContinueCmd},
  {"error",		Tcl_ErrorCmd},
  {"eval",		Tcl_EvalCmd},
  {"expr",		Tcl_ExprCmd},
  {"for",		Tcl_ForCmd},
  {"foreach",		Tcl_ForeachCmd},
  {"format",		Tcl_FormatCmd},
  {"global",		Tcl_GlobalCmd},
  //    {"glob",		Tcl_GlobCmd},
  {"if",		Tcl_IfCmd},
  {"incr",		Tcl_IncrCmd},
  {"info",		Tcl_InfoCmd},
  {"join",		Tcl_JoinCmd},
  {"lappend",		Tcl_LappendCmd},
  {"lindex",		Tcl_LindexCmd},
  {"linsert",		Tcl_LinsertCmd},
  {"list",		Tcl_ListCmd},
  {"llength",		Tcl_LlengthCmd},
  {"lrange",		Tcl_LrangeCmd},
  {"lreplace",	Tcl_LreplaceCmd},
  {"lsearch",		Tcl_LsearchCmd},
  {"lsort",		Tcl_LsortCmd},
  {"proc",		Tcl_ProcCmd},
  {"regexp",		Tcl_RegexpCmd},
  {"regsub",		Tcl_RegsubCmd},
  {"rename",		Tcl_RenameCmd},
  {"return",		Tcl_ReturnCmd},
  {"scan",		Tcl_ScanCmd},
  {"set",		Tcl_SetCmd},
  {"split",		Tcl_SplitCmd},
  {"string",		Tcl_StringCmd},
  {"trace",		Tcl_TraceCmd},
  {"unset",		Tcl_UnsetCmd},
  {"uplevel",		Tcl_UplevelCmd},
  {"upvar",		Tcl_UpvarCmd},
  {"while",		Tcl_WhileCmd},
  
  /*
   * Commands in the UNIX core:
   */
  
#ifndef TCL_GENERIC_ONLY
  {"cd",		Tcl_CdCmd},
  {"close",		Tcl_CloseCmd},
  {"eof",		Tcl_EofCmd},
  //  {"exit",		Tcl_ExitCmd},
  {"file",		Tcl_FileCmd},
  {"flush",		Tcl_FlushCmd},
  {"gets",		Tcl_GetsCmd},
  {"open",		Tcl_OpenCmd},
  {"puts",		Tcl_PutsCmd},
  {"pwd",		Tcl_PwdCmd},
  {"read",		Tcl_ReadCmd},
  {"seek",		Tcl_SeekCmd},
  {"source",		Tcl_SourceCmd},
  {"tell",		Tcl_TellCmd},
#endif /* TCL_GENERIC_ONLY */
  {NULL,		(Tcl_CmdProc *) NULL}
};

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateInterp --
 *
 *	Create a new TCL command interpreter.
 *
 * Results:
 *	The return value is a token for the interpreter, which may be
 *	used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
 *	Tcl_DeleteInterp.
 *
 * Side effects:
 *	The command interpreter is initialized with an empty variable
 *	table and the built-in commands.
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *Tcl_CreateInterp(void) {
  register Interp *iPtr;
  register Command *cmdPtr;
  register CmdInfo *cmdInfoPtr;
  int i;
  
  iPtr = (Interp *) ckalloc(sizeof(Interp));
  iPtr->result = iPtr->resultSpace;
  iPtr->freeProc = 0;
  iPtr->errorLine = 0;
  Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS);
  Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS);
  iPtr->numLevels = 0;
  iPtr->framePtr = NULL;
  iPtr->varFramePtr = NULL;
  iPtr->activeTracePtr = NULL;
  iPtr->numEvents = 0;
  iPtr->events = NULL;
  iPtr->curEvent = 0;
  iPtr->curEventNum = 0;
  iPtr->revPtr = NULL;
  iPtr->historyFirst = NULL;
  iPtr->revDisables = 1;
  iPtr->evalFirst = iPtr->evalLast = NULL;
  iPtr->appendResult = NULL;
  iPtr->appendAvl = 0;
  iPtr->appendUsed = 0;
  iPtr->numFiles = 0;
  iPtr->filePtrArray = NULL;
  for (i = 0; i < NUM_REGEXPS; i++) {
    iPtr->patterns[i] = NULL;
    iPtr->patLengths[i] = -1;
    iPtr->regexps[i] = NULL;
  }
  iPtr->cmdCount = 0;
  iPtr->noEval = 0;
  iPtr->scriptFile = NULL;
  iPtr->flags = 0;
  iPtr->tracePtr = NULL;
  iPtr->resultSpace[0] = 0;
  
  /*
   * Create the built-in commands.  Do it here, rather than calling
   * Tcl_CreateCommand, because it's faster (there's no need to
   * check for a pre-existing command by the same name).
   */
  
  for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
    int new;
    Tcl_HashEntry *hPtr;
    
    hPtr = Tcl_CreateHashEntry(&iPtr->commandTable,
                               cmdInfoPtr->name, &new);
    if (new) {
      cmdPtr = (Command *) ckalloc(sizeof(Command));
      cmdPtr->proc = cmdInfoPtr->proc;
      cmdPtr->clientData = (ClientData) NULL;
      cmdPtr->deleteProc = NULL;
      Tcl_SetHashValue(hPtr, cmdPtr);
    }
  }
  
#ifndef TCL_GENERIC_ONLY
  TclSetupEnv((Tcl_Interp *) iPtr);
#endif
  
  return (Tcl_Interp *) iPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteInterp --
 *
 *	Delete an interpreter and free up all of the resources associated
 *	with it.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interpreter is destroyed.  The caller should never again
 *	use the interp token.
 *
 *----------------------------------------------------------------------
 */

void Tcl_DeleteInterp(Tcl_Interp *interp)
  //  Tcl_Interp *interp;		/* Token for command interpreter (returned
  //				 * by a previous call to Tcl_CreateInterp). */
{
  Interp *iPtr = (Interp *) interp;
  Tcl_HashEntry *hPtr;
  Tcl_HashSearch search;
  register Command *cmdPtr;
  int i;
  
  /*
   * If the interpreter is in use, delay the deletion until later.
   */
  
  iPtr->flags |= DELETED;
  if (iPtr->numLevels != 0) {
    return;
  }
  
  /*
   * Free up any remaining resources associated with the
   * interpreter.
   */
  
  for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
       hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
    if (cmdPtr->deleteProc != NULL) { 
      (*cmdPtr->deleteProc)(cmdPtr->clientData);
    }
    ckfree((char *) cmdPtr);
  }
  Tcl_DeleteHashTable(&iPtr->commandTable);
  TclDeleteVars(iPtr, &iPtr->globalTable);
  if (iPtr->events != NULL) {
    int i;
    
    for (i = 0; i < iPtr->numEvents; i++) {
      ckfree(iPtr->events[i].command);
    }
    ckfree((char *) iPtr->events);
  }
  while (iPtr->revPtr != NULL) {
    HistoryRev *nextPtr = iPtr->revPtr->nextPtr;
    
    ckfree((char *) iPtr->revPtr);
    iPtr->revPtr = nextPtr;
  }
  if (iPtr->appendResult != NULL) {
    ckfree(iPtr->appendResult);
  }
#ifndef TCL_GENERIC_ONLY
  if (iPtr->numFiles > 0) {
    for (i = 0; i < iPtr->numFiles; i++) {
      OpenFile *filePtr;
      
      filePtr = iPtr->filePtrArray[i];
      if (filePtr == NULL) {
        continue;
      }
      if (i >= 3) {
        fclose(filePtr->f);
        if (filePtr->f2 != NULL) {
          fclose(filePtr->f2);
        }
        if (filePtr->numPids > 0) {
          /* Tcl_DetachPids(filePtr->numPids, filePtr->pidPtr); */
          ckfree((char *) filePtr->pidPtr);
        }
      }
      ckfree((char *) filePtr);
    }
    ckfree((char *) iPtr->filePtrArray);
  }
#endif
  for (i = 0; i < NUM_REGEXPS; i++) {
    if (iPtr->patterns[i] == NULL) {
      break;
    }
    ckfree(iPtr->patterns[i]);
    ckfree((char *) iPtr->regexps[i]);
  }
  while (iPtr->tracePtr != NULL) {
    Trace *nextPtr = iPtr->tracePtr->nextPtr;
    
    ckfree((char *) iPtr->tracePtr);
    iPtr->tracePtr = nextPtr;
  }
  ckfree((char *) iPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateCommand --
 *
 *	Define a new command in a command table.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If a command named cmdName already exists for interp, it is
 *	deleted.  In the future, when cmdName is seen as the name of
 *	a command by Tcl_Eval, proc will be called.  When the command
 *	is deleted from the table, deleteProc will be called.  See the
 *	manual entry for details on the calling sequence.
 *
 *----------------------------------------------------------------------
 */

void Tcl_CreateCommand(Tcl_Interp *interp, char *cmdName, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc)
  //   Tcl_Interp *interp;	/* Token for command interpreter (returned
  //			         * by a previous call to Tcl_CreateInterp). */
  //char *cmdName;		/* Name of command. */
  //Tcl_CmdProc *proc;		/* Command procedure to associate with
  //			         * cmdName. */
  //ClientData clientData;	/* Arbitrary one-word value to pass to proc. */
  //Tcl_CmdDeleteProc *deleteProc;
  //			        /* If not NULL, gives a procedure to call when
  //			         * this command is deleted. */
{
  Interp *iPtr = (Interp *) interp;
  register Command *cmdPtr;
  Tcl_HashEntry *hPtr;
  int new;

  hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
  if (!new) {
    /*
     * Command already exists:  delete the old one.
     */

    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
    if (cmdPtr->deleteProc != NULL) {
      (*cmdPtr->deleteProc)(cmdPtr->clientData);
    }
  } else {
    cmdPtr = (Command *) ckalloc(sizeof(Command));
    Tcl_SetHashValue(hPtr, cmdPtr);
  }
  cmdPtr->proc = proc;
  cmdPtr->clientData = clientData;
  cmdPtr->deleteProc = deleteProc;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteCommand --
 *
 *	Remove the given command from the given interpreter.
 *
 * Results:
 *	0 is returned if the command was deleted successfully.
 *	-1 is returned if there didn't exist a command by that
 *	name.
 *
 * Side effects:
 *	CmdName will no longer be recognized as a valid command for
 *	interp.
 *
 *----------------------------------------------------------------------
 */

int Tcl_DeleteCommand(Tcl_Interp *interp, char *cmdName)
  //  Tcl_Interp *interp;		/* Token for command interpreter (returned
  //			 * by a previous call to Tcl_CreateInterp). */
  //char *cmdName;		/* Name of command to remove. */
{
  Interp *iPtr = (Interp *) interp;
  Tcl_HashEntry *hPtr;
  Command *cmdPtr;

  hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);
  if (hPtr == NULL) {
    return -1;
  }
  cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  if (cmdPtr->deleteProc != NULL) {
    (*cmdPtr->deleteProc)(cmdPtr->clientData);
  }
  ckfree((char *) cmdPtr);
  Tcl_DeleteHashEntry(hPtr);
  return 0;
}

/*
 *-----------------------------------------------------------------
 *
 * Tcl_Eval --
 *
 *	Parse and execute a command in the Tcl language.
 *
 * Results:
 *	The return value is one of the return codes defined in tcl.hd
 *	(such as TCL_OK), and interp->result contains a string value
 *	to supplement the return code.  The value of interp->result
 *	will persist only until the next call to Tcl_Eval:  copy it or
 *	lose it! *TermPtr is filled in with the character just after
 *	the last one that was part of the command (usually a NULL
 *	character or a closing bracket).
 *
 * Side effects:
 *	Almost certainly;  depends on the command.
 *
 *-----------------------------------------------------------------
 */

int Tcl_Eval(Tcl_Interp *interp, char *cmd, int flags, char **termPtr)
  //  Tcl_Interp *interp;		/* Token for command interpreter (returned
  //				 * by a previous call to Tcl_CreateInterp). */
  //char *cmd;			/* Pointer to TCL command to interpret. */
  //int flags;			/* OR-ed combination of flags like
  //				 * TCL_BRACKET_TERM and TCL_RECORD_BOUNDS. */
  //char **termPtr;		/* If non-NULL, fill in the address it points
  //                         * to with the address of the char. just after
  //                         * the last one that was part of cmd.  See
  //                         * the man page for details on this. */
{
  /*
   * The storage immediately below is used to generate a copy
   * of the command, after all argument substitutions.  Pv will
   * contain the argv values passed to the command procedure.
   */
  
# define NUM_CHARS 200
  char copyStorage[NUM_CHARS];
  ParseValue pv;
  char *oldBuffer;
  
  /*
   * This procedure generates an (argv, argc) array for the command,
   * It starts out with stack-allocated space but uses dynamically-
   * allocated storage to increase it if needed.
   */
  
#   define NUM_ARGS 10
  char *(argStorage[NUM_ARGS]);
  char **argv = argStorage;
  int argc;
  int argSize = NUM_ARGS;
  
  register char *src;			/* Points to current character
					 * in cmd. */
  char termChar;			/* Return when this character is found
					 * (either ']' or '\0').  Zero means
					 * that newlines terminate commands. */
  int result;				/* Return value. */
  register Interp *iPtr = (Interp *) interp;
  Tcl_HashEntry *hPtr;
  Command *cmdPtr;
  char *dummy;			/* Make termPtr point here if it was
                                 * originally NULL. */
  char *cmdStart;			/* Points to first non-blank char. in
					 * command (used in calling trace
					 * procedures). */
  char *ellipsis = "";		/* Used in setting errorInfo variable;
                                 * set to "..." to indicate that not
                                 * all of offending command is included
                                 * in errorInfo.  "" means that the
                                 * command is all there. */
  register Trace *tracePtr;
  
  /*
   * Initialize the result to an empty string and clear out any
   * error information.  This makes sure that we return an empty
   * result if there are no commands in the command string.
   */
  
  Tcl_FreeResult((Tcl_Interp *) iPtr);
  iPtr->result = iPtr->resultSpace;
  iPtr->resultSpace[0] = 0;
  result = TCL_OK;
  
  /*
   * Check depth of nested calls to Tcl_Eval:  if this gets too large,
   * it's probably because of an infinite loop somewhere.
   */
  
  iPtr->numLevels++;
  if (iPtr->numLevels > MAX_NESTING_DEPTH) {
    iPtr->numLevels--;
    iPtr->result =  "too many nested calls to Tcl_Eval (infinite loop?)";
    return TCL_ERROR;
  }
  
  /*
   * Initialize the area in which command copies will be assembled.
   */
  
  pv.buffer = copyStorage;
  pv.end = copyStorage + NUM_CHARS - 1;
  pv.expandProc = TclExpandParseValue;
  pv.clientData = (ClientData) NULL;
  
  src = cmd;
  if (flags & TCL_BRACKET_TERM) {
    termChar = ']';
  } else {
    termChar = 0;
  }
  if (termPtr == NULL) {
    termPtr = &dummy;
  }
  *termPtr = src;
  cmdStart = src;
  
  /*
   * There can be many sub-commands (separated by semi-colons or
   * newlines) in one command string.  This outer loop iterates over
   * individual commands.
   */