tclutil.c

tcl是工具命令语言

     * some other interpreter so that this interpreter's value is
     * out of date.
     */

    Tcl_MutexLock(&precisionMutex);

    if (flags & TCL_TRACE_READS) {
	Tcl_SetVar2(interp, name1, name2, precisionString,
		flags & TCL_GLOBAL_ONLY);
	Tcl_MutexUnlock(&precisionMutex);
	return (char *) NULL;
    }

    /*
     * The variable is being written.  Check the new value and disallow
     * it if it isn't reasonable or if this is a safe interpreter (we
     * don't want safe interpreters messing up the precision of other
     * interpreters).
     */

    if (Tcl_IsSafe(interp)) {
	Tcl_SetVar2(interp, name1, name2, precisionString,
		flags & TCL_GLOBAL_ONLY);
	Tcl_MutexUnlock(&precisionMutex);
	return "can't modify precision from a safe interpreter";
    }
    value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
    if (value == NULL) {
	value = "";
    }
    prec = strtoul(value, &end, 10);
    if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
	    (end == value) || (*end != 0)) {
	Tcl_SetVar2(interp, name1, name2, precisionString,
		flags & TCL_GLOBAL_ONLY);
	Tcl_MutexUnlock(&precisionMutex);
	return "improper value for precision";
    }
    TclFormatInt(precisionString, prec);
    sprintf(precisionFormat, "%%.%dg", prec);
    Tcl_MutexUnlock(&precisionMutex);
    return (char *) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclNeedSpace --
 *
 *	This procedure checks to see whether it is appropriate to
 *	add a space before appending a new list element to an
 *	existing string.
 *
 * Results:
 *	The return value is 1 if a space is appropriate, 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclNeedSpace(start, end)
    CONST char *start;		/* First character in string. */
    CONST char *end;		/* End of string (place where space will
				 * be added, if appropriate). */
{
    Tcl_UniChar ch;

    /*
     * A space is needed unless either
     * (a) we're at the start of the string, or
     * (b) the trailing characters of the string consist of one or more
     *     open curly braces preceded by a space or extending back to
     *     the beginning of the string.
     * (c) the trailing characters of the string consist of a space
     *	   preceded by a character other than backslash.
     */

    if (end == start) {
	return 0;
    }
    end = Tcl_UtfPrev(end, start);
    if (*end != '{') {
	Tcl_UtfToUniChar(end, &ch);
	/*
	 * Direct char comparison on next line is safe as it is with
	 * a character in the ASCII subset, and so single-byte in UTF8.
	 */
	if (Tcl_UniCharIsSpace(ch) && ((end == start) || (end[-1] != '\\'))) {
	    return 0;
	}
	return 1;
    }
    do {
	if (end == start) {
	    return 0;
	}
	end = Tcl_UtfPrev(end, start);
    } while (*end == '{');
    Tcl_UtfToUniChar(end, &ch);
    if (Tcl_UniCharIsSpace(ch)) {
	return 0;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFormatInt --
 *
 *	This procedure formats an integer into a sequence of decimal digit
 *	characters in a buffer. If the integer is negative, a minus sign is
 *	inserted at the start of the buffer. A null character is inserted at
 *	the end of the formatted characters. It is the caller's
 *	responsibility to ensure that enough storage is available. This
 *	procedure has the effect of sprintf(buffer, "%d", n) but is faster.
 *
 * Results:
 *	An integer representing the number of characters formatted, not
 *	including the terminating \0.
 *
 * Side effects:
 *	The formatted characters are written into the storage pointer to
 *	by the "buffer" argument.
 *
 *----------------------------------------------------------------------
 */

int
TclFormatInt(buffer, n)
    char *buffer;		/* Points to the storage into which the
				 * formatted characters are written. */
    long n;			/* The integer to format. */
{
    long intVal;
    int i;
    int numFormatted, j;
    char *digits = "0123456789";

    /*
     * Check first whether "n" is zero.
     */

    if (n == 0) {
	buffer[0] = '0';
	buffer[1] = 0;
	return 1;
    }

    /*
     * Check whether "n" is the maximum negative value. This is
     * -2^(m-1) for an m-bit word, and has no positive equivalent;
     * negating it produces the same value.
     */

    if (n == -n) {
	sprintf(buffer, "%ld", n);
	return strlen(buffer);
    }

    /*
     * Generate the characters of the result backwards in the buffer.
     */

    intVal = (n < 0? -n : n);
    i = 0;
    buffer[0] = '\0';
    do {
	i++;
	buffer[i] = digits[intVal % 10];
	intVal = intVal/10;
    } while (intVal > 0);
    if (n < 0) {
	i++;
	buffer[i] = '-';
    }
    numFormatted = i;

    /*
     * Now reverse the characters.
     */

    for (j = 0;  j < i;  j++, i--) {
	char tmp = buffer[i];
	buffer[i] = buffer[j];
	buffer[j] = tmp;
    }
    return numFormatted;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLooksLikeInt --
 *
 *	This procedure decides whether the leading characters of a
 *	string look like an integer or something else (such as a
 *	floating-point number or string).
 *
 * Results:
 *	The return value is 1 if the leading characters of p look
 *	like a valid Tcl integer.  If they look like a floating-point
 *	number (e.g. "e01" or "2.4"), or if they don't look like a
 *	number at all, then 0 is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclLooksLikeInt(bytes, length)
    register CONST char *bytes;	/* Points to first byte of the string. */
    int length;			/* Number of bytes in the string. If < 0
				 * bytes up to the first null byte are
				 * considered (if they may appear in an 
				 * integer). */
{
    register CONST char *p;

    if ((bytes == NULL) && (length > 0)) {
	Tcl_Panic("TclLooksLikeInt: cannot scan %d bytes from NULL", length);
    }

    if (length < 0) {
        length = (bytes? strlen(bytes) : 0);
    }

    p = bytes;
    while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */
	length--; p++;
    }
    if (length == 0) {
        return 0;
    }
    if ((*p == '+') || (*p == '-')) {
        p++; length--;
    }

    return (0 != TclParseInteger(p, length));
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetIntForIndex --
 *
 *	This procedure returns an integer corresponding to the list index
 *	held in a Tcl object. The Tcl object's value is expected to be
 *	either an integer or a string of the form "end([+-]integer)?". 
 *
 * Results:
 *	The return value is normally TCL_OK, which means that the index was
 *	successfully stored into the location referenced by "indexPtr".  If
 *	the Tcl object referenced by "objPtr" has the value "end", the
 *	value stored is "endValue". If "objPtr"s values is not of the form
 *	"end([+-]integer)?" and
 *	can not be converted to an integer, TCL_ERROR is returned and, if
 *	"interp" is non-NULL, an error message is left in the interpreter's
 *	result object.
 *
 * Side effects:
 *	The object referenced by "objPtr" might be converted to an
 *	integer, wide integer, or end-based-index object.
 *
 *----------------------------------------------------------------------
 */

int
TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. 
				 * If NULL, then no error message is left
				 * after errors. */
    Tcl_Obj *objPtr;		/* Points to an object containing either
				 * "end" or an integer. */
    int endValue;		/* The value to be stored at "indexPtr" if
				 * "objPtr" holds "end". */
    int *indexPtr;		/* Location filled in with an integer
				 * representing an index. */
{
    char *bytes;
    int offset;
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt wideOffset;
#endif

    /*
     * If the object is already an integer, use it.
     */

    if (objPtr->typePtr == &tclIntType) {
	*indexPtr = (int)objPtr->internalRep.longValue;
	return TCL_OK;
    }

    /*
     * If the object is already a wide-int, and it is not out of range
     * for an integer, use it. [Bug #526717]
     */
#ifndef TCL_WIDE_INT_IS_LONG
    if (objPtr->typePtr == &tclWideIntType) {
	Tcl_WideInt wideOffset = objPtr->internalRep.wideValue;
	if (wideOffset >= Tcl_LongAsWide(INT_MIN)
	    && wideOffset <= Tcl_LongAsWide(INT_MAX)) {
	    *indexPtr = (int) Tcl_WideAsLong(wideOffset);
	    return TCL_OK;
	}
    }
#endif /* TCL_WIDE_INT_IS_LONG */

    if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
	/*
	 * If the object is already an offset from the end of the
	 * list, or can be converted to one, use it.
	 */

	*indexPtr = endValue + objPtr->internalRep.longValue;

#ifdef TCL_WIDE_INT_IS_LONG
    } else if (Tcl_GetIntFromObj(NULL, objPtr, &offset) == TCL_OK) {
	/*
	 * If the object can be converted to an integer, use that.
	 */

	*indexPtr = offset;

#else /* !TCL_WIDE_INT_IS_LONG */
    } else if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideOffset) == TCL_OK) {
	/*
	 * If the object can be converted to a wide integer, use
	 * that. [Bug #526717]
	 */

	offset = (int) Tcl_WideAsLong(wideOffset);
	if (Tcl_LongAsWide(offset) == wideOffset) {
	    /*
	     * But it is representable as a narrow integer, so we
	     * prefer that (so preserving old behaviour in the
	     * majority of cases.)
	     */
	    objPtr->typePtr = &tclIntType;
	    objPtr->internalRep.longValue = offset;
	}
	*indexPtr = offset;

#endif /* TCL_WIDE_INT_IS_LONG */
    } else {
	/*
	 * Report a parse error.
	 */

	if (interp != NULL) {
	    bytes = Tcl_GetString(objPtr);
	    /*
	     * The result might not be empty; this resets it which
	     * should be both a cheap operation, and of little problem
	     * because this is an error-generation path anyway.
	     */
	    Tcl_ResetResult(interp);
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
				   "bad index \"", bytes,
				   "\": must be integer or end?-integer?",
				   (char *) NULL);
	    if (!strncmp(bytes, "end-", 3)) {
		bytes += 3;
	    }
	    TclCheckBadOctal(interp, bytes);
	}

	return TCL_ERROR;
    }
	    
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfEndOffset --
 *
 *	Update the string rep of a Tcl object holding an "end-offset"
 *	expression.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Stores a valid string in the object's string rep.
 *
 * This procedure does NOT free any earlier string rep.  If it is
 * called on an object that already has a valid string rep, it will
 * leak memory.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfEndOffset(objPtr)
    register Tcl_Obj* objPtr;
{
    char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1];
    register int len;

    strcpy(buffer, "end");
    len = sizeof("end") - 1;
    if (objPtr->internalRep.longValue != 0) {
	buffer[len++] = '-';
	len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
    }
    objPtr->bytes = ckalloc((unsigned) (len+1));
    strcpy(objPtr->bytes, buffer);
    objPtr->length = len;
}

