diff options
Diffstat (limited to 'generic/tclProc.c')
| -rw-r--r-- | generic/tclProc.c | 185 |
1 files changed, 109 insertions, 76 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c index d9f5f58..3609d16 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -5,12 +5,12 @@ * including the "proc" and "uplevel" commands. * * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * 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.18 1999/03/10 05:52:49 stanton Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.19 1999/04/16 00:46:52 stanton Exp $ */ #include "tclInt.h" @@ -25,6 +25,8 @@ static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr)); static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp, + char *procName, int nameLen, int returnCode)); /* * The ProcBodyObjType type @@ -37,7 +39,6 @@ Tcl_ObjType tclProcBodyType = { ProcBodyUpdateString, /* UpdateString procedure */ ProcBodySetFromAny /* SetFromAny procedure */ }; - /* *---------------------------------------------------------------------- @@ -82,9 +83,9 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) * current namespace. */ - fullName = Tcl_GetStringFromObj(objv[1], (int *) NULL); + fullName = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, - /*flags*/ 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -145,7 +146,6 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) return TCL_OK; } - /* *---------------------------------------------------------------------- @@ -452,7 +452,6 @@ procError: } return TCL_ERROR; } - /* *---------------------------------------------------------------------- @@ -464,8 +463,8 @@ procError: * 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). + * The return value is -1 if an error occurred in finding the frame + * (in this case an error message is left in the interp's 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 @@ -506,7 +505,7 @@ TclGetFrame(interp, string, framePtrPtr) (char *) NULL); return -1; } - } else if (isdigit(UCHAR(*string))) { + } else if (isdigit(UCHAR(*string))) { /* INTL: digit */ if (Tcl_GetInt(interp, string, &level) != TCL_OK) { return -1; } @@ -565,7 +564,7 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) { register Interp *iPtr = (Interp *) interp; char *optLevel; - int length, result; + int result; CallFrame *savedVarFramePtr, *framePtr; if (objc < 2) { @@ -576,10 +575,9 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) /* * Find the level to use for executing the command. - * THIS FAILS IF THE OBJECT RESULT'S STRING REP CONTAINS A NULL. */ - optLevel = Tcl_GetStringFromObj(objv[1], &length); + optLevel = TclGetString(objv[1]); result = TclGetFrame(interp, optLevel, &framePtr); if (result == -1) { return TCL_ERROR; @@ -602,14 +600,15 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) */ if (objc == 1) { - result = Tcl_EvalObj(interp, objv[0]); + result = Tcl_EvalObjEx(interp, objv[0], 0); } else { - Tcl_Obj *cmdObjPtr = Tcl_ConcatObj(objc, objv); - result = Tcl_EvalObj(interp, cmdObjPtr); - Tcl_DecrRefCount(cmdObjPtr); /* done with object */ + Tcl_Obj *objPtr; + + objPtr = Tcl_ConcatObj(objc, objv); + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { - char msg[60]; + char msg[32 + TCL_INTEGER_SPACE]; sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } @@ -628,12 +627,17 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) * TclFindProc -- * * Given the name of a procedure, return a pointer to the - * record describing the procedure. + * record describing the procedure. The procedure will be + * looked up using the usual rules: first in the current + * namespace and then in the global namespace. * * 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. + * procedure. Otherwise, the return value is a pointer to + * the procedure's record. If the name is found but refers + * to an imported command that points to a "real" procedure + * defined in another namespace, a pointer to that "real" + * procedure's structure is returned. * * Side effects: * None. @@ -768,11 +772,9 @@ TclProcInterpProc(clientData, interp, argc, argv) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); /* @@ -815,23 +817,23 @@ TclProcInterpProc(clientData, interp, argc, argv) int TclObjInterpProc(clientData, interp, objc, objv) - ClientData clientData; /* Record describing procedure to be - * interpreted. */ - Tcl_Interp *interp; /* Interpreter in which procedure was - * invoked. */ - int objc; /* Count of number of arguments to this - * procedure. */ - Tcl_Obj *CONST objv[]; /* Argument value objects. */ + ClientData clientData; /* Record describing procedure to be + * interpreted. */ + register Tcl_Interp *interp; /* Interpreter in which procedure was + * invoked. */ + int objc; /* Count of number of arguments to this + * procedure. */ + Tcl_Obj *CONST objv[]; /* Argument value objects. */ { Interp *iPtr = (Interp *) interp; - Proc *procPtr = (Proc *) clientData; + register Proc *procPtr = (Proc *) clientData; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; CallFrame frame; register CallFrame *framePtr = &frame; + register Var *varPtr; register CompiledLocal *localPtr; - char *procName, *bytes; - int nameLen, localCt, numArgs, argCt, length, i, result; - Var *varPtr; + char *procName; + int nameLen, localCt, numArgs, argCt, i, result; /* * This procedure generates an array "compiledLocals" that holds the @@ -845,7 +847,6 @@ TclObjInterpProc(clientData, interp, objc, objv) /* * Get the procedure's name. - * THIS FAILS IF THE PROC NAME'S STRING REP HAS A NULL. */ procName = Tcl_GetStringFromObj(objv[0], &nameLen); @@ -857,7 +858,7 @@ TclObjInterpProc(clientData, interp, objc, objv) * procPtr->numCompiledLocals if new local variables are found * while compiling. */ - + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, "body of proc", procName); @@ -903,7 +904,7 @@ TclObjInterpProc(clientData, interp, objc, objv) framePtr->compiledLocals = compiledLocals; TclInitCompiledLocals(interp, framePtr, nsPtr); - + /* * Match and assign the call's actual parameters to the procedure's * formal arguments. The formal arguments are described by the first @@ -956,8 +957,7 @@ TclObjInterpProc(clientData, interp, objc, objv) Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "no value given for parameter \"", localPtr->name, - "\" to \"", Tcl_GetStringFromObj(objv[0], (int *) NULL), - "\"", (char *) NULL); + "\" to \"", Tcl_GetString(objv[0]), "\"", (char *) NULL); result = TCL_ERROR; goto procDone; } @@ -966,7 +966,7 @@ TclObjInterpProc(clientData, interp, objc, objv) } if (argCt > 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "called \"", Tcl_GetStringFromObj(objv[0], (int *) NULL), + "called \"", Tcl_GetString(objv[0]), "\" with too many arguments", (char *) NULL); result = TCL_ERROR; goto procDone; @@ -977,57 +977,38 @@ TclObjInterpProc(clientData, interp, objc, objv) */ if (tclTraceExec >= 1) { +#ifdef TCL_COMPILE_DEBUG fprintf(stdout, "Calling proc "); for (i = 0; i < objc; i++) { - bytes = Tcl_GetStringFromObj(objv[i], &length); - TclPrintSource(stdout, bytes, TclMin(length, 15)); + TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); } fprintf(stdout, "\n"); +#else /* TCL_COMPILE_DEBUG */ + fprintf(stdout, "Calling proc %.*s\n", nameLen, procName); +#endif /*TCL_COMPILE_DEBUG*/ fflush(stdout); } iPtr->returnCode = TCL_OK; procPtr->refCount++; - result = Tcl_EvalObj(interp, procPtr->bodyPtr); + result = Tcl_EvalObjEx(interp, procPtr->bodyPtr, 0); procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } if (result != TCL_OK) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } else if (result == TCL_ERROR) { - char msg[100]; - sprintf(msg, "\n (procedure \"%.50s\" line %d)", - procName, iPtr->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } else if (result == TCL_BREAK) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"break\" outside of a loop", -1); - result = TCL_ERROR; - } else if (result == TCL_CONTINUE) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"continue\" outside of a loop", -1); - result = TCL_ERROR; - } + result = ProcessProcResultCode(interp, procName, nameLen, result); } - procDone: - /* - * Pop and free the call frame for this procedure invocation. + * Pop and free the call frame for this procedure invocation, then + * free the compiledLocals array if malloc'ed storage was used. */ + procDone: Tcl_PopCallFrame(interp); - - /* - * Free the compiledLocals array if malloc'ed storage was used. - */ - if (compiledLocals != localStorage) { ckfree((char *) compiledLocals); } @@ -1088,11 +1069,11 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) */ if (bodyPtr->typePtr == &tclByteCodeType) { - if ((codePtr->iPtr != iPtr) + if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if (codePtr->iPtr != iPtr) { + if ((Interp *) *codePtr->interpHandle != iPtr) { Tcl_AppendResult(interp, "a precompiled script jumped interps", NULL); return TCL_ERROR; @@ -1100,7 +1081,7 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { - tclByteCodeType.freeIntRepProc(bodyPtr); + (*tclByteCodeType.freeIntRepProc)(bodyPtr); bodyPtr->typePtr = (Tcl_ObjType *) NULL; } } @@ -1188,7 +1169,59 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) } return TCL_OK; } - + +/* + *---------------------------------------------------------------------- + * + * ProcessProcResultCode -- + * + * Procedure called by TclObjInterpProc to process a return code other + * than TCL_OK returned by a Tcl procedure. + * + * Results: + * Depending on the argument return code, the result returned is + * another return code and the interpreter's result is set to a value + * to supplement that return code. + * + * Side effects: + * If the result returned is TCL_ERROR, traceback information about + * the procedure just executed is appended to the interpreter's + * "errorInfo" variable. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessProcResultCode(interp, procName, nameLen, returnCode) + Tcl_Interp *interp; /* The interpreter in which the procedure + * was called and returned returnCode. */ + char *procName; /* Name of the procedure. Used for error + * messages and trace information. */ + int nameLen; /* Number of bytes in procedure's name. */ + int returnCode; /* The unexpected result code. */ +{ + Interp *iPtr = (Interp *) interp; + char msg[100 + TCL_INTEGER_SPACE]; + + if (returnCode == TCL_RETURN) { + returnCode = TclUpdateReturnInfo(iPtr); + } else if (returnCode == TCL_ERROR) { + sprintf(msg, "\n (procedure \"%.*s\" line %d)", + nameLen, procName, iPtr->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } else if (returnCode == TCL_BREAK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"break\" outside of a loop", -1); + returnCode = TCL_ERROR; + } else if (returnCode == TCL_CONTINUE) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"continue\" outside of a loop", -1); + returnCode = TCL_ERROR; + } + return returnCode; +} /* *---------------------------------------------------------------------- @@ -1339,7 +1372,7 @@ TclUpdateReturnInfo(iPtr) TclCmdProcType TclGetInterpProc() { - return TclProcInterpProc; + return (TclCmdProcType) TclProcInterpProc; } /* @@ -1364,7 +1397,7 @@ TclGetInterpProc() TclObjCmdProcType TclGetObjInterpProc() { - return TclObjInterpProc; + return (TclObjCmdProcType) TclObjInterpProc; } /* |