ADDED doc/pragma.n Index: doc/pragma.n ================================================================== --- /dev/null +++ doc/pragma.n @@ -0,0 +1,121 @@ +'\" +'\" Copyright (c) 2018 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 pragma n 8.7 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tcl::pragma \- directives to assist efficient execution +.SH SYNOPSIS +.nf +\fBtcl::pragma noalias\fR ?\fIvariableSet ...\fR? +\fBtcl::pragma type \fItypeName\fR ?\fIvalue ...\fR? +.fi +.SH DESCRIPTION +The \fBtcl::pragma\fR command provides directives that can aid efficient +execution and compilation strategies for Tcl scripts, while also providing +meaningful execution models for those directives. It produces no output on +successful execution, and an error if a problem is detected. It supports two +subcommands: +.TP +\fBtcl::pragma noalias\fR ?\fIvariableSet ...\fR? +. +This subcommand takes an arbitrary number of variable sets, \fIvariableSet\fR, +(lists of variable names), and checks to see if they alias each other. +Variable names within a variable set may resolve to the same variable (after +following links such as those created by \fBupvar\fR and \fBglobal\fR, and +allowing for any current namespace qualification, TclOO variable resolution, +etc.), but it is an error if a variable mentioned in one variable set resolves +to the same variable as a variable mentioned in another set. Only existing +variables can be checked this way. +.RS +.PP +When the local variables in a procedure all have simple names (this is the +overwhelmingly common case), they can be asserted to all not alias each other +with: +.PP +.CS +\fBtcl::pragma noalias\fR {*}[info locals] +.CE +.RE +.TP +\fBtcl::pragma type \fItypeName\fR ?\fIvalue ...\fR? +. +This subcommand takes a value type, \fItypeName\fR, and throws an error if any +of the arbitrary number of \fIvalue\fRs are not of that type. Supported +\fItypeName\fRs are: +.RS +.TP +\fBboolean\fR +. +This indicates the type of values accepted by \fBTcl_GetBooleanFromObj\fR(). +.TP +\fBdict\fR +. +This indicates the type of values accepted by \fBTcl_DictObjSize\fR(). +.TP +\fBdouble\fR +. +This indicates the type of values accepted by \fBTcl_GetDoubleFromObj\fR(). +.TP +\fBint32\fR +. +This indicates the type of values accepted by \fBTcl_GetIntFromObj\fR(). +.TP +\fBint64\fR +. +This indicates the type of values accepted by \fBTcl_GetWideIntFromObj\fR(). +.TP +\fBinteger\fR +. +This indicates the type of any value accepted as an integer, without length +restriction. This is the type of values accepted by integer-accepting +\fBexpr\fR operators, such as the \fB&\fR operator or the left side of the +\fB<<\fR operator. +.TP +\fBlist\fR +. +This indicates the type of values accepted by \fBTcl_ListObjLength\fR(). +.TP +\fBnumber\fR +. +This indicates the type of any value accepted as a number, without length +restriction. This is the type of values accepted by \fBexpr\fR operators +such as \fB+\fR or \fB*\fR. +.RE +.SH EXAMPLES +.PP +This shows how a procedure could declare that it only operates on integers: +.PP +.CS +proc addThreeIntegers {a b c} { + \fBtcl::pragma type\fR integer $a $b $c + return [expr {$a + $b + $c}] +} +.CE +.PP +This shows how a procedure could declare that two variables passed in by +name/\fBupvar\fR must be distinct from each other: +.PP +.CS +proc swap {v1Name v2Name} { + upvar 1 $v1Name v1 $v2Name v2 + \fBtcl::pragma noalias\fR v1 v2 + set tmp $v2 + set v2 $v1 + set v1 $tmp + return +} +.CE +.SH "SEE ALSO" +dict(n), global(n), list(n), string(n), upvar(n) +.SH KEYWORDS +compilation, variables, types +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -939,10 +939,11 @@ TclInitEncodingCmd(interp); TclInitFileCmd(interp); TclInitInfoCmd(interp); TclInitNamespaceCmd(interp); TclInitStringCmd(interp); + TclInitPragmaCmd(interp); TclInitPrefixCmd(interp); TclInitProcessCmd(interp); /* * Register "clock" subcommands. These *do* go through Index: generic/tclCmdMZ.c ================================================================== --- generic/tclCmdMZ.c +++ generic/tclCmdMZ.c @@ -5371,10 +5371,151 @@ /* ASSERT i == n */ break; } } } + +/* + *---------------------------------------------------------------------- + * + * TclInitPragmaCmd -- + * + * This function creates the 'tcl::pragma' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclInitPragmaCmd( + Tcl_Interp *interp) +{ + static const EnsembleImplMap pragmaImplMap[] = { + {"noalias", TclPragmaNoAliasCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"type", TclPragmaTypeCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + Tcl_Command prefixCmd; + + prefixCmd = TclMakeEnsemble(interp, "::tcl::pragma", pragmaImplMap); + Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), + "prefix", 0); + return prefixCmd; +} + +/* + *---------------------------------------------------------------------- + * + * TclPragmaTypeCmd -- + * + * This function implements the 'tcl::pragma type' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclPragmaTypeCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + enum PragmaTypes { + BOOL_TYPE, DICT_TYPE, DOUBLE_TYPE, INT32_TYPE, INT64_TYPE, + INTEGER_TYPE, LIST_TYPE, NUMBER_TYPE + }; + static const char *types[] = { + "boolean", "dict", "double", "int32", "int64", "integer", "list", + "number", NULL + }; + int idx, i; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "typeName ?value...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, + &idx) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Check that the type constraint actually holds for all remaining values. + */ + + for (i=2 ; idefaultObj) { Tcl_IncrRefCount(tablePtr->defaultObj); Tcl_IncrRefCount(tablePtr->defaultObj); } } + +/* + *---------------------------------------------------------------------- + * + * TclPragmaNoAliasCmd -- + * + * This function implements the 'tcl::pragma noalias' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclPragmaNoAliasCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + typedef struct { + int setIndex; + Tcl_Obj *variableName; + } AliasData; + int i, j, varc, isNew, result = TCL_ERROR; + Var *key, *ignored; + Tcl_HashTable table; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Obj **varv; + AliasData *aliasData; + + Tcl_InitHashTable(&table, TCL_ONE_WORD_KEYS); + + /* + * For each set of variables... + */ + + for (i=1 ; isetIndex = i; + aliasData->variableName = varName; + Tcl_SetHashValue(hPtr, aliasData); + continue; + } + + /* + * Two variables alias, but that's OK if they're in the same + * variable set. + */ + + aliasData = Tcl_GetHashValue(hPtr); + if (aliasData->setIndex != i) { + /* + * There was a real duplicate! Generate an error message. + */ + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" aliases to the same variable as \"%s\"", + Tcl_GetString(varName), + Tcl_GetString(aliasData->variableName))); + Tcl_SetErrorCode(interp, "TCL", "VAR_ALIAS", NULL); + TclDecrRefCount(varName); + goto error; + } + TclDecrRefCount(varName); + } + } + result = TCL_OK; + error: + for (hPtr = Tcl_FirstHashEntry(&table, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + aliasData = Tcl_GetHashValue(hPtr); + TclDecrRefCount(aliasData->variableName); + ckfree(Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(&table); + return result; +} /* * Local Variables: * mode: c * c-basic-offset: 4 Index: tests/cmdMZ.test ================================================================== --- tests/cmdMZ.test +++ tests/cmdMZ.test @@ -446,10 +446,188 @@ set res }} } -result 5 +# Pragmas +test cmdMZ-6.1 {tcl::pragma: basics} -returnCodes error -body { + tcl::pragma +} -result {wrong # args: should be "tcl::pragma subcommand ?arg ...?"} +test cmdMZ-6.2 {tcl::pragma: basics} -returnCodes error -body { + tcl::pragma ? +} -result {unknown or ambiguous subcommand "?": must be noalias, or type} + +test cmdMZ-7.1 {tcl::pragma noalias} -body { + tcl::pragma noalias +} -result {} +test cmdMZ-7.2 {tcl::pragma noalias} -body { + tcl::pragma noalias no_such_var +} -returnCodes error -result {can't resolve "no_such_var": no such variable} +test cmdMZ-7.3 {tcl::pragma noalias} -body { + tcl::pragma noalias ::env +} -result {} +test cmdMZ-7.4 {tcl::pragma noalias} -body { + tcl::pragma noalias ::env ::tcl_platform +} -result {} +test cmdMZ-7.5 {tcl::pragma noalias} -body { + tcl::pragma noalias ::env ::tcl_platform ::auto_path +} -result {} +test cmdMZ-7.6 {tcl::pragma noalias} -body { + tcl::pragma noalias ::env ::env +} -returnCodes error -result {"::env" aliases to the same variable as "::env"} +test cmdMZ-7.6 {tcl::pragma noalias} -body { + tcl::pragma noalias {::env ::env} +} -result {} +test cmdMZ-7.7 {tcl::pragma noalias} -body { + tcl::pragma noalias {::env ::tcl_platform} +} -result {} +test cmdMZ-7.8 {tcl::pragma noalias} -body { + apply {{x y} { + tcl::pragma noalias env + }} 1 2 +} -returnCodes error -result {can't resolve "env": no such variable} +test cmdMZ-7.9 {tcl::pragma noalias} -body { + apply {{x y} { + tcl::pragma noalias {*}[info locals] + }} 1 2 +} -result {} +test cmdMZ-7.10 {tcl::pragma noalias} -body { + apply {{x y} { + global env + tcl::pragma noalias {*}[info locals] env + }} 1 2 +} -result {} +test cmdMZ-7.11 {tcl::pragma noalias} -body { + apply {{x y} { + global env + upvar ::env(PATH) path + tcl::pragma noalias [list {*}[info locals] env path] + }} 1 2 +} -result {} +test cmdMZ-7.12 {tcl::pragma noalias} -body { + apply {{x y} { + upvar 0 x z + tcl::pragma noalias x y z + }} 1 2 +} -returnCodes error -result {"z" aliases to the same variable as "x"} +test cmdMZ-7.13 {tcl::pragma noalias} -setup { + variable a 3 b 4 +} -body { + proc swap {&x &y} { + upvar 1 ${&x} x ${&y} y + tcl::pragma noalias x y + set y $x[set x $y;string cat] + return + } + swap a b + list $a $b +} -cleanup { + unset -nocomplain a b +} -result {4 3} +test cmdMZ-7.14 {tcl::pragma noalias} -setup { + variable a 3 +} -body { + proc swap {&x &y} { + upvar 1 ${&x} x ${&y} y + tcl::pragma noalias x y + set y $x[set x $y;string cat] + return + } + swap a a +} -returnCodes error -cleanup { + unset -nocomplain a +} -result {"y" aliases to the same variable as "x"} +rename swap {} + +test cmdMZ-8.1 {tcl::pragma type} -returnCodes error -body { + tcl::pragma type +} -result {wrong # args: should be "tcl::pragma type typeName ?value...?"} +test cmdMZ-8.2 {tcl::pragma type} -returnCodes error -body { + tcl::pragma type ? +} -result {bad type "?": must be boolean, dict, double, int32, int64, integer, list, or number} +test cmdMZ-8.3 {tcl::pragma type} -body { + tcl::pragma type boolean +} -result {} +test cmdMZ-8.4 {tcl::pragma type} -body { + tcl::pragma type boolean gorp +} -returnCodes error -result {expected boolean value but got "gorp"} +test cmdMZ-8.5 {tcl::pragma type} -body { + tcl::pragma type boolean true false gorp +} -returnCodes error -result {expected boolean value but got "gorp"} +test cmdMZ-8.6 {tcl::pragma type} -body { + tcl::pragma type boolean yes no 0 1 1.5 true false on off +} -result {} +test cmdMZ-8.7 {tcl::pragma type} -body { + tcl::pragma type dict gorp +} -returnCodes error -result {expected dict value but got "gorp"} +test cmdMZ-8.8 {tcl::pragma type} -body { + tcl::pragma type dict {true false} {gorp foo bar} +} -returnCodes error -result {expected dict value but got "gorp foo bar"} +test cmdMZ-8.9 {tcl::pragma type} -body { + tcl::pragma type dict {} {yes no 0 1 1.5 true} {false on off {}} +} -result {} +test cmdMZ-8.10 {tcl::pragma type} -body { + tcl::pragma type double gorp +} -returnCodes error -result {expected floating-point number but got "gorp"} +test cmdMZ-8.11 {tcl::pragma type} -body { + tcl::pragma type double 0.1 -inf gorp +} -returnCodes error -result {expected floating-point number but got "gorp"} +test cmdMZ-8.12 {tcl::pragma type} -body { + tcl::pragma type double 0 1 0x1 123 1e2 -.0 inf { +inf } +} -result {} +test cmdMZ-8.13 {tcl::pragma type} -body { + tcl::pragma type int32 gorp +} -returnCodes error -result {expected integer but got "gorp"} +test cmdMZ-8.14 {tcl::pragma type} -body { + tcl::pragma type int32 123 0x123 gorp +} -returnCodes error -result {expected integer but got "gorp"} +test cmdMZ-8.15 {tcl::pragma type} -returnCodes error -body { + tcl::pragma type int32 123 0x123 123456123456123 +} -result {integer value too large to represent as non-long integer} +test cmdMZ-8.16 {tcl::pragma type} -body { + tcl::pragma type int32 123 0b10101 0d123 0o123 0x123 { 456 } +} -result {} +test cmdMZ-8.17 {tcl::pragma type} -body { + tcl::pragma type int64 gorp +} -returnCodes error -result {expected integer but got "gorp"} +test cmdMZ-8.18 {tcl::pragma type} -body { + tcl::pragma type int64 123 0x123 gorp +} -returnCodes error -result {expected integer but got "gorp"} +test cmdMZ-8.19 {tcl::pragma type} -body { + tcl::pragma type int64 123 0b10101 0d123 0o123 0x123 { 456 } \ + 123456123456123 +} -result {} +test cmdMZ-8.20 {tcl::pragma type} -body { + tcl::pragma type integer gorp +} -returnCodes error -result {expected integer but got "gorp"} +test cmdMZ-8.21 {tcl::pragma type} -body { + tcl::pragma type integer 123 0x123 gorp +} -returnCodes error -result {expected integer but got "gorp"} +test cmdMZ-8.22 {tcl::pragma type} -body { + tcl::pragma type integer 123 0b10101 0d123 0o123 0x123 { 456 } \ + 123456123456123 \ + 123456789012345678901234567890123456789012345678901234567890 +} -result {} +test cmdMZ-8.23 {tcl::pragma type} -body { + tcl::pragma type list \{gorp +} -returnCodes error -result "expected list value but got \"\{gorp\"" +test cmdMZ-8.24 {tcl::pragma type} -body { + tcl::pragma type list true false \{gorp +} -returnCodes error -result "expected list value but got \"\{gorp\"" +test cmdMZ-8.25 {tcl::pragma type} -body { + tcl::pragma type list yes no 0 1 1.5 true false on off +} -result {} +test cmdMZ-8.26 {tcl::pragma type} -body { + tcl::pragma type number gorp +} -returnCodes error -result {expected number but got "gorp"} +test cmdMZ-8.27 {tcl::pragma type} -body { + tcl::pragma type number .5 nan gorp +} -returnCodes error -result {expected number but got "gorp"} +test cmdMZ-8.28 {tcl::pragma type} -body { + tcl::pragma type number 0 1 1.5 inf -25.375e8 +} -result {} + # The tests for Tcl_WhileObjCmd are in while.test # cleanup cleanupTests }