summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c6
-rw-r--r--generic/tclInt.h5
-rw-r--r--generic/tclObj.c40
3 files changed, 47 insertions, 4 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 54d3b47..7941c7d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.399 2009/07/23 15:23:43 das Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.400 2009/08/02 13:03:47 dkf Exp $
*/
#include "tclInt.h"
@@ -782,11 +782,13 @@ Tcl_CreateInterp(void)
TclDefaultBgErrorHandlerObjCmd, NULL, NULL);
/*
- * Create an unsupported command for debugging bytecode.
+ * Create unsupported commands for debugging bytecode and objects.
*/
Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
Tcl_DisassembleObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
+ Tcl_RepresentationCmd, NULL, NULL);
/*
* Create the 'tailcall' command
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 2f521eb..ac3b3bc 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.431 2009/07/22 19:54:49 nijtmans Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.432 2009/08/02 13:03:47 dkf Exp $
*/
#ifndef _TCLINT
@@ -3138,6 +3138,9 @@ MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_RenameObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_RepresentationCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_ReturnObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
diff --git a/generic/tclObj.c b/generic/tclObj.c
index edc203c..46758fa 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclObj.c,v 1.153 2009/06/18 09:41:29 dkf Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.154 2009/08/02 13:03:47 dkf Exp $
*/
#include "tclInt.h"
@@ -3962,6 +3962,44 @@ SetCmdNameFromAny(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RepresentationCmd --
+ *
+ * Implementation of the "tcl::unsupported::representation" command.
+ *
+ * Results:
+ * Reports the current representation (Tcl_Obj type) of its argument.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_RepresentationCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "value");
+ return TCL_ERROR;
+ }
+
+ if (objv[1]->typePtr == NULL) {
+ Tcl_AppendResult(interp, "value has no internal representation set",
+ NULL);
+ } else {
+ Tcl_AppendResult(interp, "value has internal representation of ",
+ objv[1]->typePtr->name, " currently", NULL);
+ }
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4