Tcl Source Code

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

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

Overview
Comment:merge core-8-6-branch
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: eb8b79d49c75aa73a1d0452a450ecc71098c41e0
User & Date: jan.nijtmans 2017-01-01 19:49:56
Context
2017-02-28
13:39
Implement the ?targetNamespace? parameter for [oo::copy] check-in: 998812b7db user: limeboy tags: oo-copy-ns
2017-01-04
11:55
merge core-8-6-branch check-in: 13dc69ec99 user: jan.nijtmans tags: trunk
2017-01-02
14:31
[win] bug fix in NativeGetTime: each call of it blurs current performance counters actualized in cal... check-in: b6fc234ef3 user: sebres tags: bug_b87ad7e914
2017-01-01
19:50
merge trunk check-in: d8746f0cb8 user: jan.nijtmans tags: novem
19:49
merge core-8-6-branch check-in: eb8b79d49c user: jan.nijtmans tags: trunk
19:46
Fix [39f6304c2e]: Tcl_LinkVar is not tolerant to minus, plus, dot check-in: 07bc29650e user: jan.nijtmans tags: core-8-6-branch
19:10
Update zlib to version 1.2.9. Dll's and *.lib files not updated yet check-in: 4b7084a579 user: jan.nijtmans tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclLink.c.

63
64
65
66
67
68
69




70
71
72
73
74
75
76
...
376
377
378
379
380
381
382


383
384
385

386
387
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
...
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
...
629
630
631
632
633
634
635
636











































637















































