Tcl Source Code

Check-in [5672730e2e]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Fix a few critical errors and allow int32 as a type
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | tip-480
Files: files | file ages | folders
SHA3-256: 5672730e2ed9769068785cfa8faa92c1ff21486f413553fba42af81fe0262c90
User & Date: dkf 2019-05-26 10:47:58
Context
2019-05-26
10:47
Fix a few critical errors and allow int32 as a type Leaf check-in: 5672730e2e user: dkf tags: tip-480
07:19
merge 8.7 check-in: 494534d018 user: dkf tags: tip-480
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to doc/pragma.n.

21
22
23
24
25
26
27
28
29
30

31
32
33
34
35
36
37
38





39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58




59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
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,
etc., and checks to see if they alias each other. Each variable set is a list
of variable names, and two variable names in a variable set alias if they
resolve to the same variable storage (i.e., after allowing for any variable

resolution rules, any use of \fBglobal\fR or \fBupvar\fR, any
namespace-qualification, etc.) If any variable names in a variable set
indicate the same storage space, this command will produce an error. Only
existing variables can be checked this way.
.RS
.PP
This command takes multiple variable sets. Each variable set is checked
independently.





.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
\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"






|
<
|
>
|
|
|
|


|
|
>
>
>
>
>











|



|



|
>
>
>
>



|










|




|
|













|




|







21
22
23
24
25
26
27
28

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
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"

Changes to generic/tclCmdMZ.c.

5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
....
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
....
5478
5479
5480
5481
5482
5483
5484
5485





5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
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, INT_TYPE, INTEGER_TYPE, LIST_TYPE,
	NUMBER_TYPE
    };
    static const char *types[] = {
	"boolean", "dict", "double", "int64", "integer", "list", "number",
	NULL
    };
    int idx, i;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "typeName ?value...?");
	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;
	Tcl_WideInt ival;
	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 INT_TYPE:





	    if (Tcl_GetWideIntFromObj(interp, valuePtr, &ival) != 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, &ival) != TCL_OK) {
		return TCL_ERROR;
	    }
	    break;
	case NUMBER_TYPE:
	    if (TclGetNumberFromObj(interp, valuePtr, &cdval, &bval) != TCL_OK) {
		return TCL_ERROR;
	    }






|
|


|
|







 







|
|







 







|
>
>
>
>
>
|












|







5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
....
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
....
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
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;
    }
................................................................................
    /*
     * 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;
	    }

Changes to generic/tclVar.c.

6906
6907
6908
6909
6910
6911
6912




6913
6914
6915
6916

6917



6918
6919
6920
6921
6922
6923
6924
6925
6926
6927
6928
6929
6930
6931
6932
6933
6934
6935



6936
6937
6938
6939
6940


6941

6942
6943







6944
6945


6946
6947
6948




6949
6950
6951
6952

6953
6954
6955

6956







6957


6958
6959
6960
6961
6962
6963
6964
6965
6966
6967
6968
6969
6970
int
TclPragmaNoAliasCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{




    int i, j, varc, isNew;
    Var *key, *ignored;
    Tcl_HashTable table;
    Tcl_HashEntry *hPtr;

    Tcl_Obj **varv;




    /*
     * For each set of variables...
     */

    for (i=1 ; i<objc ; i++) {
	if (Tcl_ListObjGetElements(interp, objv[i], &varc, &varv) != TCL_OK) {
	    return TCL_ERROR;
	}

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

	Tcl_InitHashTable(&table, TCL_ONE_WORD_KEYS);
	for (j=0 ; j<varc ; j++) {



	    key = TclObjLookupVarEx(interp, varv[j], NULL, TCL_LEAVE_ERR_MSG,
		    "resolve", 0, 0, &ignored);
	    if (key == NULL) {
		Tcl_DeleteHashTable(&table);
		return TCL_ERROR;


	    }

	    hPtr = Tcl_CreateHashEntry(&table, key, &isNew);
	    if (!isNew) {







		/*
		 * There was a duplicate value! Generate an error message.


		 */

		Tcl_Obj *otherName = Tcl_GetHashValue(hPtr);





		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"\"%s\" aliases to the same variable as \"%s\"",
			Tcl_GetString(varv[j]), Tcl_GetString(otherName)));

		Tcl_SetErrorCode(interp, "TCL", "VAR_ALIAS", NULL);
		Tcl_DeleteHashTable(&table);
		return TCL_ERROR;

	    }







	    Tcl_SetHashValue(hPtr, varv[j]);


	}
	Tcl_DeleteHashTable(&table);
    }
    return TCL_OK;
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */






>
>
>
>
|



>

>
>
>







|








<

>
>
>
|


<
<
>
>

>

|
>
>
>
>
>
>
>
|
<
>
>
|

|
>
>
>
>



|
>

<
|
>

>
>
>
>
>
>
>
|
>
>
|
|
<
|









6906
6907
6908
6909
6910
6911
6912
6913
6914
6915
6916
6917
6918
6919
6920
6921
6922
6923
6924
6925
6926
6927
6928
6929
6930
6931
6932
6933
6934
6935
6936
6937
6938
6939
6940
6941

6942
6943
6944
6945
6946
6947
6948


6949
6950
6951
6952
6953
6954
6955
6956
6957
6958
6959
6960
6961
6962

6963
6964
6965
6966
6967
6968
6969
6970
6971
6972
6973
6974
6975
6976
6977

6978
6979
6980
6981
6982
6983
6984
6985
6986
6987
6988
6989
6990
6991
6992

6993
6994
6995
6996
6997
6998
6999
7000
7001
7002
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
 * End:
 */

Changes to tests/cmdMZ.test.

445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476



477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508








509




















510
511
512
513
514
515
516
517
518
519
520
521
522
...
540
541
542
543
544
545
546
547
548
549












550
551
552
553

554
555
556
557
558
559
560
561
562

563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
	} on ok res {}
	set res
    }}
} -result 5


# Pragmas
test cmdMZ-6.1 {tcl::pragma: basics} -body {
    tcl::pragma
} -returnCodes error -result {wrong # args: should be "tcl::pragma subcommand ?arg ...?"}
test cmdMZ-6.2 {tcl::pragma: basics} -body {
    tcl::pragma ?
} -returnCodes error -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 ::env
} -result {}
test cmdMZ-7.5 {tcl::pragma noalias} -body {
    tcl::pragma noalias ::env ::env ::env
} -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.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 [list {*}[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-8.1 {tcl::pragma type} -body {
    tcl::pragma type
} -returnCodes error -result {wrong # args: should be "tcl::pragma type typeName ?value...?"}
test cmdMZ-8.2 {tcl::pragma type} -body {
    tcl::pragma type ?
} -returnCodes error -result {bad type "?": must be boolean, dict, double, 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 int64 gorp
} -returnCodes error -result {expected integer but got "gorp"}
test cmdMZ-8.14 {tcl::pragma type} -body {












    tcl::pragma type int64 123 0x123 gorp
} -returnCodes error -result {expected integer but got "gorp"}
test cmdMZ-8.15 {tcl::pragma type} -body {
    tcl::pragma type int64 123 0b10101 0d123 0o123 0x123 { 456 }

} -result {}
test cmdMZ-8.16 {tcl::pragma type} -body {
    tcl::pragma type integer gorp
} -returnCodes error -result {expected integer but got "gorp"}
test cmdMZ-8.17 {tcl::pragma type} -body {
    tcl::pragma type integer 123 0x123 gorp
} -returnCodes error -result {expected integer but got "gorp"}
test cmdMZ-8.18 {tcl::pragma type} -body {
    tcl::pragma type integer 123 0b10101 0d123 0o123 0x123 { 456 } \

	123456789012345678901234567890123456789012345678901234567890
} -result {}
test cmdMZ-8.19 {tcl::pragma type} -body {
    tcl::pragma type list \{gorp
} -returnCodes error -result "expected list value but got \"\{gorp\""
test cmdMZ-8.20 {tcl::pragma type} -body {
    tcl::pragma type list true false \{gorp
} -returnCodes error -result "expected list value but got \"\{gorp\""
test cmdMZ-8.21 {tcl::pragma type} -body {
    tcl::pragma type list yes no 0 1 1.5 true false on off
} -result {}
test cmdMZ-8.22 {tcl::pragma type} -body {
    tcl::pragma type number gorp
} -returnCodes error -result {expected number but got "gorp"}
test cmdMZ-8.23 {tcl::pragma type} -body {
    tcl::pragma type number .5 nan gorp
} -returnCodes error -result {expected number but got "gorp"}
test cmdMZ-8.24 {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






|

|
|

|











|


|


|

>
>
>










|





|












|


>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

|
|

|







 







|


>
>
>
>
>
>
>
>
>
>
>
>


|
|
>

|


|


|

>


|


|


|


|


|


|







445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
...
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
	} 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