Tcl Source Code

Check-in [39413ccd4f]
Login

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

Overview
Comment:Import of TIP 312 implementation
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | tip-312-new
Files: files | file ages | folders
SHA3-256: 39413ccd4f98cb34dc6ea0cb212b94df6fdac252932804168a6b73da8a4811e3
User & Date: dkf 2019-04-03 07:58:17.488
Context
2019-04-03
09:08
Some fixes. Still broken on 64-bit systems check-in: b81fc362ed user: dkf tags: tip-312-new
07:58
Import of TIP 312 implementation check-in: 39413ccd4f user: dkf tags: tip-312-new
2019-04-02
18:23
merge-mark check-in: 5b3cc9e2a9 user: jan.nijtmans tags: core-8-branch
Changes
Unified Diff Ignore Whitespace Patch
Changes to generic/tcl.decls.
2374
2375
2376
2377
2378
2379
2380






2381
2382
2383
2384
2385
2386
2387
declare 642 {
    void Tcl_DecrRefCount(Tcl_Obj *objPtr)
}

declare 643 {
    int Tcl_IsShared(Tcl_Obj *objPtr)
}







# ----- BASELINE -- FOR -- 8.7.0 ----- #

##############################################################################

# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.







>
>
>
>
>
>







2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
declare 642 {
    void Tcl_DecrRefCount(Tcl_Obj *objPtr)
}

declare 643 {
    int Tcl_IsShared(Tcl_Obj *objPtr)
}

# TIP#312 New Tcl_LinkArray() function
declare 644 {
    int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr,
	    int type, int size)
}

# ----- BASELINE -- FOR -- 8.7.0 ----- #

##############################################################################

# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
Changes to generic/tcl.h.
1089
1090
1091
1092
1093
1094
1095


1096
1097
1098
1099
1100
1101
1102
#define TCL_LINK_ULONG		((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT)
#else
#define TCL_LINK_LONG		11
#define TCL_LINK_ULONG		12
#endif
#define TCL_LINK_FLOAT		13
#define TCL_LINK_WIDE_UINT	14


#define TCL_LINK_READ_ONLY	0x80

/*
 *----------------------------------------------------------------------------
 * Forward declarations of Tcl_HashTable and related types.
 */








>
>







1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
#define TCL_LINK_ULONG		((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT)
#else
#define TCL_LINK_LONG		11
#define TCL_LINK_ULONG		12
#endif
#define TCL_LINK_FLOAT		13
#define TCL_LINK_WIDE_UINT	14
#define TCL_LINK_CHARS		15
#define TCL_LINK_BINARY		16
#define TCL_LINK_READ_ONLY	0x80

/*
 *----------------------------------------------------------------------------
 * Forward declarations of Tcl_HashTable and related types.
 */

Changes to generic/tclDecls.h.
1893
1894
1895
1896
1897
1898
1899




1900
1901
1902
1903
1904
1905
1906
EXTERN int		Tcl_HasStringRep(Tcl_Obj *objPtr);
/* 641 */
EXTERN void		Tcl_IncrRefCount(Tcl_Obj *objPtr);
/* 642 */
EXTERN void		Tcl_DecrRefCount(Tcl_Obj *objPtr);
/* 643 */
EXTERN int		Tcl_IsShared(Tcl_Obj *objPtr);





typedef struct {
    const struct TclPlatStubs *tclPlatStubs;
    const struct TclIntStubs *tclIntStubs;
    const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;








>
>
>
>







1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
EXTERN int		Tcl_HasStringRep(Tcl_Obj *objPtr);
/* 641 */
EXTERN void		Tcl_IncrRefCount(Tcl_Obj *objPtr);
/* 642 */
EXTERN void		Tcl_DecrRefCount(Tcl_Obj *objPtr);
/* 643 */
EXTERN int		Tcl_IsShared(Tcl_Obj *objPtr);
/* 644 */
EXTERN int		Tcl_LinkArray(Tcl_Interp *interp,
				const char *varName, void *addr, int type,
				int size);

typedef struct {
    const struct TclPlatStubs *tclPlatStubs;
    const struct TclIntStubs *tclIntStubs;
    const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;

2572
2573
2574
2575
2576
2577
2578

2579
2580
2581
2582
2583
2584
2585
    char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 637 */
    Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
    void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */
    int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
    void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
    void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
    int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */

} TclStubs;

extern const TclStubs *tclStubsPtr;

#ifdef __cplusplus
}
#endif







>







2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
    char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 637 */
    Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
    void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */
    int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
    void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
    void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
    int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
    int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, int size); /* 644 */
} TclStubs;

extern const TclStubs *tclStubsPtr;

#ifdef __cplusplus
}
#endif
3890
3891
3892
3893
3894
3895
3896


3897
3898
3899
3900
3901
3902
3903
	(tclStubsPtr->tcl_HasStringRep) /* 640 */
#define Tcl_IncrRefCount \
	(tclStubsPtr->tcl_IncrRefCount) /* 641 */
#define Tcl_DecrRefCount \
	(tclStubsPtr->tcl_DecrRefCount) /* 642 */
#define Tcl_IsShared \
	(tclStubsPtr->tcl_IsShared) /* 643 */



#endif /* defined(USE_TCL_STUBS) */

/* !END!: Do not edit above this line. */

#if defined(USE_TCL_STUBS)
#   undef Tcl_CreateInterp







>
>







3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
	(tclStubsPtr->tcl_HasStringRep) /* 640 */
#define Tcl_IncrRefCount \
	(tclStubsPtr->tcl_IncrRefCount) /* 641 */
#define Tcl_DecrRefCount \
	(tclStubsPtr->tcl_DecrRefCount) /* 642 */
#define Tcl_IsShared \
	(tclStubsPtr->tcl_IsShared) /* 643 */
#define Tcl_LinkArray \
	(tclStubsPtr->tcl_LinkArray) /* 644 */

#endif /* defined(USE_TCL_STUBS) */

/* !END!: Do not edit above this line. */

#if defined(USE_TCL_STUBS)
#   undef Tcl_CreateInterp
Changes to generic/tclLink.c.
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
/*
 * tclLink.c --
 *
 *	This file implements linked variables (a C variable that is tied to a
 *	Tcl variable). The idea of linked variables was first suggested by
 *	Andreas Stolcke and this implementation is based heavily on a
 *	prototype implementation provided by him.
 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.

 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"


/*
 * For each linked variable there is a data structure of the following type,
 * which describes the link and is the clientData for the trace set on the Tcl
 * variable.
 */

typedef struct Link {
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
    Tcl_Obj *varName;		/* Name of variable (must be global). This is
				 * needed during trace callbacks, since the
				 * actual variable may be aliased at that time
				 * via upvar. */
    char *addr;			/* Location of C variable. */



    int type;			/* Type of link (TCL_LINK_INT, etc.). */
    union {
	char c;
	unsigned char uc;
	int i;
	unsigned int ui;
	short s;
	unsigned short us;
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
	long l;
	unsigned long ul;
#endif
	Tcl_WideInt w;
	Tcl_WideUInt uw;
	float f;
	double d;













    } lastValue;		/* Last known value of C variable; used to
				 * avoid string conversions. */
    int flags;			/* Miscellaneous one-bit values; see below for
				 * definitions. */
} Link;

/*
 * Definitions for flag bits:
 * LINK_READ_ONLY -		1 means errors should be generated if Tcl
 *				script attempts to write variable.
 * LINK_BEING_UPDATED -		1 means that a call to Tcl_UpdateLinkedVar is
 *				in progress for this variable, so trace
 *				callbacks on the variable should be ignored.




 */

#define LINK_READ_ONLY		1
#define LINK_BEING_UPDATED	2



/*
 * Forward references to functions defined later in this file:
 */

static char *		LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
			    const char *name1, const char *name2, int flags);
static Tcl_Obj *	ObjValue(Link *linkPtr);

static int		GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr);
static int		GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr);

static int		GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr);