638
639
640
641
642
643
/*
 * 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);





/*
 * 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
................................................................................
	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) {


	    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) {


	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have integer value";
	} else {

	    LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
	}

	break;

    case TCL_LINK_DOUBLE:
	if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d)
		!= TCL_OK) {
#ifdef ACCEPT_NAN
	    if (valueObj->typePtr != &tclDoubleType) {
#endif


		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
		return (char *) "variable must have real value";

#ifdef ACCEPT_NAN
	    } else {
		linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
	    }

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

    case TCL_LINK_BOOLEAN:
	if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i)
................................................................................
	}
	LinkedVar(int) = linkPtr->lastValue.i;
	break;

    case TCL_LINK_CHAR:
	if (Tcl_GetIntFromObj(NULL, 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";

	}
	linkPtr->lastValue.c = (char)valueInt;
	LinkedVar(char) = linkPtr->lastValue.c;
	break;

    case TCL_LINK_UCHAR:
	if (Tcl_GetIntFromObj(NULL, 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";

	}
	linkPtr->lastValue.uc = (unsigned char) valueInt;
	LinkedVar(unsigned char) = linkPtr->lastValue.uc;
	break;

    case TCL_LINK_SHORT:
	if (Tcl_GetIntFromObj(NULL, 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";

	}
	linkPtr->lastValue.s = (short)valueInt;
	LinkedVar(short) = linkPtr->lastValue.s;
	break;

    case TCL_LINK_USHORT:
	if (Tcl_GetIntFromObj(NULL, 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";

	}
	linkPtr->lastValue.us = (unsigned short)valueInt;
	LinkedVar(unsigned short) = linkPtr->lastValue.us;
	break;

    case TCL_LINK_UINT:
	if (Tcl_GetWideIntFromObj(NULL, 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";


	} else {
	    linkPtr->lastValue.ui = (unsigned int)valueWide;
	}
	LinkedVar(unsigned int) = linkPtr->lastValue.ui;
	break;

    case TCL_LINK_LONG:
	if (Tcl_GetWideIntFromObj(NULL, 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";


	} else {
	    linkPtr->lastValue.l = (long)valueWide;
	}
	LinkedVar(long) = linkPtr->lastValue.l;
	break;

    case TCL_LINK_ULONG:
	if (Tcl_GetWideIntFromObj(NULL, 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";


	} else {
	    linkPtr->lastValue.ul = (unsigned long)valueWide;
	}
	LinkedVar(unsigned long) = linkPtr->lastValue.ul;
	break;

    case TCL_LINK_WIDE_UINT:
	/*
	 * FIXME: represent as a bignum.
	 */
	if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK) {


	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    return (char *) "variable must have unsigned wide int value";


	} else {
	    linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
	}
	LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
	break;

    case TCL_LINK_FLOAT:
	if (Tcl_GetDoubleFromObj(NULL, 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";
	} else {
	    linkPtr->lastValue.f = (float)valueDouble;
	}


	LinkedVar(float) = linkPtr->lastValue.f;
	break;

    case TCL_LINK_STRING:
	value = TclGetStringFromObj(valueObj, &valueLength);
	valueLength++;
	pp = (char **) linkPtr->addr;
................................................................................
     */

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











































/*















































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






>
>
>
>







 







>
>
|

|
>







>
>
|

|
<
>
|

>








>
>
|
|
|
>

<
<

>







 







>
>
|
|
|
>








>
>
|
|
|
>








>
>
|
|
|
>








>
>
|
|
|
>








>
>
|
|
|
>
>









>
>
|
|
|
>
>









>
>
|
|
|
>
>











>
>
|
|
|
>
>









>
>
|
|
|
<
<
|
>
>







 







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

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






63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
...
380
381
382
383
384
385
386
387
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
...
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
...
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
/*
 * 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		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
................................................................................
	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) {
	    if (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) {
	    if (GetInvalidIntFromObj(valueObj, &valueInt)
		    != TCL_OK) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
		return (char *) "variable must have integer value";

	    }
	    linkPtr->lastValue.w = (Tcl_WideInt) valueInt;
	}
	LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
	break;

    case TCL_LINK_DOUBLE:
	if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d)
		!= TCL_OK) {
#ifdef ACCEPT_NAN
	    if (valueObj->typePtr != &tclDoubleType) {
#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 = valueObj->internalRep.doubleValue;
#endif
	}
	LinkedVar(double) = linkPtr->lastValue.d;
	break;

    case TCL_LINK_BOOLEAN:
	if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i)
................................................................................
	}
	LinkedVar(int) = linkPtr->lastValue.i;
	break;

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

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

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

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

    case TCL_LINK_UINT:
	if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
		|| valueWide < 0 || valueWide > UINT_MAX) {
	    if (GetInvalidIntFromObj(valueObj, &valueInt)
		    != TCL_OK) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
			TCL_GLOBAL_ONLY);
		return (char *) "variable must have unsigned int value";
	    }
	    linkPtr->lastValue.ui = (unsigned int)valueInt;
	} else {
	    linkPtr->lastValue.ui = (unsigned int)valueWide;
	}
	LinkedVar(unsigned int) = linkPtr->lastValue.ui;
	break;

    case TCL_LINK_LONG:
	if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
		|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
	    if (GetInvalidIntFromObj(valueObj, &valueInt)
		    != TCL_OK) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
			TCL_GLOBAL_ONLY);
		return (char *) "variable must have long value";
	    }
	    linkPtr->lastValue.l = (long)valueInt;
	} else {
	    linkPtr->lastValue.l = (long)valueWide;
	}
	LinkedVar(long) = linkPtr->lastValue.l;
	break;

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

    case TCL_LINK_WIDE_UINT:
	/*
	 * FIXME: represent as a bignum.
	 */
	if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK) {
	    if (GetInvalidIntFromObj(valueObj, &valueInt)
		    != TCL_OK) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
			TCL_GLOBAL_ONLY);
		return (char *) "variable must have unsigned wide int value";
	    }
	    linkPtr->lastValue.uw = (Tcl_WideUInt)valueInt;
	} else {
	    linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
	}
	LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
	break;

    case TCL_LINK_FLOAT:
	if (Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK
		|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
	    if (GetInvalidDoubleFromObj(valueObj, &valueDouble)
		    != TCL_OK) {
		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
			TCL_GLOBAL_ONLY);
		return (char *) "variable must have float value";


	    }
	}
	linkPtr->lastValue.f = (float)valueDouble;
	LinkedVar(float) = linkPtr->lastValue.f;
	break;

    case TCL_LINK_STRING:
	value = TclGetStringFromObj(valueObj, &valueLength);
	valueLength++;
	pp = (char **) linkPtr->addr;
................................................................................
     */

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

static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);

static Tcl_ObjType invalidRealType = {
    "invalidReal",			/* name */
    NULL,				/* freeIntRepProc */
    NULL,				/* dupIntRepProc */
    NULL,				/* updateStringProc */
    SetInvalidRealFromAny		/* setFromAnyProc */
};

