summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/SetResult.32
-rw-r--r--generic/tclDisassemble.c135
-rw-r--r--generic/tclEnsemble.c10
-rw-r--r--library/tcltest/tcltest.tcl2
-rw-r--r--tests/compile.test99
5 files changed, 239 insertions, 9 deletions
diff --git a/doc/SetResult.3 b/doc/SetResult.3
index dc8f487..e5b81d7 100644
--- a/doc/SetResult.3
+++ b/doc/SetResult.3
@@ -164,7 +164,7 @@ The source interpreter will have its result reset by this operation.
.SH "DEPRECATED INTERFACES"
.SS "OLD STRING PROCEDURES"
.PP
-Use of the following procedures (is deprecated
+Use of the following procedures is deprecated
since they manipulate the Tcl result as a string.
Procedures such as \fBTcl_SetObjResult\fR
that manipulate the result as a value
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");
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 11ec3fc..a9698be 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -1861,9 +1861,9 @@ NsEnsembleImplementationCmdNR(
copyPtr = Tcl_NewListObj(copyObjc, NULL);
Tcl_ListObjAppendList(NULL, copyPtr, prefixObj);
- Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
+ Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
ensemblePtr->numParameters, objv+1);
- Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
+ Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
objc - 2 - ensemblePtr->numParameters,
objv + 2 + ensemblePtr->numParameters);
}
@@ -2039,7 +2039,7 @@ TclResetRewriteEnsemble(
*
* TclSpellFix --
*
- * Record a spelling correction that needs making in the
+ * Record a spelling correction that needs making in the
* generation of the WrongNumArgs usage message.
*
* Results:
@@ -2099,7 +2099,7 @@ TclSpellFix(
/* Compute the valid length of the ensemble root */
- size = iPtr->ensembleRewrite.numRemovedObjs + objc
+ size = iPtr->ensembleRewrite.numRemovedObjs + objc
- iPtr->ensembleRewrite.numInsertedObjs;
search = iPtr->ensembleRewrite.sourceObjs;
@@ -2361,7 +2361,7 @@ MakeCachedEnsembleCommand(
if (objPtr->typePtr == &ensembleCmdType) {
ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
- if (ensembleCmd->fix) {
+ if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
} else {
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index f1ce970..cde2660 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -614,7 +614,7 @@ namespace eval tcltest {
set levelMap {
l list
p pass
- b body
+ b body
s skip
t start
e error
diff --git a/tests/compile.test b/tests/compile.test
index bb12050..f021cf2 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -678,7 +678,7 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup
# change without warning.
set disassemblables [linsert [join {
- lambda method objmethod proc script
+ constructor destructor lambda method objmethod proc script
} ", "] end-1 or]
test compile-18.1 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::disassemble
@@ -872,6 +872,103 @@ test compile-18.39 {disassembler - basics} -setup {
} -cleanup {
foo destroy
} -result "$bytecodekeys initiallinenumber sourcefile"
+test compile-18.40 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::disassemble constructor
+} -match glob -result {wrong # args: should be "* constructor className"}
+test compile-18.41 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::disassemble constructor nosuchclass
+} -result {nosuchclass does not refer to an object}
+test compile-18.42 {disassembler - basics} -returnCodes error -setup {
+ oo::object create justanobject
+} -body {
+ tcl::unsupported::disassemble constructor justanobject
+} -cleanup {
+ justanobject destroy
+} -result {"justanobject" is not a class}
+test compile-18.43 {disassembler - basics} -returnCodes error -setup {
+ oo::class create constructorless
+} -body {
+ tcl::unsupported::disassemble constructor constructorless
+} -cleanup {
+ constructorless destroy
+} -result {"constructorless" has no defined constructor}
+test compile-18.44 {disassembler - basics} -setup {
+ oo::class create foo {constructor {} {set x 1}}
+} -body {
+ # Allow any string: the result format is not defined anywhere!
+ tcl::unsupported::disassemble constructor foo
+} -cleanup {
+ foo destroy
+} -match glob -result *
+test compile-18.45 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode constructor
+} -match glob -result {wrong # args: should be "* constructor className"}
+test compile-18.46 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode constructor nosuchobject
+} -result {nosuchobject does not refer to an object}
+test compile-18.47 {disassembler - basics} -returnCodes error -setup {
+ oo::class create constructorless
+} -body {
+ tcl::unsupported::getbytecode constructor constructorless
+} -cleanup {
+ constructorless destroy
+} -result {"constructorless" has no defined constructor}
+test compile-18.48 {disassembler - basics} -setup {
+ oo::class create foo {constructor {} {set x 1}}
+} -body {
+ dict keys [tcl::unsupported::getbytecode constructor foo]
+} -cleanup {
+ foo destroy
+} -result "$bytecodekeys"
+# There is no compile-18.49
+test compile-18.50 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::disassemble destructor
+} -match glob -result {wrong # args: should be "* destructor className"}
+test compile-18.51 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::disassemble destructor nosuchclass
+} -result {nosuchclass does not refer to an object}
+test compile-18.52 {disassembler - basics} -returnCodes error -setup {
+ oo::object create justanobject
+} -body {
+ tcl::unsupported::disassemble destructor justanobject
+} -cleanup {
+ justanobject destroy
+} -result {"justanobject" is not a class}
+test compile-18.53 {disassembler - basics} -returnCodes error -setup {
+ oo::class create constructorless
+} -body {
+ tcl::unsupported::disassemble destructor constructorless
+} -cleanup {
+ constructorless destroy
+} -result {"constructorless" has no defined destructor}
+test compile-18.54 {disassembler - basics} -setup {
+ oo::class create foo {destructor {set x 1}}
+} -body {
+ # Allow any string: the result format is not defined anywhere!
+ tcl::unsupported::disassemble destructor foo
+} -cleanup {
+ foo destroy
+} -match glob -result *
+test compile-18.55 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode destructor
+} -match glob -result {wrong # args: should be "* destructor className"}
+test compile-18.56 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode destructor nosuchobject
+} -result {nosuchobject does not refer to an object}
+test compile-18.57 {disassembler - basics} -returnCodes error -setup {
+ oo::class create constructorless
+} -body {
+ tcl::unsupported::getbytecode destructor constructorless
+} -cleanup {
+ constructorless destroy
+} -result {"constructorless" has no defined destructor}
+test compile-18.58 {disassembler - basics} -setup {
+ oo::class create foo {destructor {set x 1}}
+} -body {
+ dict keys [tcl::unsupported::getbytecode destructor foo]
+} -cleanup {
+ foo destroy
+} -result "$bytecodekeys"
test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
# This will panic in a --enable-symbols=compile build, unless bug is fixed.
generated by cgit v0.12 at 2024-09-30 03:05:31 (GMT)