ADDED doc/const.n Index: doc/const.n ================================================================== --- /dev/null +++ doc/const.n @@ -0,0 +1,85 @@ +'\" +'\" Copyright (c) 2023 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH const n 9.0 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +const \- create and initialize a constant +.SH SYNOPSIS +\fBconst \fIvarName value\fR +.BE +.SH DESCRIPTION +.PP +This command is normally used within a procedure body (or method body, +or lambda term) to create a constant within that procedure, or within a +\fBnamespace eval\fR body to create a constant within that namespace. +The constant is an unmodifiable variable, called \fIvarName\fR, that is +initialized with \fIvalue\fR. +The result of \fBconst\fR is always the empty string on success. +.PP +If a variable \fIvarName\fR does not exist, it is created with its value set +to \fIvalue\fR and marked as a constant; this means that no other command +(e.g., \fBset\fR, \fBappend\fR, \fBincr\fR, \fBunset\fR) +may modify or remove the variable; variables are checked for whether they +are constants before any traces are called. +If a variable \fIvarName\fR already exists, it is an error unless that +variable is marked as a constant (in which case \fBconst\fR is a no-op). +.PP +The \fIvarName\fR may not be a qualified name or reference an element of an +array by any means. If the variable exists and is an array, that is an error. +.PP +Constants are normally only removed by their containing procedure exiting or +their namespace being deleted. +.SH EXAMPLES +.PP +Create a constant in a procedure: +.PP +.CS +proc foo {a b} { + \fBconst\fR BAR 12345 + return [expr {$a + $b + $BAR}] +} +.CE +.PP +Create a constant in a namespace to factor out a regular expression: +.PP +.CS +namespace eval someNS { + \fBconst\fR FOO_MATCHER {(?i)}\emfoo\eM} + + proc findFoos str { + variable FOO_MATCHER + regexp -all $FOO_MATCHER $str + } + + proc findFooIndices str { + variable FOO_MATCHER + regexp -all -indices $FOO_MATCHER $str + } +} +.CE +.PP +Making a constant in a loop doesn't error: +.PP +.CS +proc foo {n} { + set result {} + for {set i 0} {$i < $n} {incr i} { + \fBconst\fR X 123 + lappend result [expr {$X + $i**2}] + } +} +.CE +.SH "SEE ALSO" +proc(n), namespace(n), set(n), unset(n) +.SH KEYWORDS +namespace, procedure, variable, constant +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: Index: doc/info.n ================================================================== --- doc/info.n +++ doc/info.n @@ -82,10 +82,23 @@ \fBinfo complete \fIcommand\fR . Returns 1 if \fIcommand\fR is a complete command, and \fB0\fR otherwise. Typically used in line-oriented input environments to allow users to type in commands that span multiple lines. +.TP +\fBinfo constant \fIvarName\fR +.VS "TIP 677" +Returns 1 if \fIvarName\fR is a constant variable (see \fBconst\fR) and 0 +otherwise. +.VE "TIP 677" +.TP +\fBinfo consts\fR ?\fIpattern\fR? +.VS "TIP 677" +Returns the list of constant variables (see \fBconst\fR) in the current scope, +or the list of constant variables matching \fIpattern\fR (if that is provided) +in a manner similar to \fBinfo vars\fR. +.VE "TIP 677" .TP \fBinfo coroutine\fR . Returns the name of the current \fBcoroutine\fR, or the empty string if there is no current coroutine or the current coroutine Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -314,10 +314,11 @@ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, + {"const", Tcl_ConstObjCmd, TclCompileConstCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE}, {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE}, {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, @@ -331,11 +332,11 @@ {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE}, {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, - {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, Index: generic/tclCmdIL.c ================================================================== --- generic/tclCmdIL.c +++ generic/tclCmdIL.c @@ -158,10 +158,12 @@ {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"constant", TclInfoConstantCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"consts", TclInfoConstsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0}, {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0}, {"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, Index: generic/tclCompCmds.c ================================================================== --- generic/tclCompCmds.c +++ generic/tclCompCmds.c @@ -913,10 +913,88 @@ TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr); return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TclCompileConstCmd -- + * + * Procedure called to compile the "const" 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 "const" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileConstCmd( + Tcl_Interp *interp, /* The interpreter. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + TCL_UNUSED(Command *), + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *varTokenPtr, *valueTokenPtr; + int isScalar, localIndex; + + /* + * Need exactly two arguments. + */ + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &isScalar, 1); + + /* + * If the user specified an array element, we don't bother handling + * that. + */ + if (!isScalar) { + return TCL_ERROR; + } + + /* + * We are doing an assignment to set the value of the constant. This will + * need to be extended to push a value for each argument. + */ + + valueTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, valueTokenPtr, interp, 2); + + if (localIndex < 0) { + TclEmitOpcode(INST_CONST_STK, envPtr); + } else { + TclEmitInstInt4(INST_CONST_IMM, localIndex, envPtr); + } + + /* + * The const command's result is an empty string. + */ + PushStringLiteral(envPtr, ""); + return TCL_OK; +} /* *---------------------------------------------------------------------- * * TclCompileContinueCmd -- Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -662,10 +662,17 @@ * flags: Combination of TCL_LREPLACE4_* flags * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj * where index2 is present only if TCL_LREPLACE_SINGLE_INDEX is not * set in flags. */ + + {"constImm", 5, -1, 1, {OPERAND_LVT4}}, + /* Create constant. Index into LVT is immediate, value is on stack. + * Stack: ... value => ... */ + {"constStk", 1, -2, 0, {OPERAND_NONE}}, + /* Create constant. Variable name and value on stack. + * Stack: ... varName value => ... */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; /* Index: generic/tclCompile.h ================================================================== --- generic/tclCompile.h +++ generic/tclCompile.h @@ -834,10 +834,14 @@ INST_STR_GT, INST_STR_LE, INST_STR_GE, INST_LREPLACE4, + + /* TIP 667: const */ + INST_CONST_IMM, + INST_CONST_STK, /* The last opcode */ LAST_INST_OPCODE }; Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -3923,10 +3923,81 @@ } break; /* * End of INST_UNSET instructions. + * ----------------------------------------------------------------- + * Start of INST_CONST instructions. + */ + { + const char *msgPart; + + case INST_CONST_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + cleanup = 1; + part1Ptr = NULL; + objPtr = OBJ_AT_TOS; + TRACE(("%u "\"%.30s\" => \n", opnd, O2S(objPtr))); + varPtr = LOCAL(opnd); + arrayPtr = NULL; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + goto doConst; + case INST_CONST_STK: + opnd = -1; + pcAdjustment = 1; + cleanup = 2; + part1Ptr = OBJ_UNDER_TOS; + objPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(objPtr))); + varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, + /*createPart1*/1, /*createPart2*/0, &arrayPtr); + doConst: + if (TclIsVarConstant(varPtr)) { + TRACE_APPEND(("\n")); + NEXT_INST_V(pcAdjustment, cleanup, 0); + } + if (TclIsVarArray(varPtr)) { + msgPart = "variable is array"; + goto constError; + } else if (TclIsVarArrayElement(varPtr)) { + msgPart = "name refers to an element in an array"; + goto constError; + } else if (!TclIsVarUndefined(varPtr)) { + msgPart = "variable already exists"; + goto constError; + } + if (TclIsVarDirectModifyable(varPtr)) { + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); + } else { + Tcl_Obj *resPtr; + + DECACHE_STACK_INFO(); + resPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, NULL, + objPtr, TCL_LEAVE_ERR_MSG, opnd); + CACHE_STACK_INFO(); + if (resPtr == NULL) { + TRACE_ERROR(interp); + goto gotError; + } + } + TclSetVarConstant(varPtr); + TRACE_APPEND(("\n")); + NEXT_INST_V(pcAdjustment, cleanup, 0); + + constError: + TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", msgPart, opnd); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); + TRACE_ERROR(interp); + goto gotError; + } + + /* + * End of INST_CONST instructions. * ----------------------------------------------------------------- * Start of INST_ARRAY instructions. */ case INST_ARRAY_EXISTS_IMM: Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -659,10 +659,15 @@ * real value or is itself another VAR_LINK * pointer. Variables like this come about * through "upvar" and "global" commands, or * through references to variables in enclosing * namespaces. + * VAR_CONSTANT - 1 means this is a constant "variable", and + * cannot be written to by ordinary commands. + * Structurally, it's the same as a scalar when + * being read, but writes are rejected. Constants + * are not supported inside arrays. * * Flags that indicate the type and status of storage; none is set for * compiled local variables (Var structs). * * VAR_IN_HASHTABLE - 1 means this variable is in a hash table and @@ -723,10 +728,11 @@ */ /* Type of value (0 is scalar) */ #define VAR_ARRAY 0x1 #define VAR_LINK 0x2 +#define VAR_CONSTANT 0x10000 /* Type of storage (0 is compiled local) */ #define VAR_IN_HASHTABLE 0x4 #define VAR_DEAD_HASH 0x8 #define VAR_ARRAY_ELEMENT 0x1000 @@ -757,29 +763,33 @@ * The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE void TclSetVarScalar(Var *varPtr); * MODULE_SCOPE void TclSetVarArray(Var *varPtr); * MODULE_SCOPE void TclSetVarLink(Var *varPtr); + * MODULE_SCOPE void TclSetVarConstant(Var *varPtr); * MODULE_SCOPE void TclSetVarArrayElement(Var *varPtr); * MODULE_SCOPE void TclSetVarUndefined(Var *varPtr); * MODULE_SCOPE void TclClearVarUndefined(Var *varPtr); */ #define TclSetVarScalar(varPtr) \ - (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK) + (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK|VAR_CONSTANT) #define TclSetVarArray(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_LINK) | VAR_ARRAY #define TclSetVarLink(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_LINK +#define TclSetVarConstant(varPtr) \ + (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_CONSTANT + #define TclSetVarArrayElement(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT #define TclSetVarUndefined(varPtr) \ - (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK);\ + (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK|VAR_CONSTANT);\ (varPtr)->value.objPtr = NULL #define TclClearVarUndefined(varPtr) #define TclSetVarTraceActive(varPtr) \ @@ -807,10 +817,11 @@ /* * Macros to read various flag bits of variables. * The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE int TclIsVarScalar(Var *varPtr); + * MODULE_SCOPE int TclIsVarConstant(Var *varPtr); * MODULE_SCOPE int TclIsVarLink(Var *varPtr); * MODULE_SCOPE int TclIsVarArray(Var *varPtr); * MODULE_SCOPE int TclIsVarUndefined(Var *varPtr); * MODULE_SCOPE int TclIsVarArrayElement(Var *varPtr); * MODULE_SCOPE int TclIsVarTemporary(Var *varPtr); @@ -833,10 +844,14 @@ ((varPtr)->flags & VAR_LINK) #define TclIsVarArray(varPtr) \ ((varPtr)->flags & VAR_ARRAY) +/* Implies scalar as well. */ +#define TclIsVarConstant(varPtr) \ + ((varPtr)->flags & VAR_CONSTANT) + #define TclIsVarUndefined(varPtr) \ ((varPtr)->value.objPtr == NULL) #define TclIsVarArrayElement(varPtr) \ ((varPtr)->flags & VAR_ARRAY_ELEMENT) @@ -892,17 +907,17 @@ #define TclIsVarDirectReadable(varPtr) \ ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ)) \ && (varPtr)->value.objPtr) #define TclIsVarDirectWritable(varPtr) \ - (!TclIsVarTricky(varPtr,VAR_TRACED_WRITE|VAR_DEAD_HASH)) + (!TclIsVarTricky(varPtr,VAR_TRACED_WRITE|VAR_DEAD_HASH|VAR_CONSTANT)) #define TclIsVarDirectUnsettable(varPtr) \ - (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH)) + (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH|VAR_CONSTANT)) #define TclIsVarDirectModifyable(varPtr) \ - ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE)) \ + ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_CONSTANT)) \ && (varPtr)->value.objPtr) #define TclIsVarDirectReadable2(varPtr, arrayPtr) \ (TclIsVarDirectReadable(varPtr) &&\ (!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_READ))) @@ -3359,10 +3374,12 @@ MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd; MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); MODULE_SCOPE Tcl_ObjCmdProc TclInfoGlobalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoLocalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoVarsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoConstsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoConstantCmd; MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( Tcl_Interp *interp); @@ -3641,10 +3658,11 @@ MODULE_SCOPE Tcl_ObjCmdProc TclChanPushObjCmd; MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclClockOldscanObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CloseObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConcatObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ContinueObjCmd; MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, void *clientData); MODULE_SCOPE Tcl_ObjCmdProc TclDefaultBgErrorHandlerObjCmd; @@ -3754,10 +3772,11 @@ MODULE_SCOPE CompileProc TclCompileBreakCmd; MODULE_SCOPE CompileProc TclCompileCatchCmd; MODULE_SCOPE CompileProc TclCompileClockClicksCmd; MODULE_SCOPE CompileProc TclCompileClockReadingCmd; MODULE_SCOPE CompileProc TclCompileConcatCmd; +MODULE_SCOPE CompileProc TclCompileConstCmd; MODULE_SCOPE CompileProc TclCompileContinueCmd; MODULE_SCOPE CompileProc TclCompileDictAppendCmd; MODULE_SCOPE CompileProc TclCompileDictCreateCmd; MODULE_SCOPE CompileProc TclCompileDictExistsCmd; MODULE_SCOPE CompileProc TclCompileDictForCmd; Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -126,10 +126,12 @@ "upvar refers to variable in deleted namespace"; static const char BADNAMESPACE[] = "parent namespace doesn't exist"; static const char MISSINGNAME[] = "missing variable name"; static const char ISARRAYELEMENT[] = "name refers to an element in an array"; +static const char ISCONST[] = "variable is a constant"; +static const char EXISTS[] = "variable already exists"; /* * A test to see if we are in a call frame that has local variables. This is * true if we are inside a procedure body. */ @@ -176,11 +178,12 @@ /* * Forward references to functions defined later in this file: */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Obj *patternPtr, int includeLinks); + Tcl_Obj *patternPtr, int includeLinks, + int justConstants); static void ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr); static void ArrayDoneSearch(Interp *iPtr, Var *varPtr, ArraySearch *searchPtr); @@ -1938,10 +1941,21 @@ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", (void *)NULL); } } goto earlyError; } + + /* + * It's an error to try to set a constant. + */ + if (TclIsVarConstant(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISCONST,index); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "CONST", (void *)NULL); + } + goto earlyError; + } /* * It's an error to try to set an array variable itself. */ @@ -2218,10 +2232,21 @@ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { Tcl_Obj *varValuePtr; + + /* + * It's an error to try to increment a constant. + */ + if (TclIsVarConstant(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "incr", ISCONST,index); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "CONST", (void *)NULL); + } + return NULL; + } if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)++; } varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, @@ -2427,27 +2452,38 @@ int TclPtrUnsetVarIdx( Tcl_Interp *interp, /* Command interpreter in which varName is to * be looked up. */ - Var *varPtr, /* The variable to be unset. */ + Var *varPtr, /* The variable to be unset. */ Var *arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - int flags, /* OR-ed combination of any of + int flags, /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { Interp *iPtr = (Interp *) interp; int result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); Var *initialArrayPtr = arrayPtr; + + /* + * It's an error to try to unset a constant. + */ + if (TclIsVarConstant(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", ISCONST,index); + Tcl_SetErrorCode(interp, "TCL", "UNSET", "CONST", (void *)NULL); + } + return TCL_ERROR; + } /* * Keep the variable alive until we're done with it. We used to * increase/decrease the refCount for each operation, making it hard to * find [Bug 735335] - caused by unsetting the variable whose value was @@ -4806,10 +4842,85 @@ } /* *---------------------------------------------------------------------- * + * Tcl_ConstObjCmd -- + * + * This function is invoked to process the "const" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ConstObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Var *varPtr, *arrayPtr; + Tcl_Obj *part1Ptr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "varName value"); + return TCL_ERROR; + } + + part1Ptr = objv[1]; + varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, + "const", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (TclIsVarArray(varPtr)) { + TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", ISARRAY, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); + return TCL_ERROR; + } + if (TclIsVarArrayElement(varPtr)) { + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, arrayPtr); + } + TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", ISARRAYELEMENT, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); + return TCL_ERROR; + } + + /* + * If already exists, either a constant (no problem) or an error. + */ + if (!TclIsVarUndefined(varPtr)) { + if (TclIsVarConstant(varPtr)) { + return TCL_OK; + } + TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", EXISTS, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); + return TCL_ERROR; + } + + /* + * Make the variable and flag it as a constant. + */ + if (TclPtrSetVar(interp, (Tcl_Var) varPtr, NULL, objv[1], NULL, + objv[2], TCL_LEAVE_ERR_MSG) == NULL) { + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, arrayPtr); + } + return TCL_ERROR; + }; + TclSetVarConstant(varPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GlobalObjCmd -- * * This object-based function is invoked to process the "global" Tcl * command. See the user documentation for details on what it does. * @@ -6033,11 +6144,11 @@ varPtr = VarHashNextVar(&search); } } } } else if (iPtr->varFramePtr->procPtr != NULL) { - AppendLocals(interp, listPtr, simplePatternPtr, 1); + AppendLocals(interp, listPtr, simplePatternPtr, 1, 0); } if (simplePatternPtr) { Tcl_DecrRefCount(simplePatternPtr); } @@ -6187,11 +6298,205 @@ * ones stored in the call frame), then the variables in the local hash * table (if one exists). */ listPtr = Tcl_NewListObj(0, NULL); - AppendLocals(interp, listPtr, patternPtr, 0); + AppendLocals(interp, listPtr, patternPtr, 0, 0); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclInfoConstsCmd -- + * + * Called to implement the "info consts" command that returns the list of + * constants in the interpreter that match an optional pattern. The + * pattern, if any, consists of an optional sequence of namespace names + * separated by "::" qualifiers, which is followed by a glob-style + * pattern that restricts which variables are returned. Handles the + * following syntax: + * + * info consts ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +int +TclInfoConstsCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + const char *varName, *pattern, *simplePattern; + Tcl_HashSearch search; + Var *varPtr; + Namespace *nsPtr; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Tcl_Obj *listPtr, *elemObjPtr, *varNamePtr; + int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ + Tcl_Obj *simplePatternPtr = NULL; + + /* + * Get the pattern and find the "effective namespace" in which to list + * variables. We only use this effective namespace if there's no active + * Tcl procedure frame. + */ + + if (objc == 1) { + simplePattern = NULL; + nsPtr = currNsPtr; + specificNsInPattern = 0; + } else if (objc == 2) { + /* + * From the pattern, get the effective namespace and the simple + * pattern (no namespace qualifiers or ::'s) at the end. If an error + * was found while parsing the pattern, return it. Otherwise, if the + * namespace wasn't found, just leave nsPtr NULL: we will return an + * empty list since no variables there can be found. + */ + + Namespace *dummy1NsPtr, *dummy2NsPtr; + + pattern = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0, + &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + + if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ + specificNsInPattern = (strcmp(simplePattern, pattern) != 0); + if (simplePattern == pattern) { + simplePatternPtr = objv[1]; + } else { + simplePatternPtr = Tcl_NewStringObj(simplePattern, -1); + } + Tcl_IncrRefCount(simplePatternPtr); + } + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + + /* + * If the namespace specified in the pattern wasn't found, just return. + */ + + if (nsPtr == NULL) { + return TCL_OK; + } + + listPtr = Tcl_NewListObj(0, NULL); + + if (!HasLocalVars(iPtr->varFramePtr) || specificNsInPattern) { + /* + * There is no frame pointer, the frame pointer was pushed only to + * activate a namespace, or we are in a procedure call frame but a + * specific namespace was specified. Create a list containing only the + * variables in the effective namespace's variable table. + */ + + if (simplePattern && TclMatchIsTrivial(simplePattern)) { + /* + * If we can just do hash lookups, that simplifies things a lot. + */ + + varPtr = VarHashFindVar(&nsPtr->varTable, simplePatternPtr); + if (varPtr && TclIsVarConstant(varPtr)) { + if (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr)) { + if (specificNsInPattern) { + TclNewObj(elemObjPtr); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, + elemObjPtr); + } else { + elemObjPtr = VarHashGetKey(varPtr); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + varPtr = VarHashFindVar(&globalNsPtr->varTable, + simplePatternPtr); + if (varPtr && TclIsVarConstant(varPtr)) { + if (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr)) { + Tcl_ListObjAppendElement(interp, listPtr, + VarHashGetKey(varPtr)); + } + } + } + } else { + /* + * Have to scan the tables of variables. + */ + + varPtr = VarHashFirstVar(&nsPtr->varTable, &search); + while (varPtr) { + if (TclIsVarConstant(varPtr) && (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr))) { + varNamePtr = VarHashGetKey(varPtr); + varName = TclGetString(varNamePtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(varName, simplePattern)) { + if (specificNsInPattern) { + TclNewObj(elemObjPtr); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, + elemObjPtr); + } else { + elemObjPtr = varNamePtr; + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } + varPtr = VarHashNextVar(&search); + } + + /* + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern (i.e., the + * pattern only specifies variable names), then add in all global + * :: variables that match the simple pattern. Of course, add in + * only those variables that aren't hidden by a variable in the + * effective namespace. + */ + + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); + while (varPtr) { + if (TclIsVarConstant(varPtr) && (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr))) { + varNamePtr = VarHashGetKey(varPtr); + varName = TclGetString(varNamePtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(varName, simplePattern)) { + if (VarHashFindVar(&nsPtr->varTable, + varNamePtr) == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, + varNamePtr); + } + } + } + varPtr = VarHashNextVar(&search); + } + } + } + } else if (iPtr->varFramePtr->procPtr != NULL) { + AppendLocals(interp, listPtr, simplePatternPtr, 1, 1); + } + + if (simplePatternPtr) { + Tcl_DecrRefCount(simplePatternPtr); + } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* @@ -6208,17 +6513,36 @@ * Side effects: * None. * *---------------------------------------------------------------------- */ + +static int +ContextObjectContainsConstant( + Tcl_ObjectContext context, + Tcl_Obj *varNamePtr) +{ + /* + * Helper for AppendLocals to check if an object contains a variable + * that is a constant. It's too complicated without factoring this + * check out! + */ + + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + Namespace *nsPtr = (Namespace *) oPtr->namespacePtr; + Var *varPtr = VarHashFindVar(&nsPtr->varTable, varNamePtr); + + return !TclIsVarUndefined(varPtr) && TclIsVarConstant(varPtr); +} static void AppendLocals( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *listPtr, /* List object to append names to. */ Tcl_Obj *patternPtr, /* Pattern to match against. */ - int includeLinks) /* 1 if upvars should be included, else 0. */ + int includeLinks, /* 1 if upvars should be included, else 0. */ + int justConstants) /* 1 if just constants should be included. */ { Interp *iPtr = (Interp *) interp; Var *varPtr; Tcl_Size i, localVarCt; int added; @@ -6243,14 +6567,16 @@ /* * Skip nameless (temporary) variables and undefined variables. */ if (*varNamePtr && !TclIsVarUndefined(varPtr) - && (includeLinks || !TclIsVarLink(varPtr))) { + && (includeLinks || !TclIsVarLink(varPtr))) { varName = TclGetString(*varNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); + if (!justConstants || TclIsVarConstant(varPtr)) { + Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); + } if (includeLinks) { Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); } } } @@ -6273,12 +6599,14 @@ if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { varPtr = VarHashFindVar(localVarTablePtr, patternPtr); if (varPtr != NULL) { if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { - Tcl_ListObjAppendElement(interp, listPtr, - VarHashGetKey(varPtr)); + if ((!justConstants || TclIsVarConstant(varPtr))) { + Tcl_ListObjAppendElement(interp, listPtr, + VarHashGetKey(varPtr)); + } if (includeLinks) { Tcl_CreateHashEntry(&addedTable, VarHashGetKey(varPtr), &added); } } @@ -6296,11 +6624,13 @@ if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { objNamePtr = VarHashGetKey(varPtr); varName = TclGetString(objNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + if (!justConstants || TclIsVarConstant(varPtr)) { + Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + } if (includeLinks) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); } } } @@ -6310,27 +6640,36 @@ if (!includeLinks) { return; } if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { - Method *mPtr = (Method *) - Tcl_ObjectContextMethod((Tcl_ObjectContext)iPtr->varFramePtr->clientData); + Tcl_ObjectContext context = (Tcl_ObjectContext) + iPtr->varFramePtr->clientData; + Method *mPtr = (Method *) Tcl_ObjectContextMethod(context); PrivateVariableMapping *privatePtr; if (mPtr->declaringObjectPtr) { Object *oPtr = mPtr->declaringObjectPtr; FOREACH(objNamePtr, oPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + if (justConstants && !ContextObjectContainsConstant(context, + objNamePtr)) { + continue; + } if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } } FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, &added); + if (justConstants && !ContextObjectContainsConstant(context, + privatePtr->fullNameObj)) { + continue; + } if (added && (!pattern || Tcl_StringMatch(TclGetString(privatePtr->variableObj), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, privatePtr->variableObj); @@ -6339,18 +6678,26 @@ } else { Class *clsPtr = mPtr->declaringClassPtr; FOREACH(objNamePtr, clsPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + if (justConstants && !ContextObjectContainsConstant(context, + objNamePtr)) { + continue; + } if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } } FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, &added); + if (justConstants && !ContextObjectContainsConstant(context, + privatePtr->fullNameObj)) { + continue; + } if (added && (!pattern || Tcl_StringMatch(TclGetString(privatePtr->variableObj), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, privatePtr->variableObj); @@ -6358,10 +6705,51 @@ } } } Tcl_DeleteHashTable(&addedTable); } + +/* + *---------------------------------------------------------------------- + * + * TclInfoConstantCmd -- + * + * Called to implement the "info constant" command that wests whether a + * specific variable is a constant. Handles the following syntax: + * + * info constant varName + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +int +TclInfoConstantCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Var *varPtr, *arrayPtr; + int result; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName"); + return TCL_ERROR; + } + varPtr = TclObjLookupVar(interp, objv[1], NULL, 0, "lookup", 0, 0, + &arrayPtr); + result = (varPtr && TclIsVarConstant(varPtr)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} /* * Hash table implementation - first, just copy and adapt the obj key stuff */ Index: tests/info.test ================================================================== --- tests/info.test +++ tests/info.test @@ -676,20 +676,20 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { info } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp -} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c -} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l -} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s -} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### ## info frame Index: tests/var.test ================================================================== --- tests/var.test +++ tests/var.test @@ -1478,10 +1478,785 @@ } -body { array default unset ary x } -returnCodes error -cleanup { unset -nocomplain ary } -result * -match glob + +# The const command +test var-25.1 {const: no argument} -body { + apply {{} { + const + return $X + }} +} -returnCodes error -result {wrong # args: should be "const varName value"} +test var-25.2 {const: single argument} -body { + apply {{} { + const X + return $X + }} +} -returnCodes error -result {wrong # args: should be "const varName value"} +test var-25.3 {const: two arguments (basic correct usage)} { + apply {{} { + set res [const X gorp] + return [list $res $X] + }} +} {{} gorp} +test var-25.4 {const: three arguments} -body { + apply {{} { + const X gorp foo + return $X + }} +} -returnCodes error -result {wrong # args: should be "const varName value"} +test var-25.5 {const: four arguments} -body { + apply {{} { + const X gorp foo bar + return $X + }} +} -returnCodes error -result {wrong # args: should be "const varName value"} + +test var-26.1 {const: unmodifiable by set} -body { + apply {{} { + const X 123 + set X gorp + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.2 {const: unmodifiable by append} -body { + apply {{} { + const X 123 + append X gorp + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.3 {const: unmodifiable by lappend} -body { + apply {{} { + const X 123 + lappend X gorp + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.4 {const: unmodifiable by incr} -body { + apply {{} { + const X 123 + incr X + }} +} -returnCodes error -result {can't incr "X": variable is a constant} +test var-26.5 {const: unmodifiable by dict set} -body { + apply {{} { + const X {a 123} + dict set X a gorp + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.6 {const: unmodifiable by regsub} -body { + apply {{} { + const X abcabc + regsub -all {a(.)} $X {\1\1} X + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.7 {const: unmodifiable by gets} -setup { + set file [makeFile foo var26.7.txt] + set f [open $file] +} -body { + apply {f { + const X abcabc + gets $f X + }} $f +} -returnCodes error -cleanup { + close $f + removeFile $file +} -result {can't set "X": variable is a constant} +test var-26.8 {const: may not be array} -body { + apply {{} { + array set X {a b} + const X 1 + return $X + }} +} -returnCodes error -result {can't make constant "X": variable is array} +test var-26.9.1 {const: may not be array element} -body { + apply {{} { + array set X {a b} + const X(a) 1 + return $X(a) + }} +} -returnCodes error -result {can't make constant "X(a)": name refers to an element in an array} +test var-26.9.2 {const: may not be array element} -body { + apply {{} { + array set X {a b} + const X(b) 1 + return $X(b) + }} +} -returnCodes error -result {can't make constant "X(b)": name refers to an element in an array} +test var-26.10.1 {const: unmodifiable by const but not an error} { + apply {{} { + const X 1 + const X 2 + return $X + }} +} 1 +test var-26.10.2 {const: unmodifiable by const but not an error} { + apply {{} { + lmap x {1 2 3} { + const A 2 + const B 3 + const C 5 + expr {$A * $x**2 + $B * $x + $C} + } + }} +} {10 19 32} +test var-26.11 {const: may not be unset} -body { + apply {{} { + const X 1 + unset X + }} +} -returnCodes error -result {can't unset "X": variable is a constant} +test var-26.12 {const: may not be unset, but -nocomplain doesn't complain} { + apply {{} { + const X 1 + unset -nocomplain X + return $X + }} +} 1 +test var-26.13 {const and traces: write trace causes fail} -body { + apply {{} { + trace add variable X write {apply {args { + error "ERR: $args" + }}} + const X gorp + return $X + }} +} -returnCodes error -result {can't set "X": ERR: X {} write} +test var-26.14 {const and traces: write trace err causes no const} -body { + apply {{} { + set trace {apply {args { + error "ERR: $args" + }}} + trace add variable X write $trace + catch { + const X gorp + } + trace remove variable X write $trace + set X 123 + return $X + }} +} -result 123 +test var-26.15 {const and traces: read traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + apply {{} { + trace add variable X read {apply {args { + lappend ::traces $args + }}} + const X gorp + list $X $X $::traces + }} +} -result {gorp gorp {{X {} read} {X {} read}}} -cleanup { + unset -nocomplain traces +} +test var-26.16 {const and traces: write traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + apply {{} { + trace add variable X write {apply {args { + lappend ::traces $args + }}} + const X gorp + const X foo + catch {set X bar} + list $X $::traces + }} +} -result {gorp {{X {} write}}} -cleanup { + unset -nocomplain traces +} +test var-26.17 {const and traces: unset traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + list {*}[apply {{} { + trace add variable X unset {apply {args { + lappend ::traces $args + }}} + const X gorp + unset -nocomplain X + list $X $::traces + }}] $traces +} -result {gorp {} {{X {} unset}}} -cleanup { + unset -nocomplain traces +} + +# Same [const], but definitely not compiled +test var-27.1 {const: unmodifiable by set} -body { + apply {const { + $const X 123 + set X gorp + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.2 {const: unmodifiable by append} -body { + apply {const { + $const X 123 + append X gorp + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.3 {const: unmodifiable by lappend} -body { + apply {const { + $const X 123 + lappend X gorp + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.4 {const: unmodifiable by incr} -body { + apply {const { + $const X 123 + incr X + }} const +} -returnCodes error -result {can't incr "X": variable is a constant} +test var-27.5 {const: unmodifiable by dict set} -body { + apply {const { + $const X {a 123} + dict set X a gorp + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.6 {const: unmodifiable by regsub} -body { + apply {const { + $const X abcabc + regsub -all {a(.)} $X {\1\1} X + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.7 {const: unmodifiable by gets} -setup { + set file [makeFile foo var27.7.txt] + set f [open $file] +} -body { + apply {{const f} { + $const X abcabc + gets $f X + }} const $f +} -returnCodes error -cleanup { + close $f + removeFile $file +} -result {can't set "X": variable is a constant} +test var-27.8 {const: may not be array} -body { + apply {const { + array set X {a b} + $const X 1 + return $X + }} const +} -returnCodes error -result {can't make constant "X": variable is array} +test var-27.9.1 {const: may not be array element} -body { + apply {const { + array set X {a b} + $const X(a) 1 + return $X(a) + }} const +} -returnCodes error -result {can't make constant "X(a)": name refers to an element in an array} +test var-27.9.2 {const: may not be array element} -body { + apply {const { + array set X {a b} + $const X(b) 1 + return $X(b) + }} const +} -returnCodes error -result {can't make constant "X(b)": name refers to an element in an array} +test var-27.10.1 {const: unmodifiable by const but not an error} { + apply {const { + $const X 1 + $const X 2 + return $X + }} const +} 1 +test var-27.10.2 {const: unmodifiable by const but not an error} { + apply {const { + lmap x {1 2 3} { + $const A 2 + $const B 3 + $const C 5 + expr {$A * $x**2 + $B * $x + $C} + } + }} const +} {10 19 32} +test var-27.11 {const: may not be unset} -body { + apply {const { + $const X 1 + unset X + }} const +} -returnCodes error -result {can't unset "X": variable is a constant} +test var-27.12 {const: may not be unset, but -nocomplain doesn't complain} { + apply {const { + $const X 1 + unset -nocomplain X + return $X + }} const +} 1 +test var-27.13 {const and traces: write trace causes fail} -body { + apply {const { + trace add variable X write {apply {args { + error "ERR: $args" + }}} + $const X gorp + return $X + }} const +} -returnCodes error -result {can't set "X": ERR: X {} write} +test var-27.14 {const and traces: write trace err causes no const} -body { + apply {const { + set trace {apply {args { + error "ERR: $args" + }}} + trace add variable X write $trace + catch { + $const X gorp + } + trace remove variable X write $trace + set X 123 + return $X + }} const +} -result 123 +test var-27.15 {const and traces: read traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + apply {const { + trace add variable X read {apply {args { + lappend ::traces $args + }}} + $const X gorp + list $X $X $::traces + }} const +} -result {gorp gorp {{X {} read} {X {} read}}} -cleanup { + unset -nocomplain traces +} +test var-27.16 {const and traces: write traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + apply {const { + trace add variable X write {apply {args { + lappend ::traces $args + }}} + $const X gorp + $const X foo + catch {set X bar} + list $X $::traces + }} const +} -result {gorp {{X {} write}}} -cleanup { + unset -nocomplain traces +} +test var-27.17 {const and traces: unset traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + list {*}[apply {const { + trace add variable X unset {apply {args { + lappend ::traces $args + }}} + $const X gorp + unset -nocomplain X + list $X $::traces + }} const] $traces +} -result {gorp {} {{X {} unset}}} -cleanup { + unset -nocomplain traces +} + +test var-28.1 {const: in a namespace} -setup { + namespace eval var28 {} +} -body { + namespace eval var28 { + variable X + const X gorp + return $X + } +} -cleanup { + namespace delete var28 +} -result gorp +test var-28.2 {const: in a namespace} -setup { + namespace eval var28 {} +} -body { + namespace eval var28 { + variable X + const X gorp + } + apply {{} { + variable X + set X 123 + } var28} +} -cleanup { + namespace delete var28 +} -returnCodes error -result {can't set "X": variable is a constant} +test var-28.3 {const: in a namespace} -setup { + namespace eval var28 {} +} -body { + namespace eval var28 { + variable X + const X gorp + } + apply {{} { + variable X + unset X + } var28} +} -cleanup { + namespace delete var28 +} -returnCodes error -result {can't unset "X": variable is a constant} +test var-28.4 {const: in a namespace} -setup { + namespace eval var28 {} +} -body { + namespace eval var28 { + variable X + const X gorp + } + namespace delete var28 + namespace eval var28 { + variable X abc + } + apply {{} { + variable X + return $X + } var28} +} -cleanup { + namespace delete var28 +} -result abc +test var-28.5 {const: in a namespace, direct access from proc} -setup { + namespace eval var28 {} +} -body { + set result [apply {{} { + const ::var28::X abc + # Constant in namespace, NOT locally! + info exists X + }}] + apply {res { + variable X + list $res [catch {unset X} msg] $msg $X + } var28} $result +} -cleanup { + namespace delete var28 +} -result {0 1 {can't unset "X": variable is a constant} abc} + +test var-29.1 {const: globally} -setup { + set int [interp create] +} -body { + $int eval { + const X gorp + apply {{} { + global X + return $X + }} + } +} -cleanup { + interp delete $int +} -result gorp +test var-29.2 {const: TclOO variable resolution} -setup { + oo::class create Parent +} -body { + oo::class create C { + superclass Parent + variable X + constructor {} { + const X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + set c [C new] + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Parent destroy +} -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} +test var-29.3 {const: TclOO variable resolution} -setup { + oo::class create Parent +} -body { + oo::class create C { + superclass Parent + private variable X + constructor {} { + const X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + set c [C new] + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Parent destroy +} -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} +test var-29.4 {const: TclOO variable resolution} -setup { + oo::class create Parent +} -body { + oo::class create C { + superclass Parent + variable X + constructor {} { + set X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + set X gorp + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + set c [C new] + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Parent destroy +} -result {123 {0 abc} {0 gorp} 0 {}} +test var-29.5 {const: TclOO variable resolution} -setup { + set c [oo::object create Instance] +} -body { + oo::objdefine $c { + variable X + method init {} { + const X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + $c init + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Instance destroy +} -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} +test var-29.6 {const: TclOO variable resolution} -setup { + set c [oo::object create Instance] +} -body { + oo::objdefine $c { + private variable X + method init {} { + const X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + $c init + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Instance destroy +} -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} +test var-29.7 {const: TclOO variable resolution} -setup { + set c [oo::object create Instance] +} -body { + oo::objdefine $c { + variable X + method init {} { + set X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + set X gorp + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + $c init + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Instance destroy +} -result {123 {0 abc} {0 gorp} 0 {}} + +# The info constant and info consts commands +test var-30.1 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts]] [info constant X] + const X 1 + lappend consts [lsort [info consts]] [info constant X] + const Y 2 + lappend consts [lsort [info consts]] + const X 3 + lappend consts [lsort [info consts]] + }} +} {{} 0 X 1 {X Y} {X Y}} +test var-30.2 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts X]] + const X 1 + lappend consts [lsort [info consts X]] + const Y 2 + lappend consts [lsort [info consts X]] + const X 3 + lappend consts [lsort [info consts X]] + }} +} {{} X X X} +test var-30.3 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts ?]] + const X 1 + lappend consts [lsort [info consts ?]] + const Y 2 + lappend consts [lsort [info consts ?]] + const XX 3 + lappend consts [lsort [info consts ?]] + }} +} {{} X {X Y} {X Y}} +test var-30.4 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts X]] + set X 1 + lappend consts [lsort [info consts X]] + set Y 2 + lappend consts [lsort [info consts X]] + set X 3 + lappend consts [lsort [info consts X]] + }} +} {{} {} {} {}} +test var-30.5 {info consts: in a namespace} -setup { + namespace eval var30 {} +} -body { + namespace eval var30 { + const X gorp + info consts + } +} -cleanup { + namespace delete var30 +} -result X +test var-30.6 {info consts: in a namespace} -setup { + namespace eval var30 {} +} -body { + namespace eval var30 { + const X gorp + variable Y foo + } + info consts var30::* +} -cleanup { + namespace delete var30 +} -result ::var30::X +test var-30.7 {info constant: bad constant names: array element} { + apply {{} { + info constant a(b) + }} +} 0 +test var-30.8 {info constant: bad constant names: array} { + apply {{} { + array set a {} + info constant a + }} +} 0 +test var-30.9 {info constant: bad constant names: no var} { + apply {{} { + info constant a + }} +} 0 +test var-30.10 {info constant: bad constant names: no namespace} { + apply {{} { + info constant ::var29::no::such::ns::a + }} +} 0 +test var-30.11 {info constant: bad constant names: dangling upvar} { + apply {{} { + upvar 0 no_var a + info constant a + }} +} 0 +test var-30.12 {info constant: bad constant names: bad name} { + apply {{} { + info constant a(b + }} +} 0 +test var-30.13 {info constant: bad constant names: nesting} { + apply {{} { + array set b {c d} + upvar 0 b(c) a + info constant a(d) + }} +} 0 + +test var-31.1 {info constant: syntax} -returnCodes error -body { + info constant +} -result {wrong # args: should be "info constant varName"} +test var-31.2 {info constant: syntax} -returnCodes error -body { + info constant foo bar +} -result {wrong # args: should be "info constant varName"} +test var-31.3 {info consts: syntax} -returnCodes error -body { + info consts foo bar +} -result {wrong # args: should be "info consts ?pattern?"} catch {namespace delete ns} catch {unset arr} catch {unset v}