static int
SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) {
    int length;
    const char *str;
    const char *endPtr;

    str = TclGetStringFromObj(objPtr, &length);
    if ((length == 1) && (str[0] == '.')){
	objPtr->typePtr = &invalidRealType;
	objPtr->internalRep.doubleValue = 0.0;
	return TCL_OK;
    }
    if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr,
	    TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
	/* If number is followed by [eE][+-]?, then it is an invalid
	 * double, but it could be the start of a valid double. */
	if (*endPtr == 'e' || *endPtr == 'E') {
	    ++endPtr;
	    if (*endPtr == '+' || *endPtr == '-') ++endPtr;
	    if (*endPtr == 0) {
		double doubleValue = 0.0;
		Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
		if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr);
		objPtr->typePtr = &invalidRealType;
		objPtr->internalRep.doubleValue = doubleValue;
		return TCL_OK;
	    }
	}
    }
    return TCL_ERROR;
}


/*
 * 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" and "0o" (upper-
 * and lowercase). See bug [39f6304c2e].
 */
int
GetInvalidIntFromObj(Tcl_Obj *objPtr,
				int *intPtr)
{
    int length;
    const char *str = TclGetStringFromObj(objPtr, &length);

    if ((length == 1) && strchr("+-", str[0])) {
	*intPtr = (str[0] == '+');
	return TCL_OK;
    } else if ((length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1])) {
	*intPtr = 0;
	return TCL_OK;
    }
    return TCL_ERROR;
}

/*
 * 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, result;

    if ((objPtr->typePtr == &invalidRealType) ||
	    (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK)) {
	*doublePtr = objPtr->internalRep.doubleValue;
	return TCL_OK;
    }
    result = GetInvalidIntFromObj(objPtr, &intValue);
    if (result == TCL_OK) {
	*doublePtr = (double) intValue;
    }
    return result;
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to generic/tclTest.c.

3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    Tcl_WideInt argv1 = 0;

    if (objc < 2 || objc > 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "format wideint");   
    }

    if (objc > 1) {
	Tcl_GetWideIntFromObj(interp, objv[2], &argv1);
    }
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1));
    return TCL_OK;






|







3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* The argument objects. */
{
    Tcl_WideInt argv1 = 0;

    if (objc < 2 || objc > 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "format wideint");
    }

    if (objc > 1) {
	Tcl_GetWideIntFromObj(interp, objv[2], &argv1);
    }
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1));
    return TCL_OK;

Changes to tests/link.test.

85
86
87
88
89
90
91




















































































92
93
94
95
96
97
98
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-3.1 {read-only variables} -constraints {testlink} -setup {
    testlink delete
} -body {
    testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 0 1 1 0 0 0 0 0 0 0 0 0 0 0
    list [catch {set int 4} msg] $msg $int \






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







85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
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 "+"
    set bool 1
    set string "+"
    set wide "+"
    set char "+"
    set uchar "+"
    set short "+"
    set ushort "+"
    set uint "+"
    set long "+"
    set ulong "+"
    set float "+"
    set uwide "+"
    concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
} -result {1 1.0 1 + 1 1 1 1 1 1 1 1 1.0 1 | + + 1 + + + + + + + + + + +}
test link-2.7 {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 "-"
    set bool 0
    set string "-"
    set wide "-"
    set char "-"
    set uchar "-"
    set short "-"
    set ushort "-"
    set uint "-"
    set long "-"
    set ulong "-"
    set float "-"
    set uwide "-"
    concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
} -result {0 0.0 0 - 0 0 0 0 0 0 0 0 0.0 0 | - - 0 - - - - - - - - - - -}
test link-2.8 {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 "0x"
    set real "0b"
    set bool 0
    set string "0"
    set wide "0O"
    set char "0X"
    set uchar "0B"
    set short "0O"
    set ushort "0x"
    set uint "0b"
    set long "0o"
    set ulong "0X"
    set float "0B"
    set uwide "0O"
    concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
} -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0O 0X 0B 0O 0x 0b 0o 0X 0B 0O}
test link-2.8 {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 0
    set real 5000e
    set bool 0
    set string 0
    set wide 0
    set char 0
    set uchar 0
    set short 0
    set ushort 0
    set uint 0
    set long 0
    set ulong 0
    set float -60.00e+
    set uwide 0
    concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
} -result {0 5000.0 0 0 0 0 0 0 0 0 0 0 -60.0 0 | 0 5000e 0 0 0 0 0 0 0 0 0 0 -60.00e+ 0}

test link-3.1 {read-only variables} -constraints {testlink} -setup {
    testlink delete
} -body {
    testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 0 1 1 0 0 0 0 0 0 0 0 0 0 0
    list [catch {set int 4} msg] $msg $int \