summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.h6
-rw-r--r--generic/tclBasic.c2
-rw-r--r--generic/tclCmdAH.c10
-rw-r--r--generic/tclCompExpr.c144
-rw-r--r--generic/tclDTrace.d16
-rw-r--r--generic/tclDecls.h2
-rw-r--r--generic/tclIORTrans.c7
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclInterp.c26
-rw-r--r--generic/tclMain.c9
-rw-r--r--generic/tclOOMethod.c2
-rwxr-xr-xgeneric/tclStrToD.c12
-rw-r--r--generic/tclUtil.c3
13 files changed, 162 insertions, 80 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index 7370516..7a94956 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2373,8 +2373,10 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
* Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171]
*/
-EXTERN void Tcl_Main(int argc, char **argv,
- Tcl_AppInitProc *appInitProc);
+#define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \
+ (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)()))
+EXTERN void Tcl_MainEx(int argc, char **argv,
+ Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
const char *version, int exact);
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index f0f0c0f..9758449 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -215,7 +215,7 @@ static const CmdInfo builtInCmds[] = {
{"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1},
{"coroutine", NULL, NULL, TclNRCoroutineObjCmd, 1},
{"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, 1},
- {"eval", Tcl_EvalObjCmd, NULL, NULL, 1},
+ {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, 1},
{"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1},
{"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1},
{"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1},
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 765c9dc..fc9d39d 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -737,6 +737,16 @@ Tcl_EvalObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, dummy, objc, objv);
+}
+
+int
+TclNREvalObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
register Tcl_Obj *objPtr;
Interp *iPtr = (Interp *) interp;
CmdFrame *invoker = NULL;
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index d1d7403..d96670c 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -659,11 +659,6 @@ ParseExpr(
Tcl_Obj *literal; /* Filled by the ParseLexeme() call when a
* literal is parsed that has a Tcl_Obj rep
* worth preserving. */
- const char *lastStart = start - scanned;
- /* Compute where the lexeme parsed the
- * previous pass through the loop began. This
- * is helpful for detecting invalid octals and
- * providing more complete error messages. */
/*
* Each pass through this loop adds up to one more OpNode. Allocate
@@ -754,33 +749,39 @@ ParseExpr(
Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...",
(scanned < limit) ? scanned : limit - 3,
start, (scanned < limit) ? "" : "...");
- if (NotOperator(lastParsed)) {
- errCode = "BADNUMBER";
- if ((lastStart[0] == '0')
- && ((lastStart[1] == 'o')
- || (lastStart[1] == 'O'))
- && (lastStart[2] >= '0')
- && (lastStart[2] <= '9')) {
- const char *end = lastStart + 2;
- Tcl_Obj *copy;
-
- while (isdigit(UCHAR(*end))) {
- end++;
- }
- copy = Tcl_NewStringObj(lastStart, end-lastStart);
- if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) {
+ errCode = "BAREWORD";
+ if (start[0] == '0') {
+ const char *stop;
+ TclParseNumber(NULL, NULL, NULL, start, scanned,
+ &stop, TCL_PARSE_NO_WHITESPACE);
+
+ if (isdigit(UCHAR(*stop)) || (stop == start + 1)) {
+ switch (start[1]) {
+ case 'b':
+ Tcl_AppendToObj(post,
+ " (invalid binary number?)", -1);
+ parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
+ errCode = "BADNUMBER";
+ subErrCode = "BINARY";
+ break;
+ case 'o':
Tcl_AppendToObj(post,
" (invalid octal number?)", -1);
+ parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
errCode = "BADNUMBER";
subErrCode = "OCTAL";
+ break;
+ default:
+ if (isdigit(UCHAR(start[1]))) {
+ Tcl_AppendToObj(post,
+ " (invalid octal number?)", -1);
+ parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
+ errCode = "BADNUMBER";
+ subErrCode = "OCTAL";
+ }
+ break;
}
- Tcl_DecrRefCount(copy);
}
- scanned = 0;
- insertMark = 1;
- parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
- } else {
- errCode = "BAREWORD";
}
goto error;
}
@@ -824,20 +825,8 @@ ParseExpr(
if (NotOperator(lastParsed)) {
msg = Tcl_ObjPrintf("missing operator at %s", mark);
errCode = "MISSING";
- if (lastStart[0] == '0') {
- Tcl_Obj *copy = Tcl_NewStringObj(lastStart,
- start + scanned - lastStart);
-
- if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) {
- TclNewLiteralStringObj(post,
- "looks like invalid octal number");
- errCode = "BADNUMBER_OCTAL";
- }
- Tcl_DecrRefCount(copy);
- }
scanned = 0;
insertMark = 1;
- parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
/* Free any literal to avoid a memleak. */
if ((lexeme == NUMBER) || (lexeme == BOOLEAN)) {
@@ -1996,14 +1985,53 @@ ParseLexeme(
literal = Tcl_NewObj();
if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end,
TCL_PARSE_NO_WHITESPACE) == TCL_OK) {
- TclInitStringRep(literal, start, end-start);
- *lexemePtr = NUMBER;
- if (literalPtr) {
- *literalPtr = literal;
+ if (end < start + numBytes && !isalnum(UCHAR(*end))
+ && UCHAR(*end) != '_') {
+
+ number:
+ TclInitStringRep(literal, start, end-start);
+ *lexemePtr = NUMBER;
+ if (literalPtr) {
+ *literalPtr = literal;
+ } else {
+ Tcl_DecrRefCount(literal);
+ }
+ return (end-start);
} else {
- Tcl_DecrRefCount(literal);
+ unsigned char lexeme;
+
+ /*
+ * We have a number followed directly by bareword characters
+ * (alpha, digit, underscore). Is this a number followed by
+ * bareword syntax error? Or should we join into one bareword?
+ * Example: Inf + luence + () becomes a valid function call.
+ * [Bug 3401704]
+ */
+ if (literal->typePtr == &tclDoubleType) {
+ const char *p = start;
+ while (p < end) {
+ if (!isalnum(UCHAR(*p++))) {
+ /*
+ * The number has non-bareword characters, so we
+ * must treat it as a number.
+ */
+ goto number;
+ }
+ }
+ }
+ ParseLexeme(end, numBytes-(end-start), &lexeme, NULL);
+ if ((NODE_TYPE & lexeme) == BINARY) {
+ /*
+ * The bareword characters following the number take the
+ * form of an operator (eq, ne, in, ni, ...) so we treat
+ * as number + operator.
+ */
+ goto number;
+ }
+ /*
+ * Otherwise, fall through and parse the whole as a bareword.
+ */
}
- return (end-start);
}
if (Tcl_UtfCharComplete(start, numBytes)) {
@@ -2015,7 +2043,7 @@ ParseLexeme(
utfBytes[numBytes] = '\0';
scanned = Tcl_UtfToUniChar(utfBytes, &ch);
}
- if (!isalpha(UCHAR(ch))) {
+ if (!isalnum(UCHAR(ch))) {
*lexemePtr = INVALID;
Tcl_DecrRefCount(literal);
return scanned;
@@ -2443,8 +2471,30 @@ CompileExprTree(
if (ExecConstantExprTree(interp, nodes, next, litObjvPtr)
== TCL_OK) {
- TclEmitPush(TclAddLiteralObj(envPtr,
- Tcl_GetObjResult(interp), NULL), envPtr);
+ int index;
+ Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
+
+ /*
+ * Don't generate a string rep, but if we have one
+ * already, then use it to share via the literal table.
+ */
+ if (objPtr->bytes) {
+ Tcl_Obj *tableValue;
+
+ index = TclRegisterNewLiteral(envPtr, objPtr->bytes,
+ objPtr->length);
+ tableValue = envPtr->literalArrayPtr[index].objPtr;
+ if ((tableValue->typePtr == NULL) &&
+ (objPtr->typePtr != NULL)) {
+ /* Same intrep surgery as for OT_LITERAL */
+ tableValue->typePtr = objPtr->typePtr;
+ tableValue->internalRep = objPtr->internalRep;
+ objPtr->typePtr = NULL;
+ }
+ } else {
+ index = TclAddLiteralObj(envPtr, objPtr, NULL);
+ }
+ TclEmitPush(index, envPtr);
} else {
TclCompileSyntaxError(interp, envPtr);
}
diff --git a/generic/tclDTrace.d b/generic/tclDTrace.d
index 0ee592f..360bdff 100644
--- a/generic/tclDTrace.d
+++ b/generic/tclDTrace.d
@@ -25,7 +25,7 @@ provider tcl {
* arg1: number of arguments (int)
* arg2: array of proc argument objects (Tcl_Obj**)
*/
- probe proc__entry(TclDTraceStr name, int objc, Tcl_Obj **objv);
+ probe proc__entry(TclDTraceStr name, int objc, struct Tcl_Obj **objv);
/*
* tcl*:::proc-return probe
* triggered immediately after proc bytecode execution
@@ -42,7 +42,7 @@ provider tcl {
* arg3: proc result object (Tcl_Obj*)
*/
probe proc__result(TclDTraceStr name, int code, TclDTraceStr result,
- Tcl_Obj *resultobj);
+ struct Tcl_Obj *resultobj);
/*
* tcl*:::proc-args probe
* triggered before proc-entry probe, gives access to string
@@ -79,7 +79,7 @@ provider tcl {
* arg1: number of arguments (int)
* arg2: array of command argument objects (Tcl_Obj**)
*/
- probe cmd__entry(TclDTraceStr name, int objc, Tcl_Obj **objv);
+ probe cmd__entry(TclDTraceStr name, int objc, struct Tcl_Obj **objv);
/*
* tcl*:::cmd-return probe
* triggered immediately after commmand execution
@@ -96,7 +96,7 @@ provider tcl {
* arg3: command result object (Tcl_Obj*)
*/
probe cmd__result(TclDTraceStr name, int code, TclDTraceStr result,
- Tcl_Obj *resultobj);
+ struct Tcl_Obj *resultobj);
/*
* tcl*:::cmd-args probe
* triggered before cmd-entry probe, gives access to string
@@ -133,7 +133,7 @@ provider tcl {
* arg1: depth of stack (int)
* arg2: top of stack (Tcl_Obj**)
*/
- probe inst__start(TclDTraceStr name, int depth, Tcl_Obj **stack);
+ probe inst__start(TclDTraceStr name, int depth, struct Tcl_Obj **stack);
/*
* tcl*:::inst-done probe
* triggered immediately after execution of a bytecode
@@ -141,7 +141,7 @@ provider tcl {
* arg1: depth of stack (int)
* arg2: top of stack (Tcl_Obj**)
*/
- probe inst__done(TclDTraceStr name, int depth, Tcl_Obj **stack);
+ probe inst__done(TclDTraceStr name, int depth, struct Tcl_Obj **stack);
/***************************** obj probes ******************************/
/*
@@ -149,13 +149,13 @@ provider tcl {
* triggered immediately after a new Tcl_Obj has been created
* arg0: object created (Tcl_Obj*)
*/
- probe obj__create(Tcl_Obj* obj);
+ probe obj__create(struct Tcl_Obj* obj);
/*
* tcl*:::obj-free probe
* triggered immediately before a Tcl_Obj is freed
* arg0: object to be freed (Tcl_Obj*)
*/
- probe obj__free(Tcl_Obj* obj);
+ probe obj__free(struct Tcl_Obj* obj);
/***************************** tcl probes ******************************/
/*
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 1df7e14..1f7dfe6 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -3791,8 +3791,6 @@ extern const TclStubs *tclStubsPtr;
# define Tcl_MainEx Tcl_MainExW
EXTERN void Tcl_MainExW(int argc, wchar_t **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
-# define Tcl_Main(argc, argv, proc) Tcl_MainExW(argc, argv, proc, \
- (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)()))
#endif
#undef TCL_STORAGE_CLASS
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 4806690..fa973c7 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -2191,6 +2191,7 @@ DeleteReflectedTransformMap(
Tcl_ConditionNotify(&resultPtr->done);
}
+ Tcl_MutexUnlock(&rtForwardMutex);
/*
* Get the map of all channels handled by the current thread. This is a
@@ -2215,8 +2216,6 @@ DeleteReflectedTransformMap(
Tcl_DeleteHashEntry(hPtr);
}
-
- Tcl_MutexUnlock(&rtForwardMutex);
#endif
}
@@ -2323,6 +2322,7 @@ DeleteThreadReflectedTransformMap(
Tcl_ConditionNotify(&resultPtr->done);
}
+ Tcl_MutexUnlock(&rtForwardMutex);
/*
* Get the map of all channels handled by the current thread. This is a
@@ -2339,8 +2339,7 @@ DeleteThreadReflectedTransformMap(
rtPtr->interp = NULL;
Tcl_DeleteHashEntry(hPtr);
}
-
- Tcl_MutexUnlock(&rtForwardMutex);
+ ckfree(rtmPtr);
}
static void
diff --git a/generic/tclInt.h b/generic/tclInt.h
index d65f712..f30e83e 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2768,7 +2768,7 @@ MODULE_SCOPE char tclEmptyString;
*/
MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
-MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
@@ -2778,6 +2778,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index a156a57..5b6d14f 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -4345,6 +4345,19 @@ SlaveCommandLimitCmd(
ScriptLimitCallback *limitCBPtr;
Tcl_HashEntry *hPtr;
+ /*
+ * First, ensure that we are not reading or writing the calling
+ * interpreter's limits; it may only manipulate its children. Note that
+ * the low level API enforces this with Tcl_Panic, which we want to
+ * avoid. [Bug 3398794]
+ */
+
+ if (interp == slaveInterp) {
+ Tcl_AppendResult(interp,
+ "limits on current interpreter inaccessible", NULL);
+ return TCL_ERROR;
+ }
+
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
@@ -4519,6 +4532,19 @@ SlaveTimeLimitCmd(
ScriptLimitCallback *limitCBPtr;
Tcl_HashEntry *hPtr;
+ /*
+ * First, ensure that we are not reading or writing the calling
+ * interpreter's limits; it may only manipulate its children. Note that
+ * the low level API enforces this with Tcl_Panic, which we want to
+ * avoid. [Bug 3398794]
+ */
+
+ if (interp == slaveInterp) {
+ Tcl_AppendResult(interp,
+ "limits on current interpreter inaccessible", NULL);
+ return TCL_ERROR;
+ }
+
if (objc == consumedObjc) {
Tcl_Obj *dictPtr;
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 114d2c3..373e3f6 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -620,18 +620,19 @@ Tcl_MainEx(
Tcl_Exit(exitCode);
}
-#ifndef UNICODE
-void
+#if (TCL_MAJOR_VERSION == 8) && !defined(UNICODE)
+#undef Tcl_Main
+extern DLLEXPORT void
Tcl_Main(
int argc, /* Number of arguments. */
- TCHAR **argv, /* Array of argument strings. */
+ char **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc)
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
{
Tcl_FindExecutable(argv[0]);
- Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
+ Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
}
#endif
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 4e7edb8..708295a 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -1595,7 +1595,7 @@ InitEnsembleRewrite(
if (isRootEnsemble) {
iPtr->ensembleRewrite.sourceObjs = objv;
iPtr->ensembleRewrite.numRemovedObjs = toRewrite;
- iPtr->ensembleRewrite.numInsertedObjs = rewriteLength;
+ iPtr->ensembleRewrite.numInsertedObjs = rewriteLength - 1;
} else {
int numIns = iPtr->ensembleRewrite.numInsertedObjs;
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index a55ee83..332cfca 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -249,15 +249,6 @@ static const int itens [] = {
100000000
};
-static const Tcl_WideUInt wtens[] = {
- 1, 10, 100, 1000, 10000, 100000, 1000000,
- (Tcl_WideUInt) 1000000*10, (Tcl_WideUInt) 1000000*100,
- (Tcl_WideUInt) 1000000*1000, (Tcl_WideUInt) 1000000*10000,
- (Tcl_WideUInt) 1000000*100000, (Tcl_WideUInt) 1000000*1000000,
- (Tcl_WideUInt) 1000000*1000000*10, (Tcl_WideUInt) 1000000*1000000*100,
- (Tcl_WideUInt) 1000000*1000000*1000,(Tcl_WideUInt) 1000000*1000000*10000
-};
-
static const double bigtens[] = {
1e016, 1e032, 1e064, 1e128, 1e256
};
@@ -1101,7 +1092,10 @@ TclParseNumber(
d = 10 + c - 'a';
} else if (c >= 'A' && c <= 'F') {
d = 10 + c - 'A';
+ } else {
+ goto endgame;
}
+ numSigDigs++;
significandWide = (significandWide << 4) + d;
state = sNANHEX;
break;
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 51508d2..31c9fd3 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -3156,7 +3156,8 @@ TclFormatInt(buffer, n)
* negating it produces the same value.
*/
- if (n == -n) {
+ intVal = -n; /* [Bug 3390638] Workaround for*/
+ if (n == -n || intVal == n) { /* broken compiler optimizers. */
return sprintf(buffer, "%ld", n);
}
generated by cgit v0.12 at 2024-11-21 17:10:38 (GMT)