FM This page is to discuss here about the interest to have a typing for Tcl variables.
Well, as a script programmer, I don't need to know what is the object type of the TclOO struct internaly. But very often I need some extra information about the variable I use. Sometimes a name convention is sufficient, but sometimes it's not.
I've tried an experiment about introducing a "type" on a Tcl variable. This is based on the 8.5.8 tcl source, here it is :
# file tclInt.h
typedef struct Var {
int flags; /* Miscellaneous bits of information about
* variable. See below for definitions. */
Tcl_Obj *userTypeObjPtr; /* additional user type to variable */
union {
Tcl_Obj *objPtr; /* The variable's object value. Used for
* scalar variables and array elements. */
TclVarHashTable *tablePtr;/* For array variables, this points to
* information about the hash table used to
* implement the associative array. Points to
* ckalloc-ed data. */
struct Var *linkPtr; /* If this is a global variable being referred
* to in a procedure, or a variable created by
* "upvar", this field points to the
* referenced variable's Var struct. */
} value;
} Var;
MODULE_SCOPE int Tcl_SetUserTypeObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
# file tclVar.c
int
Tcl_SetUserTypeObjCmd(
ClientData dummy, /* Not used. */
register Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *userTypeObj;
if (objc == 2) {
userTypeObj = Tcl_ObjGetUserType2(interp, objv[1], NULL,TCL_LEAVE_ERR_MSG);
if (userTypeObj == NULL) {
return TCL_ERROR;
} else {
Tcl_SetObjResult(interp, userTypeObj);
}
} else if (objc == 3) {
userTypeObj = Tcl_ObjSetUserType2(interp, objv[1], NULL, objv[2],
TCL_LEAVE_ERR_MSG);
if (userTypeObj == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
} else {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?newType?");
return TCL_ERROR;
}
}
Tcl_Obj *
Tcl_ObjGetUserType2 (
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be found. */
register Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
* array (if part2 is non-NULL) or the name of
* a variable. */
register Tcl_Obj *part2Ptr, /* If non-NULL, points to an object holding
* the name of an element in the array
* part1Ptr. */
int flags)
{
Var *varPtr, *arrayPtr;
Interp *iPtr = (Interp *) interp;
/*
* Filter to pass through only the flags this interface supports.
*/
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG
|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "set the type of",
/*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return varPtr->userTypeObjPtr;
}
Tcl_Obj *
Tcl_ObjSetUserType2 (
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be found. */
register Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
* array (if part2 is non-NULL) or the name of
* a variable. */
register Tcl_Obj *part2Ptr, /* If non-NULL, points to an object holding
* the name of an element in the array
* part1Ptr. */
Tcl_Obj *TypePtr, /* Type for variable. */
int flags)
{
Var *varPtr, *arrayPtr;
/*
* Filter to pass through only the flags this interface supports.
*/
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG
|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "set",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
if (TypePtr->refCount == 0) {
Tcl_DecrRefCount(TypePtr);
}
return NULL;
}
Tcl_IncrRefCount(TypePtr);
varPtr->userTypeObjPtr = TypePtr;
return varPtr->userTypeObjPtr;
}
# file tclDecls.h
#ifndef Tcl_ObjSetUserType2_TCL_DECLARED
#define Tcl_ObjSetUserType2_TCL_DECLARED
EXTERN Tcl_Obj * Tcl_ObjSetUserType2 (Tcl_Interp * interp,
Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr,
Tcl_Obj * TypePtr, int flags);
#endif
#ifndef Tcl_ObjGetUserType2_TCL_DECLARED
#define Tcl_ObjGetUserType2_TCL_DECLARED
EXTERN Tcl_Obj * Tcl_ObjGetUserType2 (Tcl_Interp * interp,
Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr,
int flags);
#endif
# file tclBasic.c
# added to : static const CmdInfo builtInCmds
{"type", Tcl_SetUserTypeObjCmd, NULL, 1},Test
type A; #can't set the type of "A": no such variable
type A [list this is the type]; # A
set A [list this is the A value]; # this is the A value
type A ;# this is the type
set A ; this is the A value
set [type A [list this is the type]] [list this is the A value]; # this is the A value
set B [list this is the B value]
type B [type A]; # B
type [type B [type A]]; # this is the type
type [type D [type [type C [type [type B [type A]]]]]]; # this is the type
type D; #this is the type
type C; #this is the type
type [type D [type [type C [type [type B [type A]]]]]]; # this is the type
set D;# can't read "D": no such variable (bug)
set C [list 1 2 3];# 1 2 3
type C; #this is the type (no bug ???)
type A [list I'am A]
type B [list I'am B]
type C [list I'am C]
proc tester {var} {
upvar $var v
if {[type v] eq "I'am B"} {
puts "$v"
} elseif {[type v] eq "I'am A"} {
puts $v
} else {
puts stderr "unexpected type '[type v]'"
}
}
tester A; #this is the A value
tester B; #this is the B value
tester C; #unexpected type 'I'am C'There is still some bugs... Comments are welcome.