summaryrefslogtreecommitdiffstats
path: root/generic/tclProc.c
diff options
context:
space:
mode:
authorwelch <welch>1998-07-20 16:43:31 (GMT)
committerwelch <welch>1998-07-20 16:43:31 (GMT)
commitbe9f877c186f5e653c963118d687ebb452f4bd92 (patch)
tree3199d5e144dd53c8182974539af34c942a797842 /generic/tclProc.c
parent3c3cfebe9a48698fd8c3277b02168613de2ea7e3 (diff)
downloadtcl-be9f877c186f5e653c963118d687ebb452f4bd92.zip
tcl-be9f877c186f5e653c963118d687ebb452f4bd92.tar.gz
tcl-be9f877c186f5e653c963118d687ebb452f4bd92.tar.bz2
Merged changes between child workspace "/home/welch/ws/tcl8.0.3i" and
parent workspace "/home/welch/ws/tcl8.0.3".
Diffstat (limited to 'generic/tclProc.c')
-rw-r--r--generic/tclProc.c178
1 files changed, 138 insertions, 40 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 0679fc5..f2b2617 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.7 1998/07/15 11:08:17 escoffon Exp $
+ * SCCS: %Z% $Id: tclProc.c,v 1.8 1998/07/20 16:44:02 welch Exp $
*/
#include "tclInt.h"
@@ -43,7 +43,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
- register Proc *procPtr;
+ Proc *procPtr;
char *fullName, *procName, *args, *bytes, *p;
char **argArray = NULL;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
@@ -93,6 +93,83 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
}
/*
+ * Create the data structure to represent the procedure.
+ */
+ if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
+ &procPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Now create a command for the procedure. This will initially be in
+ * the current namespace unless the procedure's name included namespace
+ * qualifiers. To create the new command in the right namespace, we
+ * generate a fully qualified name for it.
+ */
+
+ Tcl_DStringInit(&ds);
+ if (nsPtr != iPtr->globalNsPtr) {
+ Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
+ Tcl_DStringAppend(&ds, "::", 2);
+ }
+ Tcl_DStringAppend(&ds, procName, -1);
+
+ Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc,
+ (ClientData) procPtr, TclProcDeleteProc);
+ cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
+ TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
+
+ /*
+ * Now initialize the new procedure's cmdPtr field. This will be used
+ * later when the procedure is called to determine what namespace the
+ * procedure will run in. This will be different than the current
+ * namespace if the proc was renamed into a different namespace.
+ */
+
+ procPtr->cmdPtr = (Command *) cmd;
+
+ return TCL_OK;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCreateProc --
+ *
+ * Creates the data associated with a Tcl procedure definition.
+ *
+ * Results:
+ * Returns TCL_OK on success, along with a pointer to a Tcl
+ * procedure definition in procPtrPtr. This definition should
+ * be freed by calling TclCleanupProc() when it is no longer
+ * needed. Returns TCL_ERROR if anything goes wrong.
+ *
+ * Side effects:
+ * If anything goes wrong, this procedure returns an error
+ * message in the interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
+ Tcl_Interp *interp; /* interpreter containing proc */
+ Namespace *nsPtr; /* namespace containing this proc */
+ 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;
+ char **argArray = NULL;
+
+ register Proc *procPtr;
+ int i, length, result, numArgs;
+ char *args, *bytes, *p;
+ register CompiledLocal *localPtr;
+ Tcl_Obj *defPtr, *resultPtr;
+
+ /*
* If the procedure's body object is shared because its string value is
* identical to, e.g., the body of another procedure, we must create a
* private copy for this procedure to use. Such sharing of procedure
@@ -106,7 +183,6 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
* we would not want any bytecode internal representation.
*/
- bodyPtr = objv[3];
if (Tcl_IsShared(bodyPtr)) {
bytes = Tcl_GetStringFromObj(bodyPtr, &length);
bodyPtr = Tcl_NewStringObj(bytes, length);
@@ -137,7 +213,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
* THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS.
*/
- args = Tcl_GetStringFromObj(objv[2], &length);
+ args = Tcl_GetStringFromObj(argsPtr, &length);
result = Tcl_SplitList(interp, args, &numArgs, &argArray);
if (result != TCL_OK) {
goto procError;
@@ -168,7 +244,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
ckfree((char *) fieldValues);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "procedure \"", fullName,
+ "procedure \"", procName,
"\" has argument with no name", (char *) NULL);
goto procError;
}
@@ -194,7 +270,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
q--;
if (*q == ')') { /* we have an array element */
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "procedure \"", fullName,
+ "procedure \"", procName,
"\" has formal parameter \"", fieldValues[0],
"\" that is an array element",
(char *) NULL);
@@ -225,6 +301,10 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
localPtr->isArg = 1;
localPtr->isTemp = 0;
localPtr->flags = VAR_SCALAR;
+ localPtr->resolveInfo.identity = NULL;
+ localPtr->resolveInfo.fetchProc = NULL;
+ localPtr->resolveInfo.deleteProc = NULL;
+
if (fieldCount == 2) {
localPtr->defValuePtr =
Tcl_NewStringObj(fieldValues[1], valueLength);
@@ -238,37 +318,17 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
}
/*
- * Now create a command for the procedure. This will initially be in
- * the current namespace unless the procedure's name included namespace
- * qualifiers. To create the new command in the right namespace, we
- * generate a fully qualified name for it.
- */
-
- Tcl_DStringInit(&ds);
- if (nsPtr != iPtr->globalNsPtr) {
- Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
- Tcl_DStringAppend(&ds, "::", 2);
- }
- Tcl_DStringAppend(&ds, procName, -1);
-
- Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc,
- (ClientData) procPtr, TclProcDeleteProc);
- cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
- TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
-
- /*
* Now initialize the new procedure's cmdPtr field. This will be used
* later when the procedure is called to determine what namespace the
* procedure will run in. This will be different than the current
* namespace if the proc was renamed into a different namespace.
*/
- procPtr->cmdPtr = (Command *) cmd;
-
+ *procPtrPtr = procPtr;
ckfree((char *) argArray);
return TCL_OK;
- procError:
+procError:
Tcl_DecrRefCount(bodyPtr);
while (procPtr->firstLocalPtr != NULL) {
localPtr = procPtr->firstLocalPtr;
@@ -287,6 +347,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
}
return TCL_ERROR;
}
+
/*
*----------------------------------------------------------------------
@@ -660,10 +721,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;
+ register Var *varPtr, *resolvedVarPtr;
register CompiledLocal *localPtr;
+ Tcl_ResolvedVarInfo *resVarInfo;
Proc *saveProcPtr;
char *procName, *bytes;
int nameLen, localCt, numArgs, argCt, length, i, result;
@@ -703,7 +766,9 @@ TclObjInterpProc(clientData, interp, objc, objv)
ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
if ((codePtr->iPtr != iPtr)
- || (codePtr->compileEpoch != iPtr->compileEpoch)) {
+ || (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");
@@ -777,8 +842,8 @@ TclObjInterpProc(clientData, interp, objc, objv)
*/
result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
- (Tcl_Namespace *) procPtr->cmdPtr->nsPtr,
- /*isProcCallFrame*/ 1);
+ (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1);
+
if (result != TCL_OK) {
return result;
}
@@ -791,19 +856,45 @@ TclObjInterpProc(clientData, interp, objc, objv)
/*
* Initialize the array of local variables stored in the call frame.
+ * Some variables may have special resolution rules. In that case,
+ * we call their "resolver" procs to get our hands on the variable,
+ * and we make the compiled local a link to the real variable.
*/
varPtr = framePtr->compiledLocals;
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
localPtr = localPtr->nextPtr) {
- varPtr->value.objPtr = NULL;
- varPtr->name = localPtr->name; /* will be just '\0' if temp var */
- varPtr->nsPtr = NULL;
- varPtr->hPtr = NULL;
- varPtr->refCount = 0;
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
- varPtr->flags = (localPtr->flags | VAR_UNDEFINED);
+
+ resVarInfo = &localPtr->resolveInfo;
+ resolvedVarPtr = NULL;
+
+ if (resVarInfo->fetchProc != NULL) {
+ resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
+ resVarInfo->identity);
+ }
+
+ if (resolvedVarPtr) {
+ varPtr->name = localPtr->name; /* will be just '\0' if temp var */
+ varPtr->nsPtr = NULL;
+ varPtr->hPtr = NULL;
+ varPtr->refCount = 0;
+ varPtr->tracePtr = NULL;
+ varPtr->searchPtr = NULL;
+ varPtr->flags = 0;
+ TclSetVarLink(varPtr);
+ varPtr->value.linkPtr = resolvedVarPtr;
+ resolvedVarPtr->refCount++;
+ }
+ else {
+ varPtr->value.objPtr = NULL;
+ varPtr->name = localPtr->name; /* will be just '\0' if temp var */
+ varPtr->nsPtr = NULL;
+ varPtr->hPtr = NULL;
+ varPtr->refCount = 0;
+ varPtr->tracePtr = NULL;
+ varPtr->searchPtr = NULL;
+ varPtr->flags = (localPtr->flags | VAR_UNDEFINED);
+ }
varPtr++;
}
@@ -995,6 +1086,7 @@ TclProcCleanupProc(procPtr)
register CompiledLocal *localPtr;
Tcl_Obj *bodyPtr = procPtr->bodyPtr;
Tcl_Obj *defPtr;
+ Tcl_ResolvedVarInfo *resVarInfo;
if (bodyPtr != NULL) {
Tcl_DecrRefCount(bodyPtr);
@@ -1002,6 +1094,12 @@ TclProcCleanupProc(procPtr)
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
CompiledLocal *nextPtr = localPtr->nextPtr;
+ resVarInfo = &localPtr->resolveInfo;
+ if (resVarInfo->deleteProc != NULL) {
+ (*resVarInfo->deleteProc)(resVarInfo->identity);
+ resVarInfo->identity = NULL;
+ }
+
if (localPtr->defValuePtr != NULL) {
defPtr = localPtr->defValuePtr;
Tcl_DecrRefCount(defPtr);