626 lines
16 KiB
C
626 lines
16 KiB
C
|
/*
|
|||
|
* tclProc.c --
|
|||
|
*
|
|||
|
* This file contains routines that implement Tcl procedures,
|
|||
|
* including the "proc" and "uplevel" commands.
|
|||
|
*
|
|||
|
* Copyright (c) 1987-1993 The Regents of the University of California.
|
|||
|
* All rights reserved.
|
|||
|
*
|
|||
|
* Permission is hereby granted, without written agreement and without
|
|||
|
* license or royalty fees, to use, copy, modify, and distribute this
|
|||
|
* software and its documentation for any purpose, provided that the
|
|||
|
* above copyright notice and the following two paragraphs appear in
|
|||
|
* all copies of this software.
|
|||
|
*
|
|||
|
* IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
|||
|
* DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
|||
|
* OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
|||
|
* CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|||
|
*
|
|||
|
* THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
|||
|
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
|||
|
* AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
|||
|
* ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
|||
|
* PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
|||
|
*/
|
|||
|
|
|||
|
#ifndef lint
|
|||
|
static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclProc.c,v 1.68 93/10/14 15:13:55 ouster Exp $ SPRITE (Berkeley)";
|
|||
|
#endif
|
|||
|
|
|||
|
#include "tclInt.h"
|
|||
|
|
|||
|
/*
|
|||
|
* Forward references to procedures defined later in this file:
|
|||
|
*/
|
|||
|
|
|||
|
static void CleanupProc _ANSI_ARGS_((Proc *procPtr));
|
|||
|
static int InterpProc _ANSI_ARGS_((ClientData clientData,
|
|||
|
Tcl_Interp *interp, int argc, char **argv));
|
|||
|
static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* Tcl_ProcCmd --
|
|||
|
*
|
|||
|
* This procedure is invoked to process the "proc" Tcl command.
|
|||
|
* See the user documentation for details on what it does.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* A standard Tcl result value.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* A new procedure gets created.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
/* ARGSUSED */
|
|||
|
int
|
|||
|
Tcl_ProcCmd(dummy, interp, argc, argv)
|
|||
|
ClientData dummy; /* Not used. */
|
|||
|
Tcl_Interp *interp; /* Current interpreter. */
|
|||
|
int argc; /* Number of arguments. */
|
|||
|
char **argv; /* Argument strings. */
|
|||
|
{
|
|||
|
register Interp *iPtr = (Interp *) interp;
|
|||
|
register Proc *procPtr;
|
|||
|
int result, argCount, i;
|
|||
|
char **argArray = NULL;
|
|||
|
Arg *lastArgPtr;
|
|||
|
register Arg *argPtr = NULL; /* Initialization not needed, but
|
|||
|
* prevents compiler warning. */
|
|||
|
|
|||
|
if (argc != 4) {
|
|||
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
|||
|
" name args body\"", (char *) NULL);
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
procPtr = (Proc *) ckalloc(sizeof(Proc));
|
|||
|
procPtr->iPtr = iPtr;
|
|||
|
procPtr->refCount = 1;
|
|||
|
procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
|
|||
|
strcpy(procPtr->command, argv[3]);
|
|||
|
procPtr->argPtr = NULL;
|
|||
|
|
|||
|
/*
|
|||
|
* Break up the argument list into argument specifiers, then process
|
|||
|
* each argument specifier.
|
|||
|
*/
|
|||
|
|
|||
|
result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
|
|||
|
if (result != TCL_OK) {
|
|||
|
goto procError;
|
|||
|
}
|
|||
|
lastArgPtr = NULL;
|
|||
|
for (i = 0; i < argCount; i++) {
|
|||
|
int fieldCount, nameLength, valueLength;
|
|||
|
char **fieldValues;
|
|||
|
|
|||
|
/*
|
|||
|
* Now divide the specifier up into name and default.
|
|||
|
*/
|
|||
|
|
|||
|
result = Tcl_SplitList(interp, argArray[i], &fieldCount,
|
|||
|
&fieldValues);
|
|||
|
if (result != TCL_OK) {
|
|||
|
goto procError;
|
|||
|
}
|
|||
|
if (fieldCount > 2) {
|
|||
|
ckfree((char *) fieldValues);
|
|||
|
Tcl_AppendResult(interp,
|
|||
|
"too many fields in argument specifier \"",
|
|||
|
argArray[i], "\"", (char *) NULL);
|
|||
|
result = TCL_ERROR;
|
|||
|
goto procError;
|
|||
|
}
|
|||
|
if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
|
|||
|
ckfree((char *) fieldValues);
|
|||
|
Tcl_AppendResult(interp, "procedure \"", argv[1],
|
|||
|
"\" has argument with no name", (char *) NULL);
|
|||
|
result = TCL_ERROR;
|
|||
|
goto procError;
|
|||
|
}
|
|||
|
nameLength = strlen(fieldValues[0]) + 1;
|
|||
|
if (fieldCount == 2) {
|
|||
|
valueLength = strlen(fieldValues[1]) + 1;
|
|||
|
} else {
|
|||
|
valueLength = 0;
|
|||
|
}
|
|||
|
argPtr = (Arg *) ckalloc((unsigned)
|
|||
|
(sizeof(Arg) - sizeof(argPtr->name) + nameLength
|
|||
|
+ valueLength));
|
|||
|
if (lastArgPtr == NULL) {
|
|||
|
procPtr->argPtr = argPtr;
|
|||
|
} else {
|
|||
|
lastArgPtr->nextPtr = argPtr;
|
|||
|
}
|
|||
|
lastArgPtr = argPtr;
|
|||
|
argPtr->nextPtr = NULL;
|
|||
|
strcpy(argPtr->name, fieldValues[0]);
|
|||
|
if (fieldCount == 2) {
|
|||
|
argPtr->defValue = argPtr->name + nameLength;
|
|||
|
strcpy(argPtr->defValue, fieldValues[1]);
|
|||
|
} else {
|
|||
|
argPtr->defValue = NULL;
|
|||
|
}
|
|||
|
ckfree((char *) fieldValues);
|
|||
|
}
|
|||
|
|
|||
|
Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
|
|||
|
ProcDeleteProc);
|
|||
|
ckfree((char *) argArray);
|
|||
|
return TCL_OK;
|
|||
|
|
|||
|
procError:
|
|||
|
ckfree(procPtr->command);
|
|||
|
while (procPtr->argPtr != NULL) {
|
|||
|
argPtr = procPtr->argPtr;
|
|||
|
procPtr->argPtr = argPtr->nextPtr;
|
|||
|
ckfree((char *) argPtr);
|
|||
|
}
|
|||
|
ckfree((char *) procPtr);
|
|||
|
if (argArray != NULL) {
|
|||
|
ckfree((char *) argArray);
|
|||
|
}
|
|||
|
return result;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* TclGetFrame --
|
|||
|
*
|
|||
|
* Given a description of a procedure frame, such as the first
|
|||
|
* argument to an "uplevel" or "upvar" command, locate the
|
|||
|
* call frame for the appropriate level of procedure.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* The return value is -1 if an error occurred in finding the
|
|||
|
* frame (in this case an error message is left in interp->result).
|
|||
|
* 1 is returned if string was either a number or a number preceded
|
|||
|
* by "#" and it specified a valid frame. 0 is returned if string
|
|||
|
* isn't one of the two things above (in this case, the lookup
|
|||
|
* acts as if string were "1"). The variable pointed to by
|
|||
|
* framePtrPtr is filled in with the address of the desired frame
|
|||
|
* (unless an error occurs, in which case it isn't modified).
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* None.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
int
|
|||
|
TclGetFrame(interp, string, framePtrPtr)
|
|||
|
Tcl_Interp *interp; /* Interpreter in which to find frame. */
|
|||
|
char *string; /* String describing frame. */
|
|||
|
CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL
|
|||
|
* if global frame indicated). */
|
|||
|
{
|
|||
|
register Interp *iPtr = (Interp *) interp;
|
|||
|
int curLevel, level, result;
|
|||
|
CallFrame *framePtr;
|
|||
|
|
|||
|
/*
|
|||
|
* Parse string to figure out which level number to go to.
|
|||
|
*/
|
|||
|
|
|||
|
result = 1;
|
|||
|
curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
|
|||
|
if (*string == '#') {
|
|||
|
if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
|
|||
|
return -1;
|
|||
|
}
|
|||
|
if (level < 0) {
|
|||
|
levelError:
|
|||
|
Tcl_AppendResult(interp, "bad level \"", string, "\"",
|
|||
|
(char *) NULL);
|
|||
|
return -1;
|
|||
|
}
|
|||
|
} else if (isdigit(UCHAR(*string))) {
|
|||
|
if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
|
|||
|
return -1;
|
|||
|
}
|
|||
|
level = curLevel - level;
|
|||
|
} else {
|
|||
|
level = curLevel - 1;
|
|||
|
result = 0;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* Figure out which frame to use, and modify the interpreter so
|
|||
|
* its variables come from that frame.
|
|||
|
*/
|
|||
|
|
|||
|
if (level == 0) {
|
|||
|
framePtr = NULL;
|
|||
|
} else {
|
|||
|
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
|
|||
|
framePtr = framePtr->callerVarPtr) {
|
|||
|
if (framePtr->level == level) {
|
|||
|
break;
|
|||
|
}
|
|||
|
}
|
|||
|
if (framePtr == NULL) {
|
|||
|
goto levelError;
|
|||
|
}
|
|||
|
}
|
|||
|
*framePtrPtr = framePtr;
|
|||
|
return result;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* Tcl_UplevelCmd --
|
|||
|
*
|
|||
|
* This procedure is invoked to process the "uplevel" Tcl command.
|
|||
|
* See the user documentation for details on what it does.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* A standard Tcl result value.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* See the user documentation.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
/* ARGSUSED */
|
|||
|
int
|
|||
|
Tcl_UplevelCmd(dummy, interp, argc, argv)
|
|||
|
ClientData dummy; /* Not used. */
|
|||
|
Tcl_Interp *interp; /* Current interpreter. */
|
|||
|
int argc; /* Number of arguments. */
|
|||
|
char **argv; /* Argument strings. */
|
|||
|
{
|
|||
|
register Interp *iPtr = (Interp *) interp;
|
|||
|
int result;
|
|||
|
CallFrame *savedVarFramePtr, *framePtr;
|
|||
|
|
|||
|
if (argc < 2) {
|
|||
|
uplevelSyntax:
|
|||
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
|||
|
" ?level? command ?arg ...?\"", (char *) NULL);
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* Find the level to use for executing the command.
|
|||
|
*/
|
|||
|
|
|||
|
result = TclGetFrame(interp, argv[1], &framePtr);
|
|||
|
if (result == -1) {
|
|||
|
return TCL_ERROR;
|
|||
|
}
|
|||
|
argc -= (result+1);
|
|||
|
if (argc == 0) {
|
|||
|
goto uplevelSyntax;
|
|||
|
}
|
|||
|
argv += (result+1);
|
|||
|
|
|||
|
/*
|
|||
|
* Modify the interpreter state to execute in the given frame.
|
|||
|
*/
|
|||
|
|
|||
|
savedVarFramePtr = iPtr->varFramePtr;
|
|||
|
iPtr->varFramePtr = framePtr;
|
|||
|
|
|||
|
/*
|
|||
|
* Execute the residual arguments as a command.
|
|||
|
*/
|
|||
|
|
|||
|
if (argc == 1) {
|
|||
|
result = Tcl_Eval(interp, argv[0]);
|
|||
|
} else {
|
|||
|
char *cmd;
|
|||
|
|
|||
|
cmd = Tcl_Concat(argc, argv);
|
|||
|
result = Tcl_Eval(interp, cmd);
|
|||
|
ckfree(cmd);
|
|||
|
}
|
|||
|
if (result == TCL_ERROR) {
|
|||
|
char msg[60];
|
|||
|
sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine);
|
|||
|
Tcl_AddErrorInfo(interp, msg);
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* Restore the variable frame, and return.
|
|||
|
*/
|
|||
|
|
|||
|
iPtr->varFramePtr = savedVarFramePtr;
|
|||
|
return result;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* TclFindProc --
|
|||
|
*
|
|||
|
* Given the name of a procedure, return a pointer to the
|
|||
|
* record describing the procedure.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* NULL is returned if the name doesn't correspond to any
|
|||
|
* procedure. Otherwise the return value is a pointer to
|
|||
|
* the procedure's record.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* None.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
Proc *
|
|||
|
TclFindProc(iPtr, procName)
|
|||
|
Interp *iPtr; /* Interpreter in which to look. */
|
|||
|
char *procName; /* Name of desired procedure. */
|
|||
|
{
|
|||
|
Tcl_HashEntry *hPtr;
|
|||
|
Command *cmdPtr;
|
|||
|
|
|||
|
hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
|
|||
|
if (hPtr == NULL) {
|
|||
|
return NULL;
|
|||
|
}
|
|||
|
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
|
|||
|
if (cmdPtr->proc != InterpProc) {
|
|||
|
return NULL;
|
|||
|
}
|
|||
|
return (Proc *) cmdPtr->clientData;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* TclIsProc --
|
|||
|
*
|
|||
|
* Tells whether a command is a Tcl procedure or not.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* If the given command is actuall a Tcl procedure, the
|
|||
|
* return value is the address of the record describing
|
|||
|
* the procedure. Otherwise the return value is 0.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* None.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
Proc *
|
|||
|
TclIsProc(cmdPtr)
|
|||
|
Command *cmdPtr; /* Command to test. */
|
|||
|
{
|
|||
|
if (cmdPtr->proc == InterpProc) {
|
|||
|
return (Proc *) cmdPtr->clientData;
|
|||
|
}
|
|||
|
return (Proc *) 0;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* InterpProc --
|
|||
|
*
|
|||
|
* When a Tcl procedure gets invoked, this routine gets invoked
|
|||
|
* to interpret the procedure.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* A standard Tcl result value, usually TCL_OK.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* Depends on the commands in the procedure.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static int
|
|||
|
InterpProc(clientData, interp, argc, argv)
|
|||
|
ClientData clientData; /* Record describing procedure to be
|
|||
|
* interpreted. */
|
|||
|
Tcl_Interp *interp; /* Interpreter in which procedure was
|
|||
|
* invoked. */
|
|||
|
int argc; /* Count of number of arguments to this
|
|||
|
* procedure. */
|
|||
|
char **argv; /* Argument values. */
|
|||
|
{
|
|||
|
register Proc *procPtr = (Proc *) clientData;
|
|||
|
register Arg *argPtr;
|
|||
|
register Interp *iPtr;
|
|||
|
char **args;
|
|||
|
CallFrame frame;
|
|||
|
char *value;
|
|||
|
int result;
|
|||
|
|
|||
|
/*
|
|||
|
* Set up a call frame for the new procedure invocation.
|
|||
|
*/
|
|||
|
|
|||
|
iPtr = procPtr->iPtr;
|
|||
|
Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
|
|||
|
if (iPtr->varFramePtr != NULL) {
|
|||
|
frame.level = iPtr->varFramePtr->level + 1;
|
|||
|
} else {
|
|||
|
frame.level = 1;
|
|||
|
}
|
|||
|
frame.argc = argc;
|
|||
|
frame.argv = argv;
|
|||
|
frame.callerPtr = iPtr->framePtr;
|
|||
|
frame.callerVarPtr = iPtr->varFramePtr;
|
|||
|
iPtr->framePtr = &frame;
|
|||
|
iPtr->varFramePtr = &frame;
|
|||
|
iPtr->returnCode = TCL_OK;
|
|||
|
|
|||
|
/*
|
|||
|
* Match the actual arguments against the procedure's formal
|
|||
|
* parameters to compute local variables.
|
|||
|
*/
|
|||
|
|
|||
|
for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
|
|||
|
argPtr != NULL;
|
|||
|
argPtr = argPtr->nextPtr, args++, argc--) {
|
|||
|
|
|||
|
/*
|
|||
|
* Handle the special case of the last formal being "args". When
|
|||
|
* it occurs, assign it a list consisting of all the remaining
|
|||
|
* actual arguments.
|
|||
|
*/
|
|||
|
|
|||
|
if ((argPtr->nextPtr == NULL)
|
|||
|
&& (strcmp(argPtr->name, "args") == 0)) {
|
|||
|
if (argc < 0) {
|
|||
|
argc = 0;
|
|||
|
}
|
|||
|
value = Tcl_Merge(argc, args);
|
|||
|
Tcl_SetVar(interp, argPtr->name, value, 0);
|
|||
|
ckfree(value);
|
|||
|
argc = 0;
|
|||
|
break;
|
|||
|
} else if (argc > 0) {
|
|||
|
value = *args;
|
|||
|
} else if (argPtr->defValue != NULL) {
|
|||
|
value = argPtr->defValue;
|
|||
|
} else {
|
|||
|
Tcl_AppendResult(interp, "no value given for parameter \"",
|
|||
|
argPtr->name, "\" to \"", argv[0], "\"",
|
|||
|
(char *) NULL);
|
|||
|
result = TCL_ERROR;
|
|||
|
goto procDone;
|
|||
|
}
|
|||
|
Tcl_SetVar(interp, argPtr->name, value, 0);
|
|||
|
}
|
|||
|
if (argc > 0) {
|
|||
|
Tcl_AppendResult(interp, "called \"", argv[0],
|
|||
|
"\" with too many arguments", (char *) NULL);
|
|||
|
result = TCL_ERROR;
|
|||
|
goto procDone;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* Invoke the commands in the procedure's body.
|
|||
|
*/
|
|||
|
|
|||
|
procPtr->refCount++;
|
|||
|
result = Tcl_Eval(interp, procPtr->command);
|
|||
|
procPtr->refCount--;
|
|||
|
if (procPtr->refCount <= 0) {
|
|||
|
CleanupProc(procPtr);
|
|||
|
}
|
|||
|
if (result == TCL_RETURN) {
|
|||
|
result = iPtr->returnCode;
|
|||
|
iPtr->returnCode = TCL_OK;
|
|||
|
if (result == TCL_ERROR) {
|
|||
|
Tcl_SetVar2(interp, "errorCode", (char *) NULL,
|
|||
|
(iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
|
|||
|
TCL_GLOBAL_ONLY);
|
|||
|
iPtr->flags |= ERROR_CODE_SET;
|
|||
|
if (iPtr->errorInfo != NULL) {
|
|||
|
Tcl_SetVar2(interp, "errorInfo", (char *) NULL,
|
|||
|
iPtr->errorInfo, TCL_GLOBAL_ONLY);
|
|||
|
iPtr->flags |= ERR_IN_PROGRESS;
|
|||
|
}
|
|||
|
}
|
|||
|
} else if (result == TCL_ERROR) {
|
|||
|
char msg[100];
|
|||
|
|
|||
|
/*
|
|||
|
* Record information telling where the error occurred.
|
|||
|
*/
|
|||
|
|
|||
|
sprintf(msg, "\n (procedure \"%.50s\" line %d)", argv[0],
|
|||
|
iPtr->errorLine);
|
|||
|
Tcl_AddErrorInfo(interp, msg);
|
|||
|
} else if (result == TCL_BREAK) {
|
|||
|
iPtr->result = "invoked \"break\" outside of a loop";
|
|||
|
result = TCL_ERROR;
|
|||
|
} else if (result == TCL_CONTINUE) {
|
|||
|
iPtr->result = "invoked \"continue\" outside of a loop";
|
|||
|
result = TCL_ERROR;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* Delete the call frame for this procedure invocation (it's
|
|||
|
* important to remove the call frame from the interpreter
|
|||
|
* before deleting it, so that traces invoked during the
|
|||
|
* deletion don't see the partially-deleted frame).
|
|||
|
*/
|
|||
|
|
|||
|
procDone:
|
|||
|
iPtr->framePtr = frame.callerPtr;
|
|||
|
iPtr->varFramePtr = frame.callerVarPtr;
|
|||
|
TclDeleteVars(iPtr, &frame.varTable);
|
|||
|
return result;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* ProcDeleteProc --
|
|||
|
*
|
|||
|
* This procedure is invoked just before a command procedure is
|
|||
|
* removed from an interpreter. Its job is to release all the
|
|||
|
* resources allocated to the procedure.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* None.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* Memory gets freed, unless the procedure is actively being
|
|||
|
* executed. In this case the cleanup is delayed until the
|
|||
|
* last call to the current procedure completes.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static void
|
|||
|
ProcDeleteProc(clientData)
|
|||
|
ClientData clientData; /* Procedure to be deleted. */
|
|||
|
{
|
|||
|
Proc *procPtr = (Proc *) clientData;
|
|||
|
|
|||
|
procPtr->refCount--;
|
|||
|
if (procPtr->refCount <= 0) {
|
|||
|
CleanupProc(procPtr);
|
|||
|
}
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*
|
|||
|
* CleanupProc --
|
|||
|
*
|
|||
|
* This procedure does all the real work of freeing up a Proc
|
|||
|
* structure. It's called only when the structure's reference
|
|||
|
* count becomes zero.
|
|||
|
*
|
|||
|
* Results:
|
|||
|
* None.
|
|||
|
*
|
|||
|
* Side effects:
|
|||
|
* Memory gets freed.
|
|||
|
*
|
|||
|
*----------------------------------------------------------------------
|
|||
|
*/
|
|||
|
|
|||
|
static void
|
|||
|
CleanupProc(procPtr)
|
|||
|
register Proc *procPtr; /* Procedure to be deleted. */
|
|||
|
{
|
|||
|
register Arg *argPtr;
|
|||
|
|
|||
|
ckfree((char *) procPtr->command);
|
|||
|
for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
|
|||
|
Arg *nextPtr = argPtr->nextPtr;
|
|||
|
|
|||
|
ckfree((char *) argPtr);
|
|||
|
argPtr = nextPtr;
|
|||
|
}
|
|||
|
ckfree((char *) procPtr);
|
|||
|
}
|