diff options
author | dkf <donal.k.fellows@manchester.ac.uk> | 2016-07-04 08:18:53 (GMT) |
---|---|---|
committer | dkf <donal.k.fellows@manchester.ac.uk> | 2016-07-04 08:18:53 (GMT) |
commit | 8bd5f8fc4af842fb4f757eabeb38dcc91a87b4bc (patch) | |
tree | a36b0495acdf2e5f0c9a774cbad1521d44829a3a /generic/tclDisassemble.c | |
parent | 2f4c482ac0cec564faea01f71d44f481d96f9e9e (diff) | |
download | tcl-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.c | 135 |
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"); |