summaryrefslogtreecommitdiffstats
path: root/generic/tclProc.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclProc.c')
-rw-r--r--generic/tclProc.c275
1 files changed, 64 insertions, 211 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 8577470..6429488 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -11,12 +11,11 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.94 2006/10/20 14:04:01 dkf Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.95 2006/10/20 15:16:47 dkf Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
-#include "tclOO.h"
/*
* Prototypes for static functions in this file
@@ -34,8 +33,7 @@ static int ObjInterpProcEx(ClientData clientData,
static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void ProcBodyFree(Tcl_Obj *objPtr);
static int ProcessProcResultCode(Tcl_Interp *interp,
- Tcl_Obj *procNameObj, int returnCode,
- int isMethod);
+ char *procName, int nameLen, int returnCode);
static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int ProcCompileProc (Tcl_Interp *interp, Proc *procPtr,
Tcl_Obj *bodyPtr, Namespace *nsPtr,
@@ -111,12 +109,12 @@ Tcl_ProcObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
Proc *procPtr;
char *fullName;
- const char *procName, *procArgs, *procBody;
+ CONST char *procName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Command cmd;
Tcl_DString ds;
@@ -280,17 +278,17 @@ int
TclCreateProc(
Tcl_Interp *interp, /* interpreter containing proc */
Namespace *nsPtr, /* namespace containing this proc */
- const char *procName, /* unqualified name of this proc */
+ CONST char *procName, /* unqualified name of this proc */
Tcl_Obj *argsPtr, /* description of arguments */
Tcl_Obj *bodyPtr, /* command body */
Proc **procPtrPtr) /* returns: pointer to proc data */
{
Interp *iPtr = (Interp*)interp;
- const char **argArray = NULL;
+ CONST char **argArray = NULL;
register Proc *procPtr;
int i, length, result, numArgs;
- const char *args, *bytes, *p;
+ CONST char *args, *bytes, *p;
register CompiledLocal *localPtr = NULL;
Tcl_Obj *defPtr;
int precompiled = 0;
@@ -384,7 +382,7 @@ TclCreateProc(
for (i = 0; i < numArgs; i++) {
int fieldCount, nameLength, valueLength;
- const char **fieldValues;
+ CONST char **fieldValues;
/*
* Now divide the specifier up into name and default.
@@ -422,7 +420,7 @@ TclCreateProc(
p = fieldValues[0];
while (*p != '\0') {
if (*p == '(') {
- const char *q = p;
+ CONST char *q = p;
do {
q++;
} while (*q != '\0');
@@ -593,7 +591,7 @@ TclCreateProc(
int
TclGetFrame(
Tcl_Interp *interp, /* Interpreter in which to find frame. */
- const char *name, /* String describing frame. */
+ CONST char *name, /* String describing frame. */
CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if
* global frame indicated). */
{
@@ -682,7 +680,7 @@ TclObjGetFrame(
register Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
CallFrame *framePtr;
- const char *name = TclGetString(objPtr);
+ CONST char *name = TclGetString(objPtr);
/*
* Parse object to figure out which level number to go to.
@@ -800,7 +798,7 @@ Tcl_UplevelObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
int result;
@@ -890,7 +888,7 @@ Tcl_UplevelObjCmd(
Proc *
TclFindProc(
Interp *iPtr, /* Interpreter in which to look. */
- const char *procName) /* Name of desired procedure. */
+ CONST char *procName) /* Name of desired procedure. */
{
Tcl_Command cmd;
Tcl_Command origCmd;
@@ -1120,7 +1118,7 @@ TclInitCompiledLocals(
/*
*----------------------------------------------------------------------
*
- * TclObjInterpProc, ObjInterpProcEx --
+ * TclObjInterpProc --
*
* When a Tcl procedure gets invoked during bytecode evaluation, this
* object-based routine gets invoked to interpret the procedure.
@@ -1142,8 +1140,9 @@ TclObjInterpProc(
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
- Tcl_Obj *const objv[]) /* Argument value objects. */
+ Tcl_Obj *CONST objv[]) /* Argument value objects. */
{
+
return ObjInterpProcEx(clientData, interp, objc, objv, /*skip*/ 1);
}
@@ -1155,14 +1154,25 @@ ObjInterpProcEx(
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
- Tcl_Obj *const objv[], /* Argument value objects. */
+ Tcl_Obj *CONST objv[], /* Argument value objects. */
int skip) /* Number of initial arguments to be skipped,
- * i.e., words in the "command name" */
+ * ie, words in the "command name" */
{
Proc *procPtr = (Proc *) clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame *framePtr, **framePtrPtr;
- int result;
+ register Var *varPtr;
+ register CompiledLocal *localPtr;
+ char *procName;
+ int nameLen, localCt, numArgs, argCt, i, imax, result;
+ Var *compiledLocals;
+ Tcl_Obj *CONST *argObjs;
+
+ /*
+ * Get the procedure's name.
+ */
+
+ procName = Tcl_GetStringFromObj(objv[0], &nameLen);
/*
* If necessary, compile the procedure's body. The compiler will allocate
@@ -1172,12 +1182,13 @@ ObjInterpProcEx(
*/
result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
- "body of proc", TclGetString(objv[0]), &procPtr);
+ "body of proc", procName, &procPtr);
if (result != TCL_OK) {
return result;
}
+
/*
* Set up and push a new call frame for the new procedure invocation.
* This call frame will execute in the proc's namespace, which might be
@@ -1194,50 +1205,11 @@ ObjInterpProcEx(
return result;
}
+
framePtr->objc = objc;
framePtr->objv = objv; /* ref counts for args are incremented below */
framePtr->procPtr = procPtr;
- return TclObjInterpProcCore(interp, framePtr, objv[0], skip);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclObjInterpProcCore --
- *
- * When a Tcl procedure, procedure-like method or lambda term gets
- * invoked during bytecode evaluation, this object-based routine gets
- * invoked to interpret the body.
- *
- * Results:
- * A standard Tcl object result value.
- *
- * Side effects:
- * Depends on the commands in the procedure body.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclObjInterpProcCore(
- register Tcl_Interp *interp,/* Interpreter in which procedure was
- * invoked. */
- CallFrame *framePtr, /* The context to execute. The procPtr field
- * must be non-NULL. */
- Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
- int skip) /* Number of initial arguments to be skipped,
- * i.e., words in the "command name". */
-{
- register Proc *procPtr = framePtr->procPtr;
- register Var *varPtr;
- register CompiledLocal *localPtr;
- int localCt, numArgs, argCt, i, imax, result;
- Var *compiledLocals;
- Tcl_Obj *const *argObjs;
- int isMethod = (framePtr->isProcCallFrame &
- (FRAME_IS_METHOD | FRAME_IS_CONSTRUCTOR | FRAME_IS_DESTRUCTOR));
-
/*
* Create the "compiledLocals" array. Make sure it is large enough to hold
* all the procedure's compiled local variables, including its formal
@@ -1257,8 +1229,8 @@ TclObjInterpProcCore(
*/
numArgs = procPtr->numArgs;
- argCt = framePtr->objc-skip; /* set it to the number of args to the proc */
- argObjs = &framePtr->objv[skip];
+ argCt = objc-skip; /* set it to the number of args to the proc */
+ argObjs = &objv[skip];
varPtr = framePtr->compiledLocals;
localPtr = procPtr->firstLocalPtr;
if (numArgs == 0) {
@@ -1342,7 +1314,7 @@ TclObjInterpProcCore(
incorrectArgs:
codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr;
- InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
+ InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);
/*
* Build up desired argument list for Tcl_WrongNumArgs
@@ -1352,9 +1324,9 @@ TclObjInterpProcCore(
ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1));
#ifdef AVOID_HACKS_FOR_ITCL
- desiredObjs[0] = framePtr->objv[0];
+ desiredObjs[0] = objv[0];
#else
- desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv);
+ desiredObjs[0] = Tcl_NewListObj(skip, objv);
#endif /* AVOID_HACKS_FOR_ITCL */
localPtr = procPtr->firstLocalPtr;
@@ -1408,7 +1380,7 @@ TclObjInterpProcCore(
ByteCode *codePtr = (ByteCode *)
procPtr->bodyPtr->internalRep.otherValuePtr;
- InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
+ InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);
}
/*
@@ -1418,8 +1390,8 @@ TclObjInterpProcCore(
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 1) {
fprintf(stdout, "Calling proc ");
- for (i = 0; i < framePtr->objc; i++) {
- TclPrintObject(stdout, framePtr->objv[i], 15);
+ for (i = 0; i < objc; i++) {
+ TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
@@ -1436,19 +1408,19 @@ TclObjInterpProcCore(
if (result != TCL_OK) {
if (skip == 1) {
- result = ProcessProcResultCode(interp, procNameObj, result,
- isMethod);
+ result = ProcessProcResultCode(interp, procName, nameLen, result);
} else {
/*
* Use a 'procName' that contains the first skip elements of objv
* for error reporting. This insures that we do not see just
* 'apply', but also the lambda expression that caused the error.
*/
-
+
Tcl_Obj *namePtr;
- namePtr = Tcl_NewListObj(skip, framePtr->objv);
- result = ProcessProcResultCode(interp, namePtr, result, isMethod);
+ namePtr = Tcl_NewListObj(skip, objv);
+ procName = Tcl_GetStringFromObj(namePtr, &nameLen);
+ result = ProcessProcResultCode(interp, procName, nameLen, result);
TclDecrRefCount(namePtr);
}
}
@@ -1502,8 +1474,8 @@ TclProcCompileProc(
* but could be any code fragment compiled in
* the context of this procedure.) */
Namespace *nsPtr, /* Namespace containing procedure. */
- const char *description, /* string describing this body of code. */
- const char *procName) /* Name of this procedure. */
+ CONST char *description, /* string describing this body of code. */
+ CONST char *procName) /* Name of this procedure. */
{
return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
procName, NULL);
@@ -1708,11 +1680,10 @@ static int
ProcessProcResultCode(
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called and returned returnCode. */
- Tcl_Obj *procNameObj, /* Name of the procedure. Used for error
+ char *procName, /* Name of the procedure. Used for error
* messages and trace information. */
- int returnCode, /* The unexpected result code. */
- int isMethod) /* Whether this is a procedure, method,
- * constructor or destructor. */
+ int nameLen, /* Number of bytes in procedure's name. */
+ int returnCode) /* The unexpected result code. */
{
Interp *iPtr = (Interp *) interp;
int overflow, limit = 60;
@@ -1732,111 +1703,10 @@ ProcessProcResultCode(
((returnCode == TCL_BREAK) ? "break" : "continue"),
"\" outside of a loop", NULL);
}
- if (isMethod & FRAME_IS_CONSTRUCTOR) {
- if (interp->errorLine != 0xDEADBEEF) { /* hack! */
- CallContext *contextPtr =
- ((Interp *) interp)->varFramePtr->ooContextPtr;
- Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
- Tcl_Command declarer;
- Tcl_Obj *objectNameObj;
- const char *objectName, *kindName;
- int objectNameLen;
-
- if (mPtr->declaringObjectPtr != NULL) {
- declarer = mPtr->declaringObjectPtr->command;
- kindName = "object";
- } else {
- if (mPtr->declaringClassPtr == NULL) {
- Tcl_Panic("method not declared in class or object");
- }
- declarer = mPtr->declaringClassPtr->thisPtr->command;
- kindName = "class";
- }
- TclNewObj(objectNameObj);
- Tcl_GetCommandFullName(interp, declarer, objectNameObj);
- objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen);
- overflow = (objectNameLen > limit);
-
- TclFormatToErrorInfo(interp,
- "\n (%s \"%.*s%s\" constructor line %d)",
- kindName, (overflow ? limit : objectNameLen), objectName,
- (overflow ? "..." : ""), interp->errorLine);
-
- TclDecrRefCount(objectNameObj);
- }
- } else if (isMethod & FRAME_IS_DESTRUCTOR) {
- CallContext *contextPtr =
- ((Interp *) interp)->varFramePtr->ooContextPtr;
- Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
- Tcl_Command declarer;
- Tcl_Obj *objectNameObj;
- const char *objectName, *kindName;
- int objectNameLen;
-
- if (mPtr->declaringObjectPtr != NULL) {
- declarer = mPtr->declaringObjectPtr->command;
- kindName = "object";
- } else {
- if (mPtr->declaringClassPtr == NULL) {
- Tcl_Panic("method not declared in class or object");
- }
- declarer = mPtr->declaringClassPtr->thisPtr->command;
- kindName = "class";
- }
- TclNewObj(objectNameObj);
- Tcl_GetCommandFullName(interp, declarer, objectNameObj);
- objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen);
- overflow = (objectNameLen > limit);
-
- TclFormatToErrorInfo(interp,
- "\n (%s \"%.*s%s\" destructor line %d)",
- kindName, (overflow ? limit : objectNameLen), objectName,
- (overflow ? "..." : ""), interp->errorLine);
-
- TclDecrRefCount(objectNameObj);
- } else if (isMethod & FRAME_IS_METHOD) {
- int nameLen, objectNameLen, objNameOverflow;
- CallContext *contextPtr =
- ((Interp *) interp)->varFramePtr->ooContextPtr;
- Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
- Tcl_Obj *objectNameObj;
- const char *objectName, *kindName, *methodName =
- Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
- Tcl_Command declarer;
-
- if (mPtr->declaringObjectPtr != NULL) {
- declarer = mPtr->declaringObjectPtr->command;
- kindName = "object";
- } else {
- if (mPtr->declaringClassPtr == NULL) {
- Tcl_Panic("method not declared in class or object");
- }
- declarer = mPtr->declaringClassPtr->thisPtr->command;
- kindName = "class";
- }
- TclNewObj(objectNameObj);
- Tcl_GetCommandFullName(interp, declarer, objectNameObj);
- objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen);
- overflow = (nameLen > limit);
- objNameOverflow = (objectNameLen > limit);
-
- TclFormatToErrorInfo(interp,
- "\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)", kindName,
- (objNameOverflow ? limit : objectNameLen), objectName,
- (objNameOverflow ? "..." : ""), (overflow ? limit : nameLen),
- methodName, (overflow ? "..." : ""), interp->errorLine);
-
- TclDecrRefCount(objectNameObj);
- } else {
- int nameLen;
- const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
-
overflow = (nameLen > limit);
-
TclFormatToErrorInfo(interp, "\n (procedure \"%.*s%s\" line %d)",
(overflow ? limit : nameLen), procName,
(overflow ? "..." : ""), interp->errorLine);
- }
return TCL_ERROR;
}
@@ -2098,11 +1968,11 @@ DupLambdaInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2;
+ Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_Obj *nsObjPtr = (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr2;
- copyPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = (void *) procPtr;
+ copyPtr->internalRep.twoPtrValue.ptr2 = (void *) nsObjPtr;
procPtr->refCount++;
Tcl_IncrRefCount(nsObjPtr);
@@ -2114,8 +1984,8 @@ FreeLambdaInternalRep(
register Tcl_Obj *objPtr) /* CmdName object with internal representation
* to free. */
{
- Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;
+ Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_Obj *nsObjPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
procPtr->refCount--;
if (procPtr->refCount == 0) {
@@ -2163,7 +2033,7 @@ SetLambdaFromAny(
bodyPtr, &procPtr) != TCL_OK) {
TclFormatToErrorInfo(interp,
"\n (parsing lambda expression \"%s\")",
- TclGetString(objPtr), NULL);
+ Tcl_GetString(objPtr), NULL);
return TCL_ERROR;
}
@@ -2200,35 +2070,18 @@ SetLambdaFromAny(
objPtr->typePtr->freeIntRepProc(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = (void *) procPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = (void *) nsObjPtr;
objPtr->typePtr = &lambdaType;
return TCL_OK;
}
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_ApplyObjCmd --
- *
- * This object-based function is invoked to process the "apply" Tcl
- * command. See the user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl object result value.
- *
- * Side effects:
- * Depends on the content of the lambda term (i.e., objv[1]).
- *
- *----------------------------------------------------------------------
- */
-
int
Tcl_ApplyObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = NULL;
@@ -2249,7 +2102,7 @@ Tcl_ApplyObjCmd(
lambdaPtr = objv[1];
if (lambdaPtr->typePtr == &lambdaType) {
- procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
+ procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1;
}
#define JOE_EXTENSION 0
@@ -2276,7 +2129,7 @@ Tcl_ApplyObjCmd(
if (result != TCL_OK) {
return result;
}
- procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
+ procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1;
}
procPtr->cmdPtr = &cmd;
@@ -2285,7 +2138,7 @@ Tcl_ApplyObjCmd(
* for that namespace. Note that TclObjInterpProc() will pop it.
*/
- nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
+ nsObjPtr = (Tcl_Obj *) lambdaPtr->internalRep.twoPtrValue.ptr2;
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return result;
generated by cgit v0.12 at 2024-11-05 11:18:36 (GMT)