merge 8.7

Implement TCL_LINK_D(long double), which could have size_t of 8 (same as double), 10 or 16 on various platforms. Since Tcl doesn't have long double, the Tcl side will use double's

generic/tcl.decls

@@ -2330,6 +2330,12 @@ declare 631 {
 	    ClientData callbackData)
 }
 
+# TIP #312
+declare 633 {
+    int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, char *addr,
+	    int type, size_t size)
+}
+
 # ----- BASELINE -- FOR -- 8.7.0 ----- #
 
 

generic/tcl.h

@@ -1082,30 +1082,76 @@ typedef struct Tcl_DString {
 #   define TCL_PARSE_PART1	0x400
 #endif /* !TCL_NO_DEPRECATED */
 
+/*
+ * Types for Tcl_GetValue():
+ */
+
+#define TCL_TYPE_I(type) (0x100 | (int)sizeof(type)) /* signed integer */
+#define TCL_TYPE_U(type) (0x200 | (int)sizeof(type)) /* unsigned integer */
+#define TCL_TYPE_D(type) (0x300 | (int)sizeof(type)) /* float/double/long double */
+
 /*
  * Types for linked variables:
  */
 
-#define TCL_LINK_INT		1
-#define TCL_LINK_DOUBLE		2
-#define TCL_LINK_BOOLEAN	3
-#define TCL_LINK_STRING		4
-#define TCL_LINK_WIDE_INT	5
-#define TCL_LINK_CHAR		6
-#define TCL_LINK_UCHAR		7
-#define TCL_LINK_SHORT		8
-#define TCL_LINK_USHORT		9
-#define TCL_LINK_UINT		10
+#define TCL_TYPE_X(type) (0x400 | (int)sizeof(type)) /* Hexadecimal */
+#define TCL_TYPE_B(type) (0x500 | (int)sizeof(type)) /* Boolean */
+#define TCL_TYPE_C(type) (0xa00 | (int)sizeof(type)) /* Complex */
+
+#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl)
+/* Here are the legacy values 1-14, will be removed in Tcl 9.0 */
+#define TCL_LINK_INT          1 /* 32bit int -> int */
+#define TCL_LINK_DOUBLE       2 /* 64bit double -> double */
+#define TCL_LINK_BOOLEAN      3 /* tcl boolean -> int */
+#define TCL_LINK_STRING       4 /* 8bit chars -> ckalloc'd string */
+#define TCL_LINK_WIDE_INT     5 /* 64bit int -> Tcl_WideInt */
+#define TCL_LINK_CHAR         6 /* 8bit int -> char */
+#define TCL_LINK_UCHAR        7 /* 8bit uint -> unsigned char */
+#define TCL_LINK_SHORT        8 /* 16bit int -> short */
+#define TCL_LINK_USHORT       9 /* 16bit int -> unsigned short */
+#define TCL_LINK_UINT        10 /* 32bit uint -> int */
 #if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__)
-#define TCL_LINK_LONG		((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT)
-#define TCL_LINK_ULONG		((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT)
+#define TCL_LINK_LONG        ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT)
+#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
+#define TCL_LINK_LONG        11 /* long -> long */
+#define TCL_LINK_ULONG       12 /* unsigned long -> unsigned long */
 #endif
-#define TCL_LINK_FLOAT		13
-#define TCL_LINK_WIDE_UINT	14
-#define TCL_LINK_READ_ONLY	0x80
+#define TCL_LINK_FLOAT       13 /* 32bit float -> double */
+#define TCL_LINK_WIDE_UINT   14 /* 64bit uint -> wide TODO bignum */
+#else
+
+/* These are the new values, available starting with Tcl 8.7 */
+#define TCL_LINK_INT         TCL_TYPE_I(int)         /* 32bit int -> int */
+#define TCL_LINK_DOUBLE      TCL_TYPE_D(double)      /* 64bit double -> double */
+#define TCL_LINK_BOOLEAN     TCL_TYPE_B(int)         /* tcl boolean -> int */
+#define TCL_LINK_STRING      0                       /* 8bit chars -> ckalloc'd string */
+#define TCL_LINK_WIDE_INT    TCL_TYPE_I(Tcl_WideInt) /* 64bit int -> Tcl_WideInt */
+#define TCL_LINK_CHAR        TCL_TYPE_I(char)        /* 8bit int -> char */
+#define TCL_LINK_UCHAR       TCL_TYPE_U(char)        /* 8bit uint -> unsigned char */
+#define TCL_LINK_SHORT       TCL_TYPE_I(short)       /* 16bit int -> short */
+#define TCL_LINK_USHORT      TCL_TYPE_U(short)       /* 16bit int -> unsigned short */
+#define TCL_LINK_UINT        TCL_TYPE_U(int)         /* 32bit uint -> int */
+#define TCL_LINK_LONG        TCL_TYPE_I(long)
+#define TCL_LINK_ULONG       TCL_TYPE_U(long)
+#define TCL_LINK_FLOAT       TCL_TYPE_D(float)       /* 32bit float -> double */
+#define TCL_LINK_WIDE_UINT   TCL_TYPE_U(Tcl_WideInt) /* 64bit uint -> wide TODO bignum */
+#endif
+
+#define TCL_LINK_CHARS       0x901                   /* 8bit chars -> null terminated string
+                                                        last char will always set to \0 */
+#define TCL_LINK_BINARY      0x601                   /* fixed size binary byte array */
+#define TCL_LINK_BITARRAY8   0x701                   /* 8bit uint -> string, 8 chars 0|1 */
+#define TCL_LINK_BITARRAY16  0x702                   /* 16bit uint -> string, 16 chars 0|1 */
+#define TCL_LINK_BITARRAY32  0x704                   /* 32bit uint -> string, 32 chars 0|1 */
+#define TCL_LINK_BITARRAY64  0x708                   /* 64bit uint -> string, 64 chars 0|1 */
+#define TCL_LINK_BIT8        0x801                   /* bit in 8bit uint -> int (0|1) */
+#define TCL_LINK_BIT16       0x802                   /* bit in 16bit uint -> int (0|1) */
+#define TCL_LINK_BIT32       0x804                   /* bit in 32bit uint -> int (0|1) */
+#define TCL_LINK_BIT64       0x808                   /* bit in 64bit uint -> int (0|1) */
+#define TCL_LINK_S5FLOAT     0x904                   /* Siemens S5 32bit uint -> double */
+#define TCL_LINK_S5TIME      0x902                   /* Siemens S5 16bit uint -> double */
+#define TCL_LINK_READ_ONLY 0x80
 
 /*
  *----------------------------------------------------------------------------

generic/tclDecls.h

@@ -1838,6 +1838,11 @@ EXTERN Tcl_Channel	Tcl_OpenTcpServerEx(Tcl_Interp *interp,
 				unsigned int flags,
 				Tcl_TcpAcceptProc *acceptProc,
 				ClientData callbackData);
+/* Slot 632 is reserved */
+/* 633 */
+EXTERN int		Tcl_LinkArray(Tcl_Interp *interp,
+				const char *varName, char *addr, int type,
+				size_t size);
 
 typedef struct {
     const struct TclPlatStubs *tclPlatStubs;
@@ -2505,6 +2510,8 @@ typedef struct TclStubs {
     int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
     void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
     Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */
+    void (*reserved632)(void);
+    int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, char *addr, int type, size_t size); /* 633 */
 } TclStubs;
 
 extern const TclStubs *tclStubsPtr;
@@ -3799,6 +3806,9 @@ extern const TclStubs *tclStubsPtr;
 	(tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */
 #define Tcl_OpenTcpServerEx \
 	(tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */
+/* Slot 632 is reserved */
+#define Tcl_LinkArray \
+	(tclStubsPtr->tcl_LinkArray) /* 633 */
 
 #endif /* defined(USE_TCL_STUBS) */
 

generic/tclStubInit.c

@@ -1587,6 +1587,8 @@ const TclStubs tclStubs = {
     Tcl_FSUnloadFile, /* 629 */
     Tcl_ZlibStreamSetCompressionDictionary, /* 630 */
     Tcl_OpenTcpServerEx, /* 631 */
+    0, /* 632 */
+    Tcl_LinkArray, /* 633 */
 };
 
 /* !END!: Do not edit above this line. */

generic/tclTest.c

@@ -302,6 +302,9 @@ static int		TestinterpdeleteCmd(ClientData dummy,
 			    Tcl_Interp *interp, int argc, const char **argv);
 static int		TestlinkCmd(ClientData dummy,
 			    Tcl_Interp *interp, int argc, const char **argv);
+static int		TestlinkarrayCmd(ClientData dummy,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 static int		TestlocaleCmd(ClientData dummy,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -652,6 +655,7 @@ Tcltest_Init(
     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);
@@ -3269,6 +3273,154 @@ TestlinkCmd(
     return TCL_OK;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestlinkarrayCmd --
+ *	This procedure implements the "testlinkarray" command.  It is used
+ *	to test Tcl_LinkArray and related library procedures.
+ *	Additionally it can be used as an example on how to implement
+ *	a script link command with access to internal TCL_Link* functions.
+ *	It is not a global tcl command because of security reasons.
+ *	Use it in your extension on your own risk.
+ *
+ * Usage:
+ * 	testlinkobj update <name> ..
+ * 	  Update given Tcl-variables with content from C-address
+ * 	testlinkobj remove <name> ..
+ * 	  Remove link to C-variable. Free C-variable if it was created in
+ * 	  "create" command.
+ * 	testlinkobj create ?-readonly? <type> <size> <name> ?address?
+ * 	  Create new linked variable. If "-readonly" is given variable can
+ * 	  only be read from tcl side. If address is given use it as address of
+ * 	  C-variable. Otherwise create a new C-variable of needed size.
+ * 	testlinkobj types
+ * 	  Return list of available types.
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	Creates and deletes various variable links, plus returns
+ *	values of the linked variables.
+ *----------------------------------------------------------------------
+ */
+static int
+TestlinkarrayCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj * const objv[])	/* Argument strings. */
+{
+     static const char *LinkOption[] = {
+	"update", "remove", "create", "types", NULL
+    };
+    enum LinkOption
+	{ LINK_UPDATE, LINK_REMOVE, LINK_CREATE, LINK_TYPES };
+    static const char *LinkType[] = {
+	"int", "double", "bool", "string",
+	"wideint", "char", "uchar",
+	"short", "ushort", "uint",
+	"long", "ulong", "float",
+	"uint", "chars",
+	"complex32", "complex64", "binary"
+	"hex8", "hex16", "hex32", "hex64",
+	"bitarray8", "bitarray16", "bitarray32", "bitarray64",
+	"bool8", "bool16", "bool32", "bool64",
+	"bit8", "bit16", "bit32", "bit64",
+	"s5float", "s5time", NULL
+    };
+    static const int LinkTypes[] = {
+	TCL_LINK_INT, TCL_LINK_DOUBLE, TCL_LINK_BOOLEAN, TCL_LINK_STRING,
+	TCL_LINK_WIDE_INT, TCL_LINK_CHAR, TCL_LINK_UCHAR,
+	TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_UINT,
+	TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_FLOAT,
+	TCL_LINK_WIDE_UINT, TCL_LINK_CHARS,
+	TCL_TYPE_C(float), TCL_TYPE_C(double), TCL_LINK_BINARY	,
+	TCL_TYPE_X(char), TCL_TYPE_X(short), TCL_TYPE_X(int), TCL_TYPE_X(Tcl_WideInt),
+	TCL_LINK_BITARRAY8, TCL_LINK_BITARRAY16,
+	TCL_LINK_BITARRAY32, TCL_LINK_BITARRAY64,
+	TCL_TYPE_B(char), TCL_TYPE_B(short), TCL_TYPE_B(int), TCL_TYPE_B(Tcl_WideInt),
+	TCL_LINK_BIT8, TCL_LINK_BIT16, TCL_LINK_BIT32, TCL_LINK_BIT64,
+	TCL_LINK_S5FLOAT, TCL_LINK_S5TIME
+    };
+    int             optionIndex;
+    int             typeIndex;
+    int             readonly;
+    int             i;
+    char           *name;
+    Tcl_WideInt     addr;
+    int             size;
+    char           *arg;
+    int             length;
+
+    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_TYPES:
+	Tcl_AppendResult(interp, "int double bool string wideint char uchar short ushort uint long ulong float uint chars complex32 complex64 binary hex8 hex16 hex32 hex64 bitarray8 bitarray16 bitarray32 bitarray64 bool8 bool16 bool32 bool64 bit8 bit16 bit32 bit64 s5float s5time", NULL);
+	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_AppendResult(interp, "wrong size value", NULL);
+	    return TCL_ERROR;
+	}
+	name = Tcl_GetString(objv[i++]);
+	/* if no address is given request one in the underlying function */
+	if (i < objc) {
+	    if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
+		Tcl_AppendResult(interp, "wrong address value", NULL);
+		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;
+}
+
 /*
  *----------------------------------------------------------------------
  *