Tcl Source Code

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"

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 ; i<objc ; i++) {
	Tcl_Obj *valuePtr = objv[i];
	double dval;
	int bval, len, i32val;
	Tcl_WideInt i64val;
	ClientData cdval;

	switch ((enum PragmaTypes) idx) {
	case BOOL_TYPE:
	    if (Tcl_GetBooleanFromObj(interp, valuePtr, &bval) != TCL_OK) {
		return TCL_ERROR;
	    }

	    }
	    break;
	case DOUBLE_TYPE:
	    if (Tcl_GetDoubleFromObj(interp, valuePtr, &dval) != TCL_OK) {
		return TCL_ERROR;
	    }
	    break;
	case INT32_TYPE:
	    if (Tcl_GetIntFromObj(interp, valuePtr, &i32val) != TCL_OK) {
		return TCL_ERROR;
	    }
	    break;
	case INT64_TYPE:
	    if (Tcl_GetWideIntFromObj(interp, valuePtr, &i64val) != TCL_OK) {
		return TCL_ERROR;
	    }
	    break;
	case LIST_TYPE:
	    if (Tcl_ListObjLength(interp, valuePtr, &len) != TCL_OK) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"expected list value but got \"%s\"",
			Tcl_GetString(valuePtr)));
		return TCL_ERROR;
	    }
	    break;
	case INTEGER_TYPE:
	    if (TclGetWideBitsFromObj(interp, valuePtr, &i64val) != TCL_OK) {
		return TCL_ERROR;
	    }
	    break;
	case NUMBER_TYPE:
	    if (TclGetNumberFromObj(interp, valuePtr, &cdval, &bval) != TCL_OK) {
		return TCL_ERROR;
	    }

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 ; i<objc ; i++) {
	if (Tcl_ListObjGetElements(interp, objv[i], &varc, &varv) != TCL_OK) {
	    goto error;
	}

	/*
	 * ... build a map from real variable location (because
	 * TclObjLookupVarEx will follow links for us) to the name that led us
	 * there.
	 */


	for (j=0 ; j<varc ; j++) {
	    Tcl_Obj *varName = varv[j];

	    Tcl_IncrRefCount(varName);
	    key = TclObjLookupVarEx(interp, varName, NULL, TCL_LEAVE_ERR_MSG,
		    "resolve", 0, 0, &ignored);
	    if (key == NULL) {
		TclDecrRefCount(varName);

		goto error;
	    }

	    hPtr = Tcl_CreateHashEntry(&table, key, &isNew);
	    if (isNew) {
		aliasData = ckalloc(sizeof(AliasData));
		aliasData->setIndex = 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
 * fill-column: 78

	} on ok res {}
	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 {

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