/*
 * Convenience macro for accessing the value of the C variable pointed to by a
 * link. Note that this macro produces something that may be regarded as an
 * lvalue or rvalue; it may be assigned to as well as read. Also note that
 * this macro assumes the name of the variable being accessed (linkPtr); this
 * is not strictly a good thing, but it keeps the code much shorter and










>






>














>
>
>
















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













>
>
>
>




>
>








>

|
>
|
>







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
/*
 * tclLink.c --
 *
 *	This file implements linked variables (a C variable that is tied to a
 *	Tcl variable). The idea of linked variables was first suggested by
 *	Andreas Stolcke and this implementation is based heavily on a
 *	prototype implementation provided by him.
 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2008 Rene Zaumseil
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include <math.h>

/*
 * For each linked variable there is a data structure of the following type,
 * which describes the link and is the clientData for the trace set on the Tcl
 * variable.
 */

typedef struct Link {
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
    Tcl_Obj *varName;		/* Name of variable (must be global). This is
				 * needed during trace callbacks, since the
				 * actual variable may be aliased at that time
				 * via upvar. */
    char *addr;			/* Location of C variable. */
    int bytes;			/* Size of C variable array. This is 0 when
				 * single variables, and >0 used for array
				 * variables */
    int type;			/* Type of link (TCL_LINK_INT, etc.). */
    union {
	char c;
	unsigned char uc;
	int i;
	unsigned int ui;
	short s;
	unsigned short us;
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
	long l;
	unsigned long ul;
#endif
	Tcl_WideInt w;
	Tcl_WideUInt uw;
	float f;
	double d;
	void *aryPtr;
	char *pc;
	unsigned char *puc;
	int *pi;
	unsigned int *pui;
	short *ps;
	unsigned short *pus;
	long *pl;
	unsigned long *pul;
	Tcl_WideInt *pw;
	Tcl_WideUInt *puw;
	float *pf;
	double *pd;
    } lastValue;		/* Last known value of C variable; used to
				 * avoid string conversions. */
    int flags;			/* Miscellaneous one-bit values; see below for
				 * definitions. */
} Link;

/*
 * Definitions for flag bits:
 * LINK_READ_ONLY -		1 means errors should be generated if Tcl
 *				script attempts to write variable.
 * LINK_BEING_UPDATED -		1 means that a call to Tcl_UpdateLinkedVar is
 *				in progress for this variable, so trace
 *				callbacks on the variable should be ignored.
 * LINK_ALLOC_ADDR -		1 means linkPtr->addr was allocated on the
 *				heap.
 * LINK_ALLOC_LAST -		1 means linkPtr->valueLast.p was allocated on
 *				the heap.
 */

#define LINK_READ_ONLY		1
#define LINK_BEING_UPDATED	2
#define LINK_ALLOC_ADDR		4
#define LINK_ALLOC_LAST		8

/*
 * Forward references to functions defined later in this file:
 */

static char *		LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
			    const char *name1, const char *name2, int flags);
static Tcl_Obj *	ObjValue(Link *linkPtr);
static void		LinkFree(Link *linkPtr);
static int		GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr);
static int		GetInvalidWideFromObj(Tcl_Obj *objPtr,
			    Tcl_WideInt *widePtr);
static int		GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
			    double *doublePtr);

/*
 * Convenience macro for accessing the value of the C variable pointed to by a
 * link. Note that this macro produces something that may be regarded as an
 * lvalue or rvalue; it may be assigned to as well as read. Also note that
 * this macro assumes the name of the variable being accessed (linkPtr); this
 * is not strictly a good thing, but it keeps the code much shorter and
140
141
142
143
144
145
146

147
148
149
150
151
152
153



































































































































































154
155
156
157
158
159


160
161
162
163
164
165
166
    }
#endif
    if (type & TCL_LINK_READ_ONLY) {
	linkPtr->flags = LINK_READ_ONLY;
    } else {
	linkPtr->flags = 0;
    }

    objPtr = ObjValue(linkPtr);
    if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
	    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
	Tcl_DecrRefCount(linkPtr->varName);
	ckfree(linkPtr);
	return TCL_ERROR;
    }



































































































































































    code = Tcl_TraceVar2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    LinkTraceProc, linkPtr);
    if (code != TCL_OK) {
	Tcl_DecrRefCount(linkPtr->varName);
	ckfree(linkPtr);


    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *







>




|


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





|
>
>







167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
    }
#endif
    if (type & TCL_LINK_READ_ONLY) {
	linkPtr->flags = LINK_READ_ONLY;
    } else {
	linkPtr->flags = 0;
    }
    linkPtr->bytes = 0;
    objPtr = ObjValue(linkPtr);
    if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
	    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
	Tcl_DecrRefCount(linkPtr->varName);
	LinkFree(linkPtr);
	return TCL_ERROR;
    }
    code = Tcl_TraceVar2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    LinkTraceProc, linkPtr);
    if (code != TCL_OK) {
	Tcl_DecrRefCount(linkPtr->varName);
	LinkFree(linkPtr);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LinkArray --
 *
 *	Link a C variable array to a Tcl variable so that changes to either
 *	one causes the other to change.
 *
 * Results:
 *	The return value is TCL_OK if everything went well or TCL_ERROR if an
 *	error occurred (the interp's result is also set after errors).
 *
 * Side effects:
 *	The value at *addr is linked to the Tcl variable "varName", using
 *	"type" to convert between string values for Tcl and binary values for
 *	*addr.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LinkArray(
    Tcl_Interp *interp,		/* Interpreter in which varName exists. */
    const char *varName,	/* Name of a global variable in interp. */
    void *addr,			/* Address of a C variable to be linked to
				 * varName. If NULL then the necessary space
				 * will be allocated and returned as the
				 * interpreter result. */
    int type,			/* Type of C variable: TCL_LINK_INT, etc. Also
				 * may have TCL_LINK_READ_ONLY and
				 * TCL_LINK_ALLOC OR'ed in. */
    int size)			/* Size of C variable array, >1 if array */
{
    Tcl_Obj *objPtr;
    Link *linkPtr;
    int code;

    if (size < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"wrong array size given", -1));
	return TCL_ERROR;
    }

    linkPtr = ckalloc(sizeof(Link));
    linkPtr->type = type & ~TCL_LINK_READ_ONLY;
    if (type & TCL_LINK_READ_ONLY) {
	linkPtr->flags = LINK_READ_ONLY;
    } else {
	linkPtr->flags = 0;
    }

    switch (linkPtr->type) {
    case TCL_LINK_INT:
    case TCL_LINK_BOOLEAN:
	linkPtr->bytes = size * sizeof(int);
	break;
    case TCL_LINK_DOUBLE:
	linkPtr->bytes = size * sizeof(double);
	break;
    case TCL_LINK_WIDE_INT:
	linkPtr->bytes = size * sizeof(Tcl_WideInt);
	break;
    case TCL_LINK_WIDE_UINT:
	linkPtr->bytes = size * sizeof(Tcl_WideUInt);
	break;
    case TCL_LINK_CHAR:
	linkPtr->bytes = size * sizeof(char);
	break;
    case TCL_LINK_UCHAR:
	linkPtr->bytes = size * sizeof(unsigned char);
	break;
    case TCL_LINK_SHORT:
	linkPtr->bytes = size * sizeof(short);
	break;
    case TCL_LINK_USHORT:
	linkPtr->bytes = size * sizeof(unsigned short);
	break;
    case TCL_LINK_UINT:
	linkPtr->bytes = size * sizeof(unsigned int);
	break;
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
    case TCL_LINK_LONG:
	linkPtr->bytes = size * sizeof(long);
	break;
    case TCL_LINK_ULONG:
	linkPtr->bytes = size * sizeof(unsigned long);
	break;
#endif
    case TCL_LINK_FLOAT:
	linkPtr->bytes = size * sizeof(float);
	break;
    case TCL_LINK_STRING:
	linkPtr->bytes = size * sizeof(char);
	size = 1;		/* This is a variable length string, no need
				 * to check last value. */

	/*
	 * If no address is given create one and use as address the
         * not needed linkPtr->lastValue
	 */

	if (addr == NULL) {
	    linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes);
	    linkPtr->flags |= LINK_ALLOC_LAST;
	    addr = (char *) &linkPtr->lastValue.pc;
	}
	break;
    case TCL_LINK_CHARS:
    case TCL_LINK_BINARY:
	linkPtr->bytes = size * sizeof(char);
	break;
    default:
	LinkFree(linkPtr);
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"bad linked array variable type", -1));
	return TCL_ERROR;
    }

    /*
     * Allocate C variable space in case no address is given
     */

    if (addr == NULL) {
	linkPtr->addr = ckalloc(linkPtr->bytes);
	linkPtr->flags |= LINK_ALLOC_ADDR;
    } else {
	linkPtr->addr = addr;
    }

    /*
     * If necessary create space for last used value.
     */

    if (size > 1) {
	linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes);
	linkPtr->flags |= LINK_ALLOC_LAST;
    }

    /*
     * Set common structure values.
     */

    linkPtr->interp = interp;
    linkPtr->varName = Tcl_NewStringObj(varName, -1);
    Tcl_IncrRefCount(linkPtr->varName);
    objPtr = ObjValue(linkPtr);
    if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
	    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
	Tcl_DecrRefCount(linkPtr->varName);
	LinkFree(linkPtr);
	return TCL_ERROR;
    }

    code = Tcl_TraceVar2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    LinkTraceProc, linkPtr);
    if (code != TCL_OK) {
	Tcl_DecrRefCount(linkPtr->varName);
	LinkFree(linkPtr);
    } else {
	Tcl_SetObjResult(interp, Tcl_NewIntObj((int) linkPtr->addr));
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
    if (linkPtr == NULL) {
	return;
    }
    Tcl_UntraceVar2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    LinkTraceProc, linkPtr);
    Tcl_DecrRefCount(linkPtr->varName);
    ckfree(linkPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpdateLinkedVar --
 *







|







383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
    if (linkPtr == NULL) {
	return;
    }
    Tcl_UntraceVar2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    LinkTraceProc, linkPtr);
    Tcl_DecrRefCount(linkPtr->varName);
    LinkFree(linkPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpdateLinkedVar --
 *
237
238
239
240
241
242
243






































244
245
246
247
248
249
250
     */
    linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
    if (linkPtr != NULL) {
	linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
    }
}







































