summaryrefslogtreecommitdiffstats
path: root/generic/tclDisassemble.c
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2016-07-04 08:18:53 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2016-07-04 08:18:53 (GMT)
commit8bd5f8fc4af842fb4f757eabeb38dcc91a87b4bc (patch)
treea36b0495acdf2e5f0c9a774cbad1521d44829a3a /generic/tclDisassemble.c
parent2f4c482ac0cec564faea01f71d44f481d96f9e9e (diff)
downloadtcl-8bd5f8fc4af842fb4f757eabeb38dcc91a87b4bc.zip
tcl-8bd5f8fc4af842fb4f757eabeb38dcc91a87b4bc.tar.gz
tcl-8bd5f8fc4af842fb4f757eabeb38dcc91a87b4bc.tar.bz2
Add ability to disassemble TclOO constructors and destructors ([1493a43044] motivates)
Diffstat (limited to 'generic/tclDisassemble.c')
-rw-r--r--generic/tclDisassemble.c135
1 files changed, 134 insertions, 1 deletions
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index c85fe13..1d616fb 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -6,7 +6,7 @@
*
* Copyright (c) 1996-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2013 Donal K. Fellows.
+ * Copyright (c) 2013-2016 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -1279,9 +1279,11 @@ Tcl_DisassembleObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const types[] = {
+ "constructor", "destructor",
"lambda", "method", "objmethod", "proc", "script", NULL
};
enum Types {
+ DISAS_CLASS_CONSTRUCTOR, DISAS_CLASS_DESTRUCTOR,
DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC,
DISAS_SCRIPT
};
@@ -1290,6 +1292,7 @@ Tcl_DisassembleObjCmd(
Proc *procPtr = NULL;
Tcl_HashEntry *hPtr;
Object *oPtr;
+ Method *methodPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "type ...");
@@ -1384,6 +1387,136 @@ Tcl_DisassembleObjCmd(
codeObjPtr = objv[2];
break;
+ case DISAS_CLASS_CONSTRUCTOR:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Look up the body of a constructor.
+ */
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+
+ methodPtr = oPtr->classPtr->constructorPtr;
+ if (methodPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" has no defined constructor",
+ TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+ "CONSRUCTOR", NULL);
+ return TCL_ERROR;
+ }
+ procPtr = TclOOGetProcFromMethod(methodPtr);
+ if (procPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "body not available for this kind of constructor", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+ "METHODTYPE", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Compile if necessary.
+ */
+
+ if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ Command cmd;
+
+ /*
+ * Yes, this is ugly, but we need to pass the namespace in to the
+ * compiler in two places.
+ */
+
+ cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
+ procPtr->cmdPtr = &cmd;
+ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
+ (Namespace *) oPtr->namespacePtr, "body of constructor",
+ TclGetString(objv[2]));
+ procPtr->cmdPtr = NULL;
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+ codeObjPtr = procPtr->bodyPtr;
+ break;
+
+ case DISAS_CLASS_DESTRUCTOR:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Look up the body of a destructor.
+ */
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+
+ methodPtr = oPtr->classPtr->destructorPtr;
+ if (methodPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" has no defined destructor",
+ TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+ "DESRUCTOR", NULL);
+ return TCL_ERROR;
+ }
+ procPtr = TclOOGetProcFromMethod(methodPtr);
+ if (procPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "body not available for this kind of destructor", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+ "METHODTYPE", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Compile if necessary.
+ */
+
+ if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ Command cmd;
+
+ /*
+ * Yes, this is ugly, but we need to pass the namespace in to the
+ * compiler in two places.
+ */
+
+ cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
+ procPtr->cmdPtr = &cmd;
+ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
+ (Namespace *) oPtr->namespacePtr, "body of destructor",
+ TclGetString(objv[2]));
+ procPtr->cmdPtr = NULL;
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+ codeObjPtr = procPtr->bodyPtr;
+ break;
+
case DISAS_CLASS_METHOD:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "className methodName");