Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume25/tcl/part16

Text File | 1991-11-15 | 50.1 KB | 1,901 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Karl Lehenbauer)
Subject:  v25i084:  tcl - tool command language, version 6.1, Part16/33
Message-ID: <[e-mail]>
X-Md4-Signature: 32ec3174c0763e68e8e984b8f3ee3a7c
Date: Fri, 15 Nov 1991 22:47:24 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Karl Lehenbauer)
Posting-number: Volume 25, Issue 84
Archive-name: tcl/part16
Environment: UNIX

#! /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 16 (of 33)."
# Contents:  tcl6.1/tclCmdAH.c tcl6.1/tclHash.c
# Wrapped by karl@one on Tue Nov 12 19:44:24 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tcl6.1/tclCmdAH.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'tcl6.1/tclCmdAH.c'\"
else
echo shar: Extracting \"'tcl6.1/tclCmdAH.c'\" \(21838 characters\)
sed "s/^X//" >'tcl6.1/tclCmdAH.c' <<'END_OF_FILE'
X/*
X * tclCmdAH.c --
X *
X *    This file contains the top-level command routines for most of
X *    the Tcl built-in commands whose names begin with the letters
X *    A to H.
X *
X * Copyright 1987-1991 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: /user6/ouster/tcl/RCS/tclCmdAH.c,v 1.73 91/11/07 09:02:11 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include "tclInt.h"
X
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_BreakCmd --
X *
X *    This procedure is invoked to process the "break" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_BreakCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    if (argc != 1) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"",
X        argv[0], "\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    return TCL_BREAK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_CaseCmd --
X *
X *    This procedure is invoked to process the "case" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_CaseCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int i, result;
X    int body;
X    char *string;
X    int caseArgc, splitArgs;
X    char **caseArgv;
X
X    if (argc < 3) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"",
X        argv[0], " string ?in? patList body ... ?default body?\"",
X        (char *) NULL);
X    return TCL_ERROR;
X    }
X    string = argv[1];
X    body = -1;
X    if (strcmp(argv[2], "in") == 0) {
X    i = 3;
X    } else {
X    i = 2;
X    }
X    caseArgc = argc - i;
X    caseArgv = argv + i;
X
X    /*
X     * If all of the pattern/command pairs are lumped into a single
X     * argument, split them out again.
X     */
X
X    splitArgs = 0;
X    if (caseArgc == 1) {
X    result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);
X    if (result != TCL_OK) {
X        return result;
X    }
X    splitArgs = 1;
X    }
X
X    for (i = 0; i < caseArgc; i += 2) {
X    int patArgc, j;
X    char **patArgv;
X    register char *p;
X
X    if (i == (caseArgc-1)) {
X        interp->result = "extra case pattern with no body";
X        result = TCL_ERROR;
X        goto cleanup;
X    }
X
X    /*
X     * Check for special case of single pattern (no list) with
X     * no backslash sequences.
X     */
X
X    for (p = caseArgv[i]; *p != 0; p++) {
X        if (isspace(*p) || (*p == '\\')) {
X        break;
X        }
X    }
X    if (*p == 0) {
X        if ((*caseArgv[i] == 'd')
X            && (strcmp(caseArgv[i], "default") == 0)) {
X        body = i+1;
X        }
X        if (Tcl_StringMatch(string, caseArgv[i])) {
X        body = i+1;
X        goto match;
X        }
X        continue;
X    }
X
X    /*
X     * Break up pattern lists, then check each of the patterns
X     * in the list.
X     */
X
X    result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);
X    if (result != TCL_OK) {
X        goto cleanup;
X    }
X    for (j = 0; j < patArgc; j++) {
X        if (Tcl_StringMatch(string, patArgv[j])) {
X        body = i+1;
X        break;
X        }
X    }
X    ckfree((char *) patArgv);
X    if (j < patArgc) {
X        break;
X    }
X    }
X
X    match:
X    if (body != -1) {
X    result = Tcl_Eval(interp, caseArgv[body], 0, (char **) NULL);
X    if (result == TCL_ERROR) {
X        char msg[100];
X        sprintf(msg, "\n    (\"%.50s\" arm line %d)", caseArgv[i],
X            interp->errorLine);
X        Tcl_AddErrorInfo(interp, msg);
X    }
X    goto cleanup;
X    }
X
X    /*
X     * Nothing matched:  return nothing.
X     */
X
X    result = TCL_OK;
X
X    cleanup:
X    if (splitArgs) {
X    ckfree((char *) caseArgv);
X    }
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_CatchCmd --
X *
X *    This procedure is invoked to process the "catch" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_CatchCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int result;
X
X    if ((argc != 2) && (argc != 3)) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"",
X        argv[0], " command ?varName?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
X    if (argc == 3) {
X    if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
X        Tcl_SetResult(interp, "couldn't save command result in variable",
X            TCL_STATIC);
X        return TCL_ERROR;
X    }
X    }
X    Tcl_ResetResult(interp);
X    sprintf(interp->result, "%d", result);
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ConcatCmd --
X *
X *    This procedure is invoked to process the "concat" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_ConcatCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    if (argc == 1) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " arg ?arg ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    interp->result = Tcl_Concat(argc-1, argv+1);
X    interp->freeProc = (Tcl_FreeProc *) free;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ContinueCmd --
X *
X *    This procedure is invoked to process the "continue" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_ContinueCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    if (argc != 1) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        "\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    return TCL_CONTINUE;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ErrorCmd --
X *
X *    This procedure is invoked to process the "error" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_ErrorCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    Interp *iPtr = (Interp *) interp;
X
X    if ((argc < 2) || (argc > 4)) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " message ?errorInfo? ?errorCode?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    if ((argc >= 3) && (argv[2][0] != 0)) {
X    Tcl_AddErrorInfo(interp, argv[2]);
X    iPtr->flags |= ERR_ALREADY_LOGGED;
X    }
X    if (argc == 4) {
X    Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
X        TCL_GLOBAL_ONLY);
X    iPtr->flags |= ERROR_CODE_SET;
X    }
X    Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
X    return TCL_ERROR;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_EvalCmd --
X *
X *    This procedure is invoked to process the "eval" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_EvalCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int result;
X    char *cmd;
X
X    if (argc < 2) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " arg ?arg ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    if (argc == 2) {
X    result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
X    } else {
X
X    /*
X     * More than one argument:  concatenate them together with spaces
X     * between, then evaluate the result.
X     */
X
X    cmd = Tcl_Concat(argc-1, argv+1);
X    result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
X    ckfree(cmd);
X    }
X    if (result == TCL_ERROR) {
X    char msg[60];
X    sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
X    Tcl_AddErrorInfo(interp, msg);
X    }
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ExprCmd --
X *
X *    This procedure is invoked to process the "expr" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_ExprCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    if (argc != 2) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " expression\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    return Tcl_ExprString(interp, argv[1]);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ForCmd --
X *
X *    This procedure is invoked to process the "for" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_ForCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int result, value;
X
X    if (argc != 5) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " start test next command\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
X    if (result != TCL_OK) {
X    if (result == TCL_ERROR) {
X        Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
X    }
X    return result;
X    }
X    while (1) {
X    result = Tcl_ExprBoolean(interp, argv[2], &value);
X    if (result != TCL_OK) {
X        return result;
X    }
X    if (!value) {
X        break;
X    }
X    result = Tcl_Eval(interp, argv[4], 0, (char **) NULL);
X    if (result == TCL_CONTINUE) {
X        result = TCL_OK;
X    } else if (result != TCL_OK) {
X        if (result == TCL_ERROR) {
X        char msg[60];
X        sprintf(msg, "\n    (\"for\" body line %d)", interp->errorLine);
X        Tcl_AddErrorInfo(interp, msg);
X        }
X        break;
X    }
X    result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
X    if (result == TCL_BREAK) {
X        break;
X    } else if (result != TCL_OK) {
X        if (result == TCL_ERROR) {
X        Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
X        }
X        return result;
X    }
X    }
X    if (result == TCL_BREAK) {
X    result = TCL_OK;
X    }
X    if (result == TCL_OK) {
X    Tcl_ResetResult(interp);
X    }
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ForeachCmd --
X *
X *    This procedure is invoked to process the "foreach" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_ForeachCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int listArgc, i, result;
X    char **listArgv;
X
X    if (argc != 4) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " varName list command\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    /*
X     * Break the list up into elements, and execute the command once
X     * for each value of the element.
X     */
X
X    result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
X    if (result != TCL_OK) {
X    return result;
X    }
X    for (i = 0; i < listArgc; i++) {
X    if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) {
X        Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC);
X        result = TCL_ERROR;
X        break;
X    }
X
X    result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
X    if (result != TCL_OK) {
X        if (result == TCL_CONTINUE) {
X        result = TCL_OK;
X        } else if (result == TCL_BREAK) {
X        result = TCL_OK;
X        break;
X        } else if (result == TCL_ERROR) {
X        char msg[100];
X        sprintf(msg, "\n    (\"foreach\" body line %d)",
X            interp->errorLine);
X        Tcl_AddErrorInfo(interp, msg);
X        break;
X        } else {
X        break;
X        }
X    }
X    }
X    ckfree((char *) listArgv);
X    if (result == TCL_OK) {
X    Tcl_ResetResult(interp);
X    }
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_FormatCmd --
X *
X *    This procedure is invoked to process the "format" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_FormatCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    register char *format;    /* Used to read characters from the format
X                 * string. */
X    char newFormat[40];        /* A new format specifier is generated here. */
X    int width;            /* Field width from field specifier, or 0 if
X                 * no width given. */
X    int precision;        /* Field precision from field specifier, or 0
X                 * if no precision given. */
X    int size;            /* Number of bytes needed for result of
X                 * conversion, based on type of conversion
X                 * ("e", "s", etc.) and width from above. */
X    char *oneWordValue = NULL;    /* Used to hold value to pass to sprintf, if
X                 * it's a one-word value. */
X    double twoWordValue;    /* Used to hold value to pass to sprintf if
X                 * it's a two-word value. */
X    int useTwoWords;        /* 0 means use oneWordValue, 1 means use
X                 * twoWordValue. */
X    char *dst = interp->result;    /* Where result is stored.  Starts off at
X                 * interp->resultSpace, but may get dynamically
X                 * re-allocated if this isn't enough. */
X    int dstSize = 0;        /* Number of non-null characters currently
X                 * stored at dst. */
X    int dstSpace = TCL_RESULT_SIZE;
X                /* Total amount of storage space available
X                 * in dst (not including null terminator. */
X    int noPercent;        /* Special case for speed:  indicates there's
X                 * no field specifier, just a string to copy. */
X    char **curArg;        /* Remainder of argv array. */
X
X    /*
X     * This procedure is a bit nasty.  The goal is to use sprintf to
X     * do most of the dirty work.  There are several problems:
X     * 1. this procedure can't trust its arguments.
X     * 2. we must be able to provide a large enough result area to hold
X     *    whatever's generated.  This is hard to estimate.
X     * 2. there's no way to move the arguments from argv to the call
X     *    to sprintf in a reasonable way.  This is particularly nasty
X     *    because some of the arguments may be two-word values (doubles).
X     * So, what happens here is to scan the format string one % group
X     * at a time, making many individual calls to sprintf.
X     */
X
X    if (argc < 2) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " formatString ?arg arg ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    curArg = argv+2;
X    argc -= 2;
X    for (format = argv[1]; *format != 0; ) {
X    register char *newPtr = newFormat;
X
X    width = precision = useTwoWords = noPercent = 0;
X
X    /*
X     * Get rid of any characters before the next field specifier.
X     * Collapse backslash sequences found along the way.
X     */
X
X    if (*format != '%') {
X        register char *p;
X        int bsSize;
X
X        oneWordValue = p = format;
X        while ((*format != '%') && (*format != 0)) {
X        if (*format == '\\') {
X            *p = Tcl_Backslash(format, &bsSize);
X            if (*p != 0) {
X            p++;
X            }
X            format += bsSize;
X        } else {
X            *p = *format;
X            p++;
X            format++;
X        }
X        }
X        size = p - oneWordValue;
X        noPercent = 1;
X        goto doField;
X    }
X
X    if (format[1] == '%') {
X        oneWordValue = format;
X        size = 1;
X        noPercent = 1;
X        format += 2;
X        goto doField;
X    }
X
X    /*
X     * Parse off a field specifier, compute how many characters
X     * will be needed to store the result, and substitute for
X     * "*" size specifiers.
X     */
X
X    *newPtr = '%';
X    newPtr++;
X    format++;
X    while ((*format == '-') || (*format == '#')) {
X        *newPtr = *format;
X        newPtr++;
X        format++;
X    }
X    if (*format == '0') {
X        *newPtr = '0';
X        newPtr++;
X        format++;
X    }
X    if (isdigit(*format)) {
X        width = atoi(format);
X        do {
X        format++;
X        } while (isdigit(*format));
X    } else if (*format == '*') {
X        if (argc <= 0) {
X        goto notEnoughArgs;
X        }
X        if (Tcl_GetInt(interp, *curArg, &width) != TCL_OK) {
X        goto fmtError;
X        }
X        argc--;
X        curArg++;
X        format++;
X    }
X    if (width != 0) {
X        sprintf(newPtr, "%d", width);
X        while (*newPtr != 0) {
X        newPtr++;
X        }
X    }
X    if (*format == '.') {
X        *newPtr = '.';
X        newPtr++;
X        format++;
X    }
X    if (isdigit(*format)) {
X        precision = atoi(format);
X        do {
X        format++;
X        } while (isdigit(*format));
X    } else if (*format == '*') {
X        if (argc <= 0) {
X        goto notEnoughArgs;
X        }
X        if (Tcl_GetInt(interp, *curArg, &precision) != TCL_OK) {
X        goto fmtError;
X        }
X        argc--;
X        curArg++;
X        format++;
X    }
X    if (precision != 0) {
X        sprintf(newPtr, "%d", precision);
X        while (*newPtr != 0) {
X        newPtr++;
X        }
X    }
X    if (*format == 'l') {
X        format++;
X    }
X    *newPtr = *format;
X    newPtr++;
X    *newPtr = 0;
X    if (argc <= 0) {
X        goto notEnoughArgs;
X    }
X    switch (*format) {
X        case 'D':
X        case 'O':
X        case 'U':
X        *newPtr = tolower(*format);
X        newPtr[-1] = 'l';
X        newPtr++;
X        *newPtr = 0;
X        case 'd':
X        case 'o':
X        case 'u':
X        case 'x':
X        case 'X':
X        if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue)
X            != TCL_OK) {
X            goto fmtError;
X        }
X        size = 40;
X        break;
X        case 's':
X        oneWordValue = *curArg;
X        size = strlen(*curArg);
X        break;
X        case 'c':
X        if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue)
X            != TCL_OK) {
X            goto fmtError;
X        }
X        size = 1;
X        break;
X        case 'F':
X        newPtr[-1] = tolower(newPtr[-1]);
X        case 'e':
X        case 'E':
X        case 'f':
X        case 'g':
X        case 'G':
X        if (Tcl_GetDouble(interp, *curArg, &twoWordValue) != TCL_OK) {
X            goto fmtError;
X        }
X        useTwoWords = 1;
X        size = 320;
X        if (precision > 10) {
X            size += precision;
X        }
X        break;
X        case 0:
X        interp->result =
X            "format string ended in middle of field specifier";
X        goto fmtError;
X        default:
X        sprintf(interp->result, "bad field specifier \"%c\"", *format);
X        goto fmtError;
X    }
X    argc--;
X    curArg++;
X    format++;
X
X    /*
X     * Make sure that there's enough space to hold the formatted
X     * result, then format it.
X     */
X
X    doField:
X    if (width > size) {
X        size = width;
X    }
X    if ((dstSize + size) > dstSpace) {
X        char *newDst;
X        int newSpace;
X
X        newSpace = 2*(dstSize + size);
X        newDst = (char *) ckalloc((unsigned) newSpace+1);
X        if (dstSize != 0) {
X        memcpy((VOID *) newDst, (VOID *) dst, dstSize);
X        }
X        if (dstSpace != TCL_RESULT_SIZE) {
X        ckfree(dst);
X        }
X        dst = newDst;
X        dstSpace = newSpace;
X    }
X    if (noPercent) {
X        memcpy((VOID *) dst+dstSize, (VOID *) oneWordValue, size);
X        dstSize += size;
X        dst[dstSize] = 0;
X    } else {
X        if (useTwoWords) {
X        sprintf(dst+dstSize, newFormat, twoWordValue);
X        } else {
X        sprintf(dst+dstSize, newFormat, oneWordValue);
X        }
X        dstSize += strlen(dst+dstSize);
X    }
X    }
X
X    interp->result = dst;
X    if (dstSpace != TCL_RESULT_SIZE) {
X    interp->freeProc = (Tcl_FreeProc *) free;
X    } else {
X    interp->freeProc = 0;
X    }
X    return TCL_OK;
X
X    notEnoughArgs:
X    interp->result = "not enough arguments for all format specifiers";
X    fmtError:
X    if (dstSpace != TCL_RESULT_SIZE) {
X    ckfree(dst);
X    }
X    return TCL_ERROR;
X}
END_OF_FILE
if test 21838 -ne `wc -c <'tcl6.1/tclCmdAH.c'`; then
    echo shar: \"'tcl6.1/tclCmdAH.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclCmdAH.c'