/*
 *----------------------------------------------------------------------
 *
 * LinkTraceProc --
 *
 *	This function is invoked when a linked Tcl variable is read, written,







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







430
431
432
433
434
435
436
437
438
439
440
441
442
443
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
     */
    linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
    if (linkPtr != NULL) {
	linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
    }
}

static inline int
GetInt(
    Tcl_Obj *objPtr,
    int *intPtr)
{
    return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK
	    && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK);
}

static inline int
GetWide(
    Tcl_Obj *objPtr,
    Tcl_WideInt *widePtr)
{
    return (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK
	    && GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK);
}

static inline int
GetDouble(
    Tcl_Obj *objPtr,
    double *dblPtr)
{
    if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) {
	return 0;
    } else {
#ifdef ACCEPT_NAN
	Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclDoubleType);

	if (irPtr != NULL) {
	    *dblPtr = irPtr->doubleValue;
	    return 0;
	}
#endif
	return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * LinkTraceProc --
 *
 *	This function is invoked when a linked Tcl variable is read, written,
269
270
271
272
273
274
275
276
277
278
279
280
281
282



283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
    Tcl_Interp *interp,		/* Interpreter containing Tcl variable. */
    const char *name1,		/* First part of variable name. */
    const char *name2,		/* Second part of variable name. */
    int flags)			/* Miscellaneous additional information. */
{
    Link *linkPtr = clientData;
    int changed;
    size_t valueLength;
    const char *value;
    char **pp;
    Tcl_Obj *valueObj;
    int valueInt;
    Tcl_WideInt valueWide;
    double valueDouble;




    /*
     * If the variable is being unset, then just re-create it (with a trace)
     * unless the whole interpreter is going away.
     */

    if (flags & TCL_TRACE_UNSETS) {
	if (Tcl_InterpDeleted(interp)) {
	    Tcl_DecrRefCount(linkPtr->varName);
	    ckfree(linkPtr);
	} else if (flags & TCL_TRACE_DESTROYED) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL,
		    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
		    |TCL_TRACE_UNSETS, LinkTraceProc, linkPtr);
	}







|






>
>
>









|







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
    Tcl_Interp *interp,		/* Interpreter containing Tcl variable. */
    const char *name1,		/* First part of variable name. */
    const char *name2,		/* Second part of variable name. */
    int flags)			/* Miscellaneous additional information. */
{
    Link *linkPtr = clientData;
    int changed;
    int valueLength;
    const char *value;
    char **pp;
    Tcl_Obj *valueObj;
    int valueInt;
    Tcl_WideInt valueWide;
    double valueDouble;
    int objc;
    Tcl_Obj **objv;
    int i;

    /*
     * If the variable is being unset, then just re-create it (with a trace)
     * unless the whole interpreter is going away.
     */

    if (flags & TCL_TRACE_UNSETS) {
	if (Tcl_InterpDeleted(interp)) {
	    Tcl_DecrRefCount(linkPtr->varName);
	    LinkFree(linkPtr);
	} else if (flags & TCL_TRACE_DESTROYED) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL,
		    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
		    |TCL_TRACE_UNSETS, LinkTraceProc, linkPtr);
	}
312
313
314
315
316
317
318









319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359


360
361
362

363

364
365
366
367
368
369
370

    /*
     * For read accesses, update the Tcl variable if the C variable has
     * changed since the last time we updated the Tcl variable.
     */

    if (flags & TCL_TRACE_READS) {









	switch (linkPtr->type) {
	case TCL_LINK_INT:
	case TCL_LINK_BOOLEAN:
	    changed = (LinkedVar(int) != linkPtr->lastValue.i);
	    break;
	case TCL_LINK_DOUBLE:
	    changed = (LinkedVar(double) != linkPtr->lastValue.d);
	    break;
	case TCL_LINK_WIDE_INT:
	    changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
	    break;
	case TCL_LINK_WIDE_UINT:
	    changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
	    break;
	case TCL_LINK_CHAR:
	    changed = (LinkedVar(char) != linkPtr->lastValue.c);
	    break;
	case TCL_LINK_UCHAR:
	    changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc);
	    break;
	case TCL_LINK_SHORT:
	    changed = (LinkedVar(short) != linkPtr->lastValue.s);
	    break;
	case TCL_LINK_USHORT:
	    changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us);
	    break;
	case TCL_LINK_UINT:
	    changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
	    break;
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
	case TCL_LINK_LONG:
	    changed = (LinkedVar(long) != linkPtr->lastValue.l);
	    break;
	case TCL_LINK_ULONG:
	    changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
	    break;
#endif
	case TCL_LINK_FLOAT:
	    changed = (LinkedVar(float) != linkPtr->lastValue.f);
	    break;
	case TCL_LINK_STRING:


	    changed = 1;
	    break;
	default:

	    return (char *) "internal error: bad linked variable type";

	}
	if (changed) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	}
	return NULL;
    }







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

|
|
|
|
|
|

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







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

    /*
     * For read accesses, update the Tcl variable if the C variable has
     * changed since the last time we updated the Tcl variable.
     */

    if (flags & TCL_TRACE_READS) {
	/*
	 * Variable arrays
	 */

	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    changed = memcmp(linkPtr->addr, linkPtr->lastValue.aryPtr,
		    linkPtr->bytes);
	} else {
	    /* single variables */
	    switch (linkPtr->type) {
	    case TCL_LINK_INT:
	    case TCL_LINK_BOOLEAN:
		changed = (LinkedVar(int) != linkPtr->lastValue.i);
		break;
	    case TCL_LINK_DOUBLE:
		changed = (LinkedVar(double) != linkPtr->lastValue.d);
		break;
	    case TCL_LINK_WIDE_INT:
		changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
		break;
	    case TCL_LINK_WIDE_UINT:
		changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
		break;
	    case TCL_LINK_CHAR:
		changed = (LinkedVar(char) != linkPtr->lastValue.c);
		break;
	    case TCL_LINK_UCHAR:
		changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc);
		break;
	    case TCL_LINK_SHORT:
		changed = (LinkedVar(short) != linkPtr->lastValue.s);
		break;
	    case TCL_LINK_USHORT:
		changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us);
		break;
	    case TCL_LINK_UINT:
		changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
		break;
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
	    case TCL_LINK_LONG:
		changed = (LinkedVar(long) != linkPtr->lastValue.l);
		break;
	    case TCL_LINK_ULONG:
		changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
		break;
