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

Text File | 1991-11-15 | 35.1 KB | 1,227 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Karl Lehenbauer)
Subject:  v25i092:  tcl - tool command language, version 6.1, Part24/33
Message-ID: <[e-mail]>
X-Md4-Signature: 08422b25a4efa15eaae789f3488c2154
Date: Fri, 15 Nov 1991 22:54:23 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Karl Lehenbauer)
Posting-number: Volume 25, Issue 92
Archive-name: tcl/part24
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 24 (of 33)."
# Contents:  tcl6.1/tclParse.c
# Wrapped by karl@one on Tue Nov 12 19:44:29 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tcl6.1/tclParse.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'tcl6.1/tclParse.c'\"
else
echo shar: Extracting \"'tcl6.1/tclParse.c'\" \(32623 characters\)
sed "s/^X//" >'tcl6.1/tclParse.c' <<'END_OF_FILE'
X/*
X * tclParse.c --
X *
X *    This file contains a collection of procedures that are used
X *    to parse Tcl commands or parts of commands (like quoted
X *    strings or nested sub-commands).
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 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/tclParse.c,v 1.20 91/10/31 16:41:52 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include "tclInt.h"
X
X/*
X * The following table assigns a type to each character.  Only types
X * meaningful to Tcl parsing are represented here.  The table indexes
X * all 256 characters, with the negative ones first, then the positive
X * ones.
X */
X
Xchar tclTypeTable[] = {
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_COMMAND_END,   TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_SPACE,         TCL_COMMAND_END,   TCL_SPACE,
X    TCL_SPACE,         TCL_SPACE,         TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_SPACE,         TCL_NORMAL,        TCL_QUOTE,         TCL_NORMAL,
X    TCL_DOLLAR,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_COMMAND_END,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_OPEN_BRACKET,
X    TCL_BACKSLASH,     TCL_COMMAND_END,   TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,
X    TCL_NORMAL,        TCL_NORMAL,        TCL_NORMAL,        TCL_OPEN_BRACE,
X    TCL_NORMAL,        TCL_CLOSE_BRACE,   TCL_NORMAL,        TCL_NORMAL,
X};
X
X/*
X * Function prototypes for procedures local to this file:
X */
X
Xstatic char *    QuoteEnd _ANSI_ARGS_((char *string, int term));
Xstatic char *    VarNameEnd _ANSI_ARGS_((char *string));
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_Backslash --
X *
X *    Figure out how to handle a backslash sequence.
X *
X * Results:
X *    The return value is the character that should be substituted
X *    in place of the backslash sequence that starts at src, or 0
X *    if the backslash sequence should be replace by nothing (e.g.
X *    backslash followed by newline).  If readPtr isn't NULL then
X *    it is filled in with a count of the number of characters in
X *    the backslash sequence.  Note:  if the backslash isn't followed
X *    by characters that are understood here, then the backslash
X *    sequence is only considered to be one character long, and it
X *    is replaced by a backslash char.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar
XTcl_Backslash(src, readPtr)
X    char *src;            /* Points to the backslash character of
X                 * a backslash sequence. */
X    int *readPtr;        /* Fill in with number of characters read
X                 * from src, unless NULL. */
X{
X    register char *p = src+1;
X    char result;
X    int count;
X
X    count = 2;
X
X    switch (*p) {
X    case 'b':
X        result = '\b';
X        break;
X    case 'e':
X        result = 033;
X        break;
X    case 'f':
X        result = '\f';
X        break;
X    case 'n':
X        result = '\n';
X        break;
X    case 'r':
X        result = '\r';
X        break;
X    case 't':
X        result = '\t';
X        break;
X    case 'v':
X        result = '\v';
X        break;
X    case 'C':
X        p++;
X        if (isspace(*p) || (*p == 0)) {
X        result = 'C';
X        count = 1;
X        break;
X        }
X        count = 3;
X        if (*p == 'M') {
X        p++;
X        if (isspace(*p) || (*p == 0)) {
X            result = 'M' & 037;
X            break;
X        }
X        count = 4;
X        result = (*p & 037) | 0200;
X        break;
X        }
X        count = 3;
X        result = *p & 037;
X        break;
X    case 'M':
X        p++;
X        if (isspace(*p) || (*p == 0)) {
X        result = 'M';
X        count = 1;
X        break;
X        }
X        count = 3;
X        result = *p + 0200;
X        break;
X    case '}':
X    case '{':
X    case ']':
X    case '[':
X    case '$':
X    case ' ':
X    case ';':
X    case '"':
X    case '\\':
X        result = *p;
X        break;
X    case '\n':
X        result = 0;
X        break;
X    default:
X        if (isdigit(*p)) {
X        result = *p - '0';
X        p++;
X        if (!isdigit(*p)) {
X            break;
X        }
X        count = 3;
X        result = (result << 3) + (*p - '0');
X        p++;
X        if (!isdigit(*p)) {
X            break;
X        }
X        count = 4;
X        result = (result << 3) + (*p - '0');
X        break;
X        }
X        result = '\\';
X        count = 1;
X        break;
X    }
X
X    if (readPtr != NULL) {
X    *readPtr = count;
X    }
X    return result;
X}
X
X/*
X *--------------------------------------------------------------
X *
X * TclParseQuotes --
X *
X *    This procedure parses a double-quoted string such as a
X *    quoted Tcl command argument or a quoted value in a Tcl
X *    expression.  This procedure is also used to parse array
X *    element names within parentheses, or anything else that
X *    needs all the substitutions that happen in quotes.
X *
X * Results:
X *    The return value is a standard Tcl result, which is
X *    TCL_OK unless there was an error while parsing the
X *    quoted string.  If an error occurs then interp->result
X *    contains a standard error message.  *TermPtr is filled
X *    in with the address of the character just after the
X *    last one successfully processed;  this is usually the
X *    character just after the matching close-quote.  The
X *    fully-substituted contents of the quotes are stored in
X *    standard fashion in *pvPtr, null-terminated with
X *    pvPtr->next pointing to the terminating null character.
X *
X * Side effects:
X *    The buffer space in pvPtr may be enlarged by calling its
X *    expandProc.
X *
X *--------------------------------------------------------------
X */
X
Xint
XTclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr)
X    Tcl_Interp *interp;        /* Interpreter to use for nested command
X                 * evaluations and error messages. */
X    char *string;        /* Character just after opening double-
X                 * quote. */
X    int termChar;        /* Character that terminates "quoted" string
X                 * (usually double-quote, but sometimes
X                 * right-paren or something else). */
X    int flags;            /* Flags to pass to nested Tcl_Eval calls. */
X    char **termPtr;        /* Store address of terminating character
X                 * here. */
X    ParseValue *pvPtr;        /* Information about where to place
X                 * fully-substituted result of parse. */
X{
X    register char *src, *dst, c;
X
X    src = string;
X    dst = pvPtr->next;
X
X    while (1) {
X    if (dst == pvPtr->end) {
X        /*
X         * Target buffer space is about to run out.  Make more space.
X         */
X
X        pvPtr->next = dst;
X        (*pvPtr->expandProc)(pvPtr, 1);
X        dst = pvPtr->next;
X    }
X
X    c = *src;
X    src++;
X    if (c == termChar) {
X        *dst = '\0';
X        pvPtr->next = dst;
X        *termPtr = src;
X        return TCL_OK;
X    } else if (CHAR_TYPE(c) == TCL_NORMAL) {
X        copy:
X        *dst = c;
X        dst++;
X        continue;
X    } else if (c == '$') {
X        int length;
X        char *value;
X
X        value = Tcl_ParseVar(interp, src-1, termPtr);
X        if (value == NULL) {
X        return TCL_ERROR;
X        }
X        src = *termPtr;
X        length = strlen(value);
X        if ((pvPtr->end - dst) <= length) {
X        pvPtr->next = dst;
X        (*pvPtr->expandProc)(pvPtr, length);
X        dst = pvPtr->next;
X        }
X        strcpy(dst, value);
X        dst += length;
X        continue;
X    } else if (c == '[') {
X        int result;
X
X        pvPtr->next = dst;
X        result = TclParseNestedCmd(interp, src, flags, termPtr, pvPtr);
X        if (result != TCL_OK) {
X        return result;
X        }
X        src = *termPtr;
X        dst = pvPtr->next;
X        continue;
X    } else if (c == '\\') {
X        int numRead;
X
X        src--;
X        *dst = Tcl_Backslash(src, &numRead);
X        if (*dst != 0) {
X        dst++;
X        }
X        src += numRead;
X        continue;
X    } else if (c == '\0') {
X        Tcl_ResetResult(interp);
X        sprintf(interp->result, "missing %c", termChar);
X        *termPtr = string-1;
X        return TCL_ERROR;
X    } else {
X        goto copy;
X    }
X    }
X}
X
X/*
X *--------------------------------------------------------------
X *
X * TclParseNestedCmd --
X *
X *    This procedure parses a nested Tcl command between
X *    brackets, returning the result of the command.
X *
X * Results:
X *    The return value is a standard Tcl result, which is
X *    TCL_OK unless there was an error while executing the
X *    nested command.  If an error occurs then interp->result
X *    contains a standard error message.  *TermPtr is filled
X *    in with the address of the character just after the
X *    last one processed;  this is usually the character just
X *    after the matching close-bracket, or the null character
X *    at the end of the string if the close-bracket was missing
X *    (a missing close bracket is an error).  The result returned
X *    by the command is stored in standard fashion in *pvPtr,
X *    null-terminated, with pvPtr->next pointing to the null
X *    character.
X *
X * Side effects:
X *    The storage space at *pvPtr may be expanded.
X *
X *--------------------------------------------------------------
X */
X
Xint
XTclParseNestedCmd(interp, string, flags, termPtr, pvPtr)
X    Tcl_Interp *interp;        /* Interpreter to use for nested command
X                 * evaluations and error messages. */
X    char *string;        /* Character just after opening bracket. */
X    int flags;            /* Flags to pass to nested Tcl_Eval. */
X    char **termPtr;        /* Store address of terminating character
X                 * here. */
X    register ParseValue *pvPtr;    /* Information about where to place
X                 * result of command. */
X{
X    int result, length, shortfall;
X    Interp *iPtr = (Interp *) interp;
X
X    result = Tcl_Eval(interp, string, flags | TCL_BRACKET_TERM, termPtr);
X    if (result != TCL_OK) {
X    /*
X     * The increment below results in slightly cleaner message in
X     * the errorInfo variable (the close-bracket will appear).
X     */
X
X    if (**termPtr == ']') {
X        *termPtr += 1;
X    }
X    return result;
X    }
X    (*termPtr) += 1;
X    length = strlen(iPtr->result);
X    shortfall = length + 1 - (pvPtr->end - pvPtr->next);
X    if (shortfall > 0) {
X    (*pvPtr->expandProc)(pvPtr, shortfall);
X    }
X    strcpy(pvPtr->next, iPtr->result);
X    pvPtr->next += length;
X    Tcl_FreeResult(iPtr);
X    iPtr->result = iPtr->resultSpace;
X    iPtr->resultSpace[0] = '\0';
X    return TCL_OK;
X}
X
X/*
X *--------------------------------------------------------------
X *
X * TclParseBraces --
X *
X *    This procedure scans the information between matching
X *    curly braces.
X *
X * Results:
X *    The return value is a standard Tcl result, which is
X *    TCL_OK unless there was an error while parsing string.
X *    If an error occurs then interp->result contains a
X *    standard error message.  *TermPtr is filled
X *    in with the address of the character just after the
X *    last one successfully processed;  this is usually the
X *    character just after the matching close-brace.  The
X *    information between curly braces is stored in standard
X *    fashion in *pvPtr, null-terminated with pvPtr->next
X *    pointing to the terminating null character.
X *
X * Side effects:
X *    The storage space at *pvPtr may be expanded.
X *
X *--------------------------------------------------------------
X */
X
Xint
XTclParseBraces(interp, string, termPtr, pvPtr)
X    Tcl_Interp *interp;        /* Interpreter to use for nested command
X                 * evaluations and error messages. */
X    char *string;        /* Character just after opening bracket. */
X    char **termPtr;        /* Store address of terminating character
X                 * here. */
X    register ParseValue *pvPtr;    /* Information about where to place
X                 * result of command. */
X{
X    int level;
X    register char *src, *dst, *end;
X    register char c;
X
X    src = string;
X    dst = pvPtr->next;
X    end = pvPtr->end;
X    level = 1;
X
X    /*
X     * Copy the characters one at a time to the result area, stopping
X     * when the matching close-brace is found.
X     */
X
X    while (1) {
X    c = *src;
X    src++;
X    if (dst == end) {
X        pvPtr->next = dst;
X        (*pvPtr->expandProc)(pvPtr, 20);
X        dst = pvPtr->next;
X        end = pvPtr->end;
X    }
X    *dst = c;
X    dst++;
X    if (CHAR_TYPE(c) == TCL_NORMAL) {
X        continue;
X    } else if (c == '{') {
X        level++;
X    } else if (c == '}') {
X        level--;
X        if (level == 0) {
X        dst--;            /* Don't copy the last close brace. */
X        break;
X        }
X    } else if (c == '\\') {
X        int count;
X
X        /*
X         * Must always squish out backslash-newlines, even when in
X         * braces.  This is needed so that this sequence can appear
X         * anywhere in a command, such as the middle of an expression.
X         */
X
X        if (*src == '\n') {
X        dst--;
X        src++;
X        } else {
X        (void) Tcl_Backslash(src-1, &count);
X        while (count > 1) {
X                    if (dst == end) {
X                        pvPtr->next = dst;
X                        (*pvPtr->expandProc)(pvPtr, 20);
X                        dst = pvPtr->next;
X                        end = pvPtr->end;
X                    }
X            *dst = *src;
X            dst++;
X            src++;
X            count--;
X        }
X        }
X    } else if (c == '\0') {
X        Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);
X        *termPtr = string-1;
X        return TCL_ERROR;
X    }
X    }
X
X    *dst = '\0';
X    pvPtr->next = dst;
X    *termPtr = src;
X    return TCL_OK;
X}
X
X/*
X *--------------------------------------------------------------
X *
X * TclParseWords --
X *
X *    This procedure parses one or more words from a command
X *    string and creates argv-style pointers to fully-substituted
X *    copies of those words.
X *
X * Results:
X *    The return value is a standard Tcl result.
X *
X *    *argcPtr is modified to hold a count of the number of words
X *    successfully parsed, which may be 0.  At most maxWords words
X *    will be parsed.  If 0 <= *argcPtr < maxWords then it
X *    means that a command separator was seen.  If *argcPtr
X *    is maxWords then it means that a command separator was
X *    not seen yet.
X *
X *    *TermPtr is filled in with the address of the character
X *    just after the last one successfully processed in the
X *    last word.  This is either the command terminator (if
X *    *argcPtr < maxWords), the character just after the last
X *    one in a word (if *argcPtr is maxWords), or the vicinity
X *    of an error (if the result is not TCL_OK).
X *
X *    The pointers at *argv are filled in with pointers to the
X *    fully-substituted words, and the actual contents of the
X *    words are copied to the buffer at pvPtr.
X *
X *    If an error occurrs then an error message is left in
X *    interp->result and the information at *argv, *argcPtr,
X *    and *pvPtr may be incomplete.
X *
X * Side effects:
X *    The buffer space in pvPtr may be enlarged by calling its
X *    expandProc.
X *
X *--------------------------------------------------------------
X */
X
Xint
XTclParseWords(interp, string, flags, maxWords, termPtr, argcPtr, argv, pvPtr)
X    Tcl_Interp *interp;        /* Interpreter to use for nested command
X                 * evaluations and error messages. */
X    char *string;        /* First character of word. */
X    int flags;            /* Flags to control parsing (same values as
X                 * passed to Tcl_Eval). */
X    int maxWords;        /* Maximum number of words to parse. */
X    char **termPtr;        /* Store address of terminating character
X                 * here. */
X    int *argcPtr;        /* Filled in with actual number of words
X                 * parsed. */
X    char **argv;        /* Store addresses of individual words here. */
X    register ParseValue *pvPtr;    /* Information about where to place
X                 * fully-substituted word. */
X{
X    register char *src, *dst;
X    register char c;
X    int type, result, argc;
X    char *oldBuffer;        /* Used to detect when pvPtr's buffer gets
X                 * reallocated, so we can adjust all of the
X                 * argv pointers. */
X
X    src = string;
X    oldBuffer = pvPtr->buffer;
X    dst = pvPtr->next;
X    for (argc = 0; argc < maxWords; argc++) {
X    argv[argc] = dst;
X
X    /*
X     * Skip leading space.
X     */
X
X    skipSpace:
X    c = *src;
X    type = CHAR_TYPE(c);
X    while (type == TCL_SPACE) {
X        src++;
X        c = *src;
X        type = CHAR_TYPE(c);
X    }
X
X    /*
X     * Handle the normal case (i.e. no leading double-quote or brace).
X     */
X
X    if (type == TCL_NORMAL) {
X        normalArg:
X        while (1) {
X        if (dst == pvPtr->end) {
X            /*
X             * Target buffer space is about to run out.  Make
X             * more space.
X             */
X
X            pvPtr->next = dst;
X            (*pvPtr->expandProc)(pvPtr, 1);
X            dst = pvPtr->next;
X        }
X
X        if (type == TCL_NORMAL) {
X            copy:
X            *dst = c;
X            dst++;
X            src++;
X        } else if (type == TCL_SPACE) {
X            goto wordEnd;
X        } else if (type == TCL_DOLLAR) {
X            int length;
X            char *value;
X
X            value = Tcl_ParseVar(interp, src, termPtr);
X            if (value == NULL) {
X            return TCL_ERROR;
X            }
X            src = *termPtr;
X            length = strlen(value);
X            if ((pvPtr->end - dst) <= length) {
X            pvPtr->next = dst;
X            (*pvPtr->expandProc)(pvPtr, length);
X            dst = pvPtr->next;
X            }
X            strcpy(dst, value);
X            dst += length;
X        } else if (type == TCL_COMMAND_END) {
X            if ((c == ']') && !(flags & TCL_BRACKET_TERM)) {
X            goto copy;
X            }
X
X            /*
X             * End of command;  simulate a word-end first, so
X             * that the end-of-command can be processed as the
X             * first thing in a new word.
X             */
X
X            goto wordEnd;
X        } else if (type == TCL_OPEN_BRACKET) {
X            pvPtr->next = dst;
X            result = TclParseNestedCmd(interp, src+1, flags, termPtr,
X                pvPtr);
X            if (result != TCL_OK) {
X            return result;
X            }
X            src = *termPtr;
X            dst = pvPtr->next;
X        } else if (type == TCL_BACKSLASH) {
X            int numRead;
X
X            *dst = Tcl_Backslash(src, &numRead);
X            if (*dst != 0) {
X            dst++;
X            }
X            src += numRead;
X        } else {
X            goto copy;
X        }
X        c = *src;
X        type = CHAR_TYPE(c);
X        }
X    } else {
X
X        /*
X         * Check for the end of the command.
X         */
X
X        if (type == TCL_COMMAND_END) {
X        if (flags & TCL_BRACKET_TERM) {
X            if (c == '\0') {
X            Tcl_SetResult(interp, "missing close-bracket",
X                TCL_STATIC);
X            return TCL_ERROR;
X            }
X        } else {
X            if (c == ']') {
X            goto normalArg;
X            }
X        }
X        goto done;
X        }
X
X        /*
X         * Now handle the special cases: open braces, double-quotes,
X         * and backslash-newline.
X         */
X
X        pvPtr->next = dst;
X        if (type == TCL_QUOTE) {
X        result = TclParseQuotes(interp, src+1, '"', flags,
X            termPtr, pvPtr);
X        } else if (type == TCL_OPEN_BRACE) {
X        result = TclParseBraces(interp, src+1, termPtr, pvPtr);
X        } else if ((type == TCL_BACKSLASH) && (src[1] == '\n')) {
X        src += 2;
X        goto skipSpace;
X        } else {
X        goto normalArg;
X        }
X        if (result != TCL_OK) {
X        return result;
X        }
X
X        /*
X         * Back from quotes or braces;  make sure that the terminating
X         * character was the end of the word.  Have to be careful here
X         * to handle continuation lines (i.e. lines ending in backslash).
X         */
X
X        c = **termPtr;
X        if ((c == '\\') && ((*termPtr)[1] == '\n')) {
X        c = (*termPtr)[2];
X        }
X        type = CHAR_TYPE(c);
X        if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
X        if (*src == '"') {
X            Tcl_SetResult(interp, "extra characters after close-quote",
X                TCL_STATIC);
X        } else {
X            Tcl_SetResult(interp, "extra characters after close-brace",
X                TCL_STATIC);
X        }
X        return TCL_ERROR;
X        }
X        src = *termPtr;
X        dst = pvPtr->next;
X
X    }
X
X    /*
X     * We're at the end of a word, so add a null terminator.  Then
X     * see if the buffer was re-allocated during this word.  If so,
X     * update all of the argv pointers.
X     */
X
X    wordEnd:
X    *dst = '\0';
X    dst++;
X    if (oldBuffer != pvPtr->buffer) {
X        int i;
X
X        for (i = 0; i <= argc; i++) {
X        argv[i] = pvPtr->buffer + (argv[i] - oldBuffer);
X        }
X        oldBuffer = pvPtr->buffer;
X    }
X    }
X
X    done:
X    pvPtr->next = dst;
X    *termPtr = src;
X    *argcPtr = argc;
X    return TCL_OK;
X}
X
X/*
X *--------------------------------------------------------------
X *
X * TclExpandParseValue --
X *
X *    This procedure is commonly used as the value of the
X *    expandProc in a ParseValue.  It uses malloc to allocate
X *    more space for the result of a parse.
X *
X * Results:
X *    The buffer space in *pvPtr is reallocated to something
X *    larger, and if pvPtr->clientData is non-zero the old
X *    buffer is freed.  Information is copied from the old
X *    buffer to the new one.
X *
X * Side effects:
X *    None.
X *
X *--------------------------------------------------------------
X */
X
Xvoid
XTclExpandParseValue(pvPtr, needed)
X    register ParseValue *pvPtr;        /* Information about buffer that
X                     * must be expanded.  If the clientData
X                     * in the structure is non-zero, it
X                     * means that the current buffer is
X                     * dynamically allocated. */
X    int needed;                /* Minimum amount of additional space
X                     * to allocate. */
X{
X    int newSpace;
X    char *new;
X
X    /*
X     * Either double the size of the buffer or add enough new space
X     * to meet the demand, whichever produces a larger new buffer.
X     */
X
X    newSpace = (pvPtr->end - pvPtr->buffer) + 1;
X    if (newSpace < needed) {
X    newSpace += needed;
X    } else {
X    newSpace += newSpace;
X    }
X    new = (char *) ckalloc((unsigned) newSpace);
X
X    /*
X     * Copy from old buffer to new, free old buffer if needed, and
X     * mark new buffer as malloc-ed.
X     */
X
X    memcpy((VOID *) new, (VOID *) pvPtr->buffer, pvPtr->next - pvPtr->buffer);
X    pvPtr->next = new + (pvPtr->next - pvPtr->buffer);
X    if (pvPtr->clientData != 0) {
X    ckfree(pvPtr->buffer);
X    }
X    pvPtr->buffer = new;
X    pvPtr->end = new + newSpace - 1;
X    pvPtr->clientData = (ClientData) 1;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * TclWordEnd --
X *
X *    Given a pointer into a Tcl command, find the end of the next
X *    word of the command.
X *
X * Results:
X *    The return value is a pointer to the character just after the
X *    last one that's part of the word pointed to by "start".  This
X *    may be the address of the NULL character at the end of the
X *    string.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTclWordEnd(start, nested)
X    char *start;        /* Beginning of a word of a Tcl command. */
X    int nested;            /* Zero means this is a top-level command.
X                 * One means this is a nested command (close
X                 * brace is a word terminator). */
X{
X    register char *p;
X    int count;
X
X    p = start;
X    while (isspace(*p)) {
X    p++;
X    }
X
X    /*
X     * Handle words beginning with a double-quote or a brace.
X     */
X
X    if (*p == '"') {
X    p = QuoteEnd(p+1, '"');
X    } else if (*p == '{') {
X    int braces = 1;
X    while (braces != 0) {
X        p++;
X        while (*p == '\\') {
X        (void) Tcl_Backslash(p, &count);
X        p += count;
X        }
X        if (*p == '}') {
X        braces--;
X        } else if (*p == '{') {
X        braces++;
X        } else if (*p == 0) {
X        return p;
X        }
X    }
X    }
X
X    /*
X     * Handle words that don't start with a brace or double-quote.
X     * This code is also invoked if the word starts with a brace or
X     * double-quote and there is garbage after the closing brace or
X     * quote.  This is an error as far as Tcl_Eval is concerned, but
X     * for here the garbage is treated as part of the word.
X     */
X
X    while (*p != 0) {
X    if (*p == '[') {
X        p++;
X        while ((*p != ']') && (*p != 0)) {
X        p = TclWordEnd(p, 1);
X        }
X        if (*p == ']') {
X        p++;
X        }
X    } else if (*p == '\\') {
X        (void) Tcl_Backslash(p, &count);
X        p += count;
X    } else if (*p == '$') {
X        p = VarNameEnd(p);
X    } else if (*p == ';') {
X        /*
X         * Note:  semi-colon terminates a word
X         * and also counts as a word by itself.
X         */
X
X        if (p == start) {
X        p++;
X        }
X        break;
X    } else if (isspace(*p)) {
X        break;
X    } else if ((*p == ']') && nested) {
X        break;
X    } else {
X        p++;
X    }
X    }
X    return p;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * QuoteEnd --
X *
X *    Given a pointer to a string that obeys the parsing conventions
X *    for quoted things in Tcl, find the end of that quoted thing.
X *    The actual thing may be a quoted argument or a parenthesized
X *    index name.
X *
X * Results:
X *    The return value is a pointer to the character just after the
X *    last one that is part of the quoted string.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic char *
XQuoteEnd(string, term)
X    char *string;        /* Pointer to character just after opening
X                 * "quote". */
X    int term;            /* This character will terminate the
X                 * quoted string (e.g. '"' or ')'). */
X{
X    register char *p = string;
X    int count;
X
X    while ((*p != 0) && (*p != term)) {
X    if (*p == '\\') {
X        (void) Tcl_Backslash(p, &count);
X        p += count;
X    } else if (*p == '[') {
X        p++;
X        while ((*p != ']') && (*p != 0)) {
X        p = TclWordEnd(p, 1);
X        }
X        if (*p == ']') {
X        p++;
X        }
X    } else if (*p == '$') {
X        p = VarNameEnd(p);
X    } else {
X        p++;
X    }
X    }
X    return p;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * VarNameEnd --
X *
X *    Given a pointer to a variable reference using $-notation, find
X *    the end of the variable name spec.
X *
X * Results:
X *    The return value is a pointer to the character just after the
X *    last one that is part of the variable name.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic char *
XVarNameEnd(string)
X    char *string;        /* Pointer to dollar-sign character. */
X{
X    register char *p = string+1;
X
X    if (*p == '{') {
X    do {
X        p++;
X    } while ((*p != '}') && (*p != 0));
X    } else {
X    while (isalnum(*p) || (*p == '_')) {
X        p++;
X    }
X    if ((*p == '(') && (p != string+1)) {
X        p = QuoteEnd(p+1, ')');
X    }
X    }
X    return p;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ParseVar --
X *
X *    Given a string starting with a $ sign, parse off a variable
X *    name and return its value.
X *
X * Results:
X *    The return value is the contents of the variable given by
X *    the leading characters of string.  If termPtr isn't NULL,
X *    *termPtr gets filled in with the address of the character
X *    just after the last one in the variable specifier.  If the
X *    variable doesn't exist, then the return value is NULL and
X *    an error message will be left in interp->result.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_ParseVar(interp, string, termPtr)
X    Tcl_Interp *interp;            /* Context for looking up variable. */
X    register char *string;        /* String containing variable name.
X                     * First character must be "$". */
X    char **termPtr;            /* If non-NULL, points to word to fill
X                     * in with character just after last
X                     * one in the variable specifier. */
X
X{
X    char *name1, *name1End, c, *result;
X    register char *name2;
X#define NUM_CHARS 200
X    char copyStorage[NUM_CHARS];
X    ParseValue pv;
X
X    /*
X     * There are three cases:
X     * 1. The $ sign is followed by an open curly brace.  Then the variable
X     *    name is everything up to the next close curly brace, and the
X     *    variable is a scalar variable.
X     * 2. The $ sign is not followed by an open curly brace.  Then the
X     *    variable name is everything up to the next character that isn't
X     *    a letter, digit, or underscore.  If the following character is an
X     *    open parenthesis, then the information between parentheses is
X     *    the array element name, which can include any of the substitutions
X     *    permissible between quotes.
X     * 3. The $ sign is followed by something that isn't a letter, digit,
X     *    or underscore:  in this case, there is no variable name, and "$"
X     *    is returned.
X     */
X
X    name2 = NULL;
X    string++;
X    if (*string == '{') {
X    string++;
X    name1 = string;
X    while (*string != '}') {
X        if (*string == 0) {
X        Tcl_SetResult(interp, "missing close-brace for variable name",
X            TCL_STATIC);
X        return NULL;
X        }
X        string++;
X    }
X    name1End = string;
X    string++;
X    } else {
X    name1 = string;
X    while (isalnum(*string) || (*string == '_')) {
X        string++;
X    }
X    if (string == name1) {
X        if (termPtr != 0) {
X        *termPtr = string;
X        }
X        return "$";
X    }
X    name1End = string;
X    if (*string == '(') {
X        char *end;
X
X        /*
X         * Perform substitutions on the array element name, just as
X         * is done for quotes.
X         */
X
X        pv.buffer = pv.next = copyStorage;
X        pv.end = copyStorage + NUM_CHARS - 1;
X        pv.expandProc = TclExpandParseValue;
X        pv.clientData = (ClientData) NULL;
X        if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv)
X            != TCL_OK) {
X        char msg[100];
X        sprintf(msg, "\n    (parsing index for array \"%.*s\")",
X            string-name1, name1);
X        Tcl_AddErrorInfo(interp, msg);
X        result = NULL;
X        name2 = pv.buffer;
X        goto done;
X        }
X        string = end;
X        name2 = pv.buffer;
X    }
X    }
X    if (termPtr != 0) {
X    *termPtr = string;
X    }
X
X    c = *name1End;
X    *name1End = 0;
X    result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG);
X    *name1End = c;
X
X    done:
X    if ((name2 != NULL) && (pv.buffer != copyStorage)) {
X    ckfree(pv.buffer);
X    }
X    return result;
X}
END_OF_FILE
if test 32623 -ne `wc -c <'tcl6.1/tclParse.c'`; then
    echo shar: \"'tcl6.1/tclParse.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclParse.c'
fi
echo shar: End of archive 24 \(of 33\).
cp /dev/null ark24isdone
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].