/*
 *----------------------------------------------------------------------
 *
 * SetEndOffsetFromAny --
 *
 *	Look for a string of the form "end-offset" and convert it
 *	to an internal representation holding the offset.
 *
 * Results:
 *	Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
 *
 * Side effects:
 *	If interp is not NULL, stores an error message in the
 *	interpreter result.
 *
 *----------------------------------------------------------------------
 */

static int
SetEndOffsetFromAny(interp, objPtr)
     Tcl_Interp* interp;	/* Tcl interpreter or NULL */
     Tcl_Obj* objPtr;		/* Pointer to the object to parse */
{
    int offset;			/* Offset in the "end-offset" expression */
    Tcl_ObjType* oldTypePtr = objPtr->typePtr;
				/* Old internal rep type of the object */
    register char* bytes;	/* String rep of the object */
    int length;			/* Length of the object's string rep */

    /* If it's already the right type, we're fine. */

    if (objPtr->typePtr == &tclEndOffsetType) {
	return TCL_OK;
    }

    /* Check for a string rep of the right form. */

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    if ((*bytes != 'e') || (strncmp(bytes, "end",
	    (size_t)((length > 3) ? 3 : length)) != 0)) {
	if (interp != NULL) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
				   "bad index \"", bytes,
				   "\": must be end?-integer?",
				   (char*) NULL);
	}
	return TCL_ERROR;
    }

    /* Convert the string rep */

    if (length <= 3) {
	offset = 0;
    } else if ((length > 4) && (bytes[3] == '-')) {
	/*
	 * This is our limited string expression evaluator.  Pass everything
	 * after "end-" to Tcl_GetInt, then reverse for offset.
	 */
	if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
	    return TCL_ERROR;
	}
	offset = -offset;
    } else {
	/*
	 * Conversion failed.  Report the error