ADDED doc/=.n Index: doc/=.n ================================================================== --- doc/=.n +++ doc/=.n @@ -0,0 +1,148 @@ +'\" +'\" Copyright (c) 2025 Colin G. Macleod. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH = n 9.1 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME += \- Evaluate a concise form of numerical and/or logical expression +.SH SYNOPSIS +\fB= \fIarg \fR?\fIarg arg ...\fR? +.BE +.SH DESCRIPTION +.PP +This command takes the \fIarg\fRs given as a numerical and/or logical expression +and evaluates that expression, returning its value. +The \fB=\fR command can be used as a concise alternative to \fBexpr\fR when the +expression does not involve string values. +For example, if variable \fIa\fR has value 6, the command +.PP +.CS +\fB=\fR 8.2 + a +.CE +.PP +returns 14.2. +.PP +An expression consists of a combination of operands, operators, parentheses and +commas, possibly with whitespace between any of these elements, which is +ignored. Operands are always interpreted as numeric values. +.SS OPERANDS +.PP +Each operand has one of the following forms: +.RS +.TP +A literal \fBnumeric value\fR +. +Any of the forms accepted by \fBstring is integer\fR or \fBstring is double\fR +\fIunless\fR it starts with a letter. +Exceptional values like "inf" or "nan" are not accepted. +.TP +A \fBvariable\fR +. +Any sequence of characters which starts with an alphabetic character and +continues with alphanumeric characters, underscores or colons and \fIdoes not\fR +terminate with \fB(\fR will be treated as a variable name and its value +will be substituted into the expression. +It is an error for that value to be non-numeric. +This is \fInot\fR compatible with \fBexpr\fR, which requires \fB$\fR in +front of each variable name. +.TP +A function call. +. +Any sequence of characters which starts with an alphabetic character and +continues with alphanumeric characters, underscores or colons and \fIdoes\fR +terminate with \fB(\fR will be treated as a function call, and should be +followed by any arguments it takes, separated by commas and terminated by \fB)\fR. +This is a mathematical function such as \fBsin(x)\fR, whose arguments have any of +the above forms for operands. +All the standard functions listed at \fBmathfunc\fR(n) can be used, +and new functions can be defined as described in \fBexpr\fR(n). +This is compatible with \fBexpr\fR. +.RE +.PP +Because \fB=\fR does not perform the same substitutions as \fBTcl\fR, +it is not necessary to enclose expressions in braces to avoid double substitution. +.PP +.SS OPERATORS +.PP +Any of the numeric and logical operators described in \fBexpr\fR(n) can be used, +with the same precedence and associativity. +Internally the same code is used and so should always give the same results. +The string operators \fBeq ne in ni lt le gt ge\fR are not available. +.SH "SAFETY AND PERFORMANCE CONSIDERATIONS" +.PP +In general, it is both safer and more efficient to write all variables used in +\fB=\fR \fIwithout $\fR. Writing variables with \fB$\fR exposes +the program to similar issues of double-substitution as writing unbraced +expressions with \fBexpr\fR. This is particularly risky if calculations are +done with unverified user input. E.g. if a user can enter "::admin_password" +where a number was expected and this is stored in variable input and then used as +.CS +[= $input/100] +.CE +this will try to use the value of ::admin_password as a +variable name and generate an error message exposing that value. However if the +calculation is written as +.CS +[= input/100] +.CE +it will just give an error saying that "::admin_password" is not a valid number. +.PP +This command will not substitute array elements without \fB$\fR as these +cannot be distinguished from function calls. If an expression needs to +use an array element, that can be written with \fB$\fR and it will then +be substituted by \fBTcl\fR before the \fB=\fR command runs, assuming +the arguments are not braced. +\fBBeware\fR, the array element's value should be numeric; +if it is alphanumeric it will be treated as a variable name by \fB=\fR. +More efficient code can be generated if such an array reference is +written as a distinct argument, i.e. separated by space from the rest +of the expression, e.g. +.CS +set x [= 2* $foo(bar) -1] +.CE +rather than +.CS +set x [= 2*$foo(bar)-1] +.CE +.PP +Similarly, the \fB=\fR command will not do \fB[]\fR command substitutions +internally as \fBexpr\fR does, but these can be done before \fB=\fR runs. +The same caveats apply: the result should be numeric, and writing the +\fB[]\fR substitution as a separate argument will allow more efficient +execution. +.SH EXAMPLES +.PP +Calculate distance in 2-D coordinates: +.PP +.CS +set r [\fB=\fR sqrt(x**2 + y**2)] +.CE +.PP +Take reciprocal of x, guarding against division by zero: +.PP +.CS +set rx [\fB=\fR x==0 ? 0 : 1.0/x] +.CE +.PP +Calculate arguments for a \fBTk\fR image command: +.PP +.CS +my_img put $shade -to [\fB=\fR left+i] $top [\fB=\fR left+i+1] $bottom +.CE +.SH "SEE ALSO" +expr(n), mathfunc(n), mathop(n), Tcl(n) +.SH KEYWORDS +arithmetic, boolean, compare, expression, integer value +.SH COPYRIGHT +.nf +Copyright \(co 2025 Colin G. Macleod. +.fi +'\" Local Variables: +'\" mode: nroff +'\" fill-column: 78 +'\" End: Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -379,10 +379,11 @@ {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, CMD_IS_SAFE}, {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE}, {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE}, {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, + {"=", Tcl_EqualsObjCmd, TclCompileEqualsCmd, NULL, CMD_IS_SAFE}, /* * Commands in the OS-interface. Note that many of these are unsafe. */ Index: generic/tclCompExpr.c ================================================================== --- generic/tclCompExpr.c +++ generic/tclCompExpr.c @@ -11,10 +11,11 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" /* CompileEnv */ +#include /* * Expression parsing takes place in the routine ParseExpr(). It takes a * string as input, parses that string, and generates a representation of the * expression in the form of a tree of operators, a list of literals, a list @@ -2860,12 +2861,622 @@ Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected); return TCL_ERROR; } return TclVariadicOpCmd(clientData, interp, objc, objv); } + +// Compilation support for the Equals '=' command. + +// Custom Object Type for compiling an expression with pre-substitutions. +// The InternalRep will hold the Tcl_LVTIndex of the runtime value. +static const Tcl_ObjType eqPresubType = { + "presub", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 +}; + +// EqInput holds the current state of scanning the input expression. +typedef struct EqInput { + int argc; /* Argument count. */ + Tcl_Obj *const *argv; /* Argument objects. */ + int argpos; /* Current argument. */ + int charpos; /* Character position within current argument. */ + unsigned char lex; /* Current Lexeme. */ + Tcl_Obj *lit; /* Current Literal. */ + const char *lastStart; /* Start of the last lexeme scanned */ + Tcl_Size lastLen; /* Length of the last lexeme scanned */ + const char *errorFound; /* If set, describes error encountered. */ +} EqInput; + +// Get the next lexeme of the input, setting in->lex and in->lit. +// Also advances in->argpos and/or in->charpos +// and sets in->lastStart and in->lastLen. +void EqNextLex( + EqInput *in) +{ + const char *start; + Tcl_Size numBytes; + Tcl_Size scanned; + if (in->errorFound) return; + + while (1) { + // Check if we're at the end. + if (in->argpos >= in->argc) { + in->lex = 0; + in->lastStart = ""; + in->lastLen = 0; + return; + } + // If this argument already has a numeric internal rep, preserve that. + Tcl_Obj *const thisArg = in->argv[in->argpos]; + if (in->charpos==0 && ( + TclHasInternalRep(thisArg, &tclIntType) || + TclHasInternalRep(thisArg, &tclBignumType) || + TclHasInternalRep(thisArg, &tclBooleanType) || + TclHasInternalRep(thisArg, &tclDoubleType) + ) ) { + in->lex = NUMBER; + in->lit = in->argv[in->argpos++]; + return; + } + // Check if we are compiling but hit a value needing pre-substitution. + if (in->charpos==0 && ( + TclHasInternalRep(thisArg, &eqPresubType) + ) ) { + // Not necessarily a script but some kind of value we need to + // generate code to get at runtime. + in->lex = SCRIPT; + in->lit = in->argv[in->argpos++]; + return; + } + // Otherwise treat the argument as a string and scan it. + start = TclGetStringFromObj(thisArg, &numBytes); + start += in->charpos; + numBytes -= in->charpos; + + scanned = TclParseAllWhiteSpace(start, numBytes); + start += scanned; + numBytes -= scanned; + in->charpos += scanned; + + if (numBytes > 0) break; + in->argpos++; + in->charpos = 0; + } + + in->lastStart = start; + scanned = ParseLexeme(start, numBytes, &(in->lex), &(in->lit)); + start += scanned; + numBytes -= scanned; + + // Special cases that we need to modify. + switch (in->lex) { + // Don't treat NAN, INF, etc. as numbers. + case NUMBER: + if (isalpha(*in->lastStart)) { + in->lex = BAREWORD; + Tcl_SetStringObj(in->lit, in->lastStart, scanned); + } + break; + // Double colon introduces a global variable, single is for ternary op. + case COLON: + if ((numBytes < 1) || (start[0] != ':')) break; + scanned++; + start++; + numBytes--; + TCL_FALLTHROUGH(); + // We don't support the string/list operators, convert them to literals. + case STREQ: + case STRNEQ: + case IN_LIST: + case NOT_IN_LIST: + case STR_LT: + case STR_GT: + case STR_LEQ: + case STR_GEQ: + in->lex = BAREWORD; + in->lit = Tcl_NewStringObj(in->lastStart, scanned); + break; + // BAREWORD will become a variable or function name, + // but only if it starts with a letter. + case BAREWORD: + if (isalpha(*in->lastStart)) break; + TCL_FALLTHROUGH(); + case SCRIPT: + in->lex = INVALID; + in->lit = Tcl_NewStringObj(in->lastStart, scanned); + } + // Collect the whole of a namespaced name. + if (in->lex == BAREWORD) { + while (numBytes) { + if (TclIsBareword(*start)) { + start++; + numBytes--; + continue; + } + if (*start==':' && numBytes>1 && start[1]==':') { + start += 2; + numBytes -= 2; + continue; + } + break; + } + const char *extraStart = in->lastStart+scanned; + Tcl_Size extraLen = start-extraStart; + if (extraLen) { + Tcl_AppendToObj(in->lit, extraStart, extraLen); + } + } + scanned = start - in->lastStart; + in->charpos += scanned; + in->lastLen = scanned; + + if (numBytes <= 0) { + in->argpos++; + in->charpos = 0; + } + return; +} + +// The following EqParse* routines implement a simple Pratt Parser loosely +// based on https://www.rosettacode.org/wiki/Arithmetic_evaluation#Nim + +// Forward declarations: +void EqParsePrefix(EqInput *in, CompileEnv *envPtr); +void EqParseFuncArgs(EqInput *in, CompileEnv *envPtr); +void EqParseAnd(EqInput *in, CompileEnv *envPtr); +void EqParseOr(EqInput *in, CompileEnv *envPtr); +void EqParseTernary(EqInput *in, CompileEnv *envPtr); + +// Record a parsing error +void EqParseSetError( + EqInput *in, + const char *expected) +{ + //printf("ERROR: argpos=%d charpos=%d lex=%d\n", in->argpos, in->charpos, in->lex); + + // Only record the first error. + if (in->errorFound) return; + in->errorFound = expected; + in->lex = 0; +} + +// Report a parsing error +Tcl_Obj *EqParseGetError( + EqInput *in) +{ + if (!in->errorFound) return NULL; + + if (in->lex == NUMBER) { + // A pre-existing number might not have been scanned + in->lastStart = TclGetStringFromObj(in->lit, &in->lastLen); + } + return Tcl_ObjPrintf("= Expected %s but found '%.*s'", + in->errorFound, (int)in->lastLen, in->lastStart); +} + +// Parse the expression until we find an operator with precedence lower than +// or equal to minPrec. Calls EqNextLex to get successive input lexemes from +// *in. Generates bytecode in *envPtr to evaluate the expression. +void EqParse( + EqInput *in, + CompileEnv *envPtr, + int minPrec) +{ + unsigned char inLex; + EqParsePrefix(in, envPtr); + while ((inLex = in->lex)) { + // PLUS or MINUS here has to be a binary operator + if (inLex==PLUS) {inLex = BINARY_PLUS;} + if (inLex==MINUS) {inLex = BINARY_MINUS;} + + const unsigned char inPrec = prec[inLex]; + if (inPrec==0) {EqParseSetError(in, "operator"); return;} + if (inPrec < minPrec) return; + + // Binary ops are left-associative except for ** + // so exceptionally we continue for repeated exponentiation. + if (inPrec == minPrec && inLex != EXPON) return; + + // && || ?: need special handling for lazy evaluation + switch (inLex) { + case AND: + EqNextLex(in); + EqParseAnd(in, envPtr); + break; + case OR: + EqNextLex(in); + EqParseOr(in, envPtr); + break; + case QUESTION: + EqNextLex(in); + EqParseTernary(in, envPtr); + break; + default: + if (instruction[inLex]) { + EqNextLex(in); + EqParse(in, envPtr, inPrec); + TclEmitOpcode(instruction[inLex], envPtr); + } else { + EqParseSetError(in, "operator"); + return; + } + + } + } +} + +// Parse expression up to the first operator at the same level of parentheses. +// Generates bytecode in *envPtr to evaluate the subexpression. +void EqParsePrefix( + EqInput *in, + CompileEnv *envPtr) +{ + unsigned char inLex = in->lex; + Tcl_Obj *inLit = in->lit; + Tcl_LVTIndex localIndex; + + switch (inLex) { + // Number? + case NUMBER: + PUSH_OBJ(inLit); + EqNextLex(in); + return; + + // Parenthesised subexpression? + case OPEN_PAREN: + EqNextLex(in); + EqParse(in, envPtr, PREC_OPEN_PAREN); + if (in->lex == CLOSE_PAREN) { + EqNextLex(in); + return; + } + EqParseSetError(in, "')'"); + return; + + // Unary operator? + case PLUS: + case MINUS: + inLex |= UNARY; + TCL_FALLTHROUGH(); + case NOT: + case BIT_NOT: + EqNextLex(in); + EqParse(in, envPtr, PREC_UNARY); + TclEmitOpcode(instruction[inLex], envPtr); + return; + + // Some kind of name? + case BAREWORD: + EqNextLex(in); + // Function call? + if (in->lex == OPEN_PAREN) { + Tcl_Obj *funcName = Tcl_NewStringObj("tcl::mathfunc::", -1); + Tcl_AppendObjToObj(funcName, inLit); + PUSH_OBJ(funcName); + EqNextLex(in); + EqParseFuncArgs(in, envPtr); + return; + } + // Local variable reference? + if (EnvHasLVT(envPtr)) { + Tcl_Size nameLen; + const char *name = TclGetStringFromObj(inLit, &nameLen); + localIndex = TclFindCompiledLocal(name, nameLen, 0, envPtr); + if (localIndex != TCL_INDEX_NONE) { + //printf("EqParsePrefix COMPILING LOCAL VARIABLE %ld\n", localIndex); + OP4(LOAD_SCALAR, localIndex); + return; + } + } + // Other variable reference. + PUSH_OBJ(inLit); + OP(LOAD_STK); + return; + + // Numeric value substituted at runtime? + case SCRIPT: + const Tcl_ObjInternalRep *irPtr; + irPtr = TclFetchInternalRep(inLit, &eqPresubType); + assert(irPtr != NULL); + localIndex = irPtr->wideValue; + //printf("EqParsePrefix COMPILING RUNTIME SUBSTITUTION %ld\n", localIndex); + OP4(LOAD_SCALAR, localIndex); + EqNextLex(in); + return; + } + EqParseSetError(in, "start of expression"); +} + +// Parse zero or more arguments to a math function. The arguments are +// expressions separated by commas and terminated by a closing parenthesis. +// Generates bytecode in *envPtr to evaluate the arguments and call the function. +void EqParseFuncArgs( + EqInput *in, + CompileEnv *envPtr) +{ + int numWords = 1; + if (in->lex != CLOSE_PAREN) { + while (in->lex) { + + EqParse(in, envPtr, PREC_COMMA); + numWords++; + + if (in->lex == CLOSE_PAREN) break; + if (in->lex != COMMA) { + EqParseSetError(in, "')' or ','"); + return; + } + EqNextLex(in); + } + } + INVOKE4(INVOKE_STK, numWords); + EqNextLex(in); +} + +// We just saw && so parse its second operand and generate code +// to evaluate it only if needed. +void EqParseAnd( + EqInput *in, + CompileEnv *envPtr) +{ + Tcl_Size depth = TclGetStackDepth(envPtr); + Tcl_BytecodeLabel false1, false2, end; + FWDJUMP(JUMP_FALSE, false1); + EqParse(in, envPtr, PREC_AND); + if (in->errorFound) return; + FWDJUMP(JUMP_FALSE, false2); + PUSH_STRING("1"); + FWDJUMP(JUMP, end); + FWDLABEL(false1); + FWDLABEL(false2); + PUSH_STRING("0"); + FWDLABEL(end); + TclCheckStackDepth(depth+1, envPtr); + TclSetStackDepth(depth, envPtr); +} + +// We just saw || so parse its second operand and generate code +// to evaluate it only if needed. +void EqParseOr( + EqInput *in, + CompileEnv *envPtr) +{ + Tcl_Size depth = TclGetStackDepth(envPtr); + Tcl_BytecodeLabel true1, true2, end; + FWDJUMP(JUMP_TRUE, true1); + EqParse(in, envPtr, PREC_OR); + if (in->errorFound) return; + FWDJUMP(JUMP_TRUE, true2); + PUSH_STRING("0"); + FWDJUMP(JUMP, end); + FWDLABEL(true1); + FWDLABEL(true2); + PUSH_STRING("1"); + FWDLABEL(end); + TclCheckStackDepth(depth+1, envPtr); + TclSetStackDepth(depth, envPtr); +} + +// We just saw ? so parse its second and third operands and generate code +// to evaluate only the appropriate one. +void EqParseTernary( + EqInput *in, + CompileEnv *envPtr) +{ + Tcl_Size depth = TclGetStackDepth(envPtr); + Tcl_BytecodeLabel false1, end; + FWDJUMP(JUMP_FALSE, false1); + EqParse(in, envPtr, PREC_CONDITIONAL); + if (in->lex != COLON) { + EqParseSetError(in, "':'"); + return; + } + FWDJUMP(JUMP, end); + FWDLABEL(false1); + EqNextLex(in); + EqParse(in, envPtr, PREC_CONDITIONAL); + if (in->errorFound) return; + FWDLABEL(end); + TclCheckStackDepth(depth+1, envPtr); + TclSetStackDepth(depth, envPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EqualsObjCmd -- + * Implements the command = + * + * Results: + * A standard Tcl return code and result left in interp. + * + * Side effects: + * May call user-defined mathfunc procs which could have side-effects. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EqualsObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + //printf("Tcl_EqualsObjCmd CALLED\n"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); + return TCL_ERROR; + } + EqInput input = {objc, objv, 1, 0, 0, 0, "", 0, 0}; + CompileEnv compEnv; /* Compilation environment structure */ + CompileEnv *envPtr = &compEnv; + TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0); + + EqNextLex(&input); + EqParse(&input,envPtr,0); + + Tcl_Obj *errMsg = EqParseGetError(&input); + if (errMsg) { + TclFreeCompileEnv(envPtr); + Tcl_SetObjResult(interp, errMsg); + return TCL_ERROR; + } + + OP(DONE); + ByteCode *byteCodePtr = TclInitByteCode(envPtr); + TclFreeCompileEnv(envPtr); + TclNRExecuteByteCode(interp, byteCodePtr); + NRE_callback *rootPtr = TOP_CB(interp); + int code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); + TclReleaseByteCode(byteCodePtr); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileEqualsCmd -- + * + * Procedure called to compile the "=" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "=" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileEqualsCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + TCL_UNUSED(Command *), + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; + Tcl_Obj *objPtr, *listObj, **objs; + Tcl_Size len, i, numWords = parsePtr->numWords; + Tcl_Token *tokenPtr; + Tcl_Size depth = TclGetStackDepth(envPtr); + //printf("TclCompileEqualsCmd CALLED, numWords=%ld\n", numWords); + + if (numWords == 1 || numWords > UINT_MAX) { + return TCL_ERROR; + } + + TclNewObj(listObj); + // Use this to allocate local variables for pre-substituted values: + Tcl_LVTIndex presubIndex = TCL_INDEX_NONE; + // Local variable to track if all pre-substitutions produce numbers: + Tcl_LVTIndex allNumericIndex = TCL_INDEX_NONE; + + // Scan the command and arguments, appending them to listObj + for (i = 0, tokenPtr = parsePtr->tokenPtr; + i < numWords; + i++, tokenPtr = TokenAfter(tokenPtr) + ) { + TclNewObj(objPtr); + if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + // Pre-substitution detected, make a local variable for it. + presubIndex = AnonymousLocal(envPtr); + Tcl_ObjInternalRep ir; + ir.wideValue = presubIndex; + Tcl_StoreInternalRep(objPtr, &eqPresubType, &ir); + + // Generate code to get the value and check that it's numeric. + PUSH_TOKEN(tokenPtr, i); + OP4(STORE_SCALAR, presubIndex); + OP(NUM_TYPE); + if (allNumericIndex == TCL_INDEX_NONE) { + allNumericIndex = AnonymousLocal(envPtr); + } else { + OP4(LOAD_SCALAR, allNumericIndex); + OP(BITAND); + } + OP4(STORE_SCALAR, allNumericIndex); + OP(POP); + + // Check that the local variables exist, if not abandon compilation. + if (presubIndex == TCL_INDEX_NONE || allNumericIndex == TCL_INDEX_NONE) { + //printf("Could not compile pre-substitution.\n"); + Tcl_BounceRefCount(objPtr); + Tcl_BounceRefCount(listObj); + return TCL_ERROR; + } + //printf("Compiled pre-substitution %ld.\n", presubIndex); + } + (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); + } + Tcl_BytecodeLabel noncompiled, end; + if (allNumericIndex != TCL_INDEX_NONE) { + // If we found any pre-substituted values which are non-numeric, + // skip to the non-compiled implementation. + OP4(LOAD_SCALAR, allNumericIndex); + FWDJUMP(JUMP_FALSE, noncompiled); + //printf("TclCompileEqualsCmd COMPILING PRE-SUBSTITUTION CHECK\n"); + } + + // Compile the expression, asssuming that any pre-substitutions + // will give numeric values. + TclListObjGetElements(NULL, listObj, &len, &objs); + //printf("TclCompileEqualsCmd SIMPLE COMPILATION, %ld args\n", len); + EqInput input = {len, objs, 1, 0, 0, 0, "", 0, 0}; + EqNextLex(&input); + EqParse(&input,envPtr,0); + if (input.errorFound) { + Tcl_BounceRefCount(listObj); + return TCL_ERROR; + } + TclCheckStackDepth(depth+1, envPtr); + // If there are no pre-substitutions we are done. + if (allNumericIndex == TCL_INDEX_NONE) { + Tcl_BounceRefCount(listObj); + return TCL_OK; + } + FWDJUMP(JUMP, end); + FWDLABEL(noncompiled); + TclSetStackDepth(depth, envPtr); + + // The expression has pre-substitutions. If any of these turn out + // to give non-numeric values at runtime, we will fall back to the + // uncompiled implementation, so we set up to call that here. + // We push the command name, followed by all the arguments. + // Note that pre-substituted arguments will have been computed + // before reaching this code, we should not compute them again + // in case that has side-effects. + for (i = 0; i < len; i++) { + objPtr = objs[i]; + if (TclHasInternalRep(objPtr, &eqPresubType)) { + // Load the pre-substituted value. + const Tcl_ObjInternalRep *irPtr; + irPtr = TclFetchInternalRep(objPtr, &eqPresubType); + assert(irPtr != NULL); + presubIndex = irPtr->wideValue; + OP4(LOAD_SCALAR, presubIndex); + } else { + PUSH_OBJ(objPtr); + } + } + INVOKE4(INVOKE_STK, numWords); + FWDLABEL(end); + + Tcl_BounceRefCount(listObj); + return TCL_OK; +} + /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -3785,10 +3785,11 @@ /* Assemble command function */ MODULE_SCOPE Tcl_ObjCmdProc Tcl_AssembleObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRAssembleObjCmd; MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc Tcl_EofObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_EqualsObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ErrorObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_EvalObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExecObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExitObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExprObjCmd; @@ -3896,10 +3897,11 @@ MODULE_SCOPE CompileProc TclCompileDictSetCmd; MODULE_SCOPE CompileProc TclCompileDictUnsetCmd; MODULE_SCOPE CompileProc TclCompileDictUpdateCmd; MODULE_SCOPE CompileProc TclCompileDictWithCmd; MODULE_SCOPE CompileProc TclCompileEnsemble; +MODULE_SCOPE CompileProc TclCompileEqualsCmd; MODULE_SCOPE CompileProc TclCompileErrorCmd; MODULE_SCOPE CompileProc TclCompileExprCmd; MODULE_SCOPE CompileProc TclCompileForCmd; MODULE_SCOPE CompileProc TclCompileForeachCmd; MODULE_SCOPE CompileProc TclCompileFormatCmd; ADDED tests/equals.test Index: tests/equals.test ================================================================== --- tests/equals.test +++ tests/equals.test @@ -0,0 +1,2699 @@ +# Commands covered: = (equals) +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-2000 Scriptics Corporation. +# Copyright © 2025 Colin G. Macleod. +# Copyright © 2025 Eric Taylor. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# The equals-* tests here are adapted from the corresponding tests for expr. +# The calc-* tests were contributed by Eric Taylor. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands + + +# Determine if "long int" type is a 32 bit number and if the wide +# type is a 64 bit number on this machine. + +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] + +proc testIEEE {} { + binary scan [binary format dd -1.0 1.0] c* c + switch -exact -- $c { + {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { + # little endian + return 1 + } + {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { + return 1 + } + default { + return 0 + } + } +} + +testConstraint ieeeFloatingPoint [testIEEE] + + +# start of tests + +catch {unset a b i x} + +test equals-1.1 {TclCompileExprCmd: no expression} -body { + = +} -returnCodes error -result {wrong # args: should be "= arg ?arg ...?"} +test equals-1.2 {TclCompileExprCmd: one expression word} { + = -25 +} -25 +test equals-1.3 {TclCompileExprCmd: two expression words} { + = -8.2 -6 +} -14.2 +test equals-1.4 {TclCompileExprCmd: five expression words} { + = 20 - 5 +10 -7 +} 18 +test equals-1.5 {TclCompileExprCmd: quoted expression word} { + = "0005" +0 +} 5 +test equals-1.6 {TclCompileExprCmd: quoted expression word} { + catch {= "0005"zxy} msg + set msg +} {extra characters after close-quote} +test equals-1.7 {TclCompileExprCmd: expression word in braces} { + = {-0005} +} -5 +test equals-1.8 {TclCompileExprCmd: expression word in braces} { + = {-0x1234} +} -4660 +test equals-1.9 {TclCompileExprCmd: expression word in braces} { + catch {= {-0005}foo} msg + set msg +} {extra characters after close-brace} +test equals-1.10 {TclCompileExprCmd: other expression word in brackets} { + = 4*[llength "6 2"] +} 8 +test equals-1.11 {TclCompileExprCmd: expression word terminated by ;} { + = 4*[llength "6 2"]; +} 8 +test equals-1.12 {TclCompileExprCmd: inlined = inside catch} { + set a xxx + catch { + # Might not be a number + set a [= 10*a] + } +} 1 +test equals-1.14 {TclCompileExprCmd: second level of substitutions in = with comparison as top-level operator} { + set a xxx + set x 2; set b {x}; set a [= $b==2] + set a +} 1 + +test equals-2.1 {are builtin functions registered?} { + = double(5*[llength "6 2"]) +} 10.0 +test equals-2.2 {error in expression} -body { + = 2***3 +} -returnCodes error -match glob -result * +test equals-2.3 {junk after legal expression} -body { + = 7*[llength "a b"]foo +} -returnCodes error -match glob -result * + +test equals-3.1 {CompileCond: just lor expr} {= 3||0} 1 +test equals-3.2 {CompileCond: error in lor expr} -body { + = *||3 +} -returnCodes error -match glob -result * +test equals-3.3 {CompileCond: test true arm} {= 3>2?44:66} 44 +test equals-3.4 {CompileCond: error compiling true arm} -body { + = 3>2?2***3:66 +} -returnCodes error -match glob -result * +test equals-3.5 {CompileCond: test false arm} {= 2>3?44:66} 66 +test equals-3.6 {CompileCond: error compiling false arm} -body { + = 2>3?44:2***3 +} -returnCodes error -match glob -result * + +test equals-4.1 {CompileLor: just land expr} {= 1.3&&3.3} 1 +test equals-4.2 {CompileLor: error in land expr} -body { + = $&&3 +} -returnCodes error -match glob -result * +test equals-4.3 {CompileLor: simple lor exprs} {= 0||1.0} 1 +test equals-4.4 {CompileLor: simple lor exprs} {= 3.0||0.0} 1 +test equals-4.5 {CompileLor: simple lor exprs} {= 0||0||1} 1 +test equals-4.6 {CompileLor: error compiling lor arm} -body { + = 2***3||4.0 +} -returnCodes error -match glob -result * +test equals-4.7 {CompileLor: error compiling lor arm} -body { + = 1.3||2***3 +} -returnCodes error -match glob -result * +test equals-4.8 {CompileLor: error compiling lor arms} { + set v1 a; set v2 b + list [catch {= v1||v2} msg] $msg +} {1 {expected boolean value but got "a"}} +test equals-4.9 {CompileLor: long lor arm} { + set a "abcdefghijkl" + set i 7 + = [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] +} 1 +test equals-4.10 {CompileNot: error compiling ! operand} { + set v1 a + list [catch {= !v1} msg] $msg +} {1 {cannot use non-numeric string "a" as operand of "!"}} +test equals-4.11 {CompileLor: error compiling land arms} { + set v1 a + list [catch {= v1||0} msg] $msg +} {1 {expected boolean value but got "a"}} +test equals-4.12 {CompileLor: error compiling land arms} { + set v1 a + list [catch {= 0||v1} msg] $msg +} {1 {expected boolean value but got "a"}} + +test equals-5.1 {CompileBitor: just bitor expr} {= 7|0x13} 23 +test equals-5.2 {CompileBitor: error in bitor expr} -body { + = $|3 +} -returnCodes error -match glob -result * +test equals-5.3 {CompileLand: simple land exprs} {= 0&&1.0} 0 +test equals-5.4 {CompileLand: simple land exprs} {= 0&&0} 0 +test equals-5.5 {CompileLand: simple land exprs} {= 3.0&&1.2} 1 +test equals-5.6 {CompileLand: simple land exprs} {= 1&&1&&2} 1 +test equals-5.7 {CompileLand: error compiling land arm} -body { + = 2***3&&4.0 +} -returnCodes error -match glob -result * +test equals-5.8 {CompileLand: error compiling land arm} -body { + = 1.3&&2***3 +} -returnCodes error -match glob -result * +test equals-5.9 {CompileLand: error compiling land arm} { + set v1 a; set v2 b + list [catch {= v1&&v2} msg] $msg +} {1 {expected boolean value but got "a"}} +test equals-5.10 {CompileLand: long land arms} { + set a "abcdefghijkl" + set i 7 + = [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] +} 1 + +test equals-6.1 {CompileBitXor: just bitand expr} {= 7&0x13} 3 +test equals-6.2 {CompileBitXor: error in bitand expr} -body { + = $|3 +} -returnCodes error -match glob -result * +test equals-6.3 {CompileBitXor: simple bitxor exprs} {= 7^0x13} 20 +test equals-6.4 {CompileBitXor: simple bitxor exprs} {= 3^0x10} 19 +test equals-6.5 {CompileBitXor: simple bitxor exprs} {= 0^7} 7 +test equals-6.6 {CompileBitXor: simple bitxor exprs} {= -1^7} -8 +test equals-6.7 {CompileBitXor: error compiling bitxor arm} -body { + = 2***3|6 +} -returnCodes error -match glob -result * +test equals-6.8 {CompileBitXor: error compiling bitxor arm} -body { + = 2^$ +} -returnCodes error -match glob -result * +test equals-6.9 {CompileBitXor: runtime error in bitxor arm} { + list [catch {= 24.0^3} msg] $msg +} {1 {cannot use floating-point value "24.0" as left operand of "^"}} +test equals-6.10 {CompileBitXor: runtime error in bitxor arm} { + set v1 a; set v2 b + list [catch {= v1^v2} msg] $msg +} {1 {cannot use non-numeric string "a" as left operand of "^"}} + +test equals-7.1 {CompileBitAnd: just equality expr} {= 3==2} 0 +test equals-7.2 {CompileBitAnd: just equality expr} {= 2.0==2} 1 +test equals-7.3 {CompileBitAnd: just equality expr} {= 3.2!=2.2} 1 +test equals-7.5 {CompileBitAnd: error in equality expr} -body { + = $==3 +} -returnCodes error -match glob -result * +test equals-7.6 {CompileBitAnd: simple bitand exprs} {= 7&0x13} 3 +test equals-7.7 {CompileBitAnd: simple bitand exprs} {= 0xf2&0x53} 82 +test equals-7.8 {CompileBitAnd: simple bitand exprs} {= 3&6} 2 +test equals-7.9 {CompileBitAnd: simple bitand exprs} {= -1&-7} -7 +test equals-7.10 {CompileBitAnd: error compiling bitand arm} -body { + = 2***3&6 +} -returnCodes error -match glob -result * +test equals-7.11 {CompileBitAnd: error compiling bitand arm} -body { + = 2&$ +} -returnCodes error -match glob -result * +test equals-7.12 {CompileBitAnd: runtime error in bitand arm} { + list [catch {= 24.0&3} msg] $msg +} {1 {cannot use floating-point value "24.0" as left operand of "&"}} +test equals-7.13 {CompileBitAnd: runtime error in bitand arm} { + set v1 a; set v2 b + list [catch {= v1&v2} msg] $msg +} {1 {cannot use non-numeric string "a" as left operand of "&"}} +test equals-7.20 {CompileBitAnd: error in equality expr} -body { + = 2ne3 +} -returnCodes error -match glob -result * + +test equals-8.1 {CompileEquality: just relational expr} {= 3>=2} 1 +test equals-8.2 {CompileEquality: just relational expr} {= 2<=2.1} 1 +test equals-8.3 {CompileEquality: just relational expr} {= 3.2> "2.2"} 1 +test equals-8.5 {CompileEquality: error in relational expr} -body { + = $>3 +} -returnCodes error -match glob -result * +test equals-8.6 {CompileEquality: simple equality exprs} {= 7==0x13} 0 +test equals-8.7 {CompileEquality: simple equality exprs} {= -0xf2!=0x53} 1 +test equals-8.10 {CompileEquality: error compiling equality arm} -body { + = 2***3==6 +} -returnCodes error -match glob -result * +test equals-8.11 {CompileEquality: error compiling equality arm} -body { + = 2!=$ +} -returnCodes error -match glob -result * +test equals-8.24 {CompileEqualityExpr: simple equality exprs} { + set x 12398712938788234 + = {x == 100} +} 0 +test equals-8.25 {CompileEqualityExpr: simple equality exprs} { + = "0x12 " == "0x12" +} 1 +test equals-8.27 {CompileEqualityExpr: simple equality exprs} { + = "1.0e100000000" == "0.0" +} 0 +test expr-8.31 {expr edge cases} -body { + = {1e} +} -returnCodes error -match glob -result * +test expr-8.32 {expr edge cases} -body { + = {1E} +} -returnCodes error -match glob -result * +test expr-8.33 {expr edge cases} -body { + = {1e+} +} -returnCodes error -match glob -result * +test expr-8.34 {expr edge cases} -body { + = {1E+} +} -returnCodes error -match glob -result * +test expr-8.35 {expr edge cases} -body { + = {1ea} +} -returnCodes error -match glob -result * + +test equals-9.1 {CompileRelational: just shift expr} {= 3<<2} 12 +test equals-9.2 {CompileRelational: just shift expr} {= 0xff>>2} 63 +test equals-9.3 {CompileRelational: just shift expr} {= -1>>2} -1 +test equals-9.4 {CompileRelational: just shift expr} {= {1<<3}} 8 +test equals-9.5 {CompileRelational: shift expr producing LONG_MIN} { + = {int(1<<63)} +} 9223372036854775808 +test equals-9.6 {CompileRelational: error in shift expr} -body { + = $>>3 +} -returnCodes error -match glob -result * +test equals-9.7 {CompileRelational: simple relational exprs} {= 0xff>=+0x3} 1 +test equals-9.8 {CompileRelational: simple relational exprs} {= -0xf2<0x3} 1 +test equals-9.9 {CompileRelational: error compiling relational arm} -body { + = 2***3>6 +} -returnCodes error -match glob -result * +test equals-9.10 {CompileRelational: error compiling relational arm} -body { + = 2<$ +} -returnCodes error -match glob -result * + +test equals-10.1 {CompileShift: just add expr} {= 4+-2} 2 +test equals-10.2 {CompileShift: just add expr} {= 0xff-2} 253 +test equals-10.3 {CompileShift: just add expr} {= -1--2} 1 +test equals-10.4 {CompileShift: just add expr} {= 1-0o123} -82 +test equals-10.5 {CompileShift: error in add expr} -body { + = $+3 +} -returnCodes error -match glob -result * +test equals-10.6 {CompileShift: simple shift exprs} {= 0xff>>0x3} 31 +test equals-10.7 {CompileShift: simple shift exprs} {= -0xf2<<0x3} -1936 +test equals-10.8 {CompileShift: error compiling shift arm} -body { + = 2***3>>6 +} -returnCodes error -match glob -result * +test equals-10.9 {CompileShift: error compiling shift arm} -body { + = 2<<$ +} -returnCodes error -match glob -result * +test equals-10.10 {CompileShift: runtime error} { + list [catch {= {24.0>>43}} msg] $msg +} {1 {cannot use floating-point value "24.0" as left operand of ">>"}} +test equals-10.11 {CompileShift: runtime error} { + set v1 a; set v2 b + list [catch {= {v1<= 1} { + set is [= {-2 ** tval}] + set sb [= {1 << tval}] + if {$tval & 1} { + set sb [= {-sb}] + } + if {$is != $sb} { + append trouble \n "-2**" $tval " is " $is " should be " $sb + } + } + } + set trouble +} {test powers of 2} +test equals-23.50 {INST_EXPON: small powers of 32-bit integers} { + set trouble {test small powers of 32-bit ints} + for {set base 3} {$base <= 45} {incr base} { + set sb $base + set sbm [= {-base}] + for {set expt 2} {$expt <= 8} {incr expt} { + set sb [= {sb * base}] + set is [= {base ** expt}] + if {$sb != $is} { + append trouble \n $base ** $expt " is " $is " should be " $sb + } + set sbm [= {-sbm * base}] + set ism [= {(-base) ** expt}] + if {$sbm != $ism} { + append trouble \n - $base ** $expt " is " $ism \ + " should be " $sbm + } + } + } + set trouble +} {test small powers of 32-bit ints} +test equals-23.51 {INST_EXPON: intermediate powers of 32-bit integers} { + set trouble {test intermediate powers of 32-bit ints} + for {set base 3} {$base <= 11} {incr base} { + set sb [= {base ** 8}] + set sbm $sb + for {set expt 9} {$expt <= 21} {incr expt} { + set sb [= {sb * base}] + set sbm [= {sbm * -base}] + set is [= {base ** expt}] + set ism [= {-base ** expt}] + if {$sb != $is} { + append trouble \n $base ** $expt " is " $is " should be " $sb + } + if {$sbm != $ism} { + append trouble \n - $base ** $expt " is " $ism \ + " should be " $sbm + } + } + } + set trouble +} {test intermediate powers of 32-bit ints} +test equals-23.52 {INST_EXPON: small integer powers with 64-bit results} { + set trouble {test small int powers with 64-bit results} + for {set exp 2} {$exp <= 16} {incr exp} { + set base [= {entier(pow(double(0x7fffffffffffffff),(1.0/exp)))}] + set sb 1 + set sbm 1 + for {set i 0} {$i < $exp} {incr i} { + set sb [= {sb * base}] + set sbm [= {sbm * -base}] + } + set is [= {base ** exp}] + set ism [= {-base ** exp}] + if {$sb != $is} { + append trouble \n $base ** $exp " is " $is " should be " $sb + } + if {$sbm != $ism} { + append trouble \n - $base ** $exp " is " $ism " should be " $sbm + } + incr base + set sb 1 + set sbm 1 + for {set i 0} {$i < $exp} {incr i} { + set sb [= {sb * base}] + set sbm [= {sbm * -base}] + } + set is [= {base ** exp}] + set ism [= {-base ** exp}] + if {$sb != $is} { + append trouble \n $base ** $exp " is " $is " should be " $sb + } + if {$sbm != $ism} { + append trouble \n - $base ** $exp " is " $ism " should be " $sbm + } + } + set trouble +} {test small int powers with 64-bit results} +test equals-23.53 {INST_EXPON: intermediate powers of 64-bit integers} { + set trouble {test intermediate powers of 64-bit ints} + for {set base 3} {$base <= 13} {incr base} { + set sb [= {base ** 15}] + set sbm [= {-sb}] + for {set expt 16} {$expt <= 39} {incr expt} { + set sb [= {sb * base}] + set sbm [= {sbm * -base}] + set is [= {base ** expt}] + set ism [= {-base ** expt}] + if {$sb != $is} { + append trouble \n $base ** $expt " is " $is " should be " $sb + } + if {$sbm != $ism} { + append trouble \n - $base ** $expt " is " $ism \ + " should be " $sbm + } + } + } + set trouble +} {test intermediate powers of 64-bit ints} +test equals-23.54.12 {INST_EXPON: Bug 2798543} -body { + = {3**268435456} +} -returnCodes error -result {exponent too large} + +# Some compilers get this wrong; ensure that we work around it correctly +test equals-24.1 {expr edge cases; shifting} {= int(5)>>32} 0 +test equals-24.2 {expr edge cases; shifting} {= int(5)>>63} 0 +test equals-24.3 {expr edge cases; shifting} {= wide(5)>>32} 0 +test equals-24.4 {expr edge cases; shifting} {= wide(5)>>63} 0 +test equals-24.5 {expr edge cases; shifting} {= int(5<<32)} 21474836480 +test equals-24.6 {expr edge cases; shifting} {= int(5<<63)} 46116860184273879040 +test equals-24.7 {expr edge cases; shifting} {= wide(5)<<32} 21474836480 +test equals-24.8 {expr edge cases; shifting} {= wide(10<<63)} 0 +test equals-24.9 {expr edge cases; shifting} {= 5>>32} 0 + +test equals-24.10 {INST_LSHIFT: Bug 1567222} {= 500000000000000<<28} 134217728000000000000000 +test equals-24.11 {INST_LSHIFT: Bug 84a5355235} {= -549755813888>>32} -128 +test equals-24.12 {INST_LSHIFT: Bug 920e393634} {= 7244019458077122840<<1} 14488038916154245680 + +test equals-31.6 {boolean conversion} {= bool(-1 + 1)} 0 +test equals-31.7 {boolean conversion} {= bool(0 + 1)} 1 +test equals-31.8 {boolean conversion} {= bool(0.0)} 0 +test equals-31.9 {boolean conversion} {= bool(0x0)} 0 +test equals-31.10 {boolean conversion} {= bool(wide(0))} 0 +test equals-31.11 {boolean conversion} {= bool(5.0)} 1 +test equals-31.12 {boolean conversion} {= bool(5)} 1 +test equals-31.13 {boolean conversion} {= bool(0x5)} 1 +test equals-31.14 {boolean conversion} {= bool(wide(5))} 1 +test equals-31.15 {boolean conversion} -body { + set v1 fred + = bool(v1) +} -returnCodes error -match glob -result * + +test equals-32.1 {expr mod basics} { + set mod_nums [list \ + {-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \ + {-3 -1} {-3 -2} {-3 -3} {-3 -4} {-3 -5} \ + {-2 1} {-2 2} {-2 3} {-2 4} {-2 5} \ + {-2 -1} {-2 -2} {-2 -3} {-2 -4} {-2 -5} \ + {-1 1} {-1 2} {-1 3} {-1 4} {-1 5} \ + {-1 -1} {-1 -2} {-1 -3} {-1 -4} {-1 -5} \ + {0 -100} {0 -1} {0 1} {0 100} \ + {1 1} {1 2} {1 3} {1 4} {1 5} \ + {1 -1} {1 -2} {1 -3} {1 -4} {1 -5} \ + {2 1} {2 2} {2 3} {2 4} {2 5} \ + {2 -1} {2 -2} {2 -3} {2 -4} {2 -5} \ + {3 1} {3 2} {3 3} {3 4} {3 5} \ + {3 -1} {3 -2} {3 -3} {3 -4} {3 -5} \ + ] + set results [list] + foreach pair $mod_nums { + set dividend [lindex $pair 0] + set divisor [lindex $pair 1] + lappend results [= {dividend % divisor}] + } + set results +} [list \ + 0 1 0 1 2 \ + 0 -1 0 -3 -3 \ + 0 0 1 2 3 \ + 0 0 -2 -2 -2 \ + 0 1 2 3 4 \ + 0 -1 -1 -1 -1 \ + 0 0 0 0 \ + 0 1 1 1 1 \ + 0 -1 -2 -3 -4 \ + 0 0 2 2 2 \ + 0 0 -1 -2 -3 \ + 0 1 0 3 3 \ + 0 -1 0 -1 -2 \ + ] + +test equals-32.2 {expr div basics} { + set mod_nums [list \ + {-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \ + {-3 -1} {-3 -2} {-3 -3} {-3 -4} {-3 -5} \ + {-2 1} {-2 2} {-2 3} {-2 4} {-2 5} \ + {-2 -1} {-2 -2} {-2 -3} {-2 -4} {-2 -5} \ + {-1 1} {-1 2} {-1 3} {-1 4} {-1 5} \ + {-1 -1} {-1 -2} {-1 -3} {-1 -4} {-1 -5} \ + {0 -100} {0 -1} {0 1} {0 100} \ + {1 1} {1 2} {1 3} {1 4} {1 5} \ + {1 -1} {1 -2} {1 -3} {1 -4} {1 -5} \ + {2 1} {2 2} {2 3} {2 4} {2 5} \ + {2 -1} {2 -2} {2 -3} {2 -4} {2 -5} \ + {3 1} {3 2} {3 3} {3 4} {3 5} \ + {3 -1} {3 -2} {3 -3} {3 -4} {3 -5} \ + ] + set results [list] + foreach pair $mod_nums { + set dividend [lindex $pair 0] + set divisor [lindex $pair 1] + lappend results [= {dividend / divisor}] + } + set results +} [list \ + -3 -2 -1 -1 -1 \ + 3 1 1 0 0 \ + -2 -1 -1 -1 -1 \ + 2 1 0 0 0 \ + -1 -1 -1 -1 -1 \ + 1 0 0 0 0 \ + 0 0 0 0 \ + 1 0 0 0 0 \ + -1 -1 -1 -1 -1 \ + 2 1 0 0 0 \ + -2 -1 -1 -1 -1 \ + 3 1 1 0 0 \ + -3 -2 -1 -1 -1 \ + ] + +test equals-33.1 {parse largest long value} { + set max_long_str 2147483647 + set max_long_hex "0x7FFFFFFF " + + # Convert to integer (long, not wide) internal rep + set max_long 2147483647 + string is integer $max_long + + list \ + [= { max_long_str }] \ + [= {max_long_str + 0}] \ + [= {max_long + 0}] \ + [= {2147483647 + 0}] \ + [= {max_long == max_long_hex}] \ + [= {int(2147483647 + 1) > 0}] \ + +} {2147483647 2147483647 2147483647 2147483647 1 1} +test equals-33.2 {parse smallest long value} { + set min_long_str -2147483648 + set min_long_hex "-0x80000000 " + + set min_long -2147483648 + # This will convert to integer (not wide) internal rep + string is integer $min_long + + # Note: If the final expression returns 0 then the + # expression literal is being promoted to a wide type + # when it should be parsed as a long type. + list \ + [= { min_long_str }] \ + [= {min_long_str + 0}] \ + [= {min_long + 0}] \ + [= {-2147483648 + 0}] \ + [= {min_long == min_long_hex}] \ + [= {int(-2147483648 - 1) == -0x80000001}] \ + +} {-2147483648 -2147483648 -2147483648 -2147483648 1 1} +test equals-33.3 {parse largest wide value} wideIs64bit { + set max_wide_str 9223372036854775807 + set max_wide_hex "0x7FFFFFFFFFFFFFFF " + + # Convert to wide integer + set max_wide 9223372036854775807 + string is integer $max_wide + + list \ + [= { max_wide_str }] \ + [= {max_wide_str + 0}] \ + [= {max_wide + 0}] \ + [= {9223372036854775807 + 0}] \ + [= {max_wide == max_wide_hex}] \ + [= {wide(9223372036854775807 + 1) < 0}] \ + +} {9223372036854775807 9223372036854775807 9223372036854775807 9223372036854775807 1 1} +test equals-33.4 {parse smallest wide value} wideIs64bit { + set min_wide_str -9223372036854775808 + set min_wide_hex "-0x8000000000000000 " + + set min_wide -9223372036854775808 + # Convert to wide integer + string is integer $min_wide + + # Note: If the final expression returns 0 then the + # wide integer is not being parsed correctly with + # the leading - sign. + list \ + [= { min_wide_str }] \ + [= {min_wide_str + 0}] \ + [= {min_wide + 0}] \ + [= {-9223372036854775808 + 0}] \ + [= {min_wide == min_wide_hex}] \ + [= {wide(-9223372036854775808 - 1) == 0x7FFFFFFFFFFFFFFF}] \ + +} {-9223372036854775808 -9223372036854775808 -9223372036854775808 -9223372036854775808 1 1} + +test equals-40.1 {large octal shift} { + = 0o100000000000000000000000000000000 == 0x1000000000000000000000000 +} 1 +test equals-40.2 {large octal shift} { + = 0o100000000000000000000000000000001 == 0x1000000000000000000000001 +} 1 + +test equals-43.6 {0b notation} { + = 0b101 + 0 +} 5 +test equals-43.13 {0b notation} { + = 0b1[string repeat 0 63]1 + 0 +} 18446744073709551617 + +test equals-44.7 {0o notation} { + = 0o101 + 0 +} 65 +test equals-44.12 {0o notation} { + = 0o2[string repeat 0 20]1 + 0 +} 18446744073709551617 + +test equals-45.2 {entier} { + = entier(0.5) +} 0 +test equals-45.4 {entier} { + = entier(1.5) +} 1 +test equals-45.6 {entier} { + = entier(1e+22) +} 10000000000000000000000 + +test equals-46.2 {round() rounds to +-infinity} { + = round(1.5) +} 2 +test equals-46.3 {round() rounds to +-infinity} { + = round(-0.5) +} -1 + +test equals-47.1 {isqrt() - arg count} { + list [catch {= {isqrt(1,2)}} result] $result +} {1 {too many arguments for math function "isqrt"}} + +test equals-47.2 {isqrt() - non-number} { + set v1 rubbish + list [catch {= {isqrt(v1)}} result] $result +} {1 {expected number but got "rubbish"}} + +test equals-47.3 {isqrt() - NaN} ieeeFloatingPoint { + set v1 NaN + list [catch {= {isqrt(v1)}} result] $result +} {1 {floating point value is Not a Number}} + +test equals-47.4 {isqrt() of negative floating point number} { + list [catch {= {isqrt(-1.0)}} result] $result +} {1 {square root of negative argument}} + +test equals-47.5 {isqrt() of floating point zero} { + = isqrt(0.0) +} 0 + +test equals-47.8 {isqrt of inexact floating point number} ieeeFloatingPoint { + = isqrt(2[string repeat 0 34]) +} 141421356237309504 + +test equals-47.9 {isqrt of negative int} { + list [catch {= isqrt(-1)} result] $result +} {1 {square root of negative argument}} + +test equals-47.10 {isqrt of negative bignum} { + list [catch {= isqrt(-1[string repeat 0 1000])} result] $result +} {1 {square root of negative argument}} + +test equals-47.11 {isqrt of zero} { + = {isqrt(0)} +} 0 + +test equals-47.14 {isqrt() - lseq} { + set v1 [lseq 1 3] + list [catch {= {isqrt(v1)}} result] $result +} {1 {expected number but got a list}} +test equals-47.15 {isqrt() - lseq} { + set v1 {1 2 "} + list [catch {= {isqrt(v1)}} result] $result +} {1 {expected number but got "1 2 ""}} +test equals-47.16 {isqrt() - lseq} { + set v1 [dict create foo bar] + list [catch {= {isqrt(v1)}} result] $result +} {1 {expected number but got a list}} + +test equals-50.1 {test sqrt() of bignums with non-Inf answer} { + = sqrt(1[string repeat 0 616]) == 1e308 +} 1 + +test equals-51.1 {test round-to-even on input} { + = 6.9294956446009195e15 + 0 +} 6929495644600920.0 + +unset -nocomplain a min max v1 v2 results + +# calc.test - Complete expression evaluator test suite +# Tests compatibility with expr behavior + +# ---------- Basic Arithmetic ---------- + +test calc-1.1 {addition: 1 + 2} -body { + = 1 + 2 +} -result [expr {1 + 2}] + +test calc-1.2 {subtraction: 10 - 3} -body { + = 10 - 3 +} -result [expr {10 - 3}] + +test calc-1.3 {multiplication: 5 * 6} -body { + = 5 * 6 +} -result [expr {5 * 6}] + +test calc-1.4 {division: 20 / 4} -body { + = 20 / 4 +} -result [expr {20 / 4}] + +test calc-1.5 {modulo: 17 % 5} -body { + = 17 % 5 +} -result [expr {17 % 5}] + +test calc-1.6 {exponentiation: 2 ** 10} -body { + = 2 ** 10 +} -result [expr {2 ** 10}] + +# ---------- Operator Precedence ---------- + +test calc-2.1 {precedence: 2 + 3 * 4} -body { + = 2 + 3 * 4 +} -result [expr {2 + 3 * 4}] + +test calc-2.2 {precedence with parens: (2 + 3) * 4} -body { + = (2 + 3) * 4 +} -result [expr {(2 + 3) * 4}] + +test calc-2.3 {right associativity: 2 ** 3 ** 2} -body { + = 2 ** 3 ** 2 +} -result [expr {2 ** 3 ** 2}] + +# ---------- Variables ---------- + +test calc-3.1 {variables: x + y} -setup { + set x 10 + set y 20 +} -body { + expr {[= x + y] == [expr {$x + $y}]} +} -result 1 -cleanup { + unset x y +} + +test calc-3.2 {variables: x * y + z} -setup { + set x 10 + set y 20 + set z 5 +} -body { + expr {[= x * y + z] == [expr {$x * $y + $z}]} +} -result 1 -cleanup { + unset x y z +} + +test calc-3.3 {variables with parens: (x + y) * z} -setup { + set x 10 + set y 20 + set z 5 +} -body { + expr {[= (x + y) * z] == [expr {($x + $y) * $z}]} +} -result 1 -cleanup { + unset x y z +} + +# ---------- Bitwise Operations ---------- + +test calc-4.1 {bitwise AND: 15 & 7} -body { + = 15 & 7 +} -result [expr {15 & 7}] + +test calc-4.2 {bitwise OR: 8 | 4} -body { + = 8 | 4 +} -result [expr {8 | 4}] + +test calc-4.3 {bitwise XOR: 12 ^ 5} -body { + = 12 ^ 5 +} -result [expr {12 ^ 5}] + +test calc-4.4 {left shift: 1 << 8} -body { + = 1 << 8 +} -result [expr {1 << 8}] + +test calc-4.5 {right shift: 256 >> 4} -body { + = 256 >> 4 +} -result [expr {256 >> 4}] + +# ---------- Boolean Operations ---------- + +test calc-5.1 {logical AND: 1 && 1} -body { + = 1 && 1 +} -result [expr {1 && 1}] + +test calc-5.2 {logical AND: 1 && 0} -body { + = 1 && 0 +} -result [expr {1 && 0}] + +test calc-5.3 {logical OR: 0 || 1} -body { + = 0 || 1 +} -result [expr {0 || 1}] + +test calc-5.4 {logical NOT: !1} -body { + = !1 +} -result [expr {!1}] + +# ---------- Comparison ---------- + +test calc-6.1 {less than: a < b} -setup { + set a 10 + set b 20 +} -body { + expr {[= a < b] == [expr {$a < $b}]} +} -result 1 -cleanup { + unset a b +} + +test calc-6.2 {greater than: a > b} -setup { + set a 10 + set b 20 +} -body { + expr {[= a > b] == [expr {$a > $b}]} +} -result 1 -cleanup { + unset a b +} + +test calc-6.3 {equality: a == 10} -setup { + set a 10 +} -body { + expr {[= a == 10] == [expr {$a == 10}]} +} -result 1 -cleanup { + unset a +} + +test calc-6.4 {inequality: a != b} -setup { + set a 10 + set b 20 +} -body { + expr {[= a != b] == [expr {$a != $b}]} +} -result 1 -cleanup { + unset a b +} + +# ---------- Math Functions ---------- + +test calc-7.1 {sqrt of literal} -body { + = sqrt(25) +} -result [expr {sqrt(25)}] + +test calc-7.2 {sqrt with expression} -setup { + set x 10 +} -body { + expr {[= sqrt(x*x)] == [expr {sqrt($x*$x)}]} +} -result 1 -cleanup { + unset x +} + +test calc-7.3 {sin function} -setup { + set angle 0.5 +} -body { + expr {[= sin(angle)] == [expr {sin($angle)}]} +} -result 1 -cleanup { + unset angle +} + +test calc-7.4 {abs function} -body { + = abs(-42) +} -result [expr {abs(-42)}] + +# ---------- Arrays ---------- + +test calc-8.1 {array access: data(idx)} -setup { + array set data {ten 10 twenty 20} + set idx ten +} -body { + expr {[= $data($idx)] eq [expr {$data($idx)}]} +} -result 1 -cleanup { + unset data idx +} + +test calc-8.2 {array access after index change} -setup { + array set data {ten 10 twenty 20 thirty 30} + set idx twenty +} -body { + expr {[= $data($idx)] eq [expr {$data($idx)}]} +} -result 1 -cleanup { + unset data idx +} + +test calc-8.3 {array arithmetic} -setup { + array set nums {5 100 10 200 15 300} + set i 5 + set j 10 +} -body { + expr {[= $nums($i) + $nums($j)] == [expr {$nums($i) + $nums($j)}]} +} -result 1 -cleanup { + unset nums i j +} + +# ---------- Complex Array Indices ---------- + +test calc-9.1 {array with computed index: matrix(n*2)} -setup { + array set matrix {0 10 1 20 2 30 3 40} + set n 1 +} -body { + expr {[= $matrix([= n*2])] == [expr {$matrix([expr {$n*2}])}]} +} -result 1 -cleanup { + unset matrix n +} + +test calc-9.2 {array with computed index: matrix(n+1)} -setup { + array set matrix {0 10 1 20 2 30 3 40} + set n 1 +} -body { + expr {[= $matrix([= n+1])] == [expr {$matrix([expr {$n+1}])}]} +} -result 1 -cleanup { + unset matrix n +} + +# ---------- Ternary Operator ---------- + +test calc-10.1 {ternary: val > 10 ? 100 : 200} -setup { + set val 15 +} -body { + expr {[= val > 10 ? 100 : 200] == [expr {$val > 10 ? 100 : 200}]} +} -result 1 -cleanup { + unset val +} + +test calc-10.2 {ternary with different value} -setup { + set val 5 +} -body { + expr {[= val > 10 ? 100 : 200] == [expr {$val > 10 ? 100 : 200}]} +} -result 1 -cleanup { + unset val +} + +# ---------- Mixed Expressions ---------- + +test calc-11.1 {complex expression: (price * quantity) - discount} -setup { + set price 100 + set quantity 5 + set discount 10 +} -body { + expr {[= (price * quantity) - discount] == [expr {($price * $quantity) - $discount}]} +} -result 1 -cleanup { + unset price quantity discount +} + +test calc-11.2 {complex expression: price * (quantity - 1)} -setup { + set price 100 + set quantity 5 +} -body { + expr {[= price * (quantity - 1)] == [expr {$price * ($quantity - 1)}]} +} -result 1 -cleanup { + unset price quantity +} + +# ---------- Unary Operators ---------- + +test calc-12.1 {unary plus} -setup { + set num 42 +} -body { + expr {[= +num] == [expr {+$num}]} +} -result 1 -cleanup { + unset num +} + +test calc-12.2 {unary minus} -setup { + set num 42 +} -body { + expr {[= -num] == [expr {-$num}]} +} -result 1 -cleanup { + unset num +} + +test calc-12.3 {bitwise NOT} -setup { + set num 42 +} -body { + expr {[= ~num] == [expr {~$num}]} +} -result 1 -cleanup { + unset num +} + +# ---------- Boolean with Variables ---------- + +test calc-13.1 {logical AND with variables} -setup { + set flag 1 +} -body { + expr {[= flag && 1] == [expr {$flag && 1}]} +} -result 1 -cleanup { + unset flag +} + +test calc-13.2 {logical AND with false flag} -setup { + set flag 0 +} -body { + expr {[= flag && 1] == [expr {$flag && 1}]} +} -result 1 -cleanup { + unset flag +} + +# ---------- Nested Functions ---------- + +test calc-14.1 {nested: sqrt(abs(-16))} -body { + = sqrt(abs(-16)) +} -result [expr {sqrt(abs(-16))}] + +test calc-14.2 {nested: abs(sin(0))} -body { + = abs(sin(0)) +} -result [expr {abs(sin(0))}] + +# ---------- Bignum Arithmetic ---------- + +test calc-15.1 {bignum addition} -body { + = 999999999999999999999 + 1 +} -result [expr {999999999999999999999 + 1}] + +test calc-15.2 {bignum exponentiation: 2 ** 100} -body { + = 2 ** 100 +} -result [expr {2 ** 100}] + +test calc-15.3 {bignum: 10 ** 50} -body { + = 10 ** 50 +} -result [expr {10 ** 50}] + +# ---------- Bignum Operations ---------- + +test calc-16.1 {bignum addition with variables} -setup { + set big1 [expr {2 ** 100}] + set big2 [expr {3 ** 100}] +} -body { + expr {[= big1 + big2] == [expr {$big1 + $big2}]} +} -result 1 -cleanup { + unset big1 big2 +} + +test calc-16.2 {bignum multiplication} -setup { + set big1 [expr {2 ** 100}] + set big2 [expr {3 ** 100}] +} -body { + expr {[= big1 * big2] == [expr {$big1 * $big2}]} +} -result 1 -cleanup { + unset big1 big2 +} + +test calc-16.3 {bignum subtraction} -setup { + set big1 [expr {2 ** 100}] + set big2 [expr {3 ** 100}] +} -body { + expr {[= big2 - big1] == [expr {$big2 - $big1}]} +} -result 1 -cleanup { + unset big1 big2 +} + +# ---------- Factorial-like ---------- + +test calc-17.1 {factorial computation} -setup { + set n 1 + set m 1 + for {set i 1} {$i <= 50} {incr i} { + set n [expr {$n * $i}] + set m [= m * i] + } +} -body { + expr {[= m + 1] == [expr {$n + 1}]} +} -result 1 -cleanup { + unset n m i +} + +# ---------- Mixed Bignum and Regular ---------- + +test calc-18.1 {bignum mixed with small} -setup { + set small 42 + set huge [expr {10 ** 100}] +} -body { + expr {[= huge + small] == [expr {$huge + $small}]} +} -result 1 -cleanup { + unset small huge +} + +test calc-18.2 {bignum cancellation} -setup { + set small 42 + set huge [expr {10 ** 100}] +} -body { + expr {[= huge - huge + small] == [expr {$huge - $huge + $small}]} +} -result 1 -cleanup { + unset small huge +} + +# ---------- Bignum in Arrays ---------- + +test calc-19.1 {bignum array values} -setup { + array set bigdata {} + set bigdata(1) [expr {2 ** 200}] + set bigdata(2) [expr {3 ** 200}] + set idx1 1 + set idx2 2 +} -body { + expr {[= $bigdata($idx1) + $bigdata($idx2)] == [expr {$bigdata($idx1) + $bigdata($idx2)}]} +} -result 1 -cleanup { + unset bigdata idx1 idx2 +} + +# ---------- Bignum Comparisons ---------- + +test calc-20.1 {bignum less than} -setup { + set a [expr {10 ** 100}] + set b [expr {10 ** 100 + 1}] +} -body { + expr {[= a < b] == [expr {$a < $b}]} +} -result 1 -cleanup { + unset a b +} + +test calc-20.2 {bignum equality} -setup { + set a [expr {10 ** 100}] +} -body { + expr {[= a == a] == [expr {$a == $a}]} +} -result 1 -cleanup { + unset a +} + +test calc-20.3 {bignum greater than} -setup { + set a [expr {10 ** 100}] + set b [expr {10 ** 100 + 1}] +} -body { + expr {[= b > a] == [expr {$b > $a}]} +} -result 1 -cleanup { + unset a b +} + +# ---------- Bignum with Math Functions ---------- + +test calc-21.1 {abs of negative bignum} -setup { + set bigneg [expr {-(2 ** 100)}] +} -body { + expr {[= abs(bigneg)] == [expr {abs($bigneg)}]} +} -result 1 -cleanup { + unset bigneg +} + +# ---------- Bignum Ternary ---------- + +test calc-22.1 {ternary with bignums} -setup { + set x [expr {10 ** 100}] + set y [expr {10 ** 50}] +} -body { + expr {[= x > y ? x : y] == [expr {$x > $y ? $x : $y}]} +} -result 1 -cleanup { + unset x y +} + +# ---------- Bignum Bitwise ---------- + +test calc-23.1 {bignum bitwise OR} -setup { + set b1 [expr {2 ** 65}] + set b2 [expr {2 ** 66}] +} -body { + expr {[= b1 | b2] == [expr {$b1 | $b2}]} +} -result 1 -cleanup { + unset b1 b2 +} + +test calc-23.2 {bignum bitwise AND} -setup { + set b1 [expr {2 ** 65}] + set b2 [expr {2 ** 66}] +} -body { + expr {[= b1 & b2] == [expr {$b1 & $b2}]} +} -result 1 -cleanup { + unset b1 b2 +} + +# ---------- Single Argument Math Functions ---------- + +test calc-24.1 {sqrt(144)} -body { + = sqrt(144) +} -result [expr {sqrt(144)}] + +test calc-24.2 {abs(-99)} -body { + = abs(-99) +} -result [expr {abs(-99)}] + +test calc-24.3 {floor(3.7)} -body { + = floor(3.7) +} -result [expr {floor(3.7)}] + +test calc-24.4 {ceil(3.2)} -body { + = ceil(3.2) +} -result [expr {ceil(3.2)}] + +test calc-24.5 {round(3.5)} -body { + = round(3.5) +} -result [expr {round(3.5)}] + +test calc-24.6 {int(7.9)} -body { + = int(7.9) +} -result [expr {int(7.9)}] + +test calc-24.7 {sqrt with variable} -setup { + set val 16 +} -body { + expr {[= sqrt(val)] == [expr {sqrt($val)}]} +} -result 1 -cleanup { + unset val +} + +test calc-24.8 {abs with variable} -setup { + set neg -50 +} -body { + expr {[= abs(neg)] == [expr {abs($neg)}]} +} -result 1 -cleanup { + unset neg +} + +# ---------- Trigonometric Functions ---------- + +test calc-25.1 {sin(0.2)} -body { + = sin(0.2) +} -result [expr {sin(0.2)}] + +test calc-25.2 {cos(0.2)} -body { + = cos(0.2) +} -result [expr {cos(0.2)}] + +test calc-25.3 {tan(0.2)} -body { + = tan(0.2) +} -result [expr {tan(0.2)}] + +test calc-25.4 {sin(pi)} -setup { + set pi 3.14159265359 +} -body { + expr {[= sin(pi)] == [expr {sin($pi)}]} +} -result 1 -cleanup { + unset pi +} + +test calc-25.5 {cos(pi)} -setup { + set pi 3.14159265359 +} -body { + expr {[= cos(pi)] == [expr {cos($pi)}]} +} -result 1 -cleanup { + unset pi +} + +# ---------- Logarithmic and Exponential ---------- + +test calc-26.1 {exp(0)} -body { + = exp(0) +} -result [expr {exp(0)}] + +test calc-26.2 {exp(1)} -body { + = exp(1) +} -result [expr {exp(1)}] + +test calc-26.3 {log(1)} -body { + = log(1) +} -result [expr {log(1)}] + +test calc-26.4 {log10(100)} -body { + = log10(100) +} -result [expr {log10(100)}] + +test calc-26.5 {log with variable} -setup { + set e 2.71828 +} -body { + expr {[= log(e)] == [expr {log($e)}]} +} -result 1 -cleanup { + unset e +} + +# ---------- Two Argument Functions ---------- + +test calc-27.1 {min(5, 10)} -body { + = min(5, 10) +} -result [expr {min(5, 10)}] + +test calc-27.2 {min(10, 5)} -body { + = min(10, 5) +} -result [expr {min(10, 5)}] + +test calc-27.3 {max(5, 10)} -body { + = max(5, 10) +} -result [expr {max(5, 10)}] + +test calc-27.4 {max(10, 5)} -body { + = max(10, 5) +} -result [expr {max(10, 5)}] + +test calc-27.5 {pow(2, 8)} -body { + = pow(2, 8) +} -result [expr {pow(2, 8)}] + +test calc-27.6 {pow(10, 3)} -body { + = pow(10, 3) +} -result [expr {pow(10, 3)}] + +test calc-27.7 {hypot(3, 4)} -body { + = hypot(3, 4) +} -result [expr {hypot(3, 4)}] + +test calc-27.8 {atan2(1, 1)} -body { + = atan2(1, 1) +} -result [expr {atan2(1, 1)}] + +# ---------- Two Argument Functions with Variables ---------- + +test calc-28.1 {min with variables} -setup { + set a 7 + set b 12 +} -body { + expr {[= min(a, b)] == [expr {min($a, $b)}]} +} -result 1 -cleanup { + unset a b +} + +test calc-28.2 {max with variables} -setup { + set a 7 + set b 12 +} -body { + expr {[= max(a, b)] == [expr {max($a, $b)}]} +} -result 1 -cleanup { + unset a b +} + +test calc-28.3 {pow with variables} -setup { + set a 7 +} -body { + expr {[= pow(a, 2)] == [expr {pow($a, 2)}]} +} -result 1 -cleanup { + unset a +} + +test calc-28.4 {hypot with variables} -setup { + set a 7 + set b 12 +} -body { + expr {[= hypot(a, b)] == [expr {hypot($a, $b)}]} +} -result 1 -cleanup { + unset a b +} + +# ---------- Multiple Argument Functions ---------- + +test calc-29.1 {min with 3 args} -body { + = min(5, 10, 3) +} -result [expr {min(5, 10, 3)}] + +test calc-29.2 {min with 4 args} -body { + = min(10, 5, 15, 2) +} -result [expr {min(10, 5, 15, 2)}] + +test calc-29.3 {max with 3 args} -body { + = max(5, 10, 3) +} -result [expr {max(5, 10, 3)}] + +test calc-29.4 {max with 4 args} -body { + = max(10, 5, 15, 2) +} -result [expr {max(10, 5, 15, 2)}] + +test calc-29.5 {min with variables} -setup { + set x 8 + set y 3 + set z 15 +} -body { + expr {[= min(x, y, z)] == [expr {min($x, $y, $z)}]} +} -result 1 -cleanup { + unset x y z +} + +test calc-29.6 {max with variables} -setup { + set x 8 + set y 3 + set z 15 +} -body { + expr {[= max(x, y, z)] == [expr {max($x, $y, $z)}]} +} -result 1 -cleanup { + unset x y z +} + +# ---------- Mixed Expressions with Functions ---------- + +test calc-30.1 {min + max} -setup { + set a 7 + set b 12 +} -body { + expr {[= min(a, b) + max(a, b)] == [expr {min($a, $b) + max($a, $b)}]} +} -result 1 -cleanup { + unset a b +} + +test calc-30.2 {pythagorean theorem} -body { + = sqrt(pow(3, 2) + pow(4, 2)) +} -result [expr {sqrt(pow(3, 2) + pow(4, 2))}] + +test calc-30.3 {nested abs and max} -body { + = max(abs(-5), abs(-3)) +} -result [expr {max(abs(-5), abs(-3))}] + +# ---------- Functions with Expressions as Arguments ---------- + +test calc-31.1 {min with expression args} -setup { + set a 7 + set b 12 +} -body { + expr {[= min(a+1, b-1)] == [expr {min($a+1, $b-1)}]} +} -result 1 -cleanup { + unset a b +} + +test calc-31.2 {max with expression args} -setup { + set a 7 + set b 12 +} -body { + expr {[= max(a*2, b/2)] == [expr {max($a*2, $b/2)}]} +} -result 1 -cleanup { + unset a b +} + +test calc-31.3 {pow with sum} -setup { + set a 7 + set b 12 +} -body { + expr {[= pow(a+b, 2)] == [expr {pow($a+$b, 2)}]} +} -result 1 -cleanup { + unset a b +} + +test calc-31.4 {distance formula} -setup { + set a 7 + set b 12 +} -body { + expr {[= sqrt(a*a + b*b)] == [expr {sqrt($a*$a + $b*$b)}]} +} -result 1 -cleanup { + unset a b +} + +# ---------- Nested Multi-Argument Functions ---------- + +test calc-32.1 {max of mins} -setup { + set a 7 + set b 12 + set y 3 + set z 15 +} -body { + expr {[= max(min(a, b), min(y, z))] == [expr {max(min($a, $b), min($y, $z))}]} +} -result 1 -cleanup { + unset a b y z +} + +test calc-32.2 {min of maxes} -body { + = min(max(5, 10), max(3, 8)) +} -result [expr {min(max(5, 10), max(3, 8))}] + +# ---------- Functions with Bignums ---------- + +test calc-33.1 {min with bignums} -setup { + set huge1 [expr {10 ** 50}] + set huge2 [expr {10 ** 51}] +} -body { + expr {[= min(huge1, huge2)] == [expr {min($huge1, $huge2)}]} +} -result 1 -cleanup { + unset huge1 huge2 +} + +test calc-33.2 {max with bignums} -setup { + set huge1 [expr {10 ** 50}] + set huge2 [expr {10 ** 51}] +} -body { + expr {[= max(huge1, huge2)] == [expr {max($huge1, $huge2)}]} +} -result 1 -cleanup { + unset huge1 huge2 +} + +test calc-33.3 {pow creating bignum} -body { + = pow(2, 100) +} -result [expr {pow(2, 100)}] + +# ---------- Functions on Arrays ---------- + +test calc-34.1 {min with array values} -setup { + array set results {1 10 2 20 3 5} + set k1 1 + set k2 2 +} -body { + expr {[= min($results($k1), $results($k2))] == [expr {min($results($k1), $results($k2))}]} +} -result 1 -cleanup { + unset results k1 k2 +} + +test calc-34.2 {max with 3 array values} -setup { + array set results {1 10 2 20 3 5} + set k1 1 + set k2 2 + set k3 3 +} -body { + expr {[= max($results($k1), $results($k2), $results($k3))] == [expr {max($results($k1), $results($k2), $results($k3))}]} +} -result 1 -cleanup { + unset results k1 k2 k3 +} + +# ---------- Functions with Ternary ---------- + +test calc-35.1 {function result in ternary} -setup { + set test 100 +} -body { + expr {[= min(test, 50) > 40 ? 1 : 0] == [expr {min($test, 50) > 40 ? 1 : 0}]} +} -result 1 -cleanup { + unset test +} + +test calc-35.2 {ternary with function in both branches} -setup { + set a 7 + set b 12 +} -body { + expr {[= max(a, b) < 20 ? max(a,b) : 20] == [expr {max($a, $b) < 20 ? max($a,$b) : 20}]} +} -result 1 -cleanup { + unset a b +} + +# ---------- Combining Everything ---------- + +test calc-36.1 {complex nested functions} -setup { + set base 3 + set exp 4 +} -body { + expr {[= sqrt(pow(base, exp))] == [expr {sqrt(pow($base, $exp))}]} +} -result 1 -cleanup { + unset base exp +} + +test calc-36.2 {min of abs values} -setup { + set a 7 + set b 12 + set z 15 +} -body { + expr {[= min(abs(-a), abs(-b), abs(-z))] == [expr {min(abs(-$a), abs(-$b), abs(-$z))}]} +} -result 1 -cleanup { + unset a b z +} + +test calc-36.3 {max of sqrt values} -setup { + set a 7 + set b 12 + set z 15 +} -body { + expr {[= max(sqrt(a), sqrt(b), sqrt(z))] == [expr {max(sqrt($a), sqrt($b), sqrt($z))}]} +} -result 1 -cleanup { + unset a b z +} + +# ---------- Variable Scoping Tests ---------- + +test calc-37.1 {local variables in proc} -body { + proc test_locals {} { + set x 5 + set y 12 + set result [= sqrt(x*x + y*y)] + set expected [expr {sqrt($x*$x + $y*$y)}] + expr {$result == $expected} + } + test_locals +} -result 1 -cleanup { + rename test_locals {} +} + +test calc-37.2 {global with :: prefix} -setup { + set ::gx 100 + set ::gy 200 +} -body { + proc test_global_colon {} { + set result [= max(::gx, ::gy)] + set expected [expr {max($::gx, $::gy)}] + expr {$result == $expected} + } + test_global_colon +} -result 1 -cleanup { + rename test_global_colon {} + unset ::gx ::gy +} + +test calc-37.3 {global with declaration} -setup { + set ::ga 50 + set ::gb 75 +} -body { + proc test_global_declared {} { + global ga gb + set result [= min(ga, gb)] + set expected [expr {min($ga, $gb)}] + expr {$result == $expected} + } + test_global_declared +} -result 1 -cleanup { + rename test_global_declared {} + unset ::ga ::gb +} + +test calc-37.4 {mix of local and global} -setup { + set ::radius 10 +} -body { + proc test_mixed {} { + set height 20 + global radius + set result [= pow(radius, 2) + height] + set expected [expr {pow($radius, 2) + $height}] + expr {$result == $expected} + } + test_mixed +} -result 1 -cleanup { + rename test_mixed {} + unset ::radius +} + +test calc-37.5 {namespace variables} -body { + namespace eval ::myns { + variable data 42 + proc test_namespace {} { + variable data + set result [= sqrt(::myns::data)] + set expected [expr {sqrt($::myns::data)}] + expr {$result == $expected} + } + } + ::myns::test_namespace +} -result 1 -cleanup { + namespace delete ::myns +} + +# ---------- Custom Math Functions ---------- + +test calc-38.1 {custom fibonacci function: fibonacci(10)} -setup { + namespace eval ::math { + proc fibonacci {n} { + if {$n == 0} {return 0} + set prev0 0 + set prev1 1 + for {set i 1} {$i < $n} {incr i} { + set tmp $prev1 + incr prev1 $prev0 + set prev0 $tmp + } + return $prev1 + } + } + proc tcl::mathfunc::fibonacci {n} { + return [::math::fibonacci $n] + } +} -body { + expr {[= fibonacci(10)] == [expr {fibonacci(10)}]} +} -result 1 -cleanup { + rename tcl::mathfunc::fibonacci {} + namespace delete ::math +} + +test calc-38.2 {fibonacci(20)} -setup { + namespace eval ::math { + proc fibonacci {n} { + if {$n == 0} {return 0} + set prev0 0 + set prev1 1 + for {set i 1} {$i < $n} {incr i} { + set tmp $prev1 + incr prev1 $prev0 + set prev0 $tmp + } + return $prev1 + } + } + proc tcl::mathfunc::fibonacci {n} { + return [::math::fibonacci $n] + } +} -body { + expr {[= fibonacci(20)] == [expr {fibonacci(20)}]} +} -result 1 -cleanup { + rename tcl::mathfunc::fibonacci {} + namespace delete ::math +} + +test calc-38.3 {fibonacci(30)} -setup { + namespace eval ::math { + proc fibonacci {n} { + if {$n == 0} {return 0} + set prev0 0 + set prev1 1 + for {set i 1} {$i < $n} {incr i} { + set tmp $prev1 + incr prev1 $prev0 + set prev0 $tmp + } + return $prev1 + } + } + proc tcl::mathfunc::fibonacci {n} { + return [::math::fibonacci $n] + } +} -body { + expr {[= fibonacci(30)] == [expr {fibonacci(30)}]} +} -result 1 -cleanup { + rename tcl::mathfunc::fibonacci {} + namespace delete ::math +} + +test calc-38.4 {fibonacci with variable} -setup { + namespace eval ::math { + proc fibonacci {n} { + if {$n == 0} {return 0} + set prev0 0 + set prev1 1 + for {set i 1} {$i < $n} {incr i} { + set tmp $prev1 + incr prev1 $prev0 + set prev0 $tmp + } + return $prev1 + } + } + proc tcl::mathfunc::fibonacci {n} { + return [::math::fibonacci $n] + } + set n 15 +} -body { + expr {[= fibonacci(n)] == [expr {fibonacci($n)}]} +} -result 1 -cleanup { + rename tcl::mathfunc::fibonacci {} + namespace delete ::math + unset n +} + +test calc-38.5 {fibonacci bignum: fibonacci(100)} -setup { + namespace eval ::math { + proc fibonacci {n} { + if {$n == 0} {return 0} + set prev0 0 + set prev1 1 + for {set i 1} {$i < $n} {incr i} { + set tmp $prev1 + incr prev1 $prev0 + set prev0 $tmp + } + return $prev1 + } + } + proc tcl::mathfunc::fibonacci {n} { + return [::math::fibonacci $n] + } +} -body { + expr {[= fibonacci(100)] == [expr {fibonacci(100)}]} +} -result 1 -cleanup { + rename tcl::mathfunc::fibonacci {} + namespace delete ::math +} + +test calc-38.6 {fibonacci(200)} -setup { + namespace eval ::math { + proc fibonacci {n} { + if {$n == 0} {return 0} + set prev0 0 + set prev1 1 + for {set i 1} {$i < $n} {incr i} { + set tmp $prev1 + incr prev1 $prev0 + set prev0 $tmp + } + return $prev1 + } + } + proc tcl::mathfunc::fibonacci {n} { + return [::math::fibonacci $n] + } +} -body { + expr {[= fibonacci(200)] == [expr {fibonacci(200)}]} +} -result 1 -cleanup { + rename tcl::mathfunc::fibonacci {} + namespace delete ::math +} + +test calc-38.7 {fibonacci in expression} -setup { + namespace eval ::math { + proc fibonacci {n} { + if {$n == 0} {return 0} + set prev0 0 + set prev1 1 + for {set i 1} {$i < $n} {incr i} { + set tmp $prev1 + incr prev1 $prev0 + set prev0 $tmp + } + return $prev1 + } + } + proc tcl::mathfunc::fibonacci {n} { + return [::math::fibonacci $n] + } + set x 10 + set y 12 +} -body { + expr {[= fibonacci(x) + fibonacci(y)] == [expr {fibonacci($x) + fibonacci($y)}]} +} -result 1 -cleanup { + rename tcl::mathfunc::fibonacci {} + namespace delete ::math + unset x y +} + +test calc-38.8 {max of fibonacci values} -setup { + namespace eval ::math { + proc fibonacci {n} { + if {$n == 0} {return 0} + set prev0 0 + set prev1 1 + for {set i 1} {$i < $n} {incr i} { + set tmp $prev1 + incr prev1 $prev0 + set prev0 $tmp + } + return $prev1 + } + } + proc tcl::mathfunc::fibonacci {n} { + return [::math::fibonacci $n] + } +} -body { + expr {[= max(fibonacci(8), fibonacci(9))] == [expr {max(fibonacci(8), fibonacci(9))}]} +} -result 1 -cleanup { + rename tcl::mathfunc::fibonacci {} + namespace delete ::math +} + +test calc-38.9 {nested fibonacci and sqrt} -setup { + namespace eval ::math { + proc fibonacci {n} { + if {$n == 0} {return 0} + set prev0 0 + set prev1 1 + for {set i 1} {$i < $n} {incr i} { + set tmp $prev1 + incr prev1 $prev0 + set prev0 $tmp + } + return $prev1 + } + } + proc tcl::mathfunc::fibonacci {n} { + return [::math::fibonacci $n] + } +} -body { + expr {[= sqrt(fibonacci(10))] == [expr {sqrt(fibonacci(10))}]} +} -result 1 -cleanup { + rename tcl::mathfunc::fibonacci {} + namespace delete ::math +} + +test calc-38.10 {abs(fibonacci(5) - 100)} -setup { + namespace eval ::math { + proc fibonacci {n} { + if {$n == 0} {return 0} + set prev0 0 + set prev1 1 + for {set i 1} {$i < $n} {incr i} { + set tmp $prev1 + incr prev1 $prev0 + set prev0 $tmp + } + return $prev1 + } + } + proc tcl::mathfunc::fibonacci {n} { + return [::math::fibonacci $n] + } +} -body { + expr {[= abs(fibonacci(5) - 100)] == [expr {abs(fibonacci(5) - 100)}]} +} -result 1 -cleanup { + rename tcl::mathfunc::fibonacci {} + namespace delete ::math +} + +test calc-38.11 {fibonacci comparison} -setup { + namespace eval ::math { + proc fibonacci {n} { + if {$n == 0} {return 0} + set prev0 0 + set prev1 1 + for {set i 1} {$i < $n} {incr i} { + set tmp $prev1 + incr prev1 $prev0 + set prev0 $tmp + } + return $prev1 + } + } + proc tcl::mathfunc::fibonacci {n} { + return [::math::fibonacci $n] + } + set fib100 [expr {fibonacci(100)}] + set fib101 [expr {fibonacci(101)}] +} -body { + expr {[= fib100 < fib101] == [expr {$fib100 < $fib101}]} +} -result 1 -cleanup { + rename tcl::mathfunc::fibonacci {} + namespace delete ::math + unset fib100 fib101 +} + + +# ---------- Pre-Substitution in Procs (Runtime Fallback) ---------- + +test calc-39.1 {variable substitution in proc} -body { + proc test_var_subst {a b} { + = $a + $b + } + test_var_subst 10 20 +} -result 30 -cleanup { + rename test_var_subst {} +} + +test calc-39.2 {mixed literal and substitution} -body { + proc test_mixed {n} { + = $n * 2 + 5 + } + test_mixed 10 +} -result 25 -cleanup { + rename test_mixed {} +} + +test calc-39.3 {command substitution in proc} -body { + proc test_cmd_subst {x} { + = [expr {$x * 2}] + 10 + } + test_cmd_subst 5 +} -result 20 -cleanup { + rename test_cmd_subst {} +} + +# ---------- Edge Cases and Security Tests ---------- + +test calc-40.1 {comma operator only in function args} -body { + catch {= 4,10} result + string match "*Expected*" $result +} -result 1 + +test calc-40.2 {pre-substitution with simple variables} -setup { + set x 10 + set y 20 +} -body { + proc test_presub {a b} { + = $a + $b + } + test_presub $x $y +} -result 30 -cleanup { + rename test_presub {} + unset x y +} + +test calc-40.3 {pre-substitution with non-numeric fails gracefully} -body { + proc test_non_numeric {a} { + = $a + 1 + } + # Just check that it errors, don't check specific message + catch {test_non_numeric "hello"} +} -result 1 -cleanup { + rename test_non_numeric {} +} + +test calc-40.4 {concatenated pre-substitution} -setup { + set x 5 + set y 10 +} -body { + proc test_concat {a b} { + = $a+$b + } + test_concat $x $y +} -result 15 -cleanup { + rename test_concat {} + unset x y +} + +test calc-40.5 {expression injection via global variable} -setup { + set ::testvar 100 + set x "::testvar" +} -body { + # This evaluates "1+::testvar" which accesses the global + expr {[= 1 + $x] == 101} +} -result 1 -cleanup { + unset ::testvar x +} + +test calc-40.6 {invalid character in expression} -body { + catch {= 1 + \[pwd]} result + string match "*Expected*" $result +} -result 1 + +test calc-40.7 {backslash in expression} -body { + catch {= 1 + \\} result + string match "*Expected*" $result +} -result 1 + +test calc-40.8 {semicolon in expression} -body { + catch {= {1 + 2; 3}} result + string match "*Expected*" $result +} -result 1 + +test calc-40.9 {mismatched parentheses} -body { + catch {= {(1 + 2}} result + string match "*Expected*)*" $result +} -result 1 + +test calc-40.10 {operator without operand} -body { + catch {= 1 +} +} -result 1 + +test calc-40.11 {global variable with ::} -setup { + set ::globalval 42 +} -body { + = ::globalval * 2 +} -result 84 -cleanup { + unset ::globalval +} + +test calc-40.12 {namespace variable} -setup { + namespace eval ::testns { + variable nsvar 25 + } +} -body { + = ::testns::nsvar + 5 +} -result 30 -cleanup { + namespace delete ::testns +} + +test calc-40.13 {non-existent variable} -body { + catch {= noSuchVar + 1} result + string match "*can't read*noSuchVar*" $result +} -result 1 + +test calc-40.14 {empty expression} -body { + catch {=} result + string match "*wrong # args*" $result +} -result 1 + +test calc-40.15 {expression with only operators} -body { + catch {= + *} result + string match "*Expected*" $result +} -result 1 + +test calc-40.16 {pre-sub numeric check with integer} -setup { + set val 42 +} -body { + proc test_int {x} { + = $x * 2 + } + test_int $val +} -result 84 -cleanup { + rename test_int {} + unset val +} + +test calc-40.17 {pre-sub numeric check with double} -setup { + set val 3.14 +} -body { + proc test_double {x} { + = $x * 2 + } + test_double $val +} -result 6.28 -cleanup { + rename test_double {} + unset val +} + +test calc-40.18 {pre-sub numeric check with bignum} -setup { + set val 999999999999999999999 +} -body { + proc test_bignum {x} { + = $x + 1 + } + test_bignum $val +} -result 1000000000000000000000 -cleanup { + rename test_bignum {} + unset val +} + +test calc-40.19 {mixed literal and pre-substitution in proc} -body { + proc test_mixed {a b} { + = $a + b * 2 + } + test_mixed 5 10 +} -result 25 -cleanup { + rename test_mixed {} +} + +test calc-40.20 {pre-sub with expression fragment in value} -setup { + set fragment "1+1" +} -body { + proc test_fragment {x} { + = $x + 10 + } + # x contains "1+1" which gets evaluated as expression + test_fragment $fragment +} -result 12 -cleanup { + rename test_fragment {} + unset fragment +} + +test calc-40.21 {multiple pre-substitutions all numeric} -setup { + set a 1 + set b 2 + set c 3 +} -body { + proc test_multi {x y z} { + = $x + $y + $z + } + test_multi $a $b $c +} -result 6 -cleanup { + rename test_multi {} + unset a b c +} + +test calc-40.22 {multiple pre-subs with one non-numeric} -setup { + set a 1 + set b "bad" + set c 3 +} -body { + proc test_mixed {x y z} { + = $x + $y + $z + } + # Just check that it errors + catch {test_mixed $a $b $c} +} -result 1 -cleanup { + rename test_mixed {} + unset a b c +} + +test calc-40.23 {division by zero with pre-sub} -setup { + set zero 0 +} -body { + proc test_divzero {x} { + = 10 / $x + } + catch {test_divzero $zero} result + string match "*divide by zero*" $result +} -result 1 -cleanup { + rename test_divzero {} + unset zero +} + +test calc-40.24 {unary minus with pre-sub} -setup { + set val 5 +} -body { + proc test_unary {x} { + = -$x + 10 + } + test_unary $val +} -result 5 -cleanup { + rename test_unary {} + unset val +} + +test calc-40.25 {parenthesized pre-sub} -setup { + set a 5 + set b 3 +} -body { + proc test_parens {x y} { + = ($x + $y) * 2 + } + test_parens $a $b +} -result 16 -cleanup { + rename test_parens {} + unset a b +} + +test calc-40.26 {function call with pre-sub arg} -setup { + set val 16 +} -body { + proc test_func {x} { + = sqrt($x) + } + test_func $val +} -result 4.0 -cleanup { + rename test_func {} + unset val +} + +test calc-40.27 {nested function calls with pre-sub} -setup { + set val 3 +} -body { + proc test_nested {x} { + = abs(sin($x)) + } + expr {[test_nested $val] >= 0} +} -result 1 -cleanup { + rename test_nested {} + unset val +} + +test calc-40.28 {pre-sub in ternary operator} -setup { + set cond 1 + set iftrue 10 + set iffalse 20 +} -body { + proc test_ternary {c t f} { + = $c ? $t : $f + } + test_ternary $cond $iftrue $iffalse +} -result 10 -cleanup { + rename test_ternary {} + unset cond iftrue iffalse +} + +test calc-40.29 {pre-sub with logical operators} -setup { + set x 1 + set y 0 +} -body { + proc test_logical {a b} { + = $a && $b + } + test_logical $x $y +} -result 0 -cleanup { + rename test_logical {} + unset x y +} + +test calc-40.30 {comparison with pre-sub} -setup { + set a 10 + set b 20 +} -body { + proc test_compare {x y} { + = $x < $y + } + test_compare $a $b +} -result 1 -cleanup { + rename test_compare {} + unset a b +} + +test calc-40.31 {runtime path with literal bracket} -body { + # At command line (runtime path), literal [ should error gracefully + catch {= {[}} result + string match "*Expected*" $result +} -result 1 + +test calc-40.32 {compile path catches non-compilable} -body { + # Command substitution should trigger runtime fallback + proc test_cmdsub {} { + = [expr {5}] + 1 + } + test_cmdsub +} -result 6 -cleanup { + rename test_cmdsub {} +} + +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: Index: unix/installManPage ================================================================== --- unix/installManPage +++ unix/installManPage @@ -119,10 +119,13 @@ for n in $Specials; do if [ "$Name" = "$n" ] ; then Names="$n $Names" fi done +if [ "$Name" = "=" ] ; then + Names="$Name" +fi First="" for Target in $Names; do Target=$Target.$Section$Suffix rm -f "$Dir/$Target" "$Dir/$Target.*"