os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclProc.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclProc.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1944 @@
1.4 +/*
1.5 + * tclProc.c --
1.6 + *
1.7 + * This file contains routines that implement Tcl procedures,
1.8 + * including the "proc" and "uplevel" commands.
1.9 + *
1.10 + * Copyright (c) 1987-1993 The Regents of the University of California.
1.11 + * Copyright (c) 1994-1998 Sun Microsystems, Inc.
1.12 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.13 + *
1.14 + * See the file "license.terms" for information on usage and redistribution
1.15 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 + *
1.17 + * RCS: @(#) $Id: tclProc.c,v 1.44.2.6 2006/11/28 22:20:02 andreas_kupries Exp $
1.18 + */
1.19 +
1.20 +#include "tclInt.h"
1.21 +#include "tclCompile.h"
1.22 +
1.23 +/*
1.24 + * Prototypes for static functions in this file
1.25 + */
1.26 +
1.27 +static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr));
1.28 +static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr));
1.29 +static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp,
1.30 + Tcl_Obj *objPtr));
1.31 +static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr));
1.32 +static int ProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp,
1.33 + Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr,
1.34 + CONST char *description, CONST char *procName,
1.35 + Proc **procPtrPtr));
1.36 +static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
1.37 + char *procName, int nameLen, int returnCode));
1.38 +static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp,
1.39 + Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
1.40 +
1.41 +/*
1.42 + * The ProcBodyObjType type
1.43 + */
1.44 +
1.45 +Tcl_ObjType tclProcBodyType = {
1.46 + "procbody", /* name for this type */
1.47 + ProcBodyFree, /* FreeInternalRep procedure */
1.48 + ProcBodyDup, /* DupInternalRep procedure */
1.49 + ProcBodyUpdateString, /* UpdateString procedure */
1.50 + ProcBodySetFromAny /* SetFromAny procedure */
1.51 +};
1.52 +
1.53 +/*
1.54 + *----------------------------------------------------------------------
1.55 + *
1.56 + * Tcl_ProcObjCmd --
1.57 + *
1.58 + * This object-based procedure is invoked to process the "proc" Tcl
1.59 + * command. See the user documentation for details on what it does.
1.60 + *
1.61 + * Results:
1.62 + * A standard Tcl object result value.
1.63 + *
1.64 + * Side effects:
1.65 + * A new procedure gets created.
1.66 + *
1.67 + *----------------------------------------------------------------------
1.68 + */
1.69 +
1.70 + /* ARGSUSED */
1.71 +EXPORT_C int
1.72 +Tcl_ProcObjCmd(dummy, interp, objc, objv)
1.73 + ClientData dummy; /* Not used. */
1.74 + Tcl_Interp *interp; /* Current interpreter. */
1.75 + int objc; /* Number of arguments. */
1.76 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.77 +{
1.78 + register Interp *iPtr = (Interp *) interp;
1.79 + Proc *procPtr;
1.80 + char *fullName;
1.81 + CONST char *procName, *procArgs, *procBody;
1.82 + Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
1.83 + Tcl_Command cmd;
1.84 + Tcl_DString ds;
1.85 +
1.86 + if (objc != 4) {
1.87 + Tcl_WrongNumArgs(interp, 1, objv, "name args body");
1.88 + return TCL_ERROR;
1.89 + }
1.90 +
1.91 + /*
1.92 + * Determine the namespace where the procedure should reside. Unless
1.93 + * the command name includes namespace qualifiers, this will be the
1.94 + * current namespace.
1.95 + */
1.96 +
1.97 + fullName = TclGetString(objv[1]);
1.98 + TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL,
1.99 + 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
1.100 +
1.101 + if (nsPtr == NULL) {
1.102 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.103 + "can't create procedure \"", fullName,
1.104 + "\": unknown namespace", (char *) NULL);
1.105 + return TCL_ERROR;
1.106 + }
1.107 + if (procName == NULL) {
1.108 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.109 + "can't create procedure \"", fullName,
1.110 + "\": bad procedure name", (char *) NULL);
1.111 + return TCL_ERROR;
1.112 + }
1.113 + if ((nsPtr != iPtr->globalNsPtr)
1.114 + && (procName != NULL) && (procName[0] == ':')) {
1.115 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.116 + "can't create procedure \"", procName,
1.117 + "\" in non-global namespace with name starting with \":\"",
1.118 + (char *) NULL);
1.119 + return TCL_ERROR;
1.120 + }
1.121 +
1.122 + /*
1.123 + * Create the data structure to represent the procedure.
1.124 + */
1.125 + if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
1.126 + &procPtr) != TCL_OK) {
1.127 + return TCL_ERROR;
1.128 + }
1.129 +
1.130 + /*
1.131 + * Now create a command for the procedure. This will initially be in
1.132 + * the current namespace unless the procedure's name included namespace
1.133 + * qualifiers. To create the new command in the right namespace, we
1.134 + * generate a fully qualified name for it.
1.135 + */
1.136 +
1.137 + Tcl_DStringInit(&ds);
1.138 + if (nsPtr != iPtr->globalNsPtr) {
1.139 + Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
1.140 + Tcl_DStringAppend(&ds, "::", 2);
1.141 + }
1.142 + Tcl_DStringAppend(&ds, procName, -1);
1.143 +
1.144 + Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc,
1.145 + (ClientData) procPtr, TclProcDeleteProc);
1.146 + cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
1.147 + TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
1.148 +
1.149 + Tcl_DStringFree(&ds);
1.150 + /*
1.151 + * Now initialize the new procedure's cmdPtr field. This will be used
1.152 + * later when the procedure is called to determine what namespace the
1.153 + * procedure will run in. This will be different than the current
1.154 + * namespace if the proc was renamed into a different namespace.
1.155 + */
1.156 +
1.157 + procPtr->cmdPtr = (Command *) cmd;
1.158 +
1.159 +#ifdef TCL_TIP280
1.160 + /* TIP #280 Remember the line the procedure body is starting on. In a
1.161 + * Byte code context we ask the engine to provide us with the necessary
1.162 + * information. This is for the initialization of the byte code compiler
1.163 + * when the body is used for the first time.
1.164 + */
1.165 +
1.166 + if (iPtr->cmdFramePtr) {
1.167 + CmdFrame context = *iPtr->cmdFramePtr;
1.168 +
1.169 + if (context.type == TCL_LOCATION_BC) {
1.170 + TclGetSrcInfoForPc (&context);
1.171 + /* May get path in context */
1.172 + } else if (context.type == TCL_LOCATION_SOURCE) {
1.173 + /* context now holds another reference */
1.174 + Tcl_IncrRefCount (context.data.eval.path);
1.175 + }
1.176 +
1.177 + /* type == TCL_LOCATION_PREBC implies that 'line' is NULL here! We
1.178 + * cannot assume that 'line' is valid here, we have to check. If the
1.179 + * outer context is an eval (bc, prebc, eval) we do not save any
1.180 + * information. Counting relative to the beginning of the proc body is
1.181 + * more sensible than counting relative to the outer eval block.
1.182 + */
1.183 +
1.184 + if ((context.type == TCL_LOCATION_SOURCE) &&
1.185 + context.line &&
1.186 + (context.nline >= 4) &&
1.187 + (context.line [3] >= 0)) {
1.188 + int new;
1.189 + CmdFrame* cfPtr = (CmdFrame*) ckalloc (sizeof (CmdFrame));
1.190 +
1.191 + cfPtr->level = -1;
1.192 + cfPtr->type = context.type;
1.193 + cfPtr->line = (int*) ckalloc (sizeof (int));
1.194 + cfPtr->line [0] = context.line [3];
1.195 + cfPtr->nline = 1;
1.196 + cfPtr->framePtr = NULL;
1.197 + cfPtr->nextPtr = NULL;
1.198 +
1.199 + if (context.type == TCL_LOCATION_SOURCE) {
1.200 + cfPtr->data.eval.path = context.data.eval.path;
1.201 + /* Transfer of reference. The reference going away (release of
1.202 + * the context) is replaced by the reference in the
1.203 + * constructed cmdframe */
1.204 + } else {
1.205 + cfPtr->type = TCL_LOCATION_EVAL;
1.206 + cfPtr->data.eval.path = NULL;
1.207 + }
1.208 +
1.209 + cfPtr->cmd.str.cmd = NULL;
1.210 + cfPtr->cmd.str.len = 0;
1.211 +
1.212 + Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->linePBodyPtr,
1.213 + (char*) procPtr, &new),
1.214 + cfPtr);
1.215 + }
1.216 + }
1.217 +#endif
1.218 +
1.219 + /*
1.220 + * Optimize for noop procs: if the body is not precompiled (like a TclPro
1.221 + * procbody), and the argument list is just "args" and the body is empty,
1.222 + * define a compileProc to compile a noop.
1.223 + *
1.224 + * Notes:
1.225 + * - cannot be done for any argument list without having different
1.226 + * compiled/not-compiled behaviour in the "wrong argument #" case,
1.227 + * or making this code much more complicated. In any case, it doesn't
1.228 + * seem to make a lot of sense to verify the number of arguments we
1.229 + * are about to ignore ...
1.230 + * - could be enhanced to handle also non-empty bodies that contain
1.231 + * only comments; however, parsing the body will slow down the
1.232 + * compilation of all procs whose argument list is just _args_ */
1.233 +
1.234 + if (objv[3]->typePtr == &tclProcBodyType) {
1.235 + goto done;
1.236 + }
1.237 +
1.238 + procArgs = Tcl_GetString(objv[2]);
1.239 +
1.240 + while (*procArgs == ' ') {
1.241 + procArgs++;
1.242 + }
1.243 +
1.244 + if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
1.245 + procArgs +=4;
1.246 + while(*procArgs != '\0') {
1.247 + if (*procArgs != ' ') {
1.248 + goto done;
1.249 + }
1.250 + procArgs++;
1.251 + }
1.252 +
1.253 + /*
1.254 + * The argument list is just "args"; check the body
1.255 + */
1.256 +
1.257 + procBody = Tcl_GetString(objv[3]);
1.258 + while (*procBody != '\0') {
1.259 + if (!isspace(UCHAR(*procBody))) {
1.260 + goto done;
1.261 + }
1.262 + procBody++;
1.263 + }
1.264 +
1.265 + /*
1.266 + * The body is just spaces: link the compileProc
1.267 + */
1.268 +
1.269 + ((Command *) cmd)->compileProc = TclCompileNoOp;
1.270 + }
1.271 +
1.272 + done:
1.273 + return TCL_OK;
1.274 +}
1.275 +
1.276 +/*
1.277 + *----------------------------------------------------------------------
1.278 + *
1.279 + * TclCreateProc --
1.280 + *
1.281 + * Creates the data associated with a Tcl procedure definition.
1.282 + * This procedure knows how to handle two types of body objects:
1.283 + * strings and procbody. Strings are the traditional (and common) value
1.284 + * for bodies, procbody are values created by extensions that have
1.285 + * loaded a previously compiled script.
1.286 + *
1.287 + * Results:
1.288 + * Returns TCL_OK on success, along with a pointer to a Tcl
1.289 + * procedure definition in procPtrPtr. This definition should
1.290 + * be freed by calling TclCleanupProc() when it is no longer
1.291 + * needed. Returns TCL_ERROR if anything goes wrong.
1.292 + *
1.293 + * Side effects:
1.294 + * If anything goes wrong, this procedure returns an error
1.295 + * message in the interpreter.
1.296 + *
1.297 + *----------------------------------------------------------------------
1.298 + */
1.299 +int
1.300 +TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
1.301 + Tcl_Interp *interp; /* interpreter containing proc */
1.302 + Namespace *nsPtr; /* namespace containing this proc */
1.303 + CONST char *procName; /* unqualified name of this proc */
1.304 + Tcl_Obj *argsPtr; /* description of arguments */
1.305 + Tcl_Obj *bodyPtr; /* command body */
1.306 + Proc **procPtrPtr; /* returns: pointer to proc data */
1.307 +{
1.308 + Interp *iPtr = (Interp*)interp;
1.309 + CONST char **argArray = NULL;
1.310 +
1.311 + register Proc *procPtr;
1.312 + int i, length, result, numArgs;
1.313 + CONST char *args, *bytes, *p;
1.314 + register CompiledLocal *localPtr = NULL;
1.315 + Tcl_Obj *defPtr;
1.316 + int precompiled = 0;
1.317 +
1.318 + if (bodyPtr->typePtr == &tclProcBodyType) {
1.319 + /*
1.320 + * Because the body is a TclProProcBody, the actual body is already
1.321 + * compiled, and it is not shared with anyone else, so it's OK not to
1.322 + * unshare it (as a matter of fact, it is bad to unshare it, because
1.323 + * there may be no source code).
1.324 + *
1.325 + * We don't create and initialize a Proc structure for the procedure;
1.326 + * rather, we use what is in the body object. Note that
1.327 + * we initialize its cmdPtr field below after we've created the command
1.328 + * for the procedure. We increment the ref count of the Proc struct
1.329 + * since the command (soon to be created) will be holding a reference
1.330 + * to it.
1.331 + */
1.332 +
1.333 + procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr;
1.334 + procPtr->iPtr = iPtr;
1.335 + procPtr->refCount++;
1.336 + precompiled = 1;
1.337 + } else {
1.338 + /*
1.339 + * If the procedure's body object is shared because its string value is
1.340 + * identical to, e.g., the body of another procedure, we must create a
1.341 + * private copy for this procedure to use. Such sharing of procedure
1.342 + * bodies is rare but can cause problems. A procedure body is compiled
1.343 + * in a context that includes the number of compiler-allocated "slots"
1.344 + * for local variables. Each formal parameter is given a local variable
1.345 + * slot (the "procPtr->numCompiledLocals = numArgs" assignment
1.346 + * below). This means that the same code can not be shared by two
1.347 + * procedures that have a different number of arguments, even if their
1.348 + * bodies are identical. Note that we don't use Tcl_DuplicateObj since
1.349 + * we would not want any bytecode internal representation.
1.350 + */
1.351 +
1.352 + if (Tcl_IsShared(bodyPtr)) {
1.353 + bytes = Tcl_GetStringFromObj(bodyPtr, &length);
1.354 + bodyPtr = Tcl_NewStringObj(bytes, length);
1.355 + }
1.356 +
1.357 + /*
1.358 + * Create and initialize a Proc structure for the procedure. Note that
1.359 + * we initialize its cmdPtr field below after we've created the command
1.360 + * for the procedure. We increment the ref count of the procedure's
1.361 + * body object since there will be a reference to it in the Proc
1.362 + * structure.
1.363 + */
1.364 +
1.365 + Tcl_IncrRefCount(bodyPtr);
1.366 +
1.367 + procPtr = (Proc *) ckalloc(sizeof(Proc));
1.368 + procPtr->iPtr = iPtr;
1.369 + procPtr->refCount = 1;
1.370 + procPtr->bodyPtr = bodyPtr;
1.371 + procPtr->numArgs = 0; /* actual argument count is set below. */
1.372 + procPtr->numCompiledLocals = 0;
1.373 + procPtr->firstLocalPtr = NULL;
1.374 + procPtr->lastLocalPtr = NULL;
1.375 + }
1.376 +
1.377 + /*
1.378 + * Break up the argument list into argument specifiers, then process
1.379 + * each argument specifier.
1.380 + * If the body is precompiled, processing is limited to checking that
1.381 + * the the parsed argument is consistent with the one stored in the
1.382 + * Proc.
1.383 + * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS.
1.384 + */
1.385 +
1.386 + args = Tcl_GetStringFromObj(argsPtr, &length);
1.387 + result = Tcl_SplitList(interp, args, &numArgs, &argArray);
1.388 + if (result != TCL_OK) {
1.389 + goto procError;
1.390 + }
1.391 +
1.392 + if (precompiled) {
1.393 + if (numArgs > procPtr->numArgs) {
1.394 + char buf[64 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];
1.395 + sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d",
1.396 + numArgs, procPtr->numArgs);
1.397 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.398 + "procedure \"", procName,
1.399 + buf, (char *) NULL);
1.400 + goto procError;
1.401 + }
1.402 + localPtr = procPtr->firstLocalPtr;
1.403 + } else {
1.404 + procPtr->numArgs = numArgs;
1.405 + procPtr->numCompiledLocals = numArgs;
1.406 + }
1.407 + for (i = 0; i < numArgs; i++) {
1.408 + int fieldCount, nameLength, valueLength;
1.409 + CONST char **fieldValues;
1.410 +
1.411 + /*
1.412 + * Now divide the specifier up into name and default.
1.413 + */
1.414 +
1.415 + result = Tcl_SplitList(interp, argArray[i], &fieldCount,
1.416 + &fieldValues);
1.417 + if (result != TCL_OK) {
1.418 + goto procError;
1.419 + }
1.420 + if (fieldCount > 2) {
1.421 + ckfree((char *) fieldValues);
1.422 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.423 + "too many fields in argument specifier \"",
1.424 + argArray[i], "\"", (char *) NULL);
1.425 + goto procError;
1.426 + }
1.427 + if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
1.428 + ckfree((char *) fieldValues);
1.429 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.430 + "procedure \"", procName,
1.431 + "\" has argument with no name", (char *) NULL);
1.432 + goto procError;
1.433 + }
1.434 +
1.435 + nameLength = strlen(fieldValues[0]);
1.436 + if (fieldCount == 2) {
1.437 + valueLength = strlen(fieldValues[1]);
1.438 + } else {
1.439 + valueLength = 0;
1.440 + }
1.441 +
1.442 + /*
1.443 + * Check that the formal parameter name is a scalar.
1.444 + */
1.445 +
1.446 + p = fieldValues[0];
1.447 + while (*p != '\0') {
1.448 + if (*p == '(') {
1.449 + CONST char *q = p;
1.450 + do {
1.451 + q++;
1.452 + } while (*q != '\0');
1.453 + q--;
1.454 + if (*q == ')') { /* we have an array element */
1.455 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.456 + "procedure \"", procName,
1.457 + "\" has formal parameter \"", fieldValues[0],
1.458 + "\" that is an array element",
1.459 + (char *) NULL);
1.460 + ckfree((char *) fieldValues);
1.461 + goto procError;
1.462 + }
1.463 + } else if ((*p == ':') && (*(p+1) == ':')) {
1.464 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.465 + "procedure \"", procName,
1.466 + "\" has formal parameter \"", fieldValues[0],
1.467 + "\" that is not a simple name",
1.468 + (char *) NULL);
1.469 + ckfree((char *) fieldValues);
1.470 + goto procError;
1.471 + }
1.472 + p++;
1.473 + }
1.474 +
1.475 + if (precompiled) {
1.476 + /*
1.477 + * Compare the parsed argument with the stored one.
1.478 + * For the flags, we and out VAR_UNDEFINED to support bridging
1.479 + * precompiled <= 8.3 code in 8.4 where this is now used as an
1.480 + * optimization indicator. Yes, this is a hack. -- hobbs
1.481 + */
1.482 +
1.483 + if ((localPtr->nameLength != nameLength)
1.484 + || (strcmp(localPtr->name, fieldValues[0]))
1.485 + || (localPtr->frameIndex != i)
1.486 + || ((localPtr->flags & ~VAR_UNDEFINED)
1.487 + != (VAR_SCALAR | VAR_ARGUMENT))
1.488 + || ((localPtr->defValuePtr == NULL)
1.489 + && (fieldCount == 2))
1.490 + || ((localPtr->defValuePtr != NULL)
1.491 + && (fieldCount != 2))) {
1.492 + char buf[80 + TCL_INTEGER_SPACE];
1.493 + sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body",
1.494 + i);
1.495 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.496 + "procedure \"", procName,
1.497 + buf, (char *) NULL);
1.498 + ckfree((char *) fieldValues);
1.499 + goto procError;
1.500 + }
1.501 +
1.502 + /*
1.503 + * compare the default value if any
1.504 + */
1.505 +
1.506 + if (localPtr->defValuePtr != NULL) {
1.507 + int tmpLength;
1.508 + char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
1.509 + &tmpLength);
1.510 + if ((valueLength != tmpLength)
1.511 + || (strncmp(fieldValues[1], tmpPtr,
1.512 + (size_t) tmpLength))) {
1.513 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.514 + "procedure \"", procName,
1.515 + "\": formal parameter \"",
1.516 + fieldValues[0],
1.517 + "\" has default value inconsistent with precompiled body",
1.518 + (char *) NULL);
1.519 + ckfree((char *) fieldValues);
1.520 + goto procError;
1.521 + }
1.522 + }
1.523 +
1.524 + localPtr = localPtr->nextPtr;
1.525 + } else {
1.526 + /*
1.527 + * Allocate an entry in the runtime procedure frame's array of
1.528 + * local variables for the argument.
1.529 + */
1.530 +
1.531 + localPtr = (CompiledLocal *) ckalloc((unsigned)
1.532 + (sizeof(CompiledLocal) - sizeof(localPtr->name)
1.533 + + nameLength+1));
1.534 + if (procPtr->firstLocalPtr == NULL) {
1.535 + procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
1.536 + } else {
1.537 + procPtr->lastLocalPtr->nextPtr = localPtr;
1.538 + procPtr->lastLocalPtr = localPtr;
1.539 + }
1.540 + localPtr->nextPtr = NULL;
1.541 + localPtr->nameLength = nameLength;
1.542 + localPtr->frameIndex = i;
1.543 + localPtr->flags = VAR_SCALAR | VAR_ARGUMENT;
1.544 + localPtr->resolveInfo = NULL;
1.545 +
1.546 + if (fieldCount == 2) {
1.547 + localPtr->defValuePtr =
1.548 + Tcl_NewStringObj(fieldValues[1], valueLength);
1.549 + Tcl_IncrRefCount(localPtr->defValuePtr);
1.550 + } else {
1.551 + localPtr->defValuePtr = NULL;
1.552 + }
1.553 + strcpy(localPtr->name, fieldValues[0]);
1.554 + }
1.555 +
1.556 + ckfree((char *) fieldValues);
1.557 + }
1.558 +
1.559 + /*
1.560 + * Now initialize the new procedure's cmdPtr field. This will be used
1.561 + * later when the procedure is called to determine what namespace the
1.562 + * procedure will run in. This will be different than the current
1.563 + * namespace if the proc was renamed into a different namespace.
1.564 + */
1.565 +
1.566 + *procPtrPtr = procPtr;
1.567 + ckfree((char *) argArray);
1.568 + return TCL_OK;
1.569 +
1.570 +procError:
1.571 + if (precompiled) {
1.572 + procPtr->refCount--;
1.573 + } else {
1.574 + Tcl_DecrRefCount(bodyPtr);
1.575 + while (procPtr->firstLocalPtr != NULL) {
1.576 + localPtr = procPtr->firstLocalPtr;
1.577 + procPtr->firstLocalPtr = localPtr->nextPtr;
1.578 +
1.579 + defPtr = localPtr->defValuePtr;
1.580 + if (defPtr != NULL) {
1.581 + Tcl_DecrRefCount(defPtr);
1.582 + }
1.583 +
1.584 + ckfree((char *) localPtr);
1.585 + }
1.586 + ckfree((char *) procPtr);
1.587 + }
1.588 + if (argArray != NULL) {
1.589 + ckfree((char *) argArray);
1.590 + }
1.591 + return TCL_ERROR;
1.592 +}
1.593 +
1.594 +/*
1.595 + *----------------------------------------------------------------------
1.596 + *
1.597 + * TclGetFrame --
1.598 + *
1.599 + * Given a description of a procedure frame, such as the first
1.600 + * argument to an "uplevel" or "upvar" command, locate the
1.601 + * call frame for the appropriate level of procedure.
1.602 + *
1.603 + * Results:
1.604 + * The return value is -1 if an error occurred in finding the frame
1.605 + * (in this case an error message is left in the interp's result).
1.606 + * 1 is returned if string was either a number or a number preceded
1.607 + * by "#" and it specified a valid frame. 0 is returned if string
1.608 + * isn't one of the two things above (in this case, the lookup
1.609 + * acts as if string were "1"). The variable pointed to by
1.610 + * framePtrPtr is filled in with the address of the desired frame
1.611 + * (unless an error occurs, in which case it isn't modified).
1.612 + *
1.613 + * Side effects:
1.614 + * None.
1.615 + *
1.616 + *----------------------------------------------------------------------
1.617 + */
1.618 +
1.619 +int
1.620 +TclGetFrame(interp, string, framePtrPtr)
1.621 + Tcl_Interp *interp; /* Interpreter in which to find frame. */
1.622 + CONST char *string; /* String describing frame. */
1.623 + CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL
1.624 + * if global frame indicated). */
1.625 +{
1.626 + register Interp *iPtr = (Interp *) interp;
1.627 + int curLevel, level, result;
1.628 + CallFrame *framePtr;
1.629 +
1.630 + /*
1.631 + * Parse string to figure out which level number to go to.
1.632 + */
1.633 +
1.634 + result = 1;
1.635 + curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
1.636 + if (*string == '#') {
1.637 + if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
1.638 + return -1;
1.639 + }
1.640 + if (level < 0) {
1.641 + levelError:
1.642 + Tcl_AppendResult(interp, "bad level \"", string, "\"",
1.643 + (char *) NULL);
1.644 + return -1;
1.645 + }
1.646 + } else if (isdigit(UCHAR(*string))) { /* INTL: digit */
1.647 + if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
1.648 + return -1;
1.649 + }
1.650 + level = curLevel - level;
1.651 + } else {
1.652 + level = curLevel - 1;
1.653 + result = 0;
1.654 + }
1.655 +
1.656 + /*
1.657 + * Figure out which frame to use, and modify the interpreter so
1.658 + * its variables come from that frame.
1.659 + */
1.660 +
1.661 + if (level == 0) {
1.662 + framePtr = NULL;
1.663 + } else {
1.664 + for (framePtr = iPtr->varFramePtr; framePtr != NULL;
1.665 + framePtr = framePtr->callerVarPtr) {
1.666 + if (framePtr->level == level) {
1.667 + break;
1.668 + }
1.669 + }
1.670 + if (framePtr == NULL) {
1.671 + goto levelError;
1.672 + }
1.673 + }
1.674 + *framePtrPtr = framePtr;
1.675 + return result;
1.676 +}
1.677 +
1.678 +/*
1.679 + *----------------------------------------------------------------------
1.680 + *
1.681 + * Tcl_UplevelObjCmd --
1.682 + *
1.683 + * This object procedure is invoked to process the "uplevel" Tcl
1.684 + * command. See the user documentation for details on what it does.
1.685 + *
1.686 + * Results:
1.687 + * A standard Tcl object result value.
1.688 + *
1.689 + * Side effects:
1.690 + * See the user documentation.
1.691 + *
1.692 + *----------------------------------------------------------------------
1.693 + */
1.694 +
1.695 + /* ARGSUSED */
1.696 +int
1.697 +Tcl_UplevelObjCmd(dummy, interp, objc, objv)
1.698 + ClientData dummy; /* Not used. */
1.699 + Tcl_Interp *interp; /* Current interpreter. */
1.700 + int objc; /* Number of arguments. */
1.701 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.702 +{
1.703 + register Interp *iPtr = (Interp *) interp;
1.704 + char *optLevel;
1.705 + int result;
1.706 + CallFrame *savedVarFramePtr, *framePtr;
1.707 +
1.708 + if (objc < 2) {
1.709 + uplevelSyntax:
1.710 + Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
1.711 + return TCL_ERROR;
1.712 + }
1.713 +
1.714 + /*
1.715 + * Find the level to use for executing the command.
1.716 + */
1.717 +
1.718 + optLevel = TclGetString(objv[1]);
1.719 + result = TclGetFrame(interp, optLevel, &framePtr);
1.720 + if (result == -1) {
1.721 + return TCL_ERROR;
1.722 + }
1.723 + objc -= (result+1);
1.724 + if (objc == 0) {
1.725 + goto uplevelSyntax;
1.726 + }
1.727 + objv += (result+1);
1.728 +
1.729 + /*
1.730 + * Modify the interpreter state to execute in the given frame.
1.731 + */
1.732 +
1.733 + savedVarFramePtr = iPtr->varFramePtr;
1.734 + iPtr->varFramePtr = framePtr;
1.735 +
1.736 + /*
1.737 + * Execute the residual arguments as a command.
1.738 + */
1.739 +
1.740 + if (objc == 1) {
1.741 + result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
1.742 + } else {
1.743 + /*
1.744 + * More than one argument: concatenate them together with spaces
1.745 + * between, then evaluate the result. Tcl_EvalObjEx will delete
1.746 + * the object when it decrements its refcount after eval'ing it.
1.747 + */
1.748 + Tcl_Obj *objPtr;
1.749 +
1.750 + objPtr = Tcl_ConcatObj(objc, objv);
1.751 + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
1.752 + }
1.753 + if (result == TCL_ERROR) {
1.754 + char msg[32 + TCL_INTEGER_SPACE];
1.755 + sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine);
1.756 + Tcl_AddObjErrorInfo(interp, msg, -1);
1.757 + }
1.758 +
1.759 + /*
1.760 + * Restore the variable frame, and return.
1.761 + */
1.762 +
1.763 + iPtr->varFramePtr = savedVarFramePtr;
1.764 + return result;
1.765 +}
1.766 +
1.767 +/*
1.768 + *----------------------------------------------------------------------
1.769 + *
1.770 + * TclFindProc --
1.771 + *
1.772 + * Given the name of a procedure, return a pointer to the
1.773 + * record describing the procedure. The procedure will be
1.774 + * looked up using the usual rules: first in the current
1.775 + * namespace and then in the global namespace.
1.776 + *
1.777 + * Results:
1.778 + * NULL is returned if the name doesn't correspond to any
1.779 + * procedure. Otherwise, the return value is a pointer to
1.780 + * the procedure's record. If the name is found but refers
1.781 + * to an imported command that points to a "real" procedure
1.782 + * defined in another namespace, a pointer to that "real"
1.783 + * procedure's structure is returned.
1.784 + *
1.785 + * Side effects:
1.786 + * None.
1.787 + *
1.788 + *----------------------------------------------------------------------
1.789 + */
1.790 +
1.791 +Proc *
1.792 +TclFindProc(iPtr, procName)
1.793 + Interp *iPtr; /* Interpreter in which to look. */
1.794 + CONST char *procName; /* Name of desired procedure. */
1.795 +{
1.796 + Tcl_Command cmd;
1.797 + Tcl_Command origCmd;
1.798 + Command *cmdPtr;
1.799 +
1.800 + cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName,
1.801 + (Tcl_Namespace *) NULL, /*flags*/ 0);
1.802 + if (cmd == (Tcl_Command) NULL) {
1.803 + return NULL;
1.804 + }
1.805 + cmdPtr = (Command *) cmd;
1.806 +
1.807 + origCmd = TclGetOriginalCommand(cmd);
1.808 + if (origCmd != NULL) {
1.809 + cmdPtr = (Command *) origCmd;
1.810 + }
1.811 + if (cmdPtr->proc != TclProcInterpProc) {
1.812 + return NULL;
1.813 + }
1.814 + return (Proc *) cmdPtr->clientData;
1.815 +}
1.816 +
1.817 +/*
1.818 + *----------------------------------------------------------------------
1.819 + *
1.820 + * TclIsProc --
1.821 + *
1.822 + * Tells whether a command is a Tcl procedure or not.
1.823 + *
1.824 + * Results:
1.825 + * If the given command is actually a Tcl procedure, the
1.826 + * return value is the address of the record describing
1.827 + * the procedure. Otherwise the return value is 0.
1.828 + *
1.829 + * Side effects:
1.830 + * None.
1.831 + *
1.832 + *----------------------------------------------------------------------
1.833 + */
1.834 +
1.835 +Proc *
1.836 +TclIsProc(cmdPtr)
1.837 + Command *cmdPtr; /* Command to test. */
1.838 +{
1.839 + Tcl_Command origCmd;
1.840 +
1.841 + origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
1.842 + if (origCmd != NULL) {
1.843 + cmdPtr = (Command *) origCmd;
1.844 + }
1.845 + if (cmdPtr->proc == TclProcInterpProc) {
1.846 + return (Proc *) cmdPtr->clientData;
1.847 + }
1.848 + return (Proc *) 0;
1.849 +}
1.850 +
1.851 +/*
1.852 + *----------------------------------------------------------------------
1.853 + *
1.854 + * TclProcInterpProc --
1.855 + *
1.856 + * When a Tcl procedure gets invoked with an argc/argv array of
1.857 + * strings, this routine gets invoked to interpret the procedure.
1.858 + *
1.859 + * Results:
1.860 + * A standard Tcl result value, usually TCL_OK.
1.861 + *
1.862 + * Side effects:
1.863 + * Depends on the commands in the procedure.
1.864 + *
1.865 + *----------------------------------------------------------------------
1.866 + */
1.867 +
1.868 +int
1.869 +TclProcInterpProc(clientData, interp, argc, argv)
1.870 + ClientData clientData; /* Record describing procedure to be
1.871 + * interpreted. */
1.872 + Tcl_Interp *interp; /* Interpreter in which procedure was
1.873 + * invoked. */
1.874 + int argc; /* Count of number of arguments to this
1.875 + * procedure. */
1.876 + register CONST char **argv; /* Argument values. */
1.877 +{
1.878 + register Tcl_Obj *objPtr;
1.879 + register int i;
1.880 + int result;
1.881 +
1.882 + /*
1.883 + * This procedure generates an objv array for object arguments that hold
1.884 + * the argv strings. It starts out with stack-allocated space but uses
1.885 + * dynamically-allocated storage if needed.
1.886 + */
1.887 +
1.888 +#define NUM_ARGS 20
1.889 + Tcl_Obj *(objStorage[NUM_ARGS]);
1.890 + register Tcl_Obj **objv = objStorage;
1.891 +
1.892 + /*
1.893 + * Create the object argument array "objv". Make sure objv is large
1.894 + * enough to hold the objc arguments plus 1 extra for the zero
1.895 + * end-of-objv word.
1.896 + */
1.897 +
1.898 + if ((argc + 1) > NUM_ARGS) {
1.899 + objv = (Tcl_Obj **)
1.900 + ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
1.901 + }
1.902 +
1.903 + for (i = 0; i < argc; i++) {
1.904 + objv[i] = Tcl_NewStringObj(argv[i], -1);
1.905 + Tcl_IncrRefCount(objv[i]);
1.906 + }
1.907 + objv[argc] = 0;
1.908 +
1.909 + /*
1.910 + * Use TclObjInterpProc to actually interpret the procedure.
1.911 + */
1.912 +
1.913 + result = TclObjInterpProc(clientData, interp, argc, objv);
1.914 +
1.915 + /*
1.916 + * Move the interpreter's object result to the string result,
1.917 + * then reset the object result.
1.918 + */
1.919 +
1.920 + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1.921 + TCL_VOLATILE);
1.922 +
1.923 + /*
1.924 + * Decrement the ref counts on the objv elements since we are done
1.925 + * with them.
1.926 + */
1.927 +
1.928 + for (i = 0; i < argc; i++) {
1.929 + objPtr = objv[i];
1.930 + TclDecrRefCount(objPtr);
1.931 + }
1.932 +
1.933 + /*
1.934 + * Free the objv array if malloc'ed storage was used.
1.935 + */
1.936 +
1.937 + if (objv != objStorage) {
1.938 + ckfree((char *) objv);
1.939 + }
1.940 + return result;
1.941 +#undef NUM_ARGS
1.942 +}
1.943 +
1.944 +/*
1.945 + *----------------------------------------------------------------------
1.946 + *
1.947 + * TclObjInterpProc --
1.948 + *
1.949 + * When a Tcl procedure gets invoked during bytecode evaluation, this
1.950 + * object-based routine gets invoked to interpret the procedure.
1.951 + *
1.952 + * Results:
1.953 + * A standard Tcl object result value.
1.954 + *
1.955 + * Side effects:
1.956 + * Depends on the commands in the procedure.
1.957 + *
1.958 + *----------------------------------------------------------------------
1.959 + */
1.960 +
1.961 +int
1.962 +TclObjInterpProc(clientData, interp, objc, objv)
1.963 + ClientData clientData; /* Record describing procedure to be
1.964 + * interpreted. */
1.965 + register Tcl_Interp *interp; /* Interpreter in which procedure was
1.966 + * invoked. */
1.967 + int objc; /* Count of number of arguments to this
1.968 + * procedure. */
1.969 + Tcl_Obj *CONST objv[]; /* Argument value objects. */
1.970 +{
1.971 + Interp *iPtr = (Interp *) interp;
1.972 + Proc *procPtr = (Proc *) clientData;
1.973 + Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
1.974 + CallFrame frame;
1.975 + register CallFrame *framePtr = &frame;
1.976 + register Var *varPtr;
1.977 + register CompiledLocal *localPtr;
1.978 + char *procName;
1.979 + int nameLen, localCt, numArgs, argCt, i, result;
1.980 +
1.981 + /*
1.982 + * This procedure generates an array "compiledLocals" that holds the
1.983 + * storage for local variables. It starts out with stack-allocated space
1.984 + * but uses dynamically-allocated storage if needed.
1.985 + */
1.986 +
1.987 +#define NUM_LOCALS 20
1.988 + Var localStorage[NUM_LOCALS];
1.989 + Var *compiledLocals = localStorage;
1.990 +
1.991 + /*
1.992 + * Get the procedure's name.
1.993 + */
1.994 +
1.995 + procName = Tcl_GetStringFromObj(objv[0], &nameLen);
1.996 +
1.997 + /*
1.998 + * If necessary, compile the procedure's body. The compiler will
1.999 + * allocate frame slots for the procedure's non-argument local
1.1000 + * variables. Note that compiling the body might increase
1.1001 + * procPtr->numCompiledLocals if new local variables are found
1.1002 + * while compiling.
1.1003 + */
1.1004 +
1.1005 + result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
1.1006 + "body of proc", procName, &procPtr);
1.1007 +
1.1008 + if (result != TCL_OK) {
1.1009 + return result;
1.1010 + }
1.1011 +
1.1012 + /*
1.1013 + * Create the "compiledLocals" array. Make sure it is large enough to
1.1014 + * hold all the procedure's compiled local variables, including its
1.1015 + * formal parameters.
1.1016 + */
1.1017 +
1.1018 + localCt = procPtr->numCompiledLocals;
1.1019 + if (localCt > NUM_LOCALS) {
1.1020 + compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var));
1.1021 + }
1.1022 +
1.1023 + /*
1.1024 + * Set up and push a new call frame for the new procedure invocation.
1.1025 + * This call frame will execute in the proc's namespace, which might
1.1026 + * be different than the current namespace. The proc's namespace is
1.1027 + * that of its command, which can change if the command is renamed
1.1028 + * from one namespace to another.
1.1029 + */
1.1030 +
1.1031 + result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
1.1032 + (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1);
1.1033 +
1.1034 + if (result != TCL_OK) {
1.1035 + return result;
1.1036 + }
1.1037 +
1.1038 + framePtr->objc = objc;
1.1039 + framePtr->objv = objv; /* ref counts for args are incremented below */
1.1040 +
1.1041 + /*
1.1042 + * Initialize and resolve compiled variable references.
1.1043 + */
1.1044 +
1.1045 + framePtr->procPtr = procPtr;
1.1046 + framePtr->numCompiledLocals = localCt;
1.1047 + framePtr->compiledLocals = compiledLocals;
1.1048 +
1.1049 + TclInitCompiledLocals(interp, framePtr, nsPtr);
1.1050 +
1.1051 + /*
1.1052 + * Match and assign the call's actual parameters to the procedure's
1.1053 + * formal arguments. The formal arguments are described by the first
1.1054 + * numArgs entries in both the Proc structure's local variable list and
1.1055 + * the call frame's local variable array.
1.1056 + */
1.1057 +
1.1058 + numArgs = procPtr->numArgs;
1.1059 + varPtr = framePtr->compiledLocals;
1.1060 + localPtr = procPtr->firstLocalPtr;
1.1061 + argCt = objc;
1.1062 + for (i = 1, argCt -= 1; i <= numArgs; i++, argCt--) {
1.1063 + if (!TclIsVarArgument(localPtr)) {
1.1064 + panic("TclObjInterpProc: local variable %s is not argument but should be",
1.1065 + localPtr->name);
1.1066 + return TCL_ERROR;
1.1067 + }
1.1068 + if (TclIsVarTemporary(localPtr)) {
1.1069 + panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i);
1.1070 + return TCL_ERROR;
1.1071 + }
1.1072 +
1.1073 + /*
1.1074 + * Handle the special case of the last formal being "args". When
1.1075 + * it occurs, assign it a list consisting of all the remaining
1.1076 + * actual arguments.
1.1077 + */
1.1078 +
1.1079 + if ((i == numArgs) && ((localPtr->name[0] == 'a')
1.1080 + && (strcmp(localPtr->name, "args") == 0))) {
1.1081 + Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
1.1082 + varPtr->value.objPtr = listPtr;
1.1083 + Tcl_IncrRefCount(listPtr); /* local var is a reference */
1.1084 + TclClearVarUndefined(varPtr);
1.1085 + argCt = 0;
1.1086 + break; /* done processing args */
1.1087 + } else if (argCt > 0) {
1.1088 + Tcl_Obj *objPtr = objv[i];
1.1089 + varPtr->value.objPtr = objPtr;
1.1090 + TclClearVarUndefined(varPtr);
1.1091 + Tcl_IncrRefCount(objPtr); /* since the local variable now has
1.1092 + * another reference to object. */
1.1093 + } else if (localPtr->defValuePtr != NULL) {
1.1094 + Tcl_Obj *objPtr = localPtr->defValuePtr;
1.1095 + varPtr->value.objPtr = objPtr;
1.1096 + TclClearVarUndefined(varPtr);
1.1097 + Tcl_IncrRefCount(objPtr); /* since the local variable now has
1.1098 + * another reference to object. */
1.1099 + } else {
1.1100 + goto incorrectArgs;
1.1101 + }
1.1102 + varPtr++;
1.1103 + localPtr = localPtr->nextPtr;
1.1104 + }
1.1105 + if (argCt > 0) {
1.1106 + Tcl_Obj *objResult;
1.1107 + int len, flags;
1.1108 +
1.1109 + incorrectArgs:
1.1110 + /*
1.1111 + * Build up equivalent to Tcl_WrongNumArgs message for proc
1.1112 + */
1.1113 +
1.1114 + Tcl_ResetResult(interp);
1.1115 + objResult = Tcl_GetObjResult(interp);
1.1116 + Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1);
1.1117 +
1.1118 + /*
1.1119 + * Quote the proc name if it contains spaces (Bug 942757).
1.1120 + */
1.1121 +
1.1122 + len = Tcl_ScanCountedElement(procName, nameLen, &flags);
1.1123 + if (len != nameLen) {
1.1124 + char *procName1 = ckalloc((unsigned) len);
1.1125 + len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags);
1.1126 + Tcl_AppendToObj(objResult, procName1, len);
1.1127 + ckfree(procName1);
1.1128 + } else {
1.1129 + Tcl_AppendToObj(objResult, procName, len);
1.1130 + }
1.1131 +
1.1132 + localPtr = procPtr->firstLocalPtr;
1.1133 + for (i = 1; i <= numArgs; i++) {
1.1134 + if (localPtr->defValuePtr != NULL) {
1.1135 + Tcl_AppendStringsToObj(objResult,
1.1136 + " ?", localPtr->name, "?", (char *) NULL);
1.1137 + } else {
1.1138 + Tcl_AppendStringsToObj(objResult,
1.1139 + " ", localPtr->name, (char *) NULL);
1.1140 + }
1.1141 + localPtr = localPtr->nextPtr;
1.1142 + }
1.1143 + Tcl_AppendStringsToObj(objResult, "\"", (char *) NULL);
1.1144 +
1.1145 + result = TCL_ERROR;
1.1146 + goto procDone;
1.1147 + }
1.1148 +
1.1149 + /*
1.1150 + * Invoke the commands in the procedure's body.
1.1151 + */
1.1152 +
1.1153 +#ifdef TCL_COMPILE_DEBUG
1.1154 + if (tclTraceExec >= 1) {
1.1155 + fprintf(stdout, "Calling proc ");
1.1156 + for (i = 0; i < objc; i++) {
1.1157 + TclPrintObject(stdout, objv[i], 15);
1.1158 + fprintf(stdout, " ");
1.1159 + }
1.1160 + fprintf(stdout, "\n");
1.1161 + fflush(stdout);
1.1162 + }
1.1163 +#endif /*TCL_COMPILE_DEBUG*/
1.1164 +
1.1165 + iPtr->returnCode = TCL_OK;
1.1166 + procPtr->refCount++;
1.1167 +#ifndef TCL_TIP280
1.1168 + result = TclCompEvalObj(interp, procPtr->bodyPtr);
1.1169 +#else
1.1170 + /* TIP #280: No need to set the invoking context here. The body has
1.1171 + * already been compiled, so the part of CompEvalObj using it is bypassed.
1.1172 + */
1.1173 +
1.1174 + result = TclCompEvalObj(interp, procPtr->bodyPtr, NULL, 0);
1.1175 +#endif
1.1176 + procPtr->refCount--;
1.1177 + if (procPtr->refCount <= 0) {
1.1178 + TclProcCleanupProc(procPtr);
1.1179 + }
1.1180 +
1.1181 + if (result != TCL_OK) {
1.1182 + result = ProcessProcResultCode(interp, procName, nameLen, result);
1.1183 + }
1.1184 +
1.1185 + /*
1.1186 + * Pop and free the call frame for this procedure invocation, then
1.1187 + * free the compiledLocals array if malloc'ed storage was used.
1.1188 + */
1.1189 +
1.1190 + procDone:
1.1191 + Tcl_PopCallFrame(interp);
1.1192 + if (compiledLocals != localStorage) {
1.1193 + ckfree((char *) compiledLocals);
1.1194 + }
1.1195 + return result;
1.1196 +#undef NUM_LOCALS
1.1197 +}
1.1198 +
1.1199 +/*
1.1200 + *----------------------------------------------------------------------
1.1201 + *
1.1202 + * TclProcCompileProc --
1.1203 + *
1.1204 + * Called just before a procedure is executed to compile the
1.1205 + * body to byte codes. If the type of the body is not
1.1206 + * "byte code" or if the compile conditions have changed
1.1207 + * (namespace context, epoch counters, etc.) then the body
1.1208 + * is recompiled. Otherwise, this procedure does nothing.
1.1209 + *
1.1210 + * Results:
1.1211 + * None.
1.1212 + *
1.1213 + * Side effects:
1.1214 + * May change the internal representation of the body object
1.1215 + * to compiled code.
1.1216 + *
1.1217 + *----------------------------------------------------------------------
1.1218 + */
1.1219 +
1.1220 +int
1.1221 +TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
1.1222 + Tcl_Interp *interp; /* Interpreter containing procedure. */
1.1223 + Proc *procPtr; /* Data associated with procedure. */
1.1224 + Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr,
1.1225 + * but could be any code fragment compiled
1.1226 + * in the context of this procedure.) */
1.1227 + Namespace *nsPtr; /* Namespace containing procedure. */
1.1228 + CONST char *description; /* string describing this body of code. */
1.1229 + CONST char *procName; /* Name of this procedure. */
1.1230 +{
1.1231 + return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr,
1.1232 + description, procName, NULL);
1.1233 +}
1.1234 +
1.1235 +static int
1.1236 +ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
1.1237 + procName, procPtrPtr)
1.1238 + Tcl_Interp *interp; /* Interpreter containing procedure. */
1.1239 + Proc *procPtr; /* Data associated with procedure. */
1.1240 + Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr,
1.1241 + * but could be any code fragment compiled
1.1242 + * in the context of this procedure.) */
1.1243 + Namespace *nsPtr; /* Namespace containing procedure. */
1.1244 + CONST char *description; /* string describing this body of code. */
1.1245 + CONST char *procName; /* Name of this procedure. */
1.1246 + Proc **procPtrPtr; /* points to storage where a replacement
1.1247 + * (Proc *) value may be written, when
1.1248 + * appropriate */
1.1249 +{
1.1250 + Interp *iPtr = (Interp*)interp;
1.1251 + int i, result;
1.1252 + Tcl_CallFrame frame;
1.1253 + Proc *saveProcPtr;
1.1254 + ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
1.1255 + CompiledLocal *localPtr;
1.1256 +
1.1257 + /*
1.1258 + * If necessary, compile the procedure's body. The compiler will
1.1259 + * allocate frame slots for the procedure's non-argument local
1.1260 + * variables. If the ByteCode already exists, make sure it hasn't been
1.1261 + * invalidated by someone redefining a core command (this might make the
1.1262 + * compiled code wrong). Also, if the code was compiled in/for a
1.1263 + * different interpreter, we recompile it. Note that compiling the body
1.1264 + * might increase procPtr->numCompiledLocals if new local variables are
1.1265 + * found while compiling.
1.1266 + *
1.1267 + * Precompiled procedure bodies, however, are immutable and therefore
1.1268 + * they are not recompiled, even if things have changed.
1.1269 + */
1.1270 +
1.1271 + if (bodyPtr->typePtr == &tclByteCodeType) {
1.1272 + if (((Interp *) *codePtr->interpHandle != iPtr)
1.1273 + || (codePtr->compileEpoch != iPtr->compileEpoch)
1.1274 + || (codePtr->nsPtr != nsPtr)) {
1.1275 + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
1.1276 + if ((Interp *) *codePtr->interpHandle != iPtr) {
1.1277 + Tcl_AppendResult(interp,
1.1278 + "a precompiled script jumped interps", NULL);
1.1279 + return TCL_ERROR;
1.1280 + }
1.1281 + codePtr->compileEpoch = iPtr->compileEpoch;
1.1282 + codePtr->nsPtr = nsPtr;
1.1283 + } else {
1.1284 + (*tclByteCodeType.freeIntRepProc)(bodyPtr);
1.1285 + bodyPtr->typePtr = (Tcl_ObjType *) NULL;
1.1286 + }
1.1287 + }
1.1288 + }
1.1289 + if (bodyPtr->typePtr != &tclByteCodeType) {
1.1290 + int numChars;
1.1291 + char *ellipsis;
1.1292 +
1.1293 +#ifdef TCL_COMPILE_DEBUG
1.1294 + if (tclTraceCompile >= 1) {
1.1295 + /*
1.1296 + * Display a line summarizing the top level command we
1.1297 + * are about to compile.
1.1298 + */
1.1299 +
1.1300 + numChars = strlen(procName);
1.1301 + ellipsis = "";
1.1302 + if (numChars > 50) {
1.1303 + numChars = 50;
1.1304 + ellipsis = "...";
1.1305 + }
1.1306 + fprintf(stdout, "Compiling %s \"%.*s%s\"\n",
1.1307 + description, numChars, procName, ellipsis);
1.1308 + }
1.1309 +#endif
1.1310 +
1.1311 + /*
1.1312 + * Plug the current procPtr into the interpreter and coerce
1.1313 + * the code body to byte codes. The interpreter needs to
1.1314 + * know which proc it's compiling so that it can access its
1.1315 + * list of compiled locals.
1.1316 + *
1.1317 + * TRICKY NOTE: Be careful to push a call frame with the
1.1318 + * proper namespace context, so that the byte codes are
1.1319 + * compiled in the appropriate class context.
1.1320 + */
1.1321 +
1.1322 + saveProcPtr = iPtr->compiledProcPtr;
1.1323 +
1.1324 + if (procPtrPtr != NULL && procPtr->refCount > 1) {
1.1325 + Tcl_Command token;
1.1326 + Tcl_CmdInfo info;
1.1327 + Proc *new = (Proc *) ckalloc(sizeof(Proc));
1.1328 +
1.1329 + new->iPtr = procPtr->iPtr;
1.1330 + new->refCount = 1;
1.1331 + new->cmdPtr = procPtr->cmdPtr;
1.1332 + token = (Tcl_Command) new->cmdPtr;
1.1333 + new->bodyPtr = Tcl_DuplicateObj(bodyPtr);
1.1334 + bodyPtr = new->bodyPtr;
1.1335 + Tcl_IncrRefCount(bodyPtr);
1.1336 + new->numArgs = procPtr->numArgs;
1.1337 +
1.1338 + new->numCompiledLocals = new->numArgs;
1.1339 + new->firstLocalPtr = NULL;
1.1340 + new->lastLocalPtr = NULL;
1.1341 + localPtr = procPtr->firstLocalPtr;
1.1342 + for (i = 0; i < new->numArgs; i++, localPtr = localPtr->nextPtr) {
1.1343 + CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned)
1.1344 + (sizeof(CompiledLocal) -sizeof(localPtr->name)
1.1345 + + localPtr->nameLength + 1));
1.1346 + if (new->firstLocalPtr == NULL) {
1.1347 + new->firstLocalPtr = new->lastLocalPtr = copy;
1.1348 + } else {
1.1349 + new->lastLocalPtr->nextPtr = copy;
1.1350 + new->lastLocalPtr = copy;
1.1351 + }
1.1352 + copy->nextPtr = NULL;
1.1353 + copy->nameLength = localPtr->nameLength;
1.1354 + copy->frameIndex = localPtr->frameIndex;
1.1355 + copy->flags = localPtr->flags;
1.1356 + copy->defValuePtr = localPtr->defValuePtr;
1.1357 + if (copy->defValuePtr) {
1.1358 + Tcl_IncrRefCount(copy->defValuePtr);
1.1359 + }
1.1360 + copy->resolveInfo = localPtr->resolveInfo;
1.1361 + strcpy(copy->name, localPtr->name);
1.1362 + }
1.1363 +
1.1364 +
1.1365 + /* Reset the ClientData */
1.1366 + Tcl_GetCommandInfoFromToken(token, &info);
1.1367 + if (info.objClientData == (ClientData) procPtr) {
1.1368 + info.objClientData = (ClientData) new;
1.1369 + }
1.1370 + if (info.clientData == (ClientData) procPtr) {
1.1371 + info.clientData = (ClientData) new;
1.1372 + }
1.1373 + if (info.deleteData == (ClientData) procPtr) {
1.1374 + info.deleteData = (ClientData) new;
1.1375 + }
1.1376 + Tcl_SetCommandInfoFromToken(token, &info);
1.1377 +
1.1378 + procPtr->refCount--;
1.1379 + *procPtrPtr = procPtr = new;
1.1380 + }
1.1381 + iPtr->compiledProcPtr = procPtr;
1.1382 +
1.1383 + result = Tcl_PushCallFrame(interp, &frame,
1.1384 + (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0);
1.1385 +
1.1386 + if (result == TCL_OK) {
1.1387 +#ifdef TCL_TIP280
1.1388 + /* TIP #280. We get the invoking context from the cmdFrame
1.1389 + * which was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
1.1390 + */
1.1391 +
1.1392 + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
1.1393 +
1.1394 + /* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
1.1395 + */
1.1396 + iPtr->invokeWord = 0;
1.1397 + iPtr->invokeCmdFramePtr = (hePtr
1.1398 + ? (CmdFrame*) Tcl_GetHashValue (hePtr)
1.1399 + : NULL);
1.1400 +#endif
1.1401 + result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
1.1402 +#ifdef TCL_TIP280
1.1403 + iPtr->invokeCmdFramePtr = NULL;
1.1404 +#endif
1.1405 + Tcl_PopCallFrame(interp);
1.1406 + }
1.1407 +
1.1408 + iPtr->compiledProcPtr = saveProcPtr;
1.1409 +
1.1410 + if (result != TCL_OK) {
1.1411 + if (result == TCL_ERROR) {
1.1412 + char buf[100 + TCL_INTEGER_SPACE];
1.1413 +
1.1414 + numChars = strlen(procName);
1.1415 + ellipsis = "";
1.1416 + if (numChars > 50) {
1.1417 + numChars = 50;
1.1418 + ellipsis = "...";
1.1419 + }
1.1420 + while ( (procName[numChars] & 0xC0) == 0x80 ) {
1.1421 + /*
1.1422 + * Back up truncation point so that we don't truncate
1.1423 + * in the middle of a multi-byte character (in UTF-8)
1.1424 + */
1.1425 + numChars--;
1.1426 + ellipsis = "...";
1.1427 + }
1.1428 + sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)",
1.1429 + description, numChars, procName, ellipsis,
1.1430 + interp->errorLine);
1.1431 + Tcl_AddObjErrorInfo(interp, buf, -1);
1.1432 + }
1.1433 + return result;
1.1434 + }
1.1435 + } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
1.1436 +
1.1437 + /*
1.1438 + * The resolver epoch has changed, but we only need to invalidate
1.1439 + * the resolver cache.
1.1440 + */
1.1441 +
1.1442 + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
1.1443 + localPtr = localPtr->nextPtr) {
1.1444 + localPtr->flags &= ~(VAR_RESOLVED);
1.1445 + if (localPtr->resolveInfo) {
1.1446 + if (localPtr->resolveInfo->deleteProc) {
1.1447 + localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
1.1448 + } else {
1.1449 + ckfree((char*)localPtr->resolveInfo);
1.1450 + }
1.1451 + localPtr->resolveInfo = NULL;
1.1452 + }
1.1453 + }
1.1454 + }
1.1455 + return TCL_OK;
1.1456 +}
1.1457 +
1.1458 +/*
1.1459 + *----------------------------------------------------------------------
1.1460 + *
1.1461 + * ProcessProcResultCode --
1.1462 + *
1.1463 + * Procedure called by TclObjInterpProc to process a return code other
1.1464 + * than TCL_OK returned by a Tcl procedure.
1.1465 + *
1.1466 + * Results:
1.1467 + * Depending on the argument return code, the result returned is
1.1468 + * another return code and the interpreter's result is set to a value
1.1469 + * to supplement that return code.
1.1470 + *
1.1471 + * Side effects:
1.1472 + * If the result returned is TCL_ERROR, traceback information about
1.1473 + * the procedure just executed is appended to the interpreter's
1.1474 + * "errorInfo" variable.
1.1475 + *
1.1476 + *----------------------------------------------------------------------
1.1477 + */
1.1478 +
1.1479 +static int
1.1480 +ProcessProcResultCode(interp, procName, nameLen, returnCode)
1.1481 + Tcl_Interp *interp; /* The interpreter in which the procedure
1.1482 + * was called and returned returnCode. */
1.1483 + char *procName; /* Name of the procedure. Used for error
1.1484 + * messages and trace information. */
1.1485 + int nameLen; /* Number of bytes in procedure's name. */
1.1486 + int returnCode; /* The unexpected result code. */
1.1487 +{
1.1488 + Interp *iPtr = (Interp *) interp;
1.1489 + char msg[100 + TCL_INTEGER_SPACE];
1.1490 + char *ellipsis = "";
1.1491 +
1.1492 + if (returnCode == TCL_OK) {
1.1493 + return TCL_OK;
1.1494 + }
1.1495 + if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
1.1496 + return returnCode;
1.1497 + }
1.1498 + if (returnCode == TCL_RETURN) {
1.1499 + return TclUpdateReturnInfo(iPtr);
1.1500 + }
1.1501 + if (returnCode != TCL_ERROR) {
1.1502 + Tcl_ResetResult(interp);
1.1503 + Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK)
1.1504 + ? "invoked \"break\" outside of a loop"
1.1505 + : "invoked \"continue\" outside of a loop"), -1);
1.1506 + }
1.1507 + if (nameLen > 60) {
1.1508 + nameLen = 60;
1.1509 + ellipsis = "...";
1.1510 + }
1.1511 + while ( (procName[nameLen] & 0xC0) == 0x80 ) {
1.1512 + /*
1.1513 + * Back up truncation point so that we don't truncate in the
1.1514 + * middle of a multi-byte character (in UTF-8)
1.1515 + */
1.1516 + nameLen--;
1.1517 + ellipsis = "...";
1.1518 + }
1.1519 + sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", nameLen, procName,
1.1520 + ellipsis, iPtr->errorLine);
1.1521 + Tcl_AddObjErrorInfo(interp, msg, -1);
1.1522 + return TCL_ERROR;
1.1523 +}
1.1524 +
1.1525 +/*
1.1526 + *----------------------------------------------------------------------
1.1527 + *
1.1528 + * TclProcDeleteProc --
1.1529 + *
1.1530 + * This procedure is invoked just before a command procedure is
1.1531 + * removed from an interpreter. Its job is to release all the
1.1532 + * resources allocated to the procedure.
1.1533 + *
1.1534 + * Results:
1.1535 + * None.
1.1536 + *
1.1537 + * Side effects:
1.1538 + * Memory gets freed, unless the procedure is actively being
1.1539 + * executed. In this case the cleanup is delayed until the
1.1540 + * last call to the current procedure completes.
1.1541 + *
1.1542 + *----------------------------------------------------------------------
1.1543 + */
1.1544 +
1.1545 +void
1.1546 +TclProcDeleteProc(clientData)
1.1547 + ClientData clientData; /* Procedure to be deleted. */
1.1548 +{
1.1549 + Proc *procPtr = (Proc *) clientData;
1.1550 +
1.1551 + procPtr->refCount--;
1.1552 + if (procPtr->refCount <= 0) {
1.1553 + TclProcCleanupProc(procPtr);
1.1554 + }
1.1555 +}
1.1556 +
1.1557 +/*
1.1558 + *----------------------------------------------------------------------
1.1559 + *
1.1560 + * TclProcCleanupProc --
1.1561 + *
1.1562 + * This procedure does all the real work of freeing up a Proc
1.1563 + * structure. It's called only when the structure's reference
1.1564 + * count becomes zero.
1.1565 + *
1.1566 + * Results:
1.1567 + * None.
1.1568 + *
1.1569 + * Side effects:
1.1570 + * Memory gets freed.
1.1571 + *
1.1572 + *----------------------------------------------------------------------
1.1573 + */
1.1574 +
1.1575 +void
1.1576 +TclProcCleanupProc(procPtr)
1.1577 + register Proc *procPtr; /* Procedure to be deleted. */
1.1578 +{
1.1579 + register CompiledLocal *localPtr;
1.1580 + Tcl_Obj *bodyPtr = procPtr->bodyPtr;
1.1581 + Tcl_Obj *defPtr;
1.1582 + Tcl_ResolvedVarInfo *resVarInfo;
1.1583 +#ifdef TCL_TIP280
1.1584 + Tcl_HashEntry* hePtr = NULL;
1.1585 + CmdFrame* cfPtr = NULL;
1.1586 + Interp* iPtr = procPtr->iPtr;
1.1587 +#endif
1.1588 +
1.1589 + if (bodyPtr != NULL) {
1.1590 + Tcl_DecrRefCount(bodyPtr);
1.1591 + }
1.1592 + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
1.1593 + CompiledLocal *nextPtr = localPtr->nextPtr;
1.1594 +
1.1595 + resVarInfo = localPtr->resolveInfo;
1.1596 + if (resVarInfo) {
1.1597 + if (resVarInfo->deleteProc) {
1.1598 + (*resVarInfo->deleteProc)(resVarInfo);
1.1599 + } else {
1.1600 + ckfree((char *) resVarInfo);
1.1601 + }
1.1602 + }
1.1603 +
1.1604 + if (localPtr->defValuePtr != NULL) {
1.1605 + defPtr = localPtr->defValuePtr;
1.1606 + Tcl_DecrRefCount(defPtr);
1.1607 + }
1.1608 + ckfree((char *) localPtr);
1.1609 + localPtr = nextPtr;
1.1610 + }
1.1611 + ckfree((char *) procPtr);
1.1612 +
1.1613 +#ifdef TCL_TIP280
1.1614 + /* TIP #280. Release the location data associated with this Proc
1.1615 + * structure, if any. The interpreter may not exist (For example for
1.1616 + * procbody structurues created by tbcload.
1.1617 + */
1.1618 +
1.1619 + if (!iPtr) return;
1.1620 +
1.1621 + hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
1.1622 + if (!hePtr) return;
1.1623 +
1.1624 + cfPtr = (CmdFrame*) Tcl_GetHashValue (hePtr);
1.1625 +
1.1626 + if (cfPtr->type == TCL_LOCATION_SOURCE) {
1.1627 + Tcl_DecrRefCount (cfPtr->data.eval.path);
1.1628 + cfPtr->data.eval.path = NULL;
1.1629 + }
1.1630 + ckfree ((char*) cfPtr->line); cfPtr->line = NULL;
1.1631 + ckfree ((char*) cfPtr);
1.1632 + Tcl_DeleteHashEntry (hePtr);
1.1633 +#endif
1.1634 +}
1.1635 +
1.1636 +/*
1.1637 + *----------------------------------------------------------------------
1.1638 + *
1.1639 + * TclUpdateReturnInfo --
1.1640 + *
1.1641 + * This procedure is called when procedures return, and at other
1.1642 + * points where the TCL_RETURN code is used. It examines fields
1.1643 + * such as iPtr->returnCode and iPtr->errorCode and modifies
1.1644 + * the real return status accordingly.
1.1645 + *
1.1646 + * Results:
1.1647 + * The return value is the true completion code to use for
1.1648 + * the procedure, instead of TCL_RETURN.
1.1649 + *
1.1650 + * Side effects:
1.1651 + * The errorInfo and errorCode variables may get modified.
1.1652 + *
1.1653 + *----------------------------------------------------------------------
1.1654 + */
1.1655 +
1.1656 +int
1.1657 +TclUpdateReturnInfo(iPtr)
1.1658 + Interp *iPtr; /* Interpreter for which TCL_RETURN
1.1659 + * exception is being processed. */
1.1660 +{
1.1661 + int code;
1.1662 + char *errorCode;
1.1663 + Tcl_Obj *objPtr;
1.1664 +
1.1665 + code = iPtr->returnCode;
1.1666 + iPtr->returnCode = TCL_OK;
1.1667 + if (code == TCL_ERROR) {
1.1668 + errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
1.1669 + objPtr = Tcl_NewStringObj(errorCode, -1);
1.1670 + Tcl_IncrRefCount(objPtr);
1.1671 + Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
1.1672 + NULL, objPtr, TCL_GLOBAL_ONLY);
1.1673 + Tcl_DecrRefCount(objPtr);
1.1674 + iPtr->flags |= ERROR_CODE_SET;
1.1675 + if (iPtr->errorInfo != NULL) {
1.1676 + objPtr = Tcl_NewStringObj(iPtr->errorInfo, -1);
1.1677 + Tcl_IncrRefCount(objPtr);
1.1678 + Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
1.1679 + NULL, objPtr, TCL_GLOBAL_ONLY);
1.1680 + Tcl_DecrRefCount(objPtr);
1.1681 + iPtr->flags |= ERR_IN_PROGRESS;
1.1682 + }
1.1683 + }
1.1684 + return code;
1.1685 +}
1.1686 +
1.1687 +/*
1.1688 + *----------------------------------------------------------------------
1.1689 + *
1.1690 + * TclGetInterpProc --
1.1691 + *
1.1692 + * Returns a pointer to the TclProcInterpProc procedure; this is different
1.1693 + * from the value obtained from the TclProcInterpProc reference on systems
1.1694 + * like Windows where import and export versions of a procedure exported
1.1695 + * by a DLL exist.
1.1696 + *
1.1697 + * Results:
1.1698 + * Returns the internal address of the TclProcInterpProc procedure.
1.1699 + *
1.1700 + * Side effects:
1.1701 + * None.
1.1702 + *
1.1703 + *----------------------------------------------------------------------
1.1704 + */
1.1705 +
1.1706 +TclCmdProcType
1.1707 +TclGetInterpProc()
1.1708 +{
1.1709 + return (TclCmdProcType) TclProcInterpProc;
1.1710 +}
1.1711 +
1.1712 +/*
1.1713 + *----------------------------------------------------------------------
1.1714 + *
1.1715 + * TclGetObjInterpProc --
1.1716 + *
1.1717 + * Returns a pointer to the TclObjInterpProc procedure; this is different
1.1718 + * from the value obtained from the TclObjInterpProc reference on systems
1.1719 + * like Windows where import and export versions of a procedure exported
1.1720 + * by a DLL exist.
1.1721 + *
1.1722 + * Results:
1.1723 + * Returns the internal address of the TclObjInterpProc procedure.
1.1724 + *
1.1725 + * Side effects:
1.1726 + * None.
1.1727 + *
1.1728 + *----------------------------------------------------------------------
1.1729 + */
1.1730 +
1.1731 +TclObjCmdProcType
1.1732 +TclGetObjInterpProc()
1.1733 +{
1.1734 + return (TclObjCmdProcType) TclObjInterpProc;
1.1735 +}
1.1736 +
1.1737 +/*
1.1738 + *----------------------------------------------------------------------
1.1739 + *
1.1740 + * TclNewProcBodyObj --
1.1741 + *
1.1742 + * Creates a new object, of type "procbody", whose internal
1.1743 + * representation is the given Proc struct.
1.1744 + * The newly created object's reference count is 0.
1.1745 + *
1.1746 + * Results:
1.1747 + * Returns a pointer to a newly allocated Tcl_Obj, 0 on error.
1.1748 + *
1.1749 + * Side effects:
1.1750 + * The reference count in the ByteCode attached to the Proc is bumped up
1.1751 + * by one, since the internal rep stores a pointer to it.
1.1752 + *
1.1753 + *----------------------------------------------------------------------
1.1754 + */
1.1755 +
1.1756 +Tcl_Obj *
1.1757 +TclNewProcBodyObj(procPtr)
1.1758 + Proc *procPtr; /* the Proc struct to store as the internal
1.1759 + * representation. */
1.1760 +{
1.1761 + Tcl_Obj *objPtr;
1.1762 +
1.1763 + if (!procPtr) {
1.1764 + return (Tcl_Obj *) NULL;
1.1765 + }
1.1766 +
1.1767 + objPtr = Tcl_NewStringObj("", 0);
1.1768 +
1.1769 + if (objPtr) {
1.1770 + objPtr->typePtr = &tclProcBodyType;
1.1771 + objPtr->internalRep.otherValuePtr = (VOID *) procPtr;
1.1772 +
1.1773 + procPtr->refCount++;
1.1774 + }
1.1775 +
1.1776 + return objPtr;
1.1777 +}
1.1778 +
1.1779 +/*
1.1780 + *----------------------------------------------------------------------
1.1781 + *
1.1782 + * ProcBodyDup --
1.1783 + *
1.1784 + * Tcl_ObjType's Dup function for the proc body object.
1.1785 + * Bumps the reference count on the Proc stored in the internal
1.1786 + * representation.
1.1787 + *
1.1788 + * Results:
1.1789 + * None.
1.1790 + *
1.1791 + * Side effects:
1.1792 + * Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
1.1793 + *
1.1794 + *----------------------------------------------------------------------
1.1795 + */
1.1796 +
1.1797 +static void ProcBodyDup(srcPtr, dupPtr)
1.1798 + Tcl_Obj *srcPtr; /* object to copy */
1.1799 + Tcl_Obj *dupPtr; /* target object for the duplication */
1.1800 +{
1.1801 + Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr;
1.1802 +
1.1803 + dupPtr->typePtr = &tclProcBodyType;
1.1804 + dupPtr->internalRep.otherValuePtr = (VOID *) procPtr;
1.1805 + procPtr->refCount++;
1.1806 +}
1.1807 +
1.1808 +/*
1.1809 + *----------------------------------------------------------------------
1.1810 + *
1.1811 + * ProcBodyFree --
1.1812 + *
1.1813 + * Tcl_ObjType's Free function for the proc body object.
1.1814 + * The reference count on its Proc struct is decreased by 1; if the count
1.1815 + * reaches 0, the proc is freed.
1.1816 + *
1.1817 + * Results:
1.1818 + * None.
1.1819 + *
1.1820 + * Side effects:
1.1821 + * If the reference count on the Proc struct reaches 0, the struct is freed.
1.1822 + *
1.1823 + *----------------------------------------------------------------------
1.1824 + */
1.1825 +
1.1826 +static void
1.1827 +ProcBodyFree(objPtr)
1.1828 + Tcl_Obj *objPtr; /* the object to clean up */
1.1829 +{
1.1830 + Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr;
1.1831 + procPtr->refCount--;
1.1832 + if (procPtr->refCount <= 0) {
1.1833 + TclProcCleanupProc(procPtr);
1.1834 + }
1.1835 +}
1.1836 +
1.1837 +/*
1.1838 + *----------------------------------------------------------------------
1.1839 + *
1.1840 + * ProcBodySetFromAny --
1.1841 + *
1.1842 + * Tcl_ObjType's SetFromAny function for the proc body object.
1.1843 + * Calls panic.
1.1844 + *
1.1845 + * Results:
1.1846 + * Theoretically returns a TCL result code.
1.1847 + *
1.1848 + * Side effects:
1.1849 + * Calls panic, since we can't set the value of the object from a string
1.1850 + * representation (or any other internal ones).
1.1851 + *
1.1852 + *----------------------------------------------------------------------
1.1853 + */
1.1854 +
1.1855 +static int
1.1856 +ProcBodySetFromAny(interp, objPtr)
1.1857 + Tcl_Interp *interp; /* current interpreter */
1.1858 + Tcl_Obj *objPtr; /* object pointer */
1.1859 +{
1.1860 + panic("called ProcBodySetFromAny");
1.1861 +
1.1862 + /*
1.1863 + * this to keep compilers happy.
1.1864 + */
1.1865 +
1.1866 + return TCL_OK;
1.1867 +}
1.1868 +
1.1869 +/*
1.1870 + *----------------------------------------------------------------------
1.1871 + *
1.1872 + * ProcBodyUpdateString --
1.1873 + *
1.1874 + * Tcl_ObjType's UpdateString function for the proc body object.
1.1875 + * Calls panic.
1.1876 + *
1.1877 + * Results:
1.1878 + * None.
1.1879 + *
1.1880 + * Side effects:
1.1881 + * Calls panic, since we this type has no string representation.
1.1882 + *
1.1883 + *----------------------------------------------------------------------
1.1884 + */
1.1885 +
1.1886 +static void
1.1887 +ProcBodyUpdateString(objPtr)
1.1888 + Tcl_Obj *objPtr; /* the object to update */
1.1889 +{
1.1890 + panic("called ProcBodyUpdateString");
1.1891 +}
1.1892 +
1.1893 +
1.1894 +/*
1.1895 + *----------------------------------------------------------------------
1.1896 + *
1.1897 + * TclCompileNoOp --
1.1898 + *
1.1899 + * Procedure called to compile noOp's
1.1900 + *
1.1901 + * Results:
1.1902 + * The return value is TCL_OK, indicating successful compilation.
1.1903 + *
1.1904 + * Side effects:
1.1905 + * Instructions are added to envPtr to execute a noOp at runtime.
1.1906 + *
1.1907 + *----------------------------------------------------------------------
1.1908 + */
1.1909 +
1.1910 +static int
1.1911 +TclCompileNoOp(interp, parsePtr, envPtr)
1.1912 + Tcl_Interp *interp; /* Used for error reporting. */
1.1913 + Tcl_Parse *parsePtr; /* Points to a parse structure for the
1.1914 + * command created by Tcl_ParseCommand. */
1.1915 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.1916 +{
1.1917 + Tcl_Token *tokenPtr;
1.1918 + int i, code;
1.1919 + int savedStackDepth = envPtr->currStackDepth;
1.1920 +
1.1921 + tokenPtr = parsePtr->tokenPtr;
1.1922 + for(i = 1; i < parsePtr->numWords; i++) {
1.1923 + tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
1.1924 + envPtr->currStackDepth = savedStackDepth;
1.1925 +
1.1926 + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1.1927 + code = TclCompileTokens(interp, tokenPtr+1,
1.1928 + tokenPtr->numComponents, envPtr);
1.1929 + if (code != TCL_OK) {
1.1930 + return code;
1.1931 + }
1.1932 + TclEmitOpcode(INST_POP, envPtr);
1.1933 + }
1.1934 + }
1.1935 + envPtr->currStackDepth = savedStackDepth;
1.1936 + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
1.1937 + return TCL_OK;
1.1938 +}
1.1939 +
1.1940 +/*
1.1941 + * Local Variables:
1.1942 + * mode: c
1.1943 + * c-basic-offset: 4
1.1944 + * fill-column: 78
1.1945 + * End:
1.1946 + */
1.1947 +