659 lines
17 KiB
C
659 lines
17 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.
|
||
* Copyright (c) 1994-1995 Sun Microsystems, Inc.
|
||
*
|
||
* See the file "license.terms" for information on usage and redistribution
|
||
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
*
|
||
* SCCS: @(#) tclProc.c 1.72 96/02/15 11:42:48
|
||
*/
|
||
|
||
#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 = TclUpdateReturnInfo(iPtr);
|
||
} 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;
|
||
|
||
/*
|
||
* The check below is a hack. The problem is that there could be
|
||
* unset traces on the variables, which cause scripts to be evaluated.
|
||
* This will clear the ERR_IN_PROGRESS flag, losing stack trace
|
||
* information if the procedure was exiting with an error. The
|
||
* code below preserves the flag. Unfortunately, that isn't
|
||
* really enough: we really should preserve the errorInfo variable
|
||
* too (otherwise a nested error in the trace script will trash
|
||
* errorInfo). What's really needed is a general-purpose
|
||
* mechanism for saving and restoring interpreter state.
|
||
*/
|
||
|
||
if (iPtr->flags & ERR_IN_PROGRESS) {
|
||
TclDeleteVars(iPtr, &frame.varTable);
|
||
iPtr->flags |= ERR_IN_PROGRESS;
|
||
} else {
|
||
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);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclUpdateReturnInfo --
|
||
*
|
||
* This procedure is called when procedures return, and at other
|
||
* points where the TCL_RETURN code is used. It examines fields
|
||
* such as iPtr->returnCode and iPtr->errorCode and modifies
|
||
* the real return status accordingly.
|
||
*
|
||
* Results:
|
||
* The return value is the true completion code to use for
|
||
* the procedure, instead of TCL_RETURN.
|
||
*
|
||
* Side effects:
|
||
* The errorInfo and errorCode variables may get modified.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclUpdateReturnInfo(iPtr)
|
||
Interp *iPtr; /* Interpreter for which TCL_RETURN
|
||
* exception is being processed. */
|
||
{
|
||
int code;
|
||
|
||
code = iPtr->returnCode;
|
||
iPtr->returnCode = TCL_OK;
|
||
if (code == TCL_ERROR) {
|
||
Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL,
|
||
(iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
|
||
TCL_GLOBAL_ONLY);
|
||
iPtr->flags |= ERROR_CODE_SET;
|
||
if (iPtr->errorInfo != NULL) {
|
||
Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL,
|
||
iPtr->errorInfo, TCL_GLOBAL_ONLY);
|
||
iPtr->flags |= ERR_IN_PROGRESS;
|
||
}
|
||
}
|
||
return code;
|
||
}
|