#endif
	    case TCL_LINK_FLOAT:
		changed = (LinkedVar(float) != linkPtr->lastValue.f);
		break;
	    case TCL_LINK_STRING:
	    case TCL_LINK_CHARS:
	    case TCL_LINK_BINARY:
		changed = 1;
		break;
	    default:
		changed = 0;
		/* return (char *) "internal error: bad linked variable type"; */
	    }
	}
	if (changed) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	}
	return NULL;
    }
388
389
390
391
392
393
394












395
396



397









398


399
400
401
402
403

404
405
406



407










408


409
410
411
412
413

414
415
416
417
418
419
420
421
422
423
424
425
426
427
428


429
430




431
432

433
434
435















436
437
438
439
440
441

442
443
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
	/*
	 * This shouldn't ever happen.
	 */

	return (char *) "internal error: linked variable couldn't be read";
    }













    switch (linkPtr->type) {
    case TCL_LINK_INT:



	if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK









		&& GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) {


	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have integer value";
	}
	LinkedVar(int) = linkPtr->lastValue.i;

	break;

    case TCL_LINK_WIDE_INT:



	if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK










		&& GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) {


	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have integer value";
	}
	LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;

	break;

    case TCL_LINK_DOUBLE:
	if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) {
#ifdef ACCEPT_NAN
	    Tcl_ObjIntRep *irPtr = TclFetchIntRep(valueObj, &tclDoubleType);
	    if (irPtr == NULL) {
#endif
		if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
			TCL_GLOBAL_ONLY);
		    return (char *) "variable must have real value";
		}
#ifdef ACCEPT_NAN
	    }


	    linkPtr->lastValue.d = irPtr->doubleValue;
#endif




	}
	LinkedVar(double) = linkPtr->lastValue.d;

	break;

    case TCL_LINK_BOOLEAN:















	if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have boolean value";
	}
	LinkedVar(int) = linkPtr->lastValue.i;

	break;

    case TCL_LINK_CHAR:



	if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK










		&& GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
		|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have char value";
	}
	LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt;

	break;

    case TCL_LINK_UCHAR:



	if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK










		&& GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
		|| valueInt < 0 || valueInt > UCHAR_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have unsigned char value";
	}
	LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt;


	break;

    case TCL_LINK_SHORT:



	if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK









		&& GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
		|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have short value";
	}
	LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt;

	break;

    case TCL_LINK_USHORT:



	if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK










		&& GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
		|| valueInt < 0 || valueInt > USHRT_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have unsigned short value";
	}
	LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt;


	break;

    case TCL_LINK_UINT:



	if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK










		&& GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
		|| valueWide < 0 || valueWide > UINT_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have unsigned int value";
	}
	LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide;


	break;

#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
    case TCL_LINK_LONG:



	if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK










		&& GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
		|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have long value";
	}
	LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide;

	break;

    case TCL_LINK_ULONG:



	if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK










		&& GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
		|| valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have unsigned long value";
	}
	LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide;


	break;
#endif

    case TCL_LINK_WIDE_UINT:
	/*
	 * FIXME: represent as a bignum.
	 */



	if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK









		&& GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have unsigned wide int value";
	}
	LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;


	break;

    case TCL_LINK_FLOAT:



	if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK











		&& GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK)
		|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {

	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have float value";
	}
	LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble;

	break;

    case TCL_LINK_STRING:
	value = TclGetString(valueObj);
	valueLength = valueObj->length + 1;
	pp = (char **) linkPtr->addr;

	*pp = ckrealloc(*pp, valueLength);
	memcpy(*pp, value, valueLength);
	break;






























    default:
	return (char *) "internal error: bad linked variable type";
    }
    return NULL;
}








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


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



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



|
<
|
|
<
|
|
|
|

<

>
>
|
|
>
>
>
>
|
|
>



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



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



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



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



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



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




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



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







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



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










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







635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707

708
709

710
711
712
713
714

715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
	/*
	 * This shouldn't ever happen.
	 */

	return (char *) "internal error: linked variable couldn't be read";
    }

    /*
     * A couple of helper macros. 
     */

#define CheckHaveList(valueObj, underlyingType)				\
    if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR \
	    || objc != linkPtr->bytes / sizeof(underlyingType)) { \
	return (char *) "wrong dimension";			  \
    }
#define InRange(lowerLimit, value, upperLimit)	\
    ((value) >= (lowerLimit) && (value) <= (upperLimit))

    switch (linkPtr->type) {
    case TCL_LINK_INT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    CheckHaveList(valueObj, int);
	    for (i=0; i < objc; i++) {
		int *varPtr = &linkPtr->lastValue.pi[i];

		if (GetInt(objv[i], varPtr)) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
	            return (char *) "variable array must have integer values";
		}
	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	} else {
	    int *varPtr = &linkPtr->lastValue.i;

	    if (GetInt(valueObj, varPtr)) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have integer value";
	    }
	    LinkedVar(int) = *varPtr;
	}
	break;

    case TCL_LINK_WIDE_INT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    CheckHaveList(valueObj, Tcl_WideInt);
	    for (i=0; i < objc; i++) {
		Tcl_WideInt *varPtr = &linkPtr->lastValue.pw[i];

		if (GetWide(objv[i], varPtr)) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		    return (char *)
			    "variable array must have wide integer value";
		}
	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	} else {
	    Tcl_WideInt *varPtr = &linkPtr->lastValue.w;

	    if (GetWide(valueObj, varPtr)) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have wide integer value";
	    }
	    LinkedVar(Tcl_WideInt) = *varPtr;
	}
	break;

    case TCL_LINK_DOUBLE:
	if (linkPtr->flags & LINK_ALLOC_LAST) {

	    CheckHaveList(valueObj, double);
	    for (i=0; i < objc; i++) {

		if (GetDouble(objv[i], &linkPtr->lastValue.pd[i])) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		    return (char *) "variable array must have real value";
		}

	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	} else {
	    double *varPtr = &linkPtr->lastValue.d;

	    if (GetDouble(valueObj, varPtr)) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have real value";
	    }
	    LinkedVar(double) = *varPtr;
	}
	break;

    case TCL_LINK_BOOLEAN:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    CheckHaveList(valueObj, int);
	    for (i=0; i < objc; i++) {
		int *varPtr = &linkPtr->lastValue.pi[i];

		if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
	            return (char *) "variable array must have boolean value";
		}
	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	} else {
	    int *varPtr = &linkPtr->lastValue.i;

	    if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have boolean value";
	    }
	    LinkedVar(int) = *varPtr;
	}
	break;

    case TCL_LINK_CHAR:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    CheckHaveList(valueObj, char);
	    for (i=0; i < objc; i++) {
		if (GetInt(objv[i], &valueInt)
		        || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
	            return (char *) "variable array must have char value";
		}
		linkPtr->lastValue.pc[i] = (char) valueInt;
	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	    break;
	} else {
	    if (GetInt(valueObj, &valueInt)
		    || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have char value";
	    }
	    LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt;
	}
	break;

    case TCL_LINK_UCHAR:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    CheckHaveList(valueObj, unsigned char);
	    for (i=0; i < objc; i++) {
		if (GetInt(objv[i], &valueInt)
		        || !InRange(0, valueInt, UCHAR_MAX)) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		    return (char *)
			    "variable array must have unsigned char value";
		}
		linkPtr->lastValue.puc[i] = (unsigned char) valueInt;
	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	} else {
	    if (GetInt(valueObj, &valueInt)
		    || !InRange(0, valueInt, UCHAR_MAX)) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have unsigned char value";
	    }
	    LinkedVar(unsigned char) = linkPtr->lastValue.uc =
		    (unsigned char) valueInt;
	}
	break;

    case TCL_LINK_SHORT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    CheckHaveList(valueObj, short);
	    for (i=0; i < objc; i++) {
		if (GetInt(objv[i], &valueInt)
			|| !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
	            return (char *) "variable array must have short value";
		}
		linkPtr->lastValue.ps[i] = (short) valueInt;
	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	} else {
	    if (GetInt(valueObj, &valueInt)
		    || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have short value";
	    }
	    LinkedVar(short) = linkPtr->lastValue.s = (short) valueInt;
	}
	break;

    case TCL_LINK_USHORT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    CheckHaveList(valueObj, unsigned short);
	    for (i=0; i < objc; i++) {
		if (GetInt(objv[i], &valueInt)
		        || !InRange(0, valueInt, USHRT_MAX)) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
	            return (char *)
			"variable array must have unsigned short value";
		}
		linkPtr->lastValue.pus[i] = (unsigned short) valueInt;
	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	} else {
	    if (GetInt(valueObj, &valueInt)
		    || !InRange(0, valueInt, USHRT_MAX)) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have unsigned short value";
	    }
	    LinkedVar(unsigned short) = linkPtr->lastValue.us =
		    (unsigned short) valueInt;
	}
	break;

    case TCL_LINK_UINT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    CheckHaveList(valueObj, unsigned int);
	    for (i=0; i < objc; i++) {
		if (GetWide(objv[i], &valueWide)
			|| !InRange(0, valueWide, UINT_MAX)) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
	            return (char *)
			    "variable array must have unsigned int value";
		}
		linkPtr->lastValue.pui[i] = (unsigned int) valueWide;
	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	} else {
	    if (GetWide(valueObj, &valueWide)
		    || !InRange(0, valueWide, UINT_MAX)) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have unsigned int value";
	    }
	    LinkedVar(unsigned int) = linkPtr->lastValue.ui =
		    (unsigned int) valueWide;
	}
	break;

