From: peter@ficc.uu.net (Peter da Silva)
Newsgroups: alt.sources
Subject: TCL for System V (part 06/06)
Summary: Tool Command Language for System V and Xenix/286.
Message-ID: <PD22IYBxds13@ficc.uu.net>
Date: 7 Mar 90 11:27:59 GMT
Sender: peter@ficc.uu.net (Peter da Silva)
Organization: Xenix Support, FICC
Lines: 1348
Posted: Wed Mar  7 12:27:59 1990


Archive-name: tcl/Part06

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of archive 6 (of 6)."
# Contents:  tclBasic.c
# Wrapped by peter@ficc.uu.net on Wed Mar  7 05:16:13 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tclBasic.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'tclBasic.c'\"
else
echo shar: Extracting \"'tclBasic.c'\" \(32489 characters\)
sed "s/^X//" >'tclBasic.c' <<'END_OF_FILE'
X/* 
X * tclBasic.c --
X *
X *	Contains the basic facilities for TCL command interpretation,
X *	including interpreter creation and deletion, command creation
X *	and deletion, and command parsing and execution.
X *
X * Copyright 1987 Regents of the University of California
X * Permission to use, copy, modify, and distribute this
X * software and its documentation for any purpose and without
X * fee is hereby granted, provided that the above copyright
X * notice appear in all copies.  The University of California
X * makes no representations about the suitability of this
X * software for any purpose.  It is provided "as is" without
X * express or implied warranty.
X */
X
X#ifndef lint
Xstatic char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclBasic.c,v 1.62 90/01/27 14:43:53 ouster Exp $ SPRITE (Berkeley)";
X#endif /* not lint */
X
X#include <stdio.h>
X#include <ctype.h>
X#include <stdlib.h>
X#include <string.h>
X#include "tclInt.h"
X
X/*
X * Built-in commands, and the procedures associated with them:
X */
X
Xstatic char *builtInCmds[] = {
X    "break",
X    "case",
X    "catch",
X    "concat",
X    "continue",
X    "error",
X    "eval",
X    "exec",
X    "expr",
X    "file",
X    "for",
X    "foreach",
X    "format",
X#ifdef GNU
X    "glob",
X#endif
X    "global",
X    "if",
X    "strchr",
X    "info",
X    "length",
X    "list",
X    "print",
X    "proc",
X    "range",
X    "rename",
X    "return",
X    "scan",
X    "set",
X    "source",
X    "string",
X    "time",
X    "uplevel",
X    NULL
X};
X
Xstatic int (*(builtInProcs[]))() = {
X    Tcl_BreakCmd,
X    Tcl_CaseCmd,
X    Tcl_CatchCmd,
X    Tcl_ConcatCmd,
X    Tcl_ContinueCmd,
X    Tcl_ErrorCmd,
X    Tcl_EvalCmd,
X    Tcl_ExecCmd,
X    Tcl_ExprCmd,
X    Tcl_FileCmd,
X    Tcl_ForCmd,
X    Tcl_ForeachCmd,
X    Tcl_FormatCmd,
X#ifdef GNU
X    Tcl_GlobCmd,
X#endif
X    Tcl_GlobalCmd,
X    Tcl_IfCmd,
X    Tcl_IndexCmd,
X    Tcl_InfoCmd,
X    Tcl_LengthCmd,
X    Tcl_ListCmd,
X    Tcl_PrintCmd,
X    Tcl_ProcCmd,
X    Tcl_RangeCmd,
X    Tcl_RenameCmd,
X    Tcl_ReturnCmd,
X    Tcl_ScanCmd,
X    Tcl_SetCmd,
X    Tcl_SourceCmd,
X    Tcl_StringCmd,
X    Tcl_TimeCmd,
X    Tcl_UplevelCmd,
X    NULL
X};
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_CreateInterp --
X *
X *	Create a new TCL command interpreter.
X *
X * Results:
X *	The return value is a token for the interpreter, which may be
X *	used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
X *	Tcl_DeleteInterp.
X *
X * Side effects:
X *	The command interpreter is initialized with an empty variable
X *	table and the built-in commands.
X *
X *----------------------------------------------------------------------
X */
X
XTcl_Interp *
XTcl_CreateInterp()
X{
X    register Interp *iPtr;
X    register char **namePtr;
X    register int (**procPtr)();
X    register Command *cmdPtr;
X
X    iPtr = (Interp *) ckalloc(sizeof(Interp));
X    iPtr->result = iPtr->resultSpace;
X    iPtr->dynamic = 0;
X    iPtr->errorLine = 0;
X    iPtr->commandPtr = NULL;
X    iPtr->globalPtr = NULL;
X    iPtr->numLevels = 0;
X    iPtr->framePtr = NULL;
X    iPtr->varFramePtr = NULL;
X    iPtr->cmdCount = 0;
X    iPtr->errInProgress = 0;
X    iPtr->noEval = 0;
X    iPtr->flags = 0;
X    iPtr->tracePtr = NULL;
X    iPtr->callbackPtr = NULL;
X    iPtr->resultSpace[0] = 0;
X
X    /*
X     * Create the built-in commands.  Do it here, rather than calling
X     * Tcl_CreateCommand, because it's faster (there's no need to
X     * check for a pre-existing command by the same name).
X     */
X
X    for (namePtr = builtInCmds, procPtr = builtInProcs;
X	    *namePtr != NULL; namePtr++, procPtr++) {
X	cmdPtr = (Command *) ckalloc(CMD_SIZE(strlen(*namePtr)));
X	cmdPtr->proc = *procPtr;
X	cmdPtr->clientData = (ClientData) NULL;
X	cmdPtr->deleteProc = NULL;
X	cmdPtr->nextPtr = iPtr->commandPtr;
X	iPtr->commandPtr = cmdPtr;
X	strcpy(cmdPtr->name, *namePtr);
X    }
X
X    return (Tcl_Interp *) iPtr;
X}
X 
X/*
X *--------------------------------------------------------------
X *
X * Tcl_WatchInterp --
X *
X *	Arrange for a procedure to be called before a given
X *	interpreter is deleted.
X *
X * Results:
X *	None.
X *
X * Side effects:
X *	When Tcl_DeleteInterp is invoked to delete interp,
X *	proc will be invoked.  See the manual entry for
X *	details.
X *
X *--------------------------------------------------------------
X */
X
Xvoid
XTcl_WatchInterp(interp, proc, clientData)
X    Tcl_Interp *interp;		/* Interpreter to watch. */
X    void (*proc)();		/* Procedure to call when interpreter
X				 * is about to be deleted. */
X    ClientData clientData;	/* One-word value to pass to proc. */
X{
X    register InterpCallback *icPtr;
X    Interp *iPtr = (Interp *) interp;
X
X    icPtr = (InterpCallback *) ckalloc(sizeof(InterpCallback));
X    icPtr->proc = proc;
X    icPtr->clientData = clientData;
X    icPtr->nextPtr = iPtr->callbackPtr;
X    iPtr->callbackPtr = icPtr;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DeleteInterp --
X *
X *	Delete an interpreter and ckfree up all of the resources associated
X *	with it.
X *
X * Results:
X *	None.
X *
X * Side effects:
X *	The interpreter is destroyed.  The caller should never again
X *	use the interp token.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_DeleteInterp(interp)
X    Tcl_Interp *interp;		/* Token for command interpreter (returned
X				 * by a previous call to Tcl_CreateInterp). */
X{
X    Interp *iPtr = (Interp *) interp;
X    register Command *cmdPtr;
X    register Trace *tracePtr;
X    register InterpCallback *icPtr;
X
X    /*
X     * If the interpreter is in use, delay the deletion until later.
X     */
X
X    iPtr->flags |= DELETED;
X    if (iPtr->numLevels != 0) {
X	return;
X    }
X
X    /*
X     * Invoke callbacks, if there's anyone who wants to know about
X     * the interpreter deletion.
X     */
X
X    for (icPtr = iPtr->callbackPtr; icPtr != NULL;
X	    icPtr = icPtr->nextPtr) {
X	(*icPtr->proc)(icPtr->clientData, interp);
X	ckfree((char *) icPtr);
X    }
X
X    /*
X     * Free up any remaining resources associated with the
X     * interpreter.
X     */
X
X    for (cmdPtr = iPtr->commandPtr; cmdPtr != NULL;
X	    cmdPtr = cmdPtr->nextPtr) {
X	if (cmdPtr->deleteProc != NULL) { 
X	    (*cmdPtr->deleteProc)(cmdPtr->clientData);
X	}
X	ckfree((char *) cmdPtr);
X    }
X    iPtr->commandPtr = NULL;
X    TclDeleteVars(iPtr);
X    for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
X	    tracePtr = tracePtr->nextPtr) {
X	ckfree((char *) tracePtr);
X    }
X    ckfree((char *) iPtr);
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_CreateCommand --
X *
X *	Define a new command in a command table.
X *
X * Results:
X *	None.
X *
X * Side effects:
X *	If a command named cmdName already exists for interp, it is
X *	deleted.  In the future, when cmdName is seen as the name of
X *	a command by Tcl_Eval, proc will be called with the following
X *	syntax:
X *
X *	int
X *	proc(clientData, interp, argc, argv)
X *	    ClientData clientData;
X *	    Tcl_Interp *interp;
X *	    int argc;
X *	    char **argv;
X *	{
X *	}
X *
X *	The clientData and interp arguments are the same as the corresponding
X *	arguments passed to this procedure.  Argc and argv describe the
X *	arguments to the command, in the usual UNIX fashion.  Proc must
X *	return a code like TCL_OK or TCL_ERROR.  It can also set interp->result
X *	("" is the default value if proc doesn't set it) and interp->dynamic (0
X *	is the default).  See tcl.h for more information on these variables.
X *
X *	When the command is deleted from the table, deleteProc will be called
X *	in the following way:
X *
X *	void
X *	deleteProc(clientData)
X *	    ClientData clientData;
X *	{
X *	}
X *
X *	DeleteProc allows command implementors to perform their own cleanup
X *	when commands (or interpreters) are deleted.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
X    Tcl_Interp *interp;		/* Token for command interpreter (returned
X				 * by a previous call to Tcl_CreateInterp). */
X    char *cmdName;		/* Name of command. */
X    int (*proc)();		/* Command procedure to associate with
X				 * cmdName. */
X    ClientData clientData;	/* Arbitrary one-word value to pass to proc. */
X    void (*deleteProc)();	/* If not NULL, gives a procedure to call when
X				 * this command is deleted. */
X{
X    Interp *iPtr = (Interp *) interp;
X    register Command *cmdPtr;
X
X    Tcl_DeleteCommand(interp, cmdName);
X    cmdPtr = (Command *) ckalloc(CMD_SIZE(strlen(cmdName)));
X    cmdPtr->proc = proc;
X    cmdPtr->clientData = clientData;
X    cmdPtr->deleteProc = deleteProc;
X    cmdPtr->nextPtr = iPtr->commandPtr;
X    iPtr->commandPtr = cmdPtr;
X    strcpy(cmdPtr->name, cmdName);
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DeleteCommand --
X *
X *	Remove the given command from the given interpreter.
X *
X * Results:
X *	None.
X *
X * Side effects:
X *	CmdName will no longer be recognized as a valid command for
X *	interp.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_DeleteCommand(interp, cmdName)
X    Tcl_Interp *interp;		/* Token for command interpreter (returned
X				 * by a previous call to Tcl_CreateInterp). */
X    char *cmdName;		/* Name of command to remove. */
X{
X    Interp *iPtr = (Interp *) interp;
X    Command *cmdPtr;
X
X    cmdPtr = TclFindCmd(iPtr, cmdName, 0);
X    if (cmdPtr != NULL) {
X	if (cmdPtr->deleteProc != NULL) {
X	    (*cmdPtr->deleteProc)(cmdPtr->clientData);
X	}
X	iPtr->commandPtr = cmdPtr->nextPtr;
X	ckfree((char *) cmdPtr);
X    }
X}
X 
X/*
X *-----------------------------------------------------------------
X *
X * Tcl_Eval --
X *
X *	Parse and execute a command in the Tcl language.
X *
X * Results:
X *	The return value is one of the return codes defined in
X *	tcl.h (such as TCL_OK), and interp->result contains a string
X *	value to supplement the return code.  The value of interp->result
X *	will persist only until the next call to Tcl_Eval:  copy it
X *	or lose it!
X *
X * Side effects:
X *	Almost certainly;  depends on the command.
X *
X *-----------------------------------------------------------------
X */
X
Xint
XTcl_Eval(interp, cmd, flags, termPtr)
X    Tcl_Interp *interp;		/* Token for command interpreter (returned
X				 * by a previous call to Tcl_CreateInterp). */
X    char *cmd;			/* Pointer to TCL command to interpret. */
X    int flags;			/* OR-ed combination of flags like
X				 * TCL_BRACKET_TERM. */
X    char **termPtr;		/* If non-NULL, fill in the address it points
X				 * to with the address of the char. just after
X				 * the last one that was part of cmd.  See
X				 * the man page for details on this. */
X{
X    /*
X     * While processing the command, make a local copy of
X     * the command characters.  This is needed in order to
X     * terminate each argument with a null character, replace
X     * backslashed-characters, etc.  The copy starts out in
X     * a static string (for speed) but gets expanded into
X     * dynamically-allocated strings if necessary.  The constant
X     * BUFFER indicates how much space there must be in the copy
X     * in order to pass through the main loop below (e.g., must
X     * have space to copy both a backslash and its following
X     * characters).
X     */
X
X#   define NUM_CHARS 200
X#   define BUFFER 5
X    char copyStorage[NUM_CHARS];
X    char *copy = copyStorage;	/* Pointer to current copy. */
X    int copySize = NUM_CHARS;	/* Size of current copy. */
X    register char *dst;		/* Points to next place to copy
X				 * a character. */
X    char *limit;		/* When dst gets here, must make
X				 * the copy larger. */
X
X    /*
X     * This procedure generates an (argv, argc) array for the command,
X     * It starts out with stack-allocated space but uses dynamically-
X     * allocated storage to increase it if needed.
X     */
X
X#   define NUM_ARGS 10
X    char *(argStorage[NUM_ARGS]);
X    char **argv = argStorage;
X    int argc;
X    int argSize = NUM_ARGS;
X
X    /*
X     * Keep count of how many nested open braces or quotes there
X     * are at the current point in the current argument.  If a
X     * quoted argument is being read, then openQuote and openBraces
X     * will both be 1.
X     */
X
X    int openBraces = 0;			/* Curent nesting level. */
X    int openQuote = 0;			/* Non-zero means quoted arg
X					 * in progress. */
X
X    register char *src;			/* Points to current character
X					 * in cmd. */
X    char termChar;			/* Return when this character is found
X					 * (either ']' or '\0').  Zero means
X					 * that newlines terminate commands. */
X    char *argStart;			/* Location in cmd of first							 * non-separator character in
X					 * current argument;  it's
X					 * used to eliminate multiple
X					 * separators between args and
X					 * extra separators after last
X					 * arg in command. */
X    int result = TCL_OK;		/* Return value. */
X    int i;
X    register Interp *iPtr = (Interp *) interp;
X    Command *cmdPtr;
X    char *tmp;
X    char *dummy;			/* Make termPtr point here if it was
X					 * originally NULL. */
X    char *syntaxMsg;
X    char *syntaxPtr;			/* Points to "relevant" character
X					 * for syntax violations. */
X    char *cmdStart;			/* Points to first non-blank char. in
X					 * command (used in calling trace
X					 * procedures). */
X    register Trace *tracePtr;
X
X    /*
X     * Set up the result so that if there's no command at all in
X     * the string then this procedure will return TCL_OK.
X     */
X
X    if (iPtr->dynamic) {
X	ckfree((char *) iPtr->result);
X	iPtr->dynamic = 0;
X    }
X    iPtr->result = iPtr->resultSpace;
X    iPtr->resultSpace[0] = 0;
X
X    iPtr->numLevels++;
X    iPtr->errInProgress = 0;
X    src = cmd;
X    result = TCL_OK;
X    if (flags & TCL_BRACKET_TERM) {
X	termChar = ']';
X    } else {
X	termChar = 0;
X    }
X    if (termPtr == NULL) {
X	termPtr = &dummy;
X    }
X
X    /*
X     * There can be many sub-commands (separated by semi-colons or
X     * newlines) in one command string.  This outer loop iterates over
X     * the inner commands.
X     */
X
X    for (*termPtr = src; *src != termChar; *termPtr = src) {
X
X	/*
X	 * Skim off leading white space and semi-colons, and skip comments.
X	 */
X
X	while (isspace(*src) || (*src == ';')) {
X	    src += 1;
X	}
X	if (*src == '#') {
X	    for (src++; *src != 0; src++) {
X		if (*src == '\n') {
X		    src++;
X		    break;
X		}
X	    }
X	    continue;
X	}
X
X	/*
X	 * Set up the first argument (the command name).  Note that
X	 * the arg pointer gets set up BEFORE the first real character
X	 * of the argument has been found.
X	 */
X    
X	dst = copy;
X	argc = 0;
X	limit = copy + copySize - BUFFER;
X	argv[0] = dst;
X	argStart = cmdStart = src;
X
X	/*
X	 * Skim off the command name and arguments by looping over
X	 * characters and processing each one according to its type.
X	 */
X    
X	while (1) {
X	    switch (*src) {
X    
X		/*
X		 * All braces are treated as normal characters
X		 * unless the first character of the argument is an
X		 * open brace.  In that case, braces nest and
X		 * the argument terminates when all braces are matched.
X		 * Internal braces are also copied like normal chars.
X		 */
X    
X		case '{': {
X		    if ((openBraces == 0) && (dst == argv[argc])) {
X			syntaxPtr = src;
X			openBraces = 1;
X			break;
X		    }
X		    *dst = '{'; dst++;
X		    if ((openBraces > 0) && !openQuote) {
X			openBraces++;
X		    }
X		    break;
X		}
X
X		case '}': {
X		    if (openBraces == 1) {
X			openBraces = 0;
X			if (!isspace(src[1]) && (src[1] != termChar) &&
X				(src[1] != 0) && (src[1] != ';')) {
X			    syntaxPtr = src;
X			    syntaxMsg = "extra characters after close-brace";
X			    goto syntaxError;
X			}
X		    } else {
X			*dst = '}'; dst++;
X			if ((openBraces > 0) && !openQuote) {
X			    openBraces--;
X			}
X		    }
X		    break;
X		}
X
X		case '"': {
X		    if (!openQuote) {
X			if ((openBraces) || (dst != argv[argc])) {
X			    *dst = '"'; dst++;
X			    break;
X			}
X			syntaxPtr = src;
X			openQuote = 1;
X			openBraces = 1;
X		    } else {
X			openQuote = 0;
X			openBraces = 0;
X			if (!isspace(src[1]) && (src[1] != termChar) &&
X				(src[1] != 0)) {
X			    syntaxPtr = src;
X			    syntaxMsg = "extra characters after close-quote";
X			    goto syntaxError;
X			}
X		    }
X		    break;
X		}
X    
X		case '[': {
X    
X		    /*
X		     * Open bracket: if not in middle of braces, then execute
X		     * following command and substitute result into argument.
X		     */
X
X		    if (openBraces != 0) {
X			*dst = '['; dst++;
X		    } else {
X			int length;
X    
X			result = Tcl_Eval(interp, src+1, TCL_BRACKET_TERM,
X				&tmp);
X			src = tmp;
X			if (result != TCL_OK) {
X			    goto done;
X			}
X    
X			/*
X			 * Copy the return value into the current argument.
X			 * May have to enlarge the argument storage.  When
X			 * enlarging, get more than enough to reduce the
X			 * likelihood of having to enlarge again.  This code
X			 * is used for $-processing also.
X			 */
X
X			copyResult:
X			length = strlen(iPtr->result);
X			if ((limit - dst) < length) {
X			    char *newCopy;
X			    int bytes;
X
X			    bytes = dst - copy;
X			    copySize = length + 10 + bytes;
X			    newCopy = (char *) ckalloc((unsigned) copySize);
X			    move_argv(argv, argc, copy, newCopy, bytes);
X			    dst = newCopy + bytes;
X			    if (copy != copyStorage) {
X				ckfree((char *) copy);
X			    }
X			    copy = newCopy;
X			    limit = newCopy + copySize - BUFFER;
X			}
X			bcopy(iPtr->result, dst, length);
X			dst += length;
X
X			/*
X			 * Clear out the return value again.
X			 */
X
X			if (iPtr->dynamic) {
X			    ckfree((char *) iPtr->result);
X			    iPtr->dynamic = 0;
X			}
X			iPtr->result = iPtr->resultSpace;
X			iPtr->resultSpace[0] = 0;
X		    }
X		    break;
X		}
X
X		case '$': {
X		    if (openBraces != 0) {
X			*dst = '$'; dst++;
X		    } else {
X			char *value;
X
X			/*
X			 * Parse off a variable name and copy its value.
X			 */
X    
X			value = Tcl_ParseVar(interp, src, &tmp);
X			if (value == 0) {
X			    result = TCL_ERROR;
X			    goto done;
X			}
X			interp->result = value;
X			src = tmp-1;
X			goto copyResult;
X		    }
X		    break;
X		}
X
X		case ']': {
X		    if ((openBraces == 0) && (termChar == ']')) {
X			goto cmdComplete;
X		    }
X		    *dst = ']'; dst++;
X		    break;
X		}
X
X		case ';': {
X		    if (openBraces == 0) {
X			goto cmdComplete;
X		    }
X		    *dst = *src; dst++;
X		    break;
X		}
X    
X		case '\n': {
X
X		    /*
X		     * A newline can be either a command terminator
X		     * or a space character.  If it's a space character,
X		     * just fall through to the space code below.
X		     */
X    
X		    if ((openBraces == 0) && (termChar == 0)) {
X			goto cmdComplete;
X		    }
X		}
X
X		case '\r':
X		case ' ':
X		case '\t': {
X		    if (openBraces > 0) {
X    
X			/*
X			 * Quoted space.  Copy it into the argument.
X			 */
X
X			*dst = *src; dst++;
X		    } else {
X
X			/*
X			 * Argument separator.  If there are many
X			 * separators in a row (src == argStart) just
X			 * ignore this separator.  Otherwise,
X			 * Null-terminate the current argument and
X			 * set up for the next one.
X			 */
X
X			if (src == argStart) {
X			    argStart = src+1;
X			    break;
X			}
X			argStart = src+1;
X			*dst = 0;
X			dst++; argc++;
X
X			/*
X			 * Make sure that the argument array is large enough
X			 * for the next argument plus a final NULL argument
X			 * pointer to terminate the list.
X			 */
X
X			if (argc >= argSize-1) {
X			    char **newArgs;
X    
X			    argSize *= 2;
X			    newArgs = (char **)
X				    ckalloc((unsigned) argSize * sizeof(char *));
X			    for (i = 0; i < argc; i++) {
X				newArgs[i] = argv[i];
X			    }
X			    if (argv != argStorage) {
X				ckfree((char *) argv);
X			    }
X			    argv = newArgs;
X			}
X			argv[argc] = dst;
X			break;
X		    }
X		    break;
X		}
X    
X		case '\\': {
X		    int numRead;
X
X		    /*
X		     * First of all, make the special check for
X		     * backslash followed by newline.  This can't
X		     * be processed in the normal fashion of
X		     * Tcl_Backslash because is maps to "nothing",
X		     * rather than to a character.
X		     */
X
X		    if (src[1] == '\n') {
X			if (argStart  == src) {
X			    argStart += 2;
X			}
X			src++;
X			break;
X		    }
X
X		    /*
X		     * If we're in an argument in braces then the
X		     * backslash doesn't get collapsed.  However,
X		     * whether we're in braces or not the characters
X		     * inside the backslash sequence must not receive
X		     * any additional processing:  make src point to
X		     * the last character of the sequence.
X		     */
X
X		    *dst = Tcl_Backslash(src, &numRead);
X		    if (openBraces > 0) {
X			for ( ; numRead > 0; src++, dst++, numRead--) {
X			    *dst = *src;
X			}
X			src--;
X		    } else {
X			src += numRead-1;
X			dst++;
X		    }
X		    break;
X		}
X    
X		case 0: {
X
X		    /*
X		     * End of string.  Make sure that braces/quotes
X		     * were properly matched.  Also, it's only legal
X		     * to terminate a command by a null character if
X		     * termChar is zero.
X		     */
X
X		    if (openBraces != 0) {
X			if (openQuote) {
X			    syntaxMsg = "unmatched quote";
X			} else {
X			    syntaxMsg = "unmatched brace";
X			}
X			goto syntaxError;
X		    } else if (termChar == ']') {
X			syntaxPtr = cmd;
X			syntaxMsg = "missing close-bracket";
X			goto syntaxError;
X		    }
X		    goto cmdComplete;
X		}
X    
X		default: {
X		    *dst = *src; dst++;
X		    break;
X		}
X	    }
X	    src += 1;
X    
X	    /*
X	     * Make sure that we're not running out of space in the
X	     * string copy area.  If we are, allocate a larger area
X	     * and copy the string.  Be sure to update all of the
X	     * relevant pointers too.
X	     */
X    
X	    if (dst >= limit) {
X		char *newCopy;
X		int bytes;
X    
X		bytes = dst - copy;
X		copySize *= 2;
X		newCopy = (char *) ckalloc((unsigned) copySize);
X		move_argv(argv, argc, copy, newCopy, bytes);
X		dst = newCopy + bytes;
X		if (copy != copyStorage) {
X		    ckfree((char *) copy);
X		}
X		copy = newCopy;
X		limit = newCopy + copySize - BUFFER;
X	    }
X    
X	}
X    
X	/*
X	 * Terminate the last argument and add a final NULL argument.  If
X	 * the interpreter has been deleted then return;  if there's no
X	 * command, then go on to the next iteration.
X	 */
X
X	cmdComplete:
X	if (iPtr->flags & DELETED) {
X	    goto done;
X	}
X	if (src != argStart) {
X	    *dst = 0;
X	    argc++;
X	}
X	if ((argc == 0) || iPtr->noEval) {
X	    continue;
X	}
X	argv[argc] = NULL;
X
X	cmdPtr = TclFindCmd(iPtr, argv[0], 1);
X	if (cmdPtr == NULL) {
X	    sprintf(iPtr->result,
X		    "\"%.50s\" is an invalid command name %s",
X		    argv[0], "or ambiguous abbreviation");
X	    result = TCL_ERROR;
X	    goto done;
X	}
X
X	/*
X	 * Call trace procedures, if any, then invoke the command.
X	 */
X
X	for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
X		tracePtr = tracePtr->nextPtr) {
X	    char saved;
X
X	    if (tracePtr->level < iPtr->numLevels) {
X		continue;
X	    }
X	    saved = *src;
X	    *src = 0;
X	    (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
X		    cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv);
X	    *src = saved;
X	}
X
X	iPtr->cmdCount++;
X	result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv);
X	if (result != TCL_OK) {
X	    break;
X	}
X    }
X
X    /*
X     * Free up any extra resources that were allocated.
X     */
X
X    done:
X    if (copy != copyStorage) {
X	ckfree((char *) copy);
X    }
X    if (argv != argStorage) {
X	ckfree((char *) argv);
X    }
X    iPtr->numLevels--;
X    if (iPtr->numLevels == 0) {
X	if (result == TCL_RETURN) {
X	    result = TCL_OK;
X	}
X	if ((result != TCL_OK) && (result != TCL_ERROR)) {
X	    if (iPtr->dynamic) {
X		ckfree(iPtr->result);
X		iPtr->dynamic = 0;
X	    }
X	    if (result == TCL_BREAK) {
X		iPtr->result = "invoked \"break\" outside of a loop";
X	    } else if (result == TCL_CONTINUE) {
X		iPtr->result = "invoked \"continue\" outside of a loop";
X	    } else {
X		iPtr->result = iPtr->resultSpace;
X		sprintf(iPtr->resultSpace, "command returned bad code: %d",
X			result);
X	    }
X	    result = TCL_ERROR;
X	}
X	if (iPtr->flags & DELETED) {
X	    Tcl_DeleteInterp(interp);
X	}
X    }
X
X    /*
X     * If an error occurred, record information about what was being
X     * executed when the error occurred.
X     */
X
X    if (result == TCL_ERROR) {
X	int numChars;
X	register char *p;
X	char *ellipsis;
X
X	/*
X	 * Compute the line number where the error occurred.
X	 */
X
X	iPtr->errorLine = 1;
X	for (p = cmd; p != cmdStart; p++) {
X	    if (*p == '\n') {
X		iPtr->errorLine++;
X	    }
X	}
X	for ( ; isspace(*p) || (*p == ';'); p++) {
X	    if (*p == '\n') {
X		iPtr->errorLine++;
X	    }
X	}
X
X	/*
X	 * Figure out how much of the command to print in the error
X	 * message (up to a certain number of characters, or up to
X	 * the first new-line).
X	 */
X
X	ellipsis = "";
X	p = strchr(cmdStart, '\n');
X	if (p == NULL) {
X	    numChars = strlen(cmdStart);
X	} else {
X	    if (p < src) {
X		ellipsis = "...";
X	    }
X	    numChars = p - cmdStart;
X	}
X	if (numChars > 40) {
X	    numChars = 40;
X	    ellipsis = "...";
X	}
X
X	if (!iPtr->errInProgress) {
X	    /*
X	     * This is the first piece of information being recorded
X	     * for this error.  Log the error message as well as the
X	     * command being executed.
X	     */
X
X	    if (strlen(iPtr->result) < 50) {
X		sprintf(copyStorage,
X			"%s, while executing\n\"%.*s%s\"",
X			iPtr->result, numChars, cmdStart, ellipsis);
X	    } else {
X		sprintf(copyStorage,
X			"%.50s..., while executing\n\"%.*s%s\"",
X			iPtr->result, numChars, cmdStart, ellipsis);
X	    }
X	} else {
X	    sprintf(copyStorage, ", invoked from within\n\"%.*s%s\"",
X		    numChars, cmdStart, ellipsis);
X	}
X	Tcl_AddErrorInfo(interp, copyStorage);
X    }
X    return result;
X
X    /*
X     * Syntax error:  generate an error message.
X     */
X
X    syntaxError: {
X	char *first, *last;
X
X	Tcl_Return(interp, (char *) NULL, TCL_STATIC);
X	for (first = syntaxPtr; ((first != cmd) && (first[-1] != '\n'));
X		first--) {
X	    /* Null loop body. */
X	}
X	for (last = syntaxPtr; ((*last != 0) && (*last!= '\n')); last++) {
X	    /* Null loop body. */
X	}
X	if ((syntaxPtr - first) > 60) {
X	    first = syntaxPtr - 60;
X	}
X	if ((last - first) > 70) {
X	    last = first + 70;
X	}
X	if (last == first) {
X	    sprintf(iPtr->resultSpace, "%s", syntaxMsg);
X	} else {
X	    sprintf(iPtr->resultSpace, "%s: '%.*s => %.*s'", syntaxMsg,
X		    syntaxPtr-first, first, last-syntaxPtr, syntaxPtr);
X	}
X	result = TCL_ERROR;
X	iPtr->result = iPtr->resultSpace;
X    }
X
X    goto done;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_CreateTrace --
X *
X *	Arrange for a procedure to be called to trace command execution.
X *
X * Results:
X *	The return value is a token for the trace, which may be passed
X *	to Tcl_DeleteTrace to eliminate the trace.
X *
X * Side effects:
X *	From now on, proc will be called just before a command procedure
X *	is called to execute a Tcl command.  Calls to proc will have the
X *	following form:
X *
X *	void
X *	proc(clientData, interp, level, command, cmdProc, cmdClientData,
X *		argc, argv)
X *	    ClientData clientData;
X *	    Tcl_Interp *interp;
X *	    int level;
X *	    char *command;
X *	    int (*cmdProc)();
X *	    ClientData cmdClientData;
X *	    int argc;
X *	    char **argv;
X *	{
X *	}
X *
X *	The clientData and interp arguments to proc will be the same
X *	as the corresponding arguments to this procedure.  Level gives
X *	the nesting level of command interpretation for this interpreter
X *	(0 corresponds to top level).  Command gives the ASCII text of
X *	the raw command, cmdProc and cmdClientData give the procedure that
X *	will be called to process the command and the ClientData value it
X *	will receive, and argc and argv give the arguments to the
X *	command, after any argument parsing and substitution.  Proc
X *	does not return a value.
X *
X *----------------------------------------------------------------------
X */
X
XTcl_Trace
XTcl_CreateTrace(interp, level, proc, clientData)
X    Tcl_Interp *interp;		/* Interpreter in which to create the trace. */
X    int level;			/* Only call proc for commands at nesting level
X				 * <= level (1 => top level). */
X    void (*proc)();		/* Procedure to call before executing each
X				 * command. */
X    ClientData clientData;	/* Arbitrary one-word value to pass to proc. */
X{
X    register Trace *tracePtr;
X    register Interp *iPtr = (Interp *) interp;
X
X    tracePtr = (Trace *) ckalloc(sizeof(Trace));
X    tracePtr->level = level;
X    tracePtr->proc = proc;
X    tracePtr->clientData = clientData;
X    tracePtr->nextPtr = iPtr->tracePtr;
X    iPtr->tracePtr = tracePtr;
X
X    return (Tcl_Trace) tracePtr;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DeleteTrace --
X *
X *	Remove a trace.
X *
X * Results:
X *	None.
X *
X * Side effects:
X *	From now on there will be no more calls to the procedure given
X *	in trace.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_DeleteTrace(interp, trace)
X    Tcl_Interp *interp;		/* Interpreter that contains trace. */
X    Tcl_Trace trace;		/* Token for trace (returned previously by
X				 * Tcl_CreateTrace). */
X{
X    register Interp *iPtr = (Interp *) interp;
X    register Trace *tracePtr = (Trace *) trace;
X    register Trace *tracePtr2;
X
X    if (iPtr->tracePtr == tracePtr) {
X	iPtr->tracePtr = tracePtr->nextPtr;
X	ckfree((char *) tracePtr);
X    } else {
X	for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
X		tracePtr2 = tracePtr2->nextPtr) {
X	    if (tracePtr2->nextPtr == tracePtr) {
X		tracePtr2->nextPtr = tracePtr->nextPtr;
X		ckfree((char *) tracePtr);
X		return;
X	    }
X	}
X    }
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_AddErrorInfo --
X *
X *	Add information to a message being accumulated that describes
X *	the current error.
X *
X * Results:
X *	None.
X *
X * Side effects:
X *	The contents of message are added to the "errorInfo" variable.
X *	If Tcl_Eval has been called since the current value of errorInfo
X *	was set, errorInfo is cleared before adding the new message.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_AddErrorInfo(interp, message)
X    Tcl_Interp *interp;		/* Interpreter to which error information
X				 * pertains. */
X    char *message;		/* Message to record. */
X{
X    register Interp *iPtr = (Interp *) interp;
X
X    if (iPtr->errInProgress) {
X	int length;
X	char *buffer, *oldVar;
X
X	oldVar = Tcl_GetVar(interp, "errorInfo", 1);
X	if(!oldVar) oldVar = "";
X	length = strlen(oldVar);
X	buffer = (char *)ckalloc((unsigned) (length + strlen(message) + 1));
X	strcpy(buffer, oldVar);
X	strcpy(buffer+length, message);
X	Tcl_SetVar(interp, "errorInfo", buffer, 1);
X    } else {
X	iPtr->errInProgress = 1;
X	Tcl_SetVar(interp, "errorInfo", message, 1);
X    }
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * TclFindCmd --
X *
X *	Find a particular command in an interpreter.
X *
X * Results:
X *	If the command doesn't exist in the table, or if it is an
X *	ambiguous abbreviation, then NULL is returned.  Otherwise
X *	the return value is a pointer to the command.  Unique
X *	abbreviations are allowed if abbrevOK is non-zero, but
X *	abbreviations take longer to look up (must scan the whole
X *	table twice).
X *
X * Side effects:
X *	If the command is found and is an exact match, it is relinked
X *	at the front of iPtr's command list so it will be found more
X *	quickly in the future.
X *
X *----------------------------------------------------------------------
X */
X
XCommand *
XTclFindCmd(iPtr, cmdName, abbrevOK)
X    Interp *iPtr;		/* Interpreter in which to search. */
X    char *cmdName;		/* Desired command. */
X    int abbrevOK;		/* Non-zero means permit abbreviations.
X				 * Zero means exact matches only. */
X{
X    register Command *prev;
X    register Command *cur;
X    register char c;
X    Command *match;
X    int length;
X
X    /*
X     * First check for an exact match.
X     */
X
X    c = *cmdName;
X    for (prev = NULL, cur = iPtr->commandPtr; cur != NULL;
X	    prev = cur, cur = cur->nextPtr) {
X
X	/*
X	 * Check the first character here before wasting time calling
X	 * strcmp.
X	 */
X
X	if ((cur->name[0] == c) && (strcmp(cur->name, cmdName) == 0)) {
X	    if (prev != NULL) {
X		prev->nextPtr = cur->nextPtr;
X		cur->nextPtr = iPtr->commandPtr;
X		iPtr->commandPtr = cur;
X	    }
X	    return cur;
X	}
X    }
X    if (!abbrevOK) {
X	return NULL;
X    }
X
X    /*
X     * No exact match.  Make a second pass to check for a unique
X     * abbreviation.  Don't bother to pull the matching entry to
X     * the front of the list, since we have to search the whole list
X     * for abbreviations anyway.
X     */
X
X    length = strlen(cmdName);
X    match = NULL;
X    for (prev = NULL, cur = iPtr->commandPtr; cur != NULL;
X	    prev = cur, cur = cur->nextPtr) {
X	if ((cur->name[0] == c) && (strncmp(cur->name, cmdName, length) == 0)) {
X	    if (match != NULL) {
X		return NULL;
X	    }
X	    match = cur;
X	}
X    }
X    return match;
X}
X
END_OF_FILE
if test 32489 -ne `wc -c <'tclBasic.c'`; then
    echo shar: \"'tclBasic.c'\" unpacked with wrong size!
fi
# end of 'tclBasic.c'
fi
echo shar: End of archive 6 \(of 6\).
cp /dev/null ark6isdone
MISSING=""
for I in 1 2 3 4 5 6 ; do
    if test ! -f ark${I}isdone ; then
	MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 6 archives.
    rm -f ark[1-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
-- 
 _--_|\  `-_-' Peter da Silva. +1 713 274 5180. <peter@ficc.uu.net>.
/      \  'U`
\_.--._/ "I've about decided that the net is not the place to do the right
      v   thing. It might violate a charter somewhere ..." -- Spenser Aden


