Tcl Source Code

Check-in [258100c83e]
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:Clean up and refactor a bit
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-312-new
Files: files | file ages | folders
SHA3-256: 258100c83e5d8deaf8f71644ce822c8979c717f882738bc8dbee2b796bf8dc8e
User & Date: dkf 2019-04-04 23:47:38
Context
2019-04-05
18:37
More efficient version (after feedback from KBK). Better test too. check-in: 41a632a0b1 user: dkf tags: tip-312-new
2019-04-04
23:47
Clean up and refactor a bit check-in: 258100c83e user: dkf tags: tip-312-new
23:08
Now with fewer memory leaks check-in: edef464b4f user: dkf tags: tip-312-new
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to generic/tclLink.c.

     5      5    *	Tcl variable). The idea of linked variables was first suggested by
     6      6    *	Andreas Stolcke and this implementation is based heavily on a
     7      7    *	prototype implementation provided by him.
     8      8    *
     9      9    * Copyright (c) 1993 The Regents of the University of California.
    10     10    * Copyright (c) 1994-1997 Sun Microsystems, Inc.
    11     11    * Copyright (c) 2008 Rene Zaumseil
           12  + * Copyright (c) 2019 Donal K. Fellows
    12     13    *
    13     14    * See the file "license.terms" for information on usage and redistribution of
    14     15    * this file, and for a DISCLAIMER OF ALL WARRANTIES.
    15     16    */
    16     17   
    17     18   #include "tclInt.h"
    18     19   #include "tommath.h"
................................................................................
    94     95    */
    95     96   
    96     97   static char *		LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
    97     98   			    const char *name1, const char *name2, int flags);
    98     99   static Tcl_Obj *	ObjValue(Link *linkPtr);
    99    100   static void		LinkFree(Link *linkPtr);
   100    101   static int		GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr);
   101         -static int		GetInvalidWideFromObj(Tcl_Obj *objPtr,
   102         -			    Tcl_WideInt *widePtr);
   103    102   static int		GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
   104    103   			    double *doublePtr);
          104  +static int		SetInvalidRealFromAny(Tcl_Interp *interp,
          105  +			    Tcl_Obj *objPtr);
          106  +
          107  +/*
          108  + * A marker type used to flag weirdnesses so we can pass them around right.
          109  + */
          110  +
          111  +static Tcl_ObjType invalidRealType = {
          112  +    "invalidReal",			/* name */
          113  +    NULL,				/* freeIntRepProc */
          114  +    NULL,				/* dupIntRepProc */
          115  +    NULL,				/* updateStringProc */
          116  +    NULL				/* setFromAnyProc */
          117  +};
   105    118   
   106    119   /*
   107    120    * Convenience macro for accessing the value of the C variable pointed to by a
   108    121    * link. Note that this macro produces something that may be regarded as an
   109    122    * lvalue or rvalue; it may be assigned to as well as read. Also note that
   110    123    * this macro assumes the name of the variable being accessed (linkPtr); this
   111    124    * is not strictly a good thing, but it keeps the code much shorter and
................................................................................
   436    449       linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
   437    450   	    TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
   438    451       if (linkPtr != NULL) {
   439    452   	linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
   440    453       }
   441    454   }
   442    455   
          456  +/*
          457  + *----------------------------------------------------------------------
          458  + *
          459  + * GetInt, GetWide, GetUWide, GetDouble, EqualDouble, IsSpecial --
          460  + *
          461  + *	Helper functions for LinkTraceProc and ObjValue. These are all
          462  + *	factored out here to make those functions simpler.
          463  + *
          464  + *----------------------------------------------------------------------
          465  + */
          466  +
   443    467   static inline int
   444    468   GetInt(
   445    469       Tcl_Obj *objPtr,
   446    470       int *intPtr)
   447    471   {
   448    472       return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK
   449    473   	    && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK);