#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
    case TCL_LINK_LONG:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    CheckHaveList(valueObj, long);
	    for (i=0; i < objc; i++) {
		if (GetWide(objv[i], &valueWide)
			|| !InRange(LONG_MIN, valueWide, LONG_MAX)) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
	            return (char *) "variable array must have long value";
		}
		linkPtr->lastValue.pl[i] = (long) valueWide;
	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	    break;
	} else {
	    if (GetWide(valueObj, &valueWide)
		    || !InRange(LONG_MIN, valueWide, LONG_MAX)) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have long value";
	    }
	    LinkedVar(long) = linkPtr->lastValue.l = (long) valueWide;
	}
	break;

    case TCL_LINK_ULONG:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    CheckHaveList(valueObj, unsigned long);
	    for (i=0; i < objc; i++) {
		if (GetWide(objv[i], &valueWide)
			|| !InRange(0, valueWide, ULONG_MAX)) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
	            return (char *)
			    "variable array must have unsigned long value";
		}
		linkPtr->lastValue.pul[i] = (unsigned long) valueWide;
	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	} else {
	    if (GetWide(valueObj, &valueWide)
		    || !InRange(0, valueWide, ULONG_MAX)) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have unsigned long value";
	    }
	    LinkedVar(unsigned long) = linkPtr->lastValue.ul =
		    (unsigned long) valueWide;
	}
	break;
#endif

    case TCL_LINK_WIDE_UINT:
	/*
	 * FIXME: represent as a bignum.
	 */
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    CheckHaveList(valueObj, Tcl_WideUInt);
	    for (i=0; i < objc; i++) {
		if (GetWide(objv[i], &valueWide)) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
	            return (char *)
			    "variable array must have unsigned wide int value";
		}
		linkPtr->lastValue.puw[i] = (Tcl_WideUInt) valueWide;
	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	} else {
	    if (GetWide(valueObj, &valueWide)) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have unsigned wide int value";
	    }
	    LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw =
		    (Tcl_WideUInt) valueWide;
	}
	break;

    case TCL_LINK_FLOAT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    CheckHaveList(valueObj, float);
	    for (i=0; i < objc; i++) {
		if (GetDouble(objv[i], &valueDouble)
			&& !InRange(FLT_MIN, valueDouble, FLT_MAX)
		        && !TclIsInfinite(valueDouble)
			&& !TclIsNaN(valueDouble)) {
		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			    ObjValue(linkPtr), TCL_GLOBAL_ONLY);
	            return (char *) "variable array must have float value";
		}
		linkPtr->lastValue.pf[i] = (float) valueDouble;
	    }
	    memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
	} else {
	    if (GetDouble(valueObj, &valueDouble)
		    && !InRange(FLT_MIN, valueDouble, FLT_MAX)
		    && !TclIsInfinite(valueDouble) && !TclIsNaN(valueDouble)) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have float value";
	    }
	    LinkedVar(float) = linkPtr->lastValue.f = (float) valueDouble;
	}
	break;

    case TCL_LINK_STRING:
	value = TclGetString(valueObj);
	valueLength = valueObj->length + 1;
	pp = (char **) linkPtr->addr;

	*pp = ckrealloc(*pp, valueLength);
	memcpy(*pp, value, valueLength);
	break;

    case TCL_LINK_CHARS:
	value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength);
	valueLength++;		/* include end of string char */
	if (valueLength > linkPtr->bytes) {
	    return (char *) "wrong size of char* value";
	}
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength);
	    memcpy(linkPtr->addr, value, (size_t) valueLength);
	} else {
	    linkPtr->lastValue.c = '\0';
	    LinkedVar(char) = linkPtr->lastValue.c;
	}
	break;

    case TCL_LINK_BINARY:
	value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength);
	if (valueLength != linkPtr->bytes) {
	    return (char *) "wrong size of binary value";
	}
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength);
	    memcpy(linkPtr->addr, value, (size_t) valueLength);
	} else {
	    linkPtr->lastValue.uc = (unsigned char) *value;
	    LinkedVar(unsigned char) = linkPtr->lastValue.uc;
	}
	break;

    default:
	return (char *) "internal error: bad linked variable type";
    }
    return NULL;
}

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



















640
641
642
643
644
645
646

static Tcl_Obj *
ObjValue(
    Link *linkPtr)		/* Structure describing linked variable. */
{
    char *p;
    Tcl_Obj *resultObj;




    switch (linkPtr->type) {
    case TCL_LINK_INT:









	linkPtr->lastValue.i = LinkedVar(int);
	return Tcl_NewIntObj(linkPtr->lastValue.i);
    case TCL_LINK_WIDE_INT:









	linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
	return Tcl_NewWideIntObj(linkPtr->lastValue.w);
    case TCL_LINK_DOUBLE:









	linkPtr->lastValue.d = LinkedVar(double);
	return Tcl_NewDoubleObj(linkPtr->lastValue.d);
    case TCL_LINK_BOOLEAN:









	linkPtr->lastValue.i = LinkedVar(int);
	return Tcl_NewBooleanObj(linkPtr->lastValue.i);
    case TCL_LINK_CHAR:









	linkPtr->lastValue.c = LinkedVar(char);
	return Tcl_NewIntObj(linkPtr->lastValue.c);
    case TCL_LINK_UCHAR:









	linkPtr->lastValue.uc = LinkedVar(unsigned char);
	return Tcl_NewIntObj(linkPtr->lastValue.uc);
    case TCL_LINK_SHORT:









	linkPtr->lastValue.s = LinkedVar(short);
	return Tcl_NewIntObj(linkPtr->lastValue.s);
    case TCL_LINK_USHORT:









	linkPtr->lastValue.us = LinkedVar(unsigned short);
	return Tcl_NewIntObj(linkPtr->lastValue.us);
    case TCL_LINK_UINT:









	linkPtr->lastValue.ui = LinkedVar(unsigned int);
	return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
    case TCL_LINK_LONG:









	linkPtr->lastValue.l = LinkedVar(long);
	return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
    case TCL_LINK_ULONG:









	linkPtr->lastValue.ul = LinkedVar(unsigned long);
	return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
#endif
    case TCL_LINK_FLOAT:









	linkPtr->lastValue.f = LinkedVar(float);
	return Tcl_NewDoubleObj(linkPtr->lastValue.f);
    case TCL_LINK_WIDE_UINT:
	linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
	/*
	 * FIXME: represent as a bignum.
	 */











	return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw);
    case TCL_LINK_STRING:
	p = LinkedVar(char *);
	if (p == NULL) {
	    TclNewLiteralStringObj(resultObj, "NULL");
	    return resultObj;
	}
	return Tcl_NewStringObj(p, -1);




















    /*
     * This code only gets executed if the link type is unknown (shouldn't
     * ever happen).
     */

    default:
	TclNewLiteralStringObj(resultObj, "??");







>
>
>



>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>




>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>




>
>
>
>
>
>
>
>
>



<



>
>
>
>
>
>
>
>
>
>
>









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







1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207

1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256

static Tcl_Obj *
ObjValue(
    Link *linkPtr)		/* Structure describing linked variable. */
{
    char *p;
    Tcl_Obj *resultObj;
    int objc;
    static Tcl_Obj **objv = NULL; // WTF?
    int i;

    switch (linkPtr->type) {
    case TCL_LINK_INT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes / sizeof(int);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pi[i]);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.i = LinkedVar(int);
	return Tcl_NewIntObj(linkPtr->lastValue.i);
    case TCL_LINK_WIDE_INT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes / sizeof(Tcl_WideInt);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pw[i]);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
	return Tcl_NewWideIntObj(linkPtr->lastValue.w);
    case TCL_LINK_DOUBLE:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes / sizeof(double);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.pd[i]);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.d = LinkedVar(double);
	return Tcl_NewDoubleObj(linkPtr->lastValue.d);
    case TCL_LINK_BOOLEAN:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes/sizeof(int);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.pi[i] != 0);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.i = LinkedVar(int);
	return Tcl_NewBooleanObj(linkPtr->lastValue.i);
    case TCL_LINK_CHAR:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes / sizeof(char);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pc[i]);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.c = LinkedVar(char);
	return Tcl_NewIntObj(linkPtr->lastValue.c);
    case TCL_LINK_UCHAR:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes / sizeof(unsigned char);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewIntObj(linkPtr->lastValue.puc[i]);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.uc = LinkedVar(unsigned char);
	return Tcl_NewIntObj(linkPtr->lastValue.uc);
    case TCL_LINK_SHORT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes / sizeof(short);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj*));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ps[i]);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.s = LinkedVar(short);
	return Tcl_NewIntObj(linkPtr->lastValue.s);
    case TCL_LINK_USHORT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes / sizeof(unsigned short);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj*));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewIntObj(linkPtr->lastValue.pus[i]);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.us = LinkedVar(unsigned short);
	return Tcl_NewIntObj(linkPtr->lastValue.us);
    case TCL_LINK_UINT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes / sizeof(unsigned int);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pui[i]);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.ui = LinkedVar(unsigned int);
	return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
    case TCL_LINK_LONG:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes / sizeof(long);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pl[i]);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.l = LinkedVar(long);
	return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
    case TCL_LINK_ULONG:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes / sizeof(unsigned long);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.pul[i]);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.ul = LinkedVar(unsigned long);
	return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
