Initial revision

1 files changed, 2186 insertions, 0 deletions

diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
new file mode 100644
index 0000000..4dc272f
--- /dev/null
+++ b/generic/tclCmdMZ.c
@@ -0,0 +1,2186 @@
+/* 
+ * tclCmdMZ.c --
+ *
+ *	This file contains the top-level command routines for most of
+ *	the Tcl built-in commands whose names begin with the letters
+ *	M to Z.  It contains only commands in the generic core (i.e.
+ *	those that don't depend much upon UNIX facilities).
+ *
+ * Copyright (c) 1987-1993 The Regents of the University of California.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclCmdMZ.c 1.104 97/10/31 13:06:19
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+#include "tclCompile.h"
+
+/*
+ * Structure used to hold information about variable traces:
+ */
+
+typedef struct {
+    int flags;			/* Operations for which Tcl command is
+				 * to be invoked. */
+    char *errMsg;		/* Error message returned from Tcl command,
+				 * or NULL.  Malloc'ed. */
+    int length;			/* Number of non-NULL chars. in command. */
+    char command[4];		/* Space for Tcl command to invoke.  Actual
+				 * size will be as large as necessary to
+				 * hold command.  This field must be the
+				 * last in the structure, so that it can
+				 * be larger than 4 bytes. */
+} TraceVarInfo;
+
+/*
+ * Forward declarations for procedures defined in this file:
+ */
+
+static char *		TraceVarProc _ANSI_ARGS_((ClientData clientData,
+			    Tcl_Interp *interp, char *name1, char *name2,
+			    int flags));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_PwdCmd --
+ *
+ *	This procedure is invoked to process the "pwd" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_PwdCmd(dummy, interp, argc, argv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+    char *dirName;
+
+    if (argc != 1) {
+	Tcl_AppendResult(interp, "wrong # args: should be \"",
+		argv[0], "\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    dirName = TclGetCwd(interp);
+    if (dirName == NULL) {
+	return TCL_ERROR;
+    }
+    Tcl_SetResult(interp, dirName, TCL_VOLATILE);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RegexpCmd --
+ *
+ *	This procedure is invoked to process the "regexp" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_RegexpCmd(dummy, interp, argc, argv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+    int noCase = 0;
+    int indices = 0;
+    Tcl_RegExp regExpr;
+    char **argPtr, *string, *pattern, *start, *end;
+    int match = 0;			/* Initialization needed only to
+					 * prevent compiler warning. */
+    int i;
+    Tcl_DString stringDString, patternDString;
+
+    if (argc < 3) {
+	wrongNumArgs:
+	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		" ?switches? exp string ?matchVar? ?subMatchVar ",
+		"subMatchVar ...?\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+    argPtr = argv+1;
+    argc--;
+    while ((argc > 0) && (argPtr[0][0] == '-')) {
+	if (strcmp(argPtr[0], "-indices") == 0) {
+	    indices = 1;
+	} else if (strcmp(argPtr[0], "-nocase") == 0) {
+	    noCase = 1;
+	} else if (strcmp(argPtr[0], "--") == 0) {
+	    argPtr++;
+	    argc--;
+	    break;
+	} else {
+	    Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
+		    "\": must be -indices, -nocase, or --", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	argPtr++;
+	argc--;
+    }
+    if (argc < 2) {
+	goto wrongNumArgs;
+    }
+
+    /*
+     * Convert the string and pattern to lower case, if desired, and
+     * perform the matching operation.
+     */
+
+    if (noCase) {
+	register char *p;
+
+	Tcl_DStringInit(&patternDString);
+	Tcl_DStringAppend(&patternDString, argPtr[0], -1);
+	pattern = Tcl_DStringValue(&patternDString);
+	for (p = pattern; *p != 0; p++) {
+	    if (isupper(UCHAR(*p))) {
+		*p = (char)tolower(UCHAR(*p));
+	    }
+	}
+	Tcl_DStringInit(&stringDString);
+	Tcl_DStringAppend(&stringDString, argPtr[1], -1);
+	string = Tcl_DStringValue(&stringDString);
+	for (p = string; *p != 0; p++) {
+	    if (isupper(UCHAR(*p))) {
+		*p = (char)tolower(UCHAR(*p));
+	    }
+	}
+    } else {
+	pattern = argPtr[0];
+	string = argPtr[1];
+    }
+    regExpr = Tcl_RegExpCompile(interp, pattern);
+    if (regExpr != NULL) {
+	match = Tcl_RegExpExec(interp, regExpr, string, string);
+    }
+    if (noCase) {
+	Tcl_DStringFree(&stringDString);
+	Tcl_DStringFree(&patternDString);
+    }
+    if (regExpr == NULL) {
+	return TCL_ERROR;
+    }
+    if (match < 0) {
+	return TCL_ERROR;
+    }
+    if (!match) {
+	Tcl_SetResult(interp, "0", TCL_STATIC);
+	return TCL_OK;
+    }
+
+    /*
+     * If additional variable names have been specified, return
+     * index information in those variables.
+     */
+
+    argc -= 2;
+    for (i = 0; i < argc; i++) {
+	char *result, info[50];
+
+	Tcl_RegExpRange(regExpr, i, &start, &end);
+	if (start == NULL) {
+	    if (indices) {
+		result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
+	    } else {
+		result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
+	    }
+	} else {
+	    if (indices) {
+		sprintf(info, "%d %d", (int)(start - string),
+			(int)(end - string - 1));
+		result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
+	    } else {
+		char savedChar, *first, *last;
+
+		first = argPtr[1] + (start - string);
+		last = argPtr[1] + (end - string);
+		if (first == last) { /* don't modify argument */
+		    result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
+		} else {
+		    savedChar = *last;
+		    *last = 0;
+		    result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
+		    *last = savedChar;
+		}
+	    }
+	}
+	if (result == NULL) {
+	    Tcl_AppendResult(interp, "couldn't set variable \"",
+		    argPtr[i+2], "\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+    }
+    Tcl_SetResult(interp, "1", TCL_STATIC);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RegsubCmd --
+ *
+ *	This procedure is invoked to process the "regsub" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_RegsubCmd(dummy, interp, argc, argv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+    int noCase = 0, all = 0;
+    Tcl_RegExp regExpr;
+    char *string, *pattern, *p, *firstChar, **argPtr;
+    int match, code, numMatches;
+    char *start, *end, *subStart, *subEnd;
+    register char *src, c;
+    Tcl_DString stringDString, patternDString, resultDString;
+
+    if (argc < 5) {
+	wrongNumArgs:
+	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		" ?switches? exp string subSpec varName\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+    argPtr = argv+1;
+    argc--;
+    while (argPtr[0][0] == '-') {
+	if (strcmp(argPtr[0], "-nocase") == 0) {
+	    noCase = 1;
+	} else if (strcmp(argPtr[0], "-all") == 0) {
+	    all = 1;
+	} else if (strcmp(argPtr[0], "--") == 0) {
+	    argPtr++;
+	    argc--;
+	    break;
+	} else {
+	    Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
+		    "\": must be -all, -nocase, or --", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	argPtr++;
+	argc--;
+    }
+    if (argc != 4) {
+	goto wrongNumArgs;
+    }
+
+    /*
+     * Convert the string and pattern to lower case, if desired.
+     */
+
+    if (noCase) {
+	Tcl_DStringInit(&patternDString);
+	Tcl_DStringAppend(&patternDString, argPtr[0], -1);
+	pattern = Tcl_DStringValue(&patternDString);
+	for (p = pattern; *p != 0; p++) {
+	    if (isupper(UCHAR(*p))) {
+		*p = (char)tolower(UCHAR(*p));
+	    }
+	}
+	Tcl_DStringInit(&stringDString);
+	Tcl_DStringAppend(&stringDString, argPtr[1], -1);
+	string = Tcl_DStringValue(&stringDString);
+	for (p = string; *p != 0; p++) {
+	    if (isupper(UCHAR(*p))) {
+		*p = (char)tolower(UCHAR(*p));
+	    }
+	}
+    } else {
+	pattern = argPtr[0];
+	string = argPtr[1];
+    }
+    Tcl_DStringInit(&resultDString);
+    regExpr = Tcl_RegExpCompile(interp, pattern);
+    if (regExpr == NULL) {
+	code = TCL_ERROR;
+	goto done;
+    }
+
+    /*
+     * The following loop is to handle multiple matches within the
+     * same source string;  each iteration handles one match and its
+     * corresponding substitution.  If "-all" hasn't been specified
+     * then the loop body only gets executed once.
+     */
+
+    numMatches = 0;
+    for (p = string; *p != 0; ) {
+	match = Tcl_RegExpExec(interp, regExpr, p, string);
+	if (match < 0) {
+	    code = TCL_ERROR;
+	    goto done;
+	}
+	if (!match) {
+	    break;
+	}
+	numMatches += 1;
+
+	/*
+	 * Copy the portion of the source string before the match to the
+	 * result variable.
+	 */
+
+	Tcl_RegExpRange(regExpr, 0, &start, &end);
+	Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), start - p);
+    
+	/*
+	 * Append the subSpec argument to the variable, making appropriate
+	 * substitutions.  This code is a bit hairy because of the backslash
+	 * conventions and because the code saves up ranges of characters in
+	 * subSpec to reduce the number of calls to Tcl_SetVar.
+	 */
+    
+	for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
+	    int index;
+    
+	    if (c == '&') {
+		index = 0;
+	    } else if (c == '\\') {
+		c = src[1];
+		if ((c >= '0') && (c <= '9')) {
+		    index = c - '0';
+		} else if ((c == '\\') || (c == '&')) {
+		    *src = c;
+		    src[1] = 0;
+		    Tcl_DStringAppend(&resultDString, firstChar, -1);
+		    *src = '\\';
+		    src[1] = c;
+		    firstChar = src+2;
+		    src++;
+		    continue;
+		} else {
+		    continue;
+		}
+	    } else {
+		continue;
+	    }
+	    if (firstChar != src) {
+		c = *src;
+		*src = 0;
+		Tcl_DStringAppend(&resultDString, firstChar, -1);
+		*src = c;
+	    }
+	    Tcl_RegExpRange(regExpr, index, &subStart, &subEnd);
+	    if ((subStart != NULL) && (subEnd != NULL)) {
+		char *first, *last, saved;
+    
+		first = argPtr[1] + (subStart - string);
+		last = argPtr[1] + (subEnd - string);
+		saved = *last;
+		*last = 0;
+		Tcl_DStringAppend(&resultDString, first, -1);
+		*last = saved;
+	    }
+	    if (*src == '\\') {
+		src++;
+	    }
+	    firstChar = src+1;
+	}
+	if (firstChar != src) {
+	    Tcl_DStringAppend(&resultDString, firstChar, -1);
+	}
+	if (end == p) {
+
+	    /*
+	     * Always consume at least one character of the input string
+	     * in order to prevent infinite loops.
+	     */
+
+	    Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), 1);
+	    p = end + 1;
+	} else {
+	    p = end;
+	}
+	if (!all) {
+	    break;
+	}
+    }
+
+    /*
+     * Copy the portion of the source string after the last match to the
+     * result variable.
+     */
+
+    if ((*p != 0) || (numMatches == 0)) {
+	Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), -1);
+    }
+    if (Tcl_SetVar(interp, argPtr[3], Tcl_DStringValue(&resultDString), 0)
+	     == NULL) {
+	Tcl_AppendResult(interp,
+		"couldn't set variable \"", argPtr[3], "\"",
+		(char *) NULL);
+	code = TCL_ERROR;
+    } else {
+	char buf[40];
+	
+	TclFormatInt(buf, numMatches);
+	Tcl_SetResult(interp, buf, TCL_VOLATILE);
+	code = TCL_OK;
+    }
+
+    done:
+    if (noCase) {
+	Tcl_DStringFree(&stringDString);
+	Tcl_DStringFree(&patternDString);
+    }
+    Tcl_DStringFree(&resultDString);
+    return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RenameObjCmd --
+ *
+ *	This procedure is invoked to process the "rename" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl object result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_RenameObjCmd(dummy, interp, objc, objv)
+    ClientData dummy;		/* Arbitrary value passed to the command. */
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument objects. */
+{
+    char *oldName, *newName;
+    
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
+	return TCL_ERROR;
+    }
+
+    oldName = Tcl_GetStringFromObj(objv[1], (int *) NULL);
+    newName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+    return TclRenameCommand(interp, oldName, newName);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ReturnObjCmd --
+ *
+ *	This object-based procedure is invoked to process the "return" Tcl
+ *	command. See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl object result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_ReturnObjCmd(dummy, interp, objc, objv)
+    ClientData dummy;		/* Not used. */
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument objects. */
+{
+    Interp *iPtr = (Interp *) interp;
+    int optionLen, argLen, code, result;
+
+    if (iPtr->errorInfo != NULL) {
+	ckfree(iPtr->errorInfo);
+	iPtr->errorInfo = NULL;
+    }
+    if (iPtr->errorCode != NULL) {
+	ckfree(iPtr->errorCode);
+	iPtr->errorCode = NULL;
+    }
+    code = TCL_OK;
+
+   /*
+    * THIS FAILS IF AN OBJECT CONTAINS AN EMBEDDED NULL.
+    */
+    
+    for (objv++, objc--;  objc > 1;  objv += 2, objc -= 2) {
+	char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
+	char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
+    	
+	if (strcmp(option, "-code") == 0) {
+	    register int c = arg[0];
+	    if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
+		code = TCL_OK;
+	    } else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
+		code = TCL_ERROR;
+	    } else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
+		code = TCL_RETURN;
+	    } else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
+		code = TCL_BREAK;
+	    } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
+		code = TCL_CONTINUE;
+	    } else {
+		result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
+		        &code);
+		if (result != TCL_OK) {
+		    Tcl_ResetResult(interp);
+		    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+			    "bad completion code \"",
+			    Tcl_GetStringFromObj(objv[1], (int *) NULL),
+			    "\": must be ok, error, return, break, ",
+			    "continue, or an integer", (char *) NULL);
+		    return result;
+		}
+	    }
+	} else if (strcmp(option, "-errorinfo") == 0) {
+	    iPtr->errorInfo =
+		(char *) ckalloc((unsigned) (strlen(arg) + 1));
+	    strcpy(iPtr->errorInfo, arg);
+	} else if (strcmp(option, "-errorcode") == 0) {
+	    iPtr->errorCode =
+		(char *) ckalloc((unsigned) (strlen(arg) + 1));
+	    strcpy(iPtr->errorCode, arg);
+	} else {
+	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+		    "bad option \"", option,
+		    "\": must be -code, -errorcode, or -errorinfo",
+		    (char *) NULL);
+	    return TCL_ERROR;
+	}
+    }
+    
+    if (objc == 1) {
+	/*
+	 * Set the interpreter's object result. An inline version of
+	 * Tcl_SetObjResult.
+	 */
+
+	Tcl_SetObjResult(interp, objv[0]);
+    }
+    iPtr->returnCode = code;
+    return TCL_RETURN;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ScanCmd --
+ *
+ *	This procedure is invoked to process the "scan" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_ScanCmd(dummy, interp, argc, argv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+#   define MAX_FIELDS 20
+    typedef struct {
+	char fmt;			/* Format for field. */
+	int size;			/* How many bytes to allow for
+					 * field. */
+	char *location;			/* Where field will be stored. */
+    } Field;
+    Field fields[MAX_FIELDS];		/* Info about all the fields in the
+					 * format string. */
+    register Field *curField;
+    int numFields = 0;			/* Number of fields actually
+					 * specified. */
+    int suppress;			/* Current field is assignment-
+					 * suppressed. */
+    int totalSize = 0;			/* Number of bytes needed to store
+					 * all results combined. */
+    char *results;			/* Where scanned output goes.
+					 * Malloced; NULL means not allocated
+					 * yet. */
+    int numScanned;			/* sscanf's result. */
+    register char *fmt;
+    int i, widthSpecified, length, code;
+    char buf[40];
+
+    /*
+     * The variables below are used to hold a copy of the format
+     * string, so that we can replace format specifiers like "%f"
+     * and "%F" with specifiers like "%lf"
+     */
+
+#   define STATIC_SIZE 5
+    char copyBuf[STATIC_SIZE], *fmtCopy;
+    register char *dst;
+
+    if (argc < 3) {
+	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		" string format ?varName varName ...?\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * This procedure operates in four stages:
+     * 1. Scan the format string, collecting information about each field.
+     * 2. Allocate an array to hold all of the scanned fields.
+     * 3. Call sscanf to do all the dirty work, and have it store the
+     *    parsed fields in the array.
+     * 4. Pick off the fields from the array and assign them to variables.
+     */
+
+    code = TCL_OK;
+    results = NULL;
+    length = strlen(argv[2]) * 2 + 1;
+    if (length < STATIC_SIZE) {
+	fmtCopy = copyBuf;
+    } else {
+	fmtCopy = (char *) ckalloc((unsigned) length);
+    }
+    dst = fmtCopy;
+    for (fmt = argv[2]; *fmt != 0; fmt++) {
+	*dst = *fmt;
+	dst++;
+	if (*fmt != '%') {
+	    continue;
+	}
+	fmt++;
+	if (*fmt == '%') {
+	    *dst = *fmt;
+	    dst++;
+	    continue;
+	}
+	if (*fmt == '*') {
+	    suppress = 1;
+	    *dst = *fmt;
+	    dst++;
+	    fmt++;
+	} else {
+	    suppress = 0;
+	}
+	widthSpecified = 0;
+	while (isdigit(UCHAR(*fmt))) {
+	    widthSpecified = 1;
+	    *dst = *fmt;
+	    dst++;
+	    fmt++;
+	}
+	if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) {
+	    fmt++;
+	}
+	*dst = *fmt;
+	dst++;
+	if (suppress) {
+	    continue;
+	}
+	if (numFields == MAX_FIELDS) {
+	    Tcl_SetResult(interp, "too many fields to scan", TCL_STATIC);
+	    code = TCL_ERROR;
+	    goto done;
+	}
+	curField = &fields[numFields];
+	numFields++;
+	switch (*fmt) {
+	    case 'd':
+	    case 'i':
+	    case 'o':
+	    case 'x':
+		curField->fmt = 'd';
+		curField->size = sizeof(int);
+		break;
+
+	    case 'u':
+		curField->fmt = 'u';
+		curField->size = sizeof(int);
+		break;
+
+	    case 's':
+		curField->fmt = 's';
+		curField->size = strlen(argv[1]) + 1;
+		break;
+
+	    case 'c':
+                if (widthSpecified) {
+		    Tcl_SetResult(interp,
+		            "field width may not be specified in %c conversion",
+			    TCL_STATIC);
+		    code = TCL_ERROR;
+		    goto done;
+                }
+		curField->fmt = 'c';
+		curField->size = sizeof(int);
+		break;
+
+	    case 'e':
+	    case 'f':
+	    case 'g':
+		dst[-1] = 'l';
+		dst[0] = 'f';
+		dst++;
+		curField->fmt = 'f';
+		curField->size = sizeof(double);
+		break;
+
+	    case '[':
+		curField->fmt = 's';
+		curField->size = strlen(argv[1]) + 1;
+		do {
+		    fmt++;
+		    if (*fmt == 0) {
+			Tcl_SetResult(interp,
+			        "unmatched [ in format string", TCL_STATIC);
+			code = TCL_ERROR;
+			goto done;
+		    }
+		    *dst = *fmt;
+		    dst++;
+		} while (*fmt != ']');
+		break;
+
+	    default:
+		{
+		    char buf[50];
+
+		    sprintf(buf, "bad scan conversion character \"%c\"", *fmt);
+		    Tcl_SetResult(interp, buf, TCL_VOLATILE);
+		    code = TCL_ERROR;
+		    goto done;
+		}
+	}
+	curField->size = TCL_ALIGN(curField->size);
+	totalSize += curField->size;
+    }
+    *dst = 0;
+
+    if (numFields != (argc-3)) {
+	Tcl_SetResult(interp,
+		"different numbers of variable names and field specifiers",
+		TCL_STATIC);
+	code = TCL_ERROR;
+	goto done;
+    }
+
+    /*
+     * Step 2:
+     */
+
+    results = (char *) ckalloc((unsigned) totalSize);
+    for (i = 0, totalSize = 0, curField = fields;
+	    i < numFields; i++, curField++) {
+	curField->location = results + totalSize;
+	totalSize += curField->size;
+    }
+
+    /*
+     * Fill in the remaining fields with NULL;  the only purpose of
+     * this is to keep some memory analyzers, like Purify, from
+     * complaining.
+     */
+
+    for ( ; i < MAX_FIELDS; i++, curField++) {
+	curField->location = NULL;
+    }
+
+    /*
+     * Step 3:
+     */
+
+    numScanned = sscanf(argv[1], fmtCopy,
+	    fields[0].location, fields[1].location, fields[2].location,
+	    fields[3].location, fields[4].location, fields[5].location,
+	    fields[6].location, fields[7].location, fields[8].location,
+	    fields[9].location, fields[10].location, fields[11].location,
+	    fields[12].location, fields[13].location, fields[14].location,
+	    fields[15].location, fields[16].location, fields[17].location,
+	    fields[18].location, fields[19].location);
+
+    /*
+     * Step 4:
+     */
+
+    if (numScanned < numFields) {
+	numFields = numScanned;
+    }
+    for (i = 0, curField = fields; i < numFields; i++, curField++) {
+	switch (curField->fmt) {
+	    char string[TCL_DOUBLE_SPACE];
+
+	    case 'd':
+		TclFormatInt(string, *((int *) curField->location));
+		if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
+		    storeError:
+		    Tcl_AppendResult(interp,
+			    "couldn't set variable \"", argv[i+3], "\"",
+			    (char *) NULL);
+		    code = TCL_ERROR;
+		    goto done;
+		}
+		break;
+
+	    case 'u':
+		sprintf(string, "%u", *((int *) curField->location));
+		if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
+		    goto storeError;
+		}
+		break;
+
+	    case 'c':
+		TclFormatInt(string, *((char *) curField->location) & 0xff);
+		if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
+		    goto storeError;
+		}
+		break;
+
+	    case 's':
+		if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
+			== NULL) {
+		    goto storeError;
+		}
+		break;
+
+	    case 'f':
+		Tcl_PrintDouble((Tcl_Interp *) NULL,
+			*((double *) curField->location), string);
+		if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
+		    goto storeError;
+		}
+		break;
+	}
+    }
+    TclFormatInt(buf, numScanned);
+    Tcl_SetResult(interp, buf, TCL_VOLATILE);
+    done:
+    if (results != NULL) {
+	ckfree(results);
+    }
+    if (fmtCopy != copyBuf) {
+	ckfree(fmtCopy);
+    }
+    return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SourceObjCmd --
+ *
+ *	This procedure is invoked to process the "source" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl object result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_SourceObjCmd(dummy, interp, objc, objv)
+    ClientData dummy;		/* Not used. */
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument objects. */
+{
+    char *bytes;
+    int result;
+    
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "fileName");
+	return TCL_ERROR;
+    }
+
+    /*
+     * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL.
+     */
+
+    bytes = Tcl_GetStringFromObj(objv[1], (int *) NULL);
+    result = Tcl_EvalFile(interp, bytes);
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SplitObjCmd --
+ *
+ *	This procedure is invoked to process the "split" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_SplitObjCmd(dummy, interp, objc, objv)
+    ClientData dummy;		/* Not used. */
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument objects. */
+{
+    register char *p, *p2;
+    char *splitChars, *string, *elementStart;
+    int splitCharLen, stringLen, i, j;
+    Tcl_Obj *listPtr;
+
+    if (objc == 2) {
+	splitChars = " \n\t\r";
+	splitCharLen = 4;
+    } else if (objc == 3) {
+	splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
+    } else {
+	Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
+	return TCL_ERROR;
+    }
+
+    string = Tcl_GetStringFromObj(objv[1], &stringLen);
+    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+    
+    /*
+     * Handle the special case of splitting on every character.
+     */
+
+    if (splitCharLen == 0) {
+	for (i = 0, p = string;  i < stringLen;  i++, p++) {
+	    Tcl_ListObjAppendElement(interp, listPtr,
+                    Tcl_NewStringObj(p, 1));
+	}
+    } else {
+	/*
+	 * Normal case: split on any of a given set of characters.
+	 * Discard instances of the split characters.
+	 */
+
+	for (i = 0, p = elementStart = string;  i < stringLen;  i++, p++) {
+	    for (j = 0, p2 = splitChars;  j < splitCharLen;  j++, p2++) {
+		if (*p2 == *p) {
+		    Tcl_ListObjAppendElement(interp, listPtr,
+                            Tcl_NewStringObj(elementStart, (p-elementStart)));
+		    elementStart = p+1;
+		    break;
+		}
+	    }
+	}
+	if (p != string) {
+	    int remainingChars = stringLen - (elementStart-string);
+	    Tcl_ListObjAppendElement(interp, listPtr,
+                    Tcl_NewStringObj(elementStart, remainingChars));
+	}
+    }
+
+    Tcl_SetObjResult(interp, listPtr);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_StringObjCmd --
+ *
+ *	This procedure is invoked to process the "string" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_StringObjCmd(dummy, interp, objc, objv)
+    ClientData dummy;		/* Not used. */
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument objects. */
+{
+    int index, left, right;
+    Tcl_Obj *resultPtr;
+    char *string1, *string2;
+    int length1, length2;
+    static char *options[] = {
+	"compare",	"first",	"index",	"last",
+	"length",	"match",	"range",	"tolower",
+	"toupper",	"trim",		"trimleft",	"trimright",
+	"wordend",	"wordstart",	NULL
+    };
+    enum options {
+	STR_COMPARE,	STR_FIRST,	STR_INDEX,	STR_LAST,
+	STR_LENGTH,	STR_MATCH,	STR_RANGE,	STR_TOLOWER,
+	STR_TOUPPER,	STR_TRIM,	STR_TRIMLEFT,	STR_TRIMRIGHT,
+	STR_WORDEND,	STR_WORDSTART
+    };	  
+	    
+    if (objc < 2) {
+        Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
+	return TCL_ERROR;
+    }
+    
+    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
+	    &index) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    resultPtr = Tcl_GetObjResult(interp);
+    switch ((enum options) index) {
+	case STR_COMPARE: {
+	    int match, length;
+
+	    if (objc != 4) {
+	        Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
+		return TCL_ERROR;
+	    }
+
+	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
+	    string2 = Tcl_GetStringFromObj(objv[3], &length2);
+
+	    length = (length1 < length2) ? length1 : length2;
+	    match = memcmp(string1, string2, (unsigned) length);
+	    if (match == 0) {
+	        match = length1 - length2;
+	    }
+	    Tcl_SetIntObj(resultPtr, (match > 0) ? 1 : (match < 0) ? -1 : 0);
+	    break;
+	}
+	case STR_FIRST: {
+	    register char *p, *end;
+	    int match;
+
+	    if (objc != 4) {
+	        badFirstLastArgs:
+	        Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
+		return TCL_ERROR;
+	    }
+
+	    match = -1;
+	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
+	    string2 = Tcl_GetStringFromObj(objv[3], &length2);
+	    if (length1 > 0) {
+		end = string2 + length2 - length1 + 1;
+		for (p = string2;  p < end;  p++) {
+		  /*
+		   * Scan forward to find the first character.
+		   */
+		    
+		  p = memchr(p, *string1, (unsigned) (end - p));
+		  if (p == NULL) {
+		      break;
+		  }
+		  if (memcmp(string1, p, (unsigned) length1) == 0) {
+		      match = p - string2;
+		      break;
+		  }
+		}
+	    }
+	    Tcl_SetIntObj(resultPtr, match);
+	    break;
+	}
+	case STR_INDEX: {
+	    int index;
+
+	    if (objc != 4) {
+	        Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
+		return TCL_ERROR;
+	    }
+
+	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
+	    if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    if ((index >= 0) && (index < length1)) {
+	        Tcl_SetStringObj(resultPtr, string1 + index, 1);
+	    }
+	    break;
+	}
+	case STR_LAST: {
+	    register char *p;
+	    int match;
+
+	    if (objc != 4) {
+	        goto badFirstLastArgs;
+	    }
+
+	    match = -1;
+	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
+	    string2 = Tcl_GetStringFromObj(objv[3], &length2);
+	    if (length1 > 0) {
+		for (p = string2 + length2 - length1;  p >= string2;  p--) {
+		    /*
+		     * Scan backwards to find the first character.
+		     */
+		    
+		    while ((p != string2) && (*p != *string1)) {
+			p--;
+		    }
+		    if (memcmp(string1, p, (unsigned) length1) == 0) {
+			match = p - string2;
+			break;
+		    }
+		}
+	    }
+	    Tcl_SetIntObj(resultPtr, match);
+	    break;
+	}
+	case STR_LENGTH: {
+	    if (objc != 3) {
+	        Tcl_WrongNumArgs(interp, 2, objv, "string");
+		return TCL_ERROR;
+	    }
+
+	    (void) Tcl_GetStringFromObj(objv[2], &length1);
+	    Tcl_SetIntObj(resultPtr, length1);
+	    break;
+	}
+	case STR_MATCH: {
+	    if (objc != 4) {
+	        Tcl_WrongNumArgs(interp, 2, objv, "pattern string");
+		return TCL_ERROR;
+	    }
+
+	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
+	    string2 = Tcl_GetStringFromObj(objv[3], &length2);
+	    Tcl_SetBooleanObj(resultPtr, Tcl_StringMatch(string2, string1));
+	    break;
+	}
+	case STR_RANGE: {
+	    int first, last;
+
+	    if (objc != 5) {
+	        Tcl_WrongNumArgs(interp, 2, objv, "string first last");
+		return TCL_ERROR;
+	    }
+
+	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
+	    if (TclGetIntForIndex(interp, objv[3], length1 - 1,
+		    &first) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    if (TclGetIntForIndex(interp, objv[4], length1 - 1,
+		    &last) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    if (first < 0) {
+		first = 0;
+	    }
+	    if (last >= length1 - 1) {
+		last = length1 - 1;
+	    }
+	    if (last >= first) {
+	        Tcl_SetStringObj(resultPtr, string1 + first, last - first + 1);
+	    }
+	    break;
+	}
+	case STR_TOLOWER: {
+	    register char *p, *end;
+
+	    if (objc != 3) {
+	        Tcl_WrongNumArgs(interp, 2, objv, "string");
+		return TCL_ERROR;
+	    }
+
+	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
+
+	    /*
+	     * Since I know resultPtr is not a shared object, I can reach
+	     * in and diddle the bytes in its string rep to convert them in
+	     * place to lower case.
+	     */
+
+	    Tcl_SetStringObj(resultPtr, string1, length1);
+	    string1 = Tcl_GetStringFromObj(resultPtr, &length1);
+	    end = string1 + length1;
+	    for (p = string1; p < end; p++) {
+		if (isupper(UCHAR(*p))) {
+		    *p = (char) tolower(UCHAR(*p));
+		}
+	    }
+	    break;
+	}
+	case STR_TOUPPER: {
+	    register char *p, *end;
+
+	    if (objc != 3) {
+	        Tcl_WrongNumArgs(interp, 2, objv, "string");
+		return TCL_ERROR;
+	    }
+
+	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
+
+	    /*
+	     * Since I know resultPtr is not a shared object, I can reach
+	     * in and diddle the bytes in its string rep to convert them in
+	     * place to upper case.
+	     */
+
+	    Tcl_SetStringObj(resultPtr, string1, length1);
+	    string1 = Tcl_GetStringFromObj(resultPtr, &length1);
+	    end = string1 + length1;
+	    for (p = string1; p < end; p++) {
+		if (islower(UCHAR(*p))) {
+		    *p = (char) toupper(UCHAR(*p));
+		}
+	    }
+	    break;
+	}
+	case STR_TRIM: {
+	    char ch;
+	    register char *p, *end;
+	    char *check, *checkEnd;
+
+	    left = 1;
+	    right = 1;
+
+	    trim:
+	    if (objc == 4) {
+		string2 = Tcl_GetStringFromObj(objv[3], &length2);
+	    } else if (objc == 3) {
+		string2 = " \t\n\r";
+		length2 = strlen(string2);
+	    } else {
+	        Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
+		return TCL_ERROR;
+	    }
+	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
+	    checkEnd = string2 + length2;
+
+	    if (left) {
+		end = string1 + length1;
+		for (p = string1; p < end; p++) {
+		    ch = *p;
+		    for (check = string2; ; check++) {
+			if (check >= checkEnd) {
+			    p = end;
+			    break;
+			}
+			if (ch == *check) {
+			    length1--;
+			    string1++;
+			    break;
+			}
+		    }
+		}
+	    }
+	    if (right) {
+	        end = string1;
+		for (p = string1 + length1; p > end; ) {
+		    p--;
+		    ch = *p;
+		    for (check = string2; ; check++) {
+		        if (check >= checkEnd) {
+			    p = end;
+			    break;
+			}
+			if (ch == *check) {
+			    length1--;
+			    break;
+			}
+		    }
+		}
+	    }
+	    Tcl_SetStringObj(resultPtr, string1, length1);
+	    break;
+	}
+	case STR_TRIMLEFT: {
+	    left = 1;
+	    right = 0;
+	    goto trim;
+	}
+	case STR_TRIMRIGHT: {
+	    left = 0;
+	    right = 1;
+	    goto trim;
+	}
+	case STR_WORDEND: {
+	    int cur, c;
+	    
+	    if (objc != 4) {
+	        Tcl_WrongNumArgs(interp, 2, objv, "string index");
+		return TCL_ERROR;
+	    }
+
+	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
+	    if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
+	        return TCL_ERROR;
+	    }
+	    if (index < 0) {
+		index = 0;
+	    }
+	    cur = length1;
+	    if (index < length1) {
+		for (cur = index; cur < length1; cur++) {
+		    c = UCHAR(string1[cur]);
+		    if (!isalnum(c) && (c != '_')) {
+			break;
+		    }
+		}
+		if (cur == index) {
+		    cur = index + 1;
+		}
+	    }
+	    Tcl_SetIntObj(resultPtr, cur);
+	    break;
+	}
+	case STR_WORDSTART: {
+	    int cur, c;
+	    
+	    if (objc != 4) {
+	        Tcl_WrongNumArgs(interp, 2, objv, "string index");
+		return TCL_ERROR;
+	    }
+
+	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
+	    if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    if (index >= length1) {
+		index = length1 - 1;
+	    }
+	    cur = 0;
+	    if (index > 0) {
+	        for (cur = index; cur >= 0; cur--) {
+		    c = UCHAR(string1[cur]);
+		    if (!isalnum(c) && (c != '_')) {
+			break;
+		    }
+		}
+		if (cur != index) {
+		    cur += 1;
+		}
+	    }
+	    Tcl_SetIntObj(resultPtr, cur);
+	    break;
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SubstCmd --
+ *
+ *	This procedure is invoked to process the "subst" Tcl command.
+ *	See the user documentation for details on what it does.  This
+ *	command is an almost direct copy of an implementation by
+ *	Andrew Payne.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_SubstCmd(dummy, interp, argc, argv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_DString result;
+    char *p, *old, *value;
+    int code, count, doVars, doCmds, doBackslashes, i;
+    size_t length;
+    char c;
+
+    /*
+     * Parse command-line options.
+     */
+
+    doVars = doCmds = doBackslashes = 1;
+    for (i = 1; i < (argc-1); i++) {
+	p = argv[i];
+	if (*p != '-') {
+	    break;
+	}
+	length = strlen(p);
+	if (length < 4) {
+	    badSwitch:
+	    Tcl_AppendResult(interp, "bad switch \"", p,
+		    "\": must be -nobackslashes, -nocommands, ",
+		    "or -novariables", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) {
+	    doBackslashes = 0;
+	} else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) {
+	    doCmds = 0;
+	} else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) {
+	    doVars = 0;
+	} else {
+	    goto badSwitch;
+	}
+    }
+    if (i != (argc-1)) {
+	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		" ?-nobackslashes? ?-nocommands? ?-novariables? string\"",
+		(char *) NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Scan through the string one character at a time, performing
+     * command, variable, and backslash substitutions.
+     */
+
+    Tcl_DStringInit(&result);
+    old = p = argv[i];
+    while (*p != 0) {
+	switch (*p) {
+	    case '\\':
+		if (doBackslashes) {
+		    if (p != old) {
+			Tcl_DStringAppend(&result, old, p-old);
+		    }
+		    c = Tcl_Backslash(p, &count);
+		    Tcl_DStringAppend(&result, &c, 1);
+		    p += count;
+		    old = p;
+		} else {
+		    p++;
+		}
+		break;
+
+	    case '$':
+		if (doVars) {
+		    if (p != old) {
+			Tcl_DStringAppend(&result, old, p-old);
+		    }
+		    value = Tcl_ParseVar(interp, p, &p);
+		    if (value == NULL) {
+			Tcl_DStringFree(&result);
+			return TCL_ERROR;
+		    }
+		    Tcl_DStringAppend(&result, value, -1);
+		    old = p;
+		} else {
+		    p++;
+		}
+		break;
+
+	    case '[':
+		if (doCmds) {
+		    if (p != old) {
+			Tcl_DStringAppend(&result, old, p-old);
+		    }
+		    iPtr->evalFlags = TCL_BRACKET_TERM;
+		    code = Tcl_Eval(interp, p+1);
+		    if (code == TCL_ERROR) {
+			Tcl_DStringFree(&result);
+			return code;
+		    }
+		    old = p = (p+1 + iPtr->termOffset+1);
+		    Tcl_DStringAppend(&result, iPtr->result, -1);
+		    Tcl_ResetResult(interp);
+		} else {
+		    p++;
+		}
+		break;
+
+	    default:
+		p++;
+		break;
+	}
+    }
+    if (p != old) {
+	Tcl_DStringAppend(&result, old, p-old);
+    }
+    Tcl_DStringResult(interp, &result);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SwitchObjCmd --
+ *
+ *	This object-based procedure is invoked to process the "switch" Tcl
+ *	command. See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl object result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_SwitchObjCmd(dummy, interp, objc, objv)
+    ClientData dummy;		/* Not used. */
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument objects. */
+{
+#define EXACT	0
+#define GLOB	1
+#define REGEXP	2
+    int switchObjc, index;
+    Tcl_Obj *CONST *switchObjv;
+    Tcl_Obj *patternObj, *bodyObj;
+    char *string, *pattern, *body;
+    int splitObjs, length, patternLen, i, code, mode, matched, bodyIdx;
+    static char *switches[] =
+	    {"-exact", "-glob", "-regexp", "--", (char *) NULL};
+
+    switchObjc = objc-1;
+    switchObjv = objv+1;
+    mode = EXACT;
+
+    while (switchObjc > 0) {
+	string = Tcl_GetStringFromObj(switchObjv[0], &length);
+	if (*string != '-') {
+	    break;
+	}
+	if (Tcl_GetIndexFromObj(interp, switchObjv[0], switches,
+		"option", 0, &index) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+	switch (index) {
+	    case 0:			/* -exact */
+		mode = EXACT;
+		break;
+	    case 1:			/* -glob */
+		mode = GLOB;
+		break;
+	    case 2:			/* -regexp */
+		mode = REGEXP;
+		break;
+	    case 3:			/* -- */
+		switchObjc--;
+		switchObjv++;
+		goto doneWithSwitches;
+	}
+	switchObjc--;
+	switchObjv++;
+    }
+
+    doneWithSwitches:
+    if (switchObjc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv,
+		"?switches? string pattern body ... ?default body?");
+	return TCL_ERROR;
+    }
+    
+    string = Tcl_GetStringFromObj(switchObjv[0], &length);
+    switchObjc--;
+    switchObjv++;
+
+    /*
+     * If all of the pattern/command pairs are lumped into a single
+     * argument, split them out again.
+     */
+
+    splitObjs = 0;
+    if (switchObjc == 1) {
+	code = Tcl_ListObjLength(interp, switchObjv[0], &switchObjc);
+	if (code != TCL_OK) {
+	    return code;
+	}
+	splitObjs = 1;
+    }
+
+    for (i = 0;  i < switchObjc;  i += 2) {
+	if (i == (switchObjc-1)) {
+	    Tcl_ResetResult(interp);
+	    Tcl_AppendToObj(Tcl_GetObjResult(interp),
+	            "extra switch pattern with no body", -1);
+	    code = TCL_ERROR;
+	    goto done;
+	}
+
+	/*
+	 * See if the pattern matches the string.
+	 */
+
+	if (splitObjs) {
+	    code = Tcl_ListObjIndex(interp, switchObjv[0], i, &patternObj);
+	    if (code != TCL_OK) {
+		return code;
+	    }
+	    pattern = Tcl_GetStringFromObj(patternObj, &patternLen);
+	} else {
+	    pattern = Tcl_GetStringFromObj(switchObjv[i], &patternLen);
+	}
+
+	matched = 0;
+	if ((*pattern == 'd') && (i == switchObjc-2)
+		&& (strcmp(pattern, "default") == 0)) {
+	    matched = 1;
+	} else {
+	    /*
+	     * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL.
+	     */
+	    switch (mode) {
+		case EXACT:
+		    matched = (strcmp(string, pattern) == 0);
+		    break;
+		case GLOB:
+		    matched = Tcl_StringMatch(string, pattern);
+		    break;
+		case REGEXP:
+		    matched = Tcl_RegExpMatch(interp, string, pattern);
+		    if (matched < 0) {
+			code = TCL_ERROR;
+			goto done;
+		    }
+		    break;
+	    }
+	}
+	if (!matched) {
+	    continue;
+	}
+
+	/*
+	 * We've got a match. Find a body to execute, skipping bodies
+	 * that are "-".
+	 */
+
+	for (bodyIdx = i+1;  ;  bodyIdx += 2) {
+	    if (bodyIdx >= switchObjc) {
+		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+			"no body specified for pattern \"", pattern,
+			"\"", (char *) NULL);
+		code = TCL_ERROR;
+		goto done;
+	    }
+	    
+	    if (splitObjs) {
+		code = Tcl_ListObjIndex(interp, switchObjv[0], bodyIdx,
+		        &bodyObj);
+		if (code != TCL_OK) {
+		    return code;
+		}
+	    } else {
+		bodyObj = switchObjv[bodyIdx];
+	    }
+	    /*
+	     * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL.
+	     */
+	    body = Tcl_GetStringFromObj(bodyObj, &length);
+	    if ((length != 1) || (body[0] != '-')) {
+		break;
+	    }
+	}
+	code = Tcl_EvalObj(interp, bodyObj);
+	if (code == TCL_ERROR) {
+	    char msg[100];
+	    sprintf(msg, "\n    (\"%.50s\" arm line %d)", pattern,
+		    interp->errorLine);
+	    Tcl_AddObjErrorInfo(interp, msg, -1);
+	}
+	goto done;
+    }
+
+    /*
+     * Nothing matched:  return nothing.
+     */
+
+    code = TCL_OK;
+
+    done:
+    return code;
+#undef EXACT
+#undef GLOB
+#undef REGEXP
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_TimeObjCmd --
+ *
+ *	This object-based procedure is invoked to process the "time" Tcl
+ *	command.  See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl object result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_TimeObjCmd(dummy, interp, objc, objv)
+    ClientData dummy;		/* Not used. */
+    Tcl_Interp *interp;		/* Current interpreter. */
+    int objc;			/* Number of arguments. */
+    Tcl_Obj *CONST objv[];	/* Argument objects. */
+{
+    register Tcl_Obj *objPtr;
+    register int i, result;
+    int count;
+    double totalMicroSec;
+    Tcl_Time start, stop;
+    char buf[100];
+
+    if (objc == 2) {
+	count = 1;
+    } else if (objc == 3) {
+	result = Tcl_GetIntFromObj(interp, objv[2], &count);
+	if (result != TCL_OK) {
+	    return result;
+	}
+    } else {
+	Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
+	return TCL_ERROR;
+    }
+    
+    objPtr = objv[1];
+    i = count;
+    TclpGetTime(&start);
+    while (i-- > 0) {
+	result = Tcl_EvalObj(interp, objPtr);
+	if (result != TCL_OK) {
+	    return result;
+	}
+    }
+    TclpGetTime(&stop);
+    
+    totalMicroSec =
+	(stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
+    sprintf(buf, "%.0f microseconds per iteration",
+	((count <= 0) ? 0 : totalMicroSec/count));
+    Tcl_ResetResult(interp);
+    Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_TraceCmd --
+ *
+ *	This procedure is invoked to process the "trace" Tcl command.
+ *	See the user documentation for details on what it does.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+int
+Tcl_TraceCmd(dummy, interp, argc, argv)
+    ClientData dummy;			/* Not used. */
+    Tcl_Interp *interp;			/* Current interpreter. */
+    int argc;				/* Number of arguments. */
+    char **argv;			/* Argument strings. */
+{
+    int c;
+    size_t length;
+
+    if (argc < 2) {
+	Tcl_AppendResult(interp, "too few args: should be \"",
+		argv[0], " option [arg arg ...]\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+    c = argv[1][1];
+    length = strlen(argv[1]);
+    if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
+	    && (length >= 2)) {
+	char *p;
+	int flags, length;
+	TraceVarInfo *tvarPtr;
+
+	if (argc != 5) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"",
+		    argv[0], " variable name ops command\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+
+	flags = 0;
+	for (p = argv[3] ; *p != 0; p++) {
+	    if (*p == 'r') {
+		flags |= TCL_TRACE_READS;
+	    } else if (*p == 'w') {
+		flags |= TCL_TRACE_WRITES;
+	    } else if (*p == 'u') {
+		flags |= TCL_TRACE_UNSETS;
+	    } else {
+		goto badOps;
+	    }
+	}
+	if (flags == 0) {
+	    goto badOps;
+	}
+
+	length = strlen(argv[4]);
+	tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
+		(sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
+	tvarPtr->flags = flags;
+	tvarPtr->errMsg = NULL;
+	tvarPtr->length = length;
+	flags |= TCL_TRACE_UNSETS;
+	strcpy(tvarPtr->command, argv[4]);
+	if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
+		(ClientData) tvarPtr) != TCL_OK) {
+	    ckfree((char *) tvarPtr);
+	    return TCL_ERROR;
+	}
+    } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
+	    && (length >= 2)) == 0) {
+	char *p;
+	int flags, length;
+	TraceVarInfo *tvarPtr;
+	ClientData clientData;
+
+	if (argc != 5) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"",
+		    argv[0], " vdelete name ops command\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+
+	flags = 0;
+	for (p = argv[3] ; *p != 0; p++) {
+	    if (*p == 'r') {
+		flags |= TCL_TRACE_READS;
+	    } else if (*p == 'w') {
+		flags |= TCL_TRACE_WRITES;
+	    } else if (*p == 'u') {
+		flags |= TCL_TRACE_UNSETS;
+	    } else {
+		goto badOps;
+	    }
+	}
+	if (flags == 0) {
+	    goto badOps;
+	}
+
+	/*
+	 * Search through all of our traces on this variable to
+	 * see if there's one with the given command.  If so, then
+	 * delete the first one that matches.
+	 */
+
+	length = strlen(argv[4]);
+	clientData = 0;
+	while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
+		TraceVarProc, clientData)) != 0) {
+	    tvarPtr = (TraceVarInfo *) clientData;
+	    if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
+		    && (strncmp(argv[4], tvarPtr->command,
+		    (size_t) length) == 0)) {
+		Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
+			TraceVarProc, clientData);
+		if (tvarPtr->errMsg != NULL) {
+		    ckfree(tvarPtr->errMsg);
+		}
+		ckfree((char *) tvarPtr);
+		break;
+	    }
+	}
+    } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
+	    && (length >= 2)) {
+	ClientData clientData;
+	char ops[4], *p;
+	char *prefix = "{";
+
+	if (argc != 3) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"",
+		    argv[0], " vinfo name\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+	clientData = 0;
+	while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
+		TraceVarProc, clientData)) != 0) {
+	    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
+	    p = ops;
+	    if (tvarPtr->flags & TCL_TRACE_READS) {
+		*p = 'r';
+		p++;
+	    }
+	    if (tvarPtr->flags & TCL_TRACE_WRITES) {
+		*p = 'w';
+		p++;
+	    }
+	    if (tvarPtr->flags & TCL_TRACE_UNSETS) {
+		*p = 'u';
+		p++;
+	    }
+	    *p = '\0';
+	    Tcl_AppendResult(interp, prefix, (char *) NULL);
+	    Tcl_AppendElement(interp, ops);
+	    Tcl_AppendElement(interp, tvarPtr->command);
+	    Tcl_AppendResult(interp, "}", (char *) NULL);
+	    prefix = " {";
+	}
+    } else {
+	Tcl_AppendResult(interp, "bad option \"", argv[1],
+		"\": should be variable, vdelete, or vinfo",
+		(char *) NULL);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+
+    badOps:
+    Tcl_AppendResult(interp, "bad operations \"", argv[3],
+	    "\": should be one or more of rwu", (char *) NULL);
+    return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TraceVarProc --
+ *
+ *	This procedure is called to handle variable accesses that have
+ *	been traced using the "trace" command.
+ *
+ * Results:
+ *	Normally returns NULL.  If the trace command returns an error,
+ *	then this procedure returns an error string.
+ *
+ * Side effects:
+ *	Depends on the command associated with the trace.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static char *
+TraceVarProc(clientData, interp, name1, name2, flags)
+    ClientData clientData;	/* Information about the variable trace. */
+    Tcl_Interp *interp;		/* Interpreter containing variable. */
+    char *name1;		/* Name of variable or array. */
+    char *name2;		/* Name of element within array;  NULL means
+				 * scalar variable is being referenced. */
+    int flags;			/* OR-ed bits giving operation and other
+				 * information. */
+{
+    Interp *iPtr = (Interp *) interp;
+    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
+    char *result;
+    int code;
+    Interp dummy;
+    Tcl_DString cmd;
+    Tcl_Obj *saveObjPtr, *oldObjResultPtr;
+
+    result = NULL;
+    if (tvarPtr->errMsg != NULL) {
+	ckfree(tvarPtr->errMsg);
+	tvarPtr->errMsg = NULL;
+    }
+    if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
+
+	/*
+	 * Generate a command to execute by appending list elements
+	 * for the two variable names and the operation.  The five
+	 * extra characters are for three space, the opcode character,
+	 * and the terminating null.
+	 */
+
+	if (name2 == NULL) {
+	    name2 = "";
+	}
+	Tcl_DStringInit(&cmd);
+	Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length);
+	Tcl_DStringAppendElement(&cmd, name1);
+	Tcl_DStringAppendElement(&cmd, name2);
+	if (flags & TCL_TRACE_READS) {
+	    Tcl_DStringAppend(&cmd, " r", 2);
+	} else if (flags & TCL_TRACE_WRITES) {
+	    Tcl_DStringAppend(&cmd, " w", 2);
+	} else if (flags & TCL_TRACE_UNSETS) {
+	    Tcl_DStringAppend(&cmd, " u", 2);
+	}
+
+	/*
+	 * Execute the command.  Be careful to save and restore both the
+	 * string and object results from the interpreter used for
+	 * the command. We discard any object result the command returns.
+	 */
+
+	dummy.objResultPtr = Tcl_NewObj();
+	Tcl_IncrRefCount(dummy.objResultPtr);
+	if (interp->freeProc == 0) {
+	    dummy.freeProc = (Tcl_FreeProc *) 0;
+	    dummy.result = "";
+	    Tcl_SetResult((Tcl_Interp *) &dummy, interp->result,
+		    TCL_VOLATILE);
+	} else {
+	    dummy.freeProc = interp->freeProc;
+	    dummy.result = interp->result;
+	    interp->freeProc = (Tcl_FreeProc *) 0;
+	}
+	
+	saveObjPtr = Tcl_GetObjResult(interp);
+	Tcl_IncrRefCount(saveObjPtr);
+	
+	code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
+	if (code != TCL_OK) {	     /* copy error msg to result */
+	    tvarPtr->errMsg = (char *)
+		    ckalloc((unsigned) (strlen(interp->result) + 1));
+	    strcpy(tvarPtr->errMsg, interp->result);
+	    result = tvarPtr->errMsg;
+	    Tcl_ResetResult(interp); /* must clear error state. */
+	}
+
+	/*
+	 * Restore the interpreter's string result.
+	 */
+	
+	Tcl_SetResult(interp, dummy.result,
+		(dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc);
+
+	/*
+	 * Restore the interpreter's object result from saveObjPtr.
+	 */
+
+	oldObjResultPtr = iPtr->objResultPtr;
+	iPtr->objResultPtr = saveObjPtr;  /* was incremented above */
+	Tcl_DecrRefCount(oldObjResultPtr);
+
+	Tcl_DecrRefCount(dummy.objResultPtr);
+	dummy.objResultPtr = NULL;
+	Tcl_DStringFree(&cmd);
+    }
+    if (flags & TCL_TRACE_DESTROYED) {
+	result = NULL;
+	if (tvarPtr->errMsg != NULL) {
+	    ckfree(tvarPtr->errMsg);
+	}
+	ckfree((char *) tvarPtr);
+    }
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_WhileCmd --
+ *
+ *      This procedure is invoked to process the "while" Tcl command.
+ *      See the user documentation for details on what it does.
+ *
+ *	With the bytecode compiler, this procedure is only called when
+ *	a command name is computed at runtime, and is "while" or the name
+ *	to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
+ *
+ * Results:
+ *      A standard Tcl result.
+ *
+ * Side effects:
+ *      See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+        /* ARGSUSED */
+int
+Tcl_WhileCmd(dummy, interp, argc, argv)
+    ClientData dummy;                   /* Not used. */
+    Tcl_Interp *interp;                 /* Current interpreter. */
+    int argc;                           /* Number of arguments. */
+    char **argv;                        /* Argument strings. */
+{
+    int result, value;
+
+    if (argc != 3) {
+        Tcl_AppendResult(interp, "wrong # args: should be \"",
+                argv[0], " test command\"", (char *) NULL);
+        return TCL_ERROR;
+    }
+
+    while (1) {
+        result = Tcl_ExprBoolean(interp, argv[1], &value);
+        if (result != TCL_OK) {
+            return result;
+        }
+        if (!value) {
+            break;
+        }
+        result = Tcl_Eval(interp, argv[2]);
+        if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
+            if (result == TCL_ERROR) {
+                char msg[60];
+                sprintf(msg, "\n    (\"while\" body line %d)",
+                        interp->errorLine);
+                Tcl_AddErrorInfo(interp, msg);
+            }
+            break;
+        }
+    }
+    if (result == TCL_BREAK) {
+        result = TCL_OK;
+    }
+    if (result == TCL_OK) {
+        Tcl_ResetResult(interp);
+    }
+    return result;
+}
+