summaryrefslogtreecommitdiffstats
path: root/generic/tclOOBasic.c
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2012-05-20 07:58:11 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2012-05-20 07:58:11 (GMT)
commit40ff07a07969afd5de9232f869a9405dcc68f2a4 (patch)
tree2ccfc6eb96ab5fc4fb4fec69724fe1f02a54f901 /generic/tclOOBasic.c
parent6e977b903ee0e35f5b799abe1c8b3c902a5b5cef (diff)
downloadtcl-40ff07a07969afd5de9232f869a9405dcc68f2a4.zip
tcl-40ff07a07969afd5de9232f869a9405dcc68f2a4.tar.gz
tcl-40ff07a07969afd5de9232f869a9405dcc68f2a4.tar.bz2
* generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut
the amount of hackiness in class constructors, and refactor some of the error message handling from [oo::define] to be saner in the face of odd happenings.
Diffstat (limited to 'generic/tclOOBasic.c')
-rw-r--r--generic/tclOOBasic.c138
1 files changed, 70 insertions, 68 deletions
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 329f0a4..5e983fc 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -19,6 +19,8 @@
static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
static int AfterNRDestructor(ClientData data[],
Tcl_Interp *interp, int result);
+static int DecrRefsPostClassConstructor(ClientData data[],
+ Tcl_Interp *interp, int result);
static int FinalizeConstruction(ClientData data[],
Tcl_Interp *interp, int result);
static int FinalizeEval(ClientData data[],
@@ -70,6 +72,74 @@ FinalizeConstruction(
/*
* ----------------------------------------------------------------------
*
+ * TclOO_Class_Constructor --
+ *
+ * Implementation for oo::class constructor.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_Constructor(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ Tcl_Obj *invoke[3];
+
+ if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "?definitionScript?");
+ return TCL_ERROR;
+ } else if (objc == Tcl_ObjectContextSkippedArgs(context)) {
+ return TCL_OK;
+ }
+
+ /*
+ * Delegate to [oo::define] to do the work.
+ */
+
+ invoke[0] = oPtr->fPtr->defineName;
+ invoke[1] = TclOOObjectName(interp, oPtr);
+ invoke[2] = objv[objc-1];
+
+ /*
+ * Must add references or errors in configuration script will cause
+ * trouble.
+ */
+
+ Tcl_IncrRefCount(invoke[0]);
+ Tcl_IncrRefCount(invoke[1]);
+ Tcl_IncrRefCount(invoke[2]);
+ TclNRAddCallback(interp, DecrRefsPostClassConstructor,
+ invoke[0], invoke[1], invoke[2], NULL);
+
+ /*
+ * Tricky point: do not want the extra reported level in the Tcl stack
+ * trace, so use TCL_EVAL_NOERR.
+ */
+
+ return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
+}
+
+static int
+DecrRefsPostClassConstructor(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ TclDecrRefCount((Tcl_Obj *) data[0]);
+ TclDecrRefCount((Tcl_Obj *) data[1]);
+ TclDecrRefCount((Tcl_Obj *) data[2]);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOO_Class_Create --
*
* Implementation for oo::class->create method.
@@ -1141,74 +1211,6 @@ TclOOCopyObjectCmd(
}
/*
- * ----------------------------------------------------------------------
- *
- * TclOOUpcatchCmd --
- *
- * Implementation of the [oo::UpCatch] command, which is a combination of
- * [uplevel 1] and [catch] that makes it easier to write transparent
- * error handling in scripts.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOOUpcatchCmd(
- ClientData ignored,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- return Tcl_NRCallObjProc(interp, TclOONRUpcatch, NULL, objc, objv);
-}
-
-static int
-UpcatchCallback(
- ClientData data[],
- Tcl_Interp *interp,
- int result)
-{
- Interp *iPtr = (Interp *) interp;
- CallFrame *savedFramePtr = data[0];
- Tcl_Obj *resultObj[2];
- int rewind = iPtr->execEnvPtr->rewind;
-
- iPtr->varFramePtr = savedFramePtr;
- if (rewind || Tcl_LimitExceeded(interp)) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"UpCatch\" body line %d)", Tcl_GetErrorLine(interp)));
- return TCL_ERROR;
- }
- resultObj[0] = Tcl_GetObjResult(interp);
- resultObj[1] = Tcl_GetReturnOptions(interp, result);
- Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj));
- return TCL_OK;
-}
-
-int
-TclOONRUpcatch(
- ClientData ignored,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Interp *iPtr = (Interp *) interp;
- CallFrame *savedFramePtr = iPtr->varFramePtr;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "script");
- return TCL_ERROR;
- }
- if (iPtr->varFramePtr->callerVarPtr != NULL) {
- iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
- }
-
- Tcl_NRAddCallback(interp, UpcatchCallback, savedFramePtr, NULL,NULL,NULL);
- return TclNREvalObjEx(interp, objv[1], TCL_EVAL_NOERR,
- iPtr->cmdFramePtr, 1);
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4