summaryrefslogtreecommitdiffstats
path: root/generic/tclProc.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclProc.c')
-rw-r--r--generic/tclProc.c364
1 files changed, 59 insertions, 305 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 1314719..7bf63c2 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -15,7 +15,6 @@
#include "tclInt.h"
#include "tclCompile.h"
-#include "tclOOInt.h"
/*
* Variables that are part of the [apply] command implementation and which
@@ -41,9 +40,6 @@ static void InitResolvedLocals(Tcl_Interp *interp,
ByteCode *codePtr, Var *defPtr,
Namespace *nsPtr);
static void InitLocalCache(Proc *procPtr);
-static int PushProcCallFrame(ClientData clientData,
- register Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[], int isLambda);
static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void ProcBodyFree(Tcl_Obj *objPtr);
static int ProcWrongNumArgs(Tcl_Interp *interp, int skip);
@@ -73,9 +69,9 @@ const Tcl_ObjType tclProcBodyType = {
};
/*
- * The [upvar]/[uplevel] level reference type. Uses the ptrAndLongRep field,
+ * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field,
* encoding the type of level reference in ptr and the actual parsed out
- * offset in value.
+ * offset in ptr2.
*
* Uses the default behaviour throughout, and never disposes of the string
* rep; it's just a cache type.
@@ -92,10 +88,10 @@ static const Tcl_ObjType levelReferenceType = {
*
* Internally, ptr1 is a pointer to a Proc instance that is not bound to a
* command name, and ptr2 is a pointer to the namespace that the Proc instance
- * will execute within.
+ * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO.
*/
-static const Tcl_ObjType lambdaType = {
+const Tcl_ObjType tclLambdaType = {
"lambdaExpr", /* name */
FreeLambdaInternalRep, /* freeIntRepProc */
DupLambdaInternalRep, /* dupIntRepProc */
@@ -221,7 +217,7 @@ Tcl_ProcObjCmd(
*
* This code is nearly identical to the #280 code in SetLambdaFromAny, see
* this file. The differences are the different index of the body in the
- * line array of the context, and the lamdba code requires some special
+ * line array of the context, and the lambda code requires some special
* processing. Find a way to factor the common elements into a single
* function.
*/
@@ -827,10 +823,10 @@ TclObjGetFrame(
name = TclGetString(objPtr);
if (objPtr->typePtr == &levelReferenceType) {
- if (objPtr->internalRep.ptrAndLongRep.ptr != NULL) {
- level = curLevel - objPtr->internalRep.ptrAndLongRep.value;
+ if (objPtr->internalRep.twoPtrValue.ptr1) {
+ level = curLevel - PTR2INT(objPtr->internalRep.twoPtrValue.ptr2);
} else {
- level = objPtr->internalRep.ptrAndLongRep.value;
+ level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr2);
}
if (level < 0) {
goto levelError;
@@ -852,14 +848,12 @@ TclObjGetFrame(
/*
* Cache for future reference.
- *
- * TODO: Use the new ptrAndLongRep intrep
*/
TclFreeIntRep(objPtr);
objPtr->typePtr = &levelReferenceType;
- objPtr->internalRep.ptrAndLongRep.ptr = NULL;
- objPtr->internalRep.ptrAndLongRep.value = level;
+ objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0;
+ objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level);
} else if (isdigit(UCHAR(*name))) { /* INTL: digit */
if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
return -1;
@@ -867,14 +861,12 @@ TclObjGetFrame(
/*
* Cache for future reference.
- *
- * TODO: Use the new ptrAndLongRep intrep
*/
TclFreeIntRep(objPtr);
objPtr->typePtr = &levelReferenceType;
- objPtr->internalRep.ptrAndLongRep.ptr = (void *) 1; /* non-NULL */
- objPtr->internalRep.ptrAndLongRep.value = level;
+ objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1;
+ objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level);
level = curLevel - level;
} else {
/*
@@ -1571,7 +1563,7 @@ InitArgsAndLocals(
/*
*----------------------------------------------------------------------
*
- * PushProcCallFrame --
+ * TclPushProcCallFrame --
*
* Compiles a proc body if necessary, then pushes a CallFrame suitable
* for executing it.
@@ -1586,8 +1578,8 @@ InitArgsAndLocals(
*----------------------------------------------------------------------
*/
-static int
-PushProcCallFrame(
+int
+TclPushProcCallFrame(
ClientData clientData, /* Record describing procedure to be
* interpreted. */
register Tcl_Interp *interp,/* Interpreter in which procedure was
@@ -1708,7 +1700,7 @@ TclNRInterpProc(
* procedure. */
Tcl_Obj *const objv[]) /* Argument value objects. */
{
- int result = PushProcCallFrame(clientData, interp, objc, objv,
+ int result = TclPushProcCallFrame(clientData, interp, objc, objv,
/*isLambda*/ 0);
if (result != TCL_OK) {
@@ -1850,14 +1842,44 @@ InterpProcNR2(
TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result);
}
- if (--procPtr->refCount <= 0) {
+ if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
/*
- * Process the result code.
+ * Free the stack-allocated compiled locals and CallFrame. It is important
+ * to pop the call frame without freeing it first: the compiledLocals
+ * cannot be freed before the frame is popped, as the local variables must
+ * be deleted. But the compiledLocals must be freed first, as they were
+ * allocated later on the stack.
+ */
+
+ if (result != TCL_OK) {
+ goto process;
+ }
+
+ done:
+ if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
+ int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Obj *r = Tcl_GetObjResult(interp);
+
+ TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ?
+ TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result,
+ TclGetString(r), r);
+ }
+
+ freePtr = iPtr->framePtr;
+ Tcl_PopCallFrame(interp); /* Pop but do not free. */
+ TclStackFree(interp, freePtr->compiledLocals);
+ /* Free compiledLocals. */
+ TclStackFree(interp, freePtr); /* Free CallFrame. */
+ return result;
+
+ /*
+ * Process any non-TCL_OK result code.
*/
+ process:
switch (result) {
case TCL_RETURN:
/*
@@ -1892,46 +1914,8 @@ InterpProcNR2(
*/
errorProc(interp, procNameObj);
-
- default:
- /*
- * Process other results (OK and non-standard) by doing nothing
- * special, skipping directly to the code afterwards that cleans up
- * associated memory.
- *
- * Non-standard results are processed by passing them through quickly.
- * This means they all work as exceptions, unwinding the stack quickly
- * and neatly. Who knows how well they are handled by third-party code
- * though...
- */
-
- (void) 0; /* do nothing */
- }
-
- if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
- int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
- Tcl_Obj *r = Tcl_GetObjResult(interp);
-
- TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ?
- TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result,
- TclGetString(r), r);
}
-
- /*
- * Free the stack-allocated compiled locals and CallFrame. It is important
- * to pop the call frame without freeing it first: the compiledLocals
- * cannot be freed before the frame is popped, as the local variables must
- * be deleted. But the compiledLocals must be freed first, as they were
- * allocated later on the stack.
- */
-
- freePtr = iPtr->framePtr;
- Tcl_PopCallFrame(interp); /* Pop but do not free. */
- TclStackFree(interp, freePtr->compiledLocals);
- /* Free compiledLocals. */
- TclStackFree(interp, freePtr); /* Free CallFrame. */
-
- return result;
+ goto done;
}
/*
@@ -2163,8 +2147,7 @@ TclProcDeleteProc(
{
Proc *procPtr = clientData;
- procPtr->refCount--;
- if (procPtr->refCount <= 0) {
+ if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
}
@@ -2419,7 +2402,7 @@ ProcBodyFree(
{
Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
- if (procPtr->refCount-- < 2) {
+ if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
}
@@ -2451,7 +2434,7 @@ DupLambdaInternalRep(
procPtr->refCount++;
Tcl_IncrRefCount(nsObjPtr);
- copyPtr->typePtr = &lambdaType;
+ copyPtr->typePtr = &tclLambdaType;
}
static void
@@ -2462,8 +2445,7 @@ FreeLambdaInternalRep(
Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;
- procPtr->refCount--;
- if (procPtr->refCount == 0) {
+ if (procPtr->refCount-- == 1) {
TclProcCleanupProc(procPtr);
}
TclDecrRefCount(nsObjPtr);
@@ -2488,7 +2470,7 @@ SetLambdaFromAny(
/*
* Convert objPtr to list type first; if it cannot be converted, or if its
- * length is not 2, then it cannot be converted to lambdaType.
+ * length is not 2, then it cannot be converted to tclLambdaType.
*/
result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
@@ -2634,14 +2616,14 @@ SetLambdaFromAny(
/*
* Free the list internalrep of objPtr - this will free argsPtr, but
* bodyPtr retains a reference from the Proc structure. Then finish the
- * conversion to lambdaType.
+ * conversion to tclLambdaType.
*/
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
- objPtr->typePtr = &lambdaType;
+ objPtr->typePtr = &tclLambdaType;
return TCL_OK;
}
@@ -2692,12 +2674,12 @@ TclNRApplyObjCmd(
}
/*
- * Set lambdaPtr, convert it to lambdaType in the current interp if
+ * Set lambdaPtr, convert it to tclLambdaType in the current interp if
* necessary.
*/
lambdaPtr = objv[1];
- if (lambdaPtr->typePtr == &lambdaType) {
+ if (lambdaPtr->typePtr == &tclLambdaType) {
procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
}
@@ -2775,7 +2757,7 @@ TclNRApplyObjCmd(
}
extraPtr->isRootEnsemble = isRootEnsemble;
- result = PushProcCallFrame(procPtr, interp, objc, objv, 1);
+ result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1);
if (result == TCL_OK) {
TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL);
result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
@@ -2835,234 +2817,6 @@ MakeLambdaError(
}
/*
- *----------------------------------------------------------------------
- *
- * Tcl_DisassembleObjCmd --
- *
- * Implementation of the "::tcl::unsupported::disassemble" command. This
- * command is not documented, but will disassemble procedures, lambda
- * terms and general scripts. Note that will compile terms if necessary
- * in order to disassemble them.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_DisassembleObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- static const char *const types[] = {
- "lambda", "method", "objmethod", "proc", "script", NULL
- };
- enum Types {
- DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC,
- DISAS_SCRIPT
- };
- int idx, result;
- Tcl_Obj *codeObjPtr = NULL;
- Proc *procPtr = NULL;
- Tcl_HashEntry *hPtr;
- Object *oPtr;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "type ...");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){
- return TCL_ERROR;
- }
-
- switch ((enum Types) idx) {
- case DISAS_LAMBDA: {
- Command cmd;
- Tcl_Obj *nsObjPtr;
- Tcl_Namespace *nsPtr;
-
- /*
- * Compile (if uncompiled) and disassemble a lambda term.
- */
-
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm");
- return TCL_ERROR;
- }
- if (objv[2]->typePtr == &lambdaType) {
- procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
- }
- if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) {
- result = SetLambdaFromAny(interp, objv[2]);
- if (result != TCL_OK) {
- return result;
- }
- procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
- }
-
- memset(&cmd, 0, sizeof(Command));
- nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2;
- result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
- if (result != TCL_OK) {
- return result;
- }
- cmd.nsPtr = (Namespace *) nsPtr;
- procPtr->cmdPtr = &cmd;
- result = PushProcCallFrame(procPtr, interp, objc, objv, 1);
- if (result != TCL_OK) {
- return result;
- }
- TclPopStackFrame(interp);
- codeObjPtr = procPtr->bodyPtr;
- break;
- }
- case DISAS_PROC:
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "procName");
- return TCL_ERROR;
- }
-
- procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
- if (procPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "\"%s\" isn't a procedure", TclGetString(objv[2])));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
- TclGetString(objv[2]), NULL);
- return TCL_ERROR;
- }
-
- /*
- * Compile (if uncompiled) and disassemble a procedure.
- */
-
- result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1);
- if (result != TCL_OK) {
- return result;
- }
- TclPopStackFrame(interp);
- codeObjPtr = procPtr->bodyPtr;
- break;
- case DISAS_SCRIPT:
- /*
- * Compile and disassemble a script.
- */
-
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "script");
- return TCL_ERROR;
- }
- if ((objv[2]->typePtr != &tclByteCodeType)
- && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) {
- return TCL_ERROR;
- }
- codeObjPtr = objv[2];
- break;
-
- case DISAS_CLASS_METHOD:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "className methodName");
- return TCL_ERROR;
- }
-
- /*
- * Look up the body of a class method.
- */
-
- 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;
- }
- hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
- (char *) objv[3]);
- goto methodBody;
- case DISAS_OBJECT_METHOD:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName");
- return TCL_ERROR;
- }
-
- /*
- * Look up the body of an instance method.
- */
-
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->methodsPtr == NULL) {
- goto unknownMethod;
- }
- hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]);
-
- /*
- * Compile (if necessary) and disassemble a method body.
- */
-
- methodBody:
- if (hPtr == NULL) {
- unknownMethod:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "unknown method \"%s\"", TclGetString(objv[3])));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[3]), NULL);
- return TCL_ERROR;
- }
- procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
- if (procPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "body not available for this kind of method", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "METHODTYPE", NULL);
- return TCL_ERROR;
- }
- 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 method",
- TclGetString(objv[3]));
- procPtr->cmdPtr = NULL;
- if (result != TCL_OK) {
- return result;
- }
- }
- codeObjPtr = procPtr->bodyPtr;
- break;
- default:
- CLANG_ASSERT(0);
- }
-
- /*
- * Do the actual disassembly.
- */
-
- if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags
- & TCL_BYTECODE_PRECOMPILED) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "may not disassemble prebuilt bytecode", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "BYTECODE", NULL);
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
- return TCL_OK;
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4