#endif
    case TCL_LINK_FLOAT:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes / sizeof(float);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.pf[i]);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.f = LinkedVar(float);
	return Tcl_NewDoubleObj(linkPtr->lastValue.f);
    case TCL_LINK_WIDE_UINT:

	/*
	 * FIXME: represent as a bignum.
	 */
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    objc = linkPtr->bytes / sizeof(Tcl_WideUInt);
	    objv = ckrealloc(objv, objc * sizeof(Tcl_Obj *));
	    for (i=0; i < objc; i++) {
		objv[i] = Tcl_NewWideIntObj((Tcl_WideInt)
			linkPtr->lastValue.puw[i]);
	    }
	    return Tcl_NewListObj(objc, objv);
	}
	linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
	return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw);
    case TCL_LINK_STRING:
	p = LinkedVar(char *);
	if (p == NULL) {
	    TclNewLiteralStringObj(resultObj, "NULL");
	    return resultObj;
	}
	return Tcl_NewStringObj(p, -1);

    case TCL_LINK_CHARS:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    linkPtr->lastValue.pc[linkPtr->bytes-1] = '\0';
	    /* take care of proper string end */
	    return Tcl_NewStringObj(linkPtr->lastValue.pc, linkPtr->bytes);
	}
	linkPtr->lastValue.c = '\0';
	return Tcl_NewStringObj(&linkPtr->lastValue.c, 1);

    case TCL_LINK_BINARY:
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
	    return Tcl_NewByteArrayObj((unsigned char *) linkPtr->addr,
		    linkPtr->bytes);
	}
	linkPtr->lastValue.uc = LinkedVar(unsigned char);
	return Tcl_NewByteArrayObj(&linkPtr->lastValue.uc, 1);

    /*
     * This code only gets executed if the link type is unknown (shouldn't
     * ever happen).
     */

    default:
	TclNewLiteralStringObj(resultObj, "??");
692
693
694
695
696
697
698

699
700
701
702
703
704
705

/*
 * This function checks for integer representations, which are valid
 * when linking with C variables, but which are invalid in other
 * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o"
 * (upperand lowercase). See bug [39f6304c2e].
 */

int
GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr)
{
    const char *str = TclGetString(objPtr);

    if ((objPtr->length == 0) ||
	    ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) {







>







1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316

/*
 * This function checks for integer representations, which are valid
 * when linking with C variables, but which are invalid in other
 * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o"
 * (upperand lowercase). See bug [39f6304c2e].
 */

int
GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr)
{
    const char *str = TclGetString(objPtr);

    if ((objPtr->length == 0) ||
	    ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) {
726
727
728
729
730
731
732

733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751





























752
753
754
755
756
757
758
759

/*
 * This function checks for double representations, which are valid
 * when linking with C variables, but which are invalid in other
 * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o"
 * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
 */

int
GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr)
{
    int intValue;

    if (TclHasIntRep(objPtr, &invalidRealType)) {
	goto gotdouble;
    }
    if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) {
	*doublePtr = (double) intValue;
	return TCL_OK;
    }
    if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) {
    gotdouble:
	*doublePtr = objPtr->internalRep.doubleValue;
	return TCL_OK;
    }
    return TCL_ERROR;
}





























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







>



















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








1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400

/*
 * This function checks for double representations, which are valid
 * when linking with C variables, but which are invalid in other
 * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o"
 * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
 */

int
GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr)
{
    int intValue;

    if (TclHasIntRep(objPtr, &invalidRealType)) {
	goto gotdouble;
    }
    if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) {
	*doublePtr = (double) intValue;
	return TCL_OK;
    }
    if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) {
    gotdouble:
	*doublePtr = objPtr->internalRep.doubleValue;
	return TCL_OK;
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * LinkFree --
 *
 *	Free's allocated space of given link and link structure.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
LinkFree(
    Link *linkPtr)		/* Structure describing linked variable. */
{
    if (linkPtr->flags & LINK_ALLOC_ADDR) {
	ckfree(linkPtr->addr);
    }
    if (linkPtr->flags & LINK_ALLOC_LAST) {
	ckfree(linkPtr->lastValue.aryPtr);
    }
    ckfree((char *) linkPtr);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
Changes to generic/tclStubInit.c.
1624
1625
1626
1627
1628
1629
1630

1631
1632
1633
    Tcl_InitStringRep, /* 637 */
    Tcl_FetchIntRep, /* 638 */
    Tcl_StoreIntRep, /* 639 */
    Tcl_HasStringRep, /* 640 */
    Tcl_IncrRefCount, /* 641 */
    Tcl_DecrRefCount, /* 642 */
    Tcl_IsShared, /* 643 */

};

/* !END!: Do not edit above this line. */







>



1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
    Tcl_InitStringRep, /* 637 */
    Tcl_FetchIntRep, /* 638 */
    Tcl_StoreIntRep, /* 639 */
    Tcl_HasStringRep, /* 640 */
    Tcl_IncrRefCount, /* 641 */
    Tcl_DecrRefCount, /* 642 */
    Tcl_IsShared, /* 643 */
    Tcl_LinkArray, /* 644 */
};

/* !END!: Do not edit above this line. */
Changes to generic/tclTest.c.
304
305
306
307
308
309
310


