Tcl Source Code

Changes On Branch tip-480
Login
Bounty program for improvements to Tcl and certain Tcl packages.

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

Changes In Branch tip-480 Excluding Merge-Ins

This is equivalent to a diff from 7bcb41aa5e to 5672730e2e

2019-05-28
21:42
Merge 8.6 check-in: f70e8b4830 user: jan.nijtmans tags: core-8-branch
2019-05-26
12:11
Import of old TIP 284 patch, and update for current Tcl check-in: 1832e6f878 user: dkf tags: tip-284
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
2019-05-25
08:17
Merge 8.7 check-in: dd82009b2c user: dkf tags: trunk
08:06
TIP 383: [coroinject] and [coroprobe] check-in: 7bcb41aa5e user: dkf tags: core-8-branch
08:01
Add to error info when passing an error out of [coroprobe] Closed-Leaf check-in: de44589e23 user: dkf tags: tip-383
07:46
Implement TIP 431: [file tempdir] check-in: 974c5d161d user: dkf tags: core-8-branch

Added doc/pragma.n.


















































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
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
115
116
117
118
119
120
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:

Changes to generic/tclBasic.c.

937
938
939
940
941
942
943

944
945
946
947
948
949
950
    TclInitChanCmd(interp);
    TclInitDictCmd(interp);
    TclInitEncodingCmd(interp);
    TclInitFileCmd(interp);
    TclInitInfoCmd(interp);
    TclInitNamespaceCmd(interp);
    TclInitStringCmd(interp);

    TclInitPrefixCmd(interp);
    TclInitProcessCmd(interp);

    /*
     * Register "clock" subcommands. These *do* go through
     * Tcl_CreateObjCommand, since they aren't in the global namespace and
     * involve ensembles.






>







937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
    TclInitChanCmd(interp);
    TclInitDictCmd(interp);
    TclInitEncodingCmd(interp);
    TclInitFileCmd(interp);
    TclInitInfoCmd(interp);
    TclInitNamespaceCmd(interp);
    TclInitStringCmd(interp);
    TclInitPragmaCmd(interp);
    TclInitPrefixCmd(interp);
    TclInitProcessCmd(interp);

    /*
     * Register "clock" subcommands. These *do* go through
     * Tcl_CreateObjCommand, since they aren't in the global namespace and
     * involve ensembles.

Changes to generic/tclCmdMZ.c.

5369
5370
5371
5372
5373
5374
5375
5376
5377













































































































































5378
5379
5380
5381
5382
5383
	if (*element == 0) {
	    /* ASSERT i == n */
	    break;
	}
    }
}
 
/*













































































































































 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */








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






5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
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
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
	if (*element == 0) {
	    /* 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 ; 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 DICT_TYPE:
	    if (Tcl_DictObjSize(interp, valuePtr, &len) != TCL_OK) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"expected dict value but got \"%s\"",
			Tcl_GetString(valuePtr)));
		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;
	    }
	    break;
	}
    }
    return TCL_OK;
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclInt.h.

3503
3504
3505
3506
3507
3508
3509



3510
3511
3512
3513
3514
3515
3516
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_PackageObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_PidObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);



MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp);
MODULE_SCOPE int	Tcl_PutsObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_PwdObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);






>
>
>







3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_PackageObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_PidObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_Command TclInitPragmaCmd(Tcl_Interp *interp);
MODULE_SCOPE Tcl_ObjCmdProc TclPragmaNoAliasCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclPragmaTypeCmd;
MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp);
MODULE_SCOPE int	Tcl_PutsObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_PwdObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);

Changes to generic/tclVar.c.

6880
6881
6882
6883
6884
6885
6886
6887
6888












































































































6889
6890
6891
6892
6893
6894
    }
    tablePtr->defaultObj = defaultObj;
    if (tablePtr->defaultObj) {
        Tcl_IncrRefCount(tablePtr->defaultObj);
        Tcl_IncrRefCount(tablePtr->defaultObj);
    }
}
 
/*












































































































 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */








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






6880
6881
6882
6883
6884
6885
6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899
6900
6901
6902
6903
6904
6905
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
    }
    tablePtr->defaultObj = defaultObj;
    if (tablePtr->defaultObj) {
        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 ; 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.

444
445
446
447
448
449
450


















































































































































































451
452
453
454
455
456
457
458
459
460
461
	    lindex 5
	} on ok res {}
	set res
    }}
} -result 5




















































































































































































# The tests for Tcl_WhileObjCmd are in while.test
 
# cleanup
cleanupTests
}
namespace delete ::tcl::test::cmdMZ
return

# Local Variables:
# mode: tcl
# End:






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











444
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
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
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
633
634
635
636
637
638
639
	    lindex 5
	} 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 {
    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
}
namespace delete ::tcl::test::cmdMZ
return

# Local Variables:
# mode: tcl
# End: