diff options
| -rw-r--r-- | ChangeLog | 18 | ||||
| -rw-r--r-- | generic/tclBasic.c | 8 | ||||
| -rw-r--r-- | generic/tclExecute.c | 83 | ||||
| -rw-r--r-- | generic/tclInt.decls | 16 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 46 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 79 | ||||
| -rw-r--r-- | generic/tclProc.c | 16 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 6 | ||||
| -rw-r--r-- | generic/tclTest.c | 8 |
9 files changed, 247 insertions, 33 deletions
@@ -1,3 +1,21 @@ +2004-12-15 Miguel Sofer <msofer@users.sf.net> + + * generic/tclBasic.c: + * generic/tclExecute.c: + * generic/tclInt.decls: + * generic/tclIntDecls.h: + * generic/tclNamesp.c: + * generic/tclProc.c: + * generic/tclStubInit.c: + * generic/tclTest.c: Added two new functions to allocate memory + from the execution stack (TclStackAlloc, TclStackFree). Added + functions TclPushStackFrame and TclPopStackFrame that do the work + of Tcl_PushCallFrame and Tcl_PopCallFrame, but using frames + allocated in the execution stack - i.e., heap instead of + C-stack. The core uses these two new functions exclusively; the + old ones remain for backwards compat, as at least two popular + extensions (itcl, xotcl) are known to use them. + 2004-12-14 Miguel Sofer <msofer@users.sf.net> * generic/tclCmdIL.c: diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d4c9382..45a3c4b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.136 2004/11/30 19:34:46 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.137 2004/12/15 20:44:34 msofer Exp $ */ #include "tclInt.h" @@ -4145,22 +4145,22 @@ TclObjInvokeNamespace(interp, objc, objv, nsPtr, flags) * TCL_INVOKE_NO_UNKNOWN, or * TCL_INVOKE_NO_TRACEBACK. */ { - Tcl_CallFrame frame; int result; + Tcl_CallFrame *framePtr; /* * Make the specified namespace the current namespace and invoke * the command. */ - result = Tcl_PushCallFrame(interp, &frame, nsPtr, /*isProcCallFrame*/ 0); + result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return TCL_ERROR; } result = TclObjInvoke(interp, objc, objv, flags); - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); return result; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 99cf90a..afbb4aa 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.167 2004/11/12 19:16:50 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.168 2004/12/15 20:44:36 msofer Exp $ */ #include "tclInt.h" @@ -659,6 +659,87 @@ GrowEvaluationStack(eePtr) /* *-------------------------------------------------------------- * + * TclStackAlloc -- + * + * Allocate memory from the execution stack; it has to be returned later + * with a call to TclStackFree + * + * Results: + * A pointer to the first byte allocated, or panics if the allocation did + * not succeed. + * + * Side effects: + * The execution stack may be grown. + * + *-------------------------------------------------------------- + */ + +char * +TclStackAlloc(interp, numBytes) + Tcl_Interp *interp; + int numBytes; +{ + Interp *iPtr = (Interp *) interp; + ExecEnv *eePtr = iPtr->execEnvPtr; + int numWords; + Tcl_Obj **tosPtr = eePtr->tosPtr; + char **stackRefCountPtr; + + /* + * Add two words to store + * - a pointer to the used execution stack + * - the number of words reserved + * These will be used later by TclStackFree. + */ + + numWords = (numBytes + 3*sizeof(void *) - 1)/sizeof(void *); + + while ((tosPtr + numWords) > eePtr->endPtr) { + GrowEvaluationStack(eePtr); + tosPtr = eePtr->tosPtr; + } + + /* + * Increase the stack's reference count, to make sure it is not freed + * prematurely. + */ + + stackRefCountPtr = (char **) (eePtr->stackPtr-1); + ++*stackRefCountPtr; + + /* + * Reserve the space in the exec stack, and store the data for freeing. + */ + + eePtr->tosPtr += numWords; + *(eePtr->tosPtr-1) = (Tcl_Obj *) stackRefCountPtr; + *(eePtr->tosPtr) = (Tcl_Obj *) numWords; + + return (char *) (tosPtr+1); +} + +void +TclStackFree(interp) + Tcl_Interp *interp; +{ + Interp *iPtr = (Interp *) interp; + ExecEnv *eePtr = iPtr->execEnvPtr; + char **stackRefCountPtr; + + + stackRefCountPtr = (char **) *(eePtr->tosPtr-1); + eePtr->tosPtr -= (int) *(eePtr->tosPtr); + + --*stackRefCountPtr; + if (*stackRefCountPtr == (char *) 0) { + ckfree((VOID *) stackRefCountPtr); + } +} + + +/* + *-------------------------------------------------------------- + * * Tcl_ExprObj -- * * Evaluate an expression in a Tcl_Obj. diff --git a/generic/tclInt.decls b/generic/tclInt.decls index e497298..f59d01e 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclInt.decls,v 1.84 2004/12/01 23:18:50 dgp Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.85 2004/12/15 20:44:38 msofer Exp $ library tcl @@ -859,6 +859,20 @@ declare 213 generic { declare 214 generic { void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding) } +declare 215 generic { + char * TclStackAlloc(Tcl_Interp *interp, int numBytes) +} +declare 216 generic { + void TclStackFree(Tcl_Interp *interp) +} +declare 217 generic { + int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, + Tcl_Namespace *namespacePtr, int isProcCallFrame ) +} +declare 218 generic { + void TclPopStackFrame(Tcl_Interp *interp) +} + ############################################################################## diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index ed4b443..23acb90 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.75 2004/12/01 23:18:52 dgp Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.76 2004/12/15 20:44:39 msofer Exp $ */ #ifndef _TCLINTDECLS @@ -1118,6 +1118,30 @@ EXTERN Tcl_Obj * TclGetObjNameOfExecutable _ANSI_ARGS_((void)); EXTERN void TclSetObjNameOfExecutable _ANSI_ARGS_(( Tcl_Obj * name, Tcl_Encoding encoding)); #endif +#ifndef TclStackAlloc_TCL_DECLARED +#define TclStackAlloc_TCL_DECLARED +/* 215 */ +EXTERN char * TclStackAlloc _ANSI_ARGS_((Tcl_Interp * interp, + int numBytes)); +#endif +#ifndef TclStackFree_TCL_DECLARED +#define TclStackFree_TCL_DECLARED +/* 216 */ +EXTERN void TclStackFree _ANSI_ARGS_((Tcl_Interp * interp)); +#endif +#ifndef TclPushStackFrame_TCL_DECLARED +#define TclPushStackFrame_TCL_DECLARED +/* 217 */ +EXTERN int TclPushStackFrame _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_CallFrame ** framePtrPtr, + Tcl_Namespace * namespacePtr, + int isProcCallFrame)); +#endif +#ifndef TclPopStackFrame_TCL_DECLARED +#define TclPopStackFrame_TCL_DECLARED +/* 218 */ +EXTERN void TclPopStackFrame _ANSI_ARGS_((Tcl_Interp * interp)); +#endif typedef struct TclIntStubs { int magic; @@ -1353,6 +1377,10 @@ typedef struct TclIntStubs { void (*tclpFindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 212 */ Tcl_Obj * (*tclGetObjNameOfExecutable) _ANSI_ARGS_((void)); /* 213 */ void (*tclSetObjNameOfExecutable) _ANSI_ARGS_((Tcl_Obj * name, Tcl_Encoding encoding)); /* 214 */ + char * (*tclStackAlloc) _ANSI_ARGS_((Tcl_Interp * interp, int numBytes)); /* 215 */ + void (*tclStackFree) _ANSI_ARGS_((Tcl_Interp * interp)); /* 216 */ + int (*tclPushStackFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_CallFrame ** framePtrPtr, Tcl_Namespace * namespacePtr, int isProcCallFrame)); /* 217 */ + void (*tclPopStackFrame) _ANSI_ARGS_((Tcl_Interp * interp)); /* 218 */ } TclIntStubs; #ifdef __cplusplus @@ -2100,6 +2128,22 @@ extern TclIntStubs *tclIntStubsPtr; #define TclSetObjNameOfExecutable \ (tclIntStubsPtr->tclSetObjNameOfExecutable) /* 214 */ #endif +#ifndef TclStackAlloc +#define TclStackAlloc \ + (tclIntStubsPtr->tclStackAlloc) /* 215 */ +#endif +#ifndef TclStackFree +#define TclStackFree \ + (tclIntStubsPtr->tclStackFree) /* 216 */ +#endif +#ifndef TclPushStackFrame +#define TclPushStackFrame \ + (tclIntStubsPtr->tclPushStackFrame) /* 217 */ +#endif +#ifndef TclPopStackFrame +#define TclPopStackFrame \ + (tclIntStubsPtr->tclPopStackFrame) /* 218 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index b9818a1..48a306d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -21,7 +21,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.69 2004/12/11 14:41:47 msofer Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.70 2004/12/15 20:44:41 msofer Exp $ */ #include "tclInt.h" @@ -533,6 +533,59 @@ Tcl_PopCallFrame(interp) /* *---------------------------------------------------------------------- * + * TclPushStackFrame -- + * + * Allocates a new call frame in the interpreter's execution stack, then + * pushes it onto the interpreter's Tcl call stack. + * Called when executing a Tcl procedure or a "namespace eval" or + * "namespace inscope" command. + * + * Results: + * Returns TCL_OK if successful, or TCL_ERROR (along with an error + * message in the interpreter's result object) if something goes wrong. + * + * Side effects: + * Modifies the interpreter's Tcl call stack. + * + *---------------------------------------------------------------------- + */ + +int +TclPushStackFrame(interp, framePtrPtr, namespacePtr, isProcCallFrame) + Tcl_Interp *interp; /* Interpreter in which the new call frame + * is to be pushed. */ + Tcl_CallFrame **framePtrPtr; /* Place to store a pointer to the stack + * allocated call frame.*/ + Tcl_Namespace *namespacePtr; /* Points to the namespace in which the + * frame will execute. If NULL, the + * interpreter's current namespace will + * be used. */ + int isProcCallFrame; /* If nonzero, the frame represents a + * called Tcl procedure and may have local + * vars. Vars will ordinarily be looked up + * in the frame. If new variables are + * created, they will be created in the + * frame. If 0, the frame is for a + * "namespace eval" or "namespace inscope" + * command and var references are treated + * as references to namespace variables. */ +{ + + *framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame)); + return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr, isProcCallFrame); +} + +void +TclPopStackFrame(interp) + Tcl_Interp* interp; /* Interpreter with call frame to pop. */ +{ + Tcl_PopCallFrame(interp); + TclStackFree(interp); +} + +/* + *---------------------------------------------------------------------- + * * EstablishErrorCodeTraces -- * * Creates traces on the ::errorCode variable to keep its value @@ -2046,14 +2099,14 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, if (entryPtr != NULL) { nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) { - Tcl_CallFrame frame; + Tcl_CallFrame *framePtr; - (void) Tcl_PushCallFrame(interp, &frame, + (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); if (nsPtr == NULL) { Tcl_Panic("Could not create namespace '%s'", nsName); @@ -3183,7 +3236,7 @@ NamespaceEvalCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; - CallFrame frame, *framePtr; + CallFrame *framePtr, **framePtrPtr; Tcl_Obj *objPtr; int result; @@ -3221,14 +3274,14 @@ NamespaceEvalCmd(dummy, interp, objc, objv) */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ - framePtr = &frame; - result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + framePtrPtr = &framePtr; + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return TCL_ERROR; } - frame.objc = objc; - frame.objv = objv; /* ref counts do not need to be incremented here */ + framePtr->objc = objc; + framePtr->objv = objv; /* ref counts do not need to be incremented here */ if (objc == 4) { result = Tcl_EvalObjEx(interp, objv[3], 0); @@ -3260,7 +3313,7 @@ NamespaceEvalCmd(dummy, interp, objc, objv) * Restore the previous "current" namespace. */ - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); return result; } @@ -3596,7 +3649,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; - Tcl_CallFrame frame; + Tcl_CallFrame *framePtr; int i, result; if (objc < 4) { @@ -3622,7 +3675,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv) * Make the specified namespace the current namespace. */ - result = Tcl_PushCallFrame(interp, &frame, namespacePtr, + result = TclPushStackFrame(interp, &framePtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; @@ -3675,7 +3728,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv) * Restore the previous "current" namespace. */ - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); return result; } diff --git a/generic/tclProc.c b/generic/tclProc.c index bcf82d2..feda831 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -10,7 +10,7 @@ * 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.68 2004/12/14 21:11:47 msofer Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.69 2004/12/15 20:44:41 msofer Exp $ */ #include "tclInt.h" @@ -918,8 +918,7 @@ TclObjInterpProc(clientData, interp, objc, objv) { register Proc *procPtr = (Proc *) clientData; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; - CallFrame frame; - register CallFrame *framePtr = &frame; + CallFrame *framePtr, **framePtrPtr; register Var *varPtr; register CompiledLocal *localPtr; char *procName; @@ -975,7 +974,8 @@ TclObjInterpProc(clientData, interp, objc, objv) * from one namespace to another. */ - result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + framePtrPtr = &framePtr; + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, FRAME_IS_PROC); if (result != TCL_OK) { @@ -1139,7 +1139,7 @@ TclObjInterpProc(clientData, interp, objc, objv) */ procDone: - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); if (compiledLocals != localStorage) { ckfree((char *) compiledLocals); } @@ -1181,7 +1181,7 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) { Interp *iPtr = (Interp*)interp; int result; - Tcl_CallFrame frame; + Tcl_CallFrame *framePtr; Proc *saveProcPtr; ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; @@ -1247,12 +1247,12 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) saveProcPtr = iPtr->compiledProcPtr; iPtr->compiledProcPtr = procPtr; - result = Tcl_PushCallFrame(interp, &frame, + result = TclPushStackFrame(interp, &framePtr, (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); if (result == TCL_OK) { result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); } iPtr->compiledProcPtr = saveProcPtr; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 83218f9..7c302bc 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.109 2004/12/01 23:18:53 dgp Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.110 2004/12/15 20:44:42 msofer Exp $ */ #include "tclInt.h" @@ -299,6 +299,10 @@ TclIntStubs tclIntStubs = { TclpFindExecutable, /* 212 */ TclGetObjNameOfExecutable, /* 213 */ TclSetObjNameOfExecutable, /* 214 */ + TclStackAlloc, /* 215 */ + TclStackFree, /* 216 */ + TclPushStackFrame, /* 217 */ + TclPopStackFrame, /* 218 */ }; TclIntPlatStubs tclIntPlatStubs = { diff --git a/generic/tclTest.c b/generic/tclTest.c index c2f9dd0..72c8cef 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.86 2004/11/30 19:34:50 dgp Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.87 2004/12/15 20:44:43 msofer Exp $ */ #define TCL_TEST @@ -4191,7 +4191,7 @@ TestgetvarfullnameCmd(dummy, interp, objc, objv) char *name, *arg; int flags = 0; Tcl_Namespace *namespacePtr; - Tcl_CallFrame frame; + Tcl_CallFrame *framePtr; Tcl_Var variable; int result; @@ -4222,7 +4222,7 @@ TestgetvarfullnameCmd(dummy, interp, objc, objv) if (namespacePtr == NULL) { return TCL_ERROR; } - result = Tcl_PushCallFrame(interp, &frame, namespacePtr, + result = TclPushStackFrame(interp, &framePtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; @@ -4233,7 +4233,7 @@ TestgetvarfullnameCmd(dummy, interp, objc, objv) (flags | TCL_LEAVE_ERR_MSG)); if (flags == TCL_NAMESPACE_ONLY) { - Tcl_PopCallFrame(interp); + TclPopStackFrame(interp); } if (variable == (Tcl_Var) NULL) { return TCL_ERROR; |