311
312
313
314
315
316
317
static int		TestgetvarfullnameCmd(
			    void *dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		TestinterpdeleteCmd(void *dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestlinkCmd(void *dummy,
			    Tcl_Interp *interp, int argc, const char **argv);


static int		TestlocaleCmd(void *dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestmainthreadCmd(void *dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestsetmainloopCmd(void *dummy,
			    Tcl_Interp *interp, int argc, const char **argv);







>
>







304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
static int		TestgetvarfullnameCmd(
			    void *dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		TestinterpdeleteCmd(void *dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestlinkCmd(void *dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestlinkarrayCmd(void *dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const *objv);
static int		TestlocaleCmd(void *dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestmainthreadCmd(void *dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
static int		TestsetmainloopCmd(void *dummy,
			    Tcl_Interp *interp, int argc, const char **argv);
661
662
663
664
665
666
667

668
669
670
671
672
673
674
    Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testgetvarfullname",
	    TestgetvarfullnameCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);

    Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
	    NULL);
    Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
    Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,







>







663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
    Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testgetvarfullname",
	    TestgetvarfullnameCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
	    NULL);
    Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
    Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
3275
3276
3277
3278
3279
3280
3281





















































































































3282
3283
3284
3285
3286
3287
3288
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": should be create, delete, get, set, or update", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}






















































































































/*
 *----------------------------------------------------------------------
 *
 * TestlocaleCmd --
 *
 *	This procedure implements the "testlocale" command.  It is used







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







3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": should be create, delete, get, set, or update", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestlinkarrayCmd --
 *
 *      This function is invoked to process the "testlinkarray" Tcl command.
 *      It is used to test the 'Tcl_LinkArray' function.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *	Creates, deletes, and invokes variable links.
 *
 *----------------------------------------------------------------------
 */

static int
TestlinkarrayCmd(
    ClientData dummy,           /* Not used. */
    Tcl_Interp *interp,         /* Current interpreter. */
    int objc,                   /* Number of arguments. */
    Tcl_Obj *const objv[])      /* Argument objects. */
{
    static const char *LinkOption[] = {
        "update", "remove", "create", NULL
    };
    enum LinkOption { LINK_UPDATE, LINK_REMOVE, LINK_CREATE };
    static const char *LinkType[] = {
	"char", "uchar", "short", "ushort", "int", "uint", "long", "ulong",
	"wide", "uwide", "float", "double", "string", "char*", "binary", NULL
    };
    /* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */
    static int LinkTypes[] = {
	TCL_LINK_CHAR, TCL_LINK_UCHAR,
	TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT,
	TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT,
	TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS,
	TCL_LINK_BINARY
    };
    int optionIndex, typeIndex, readonly, i, addr, size, length;
    char *name, *arg;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option args");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0,
	    &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum LinkOption) optionIndex) {
    case LINK_UPDATE:
	for (i=2; i<objc; i++) {
	    Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i]));
	}
	return TCL_OK;
    case LINK_REMOVE:
	for (i=2; i<objc; i++) {
	    Tcl_UnlinkVar(interp, Tcl_GetString(objv[i]));
	}
	return TCL_OK;
    case LINK_CREATE:
	if (objc < 4) {
	    goto wrongArgs;
	}
	readonly = 0;
	i = 2;

	/*
	 * test on switch -r...
	 */

	arg = Tcl_GetStringFromObj(objv[i], &length);
	if (length < 2) {
	    goto wrongArgs;
	}
	if (arg[0] == '-') {
	    if (arg[1] != 'r') {
		goto wrongArgs;
	    }
	    readonly = TCL_LINK_READ_ONLY;
	    i++;
	}
	if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0,
 		&typeIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1));
	    return TCL_ERROR;
	}
	name = Tcl_GetString(objv[i++]);

	/*
	 * If no address is given request one in the underlying function
	 */

	if (i < objc) {
	    if (Tcl_GetIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong address value", -1));
		return TCL_ERROR;
	    }
	} else {
	    addr = 0;
	}
	return Tcl_LinkArray(interp, name, (char *) addr,
		LinkTypes[typeIndex] | readonly, size);
    }
    return TCL_OK;

  wrongArgs:
    Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?");
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TestlocaleCmd --
 *
 *	This procedure implements the "testlocale" command.  It is used
Changes to tests/link.test.
16
17
18
19
20
21
22

23
24
25
26
27
28
29
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testlink [llength [info commands testlink]]


foreach i {int real bool string} {
    unset -nocomplain $i
}

test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
    testlink delete







>







16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testlink [llength [info commands testlink]]
testConstraint testlinkarray [llength [info commands testlinkarray]]

foreach i {int real bool string} {
    unset -nocomplain $i
}