fi
if test -f 'tcl6.1/tclHash.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'tcl6.1/tclHash.c'\"
else
echo shar: Extracting \"'tcl6.1/tclHash.c'\" \(25018 characters\)
sed "s/^X//" >'tcl6.1/tclHash.c' <<'END_OF_FILE'
X/*
X * tclHash.c --
X *
X *    Implementation of in-memory hash tables for Tcl and Tcl-based
X *    applications.
X *
X * Copyright 1991 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 this copyright
X * notice appears 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/tclHash.c,v 1.8 91/07/22 11:46:00 ouster Exp $ SPRITE (Berkeley)";
X#endif /* not lint */
X
X#include "tclInt.h"
X
X/*
X * Imported library procedures for which there are no header files:
X */
X
Xextern void panic();
X
X/*
X * When there are this many entries per bucket, on average, rebuild
X * the hash table to make it larger.
X */
X
X#define REBUILD_MULTIPLIER    3
X
X
X/*
X * The following macro takes a preliminary integer hash value and
X * produces an index into a hash tables bucket list.  The idea is
X * to make it so that preliminary values that are arbitrarily similar
X * will end up in different buckets.  The hash function was taken
X * from a random-number generator.
X */
X
X#define RANDOM_INDEX(tablePtr, i) \
X    (((((int) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask)
X
X/*
X * Procedure prototypes for static procedures in this file:
X */
X
Xstatic Tcl_HashEntry *    ArrayFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X                char *key));
Xstatic Tcl_HashEntry *    ArrayCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X                char *key, int *newPtr));
Xstatic Tcl_HashEntry *    BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X                char *key));
Xstatic Tcl_HashEntry *    BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X                char *key, int *newPtr));
Xstatic int        HashString _ANSI_ARGS_((char *string));
Xstatic void        RebuildTable _ANSI_ARGS_((Tcl_HashTable *tablePtr));
Xstatic Tcl_HashEntry *    StringFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X                char *key));
Xstatic Tcl_HashEntry *    StringCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X                char *key, int *newPtr));
Xstatic Tcl_HashEntry *    OneWordFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X                char *key));
Xstatic Tcl_HashEntry *    OneWordCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X                char *key, int *newPtr));
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_InitHashTable --
X *
X *    Given storage for a hash table, set up the fields to prepare
X *    the hash table for use.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    TablePtr is now ready to be passed to Tcl_FindHashEntry and
X *    Tcl_CreateHashEntry.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_InitHashTable(tablePtr, keyType)
X    register Tcl_HashTable *tablePtr;    /* Pointer to table record, which
X                     * is supplied by the caller. */
X    int keyType;            /* Type of keys to use in table:
X                     * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
X                     * or an integer >= 2. */
X{
X    tablePtr->buckets = tablePtr->staticBuckets;
X    tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
X    tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
X    tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
X    tablePtr->numEntries = 0;
X    tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;
X    tablePtr->downShift = 28;
X    tablePtr->mask = 3;
X    tablePtr->keyType = keyType;
X    if (keyType == TCL_STRING_KEYS) {
X    tablePtr->findProc = StringFind;
X    tablePtr->createProc = StringCreate;
X    } else if (keyType == TCL_ONE_WORD_KEYS) {
X    tablePtr->findProc = OneWordFind;
X    tablePtr->createProc = OneWordCreate;
X    } else {
X    tablePtr->findProc = ArrayFind;
X    tablePtr->createProc = ArrayCreate;
X    };
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DeleteHashEntry --
X *
X *    Remove a single entry from a hash table.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    The entry given by entryPtr is deleted from its table and
X *    should never again be used by the caller.  It is up to the
X *    caller to free the clientData field of the entry, if that
X *    is relevant.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_DeleteHashEntry(entryPtr)
X    Tcl_HashEntry *entryPtr;
X{
X    register Tcl_HashEntry *prevPtr;
X
X    if (*entryPtr->bucketPtr == entryPtr) {
X    *entryPtr->bucketPtr = entryPtr->nextPtr;
X    } else {
X    for (prevPtr = *entryPtr->bucketPtr; ; prevPtr = prevPtr->nextPtr) {
X        if (prevPtr == NULL) {
X        panic("malformed bucket chain in Tcl_DeleteHashEntry");
X        }
X        if (prevPtr->nextPtr == entryPtr) {
X        prevPtr->nextPtr = entryPtr->nextPtr;
X        break;
X        }
X    }
X    }
X    entryPtr->tablePtr->numEntries--;
X    ckfree((char *) entryPtr);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DeleteHashTable --
X *
X *    Free up everything associated with a hash table except for
X *    the record for the table itself.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    The hash table is no longer useable.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_DeleteHashTable(tablePtr)
X    register Tcl_HashTable *tablePtr;        /* Table to delete. */
X{
X    register Tcl_HashEntry *hPtr, *nextPtr;
X    int i;
X
X    /*
X     * Free up all the entries in the table.
X     */
X
X    for (i = 0; i < tablePtr->numBuckets; i++) {
X    hPtr = tablePtr->buckets[i];
X    while (hPtr != NULL) {
X        nextPtr = hPtr->nextPtr;
X        ckfree((char *) hPtr);
X        hPtr = nextPtr;
X    }
X    }
X
X    /*
X     * Free up the bucket array, if it was dynamically allocated.
X     */
X
X    if (tablePtr->buckets != tablePtr->staticBuckets) {
X    ckfree((char *) tablePtr->buckets);
X    }
X
X    /*
X     * Arrange for panics if the table is used again without
X     * re-initialization.
X     */
X
X    tablePtr->findProc = BogusFind;
X    tablePtr->createProc = BogusCreate;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_FirstHashEntry --
X *
X *    Locate the first entry in a hash table and set up a record
X *    that can be used to step through all the remaining entries
X *    of the table.
X *
X * Results:
X *    The return value is a pointer to the first entry in tablePtr,
X *    or NULL if tablePtr has no entries in it.  The memory at
X *    *searchPtr is initialized so that subsequent calls to
X *    Tcl_NextHashEntry will return all of the entries in the table,
X *    one at a time.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
XTcl_HashEntry *
XTcl_FirstHashEntry(tablePtr, searchPtr)
X    Tcl_HashTable *tablePtr;        /* Table to search. */
X    Tcl_HashSearch *searchPtr;        /* Place to store information about
X                     * progress through the table. */
X{
X    searchPtr->tablePtr = tablePtr;
X    searchPtr->nextIndex = 0;
X    searchPtr->nextEntryPtr = NULL;
X    return Tcl_NextHashEntry(searchPtr);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_NextHashEntry --
X *
X *    Once a hash table enumeration has been initiated by calling
X *    Tcl_FirstHashEntry, this procedure may be called to return
X *    successive elements of the table.
X *
X * Results:
X *    The return value is the next entry in the hash table being
X *    enumerated, or NULL if the end of the table is reached.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
XTcl_HashEntry *
XTcl_NextHashEntry(searchPtr)
X    register Tcl_HashSearch *searchPtr;    /* Place to store information about
X                     * progress through the table.  Must
X                     * have been initialized by calling
X                     * Tcl_FirstHashEntry. */
X{
X    Tcl_HashEntry *hPtr;
X
X    while (searchPtr->nextEntryPtr == NULL) {
X    if (searchPtr->nextIndex >= searchPtr->tablePtr->numBuckets) {
X        return NULL;
X    }
X    searchPtr->nextEntryPtr =
X        searchPtr->tablePtr->buckets[searchPtr->nextIndex];
X    searchPtr->nextIndex++;
X    }
X    hPtr = searchPtr->nextEntryPtr;
X    searchPtr->nextEntryPtr = hPtr->nextPtr;
X    return hPtr;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_HashStats --
X *
X *    Return statistics describing the layout of the hash table
X *    in its hash buckets.
X *
X * Results:
X *    The return value is a malloc-ed string containing information
X *    about tablePtr.  It is the caller's responsibility to free
X *    this string.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_HashStats(tablePtr)
X    Tcl_HashTable *tablePtr;        /* Table for which to produce stats. */
X{
X#define NUM_COUNTERS 10
X    int count[NUM_COUNTERS], overflow, i, j;
X    double average, tmp;
X    register Tcl_HashEntry *hPtr;
X    char *result, *p;
X
X    /*
X     * Compute a histogram of bucket usage.
X     */
X
X    for (i = 0; i < NUM_COUNTERS; i++) {
X    count[i] = 0;
X    }
X    overflow = 0;
X    average = 0.0;
X    for (i = 0; i < tablePtr->numBuckets; i++) {
X    j = 0;
X    for (hPtr = tablePtr->buckets[i]; hPtr != NULL; hPtr = hPtr->nextPtr) {
X        j++;
X    }
X    if (j < NUM_COUNTERS) {
X        count[j]++;
X    } else {
X        overflow++;
X    }
X    tmp = j;
X    average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
X    }
X
X    /*
X     * Print out the histogram and a few other pieces of information.
X     */
X
X    result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
X    sprintf(result, "%d entries in table, %d buckets\n",
X        tablePtr->numEntries, tablePtr->numBuckets);
X    p = result + strlen(result);
X    for (i = 0; i < NUM_COUNTERS; i++) {
X    sprintf(p, "number of buckets with %d entries: %d\n",
X        i, count[i]);
X    p += strlen(p);
X    }
X    sprintf(p, "number of buckets with more %d or more entries: %d\n",
X        NUM_COUNTERS, overflow);
X    p += strlen(p);
X    sprintf(p, "average search distance for entry: %.1f", average);
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * HashString --
X *
X *    Compute a one-word summary of a text string, which can be
X *    used to generate a hash index.
X *
X * Results:
X *    The return value is a one-word summary of the information in
X *    string.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic int
XHashString(string)
X    register char *string;    /* String from which to compute hash value. */
X{
X    register int result, c;
X
X    /*
X     * I tried a zillion different hash functions and asked many other
X     * people for advice.  Many people had their own favorite functions,
X     * all different, but no-one had much idea why they were good ones.
X     * I chose the one below (multiply by 9 and add new character)
X     * because of the following reasons:
X     *
X     * 1. Multiplying by 10 is perfect for keys that are decimal strings,
X     *    and multiplying by 9 is just about as good.
X     * 2. Times-9 is (shift-left-3) plus (old).  This means that each
X     *    character's bits hang around in the low-order bits of the
X     *    hash value for ever, plus they spread fairly rapidly up to
X     *    the high-order bits to fill out the hash value.  This seems
X     *    works well both for decimal and non-decimal strings.
X     */
X
X    result = 0;
X    while (1) {
X    c = *string;
X    string++;
X    if (c == 0) {
X        break;
X    }
X    result += (result<<3) + c;
X    }
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * StringFind --
X *
X *    Given a hash table with string keys, and a string key, find
X *    the entry with a matching key.
X *
X * Results:
X *    The return value is a token for the matching entry in the
X *    hash table, or NULL if there was no matching entry.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic Tcl_HashEntry *
XStringFind(tablePtr, key)
X    Tcl_HashTable *tablePtr;    /* Table in which to lookup entry. */
X    char *key;            /* Key to use to find matching entry. */
X{
X    register Tcl_HashEntry *hPtr;
X    register char *p1, *p2;
X    int index;
X
X    index = HashString(key) & tablePtr->mask;
X
X    /*
X     * Search all of the entries in the appropriate bucket.
X     */
X
X    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
X        hPtr = hPtr->nextPtr) {
X    for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) {
X        if (*p1 != *p2) {
X        break;
X        }
X        if (*p1 == '\0') {
X        return hPtr;
X        }
X    }
X    }
X    return NULL;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * StringCreate --
X *
X *    Given a hash table with string keys, and a string key, find
X *    the entry with a matching key.  If there is no matching entry,
X *    then create a new entry that does match.
X *
X * Results:
X *    The return value is a pointer to the matching entry.  If this
X *    is a newly-created entry, then *newPtr will be set to a non-zero
X *    value;  otherwise *newPtr will be set to 0.  If this is a new
X *    entry the value stored in the entry will initially be 0.
X *
X * Side effects:
X *    A new entry may be added to the hash table.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic Tcl_HashEntry *
XStringCreate(tablePtr, key, newPtr)
X    Tcl_HashTable *tablePtr;    /* Table in which to lookup entry. */
X    char *key;            /* Key to use to find or create matching
X                 * entry. */
X    int *newPtr;        /* Store info here telling whether a new
X                 * entry was created. */
X{
X    register Tcl_HashEntry *hPtr;
X    register char *p1, *p2;
X    int index;
X
X    index = HashString(key) & tablePtr->mask;
X
X    /*
X     * Search all of the entries in this bucket.
X     */
X
X    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
X        hPtr = hPtr->nextPtr) {
X    for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) {
X        if (*p1 != *p2) {
X        break;
X        }
X        if (*p1 == '\0') {
X        *newPtr = 0;
X        return hPtr;
X        }
X    }
X    }
X
X    /*
X     * Entry not found.  Add a new one to the bucket.
X     */
X
X    *newPtr = 1;
X    hPtr = (Tcl_HashEntry *) ckalloc((unsigned)
X        (sizeof(Tcl_HashEntry) + strlen(key) - (sizeof(hPtr->key) -1)));
X    hPtr->tablePtr = tablePtr;
X    hPtr->bucketPtr = &(tablePtr->buckets[index]);
X    hPtr->nextPtr = *hPtr->bucketPtr;
X    hPtr->clientData = 0;
X    strcpy(hPtr->key.string, key);
X    *hPtr->bucketPtr = hPtr;
X    tablePtr->numEntries++;
X
X    /*
X     * If the table has exceeded a decent size, rebuild it with many
X     * more buckets.
X     */
X
X    if (tablePtr->numEntries >= tablePtr->rebuildSize) {
X    RebuildTable(tablePtr);
X    }
X    return hPtr;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * OneWordFind --
X *
X *    Given a hash table with one-word keys, and a one-word key, find
X *    the entry with a matching key.
X *
X * Results:
X *    The return value is a token for the matching entry in the
X *    hash table, or NULL if there was no matching entry.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic Tcl_HashEntry *
XOneWordFind(tablePtr, key)
X    Tcl_HashTable *tablePtr;    /* Table in which to lookup entry. */
X    register char *key;        /* Key to use to find matching entry. */
X{
X    register Tcl_HashEntry *hPtr;
X    int index;
X
X    index = RANDOM_INDEX(tablePtr, key);
X
X    /*
X     * Search all of the entries in the appropriate bucket.
X     */
X
X    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
X        hPtr = hPtr->nextPtr) {
X    if (hPtr->key.oneWordValue == key) {
X        return hPtr;
X    }
X    }
X    return NULL;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * OneWordCreate --
X *
X *    Given a hash table with one-word keys, and a one-word key, find
X *    the entry with a matching key.  If there is no matching entry,
X *    then create a new entry that does match.
X *
X * Results:
X *    The return value is a pointer to the matching entry.  If this
X *    is a newly-created entry, then *newPtr will be set to a non-zero
X *    value;  otherwise *newPtr will be set to 0.  If this is a new
X *    entry the value stored in the entry will initially be 0.
X *
X * Side effects:
X *    A new entry may be added to the hash table.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic Tcl_HashEntry *
XOneWordCreate(tablePtr, key, newPtr)
X    Tcl_HashTable *tablePtr;    /* Table in which to lookup entry. */
X    register char *key;        /* Key to use to find or create matching
X                 * entry. */
X    int *newPtr;        /* Store info here telling whether a new
X                 * entry was created. */
X{
X    register Tcl_HashEntry *hPtr;
X    int index;
X
X    index = RANDOM_INDEX(tablePtr, key);
X
X    /*
X     * Search all of the entries in this bucket.
X     */
X
X    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
X        hPtr = hPtr->nextPtr) {
X    if (hPtr->key.oneWordValue == key) {
X        *newPtr = 0;
X        return hPtr;
X    }
X    }
X
X    /*
X     * Entry not found.  Add a new one to the bucket.
X     */
X
X    *newPtr = 1;
X    hPtr = (Tcl_HashEntry *) ckalloc(sizeof(Tcl_HashEntry));
X    hPtr->tablePtr = tablePtr;
X    hPtr->bucketPtr = &(tablePtr->buckets[index]);
X    hPtr->nextPtr = *hPtr->bucketPtr;
X    hPtr->clientData = 0;
X    hPtr->key.oneWordValue = key;
X    *hPtr->bucketPtr = hPtr;
X    tablePtr->numEntries++;
X
X    /*
X     * If the table has exceeded a decent size, rebuild it with many
X     * more buckets.
X     */
X
X    if (tablePtr->numEntries >= tablePtr->rebuildSize) {
X    RebuildTable(tablePtr);
X    }
X    return hPtr;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * ArrayFind --
X *
X *    Given a hash table with array-of-int keys, and a key, find
X *    the entry with a matching key.
X *
X * Results:
X *    The return value is a token for the matching entry in the
X *    hash table, or NULL if there was no matching entry.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic Tcl_HashEntry *
XArrayFind(tablePtr, key)
X    Tcl_HashTable *tablePtr;    /* Table in which to lookup entry. */
X    char *key;            /* Key to use to find matching entry. */
X{
X    register Tcl_HashEntry *hPtr;
X    int *arrayPtr = (int *) key;
X    register int *iPtr1, *iPtr2;
X    int index, count;
X
X    for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr;
X        count > 0; count--, iPtr1++) {
X    index += *iPtr1;
X    }
X    index = RANDOM_INDEX(tablePtr, index);
X
X    /*
X     * Search all of the entries in the appropriate bucket.
X     */
X
X    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
X        hPtr = hPtr->nextPtr) {
X    for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words,
X        count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
X        if (count == 0) {
X        return hPtr;
X        }
X        if (*iPtr1 != *iPtr2) {
X        break;
X        }
X    }
X    }
X    return NULL;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * ArrayCreate --
X *
X *    Given a hash table with one-word keys, and a one-word key, find
X *    the entry with a matching key.  If there is no matching entry,
X *    then create a new entry that does match.
X *
X * Results:
X *    The return value is a pointer to the matching entry.  If this
X *    is a newly-created entry, then *newPtr will be set to a non-zero
X *    value;  otherwise *newPtr will be set to 0.  If this is a new
X *    entry the value stored in the entry will initially be 0.
X *
X * Side effects:
X *    A new entry may be added to the hash table.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic Tcl_HashEntry *
XArrayCreate(tablePtr, key, newPtr)
X    Tcl_HashTable *tablePtr;    /* Table in which to lookup entry. */
X    register char *key;        /* Key to use to find or create matching
X                 * entry. */
X    int *newPtr;        /* Store info here telling whether a new
X                 * entry was created. */
X{
X    register Tcl_HashEntry *hPtr;
X    int *arrayPtr = (int *) key;
X    register int *iPtr1, *iPtr2;
X    int index, count;
X
X    for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr;
X        count > 0; count--, iPtr1++) {
X    index += *iPtr1;
X    }
X    index = RANDOM_INDEX(tablePtr, index);
X
X    /*
X     * Search all of the entries in the appropriate bucket.
X     */
X
X    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
X        hPtr = hPtr->nextPtr) {
X    for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words,
X        count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
X        if (count == 0) {
X        *newPtr = 0;
X        return hPtr;
X        }
X        if (*iPtr1 != *iPtr2) {
X        break;
X        }
X    }
X    }
X
X    /*
X     * Entry not found.  Add a new one to the bucket.
X     */
X
X    *newPtr = 1;
X    hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)
X        + (tablePtr->keyType*sizeof(int)) - 4));
X    hPtr->tablePtr = tablePtr;
X    hPtr->bucketPtr = &(tablePtr->buckets[index]);
X    hPtr->nextPtr = *hPtr->bucketPtr;
X    hPtr->clientData = 0;
X    for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, count = tablePtr->keyType;
X        count > 0; count--, iPtr1++, iPtr2++) {
X    *iPtr2 = *iPtr1;
X    }
X    *hPtr->bucketPtr = hPtr;
X    tablePtr->numEntries++;
X
X    /*
X     * If the table has exceeded a decent size, rebuild it with many
X     * more buckets.
X     */
X
X    if (tablePtr->numEntries >= tablePtr->rebuildSize) {
X    RebuildTable(tablePtr);
X    }
X    return hPtr;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * BogusFind --
X *
X *    This procedure is invoked when an Tcl_FindHashEntry is called
X *    on a table that has been deleted.
X *
X * Results:
X *    If panic returns (which it shouldn't) this procedure returns
X *    NULL.
X *
X * Side effects:
X *    Generates a panic.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xstatic Tcl_HashEntry *
XBogusFind(tablePtr, key)
X    Tcl_HashTable *tablePtr;    /* Table in which to lookup entry. */
X    char *key;            /* Key to use to find matching entry. */
X{
X    panic("called Tcl_FindHashEntry on deleted table");
X    return NULL;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * BogusCreate --
X *
X *    This procedure is invoked when an Tcl_CreateHashEntry is called
X *    on a table that has been deleted.
X *
X * Results:
X *    If panic returns (which it shouldn't) this procedure returns
X *    NULL.
X *
X * Side effects:
X *    Generates a panic.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xstatic Tcl_HashEntry *
XBogusCreate(tablePtr, key, newPtr)
X    Tcl_HashTable *tablePtr;    /* Table in which to lookup entry. */
X    char *key;            /* Key to use to find or create matching
X                 * entry. */
X    int *newPtr;        /* Store info here telling whether a new
X                 * entry was created. */
X{
X    panic("called Tcl_CreateHashEntry on deleted table");
X    return NULL;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * RebuildTable --
X *
X *    This procedure is invoked when the ratio of entries to hash
X *    buckets becomes too large.  It creates a new table with a
X *    larger bucket array and moves all of the entries into the
X *    new table.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    Memory gets reallocated and entries get re-hashed to new
X *    buckets.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic void
XRebuildTable(tablePtr)
X    register Tcl_HashTable *tablePtr;    /* Table to enlarge. */
X{
X    int oldSize, count, index;
X    Tcl_HashEntry **oldBuckets;
X    register Tcl_HashEntry **oldChainPtr, **newChainPtr;
X    register Tcl_HashEntry *hPtr;
X
X    oldSize = tablePtr->numBuckets;
X    oldBuckets = tablePtr->buckets;
X
X    /*
X     * Allocate and initialize the new bucket array, and set up
X     * hashing constants for new array size.
X     */
X
X    tablePtr->numBuckets *= 4;
X    tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned)
X        (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)));
X    for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
X        count > 0; count--, newChainPtr++) {
X    *newChainPtr = NULL;
X    }
X    tablePtr->rebuildSize *= 4;
X    tablePtr->downShift -= 2;
X    tablePtr->mask = (tablePtr->mask << 2) + 3;
X
X    /*
X     * Rehash all of the existing entries into the new bucket array.
X     */
X
X    for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) {
X    for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) {
X        *oldChainPtr = hPtr->nextPtr;
X        if (tablePtr->keyType == TCL_STRING_KEYS) {
X        index = HashString(hPtr->key.string) & tablePtr->mask;
X        } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
X        index = RANDOM_INDEX(tablePtr, hPtr->key.oneWordValue);
X        } else {
X        register int *iPtr;
X        int count;
X
X        for (index = 0, count = tablePtr->keyType,
X            iPtr = hPtr->key.words; count > 0; count--, iPtr++) {
X            index += *iPtr;
X        }
X        index = RANDOM_INDEX(tablePtr, index);
X        }
X        hPtr->bucketPtr = &(tablePtr->buckets[index]);
X        hPtr->nextPtr = *hPtr->bucketPtr;
X        *hPtr->bucketPtr = hPtr;
X    }
X    }
X
X    /*
X     * Free up the old bucket array, if it was dynamically allocated.
X     */
X
X    if (oldBuckets != tablePtr->staticBuckets) {
X    ckfree((char *) oldBuckets);
X    }
X}
END_OF_FILE
if test 25018 -ne `wc -c <'tcl6.1/tclHash.c'`; then
    echo shar: \"'tcl6.1/tclHash.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclHash.c'
fi
echo shar: End of archive 16 \(of 33\).
cp /dev/null ark16isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 33 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0

exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].