diff options
| author | dkf <donal.k.fellows@manchester.ac.uk> | 2009-08-02 13:03:46 (GMT) |
|---|---|---|
| committer | dkf <donal.k.fellows@manchester.ac.uk> | 2009-08-02 13:03:46 (GMT) |
| commit | 9b243d8861a7ba96ab64928edc9795beb02a4997 (patch) | |
| tree | 9ef3ff93e52517d40aa719be4a9fcb282bf74aa5 /generic | |
| parent | caf9f82c8c57615ac532064b2eb0c7649ea7eb40 (diff) | |
| download | tcl-9b243d8861a7ba96ab64928edc9795beb02a4997.zip tcl-9b243d8861a7ba96ab64928edc9795beb02a4997.tar.gz tcl-9b243d8861a7ba96ab64928edc9795beb02a4997.tar.bz2 | |
Added *unsupported* command to report an object's representation.
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 6 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | generic/tclObj.c | 40 |
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 |