test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
    testlink delete
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
} -result {1 {can't set "bool": variable must have boolean value} 1}
test link-2.5 {writing bad values into variables} -setup {
    testlink delete
} -constraints {testlink} -body {
    testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    list [catch {set wide gorp} msg] $msg $bool
} -result {1 {can't set "wide": variable must have integer value} 1}
test link-2.6 {writing C variables from Tcl} -constraints {testlink} -setup {
    testlink delete
} -body {
    testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    set int "+"
    set real "+"







|







85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
} -result {1 {can't set "bool": variable must have boolean value} 1}
test link-2.5 {writing bad values into variables} -setup {
    testlink delete
} -constraints {testlink} -body {
    testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    list [catch {set wide gorp} msg] $msg $bool
} -result {1 {can't set "wide": variable must have wide integer value} 1}
test link-2.6 {writing C variables from Tcl} -constraints {testlink} -setup {
    testlink delete
} -body {
    testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    set int "+"
    set real "+"
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
    proc x {} {
	upvar wide y
	set y abc
    }
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {}
    list [catch x msg] $msg $wide
} -result {1 {can't set "y": variable must have integer value} 778899}

test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
    proc x args {
	global x int real bool string wide
	lappend x $args $int $real $bool $string $wide
    }
    set x {}







|







360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
    proc x {} {
	upvar wide y
	set y abc
    }
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {}
    list [catch x msg] $msg $wide
} -result {1 {can't set "y": variable must have wide integer value} 778899}

test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
    proc x args {
	global x int real bool string wide
	lappend x $args $int $real $bool $string $wide
    }
    set x {}
394
395
396
397
398
399
400


































































































































































































































































































































































































































































401
402
403
404
405
406
407
} {}
test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
    testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0
    list [catch {
	testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
    } msg] $msg $int
} {0 {} 47}



































































































































































































































































































































































































































































catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0}
catch {testlink delete}
foreach i {int real bool string wide} {
    unset -nocomplain $i
}








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







395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
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
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
} {}
test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
    testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0
    list [catch {
	testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
    } msg] $msg $int
} {0 {} 47}

test link-9.1 {linkarray usage messages} {
    set mylist [list]
    catch {testlinkarray} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    catch {testlinkarray x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    catch {testlinkarray update} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    catch {testlinkarray remove} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    catch {testlinkarray create} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    catch {testlinkarray create xx 1 my} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    catch {testlinkarray create char* 0 my} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    join $mylist "\n"
} {wrong # args: should be "testlinkarray option args"
bad option "x": must be update, remove, or create


wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?"
bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary
wrong array size given}

test link-10.1 {linkarray char*} {
    set mylist [list]
    testlinkarray create char* 1 ::my(var)
    lappend mylist [set ::my(var) ""]
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    testlinkarray create char* 4 ::my(var)
    set ::my(var) x
    catch {set ::my(var) xyzz} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    testlinkarray create -r char* 4 ::my(var)
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {
can't set "::my(var)": wrong size of char* value
can't set "::my(var)": wrong size of char* value
can't set "::my(var)": linked variable is read-only}

test link-11.1 {linkarray char} {
    set mylist [list]
    testlinkarray create char 1 ::my(var)
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    lappend mylist [set ::my(var) 120]
    catch {set ::my(var) 1234} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    testlinkarray create char 4 ::my(var)
    catch {set ::my(var) {1 2 3}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    set ::my(var) {1 2 3 4}
    lappend mylist $my(var)
    testlinkarray remove ::my(var)
    testlinkarray create -r char 2 ::my(var)
    catch {set ::my(var) {1 2}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {can't set "::my(var)": variable must have char value
120
can't set "::my(var)": variable must have char value
can't set "::my(var)": wrong dimension
1 2 3 4
can't set "::my(var)": linked variable is read-only}

test link-12.1 {linkarray unsigned char} {
    set mylist [list]
    testlinkarray create uchar 1 ::my(var)
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    lappend mylist [set ::my(var) 120]
    catch {set ::my(var) 1234} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    catch {set ::my(var) -1} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    testlinkarray create uchar 4 ::my(var)
    catch {set ::my(var) {1 2 3}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    set ::my(var) {1 2 3 4}
    lappend mylist $my(var)
    testlinkarray remove ::my(var)
    testlinkarray create -r uchar 2 ::my(var)
    catch {set ::my(var) {1 2}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {can't set "::my(var)": variable must have unsigned char value
120
can't set "::my(var)": variable must have unsigned char value
can't set "::my(var)": variable must have unsigned char value
can't set "::my(var)": wrong dimension
1 2 3 4
can't set "::my(var)": linked variable is read-only}

test link-13.1 {linkarray short} {
    set mylist [list]
    testlinkarray create short 1 ::my(var)
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    lappend mylist [set ::my(var) 120]
    catch {set ::my(var) 123456} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    testlinkarray create short 4 ::my(var)
    catch {set ::my(var) {1 2 3}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    set ::my(var) {1 2 3 4}
    lappend mylist $my(var)
    testlinkarray remove ::my(var)
    testlinkarray create -r short 2 ::my(var)
    catch {set ::my(var) {1 2}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {can't set "::my(var)": variable must have short value
120
can't set "::my(var)": variable must have short value
can't set "::my(var)": wrong dimension
1 2 3 4
can't set "::my(var)": linked variable is read-only}

test link-14.1 {linkarray unsigned short} {
    set mylist [list]
    testlinkarray create ushort 1 ::my(var)
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    lappend mylist [set ::my(var) 120]
    catch {set ::my(var) 123456} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    catch {set ::my(var) -1} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    testlinkarray create ushort 4 ::my(var)
    catch {set ::my(var) {1 2 3}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    set ::my(var) {1 2 3 4}
    lappend mylist $my(var)
    testlinkarray remove ::my(var)
    testlinkarray create -r ushort 2 ::my(var)
    catch {set ::my(var) {1 2}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {can't set "::my(var)": variable must have unsigned short value
120
can't set "::my(var)": variable must have unsigned short value
can't set "::my(var)": variable must have unsigned short value
can't set "::my(var)": wrong dimension
1 2 3 4
can't set "::my(var)": linked variable is read-only}

test link-15.1 {linkarray int} {
    set mylist [list]
    testlinkarray create int 1 ::my(var)
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    lappend mylist [set ::my(var) 120]
    catch {set ::my(var) 1e3} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    testlinkarray create int 4 ::my(var)
    catch {set ::my(var) {1 2 3}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    set ::my(var) {1 2 3 4}
    lappend mylist $my(var)
    testlinkarray remove ::my(var)
    testlinkarray create -r int 2 ::my(var)
    catch {set ::my(var) {1 2}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {can't set "::my(var)": variable must have integer value
120
can't set "::my(var)": variable must have integer value
can't set "::my(var)": wrong dimension
1 2 3 4
can't set "::my(var)": linked variable is read-only}

test link-16.1 {linkarray unsigned int} {
    set mylist [list]
    testlinkarray create uint 1 ::my(var)
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    lappend mylist [set ::my(var) 120]
    catch {set ::my(var) 1e33} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    catch {set ::my(var) -1} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    testlinkarray create uint 4 ::my(var)
    catch {set ::my(var) {1 2 3}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    set ::my(var) {1 2 3 4}
    lappend mylist $my(var)
    testlinkarray remove ::my(var)
    testlinkarray create -r uint 2 ::my(var)
    catch {set ::my(var) {1 2}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {can't set "::my(var)": variable must have unsigned int value
120
can't set "::my(var)": variable must have unsigned int value
can't set "::my(var)": variable must have unsigned int value
can't set "::my(var)": wrong dimension
1 2 3 4
can't set "::my(var)": linked variable is read-only}

test link-17.1 {linkarray long} {
    set mylist [list]
    testlinkarray create long 1 ::my(var)
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    lappend mylist [set ::my(var) 120]
    catch {set ::my(var) 1e33} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    testlinkarray create long 4 ::my(var)
    catch {set ::my(var) {1 2 3}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    set ::my(var) {1 2 3 4}
    lappend mylist $my(var)
    testlinkarray remove ::my(var)
    testlinkarray create -r long 2 ::my(var)
    catch {set ::my(var) {1 2}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {can't set "::my(var)": variable must have long value
120
can't set "::my(var)": variable must have long value
can't set "::my(var)": wrong dimension
1 2 3 4
can't set "::my(var)": linked variable is read-only}

test link-18.1 {linkarray unsigned long} {
    set mylist [list]
    testlinkarray create ulong 1 ::my(var)
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    lappend mylist [set ::my(var) 120]
    catch {set ::my(var) 1e33} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    catch {set ::my(var) -1} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    testlinkarray create ulong 4 ::my(var)
    catch {set ::my(var) {1 2 3}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    set ::my(var) {1 2 3 4}
    lappend mylist $my(var)
    testlinkarray remove ::my(var)
    testlinkarray create -r ulong 2 ::my(var)
    catch {set ::my(var) {1 2}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {can't set "::my(var)": variable must have unsigned long value
120
can't set "::my(var)": variable must have unsigned long value
can't set "::my(var)": variable must have unsigned long value
can't set "::my(var)": wrong dimension
1 2 3 4
can't set "::my(var)": linked variable is read-only}

test link-19.1 {linkarray wide} {
    set mylist [list]
    testlinkarray create wide 1 ::my(var)
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    lappend mylist [set ::my(var) 120]
    catch {set ::my(var) 1e33} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    testlinkarray create wide 4 ::my(var)
    catch {set ::my(var) {1 2 3}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    set ::my(var) {1 2 3 4}
    lappend mylist $my(var)
    testlinkarray remove ::my(var)
    testlinkarray create -r wide 2 ::my(var)
    catch {set ::my(var) {1 2}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {can't set "::my(var)": variable must have wide integer value
120
can't set "::my(var)": variable must have wide integer value
can't set "::my(var)": wrong dimension
1 2 3 4
can't set "::my(var)": linked variable is read-only}

test link-20.1 {linkarray unsigned wide} {
    set mylist [list]
    testlinkarray create uwide 1 ::my(var)
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    lappend mylist [set ::my(var) 120]
    catch {set ::my(var) 1e33} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    catch {set ::my(var) -1} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    testlinkarray create uwide 4 ::my(var)
    catch {set ::my(var) {1 2 3}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    set ::my(var) {1 2 3 4}
    lappend mylist $my(var)
    testlinkarray remove ::my(var)
    testlinkarray create -r uwide 2 ::my(var)
    catch {set ::my(var) {1 2}} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {can't set "::my(var)": variable must have unsigned wide int value
120
can't set "::my(var)": variable must have unsigned wide int value
can't set "::my(var)": variable must have unsigned wide int value
can't set "::my(var)": wrong dimension
1 2 3 4
can't set "::my(var)": linked variable is read-only}

test link-21.1 {linkarray string} {
    set mylist [list]
    testlinkarray create string 1 ::my(var)
    lappend mylist [set ::my(var) ""]
    lappend mylist [set ::my(var) "xyz"]
    lappend mylist $::my(var)
    testlinkarray remove ::my(var)
    testlinkarray create -r string 4 ::my(var)
    catch {set ::my(var) x} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {
xyz
xyz
can't set "::my(var)": linked variable is read-only}

test link-22.1 {linkarray binary} {
    set mylist [list]
    testlinkarray create binary 1 ::my(var)
    set ::my(var) x
    catch {set ::my(var) xy} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    lappend mylist $::my(var)
    testlinkarray remove ::my(var)
    testlinkarray create binary 4 ::my(var)
    catch {set ::my(var) abc} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    catch {set ::my(var) abcde} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    set ::my(var) abcd
    lappend mylist $::my(var)
    testlinkarray remove ::my(var)
    testlinkarray create -r binary 4 ::my(var)
    catch {set ::my(var) xyzv} my(msg)
    lappend mylist $my(msg)
    unset my(msg)
    testlinkarray remove ::my(var)
    unset my
    join $mylist "\n"
} {can't set "::my(var)": wrong size of binary value
x
can't set "::my(var)": wrong size of binary value
can't set "::my(var)": wrong size of binary value
abcd
can't set "::my(var)": linked variable is read-only}

catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0}
catch {testlink delete}
foreach i {int real bool string wide} {
    unset -nocomplain $i
}