................................................................................
   450    474   }
   451    475   
   452    476   static inline int
   453    477   GetWide(
   454    478       Tcl_Obj *objPtr,
   455    479       Tcl_WideInt *widePtr)
   456    480   {
   457         -    return (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK
   458         -	    && GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK);
          481  +    if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) {
          482  +	int intValue;
          483  +
          484  +	if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
          485  +	    return 1;
          486  +	}
          487  +	*widePtr = intValue;
          488  +    }
          489  +    return 0;
   459    490   }
   460    491   
   461    492   static inline int
   462    493   GetUWide(
   463    494       Tcl_Obj *objPtr,
   464    495       Tcl_WideUInt *uwidePtr)
   465    496   {
   466    497       Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr;
   467    498       ClientData clientData;
   468         -    int type;
          499  +    int type, intValue;
   469    500   
   470    501       if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) {
   471    502   	if (type == TCL_NUMBER_INT) {
   472    503   	    *widePtr = *((const Tcl_WideInt *) clientData);
   473    504   	    return (*widePtr < 0);
   474    505   	} else if (type == TCL_NUMBER_BIG) {
   475    506   	    mp_int num;
................................................................................
   505    536   	}
   506    537       }
   507    538   
   508    539       /*
   509    540        * Evil edge case fallback.
   510    541        */
   511    542   
   512         -    return (GetInvalidWideFromObj(objPtr, widePtr) != TCL_OK);
          543  +    if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
          544  +	return 1;
          545  +    }
          546  +    *uwidePtr = intValue;
          547  +    return 0;
   513    548   }
   514    549   
   515    550   static inline int
   516    551   GetDouble(
   517    552       Tcl_Obj *objPtr,
   518    553       double *dblPtr)
   519    554   {
................................................................................
   523    558   #ifdef ACCEPT_NAN
   524    559   	Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclDoubleType);
   525    560   
   526    561   	if (irPtr != NULL) {
   527    562   	    *dblPtr = irPtr->doubleValue;
   528    563   	    return 0;
   529    564   	}
   530         -#endif
          565  +#endif /* ACCEPT_NAN */
   531    566   	return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK;
   532    567       }
   533    568   }
   534    569   
   535    570   static inline int
   536    571   EqualDouble(
   537    572       double a,
   538    573       double b)
   539    574   {
   540    575       return (a == b)
   541    576   #ifdef ACCEPT_NAN
   542    577   	|| (TclIsNaN(a) && TclIsNaN(b))
   543         -#endif
          578  +#endif /* ACCEPT_NAN */
   544    579   	;
   545    580   }
   546    581   
   547    582   static inline int
   548    583   IsSpecial(
   549    584       double a)
   550    585   {
   551    586       return TclIsInfinite(a)
   552    587   #ifdef ACCEPT_NAN
   553    588   	|| TclIsNaN(a)
   554         -#endif
          589  +#endif /* ACCEPT_NAN */
   555    590   	;
   556    591   }
          592  +
          593  +/*
          594  + * Mark an object as holding a weird double.
          595  + */
          596  +
          597  +static int
          598  +SetInvalidRealFromAny(
          599  +    Tcl_Interp *interp,
          600  +    Tcl_Obj *objPtr)
          601  +{
          602  +    const char *str;
          603  +    const char *endPtr;
          604  +
          605  +    str = TclGetString(objPtr);
          606  +    if ((objPtr->length == 1) && (str[0] == '.')) {
          607  +	objPtr->typePtr = &invalidRealType;
          608  +	objPtr->internalRep.doubleValue = 0.0;
          609  +	return TCL_OK;
          610  +    }
          611  +    if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr,
          612  +	    TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
          613  +	/*
          614  +	 * If number is followed by [eE][+-]?, then it is an invalid
          615  +	 * double, but it could be the start of a valid double.
          616  +	 */
          617  +
          618  +	if (*endPtr == 'e' || *endPtr == 'E') {
          619  +	    ++endPtr;
          620  +	    if (*endPtr == '+' || *endPtr == '-') {
          621  +		++endPtr;
          622  +	    }
          623  +	    if (*endPtr == 0) {
          624  +		double doubleValue = 0.0;
          625  +
          626  +		Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
          627  +		TclFreeIntRep(objPtr);
          628  +		objPtr->typePtr = &invalidRealType;
          629  +		objPtr->internalRep.doubleValue = doubleValue;
          630  +		return TCL_OK;
          631  +	    }
          632  +	}
          633  +    }
          634  +    return TCL_ERROR;
          635  +}
          636  +
          637  +/*
          638  + * This function checks for integer representations, which are valid
          639  + * when linking with C variables, but which are invalid in other
          640  + * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o"
          641  + * (upperand lowercase). See bug [39f6304c2e].
          642  + */
          643  +
          644  +static int
          645  +GetInvalidIntFromObj(
          646  +    Tcl_Obj *objPtr,
          647  +    int *intPtr)
          648  +{
          649  +    const char *str = TclGetString(objPtr);
          650  +
          651  +    if ((objPtr->length == 0) || ((objPtr->length == 2) && (str[0] == '0')
          652  +	    && strchr("xXbBoOdD", str[1]))) {
          653  +	*intPtr = 0;
          654  +	return TCL_OK;
          655  +    } else if ((objPtr->length == 1) && strchr("+-", str[0])) {
          656  +	*intPtr = (str[0] == '+');
          657  +	return TCL_OK;
          658  +    }
          659  +    return TCL_ERROR;
          660  +}
          661  +
          662  +/*
          663  + * This function checks for double representations, which are valid
          664  + * when linking with C variables, but which are invalid in other
          665  + * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o"
          666  + * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
          667  + */
          668  +
          669  +static int
          670  +GetInvalidDoubleFromObj(
          671  +    Tcl_Obj *objPtr,
          672  +    double *doublePtr)
          673  +{
          674  +    int intValue;
          675  +
          676  +    if (TclHasIntRep(objPtr, &invalidRealType)) {
          677  +	goto gotdouble;
          678  +    }
          679  +    if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) {
          680  +	*doublePtr = (double) intValue;
          681  +	return TCL_OK;
          682  +    }
          683  +    if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) {
          684  +    gotdouble:
          685  +	*doublePtr = objPtr->internalRep.doubleValue;
          686  +	return TCL_OK;
          687  +    }
          688  +    return TCL_ERROR;
          689  +}
   557    690   
   558    691   /*
   559    692    *----------------------------------------------------------------------
   560    693    *
   561    694    * LinkTraceProc --
   562    695    *
   563    696    *	This function is invoked when a linked Tcl variable is read, written,
................................................................................
  1329   1462        */
  1330   1463   
  1331   1464       default:
  1332   1465   	TclNewLiteralStringObj(resultObj, "??");
  1333   1466   	return resultObj;
  1334   1467       }
  1335   1468   }
  1336         -
  1337         -static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
  1338         -
  1339         -static Tcl_ObjType invalidRealType = {
  1340         -    "invalidReal",			/* name */
  1341         -    NULL,				/* freeIntRepProc */
  1342         -    NULL,				/* dupIntRepProc */
  1343         -    NULL,				/* updateStringProc */
  1344         -    NULL				/* setFromAnyProc */
  1345         -};
  1346         -
  1347         -static int
  1348         -SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) {
  1349         -    const char *str;
  1350         -    const char *endPtr;
  1351         -
  1352         -    str = TclGetString(objPtr);
  1353         -    if ((objPtr->length == 1) && (str[0] == '.')){
  1354         -	objPtr->typePtr = &invalidRealType;
  1355         -	objPtr->internalRep.doubleValue = 0.0;
  1356         -	return TCL_OK;
  1357         -    }
  1358         -    if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr,
  1359         -	    TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
  1360         -	/* If number is followed by [eE][+-]?, then it is an invalid
  1361         -	 * double, but it could be the start of a valid double. */
  1362         -	if (*endPtr == 'e' || *endPtr == 'E') {
  1363         -	    ++endPtr;
  1364         -	    if (*endPtr == '+' || *endPtr == '-') ++endPtr;
  1365         -	    if (*endPtr == 0) {
  1366         -		double doubleValue = 0.0;
  1367         -		Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
  1368         -		TclFreeIntRep(objPtr);
  1369         -		objPtr->typePtr = &invalidRealType;
  1370         -		objPtr->internalRep.doubleValue = doubleValue;
  1371         -		return TCL_OK;
  1372         -	    }
  1373         -	}
  1374         -    }
  1375         -    return TCL_ERROR;
  1376         -}
  1377         -
  1378         -
  1379         -/*
  1380         - * This function checks for integer representations, which are valid
  1381         - * when linking with C variables, but which are invalid in other
  1382         - * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o"
  1383         - * (upperand lowercase). See bug [39f6304c2e].
  1384         - */
  1385         -
  1386         -int
  1387         -GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr)
  1388         -{
  1389         -    const char *str = TclGetString(objPtr);
  1390         -
  1391         -    if ((objPtr->length == 0) ||
  1392         -	    ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) {
  1393         -	*intPtr = 0;
  1394         -	return TCL_OK;
  1395         -    } else if ((objPtr->length == 1) && strchr("+-", str[0])) {
  1396         -	*intPtr = (str[0] == '+');
  1397         -	return TCL_OK;
  1398         -    }
  1399         -    return TCL_ERROR;
  1400         -}
  1401         -
  1402         -int
  1403         -GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr)
  1404         -{
  1405         -    int intValue;
  1406         -
  1407         -    if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
  1408         -	return TCL_ERROR;
  1409         -    }
  1410         -    *widePtr = intValue;
  1411         -    return TCL_OK;
  1412         -}
  1413         -
  1414         -/*
  1415         - * This function checks for double representations, which are valid
  1416         - * when linking with C variables, but which are invalid in other
  1417         - * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o"
  1418         - * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
  1419         - */
  1420         -
  1421         -int
  1422         -GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr)
  1423         -{
  1424         -    int intValue;
  1425         -
  1426         -    if (TclHasIntRep(objPtr, &invalidRealType)) {
  1427         -	goto gotdouble;
  1428         -    }
  1429         -    if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) {
  1430         -	*doublePtr = (double) intValue;
  1431         -	return TCL_OK;
  1432         -    }
  1433         -    if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) {
  1434         -    gotdouble:
  1435         -	*doublePtr = objPtr->internalRep.doubleValue;
  1436         -	return TCL_OK;
  1437         -    }
  1438         -    return TCL_ERROR;
  1439         -}
  1440   1469   
  1441   1470   /*
  1442   1471    *----------------------------------------------------------------------
  1443   1472    *
  1444   1473    * LinkFree --
  1445   1474    *
  1446   1475    *	Free's allocated space of given link and link structure.