aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/generic
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/tcl/generic')
-rw-r--r--contrib/tcl/generic/tcl.h6
-rw-r--r--contrib/tcl/generic/tclBinary.c94
-rw-r--r--contrib/tcl/generic/tclCmdAH.c5
-rw-r--r--contrib/tcl/generic/tclCmdIL.c64
-rw-r--r--contrib/tcl/generic/tclCmdMZ.c76
-rw-r--r--contrib/tcl/generic/tclCompExpr.c55
-rw-r--r--contrib/tcl/generic/tclCompile.c139
-rw-r--r--contrib/tcl/generic/tclEnv.c31
-rw-r--r--contrib/tcl/generic/tclExecute.c208
-rw-r--r--contrib/tcl/generic/tclFileName.c11
-rw-r--r--contrib/tcl/generic/tclIO.c66
-rw-r--r--contrib/tcl/generic/tclIOUtil.c20
-rw-r--r--contrib/tcl/generic/tclInterp.c10
-rw-r--r--contrib/tcl/generic/tclNotify.c21
-rw-r--r--contrib/tcl/generic/tclObj.c6
-rw-r--r--contrib/tcl/generic/tclPosixStr.c6
-rw-r--r--contrib/tcl/generic/tclProc.c4
-rw-r--r--contrib/tcl/generic/tclStringObj.c6
-rw-r--r--contrib/tcl/generic/tclTest.c128
-rw-r--r--contrib/tcl/generic/tclVar.c120
20 files changed, 701 insertions, 375 deletions
diff --git a/contrib/tcl/generic/tcl.h b/contrib/tcl/generic/tcl.h
index 2d773da703ab..0a80e52d53b2 100644
--- a/contrib/tcl/generic/tcl.h
+++ b/contrib/tcl/generic/tcl.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tcl.h 1.324 97/08/07 10:26:49
+ * SCCS: @(#) tcl.h 1.326 97/11/20 12:40:43
*/
#ifndef _TCL
@@ -38,10 +38,10 @@
#define TCL_MAJOR_VERSION 8
#define TCL_MINOR_VERSION 0
#define TCL_RELEASE_LEVEL 2
-#define TCL_RELEASE_SERIAL 0
+#define TCL_RELEASE_SERIAL 2
#define TCL_VERSION "8.0"
-#define TCL_PATCH_LEVEL "8.0"
+#define TCL_PATCH_LEVEL "8.0p2"
/*
* The following definitions set up the proper options for Windows
diff --git a/contrib/tcl/generic/tclBinary.c b/contrib/tcl/generic/tclBinary.c
index c20d03dcd88d..e15fe4c7f51b 100644
--- a/contrib/tcl/generic/tclBinary.c
+++ b/contrib/tcl/generic/tclBinary.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclBinary.c 1.20 97/08/11 18:43:09
+ * SCCS: @(#) tclBinary.c 1.26 97/11/05 13:02:05
*/
#include <math.h>
@@ -867,13 +867,20 @@ FormatNumber(interp, type, src, cursorPtr)
char cmd = (char)type;
if (cmd == 'd' || cmd == 'f') {
+ /*
+ * For floating point types, we need to copy the data using
+ * memcpy to avoid alignment issues.
+ */
+
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
return TCL_ERROR;
}
if (cmd == 'd') {
- *((double *)(*cursorPtr)) = dvalue;
+ memcpy((*cursorPtr), &dvalue, sizeof(double));
(*cursorPtr) += sizeof(double);
} else {
+ float fvalue;
+
/*
* Because some compilers will generate floating point exceptions
* on an overflow cast (e.g. Borland), we restrict the values
@@ -881,13 +888,11 @@ FormatNumber(interp, type, src, cursorPtr)
*/
if (fabs(dvalue) > (double)FLT_MAX) {
- *((float *)(*cursorPtr))
- = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
- } else if (fabs(dvalue) < (double)FLT_MIN) {
- *((float *)(*cursorPtr)) = (float) 0.0;
+ fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
} else {
- *((float *)(*cursorPtr)) = (float) dvalue;
+ fvalue = (float) dvalue;
}
+ memcpy((*cursorPtr), &fvalue, sizeof(float));
(*cursorPtr) += sizeof(float);
}
} else {
@@ -938,44 +943,71 @@ FormatNumber(interp, type, src, cursorPtr)
static Tcl_Obj *
ScanNumber(buffer, type)
char *buffer; /* Buffer to scan number from. */
- int type; /* Type of number to scan. */
+ int type; /* Format character from "binary scan" */
{
- int c;
+ int value;
+
+ /*
+ * We cannot rely on the compiler to properly sign extend integer values
+ * when we cast from smaller values to larger values because we don't know
+ * the exact size of the integer types. So, we have to handle sign
+ * extension explicitly by checking the high bit and padding with 1's as
+ * needed.
+ */
switch ((char) type) {
case 'c':
- /*
- * Characters need special handling. We want to produce a
- * signed result, but on some platforms (such as AIX) chars
- * are unsigned. To deal with this, check for a value that
- * should be negative but isn't.
- */
+ value = buffer[0];
- c = buffer[0];
- if (c > 127) {
- c -= 256;
+ if (value & 0x80) {
+ value |= -0x100;
}
- return Tcl_NewIntObj(c);
+ return Tcl_NewLongObj((long)value);
case 's':
- return Tcl_NewIntObj((short)(((unsigned char)buffer[0])
- + ((unsigned char)buffer[1] << 8)));
+ value = (((unsigned char)buffer[0])
+ + ((unsigned char)buffer[1] << 8));
+ goto shortValue;
case 'S':
- return Tcl_NewIntObj((short)(((unsigned char)buffer[1])
- + ((unsigned char)buffer[0] << 8)));
+ value = (((unsigned char)buffer[1])
+ + ((unsigned char)buffer[0] << 8));
+ shortValue:
+ if (value & 0x8000) {
+ value |= -0x10000;
+ }
+ return Tcl_NewLongObj((long)value);
case 'i':
- return Tcl_NewIntObj((long) (((unsigned char)buffer[0])
+ value = (((unsigned char)buffer[0])
+ ((unsigned char)buffer[1] << 8)
+ ((unsigned char)buffer[2] << 16)
- + ((unsigned char)buffer[3] << 24)));
+ + ((unsigned char)buffer[3] << 24));
+ goto intValue;
case 'I':
- return Tcl_NewIntObj((long) (((unsigned char)buffer[3])
+ value = (((unsigned char)buffer[3])
+ ((unsigned char)buffer[2] << 8)
+ ((unsigned char)buffer[1] << 16)
- + ((unsigned char)buffer[0] << 24)));
- case 'f':
- return Tcl_NewDoubleObj(*(float*)buffer);
- case 'd':
- return Tcl_NewDoubleObj(*(double*)buffer);
+ + ((unsigned char)buffer[0] << 24));
+ intValue:
+ /*
+ * Check to see if the value was sign extended properly on
+ * systems where an int is more than 32-bits.
+ */
+
+ if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
+ value -= (((unsigned int)1)<<31);
+ value -= (((unsigned int)1)<<31);
+ }
+
+ return Tcl_NewLongObj((long)value);
+ case 'f': {
+ float fvalue;
+ memcpy(&fvalue, buffer, sizeof(float));
+ return Tcl_NewDoubleObj(fvalue);
+ }
+ case 'd': {
+ double dvalue;
+ memcpy(&dvalue, buffer, sizeof(double));
+ return Tcl_NewDoubleObj(dvalue);
+ }
}
return NULL;
}
diff --git a/contrib/tcl/generic/tclCmdAH.c b/contrib/tcl/generic/tclCmdAH.c
index 79968d343c5a..4c5fd0ab6ef2 100644
--- a/contrib/tcl/generic/tclCmdAH.c
+++ b/contrib/tcl/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdAH.c 1.156 97/08/12 18:10:15
+ * SCCS: @(#) tclCmdAH.c 1.159 97/10/31 13:06:07
*/
#include "tclInt.h"
@@ -590,6 +590,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv)
Tcl_SetObjResult(interp, resultPtr);
Tcl_DecrRefCount(resultPtr); /* done with the result object */
}
+ return result;
}
/*
@@ -1670,7 +1671,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
# define MAX_FLOAT_SIZE 320
Tcl_Obj *resultPtr; /* Where result is stored finally. */
- char staticBuf[MAX_FLOAT_SIZE];
+ char staticBuf[MAX_FLOAT_SIZE + 1];
/* A static buffer to copy the format results
* into */
char *dst = staticBuf; /* The buffer that sprintf writes into each
diff --git a/contrib/tcl/generic/tclCmdIL.c b/contrib/tcl/generic/tclCmdIL.c
index 6503d351b5ac..44e4270c167e 100644
--- a/contrib/tcl/generic/tclCmdIL.c
+++ b/contrib/tcl/generic/tclCmdIL.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdIL.c 1.168 97/07/29 12:52:40
+ * SCCS: @(#) tclCmdIL.c 1.173 97/11/18 13:55:01
*/
#include "tclInt.h"
@@ -987,13 +987,21 @@ InfoHostnameCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+ char *name;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- Tcl_SetStringObj(Tcl_GetObjResult(interp), Tcl_GetHostName(), -1);
- return TCL_OK;
+ name = Tcl_GetHostName();
+ if (name) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1);
+ return TCL_OK;
+ } else {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ "unable to determine name of host", -1);
+ return TCL_ERROR;
+ }
}
/*
@@ -1748,6 +1756,7 @@ Tcl_JoinObjCmd(dummy, interp, objc, objv)
char *joinString, *bytes;
int joinLength, listLen, length, i, result;
Tcl_Obj **elemPtrs;
+ Tcl_Obj *resObjPtr;
if (objc == 2) {
joinString = " ";
@@ -1774,14 +1783,14 @@ Tcl_JoinObjCmd(dummy, interp, objc, objv)
* directly into the interpreter's result object.
*/
+ resObjPtr = Tcl_GetObjResult(interp);
+
for (i = 0; i < listLen; i++) {
bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
if (i > 0) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), joinString,
- bytes, (char *) NULL);
- } else {
- Tcl_AppendToObj(Tcl_GetObjResult(interp), bytes, length);
+ Tcl_AppendToObj(resObjPtr, joinString, joinLength);
}
+ Tcl_AppendToObj(resObjPtr, bytes, length);
}
return TCL_OK;
}
@@ -1895,8 +1904,8 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *listPtr, *resultPtr;
- int index, isDuplicate;
- int result;
+ Tcl_ObjType *typePtr;
+ int index, isDuplicate, len, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
@@ -1923,16 +1932,29 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv)
listPtr = objv[1];
isDuplicate = 0;
if (Tcl_IsShared(listPtr)) {
+ /*
+ * The following code must reflect the logic in Tcl_DuplicateObj()
+ * except that it must duplicate the list object directly into the
+ * interpreter's result.
+ */
+
Tcl_ResetResult(interp);
resultPtr = Tcl_GetObjResult(interp);
- if (listPtr->typePtr != NULL) {
- Tcl_InvalidateStringRep(resultPtr);
- listPtr->typePtr->dupIntRepProc(listPtr, resultPtr);
- } else if (listPtr->bytes != NULL) {
- int len = listPtr->length;
-
+ typePtr = listPtr->typePtr;
+ if (listPtr->bytes == NULL) {
+ resultPtr->bytes = NULL;
+ } else if (listPtr->bytes != tclEmptyStringRep) {
+ len = listPtr->length;
TclInitStringRep(resultPtr, listPtr->bytes, len);
}
+ if (typePtr != NULL) {
+ if (typePtr->dupIntRepProc == NULL) {
+ resultPtr->internalRep = listPtr->internalRep;
+ resultPtr->typePtr = typePtr;
+ } else {
+ (*typePtr->dupIntRepProc)(listPtr, resultPtr);
+ }
+ }
listPtr = resultPtr;
isDuplicate = 1;
}
@@ -2164,7 +2186,9 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Tcl_Obj *listPtr;
- int createdNewObj, first, last, listLen, numToDelete, result;
+ int createdNewObj, first, last, listLen, numToDelete;
+ int firstArgLen, result;
+ char *firstArg;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2201,6 +2225,7 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
if (result != TCL_OK) {
goto errorReturn;
}
+ firstArg = Tcl_GetStringFromObj(objv[2], &firstArgLen);
result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
&last);
@@ -2211,7 +2236,8 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
if (first < 0) {
first = 0;
}
- if (first >= listLen) {
+ if ((first >= listLen) && (listLen > 0)
+ && (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"list doesn't contain element ",
Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL);
@@ -2821,11 +2847,11 @@ DictionaryCompare(left, right)
*/
zeros = 0;
- while (*right == '0') {
+ while ((*right == '0') && (*(right + 1) != '\0')) {
right++;
zeros--;
}
- while (*left == '0') {
+ while ((*left == '0') && (*(left + 1) != '\0')) {
left++;
zeros++;
}
diff --git a/contrib/tcl/generic/tclCmdMZ.c b/contrib/tcl/generic/tclCmdMZ.c
index 9ab2c826a656..4dc272f64778 100644
--- a/contrib/tcl/generic/tclCmdMZ.c
+++ b/contrib/tcl/generic/tclCmdMZ.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdMZ.c 1.102 97/08/13 10:06:58
+ * SCCS: @(#) tclCmdMZ.c 1.104 97/10/31 13:06:19
*/
#include "tclInt.h"
@@ -1054,7 +1054,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int index, first, left, right;
+ int index, left, right;
Tcl_Obj *resultPtr;
char *string1, *string2;
int length1, length2;
@@ -1103,8 +1103,37 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
break;
}
case STR_FIRST: {
- first = 1;
- goto firstlast;
+ register char *p, *end;
+ int match;
+
+ if (objc != 4) {
+ badFirstLastArgs:
+ Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
+ return TCL_ERROR;
+ }
+
+ match = -1;
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string2 = Tcl_GetStringFromObj(objv[3], &length2);
+ if (length1 > 0) {
+ end = string2 + length2 - length1 + 1;
+ for (p = string2; p < end; p++) {
+ /*
+ * Scan forward to find the first character.
+ */
+
+ p = memchr(p, *string1, (unsigned) (end - p));
+ if (p == NULL) {
+ break;
+ }
+ if (memcmp(string1, p, (unsigned) length1) == 0) {
+ match = p - string2;
+ break;
+ }
+ }
+ }
+ Tcl_SetIntObj(resultPtr, match);
+ break;
}
case STR_INDEX: {
int index;
@@ -1124,28 +1153,28 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
break;
}
case STR_LAST: {
- char *p, *end;
+ register char *p;
int match;
- first = 0;
-
- firstlast:
if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
- return TCL_ERROR;
+ goto badFirstLastArgs;
}
match = -1;
string1 = Tcl_GetStringFromObj(objv[2], &length1);
string2 = Tcl_GetStringFromObj(objv[3], &length2);
if (length1 > 0) {
- end = string2 + length2 - length1 + 1;
- for (p = string2; p < end; p++) {
+ for (p = string2 + length2 - length1; p >= string2; p--) {
+ /*
+ * Scan backwards to find the first character.
+ */
+
+ while ((p != string2) && (*p != *string1)) {
+ p--;
+ }
if (memcmp(string1, p, (unsigned) length1) == 0) {
match = p - string2;
- if (first) {
- break;
- }
+ break;
}
}
}
@@ -1202,7 +1231,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
break;
}
case STR_TOLOWER: {
- char *p, *end;
+ register char *p, *end;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
@@ -1228,7 +1257,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
break;
}
case STR_TOUPPER: {
- char *p, *end;
+ register char *p, *end;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
@@ -1255,7 +1284,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
}
case STR_TRIM: {
char ch;
- char *p, *end, *check, *checkEnd;
+ register char *p, *end;
+ char *check, *checkEnd;
left = 1;
right = 1;
@@ -1563,9 +1593,12 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
switchObjc = objc-1;
switchObjv = objv+1;
mode = EXACT;
-
- string = Tcl_GetStringFromObj(switchObjv[0], &length);
- while ((switchObjc > 0) && (*string == '-')) {
+
+ while (switchObjc > 0) {
+ string = Tcl_GetStringFromObj(switchObjv[0], &length);
+ if (*string != '-') {
+ break;
+ }
if (Tcl_GetIndexFromObj(interp, switchObjv[0], switches,
"option", 0, &index) != TCL_OK) {
return TCL_ERROR;
@@ -1587,7 +1620,6 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
}
switchObjc--;
switchObjv++;
- string = Tcl_GetStringFromObj(switchObjv[0], &length);
}
doneWithSwitches:
diff --git a/contrib/tcl/generic/tclCompExpr.c b/contrib/tcl/generic/tclCompExpr.c
index 74b12c171e6f..6bae02b063e6 100644
--- a/contrib/tcl/generic/tclCompExpr.c
+++ b/contrib/tcl/generic/tclCompExpr.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCompExpr.c 1.31 97/08/07 10:14:07
+ * SCCS: @(#) tclCompExpr.c 1.34 97/11/03 14:29:18
*/
#include "tclInt.h"
@@ -1596,7 +1596,7 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr)
HERE("primaryExpr", 13);
theToken = infoPtr->token;
- if (theToken != DOLLAR) {
+ if ((theToken != DOLLAR) && (theToken != OPEN_PAREN)) {
infoPtr->exprIsJustVarRef = 0;
}
switch (theToken) {
@@ -1995,27 +1995,28 @@ GetToken(interp, infoPtr, envPtr)
(char *) NULL);
return TCL_ERROR;
}
-
- /*
- * Find/create an object in envPtr's object array that contains
- * the integer.
- */
-
- savedChar = *termPtr;
- *termPtr = '\0';
- objIndex = TclObjIndexForString(src, termPtr - src,
- /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
- *termPtr = savedChar; /* restore the saved char */
-
- objPtr = envPtr->objArrayPtr[objIndex];
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = longValue;
- objPtr->typePtr = &tclIntType;
+ if (termPtr != src) {
+ /*
+ * src was the start of a valid integer. Find/create an
+ * object in envPtr's object array to contain the integer.
+ */
- infoPtr->token = LITERAL;
- infoPtr->objIndex = objIndex;
- infoPtr->next = termPtr;
- return TCL_OK;
+ savedChar = *termPtr;
+ *termPtr = '\0';
+ objIndex = TclObjIndexForString(src, termPtr - src,
+ /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
+ *termPtr = savedChar; /* restore the saved char */
+
+ objPtr = envPtr->objArrayPtr[objIndex];
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = longValue;
+ objPtr->typePtr = &tclIntType;
+
+ infoPtr->token = LITERAL;
+ infoPtr->objIndex = objIndex;
+ infoPtr->next = termPtr;
+ return TCL_OK;
+ }
} else if (startsWithDigit || (*src == '.')
|| (*src == 'n') || (*src == 'N')) {
errno = 0;
@@ -2057,7 +2058,8 @@ GetToken(interp, infoPtr, envPtr)
if (*src == '{') {
int level = 0; /* The {} nesting level. */
int hasBackslashNL = 0; /* Nonzero if '\newline' was found. */
- char *string = src+1; /* Points just after the starting '{'. */
+ char *string = src; /* Set below to point just after the
+ * starting '{'. */
char *last; /* Points just before terminating '}'. */
int numChars; /* Number of chars in braced string. */
char savedChar; /* Holds the character from string
@@ -2069,7 +2071,7 @@ GetToken(interp, infoPtr, envPtr)
* Check first for any backslash-newlines, since we must treat
* backslash-newlines specially (they must be replaced by spaces).
*/
-
+
while (1) {
if (src == infoPtr->lastChar) {
Tcl_ResetResult(interp);
@@ -2099,13 +2101,14 @@ GetToken(interp, infoPtr, envPtr)
}
/*
- * Create a string object for the braced string. This starts at
+ * Create a string object for the braced string. This will start at
* "string" and ends just after "last" (which points to the final
* character before the terminating '}'). If backslash-newlines were
* found, we copy characters one at a time into a heap-allocated
* buffer and do backslash-newline substitutions.
*/
-
+
+ string++;
numChars = (last - string + 1);
savedChar = string[numChars];
string[numChars] = '\0';
diff --git a/contrib/tcl/generic/tclCompile.c b/contrib/tcl/generic/tclCompile.c
index d4fad0c74c7d..3291b3d5d2a6 100644
--- a/contrib/tcl/generic/tclCompile.c
+++ b/contrib/tcl/generic/tclCompile.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCompile.c 1.76 97/08/12 13:35:43
+ * SCCS: @(#) tclCompile.c 1.80 97/09/18 18:23:30
*/
#include "tclInt.h"
@@ -727,7 +727,7 @@ TclPrintInstruction(codePtr, pc)
if ((i == 0) && ((opCode == INST_JUMP1)
|| (opCode == INST_JUMP_TRUE1)
|| (opCode == INST_JUMP_FALSE1))) {
- fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
+ fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
} else {
fprintf(stdout, "%d", opnd);
}
@@ -737,7 +737,7 @@ TclPrintInstruction(codePtr, pc)
if ((i == 0) && ((opCode == INST_JUMP4)
|| (opCode == INST_JUMP_TRUE4)
|| (opCode == INST_JUMP_FALSE4))) {
- fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
+ fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
} else {
fprintf(stdout, "%d", opnd);
}
@@ -979,18 +979,16 @@ TclCleanupByteCode(codePtr)
*
* DupByteCodeInternalRep --
*
- * Part of the bytecode Tcl object type implementation. Initializes the
- * internal representation of a bytecode Tcl_Obj to a copy of the
- * internal representation of an existing bytecode object.
+ * Part of the bytecode Tcl object type implementation. However, it
+ * does not copy the internal representation of a bytecode Tcl_Obj, but
+ * instead leaves the new object untyped (with a NULL type pointer).
+ * Code will be compiled for the new object only if necessary.
*
* Results:
* None.
*
* Side effects:
- * "copyPtr"s internal rep is set to the bytecode sequence
- * corresponding to "srcPtr"s internal rep. Ref counts for objects
- * in the existing bytecode object's object array are incremented
- * the bytecode copy now also refers to them.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -1000,90 +998,7 @@ DupByteCodeInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
- ByteCode *codePtr = (ByteCode *) srcPtr->internalRep.otherValuePtr;
- register ByteCode *dupPtr;
- register AuxData *srcAuxDataPtr, *dupAuxDataPtr;
- size_t objArrayBytes, exceptArrayBytes, cmdLocBytes, auxDataBytes;
- register size_t size;
- register char *p;
- int codeBytes, numObjects, i;
-
- /*
- * Allocate a single heap object to hold the copied ByteCode structure
- * and its code, object, command location, and auxiliary data arrays.
- */
-
- codeBytes = codePtr->numCodeBytes;
- numObjects = codePtr->numObjects;
- objArrayBytes = (numObjects * sizeof(Tcl_Obj *));
- exceptArrayBytes = (codePtr->numExcRanges * sizeof(ExceptionRange));
- auxDataBytes = (codePtr->numAuxDataItems * sizeof(AuxData));
- cmdLocBytes = codePtr->numCmdLocBytes;
-
- size = sizeof(ByteCode);
- size += TCL_ALIGN(codeBytes); /* align object array */
- size += TCL_ALIGN(objArrayBytes); /* align exception range array */
- size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
- size += auxDataBytes;
- size += cmdLocBytes;
-
- p = (char *) ckalloc(size);
- dupPtr = (ByteCode *) p;
- memcpy((VOID *) dupPtr, (VOID *) codePtr, size);
-
- p += sizeof(ByteCode);
- dupPtr->codeStart = (unsigned char *) p;
-
- p += TCL_ALIGN(codeBytes); /* object array is aligned */
- dupPtr->objArrayPtr = (Tcl_Obj **) p;
-
- p += TCL_ALIGN(objArrayBytes); /* exception range array is aligned */
- dupPtr->excRangeArrayPtr = (ExceptionRange *) p;
-
- p += TCL_ALIGN(exceptArrayBytes); /* AuxData array is aligned */
- dupPtr->auxDataArrayPtr = (AuxData *) p;
-
- p += auxDataBytes;
- dupPtr->codeDeltaStart = ((unsigned char *) dupPtr) +
- (codePtr->codeDeltaStart - (unsigned char *) codePtr);
- dupPtr->srcDeltaStart = ((unsigned char *) dupPtr) +
- (codePtr->srcDeltaStart - (unsigned char *) codePtr);
- dupPtr->srcLengthStart = ((unsigned char *) dupPtr) +
- (codePtr->srcLengthStart - (unsigned char *) codePtr);
-
- /*
- * Increment the ref counts for objects in the object array since we are
- * creating new references for them in the copied object array.
- */
-
- for (i = 0; i < numObjects; i++) {
- Tcl_IncrRefCount(dupPtr->objArrayPtr[i]);
- }
-
- /*
- * Duplicate any auxiliary data items.
- */
-
- srcAuxDataPtr = codePtr->auxDataArrayPtr;
- dupAuxDataPtr = dupPtr->auxDataArrayPtr;
- for (i = 0; i < codePtr->numAuxDataItems; i++) {
- if (srcAuxDataPtr->dupProc != NULL) {
- dupAuxDataPtr->clientData =
- srcAuxDataPtr->dupProc(srcAuxDataPtr->clientData);
- } else {
- dupAuxDataPtr->clientData = srcAuxDataPtr->clientData;
- }
- srcAuxDataPtr++;
- dupAuxDataPtr++;
- }
-
- copyPtr->internalRep.otherValuePtr = (VOID *) dupPtr;
- copyPtr->typePtr = &tclByteCodeType;
-
-#ifdef TCL_COMPILE_STATS
- tclCurrentSourceBytes += (double) codePtr->numSrcChars;
- tclCurrentCodeBytes += (double) codePtr->totalSize;
-#endif /* TCL_COMPILE_STATS */
+ return;
}
/*
@@ -1431,6 +1346,7 @@ TclInitByteCodeObj(objPtr, envPtr)
codePtr->numObjects = numObjects;
codePtr->numExcRanges = envPtr->excRangeArrayNext;
codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
+ codePtr->auxDataArrayPtr = NULL;
codePtr->numCmdLocBytes = cmdLocBytes;
codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth;
codePtr->maxStackDepth = envPtr->maxStackDepth;
@@ -1724,13 +1640,14 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* warning. */
int cmdIndex; /* The index of the current command in the
* compilation environment's command
- * location table. Initialized to avoid
- * compiler warning. */
+ * location table. */
+ int lastTopLevelCmdIndex = -1;
+ /* Index of most recent toplevel command in
+ * the command location table. Initialized
+ * to avoid compiler warning. */
int cmdCodeOffset = -1; /* Offset of first byte of current command's
* code. Initialized to avoid compiler
* warning. */
- int cmdCodeBytes; /* Number of code bytes for current
- * command. */
int cmdWords; /* Number of words in current command. */
Tcl_Command cmd; /* Used to search for commands. */
Command *cmdPtr; /* Points to command's Command structure if
@@ -1827,14 +1744,11 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
/*
* We are compiling a top level command. Update the number
* of code bytes for the last command to account for the pop
- * instruction we just emitted.
+ * instruction.
*/
- int lastCmdIndex = (envPtr->numCommands - 1);
- cmdCodeBytes =
- (envPtr->codeNext - envPtr->codeStart - cmdCodeOffset);
- (envPtr->cmdMapPtr[lastCmdIndex]).numCodeBytes =
- cmdCodeBytes;
+ (envPtr->cmdMapPtr[lastTopLevelCmdIndex]).numCodeBytes =
+ (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset;
}
}
@@ -1848,14 +1762,17 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* starting source and object information for the command.
*/
+ envPtr->numCommands++;
+ cmdIndex = (envPtr->numCommands - 1);
+ if (!(flags & TCL_BRACKET_TERM)) {
+ lastTopLevelCmdIndex = cmdIndex;
+ }
+
cmdSrcStart = src;
cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart);
cmdWords = 0;
-
- envPtr->numCommands++;
- cmdIndex = (envPtr->numCommands - 1);
- EnterCmdStartData(envPtr, cmdIndex,
- (cmdSrcStart - envPtr->source), cmdCodeOffset);
+ EnterCmdStartData(envPtr, cmdIndex, src-envPtr->source,
+ cmdCodeOffset);
if ((!(flags & TCL_BRACKET_TERM))
&& (tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
@@ -2131,8 +2048,8 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
*/
finishCommand:
- cmdCodeBytes = envPtr->codeNext - envPtr->codeStart - cmdCodeOffset;
- EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart, cmdCodeBytes);
+ EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart,
+ (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset);
isFirstCmd = 0;
envPtr->termOffset = (src - string);
diff --git a/contrib/tcl/generic/tclEnv.c b/contrib/tcl/generic/tclEnv.c
index 8027f5ed76d2..8b46bb2289fc 100644
--- a/contrib/tcl/generic/tclEnv.c
+++ b/contrib/tcl/generic/tclEnv.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclEnv.c 1.49 97/08/11 20:22:40
+ * SCCS: @(#) tclEnv.c 1.54 97/10/27 17:47:52
*/
#include "tclInt.h"
@@ -244,15 +244,6 @@ TclSetEnv(name, value)
/*
- * Update all of the interpreters.
- */
-
- for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) {
- (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name,
- (char *) value, TCL_GLOBAL_ONLY);
- }
-
- /*
* Create a new entry.
*/
@@ -276,6 +267,16 @@ TclSetEnv(name, value)
*/
ReplaceString(oldValue, p);
+
+ /*
+ * Update all of the interpreters.
+ */
+
+ for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) {
+ (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name,
+ (char *) value, TCL_GLOBAL_ONLY);
+ }
+
}
/*
@@ -597,11 +598,15 @@ ReplaceString(oldStr, newStr)
environCache[cacheSize-1] = NULL;
}
} else {
+ int allocatedSize = (cacheSize + 5) * sizeof(char *);
+
/*
* We need to grow the cache in order to hold the new string.
*/
- newCache = (char **) ckalloc((cacheSize + 5) * sizeof(char *));
+ newCache = (char **) ckalloc((size_t) allocatedSize);
+ (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize);
+
if (environCache) {
memcpy((VOID *) newCache, (VOID *) environCache,
(size_t) (cacheSize * sizeof(char*)));
@@ -690,5 +695,9 @@ TclFinalizeEnvironment()
if (environCache) {
ckfree((char *) environCache);
environCache = NULL;
+ cacheSize = 0;
+#ifndef USE_PUTENV
+ environSize = 0;
+#endif
}
}
diff --git a/contrib/tcl/generic/tclExecute.c b/contrib/tcl/generic/tclExecute.c
index 4c1243793093..c6cea084a90f 100644
--- a/contrib/tcl/generic/tclExecute.c
+++ b/contrib/tcl/generic/tclExecute.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclExecute.c 1.95 97/08/12 17:06:49
+ * SCCS: @(#) tclExecute.c 1.102 97/11/06 11:36:35
*/
#include "tclInt.h"
@@ -96,7 +96,7 @@ static char *opName[256];
*/
static char *operatorStrings[] = {
- "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
+ "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
"+", "-", "*", "/", "%", "+", "-", "~", "!",
"BUILTIN FUNCTION", "FUNCTION"
};
@@ -292,6 +292,8 @@ static void IllegalExprOperandType _ANSI_ARGS_((
static void InitByteCodeExecution _ANSI_ARGS_((
Tcl_Interp *interp));
static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
+static void RecordTracebackInfo _ANSI_ARGS_((Tcl_Interp *interp,
+ unsigned char *pc, ByteCode *codePtr));
static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
#ifdef TCL_COMPILE_DEBUG
@@ -809,7 +811,6 @@ TclExecuteByteCode(interp, codePtr)
/* Instruction offset computed during
* break, continue, error processing.
* Init. to avoid compiler warning. */
- Trace *tracePtr;
Tcl_Command cmd;
#ifdef TCL_COMPILE_DEBUG
int isUnknownCmd = 0;
@@ -884,17 +885,23 @@ TclExecuteByteCode(interp, codePtr)
/*
* Call any trace procedures.
*/
-
- for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
- tracePtr = tracePtr->nextPtr) {
- if (iPtr->numLevels <= tracePtr->level) {
- int numChars;
- char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
- if (cmd != NULL) {
- DECACHE_STACK_INFO();
- CallTraceProcedure(interp, tracePtr, cmdPtr,
- cmd, numChars, objc, objv);
- CACHE_STACK_INFO();
+
+ if (iPtr->tracePtr != NULL) {
+ Trace *tracePtr, *nextTracePtr;
+
+ for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
+ tracePtr = nextTracePtr) {
+ nextTracePtr = tracePtr->nextPtr;
+ if (iPtr->numLevels <= tracePtr->level) {
+ int numChars;
+ char *cmd = GetSrcInfoForPc(pc, codePtr,
+ &numChars);
+ if (cmd != NULL) {
+ DECACHE_STACK_INFO();
+ CallTraceProcedure(interp, tracePtr, cmdPtr,
+ cmd, numChars, objc, objv);
+ CACHE_STACK_INFO();
+ }
}
}
}
@@ -1764,12 +1771,12 @@ TclExecuteByteCode(interp, codePtr)
case INST_LAND:
{
/*
- * Operands must be numeric, but no int->double conversions
- * are performed.
+ * Operands must be boolean or numeric. No int->double
+ * conversions are performed.
*/
- long i2, iResult;
- double d1;
+ int i1, i2;
+ int iResult;
char *s;
Tcl_ObjType *t1Ptr, *t2Ptr;
@@ -1778,20 +1785,20 @@ TclExecuteByteCode(interp, codePtr)
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
- if (t1Ptr == &tclIntType) {
- i = (valuePtr->internalRep.longValue != 0);
+ if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
+ i1 = (valuePtr->internalRep.longValue != 0);
} else if (t1Ptr == &tclDoubleType) {
- i = (valuePtr->internalRep.doubleValue != 0.0);
+ i1 = (valuePtr->internalRep.doubleValue != 0.0);
} else { /* FAILS IF NULL STRING REP */
s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
if (TclLooksLikeInt(s)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
- i = (i != 0);
+ i1 = (i != 0);
} else {
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- valuePtr, &d1);
- i = (d1 != 0.0);
+ result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
+ valuePtr, &i1);
+ i1 = (i1 != 0);
}
if (result != TCL_OK) {
TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
@@ -1804,7 +1811,7 @@ TclExecuteByteCode(interp, codePtr)
}
}
- if (t2Ptr == &tclIntType) {
+ if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
i2 = (value2Ptr->internalRep.longValue != 0);
} else if (t2Ptr == &tclDoubleType) {
i2 = (value2Ptr->internalRep.doubleValue != 0.0);
@@ -1812,12 +1819,12 @@ TclExecuteByteCode(interp, codePtr)
s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL);
if (TclLooksLikeInt(s)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
+ value2Ptr, &i);
+ i2 = (i != 0);
+ } else {
+ result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
value2Ptr, &i2);
i2 = (i2 != 0);
- } else {
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- value2Ptr, &d1);
- i2 = (d1 != 0.0);
}
if (result != TCL_OK) {
TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
@@ -1835,17 +1842,17 @@ TclExecuteByteCode(interp, codePtr)
*/
if (opCode == INST_LOR) {
- iResult = (i || i2);
+ iResult = (i1 || i2);
} else {
- iResult = (i && i2);
+ iResult = (i1 && i2);
}
if (Tcl_IsShared(valuePtr)) {
PUSH_OBJECT(Tcl_NewLongObj(iResult));
- TRACE(("%s %.20s %.20s => %ld\n", opName[opCode],
+ TRACE(("%s %.20s %.20s => %d\n", opName[opCode],
O2S(valuePtr), O2S(value2Ptr), iResult));
TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
- TRACE(("%s %.20s %.20s => %ld\n",
+ TRACE(("%s %.20s %.20s => %d\n",
opName[opCode], /* NB: stack top is off by 1 */
O2S(valuePtr), O2S(value2Ptr), iResult));
Tcl_SetLongObj(valuePtr, iResult);
@@ -2915,45 +2922,8 @@ TclExecuteByteCode(interp, codePtr)
checkForCatch:
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
- int numChars;
- char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
- char buf[200];
- register char *p;
- char *ellipsis = "";
-
- /*
- * Print the command in the error message (up to a certain
- * number of characters, or up to the first newline).
- */
-
- iPtr->errorLine = 1;
- if (cmd != NULL) {
- for (p = codePtr->source; p != cmd; p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
- for ( ; (isspace(UCHAR(*p)) || (*p == ';')); p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
-
- if (numChars > 150) {
- numChars = 150;
- ellipsis = "...";
- }
- if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- sprintf(buf, "\n while executing\n\"%.*s%s\"",
- numChars, cmd, ellipsis);
- } else {
- sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
- numChars, cmd, ellipsis);
- }
- Tcl_AddObjErrorInfo(interp, buf, -1);
- iPtr->flags |= ERR_ALREADY_LOGGED;
- }
- }
+ RecordTracebackInfo(interp, pc, codePtr);
+ }
rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr);
if (rangePtr == NULL) {
TRACE((" ... no enclosing catch, returning %s\n",
@@ -3172,12 +3142,12 @@ IllegalExprOperandType(interp, opCode, opndPtr)
if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't use empty string as operand of \"",
- operatorStrings[opCode - INST_BITOR], "\"", (char *) NULL);
+ operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
} else {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "can't use ", ((opndPtr->typePtr == &tclDoubleType) ?
- "floating-point value" : "non-numeric string"),
- " as operand of \"", operatorStrings[opCode - INST_BITOR],
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
+ ((opndPtr->typePtr == &tclDoubleType) ?
+ "floating-point value" : "non-numeric string"),
+ " as operand of \"", operatorStrings[opCode - INST_LOR],
"\"", (char *) NULL);
}
}
@@ -3254,6 +3224,76 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
/*
*----------------------------------------------------------------------
*
+ * RecordTracebackInfo --
+ *
+ * Procedure called by TclExecuteByteCode to record information
+ * about what was being executed when the error occurred.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Appends information about the command being executed to the
+ * "errorInfo" variable. Sets the errorLine field in the interpreter
+ * to the line number of that command. Sets the ERR_ALREADY_LOGGED
+ * bit in the interpreter's execution flags.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+RecordTracebackInfo(interp, pc, codePtr)
+ Tcl_Interp *interp; /* The interpreter in which the error
+ * occurred. */
+ unsigned char *pc; /* The program counter value where the error * occurred. This points to a bytecode
+ * instruction in codePtr's code. */
+ ByteCode *codePtr; /* The bytecode sequence being executed. */
+{
+ register Interp *iPtr = (Interp *) interp;
+ char *cmd, *ellipsis;
+ char buf[200];
+ register char *p;
+ int numChars;
+
+ /*
+ * Record the command in errorInfo (up to a certain number of
+ * characters, or up to the first newline).
+ */
+
+ iPtr->errorLine = 1;
+ cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
+ if (cmd != NULL) {
+ for (p = codePtr->source; p != cmd; p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+ for ( ; (isspace(UCHAR(*p)) || (*p == ';')); p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+
+ ellipsis = "";
+ if (numChars > 150) {
+ numChars = 150;
+ ellipsis = "...";
+ }
+ if (!(iPtr->flags & ERR_IN_PROGRESS)) {
+ sprintf(buf, "\n while executing\n\"%.*s%s\"",
+ numChars, cmd, ellipsis);
+ } else {
+ sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
+ numChars, cmd, ellipsis);
+ }
+ Tcl_AddObjErrorInfo(interp, buf, -1);
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* GetSrcInfoForPc --
*
* Given a program counter value, finds the closest command in the
@@ -3281,7 +3321,7 @@ GetSrcInfoForPc(pc, codePtr, lengthPtr)
* return the closest command's source info.
* This points to a bytecode instruction
* in codePtr's code. */
- ByteCode* codePtr; /* The bytecode sequence in which to look
+ ByteCode *codePtr; /* The bytecode sequence in which to look
* up the command source for the pc. */
int *lengthPtr; /* If non-NULL, the location where the
* length of the command's source should be
@@ -3948,6 +3988,16 @@ ExprRandFunc(interp, eePtr, clientData)
if (iPtr->randSeed < 0) {
iPtr->randSeed += RAND_IM;
}
+
+ /*
+ * On 64-bit architectures we need to mask off the upper bits to
+ * ensure we only have a 32-bit range. The constant has the
+ * bizarre form below in order to make sure that it doesn't
+ * get sign-extended (the rules for sign extension are very
+ * concat, particularly on 64-bit machines).
+ */
+
+ iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf);
dResult = iPtr->randSeed * (1.0/RAND_IM);
/*
diff --git a/contrib/tcl/generic/tclFileName.c b/contrib/tcl/generic/tclFileName.c
index 69d825cdac41..2024b61ce350 100644
--- a/contrib/tcl/generic/tclFileName.c
+++ b/contrib/tcl/generic/tclFileName.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclFileName.c 1.31 97/08/05 15:23:04
+ * SCCS: @(#) tclFileName.c 1.32 97/08/19 18:44:03
*/
#include "tclInt.h"
@@ -1229,7 +1229,16 @@ Tcl_GlobCmd(dummy, interp, argc, argv)
result = TclDoGlob(interp, separators, &buffer, tail);
if (result != TCL_OK) {
if (noComplain) {
+ /*
+ * We should in fact pass down the nocomplain flag
+ * or save the interp result or use another mecanism
+ * so the interp result is not mangled on errors in that case.
+ * but that would a bigger change than reasonable for a patch
+ * release.
+ * (see fileName.test 15.2-15.4 for expected behaviour)
+ */
Tcl_ResetResult(interp);
+ result = TCL_OK;
continue;
} else {
goto done;
diff --git a/contrib/tcl/generic/tclIO.c b/contrib/tcl/generic/tclIO.c
index 2b13e2d60ad3..73ff65f3d8d9 100644
--- a/contrib/tcl/generic/tclIO.c
+++ b/contrib/tcl/generic/tclIO.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclIO.c 1.268 97/07/28 14:20:36
+ * SCCS: @(#) tclIO.c 1.272 97/10/22 10:27:53
*/
#include "tclInt.h"
@@ -4352,7 +4352,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
if (writeMode) {
if (*writeMode == '\0') {
/* Do nothing. */
- } else if (strcmp(argv[0], "auto") == 0) {
+ } else if (strcmp(writeMode, "auto") == 0) {
/*
* This is a hack to get TCP sockets to produce output
* in CRLF mode if they are being set into AUTO mode.
@@ -4614,6 +4614,7 @@ ChannelTimerProc(clientData)
Channel *chanPtr = (Channel *) clientData;
if (!(chanPtr->flags & CHANNEL_GETS_BLOCKED)
+ && (chanPtr->interestMask & TCL_READABLE)
&& (chanPtr->inQueueHead != (ChannelBuffer *) NULL)
&& (chanPtr->inQueueHead->nextRemoved <
chanPtr->inQueueHead->nextAdded)) {
@@ -5458,9 +5459,11 @@ TclTestChannelEventCmd(dummy, interp, argc, argv)
mask = TCL_READABLE;
} else if (strcmp(argv[3], "writable") == 0) {
mask = TCL_WRITABLE;
- } else {
+ } else if (strcmp(argv[3], "none") == 0) {
+ mask = 0;
+ } else {
Tcl_AppendResult(interp, "bad event name \"", argv[3],
- "\": must be readable or writable", (char *) NULL);
+ "\": must be readable, writable, or none", (char *) NULL);
return TCL_ERROR;
}
@@ -5536,8 +5539,14 @@ TclTestChannelEventCmd(dummy, interp, argc, argv)
for (esPtr = chanPtr->scriptRecordPtr;
esPtr != (EventScriptRecord *) NULL;
esPtr = esPtr->nextPtr) {
- Tcl_AppendElement(interp,
- esPtr->mask == TCL_READABLE ? "readable" : "writable");
+ char *event;
+ if (esPtr->mask) {
+ event = ((esPtr->mask == TCL_READABLE)
+ ? "readable" : "writable");
+ } else {
+ event = "none";
+ }
+ Tcl_AppendElement(interp, event);
Tcl_AppendElement(interp, esPtr->script);
}
return TCL_OK;
@@ -5562,8 +5571,49 @@ TclTestChannelEventCmd(dummy, interp, argc, argv)
return TCL_OK;
}
+ if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) {
+ if (argc != 5) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName delete index event\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (index < 0) {
+ Tcl_AppendResult(interp, "bad event index: ", argv[3],
+ ": must be nonnegative", (char *) NULL);
+ return TCL_ERROR;
+ }
+ for (i = 0, esPtr = chanPtr->scriptRecordPtr;
+ (i < index) && (esPtr != (EventScriptRecord *) NULL);
+ i++, esPtr = esPtr->nextPtr) {
+ /* Empty loop body. */
+ }
+ if (esPtr == (EventScriptRecord *) NULL) {
+ Tcl_AppendResult(interp, "bad event index ", argv[3],
+ ": out of range", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ if (strcmp(argv[4], "readable") == 0) {
+ mask = TCL_READABLE;
+ } else if (strcmp(argv[4], "writable") == 0) {
+ mask = TCL_WRITABLE;
+ } else if (strcmp(argv[4], "none") == 0) {
+ mask = 0;
+ } else {
+ Tcl_AppendResult(interp, "bad event name \"", argv[4],
+ "\": must be readable, writable, or none", (char *) NULL);
+ return TCL_ERROR;
+ }
+ esPtr->mask = mask;
+ Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
+ ChannelEventScriptInvoker, (ClientData) esPtr);
+ return TCL_OK;
+ }
Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ",
- "add, delete, list, or removeall", (char *) NULL);
+ "add, delete, list, set, or removeall", (char *) NULL);
return TCL_ERROR;
}
@@ -5856,7 +5906,7 @@ CopyData(csPtr, mask)
if (errObj) {
Tcl_ListObjAppendElement(interp, cmdPtr, errObj);
}
- if (Tcl_EvalObj(interp, cmdPtr) != TCL_OK) {
+ if (Tcl_GlobalEvalObj(interp, cmdPtr) != TCL_OK) {
Tcl_BackgroundError(interp);
result = TCL_ERROR;
}
diff --git a/contrib/tcl/generic/tclIOUtil.c b/contrib/tcl/generic/tclIOUtil.c
index cb2bd94c017f..7d4cff869e88 100644
--- a/contrib/tcl/generic/tclIOUtil.c
+++ b/contrib/tcl/generic/tclIOUtil.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclIOUtil.c 1.132 97/04/23 16:21:42
+ * SCCS: @(#) tclIOUtil.c 1.133 97/09/24 16:38:57
*/
#include "tclInt.h"
@@ -220,6 +220,7 @@ Tcl_EvalFile(interp, fileName)
Tcl_DString buffer;
char *nativeName;
Tcl_Channel chan;
+ Tcl_Obj *cmdObjPtr;
Tcl_ResetResult(interp);
oldScriptFile = iPtr->scriptFile;
@@ -268,7 +269,21 @@ Tcl_EvalFile(interp, fileName)
goto error;
}
- result = Tcl_Eval(interp, cmdBuffer);
+ /*
+ * Transfer the buffer memory allocated above to the object system.
+ * Tcl_EvalObj will own this new string object if needed,
+ * so past the Tcl_EvalObj point, we must not ckfree(cmdBuffer)
+ * but rather use the reference counting mechanism.
+ * (Nb: and we must not thus not use goto error after this point)
+ */
+ cmdObjPtr = Tcl_NewObj();
+ cmdObjPtr->bytes = cmdBuffer;
+ cmdObjPtr->length = result;
+
+ Tcl_IncrRefCount(cmdObjPtr);
+ result = Tcl_EvalObj(interp, cmdObjPtr);
+ Tcl_DecrRefCount(cmdObjPtr);
+
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
@@ -283,7 +298,6 @@ Tcl_EvalFile(interp, fileName)
Tcl_AddErrorInfo(interp, msg);
}
iPtr->scriptFile = oldScriptFile;
- ckfree(cmdBuffer);
Tcl_DStringFree(&buffer);
return result;
diff --git a/contrib/tcl/generic/tclInterp.c b/contrib/tcl/generic/tclInterp.c
index ae5171a0a388..6cf3f668d208 100644
--- a/contrib/tcl/generic/tclInterp.c
+++ b/contrib/tcl/generic/tclInterp.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclInterp.c 1.125 97/08/05 15:22:51
+ * SCCS: @(#) tclInterp.c 1.128 97/11/05 09:35:12
*/
#include <stdio.h>
@@ -580,6 +580,12 @@ CreateSlave(interp, masterPtr, slavePath, safe)
Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
+ /*
+ * Inherit the recursion limit.
+ */
+ ((Interp *)slaveInterp)->maxNestingDepth =
+ ((Interp *)masterInterp)->maxNestingDepth ;
+
if (safe) {
if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
goto error;
@@ -606,6 +612,8 @@ error:
Tcl_ResetResult(slaveInterp);
(void) Tcl_DeleteCommand(masterInterp, slavePath);
+
+ ckfree((char *) argv);
return (Tcl_Interp *) NULL;
}
diff --git a/contrib/tcl/generic/tclNotify.c b/contrib/tcl/generic/tclNotify.c
index 19f38f3282ed..939624881527 100644
--- a/contrib/tcl/generic/tclNotify.c
+++ b/contrib/tcl/generic/tclNotify.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclNotify.c 1.15 97/06/18 17:14:04
+ * SCCS: @(#) tclNotify.c 1.16 97/09/15 15:12:52
*/
#include "tclInt.h"
@@ -761,6 +761,25 @@ Tcl_DoOneEvent(flags)
if (flags & TCL_DONT_WAIT) {
break;
}
+
+ /*
+ * If Tcl_WaitForEvent has returned 1,
+ * indicating that one system event has been dispatched
+ * (and thus that some Tcl code might have been indirectly executed),
+ * we break out of the loop.
+ * We do this to give VwaitCmd for instance a chance to check
+ * if that system event had the side effect of changing the
+ * variable (so the vwait can return and unwind properly).
+ *
+ * NB: We will process idle events if any first, because
+ * otherwise we might never do the idle events if the notifier
+ * always gets system events.
+ */
+
+ if (result) {
+ break;
+ }
+
}
notifier.serviceMode = oldMode;
diff --git a/contrib/tcl/generic/tclObj.c b/contrib/tcl/generic/tclObj.c
index bc697f391f87..62f892c56168 100644
--- a/contrib/tcl/generic/tclObj.c
+++ b/contrib/tcl/generic/tclObj.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclObj.c 1.45 97/07/07 18:26:00
+ * SCCS: @(#) tclObj.c 1.47 97/10/30 13:39:00
*/
#include "tclInt.h"
@@ -2092,7 +2092,7 @@ Tcl_DbDecrRefCount(objPtr, file, line)
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
- panic("Trying to increment refCount of previously disposed object.");
+ panic("Trying to decrement refCount of previously disposed object.");
}
#endif
if (--(objPtr)->refCount <= 0) {
@@ -2134,7 +2134,7 @@ Tcl_DbIsShared(objPtr, file, line)
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
- panic("Trying to increment refCount of previously disposed object.");
+ panic("Trying to check whether previously disposed object is shared.");
}
#endif
return ((objPtr)->refCount > 1);
diff --git a/contrib/tcl/generic/tclPosixStr.c b/contrib/tcl/generic/tclPosixStr.c
index 162021fca5ef..9e4588f8cfe3 100644
--- a/contrib/tcl/generic/tclPosixStr.c
+++ b/contrib/tcl/generic/tclPosixStr.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclPosixStr.c 1.32 96/10/10 10:09:42
+ * SCCS: @(#) tclPosixStr.c 1.33 97/10/08 12:40:12
*/
#include "tclInt.h"
@@ -974,7 +974,7 @@ Tcl_SignalId(sig)
#ifdef SIGKILL
case SIGKILL: return "SIGKILL";
#endif
-#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF))
+#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO))
case SIGLOST: return "SIGLOST";
#endif
#ifdef SIGPIPE
@@ -1106,7 +1106,7 @@ Tcl_SignalMsg(sig)
#ifdef SIGKILL
case SIGKILL: return "kill signal";
#endif
-#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG))
+#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO))
case SIGLOST: return "resource lost";
#endif
#ifdef SIGPIPE
diff --git a/contrib/tcl/generic/tclProc.c b/contrib/tcl/generic/tclProc.c
index 7cd94ec865e2..c9039dfee5f8 100644
--- a/contrib/tcl/generic/tclProc.c
+++ b/contrib/tcl/generic/tclProc.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclProc.c 1.115 97/08/12 13:36:11
+ * SCCS: @(#) tclProc.c 1.116 97/10/29 18:33:24
*/
#include "tclInt.h"
@@ -784,7 +784,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
localPtr = localPtr->nextPtr) {
varPtr->value.objPtr = NULL;
varPtr->name = localPtr->name; /* will be just '\0' if temp var */
- varPtr->nsPtr = procPtr->cmdPtr->nsPtr;
+ varPtr->nsPtr = NULL;
varPtr->hPtr = NULL;
varPtr->refCount = 0;
varPtr->tracePtr = NULL;
diff --git a/contrib/tcl/generic/tclStringObj.c b/contrib/tcl/generic/tclStringObj.c
index beed142d2e83..6b1f2afd7a2f 100644
--- a/contrib/tcl/generic/tclStringObj.c
+++ b/contrib/tcl/generic/tclStringObj.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclStringObj.c 1.30 97/07/24 18:53:30
+ * SCCS: @(#) tclStringObj.c 1.31 97/10/30 13:56:35
*/
#include "tclInt.h"
@@ -98,7 +98,7 @@ Tcl_NewStringObj(bytes, length)
register Tcl_Obj *objPtr;
if (length < 0) {
- length = bytes ? strlen(bytes) : 0 ;
+ length = (bytes? strlen(bytes) : 0);
}
TclNewObj(objPtr);
TclInitStringRep(objPtr, bytes, length);
@@ -154,7 +154,7 @@ Tcl_DbNewStringObj(bytes, length, file, line)
register Tcl_Obj *objPtr;
if (length < 0) {
- length = strlen(bytes);
+ length = (bytes? strlen(bytes) : 0);
}
TclDbNewObj(objPtr, file, line);
TclInitStringRep(objPtr, bytes, length);
diff --git a/contrib/tcl/generic/tclTest.c b/contrib/tcl/generic/tclTest.c
index ecc2abfdd429..80cfb9c40cc3 100644
--- a/contrib/tcl/generic/tclTest.c
+++ b/contrib/tcl/generic/tclTest.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclTest.c 1.115 97/08/13 10:27:26
+ * SCCS: @(#) tclTest.c 1.119 97/10/31 15:57:28
*/
#define TCL_TEST
@@ -59,6 +59,13 @@ static TestAsyncHandler *firstHandler = NULL;
static Tcl_DString dstring;
/*
+ * The command trace below is used by the "testcmdtraceCmd" command
+ * to test the command tracing facilities.
+ */
+
+static Tcl_Trace cmdTrace;
+
+/*
* One of the following structures exists for each command created
* by TestdelCmd:
*/
@@ -84,6 +91,11 @@ static int CmdProc1 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
static int CmdProc2 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
+static void CmdTraceDeleteProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int level, char *command, Tcl_CmdProc *cmdProc,
+ ClientData cmdClientData, int argc,
+ char **argv));
static void CmdTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int level, char *command,
Tcl_CmdProc *cmdProc, ClientData cmdClientData,
@@ -167,6 +179,9 @@ static int TestsetobjerrorcodeCmd _ANSI_ARGS_((
int objc, Tcl_Obj *CONST objv[]));
static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestsetrecursionlimitCmd _ANSI_ARGS_((
+ ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
@@ -274,6 +289,9 @@ Tcltest_Init(interp)
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testsetrecursionlimit",
+ TestsetrecursionlimitCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
@@ -661,28 +679,42 @@ TestcmdtraceCmd(dummy, interp, argc, argv)
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
- Tcl_Trace trace;
Tcl_DString buffer;
int result;
- if (argc != 2) {
+ if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " script\"", (char *) NULL);
+ " option script\"", (char *) NULL);
return TCL_ERROR;
}
- Tcl_DStringInit(&buffer);
- trace = Tcl_CreateTrace(interp, 50000,
- (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
-
- result = Tcl_Eval(interp, argv[1]);
- if (result == TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
+ if (strcmp(argv[1], "tracetest") == 0) {
+ Tcl_DStringInit(&buffer);
+ cmdTrace = Tcl_CreateTrace(interp, 50000,
+ (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
+ result = Tcl_Eval(interp, argv[2]);
+ if (result == TCL_OK) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
+ }
+ Tcl_DeleteTrace(interp, cmdTrace);
+ Tcl_DStringFree(&buffer);
+ } else if (strcmp(argv[1], "deletetest") == 0) {
+ /*
+ * Create a command trace then eval a script to check whether it is
+ * called. Note that this trace procedure removes itself as a
+ * further check of the robustness of the trace proc calling code in
+ * TclExecuteByteCode.
+ */
+
+ cmdTrace = Tcl_CreateTrace(interp, 50000,
+ (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
+ result = Tcl_Eval(interp, argv[2]);
+ } else {
+ Tcl_AppendResult(interp, "bad option \"", argv[1],
+ "\": must be tracetest or deletetest", (char *) NULL);
+ return TCL_ERROR;
}
-
- Tcl_DeleteTrace(interp, trace);
- Tcl_DStringFree(&buffer);
return TCL_OK;
}
@@ -713,6 +745,29 @@ CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData,
}
Tcl_DStringEndSublist(bufPtr);
}
+
+static void
+CmdTraceDeleteProc(clientData, interp, level, command, cmdProc,
+ cmdClientData, argc, argv)
+ ClientData clientData; /* Unused. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int level; /* Current trace level. */
+ char *command; /* The command being traced (after
+ * substitutions). */
+ Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */
+ ClientData cmdClientData; /* Client data associated with command
+ * procedure. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ /*
+ * Remove ourselves to test whether calling Tcl_DeleteTrace within
+ * a trace callback causes the for loop in TclExecuteByteCode that
+ * calls traces to reference freed memory.
+ */
+
+ Tcl_DeleteTrace(interp, cmdTrace);
+}
/*
*----------------------------------------------------------------------
@@ -1794,6 +1849,47 @@ TestsetplatformCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * TestsetrecursionlimitCmd --
+ *
+ * This procedure implements the "testsetrecursionlimit" command. It is
+ * used to change the interp recursion limit (to test the effects
+ * of Tcl_SetRecursionLimit).
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Sets the interp's recursion limit.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestsetrecursionlimitCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* The argument objects. */
+{
+ int value;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "integer");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ value = Tcl_SetRecursionLimit(interp, value);
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), value);
+ return TCL_OK;
+}
+
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* TeststaticpkgCmd --
*
* This procedure implements the "teststaticpkg" command.
@@ -2164,7 +2260,7 @@ TestchmodCmd(dummy, interp, argc, argv)
}
mode = (int) strtol(argv[1], &rest, 8);
- if (*rest != '\0') {
+ if ((rest == argv[1]) || (*rest != '\0')) {
goto usage;
}
diff --git a/contrib/tcl/generic/tclVar.c b/contrib/tcl/generic/tclVar.c
index 587eca9dd70e..f013e6559b34 100644
--- a/contrib/tcl/generic/tclVar.c
+++ b/contrib/tcl/generic/tclVar.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclVar.c 1.125 97/08/06 14:47:55
+ * SCCS: @(#) tclVar.c 1.130 97/10/29 18:26:16
*/
#include "tclInt.h"
@@ -2630,7 +2630,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
Tcl_Obj *varValuePtr, *newValuePtr;
register List *listRepPtr;
register Tcl_Obj **elemPtrs;
- int numElems, numRequired, createdNewObj, i, j;
+ int numElems, numRequired, createdNewObj, createVar, i, j;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
@@ -2666,10 +2666,30 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
*/
createdNewObj = 0;
+ createVar = 1;
varValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL,
TCL_PARSE_PART1);
- if (varValuePtr == NULL) { /* no old value: append to new obj */
- varValuePtr = Tcl_NewObj();
+ if (varValuePtr == NULL) {
+ /*
+ * We couldn't read the old value: either the var doesn't yet
+ * exist or it's an array element. If it's new, we will try to
+ * create it with Tcl_ObjSetVar2 below.
+ */
+
+ char *name, *p;
+ int nameBytes, i;
+
+ name = TclGetStringFromObj(objv[1], &nameBytes);
+ for (i = 0, p = name; i < nameBytes; i++, p++) {
+ if (*p == '(') {
+ p = (name + nameBytes-1);
+ if (*p == ')') { /* last char is ')' => array ref */
+ createVar = 0;
+ }
+ break;
+ }
+ }
+ varValuePtr = Tcl_NewObj();
createdNewObj = 1;
} else if (Tcl_IsShared(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
@@ -2732,13 +2752,13 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
/*
* Now store the list object back into the variable. If there is an
* error setting the new value, decrement its ref count if it
- * was new.
+ * was new and we didn't create the variable.
*/
newValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL,
varValuePtr, (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1));
if (newValuePtr == NULL) {
- if (createdNewObj) {
+ if (createdNewObj && !createVar) {
Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */
}
return TCL_ERROR;
@@ -2779,8 +2799,8 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- static char *arrayOptions[] = {"anymore", "donesearch", "exists", "get",
- "names", "nextelement", "set", "size", "startsearch",
+ static char *arrayOptions[] = {"anymore", "donesearch", "exists",
+ "get", "names", "nextelement", "set", "size", "startsearch",
(char *) NULL};
Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
@@ -2804,19 +2824,17 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
* Locate the array variable (and it better be an array).
* THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE.
*/
+
varName = TclGetStringFromObj(objv[2], (int *) NULL);
varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
notArray = 0;
- if (varPtr == NULL) {
+ if ((varPtr == NULL) || !TclIsVarArray(varPtr)
+ || TclIsVarUndefined(varPtr)) {
notArray = 1;
- } else {
- if (!TclIsVarArray(varPtr)) {
- notArray = 1;
- }
}
-
+
switch (index) {
case 0: { /* anymore */
ArraySearch *searchPtr;
@@ -2921,22 +2939,23 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
}
namePtr = Tcl_NewStringObj(name, -1);
- result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
+ result = Tcl_ListObjAppendElement(interp, resultPtr,
+ namePtr);
if (result != TCL_OK) {
- Tcl_DecrRefCount(namePtr); /* free unneeded name object */
+ Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
return result;
}
-
- if (varPtr2->value.objPtr == NULL) {
- TclNewObj(valuePtr);
- } else {
- valuePtr = varPtr2->value.objPtr;
+
+ valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr,
+ TCL_LEAVE_ERR_MSG);
+ if (valuePtr == NULL) {
+ Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
+ return result;
}
- result = Tcl_ListObjAppendElement(interp, resultPtr, valuePtr);
+ result = Tcl_ListObjAppendElement(interp, resultPtr,
+ valuePtr);
if (result != TCL_OK) {
- if (varPtr2->value.objPtr == NULL) {
- Tcl_DecrRefCount(valuePtr); /* free unneeded object */
- }
+ Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
return result;
}
}
@@ -3037,11 +3056,37 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
"list must have an even number of elements", -1);
return TCL_ERROR;
}
- for (i = 0; i < listLen; i += 2) {
- if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i], elemPtrs[i+1],
- TCL_LEAVE_ERR_MSG) == NULL) {
- result = TCL_ERROR;
- break;
+ if (listLen > 0) {
+ for (i = 0; i < listLen; i += 2) {
+ if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i],
+ elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) {
+ result = TCL_ERROR;
+ break;
+ }
+ }
+ } else if (varPtr == NULL) {
+ /*
+ * The list is empty and the array variable doesn't
+ * exist yet: create the variable with an empty array
+ * as the value.
+ */
+
+ Tcl_Obj *namePtr, *valuePtr;
+
+ namePtr = Tcl_NewStringObj("tempElem", -1);
+ valuePtr = Tcl_NewObj();
+ if (Tcl_ObjSetVar2(interp, objv[2], namePtr, valuePtr,
+ /* flags*/ 0) == NULL) {
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
+ return TCL_ERROR;
+ }
+ result = Tcl_UnsetVar2(interp, varName, "tempElem",
+ TCL_LEAVE_ERR_MSG);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
+ return result;
}
}
return result;
@@ -3206,6 +3251,21 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags)
myName, "\": unknown namespace", (char *) NULL);
return TCL_ERROR;
}
+
+ /*
+ * Check that we are not trying to create a namespace var linked to
+ * a local variable in a procedure. If we allowed this, the local
+ * variable in the shorter-lived procedure frame could go away
+ * leaving the namespace var's reference invalid.
+ */
+
+ if (otherPtr->nsPtr == NULL) {
+ Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
+ myName, "\": upvar won't create namespace variable that refers to procedure variable",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
hPtr = Tcl_CreateHashEntry(&nsPtr->varTable, tail, &new);
if (new) {
varPtr = NewVar();
generated by cgit v1.2.3 (git 2.25.1) at 2022-07-05 16:46:38 +0000