diff options
Diffstat (limited to 'generic/tclProc.c')
| -rw-r--r-- | generic/tclProc.c | 221 |
1 files changed, 141 insertions, 80 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c index 145db1c..5042279 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. * - * SCCS: %Z% $Id: tclProc.c,v 1.9 1998/07/21 15:58:44 surles Exp $ + * SCCS: %Z% $Id: tclProc.c,v 1.10 1998/07/24 13:49:29 surles Exp $ */ #include "tclInt.h" @@ -45,7 +45,6 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) register Interp *iPtr = (Interp *) interp; Proc *procPtr; char *fullName, *procName; - char **argArray = NULL; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; Tcl_DString ds; @@ -299,10 +298,8 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) localPtr->isArg = 1; localPtr->isTemp = 0; localPtr->flags = VAR_SCALAR; - localPtr->resolveInfo.identity = NULL; - localPtr->resolveInfo.fetchProc = NULL; - localPtr->resolveInfo.deleteProc = NULL; - + localPtr->resolveInfo = NULL; + if (fieldCount == 2) { localPtr->defValuePtr = Tcl_NewStringObj(fieldValues[1], valueLength); @@ -718,14 +715,12 @@ TclObjInterpProc(clientData, interp, objc, objv) { Interp *iPtr = (Interp *) interp; Proc *procPtr = (Proc *) clientData; - Tcl_Obj *bodyPtr = procPtr->bodyPtr; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; CallFrame frame; register CallFrame *framePtr = &frame; register Var *varPtr, *resolvedVarPtr; register CompiledLocal *localPtr; Tcl_ResolvedVarInfo *resVarInfo; - Proc *saveProcPtr; char *procName, *bytes; int nameLen, localCt, numArgs, argCt, length, i, result; @@ -749,75 +744,16 @@ TclObjInterpProc(clientData, interp, objc, objv) /* * If necessary, compile the procedure's body. The compiler will * allocate frame slots for the procedure's non-argument local - * variables. If the ByteCode already exists, make sure it hasn't been - * invalidated by someone redefining a core command (this might make the - * compiled code wrong). Also, if the code was compiled in/for a - * different interpreter, we recompile it. Note that compiling the body - * might increase procPtr->numCompiledLocals if new local variables are - * found while compiling. - * - * Precompiled procedure bodies, however, are immutable and therefore - * they are not recompiled, even if the epoch has changed. + * variables. Note that compiling the body might increase + * procPtr->numCompiledLocals if new local variables are found + * while compiling. */ - - if (bodyPtr->typePtr == &tclByteCodeType) { - ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; - - if ((codePtr->iPtr != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != nsPtr) - || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if (codePtr->iPtr != iPtr) { - panic("TclObjInterpProc: compiled body jumped interps"); - } - codePtr->compileEpoch = iPtr->compileEpoch; - } else { - tclByteCodeType.freeIntRepProc(bodyPtr); - bodyPtr->typePtr = (Tcl_ObjType *) NULL; - } - } - } - if (bodyPtr->typePtr != &tclByteCodeType) { - char buf[100]; - int numChars; - char *ellipsis; - - if (tclTraceCompile >= 1) { - /* - * Display a line summarizing the top level command we - * are about to compile. - */ - - numChars = nameLen; - ellipsis = ""; - if (numChars > 50) { - numChars = 50; - ellipsis = "..."; - } - fprintf(stdout, "Compiling body of proc \"%.*s%s\"\n", - numChars, procName, ellipsis); - } - - saveProcPtr = iPtr->compiledProcPtr; - iPtr->compiledProcPtr = procPtr; - result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); - iPtr->compiledProcPtr = saveProcPtr; - - if (result != TCL_OK) { - if (result == TCL_ERROR) { - numChars = nameLen; - ellipsis = ""; - if (numChars > 50) { - numChars = 50; - ellipsis = "..."; - } - sprintf(buf, "\n (compiling body of proc \"%.*s%s\", line %d)", - numChars, procName, ellipsis, interp->errorLine); - Tcl_AddObjErrorInfo(interp, buf, -1); - } - return result; - } + + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, + "body of proc", procName); + + if (result != TCL_OK) { + return result; } /* @@ -863,10 +799,10 @@ TclObjInterpProc(clientData, interp, objc, objv) for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; localPtr = localPtr->nextPtr) { - resVarInfo = &localPtr->resolveInfo; + resVarInfo = localPtr->resolveInfo; resolvedVarPtr = NULL; - if (resVarInfo->fetchProc != NULL) { + if (resVarInfo && resVarInfo->fetchProc) { resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, resVarInfo->identity); } @@ -1030,6 +966,130 @@ TclObjInterpProc(clientData, interp, objc, objv) /* *---------------------------------------------------------------------- * + * TclProcCompileProc -- + * + * Called just before a procedure is executed to compile the + * body to byte codes. If the type of the body is not + * "byte code" or if the compile conditions have changed + * (namespace context, epoch counters, etc.) then the body + * is recompiled. Otherwise, this procedure does nothing. + * + * Results: + * None. + * + * Side effects: + * May change the internal representation of the body object + * to compiled code. + * + *---------------------------------------------------------------------- + */ + +int +TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) + Tcl_Interp *interp; /* Interpreter containing procedure. */ + Proc *procPtr; /* Data associated with procedure. */ + Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr, + * 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. */ +{ + Interp *iPtr = (Interp*)interp; + int result; + Tcl_CallFrame frame; + Proc *saveProcPtr; + + /* + * If necessary, compile the procedure's body. The compiler will + * allocate frame slots for the procedure's non-argument local + * variables. If the ByteCode already exists, make sure it hasn't been + * invalidated by someone redefining a core command (this might make the + * compiled code wrong). Also, if the code was compiled in/for a + * different interpreter, we recompile it. Note that compiling the body + * might increase procPtr->numCompiledLocals if new local variables are + * found while compiling. + */ + + if (bodyPtr->typePtr == &tclByteCodeType) { + ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + + if ((codePtr->iPtr != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != nsPtr) + || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { + tclByteCodeType.freeIntRepProc(bodyPtr); + bodyPtr->typePtr = (Tcl_ObjType *) NULL; + } + } + if (bodyPtr->typePtr != &tclByteCodeType) { + char buf[100]; + int numChars; + char *ellipsis; + + if (tclTraceCompile >= 1) { + /* + * Display a line summarizing the top level command we + * are about to compile. + */ + + numChars = strlen(procName); + ellipsis = ""; + if (numChars > 50) { + numChars = 50; + ellipsis = "..."; + } + fprintf(stdout, "Compiling %s \"%.*s%s\"\n", + description, numChars, procName, ellipsis); + } + + /* + * Plug the current procPtr into the interpreter and coerce + * the code body to byte codes. The interpreter needs to + * know which proc it's compiling so that it can access its + * list of compiled locals. + * + * TRICKY NOTE: Be careful to push a call frame with the + * proper namespace context, so that the byte codes are + * compiled in the appropriate class context. + */ + + saveProcPtr = iPtr->compiledProcPtr; + iPtr->compiledProcPtr = procPtr; + + result = Tcl_PushCallFrame(interp, &frame, + (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); + + if (result == TCL_OK) { + result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); + Tcl_PopCallFrame(interp); + } + + iPtr->compiledProcPtr = saveProcPtr; + + if (result != TCL_OK) { + if (result == TCL_ERROR) { + numChars = strlen(procName); + ellipsis = ""; + if (numChars > 50) { + numChars = 50; + ellipsis = "..."; + } + sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)", + description, numChars, procName, ellipsis, + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buf, -1); + } + return result; + } + } + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * * TclProcDeleteProc -- * * This procedure is invoked just before a command procedure is @@ -1092,10 +1152,11 @@ TclProcCleanupProc(procPtr) for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { CompiledLocal *nextPtr = localPtr->nextPtr; - resVarInfo = &localPtr->resolveInfo; - if (resVarInfo->deleteProc != NULL) { + resVarInfo = localPtr->resolveInfo; + if (resVarInfo && resVarInfo->deleteProc) { (*resVarInfo->deleteProc)(resVarInfo->identity); resVarInfo->identity = NULL; + ckfree((char *) resVarInfo); } if (localPtr->defValuePtr != NULL) { |