1/* 2 * tclProc.c -- 3 * 4 * This file contains routines that implement Tcl procedures, 5 * including the "proc" and "uplevel" commands. 6 * 7 * Copyright (c) 1987-1993 The Regents of the University of California. 8 * Copyright (c) 1994-1998 Sun Microsystems, Inc. 9 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> 10 * 11 * See the file "license.terms" for information on usage and redistribution 12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 * 14 * RCS: @(#) $Id: tclProc.c,v 1.44.2.7 2007/09/13 15:28:17 das Exp $ 15 */ 16 17#include "tclInt.h" 18#include "tclCompile.h" 19 20/* 21 * Prototypes for static functions in this file 22 */ 23 24static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr)); 25static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr)); 26static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp, 27 Tcl_Obj *objPtr)); 28static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr)); 29static int ProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp, 30 Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, 31 CONST char *description, CONST char *procName, 32 Proc **procPtrPtr)); 33static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp, 34 char *procName, int nameLen, int returnCode)); 35static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp, 36 Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); 37 38/* 39 * The ProcBodyObjType type 40 */ 41 42Tcl_ObjType tclProcBodyType = { 43 "procbody", /* name for this type */ 44 ProcBodyFree, /* FreeInternalRep procedure */ 45 ProcBodyDup, /* DupInternalRep procedure */ 46 ProcBodyUpdateString, /* UpdateString procedure */ 47 ProcBodySetFromAny /* SetFromAny procedure */ 48}; 49 50/* 51 *---------------------------------------------------------------------- 52 * 53 * Tcl_ProcObjCmd -- 54 * 55 * This object-based procedure is invoked to process the "proc" Tcl 56 * command. See the user documentation for details on what it does. 57 * 58 * Results: 59 * A standard Tcl object result value. 60 * 61 * Side effects: 62 * A new procedure gets created. 63 * 64 *---------------------------------------------------------------------- 65 */ 66 67 /* ARGSUSED */ 68int 69Tcl_ProcObjCmd(dummy, interp, objc, objv) 70 ClientData dummy; /* Not used. */ 71 Tcl_Interp *interp; /* Current interpreter. */ 72 int objc; /* Number of arguments. */ 73 Tcl_Obj *CONST objv[]; /* Argument objects. */ 74{ 75 register Interp *iPtr = (Interp *) interp; 76 Proc *procPtr; 77 char *fullName; 78 CONST char *procName, *procArgs, *procBody; 79 Namespace *nsPtr, *altNsPtr, *cxtNsPtr; 80 Tcl_Command cmd; 81 Tcl_DString ds; 82 83 if (objc != 4) { 84 Tcl_WrongNumArgs(interp, 1, objv, "name args body"); 85 return TCL_ERROR; 86 } 87 88 /* 89 * Determine the namespace where the procedure should reside. Unless 90 * the command name includes namespace qualifiers, this will be the 91 * current namespace. 92 */ 93 94 fullName = TclGetString(objv[1]); 95 TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, 96 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); 97 98 if (nsPtr == NULL) { 99 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 100 "can't create procedure \"", fullName, 101 "\": unknown namespace", (char *) NULL); 102 return TCL_ERROR; 103 } 104 if (procName == NULL) { 105 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 106 "can't create procedure \"", fullName, 107 "\": bad procedure name", (char *) NULL); 108 return TCL_ERROR; 109 } 110 if ((nsPtr != iPtr->globalNsPtr) 111 && (procName != NULL) && (procName[0] == ':')) { 112 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 113 "can't create procedure \"", procName, 114 "\" in non-global namespace with name starting with \":\"", 115 (char *) NULL); 116 return TCL_ERROR; 117 } 118 119 /* 120 * Create the data structure to represent the procedure. 121 */ 122 if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], 123 &procPtr) != TCL_OK) { 124 return TCL_ERROR; 125 } 126 127 /* 128 * Now create a command for the procedure. This will initially be in 129 * the current namespace unless the procedure's name included namespace 130 * qualifiers. To create the new command in the right namespace, we 131 * generate a fully qualified name for it. 132 */ 133 134 Tcl_DStringInit(&ds); 135 if (nsPtr != iPtr->globalNsPtr) { 136 Tcl_DStringAppend(&ds, nsPtr->fullName, -1); 137 Tcl_DStringAppend(&ds, "::", 2); 138 } 139 Tcl_DStringAppend(&ds, procName, -1); 140 141 Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc, 142 (ClientData) procPtr, TclProcDeleteProc); 143 cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), 144 TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); 145 146 Tcl_DStringFree(&ds); 147 /* 148 * Now initialize the new procedure's cmdPtr field. This will be used 149 * later when the procedure is called to determine what namespace the 150 * procedure will run in. This will be different than the current 151 * namespace if the proc was renamed into a different namespace. 152 */ 153 154 procPtr->cmdPtr = (Command *) cmd; 155 156#ifdef TCL_TIP280 157 /* TIP #280 Remember the line the procedure body is starting on. In a 158 * Byte code context we ask the engine to provide us with the necessary 159 * information. This is for the initialization of the byte code compiler 160 * when the body is used for the first time. 161 */ 162 163 if (iPtr->cmdFramePtr) { 164 CmdFrame context = *iPtr->cmdFramePtr; 165 166 if (context.type == TCL_LOCATION_BC) { 167 TclGetSrcInfoForPc (&context); 168 /* May get path in context */ 169 } else if (context.type == TCL_LOCATION_SOURCE) { 170 /* context now holds another reference */ 171 Tcl_IncrRefCount (context.data.eval.path); 172 } 173 174 /* type == TCL_LOCATION_PREBC implies that 'line' is NULL here! We 175 * cannot assume that 'line' is valid here, we have to check. If the 176 * outer context is an eval (bc, prebc, eval) we do not save any 177 * information. Counting relative to the beginning of the proc body is 178 * more sensible than counting relative to the outer eval block. 179 */ 180 181 if ((context.type == TCL_LOCATION_SOURCE) && 182 context.line && 183 (context.nline >= 4) && 184 (context.line [3] >= 0)) { 185 int isNew; 186 Tcl_HashEntry* hePtr; 187 CmdFrame* cfPtr = (CmdFrame*) ckalloc (sizeof (CmdFrame)); 188 189 cfPtr->level = -1; 190 cfPtr->type = context.type; 191 cfPtr->line = (int*) ckalloc (sizeof (int)); 192 cfPtr->line [0] = context.line [3]; 193 cfPtr->nline = 1; 194 cfPtr->framePtr = NULL; 195 cfPtr->nextPtr = NULL; 196 197 if (context.type == TCL_LOCATION_SOURCE) { 198 cfPtr->data.eval.path = context.data.eval.path; 199 /* Transfer of reference. The reference going away (release of 200 * the context) is replaced by the reference in the 201 * constructed cmdframe */ 202 } else { 203 cfPtr->type = TCL_LOCATION_EVAL; 204 cfPtr->data.eval.path = NULL; 205 } 206 207 cfPtr->cmd.str.cmd = NULL; 208 cfPtr->cmd.str.len = 0; 209 210 hePtr = Tcl_CreateHashEntry (iPtr->linePBodyPtr, (char*) procPtr, 211 &isNew); 212 if (!isNew) { 213 /* 214 * Get the old command frame and release it. See also 215 * TclProcCleanupProc in this file. Currently it seems as if 216 * only the procbodytest::proc command of the testsuite is 217 * able to trigger this situation. 218 */ 219 220 CmdFrame* cfOldPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); 221 222 if (cfOldPtr->type == TCL_LOCATION_SOURCE) { 223 Tcl_DecrRefCount(cfOldPtr->data.eval.path); 224 cfOldPtr->data.eval.path = NULL; 225 } 226 ckfree((char *) cfOldPtr->line); 227 cfOldPtr->line = NULL; 228 ckfree((char *) cfOldPtr); 229 } 230 Tcl_SetHashValue (hePtr, cfPtr); 231 } 232 } 233#endif 234 235 /* 236 * Optimize for noop procs: if the body is not precompiled (like a TclPro 237 * procbody), and the argument list is just "args" and the body is empty, 238 * define a compileProc to compile a noop. 239 * 240 * Notes: 241 * - cannot be done for any argument list without having different 242 * compiled/not-compiled behaviour in the "wrong argument #" case, 243 * or making this code much more complicated. In any case, it doesn't 244 * seem to make a lot of sense to verify the number of arguments we 245 * are about to ignore ... 246 * - could be enhanced to handle also non-empty bodies that contain 247 * only comments; however, parsing the body will slow down the 248 * compilation of all procs whose argument list is just _args_ */ 249 250 if (objv[3]->typePtr == &tclProcBodyType) { 251 goto done; 252 } 253 254 procArgs = Tcl_GetString(objv[2]); 255 256 while (*procArgs == ' ') { 257 procArgs++; 258 } 259 260 if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { 261 procArgs +=4; 262 while(*procArgs != '\0') { 263 if (*procArgs != ' ') { 264 goto done; 265 } 266 procArgs++; 267 } 268 269 /* 270 * The argument list is just "args"; check the body 271 */ 272 273 procBody = Tcl_GetString(objv[3]); 274 while (*procBody != '\0') { 275 if (!isspace(UCHAR(*procBody))) { 276 goto done; 277 } 278 procBody++; 279 } 280 281 /* 282 * The body is just spaces: link the compileProc 283 */ 284 285 ((Command *) cmd)->compileProc = TclCompileNoOp; 286 } 287 288 done: 289 return TCL_OK; 290} 291 292/* 293 *---------------------------------------------------------------------- 294 * 295 * TclCreateProc -- 296 * 297 * Creates the data associated with a Tcl procedure definition. 298 * This procedure knows how to handle two types of body objects: 299 * strings and procbody. Strings are the traditional (and common) value 300 * for bodies, procbody are values created by extensions that have 301 * loaded a previously compiled script. 302 * 303 * Results: 304 * Returns TCL_OK on success, along with a pointer to a Tcl 305 * procedure definition in procPtrPtr. This definition should 306 * be freed by calling TclCleanupProc() when it is no longer 307 * needed. Returns TCL_ERROR if anything goes wrong. 308 * 309 * Side effects: 310 * If anything goes wrong, this procedure returns an error 311 * message in the interpreter. 312 * 313 *---------------------------------------------------------------------- 314 */ 315int 316TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) 317 Tcl_Interp *interp; /* interpreter containing proc */ 318 Namespace *nsPtr; /* namespace containing this proc */ 319 CONST char *procName; /* unqualified name of this proc */ 320 Tcl_Obj *argsPtr; /* description of arguments */ 321 Tcl_Obj *bodyPtr; /* command body */ 322 Proc **procPtrPtr; /* returns: pointer to proc data */ 323{ 324 Interp *iPtr = (Interp*)interp; 325 CONST char **argArray = NULL; 326 327 register Proc *procPtr; 328 int i, length, result, numArgs; 329 CONST char *args, *bytes, *p; 330 register CompiledLocal *localPtr = NULL; 331 Tcl_Obj *defPtr; 332 int precompiled = 0; 333 334 if (bodyPtr->typePtr == &tclProcBodyType) { 335 /* 336 * Because the body is a TclProProcBody, the actual body is already 337 * compiled, and it is not shared with anyone else, so it's OK not to 338 * unshare it (as a matter of fact, it is bad to unshare it, because 339 * there may be no source code). 340 * 341 * We don't create and initialize a Proc structure for the procedure; 342 * rather, we use what is in the body object. Note that 343 * we initialize its cmdPtr field below after we've created the command 344 * for the procedure. We increment the ref count of the Proc struct 345 * since the command (soon to be created) will be holding a reference 346 * to it. 347 */ 348 349 procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr; 350 procPtr->iPtr = iPtr; 351 procPtr->refCount++; 352 precompiled = 1; 353 } else { 354 /* 355 * If the procedure's body object is shared because its string value is 356 * identical to, e.g., the body of another procedure, we must create a 357 * private copy for this procedure to use. Such sharing of procedure 358 * bodies is rare but can cause problems. A procedure body is compiled 359 * in a context that includes the number of compiler-allocated "slots" 360 * for local variables. Each formal parameter is given a local variable 361 * slot (the "procPtr->numCompiledLocals = numArgs" assignment 362 * below). This means that the same code can not be shared by two 363 * procedures that have a different number of arguments, even if their 364 * bodies are identical. Note that we don't use Tcl_DuplicateObj since 365 * we would not want any bytecode internal representation. 366 */ 367 368 if (Tcl_IsShared(bodyPtr)) { 369#ifdef TCL_TIP280 370 Tcl_Obj* sharedBodyPtr = bodyPtr; 371#endif 372 bytes = Tcl_GetStringFromObj(bodyPtr, &length); 373 bodyPtr = Tcl_NewStringObj(bytes, length); 374#ifdef TCL_TIP280 375 /* 376 * TIP #280. 377 * Ensure that the continuation line data for the original body is 378 * not lost and applies to the new body as well. 379 */ 380 381 TclContinuationsCopy (bodyPtr, sharedBodyPtr); 382#endif 383 } 384 385 /* 386 * Create and initialize a Proc structure for the procedure. Note that 387 * we initialize its cmdPtr field below after we've created the command 388 * for the procedure. We increment the ref count of the procedure's 389 * body object since there will be a reference to it in the Proc 390 * structure. 391 */ 392 393 Tcl_IncrRefCount(bodyPtr); 394 395 procPtr = (Proc *) ckalloc(sizeof(Proc)); 396 procPtr->iPtr = iPtr; 397 procPtr->refCount = 1; 398 procPtr->bodyPtr = bodyPtr; 399 procPtr->numArgs = 0; /* actual argument count is set below. */ 400 procPtr->numCompiledLocals = 0; 401 procPtr->firstLocalPtr = NULL; 402 procPtr->lastLocalPtr = NULL; 403 } 404 405 /* 406 * Break up the argument list into argument specifiers, then process 407 * each argument specifier. 408 * If the body is precompiled, processing is limited to checking that 409 * the the parsed argument is consistent with the one stored in the 410 * Proc. 411 * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS. 412 */ 413 414 args = Tcl_GetStringFromObj(argsPtr, &length); 415 result = Tcl_SplitList(interp, args, &numArgs, &argArray); 416 if (result != TCL_OK) { 417 goto procError; 418 } 419 420 if (precompiled) { 421 if (numArgs > procPtr->numArgs) { 422 char buf[64 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE]; 423 sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d", 424 numArgs, procPtr->numArgs); 425 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 426 "procedure \"", procName, 427 buf, (char *) NULL); 428 goto procError; 429 } 430 localPtr = procPtr->firstLocalPtr; 431 } else { 432 procPtr->numArgs = numArgs; 433 procPtr->numCompiledLocals = numArgs; 434 } 435 for (i = 0; i < numArgs; i++) { 436 int fieldCount, nameLength, valueLength; 437 CONST char **fieldValues; 438 439 /* 440 * Now divide the specifier up into name and default. 441 */ 442 443 result = Tcl_SplitList(interp, argArray[i], &fieldCount, 444 &fieldValues); 445 if (result != TCL_OK) { 446 goto procError; 447 } 448 if (fieldCount > 2) { 449 ckfree((char *) fieldValues); 450 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 451 "too many fields in argument specifier \"", 452 argArray[i], "\"", (char *) NULL); 453 goto procError; 454 } 455 if ((fieldCount == 0) || (*fieldValues[0] == 0)) { 456 ckfree((char *) fieldValues); 457 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 458 "procedure \"", procName, 459 "\" has argument with no name", (char *) NULL); 460 goto procError; 461 } 462 463 nameLength = strlen(fieldValues[0]); 464 if (fieldCount == 2) { 465 valueLength = strlen(fieldValues[1]); 466 } else { 467 valueLength = 0; 468 } 469 470 /* 471 * Check that the formal parameter name is a scalar. 472 */ 473 474 p = fieldValues[0]; 475 while (*p != '\0') { 476 if (*p == '(') { 477 CONST char *q = p; 478 do { 479 q++; 480 } while (*q != '\0'); 481 q--; 482 if (*q == ')') { /* we have an array element */ 483 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 484 "procedure \"", procName, 485 "\" has formal parameter \"", fieldValues[0], 486 "\" that is an array element", 487 (char *) NULL); 488 ckfree((char *) fieldValues); 489 goto procError; 490 } 491 } else if ((*p == ':') && (*(p+1) == ':')) { 492 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 493 "procedure \"", procName, 494 "\" has formal parameter \"", fieldValues[0], 495 "\" that is not a simple name", 496 (char *) NULL); 497 ckfree((char *) fieldValues); 498 goto procError; 499 } 500 p++; 501 } 502 503 if (precompiled) { 504 /* 505 * Compare the parsed argument with the stored one. 506 * For the flags, we and out VAR_UNDEFINED to support bridging 507 * precompiled <= 8.3 code in 8.4 where this is now used as an 508 * optimization indicator. Yes, this is a hack. -- hobbs 509 */ 510 511 if ((localPtr->nameLength != nameLength) 512 || (strcmp(localPtr->name, fieldValues[0])) 513 || (localPtr->frameIndex != i) 514 || ((localPtr->flags & ~VAR_UNDEFINED) 515 != (VAR_SCALAR | VAR_ARGUMENT)) 516 || ((localPtr->defValuePtr == NULL) 517 && (fieldCount == 2)) 518 || ((localPtr->defValuePtr != NULL) 519 && (fieldCount != 2))) { 520 char buf[80 + TCL_INTEGER_SPACE]; 521 sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body", 522 i); 523 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 524 "procedure \"", procName, 525 buf, (char *) NULL); 526 ckfree((char *) fieldValues); 527 goto procError; 528 } 529 530 /* 531 * compare the default value if any 532 */ 533 534 if (localPtr->defValuePtr != NULL) { 535 int tmpLength; 536 char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, 537 &tmpLength); 538 if ((valueLength != tmpLength) 539 || (strncmp(fieldValues[1], tmpPtr, 540 (size_t) tmpLength))) { 541 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 542 "procedure \"", procName, 543 "\": formal parameter \"", 544 fieldValues[0], 545 "\" has default value inconsistent with precompiled body", 546 (char *) NULL); 547 ckfree((char *) fieldValues); 548 goto procError; 549 } 550 } 551 552 localPtr = localPtr->nextPtr; 553 } else { 554 /* 555 * Allocate an entry in the runtime procedure frame's array of 556 * local variables for the argument. 557 */ 558 559 localPtr = (CompiledLocal *) ckalloc((unsigned) 560 (sizeof(CompiledLocal) - sizeof(localPtr->name) 561 + nameLength+1)); 562 if (procPtr->firstLocalPtr == NULL) { 563 procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; 564 } else { 565 procPtr->lastLocalPtr->nextPtr = localPtr; 566 procPtr->lastLocalPtr = localPtr; 567 } 568 localPtr->nextPtr = NULL; 569 localPtr->nameLength = nameLength; 570 localPtr->frameIndex = i; 571 localPtr->flags = VAR_SCALAR | VAR_ARGUMENT; 572 localPtr->resolveInfo = NULL; 573 574 if (fieldCount == 2) { 575 localPtr->defValuePtr = 576 Tcl_NewStringObj(fieldValues[1], valueLength); 577 Tcl_IncrRefCount(localPtr->defValuePtr); 578 } else { 579 localPtr->defValuePtr = NULL; 580 } 581 strcpy(localPtr->name, fieldValues[0]); 582 } 583 584 ckfree((char *) fieldValues); 585 } 586 587 /* 588 * Now initialize the new procedure's cmdPtr field. This will be used 589 * later when the procedure is called to determine what namespace the 590 * procedure will run in. This will be different than the current 591 * namespace if the proc was renamed into a different namespace. 592 */ 593 594 *procPtrPtr = procPtr; 595 ckfree((char *) argArray); 596 return TCL_OK; 597 598procError: 599 if (precompiled) { 600 procPtr->refCount--; 601 } else { 602 Tcl_DecrRefCount(bodyPtr); 603 while (procPtr->firstLocalPtr != NULL) { 604 localPtr = procPtr->firstLocalPtr; 605 procPtr->firstLocalPtr = localPtr->nextPtr; 606 607 defPtr = localPtr->defValuePtr; 608 if (defPtr != NULL) { 609 Tcl_DecrRefCount(defPtr); 610 } 611 612 ckfree((char *) localPtr); 613 } 614 ckfree((char *) procPtr); 615 } 616 if (argArray != NULL) { 617 ckfree((char *) argArray); 618 } 619 return TCL_ERROR; 620} 621 622/* 623 *---------------------------------------------------------------------- 624 * 625 * TclGetFrame -- 626 * 627 * Given a description of a procedure frame, such as the first 628 * argument to an "uplevel" or "upvar" command, locate the 629 * call frame for the appropriate level of procedure. 630 * 631 * Results: 632 * The return value is -1 if an error occurred in finding the frame 633 * (in this case an error message is left in the interp's result). 634 * 1 is returned if string was either a number or a number preceded 635 * by "#" and it specified a valid frame. 0 is returned if string 636 * isn't one of the two things above (in this case, the lookup 637 * acts as if string were "1"). The variable pointed to by 638 * framePtrPtr is filled in with the address of the desired frame 639 * (unless an error occurs, in which case it isn't modified). 640 * 641 * Side effects: 642 * None. 643 * 644 *---------------------------------------------------------------------- 645 */ 646 647int 648TclGetFrame(interp, string, framePtrPtr) 649 Tcl_Interp *interp; /* Interpreter in which to find frame. */ 650 CONST char *string; /* String describing frame. */ 651 CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL 652 * if global frame indicated). */ 653{ 654 register Interp *iPtr = (Interp *) interp; 655 int curLevel, level, result; 656 CallFrame *framePtr; 657 658 /* 659 * Parse string to figure out which level number to go to. 660 */ 661 662 result = 1; 663 curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; 664 if (*string == '#') { 665 if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) { 666 return -1; 667 } 668 if (level < 0) { 669 levelError: 670 Tcl_AppendResult(interp, "bad level \"", string, "\"", 671 (char *) NULL); 672 return -1; 673 } 674 } else if (isdigit(UCHAR(*string))) { /* INTL: digit */ 675 if (Tcl_GetInt(interp, string, &level) != TCL_OK) { 676 return -1; 677 } 678 level = curLevel - level; 679 } else { 680 level = curLevel - 1; 681 result = 0; 682 } 683 684 /* 685 * Figure out which frame to use, and modify the interpreter so 686 * its variables come from that frame. 687 */ 688 689 if (level == 0) { 690 framePtr = NULL; 691 } else { 692 for (framePtr = iPtr->varFramePtr; framePtr != NULL; 693 framePtr = framePtr->callerVarPtr) { 694 if (framePtr->level == level) { 695 break; 696 } 697 } 698 if (framePtr == NULL) { 699 goto levelError; 700 } 701 } 702 *framePtrPtr = framePtr; 703 return result; 704} 705 706/* 707 *---------------------------------------------------------------------- 708 * 709 * Tcl_UplevelObjCmd -- 710 * 711 * This object procedure is invoked to process the "uplevel" Tcl 712 * command. See the user documentation for details on what it does. 713 * 714 * Results: 715 * A standard Tcl object result value. 716 * 717 * Side effects: 718 * See the user documentation. 719 * 720 *---------------------------------------------------------------------- 721 */ 722 723 /* ARGSUSED */ 724int 725Tcl_UplevelObjCmd(dummy, interp, objc, objv) 726 ClientData dummy; /* Not used. */ 727 Tcl_Interp *interp; /* Current interpreter. */ 728 int objc; /* Number of arguments. */ 729 Tcl_Obj *CONST objv[]; /* Argument objects. */ 730{ 731 register Interp *iPtr = (Interp *) interp; 732 char *optLevel; 733 int result; 734 CallFrame *savedVarFramePtr, *framePtr; 735 736 if (objc < 2) { 737 uplevelSyntax: 738 Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); 739 return TCL_ERROR; 740 } 741 742 /* 743 * Find the level to use for executing the command. 744 */ 745 746 optLevel = TclGetString(objv[1]); 747 result = TclGetFrame(interp, optLevel, &framePtr); 748 if (result == -1) { 749 return TCL_ERROR; 750 } 751 objc -= (result+1); 752 if (objc == 0) { 753 goto uplevelSyntax; 754 } 755 objv += (result+1); 756 757 /* 758 * Modify the interpreter state to execute in the given frame. 759 */ 760 761 savedVarFramePtr = iPtr->varFramePtr; 762 iPtr->varFramePtr = framePtr; 763 764 /* 765 * Execute the residual arguments as a command. 766 */ 767 768 if (objc == 1) { 769#ifdef TCL_TIP280 770 /* TIP #280. Make argument location available to eval'd script */ 771 CmdFrame* invoker = NULL; 772 int word = 0; 773 TclArgumentGet (interp, objv[0], &invoker, &word); 774 result = TclEvalObjEx(interp, objv[0], TCL_EVAL_DIRECT, invoker, word); 775#else 776 result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT); 777#endif 778 } else { 779 /* 780 * More than one argument: concatenate them together with spaces 781 * between, then evaluate the result. Tcl_EvalObjEx will delete 782 * the object when it decrements its refcount after eval'ing it. 783 */ 784 Tcl_Obj *objPtr; 785 786 objPtr = Tcl_ConcatObj(objc, objv); 787 result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); 788 } 789 if (result == TCL_ERROR) { 790 char msg[32 + TCL_INTEGER_SPACE]; 791 sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); 792 Tcl_AddObjErrorInfo(interp, msg, -1); 793 } 794 795 /* 796 * Restore the variable frame, and return. 797 */ 798 799 iPtr->varFramePtr = savedVarFramePtr; 800 return result; 801} 802 803/* 804 *---------------------------------------------------------------------- 805 * 806 * TclFindProc -- 807 * 808 * Given the name of a procedure, return a pointer to the 809 * record describing the procedure. The procedure will be 810 * looked up using the usual rules: first in the current 811 * namespace and then in the global namespace. 812 * 813 * Results: 814 * NULL is returned if the name doesn't correspond to any 815 * procedure. Otherwise, the return value is a pointer to 816 * the procedure's record. If the name is found but refers 817 * to an imported command that points to a "real" procedure 818 * defined in another namespace, a pointer to that "real" 819 * procedure's structure is returned. 820 * 821 * Side effects: 822 * None. 823 * 824 *---------------------------------------------------------------------- 825 */ 826 827Proc * 828TclFindProc(iPtr, procName) 829 Interp *iPtr; /* Interpreter in which to look. */ 830 CONST char *procName; /* Name of desired procedure. */ 831{ 832 Tcl_Command cmd; 833 Tcl_Command origCmd; 834 Command *cmdPtr; 835 836 cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, 837 (Tcl_Namespace *) NULL, /*flags*/ 0); 838 if (cmd == (Tcl_Command) NULL) { 839 return NULL; 840 } 841 cmdPtr = (Command *) cmd; 842 843 origCmd = TclGetOriginalCommand(cmd); 844 if (origCmd != NULL) { 845 cmdPtr = (Command *) origCmd; 846 } 847 if (cmdPtr->proc != TclProcInterpProc) { 848 return NULL; 849 } 850 return (Proc *) cmdPtr->clientData; 851} 852 853/* 854 *---------------------------------------------------------------------- 855 * 856 * TclIsProc -- 857 * 858 * Tells whether a command is a Tcl procedure or not. 859 * 860 * Results: 861 * If the given command is actually a Tcl procedure, the 862 * return value is the address of the record describing 863 * the procedure. Otherwise the return value is 0. 864 * 865 * Side effects: 866 * None. 867 * 868 *---------------------------------------------------------------------- 869 */ 870 871Proc * 872TclIsProc(cmdPtr) 873 Command *cmdPtr; /* Command to test. */ 874{ 875 Tcl_Command origCmd; 876 877 origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); 878 if (origCmd != NULL) { 879 cmdPtr = (Command *) origCmd; 880 } 881 if (cmdPtr->proc == TclProcInterpProc) { 882 return (Proc *) cmdPtr->clientData; 883 } 884 return (Proc *) 0; 885} 886 887/* 888 *---------------------------------------------------------------------- 889 * 890 * TclProcInterpProc -- 891 * 892 * When a Tcl procedure gets invoked with an argc/argv array of 893 * strings, this routine gets invoked to interpret the procedure. 894 * 895 * Results: 896 * A standard Tcl result value, usually TCL_OK. 897 * 898 * Side effects: 899 * Depends on the commands in the procedure. 900 * 901 *---------------------------------------------------------------------- 902 */ 903 904int 905TclProcInterpProc(clientData, interp, argc, argv) 906 ClientData clientData; /* Record describing procedure to be 907 * interpreted. */ 908 Tcl_Interp *interp; /* Interpreter in which procedure was 909 * invoked. */ 910 int argc; /* Count of number of arguments to this 911 * procedure. */ 912 register CONST char **argv; /* Argument values. */ 913{ 914 register Tcl_Obj *objPtr; 915 register int i; 916 int result; 917 918 /* 919 * This procedure generates an objv array for object arguments that hold 920 * the argv strings. It starts out with stack-allocated space but uses 921 * dynamically-allocated storage if needed. 922 */ 923 924#define NUM_ARGS 20 925 Tcl_Obj *(objStorage[NUM_ARGS]); 926 register Tcl_Obj **objv = objStorage; 927 928 /* 929 * Create the object argument array "objv". Make sure objv is large 930 * enough to hold the objc arguments plus 1 extra for the zero 931 * end-of-objv word. 932 */ 933 934 if ((argc + 1) > NUM_ARGS) { 935 objv = (Tcl_Obj **) 936 ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *)); 937 } 938 939 for (i = 0; i < argc; i++) { 940 objv[i] = Tcl_NewStringObj(argv[i], -1); 941 Tcl_IncrRefCount(objv[i]); 942 } 943 objv[argc] = 0; 944 945 /* 946 * Use TclObjInterpProc to actually interpret the procedure. 947 */ 948 949 result = TclObjInterpProc(clientData, interp, argc, objv); 950 951 /* 952 * Move the interpreter's object result to the string result, 953 * then reset the object result. 954 */ 955 956 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), 957 TCL_VOLATILE); 958 959 /* 960 * Decrement the ref counts on the objv elements since we are done 961 * with them. 962 */ 963 964 for (i = 0; i < argc; i++) { 965 objPtr = objv[i]; 966 TclDecrRefCount(objPtr); 967 } 968 969 /* 970 * Free the objv array if malloc'ed storage was used. 971 */ 972 973 if (objv != objStorage) { 974 ckfree((char *) objv); 975 } 976 return result; 977#undef NUM_ARGS 978} 979 980/* 981 *---------------------------------------------------------------------- 982 * 983 * TclObjInterpProc -- 984 * 985 * When a Tcl procedure gets invoked during bytecode evaluation, this 986 * object-based routine gets invoked to interpret the procedure. 987 * 988 * Results: 989 * A standard Tcl object result value. 990 * 991 * Side effects: 992 * Depends on the commands in the procedure. 993 * 994 *---------------------------------------------------------------------- 995 */ 996 997int 998TclObjInterpProc(clientData, interp, objc, objv) 999 ClientData clientData; /* Record describing procedure to be 1000 * interpreted. */ 1001 register Tcl_Interp *interp; /* Interpreter in which procedure was 1002 * invoked. */ 1003 int objc; /* Count of number of arguments to this 1004 * procedure. */ 1005 Tcl_Obj *CONST objv[]; /* Argument value objects. */ 1006{ 1007 Interp *iPtr = (Interp *) interp; 1008 Proc *procPtr = (Proc *) clientData; 1009 Namespace *nsPtr = procPtr->cmdPtr->nsPtr; 1010 CallFrame frame; 1011 register CallFrame *framePtr = &frame; 1012 register Var *varPtr; 1013 register CompiledLocal *localPtr; 1014 char *procName; 1015 int nameLen, localCt, numArgs, argCt, i, result; 1016 1017 /* 1018 * This procedure generates an array "compiledLocals" that holds the 1019 * storage for local variables. It starts out with stack-allocated space 1020 * but uses dynamically-allocated storage if needed. 1021 */ 1022 1023#define NUM_LOCALS 20 1024 Var localStorage[NUM_LOCALS]; 1025 Var *compiledLocals = localStorage; 1026 1027 /* 1028 * Get the procedure's name. 1029 */ 1030 1031 procName = Tcl_GetStringFromObj(objv[0], &nameLen); 1032 1033 /* 1034 * If necessary, compile the procedure's body. The compiler will 1035 * allocate frame slots for the procedure's non-argument local 1036 * variables. Note that compiling the body might increase 1037 * procPtr->numCompiledLocals if new local variables are found 1038 * while compiling. 1039 */ 1040 1041 result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, 1042 "body of proc", procName, &procPtr); 1043 1044 if (result != TCL_OK) { 1045 return result; 1046 } 1047 1048 /* 1049 * Create the "compiledLocals" array. Make sure it is large enough to 1050 * hold all the procedure's compiled local variables, including its 1051 * formal parameters. 1052 */ 1053 1054 localCt = procPtr->numCompiledLocals; 1055 if (localCt > NUM_LOCALS) { 1056 compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var)); 1057 } 1058 1059 /* 1060 * Set up and push a new call frame for the new procedure invocation. 1061 * This call frame will execute in the proc's namespace, which might 1062 * be different than the current namespace. The proc's namespace is 1063 * that of its command, which can change if the command is renamed 1064 * from one namespace to another. 1065 */ 1066 1067 result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, 1068 (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1); 1069 1070 if (result != TCL_OK) { 1071 return result; 1072 } 1073 1074 framePtr->objc = objc; 1075 framePtr->objv = objv; /* ref counts for args are incremented below */ 1076 1077 /* 1078 * Initialize and resolve compiled variable references. 1079 */ 1080 1081 framePtr->procPtr = procPtr; 1082 framePtr->numCompiledLocals = localCt; 1083 framePtr->compiledLocals = compiledLocals; 1084 1085 TclInitCompiledLocals(interp, framePtr, nsPtr); 1086 1087 /* 1088 * Match and assign the call's actual parameters to the procedure's 1089 * formal arguments. The formal arguments are described by the first 1090 * numArgs entries in both the Proc structure's local variable list and 1091 * the call frame's local variable array. 1092 */ 1093 1094 numArgs = procPtr->numArgs; 1095 varPtr = framePtr->compiledLocals; 1096 localPtr = procPtr->firstLocalPtr; 1097 argCt = objc; 1098 for (i = 1, argCt -= 1; i <= numArgs; i++, argCt--) { 1099 if (!TclIsVarArgument(localPtr)) { 1100 panic("TclObjInterpProc: local variable %s is not argument but should be", 1101 localPtr->name); 1102 return TCL_ERROR; 1103 } 1104 if (TclIsVarTemporary(localPtr)) { 1105 panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i); 1106 return TCL_ERROR; 1107 } 1108 1109 /* 1110 * Handle the special case of the last formal being "args". When 1111 * it occurs, assign it a list consisting of all the remaining 1112 * actual arguments. 1113 */ 1114 1115 if ((i == numArgs) && ((localPtr->name[0] == 'a') 1116 && (strcmp(localPtr->name, "args") == 0))) { 1117 Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i])); 1118 varPtr->value.objPtr = listPtr; 1119 Tcl_IncrRefCount(listPtr); /* local var is a reference */ 1120 TclClearVarUndefined(varPtr); 1121 argCt = 0; 1122 break; /* done processing args */ 1123 } else if (argCt > 0) { 1124 Tcl_Obj *objPtr = objv[i]; 1125 varPtr->value.objPtr = objPtr; 1126 TclClearVarUndefined(varPtr); 1127 Tcl_IncrRefCount(objPtr); /* since the local variable now has 1128 * another reference to object. */ 1129 } else if (localPtr->defValuePtr != NULL) { 1130 Tcl_Obj *objPtr = localPtr->defValuePtr; 1131 varPtr->value.objPtr = objPtr; 1132 TclClearVarUndefined(varPtr); 1133 Tcl_IncrRefCount(objPtr); /* since the local variable now has 1134 * another reference to object. */ 1135 } else { 1136 goto incorrectArgs; 1137 } 1138 varPtr++; 1139 localPtr = localPtr->nextPtr; 1140 } 1141 if (argCt > 0) { 1142 Tcl_Obj *objResult; 1143 int len, flags; 1144 1145 incorrectArgs: 1146 /* 1147 * Build up equivalent to Tcl_WrongNumArgs message for proc 1148 */ 1149 1150 Tcl_ResetResult(interp); 1151 objResult = Tcl_GetObjResult(interp); 1152 Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1); 1153 1154 /* 1155 * Quote the proc name if it contains spaces (Bug 942757). 1156 */ 1157 1158 len = Tcl_ScanCountedElement(procName, nameLen, &flags); 1159 if (len != nameLen) { 1160 char *procName1 = ckalloc((unsigned) len); 1161 len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags); 1162 Tcl_AppendToObj(objResult, procName1, len); 1163 ckfree(procName1); 1164 } else { 1165 Tcl_AppendToObj(objResult, procName, len); 1166 } 1167 1168 localPtr = procPtr->firstLocalPtr; 1169 for (i = 1; i <= numArgs; i++) { 1170 if (localPtr->defValuePtr != NULL) { 1171 Tcl_AppendStringsToObj(objResult, 1172 " ?", localPtr->name, "?", (char *) NULL); 1173 } else { 1174 Tcl_AppendStringsToObj(objResult, 1175 " ", localPtr->name, (char *) NULL); 1176 } 1177 localPtr = localPtr->nextPtr; 1178 } 1179 Tcl_AppendStringsToObj(objResult, "\"", (char *) NULL); 1180 1181 result = TCL_ERROR; 1182 goto procDone; 1183 } 1184 1185 /* 1186 * Invoke the commands in the procedure's body. 1187 */ 1188 1189#ifdef TCL_COMPILE_DEBUG 1190 if (tclTraceExec >= 1) { 1191 fprintf(stdout, "Calling proc "); 1192 for (i = 0; i < objc; i++) { 1193 TclPrintObject(stdout, objv[i], 15); 1194 fprintf(stdout, " "); 1195 } 1196 fprintf(stdout, "\n"); 1197 fflush(stdout); 1198 } 1199#endif /*TCL_COMPILE_DEBUG*/ 1200 1201 if (TCL_DTRACE_PROC_ARGS_ENABLED()) { 1202 char *a[10]; 1203 int i = 0; 1204 1205 while (i < 10) { 1206 a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; 1207 } 1208 TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], 1209 a[8], a[9]); 1210 } 1211 1212 iPtr->returnCode = TCL_OK; 1213 procPtr->refCount++; 1214 if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { 1215 TCL_DTRACE_PROC_ENTRY(TclGetString(objv[0]), objc - 1, 1216 (Tcl_Obj **)(objv + 1)); 1217 } 1218#ifndef TCL_TIP280 1219 result = TclCompEvalObj(interp, procPtr->bodyPtr); 1220#else 1221 /* TIP #280: No need to set the invoking context here. The body has 1222 * already been compiled, so the part of CompEvalObj using it is bypassed. 1223 */ 1224 1225 result = TclCompEvalObj(interp, procPtr->bodyPtr, NULL, 0); 1226#endif 1227 if (TCL_DTRACE_PROC_RETURN_ENABLED()) { 1228 TCL_DTRACE_PROC_RETURN(TclGetString(objv[0]), result); 1229 } 1230 procPtr->refCount--; 1231 if (procPtr->refCount <= 0) { 1232 TclProcCleanupProc(procPtr); 1233 } 1234 1235 if (result != TCL_OK) { 1236 result = ProcessProcResultCode(interp, procName, nameLen, result); 1237 } 1238 1239 if (TCL_DTRACE_PROC_RESULT_ENABLED()) { 1240 Tcl_Obj *r; 1241 1242 r = Tcl_GetObjResult(interp); 1243 TCL_DTRACE_PROC_RESULT(TclGetString(objv[0]), result, 1244 TclGetString(r), r); 1245 } 1246 1247 /* 1248 * Pop and free the call frame for this procedure invocation, then 1249 * free the compiledLocals array if malloc'ed storage was used. 1250 */ 1251 1252 procDone: 1253 Tcl_PopCallFrame(interp); 1254 if (compiledLocals != localStorage) { 1255 ckfree((char *) compiledLocals); 1256 } 1257 return result; 1258#undef NUM_LOCALS 1259} 1260 1261/* 1262 *---------------------------------------------------------------------- 1263 * 1264 * TclProcCompileProc -- 1265 * 1266 * Called just before a procedure is executed to compile the 1267 * body to byte codes. If the type of the body is not 1268 * "byte code" or if the compile conditions have changed 1269 * (namespace context, epoch counters, etc.) then the body 1270 * is recompiled. Otherwise, this procedure does nothing. 1271 * 1272 * Results: 1273 * None. 1274 * 1275 * Side effects: 1276 * May change the internal representation of the body object 1277 * to compiled code. 1278 * 1279 *---------------------------------------------------------------------- 1280 */ 1281 1282int 1283TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) 1284 Tcl_Interp *interp; /* Interpreter containing procedure. */ 1285 Proc *procPtr; /* Data associated with procedure. */ 1286 Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr, 1287 * but could be any code fragment compiled 1288 * in the context of this procedure.) */ 1289 Namespace *nsPtr; /* Namespace containing procedure. */ 1290 CONST char *description; /* string describing this body of code. */ 1291 CONST char *procName; /* Name of this procedure. */ 1292{ 1293 return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, 1294 description, procName, NULL); 1295} 1296 1297static int 1298ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, 1299 procName, procPtrPtr) 1300 Tcl_Interp *interp; /* Interpreter containing procedure. */ 1301 Proc *procPtr; /* Data associated with procedure. */ 1302 Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr, 1303 * but could be any code fragment compiled 1304 * in the context of this procedure.) */ 1305 Namespace *nsPtr; /* Namespace containing procedure. */ 1306 CONST char *description; /* string describing this body of code. */ 1307 CONST char *procName; /* Name of this procedure. */ 1308 Proc **procPtrPtr; /* points to storage where a replacement 1309 * (Proc *) value may be written, when 1310 * appropriate */ 1311{ 1312 Interp *iPtr = (Interp*)interp; 1313 int i, result; 1314 Tcl_CallFrame frame; 1315 ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; 1316 CompiledLocal *localPtr; 1317 1318 /* 1319 * If necessary, compile the procedure's body. The compiler will 1320 * allocate frame slots for the procedure's non-argument local 1321 * variables. If the ByteCode already exists, make sure it hasn't been 1322 * invalidated by someone redefining a core command (this might make the 1323 * compiled code wrong). Also, if the code was compiled in/for a 1324 * different interpreter, we recompile it. Note that compiling the body 1325 * might increase procPtr->numCompiledLocals if new local variables are 1326 * found while compiling. 1327 * 1328 * Precompiled procedure bodies, however, are immutable and therefore 1329 * they are not recompiled, even if things have changed. 1330 */ 1331 1332 if (bodyPtr->typePtr == &tclByteCodeType) { 1333 if (((Interp *) *codePtr->interpHandle != iPtr) 1334 || (codePtr->compileEpoch != iPtr->compileEpoch) 1335 || (codePtr->nsPtr != nsPtr)) { 1336 if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { 1337 if ((Interp *) *codePtr->interpHandle != iPtr) { 1338 Tcl_AppendResult(interp, 1339 "a precompiled script jumped interps", NULL); 1340 return TCL_ERROR; 1341 } 1342 codePtr->compileEpoch = iPtr->compileEpoch; 1343 codePtr->nsPtr = nsPtr; 1344 } else { 1345 (*tclByteCodeType.freeIntRepProc)(bodyPtr); 1346 bodyPtr->typePtr = (Tcl_ObjType *) NULL; 1347 } 1348 } 1349 } 1350 if (bodyPtr->typePtr != &tclByteCodeType) { 1351 int numChars; 1352 char *ellipsis; 1353 1354#ifdef TCL_COMPILE_DEBUG 1355 if (tclTraceCompile >= 1) { 1356 /* 1357 * Display a line summarizing the top level command we 1358 * are about to compile. 1359 */ 1360 1361 numChars = strlen(procName); 1362 ellipsis = ""; 1363 if (numChars > 50) { 1364 numChars = 50; 1365 ellipsis = "..."; 1366 } 1367 fprintf(stdout, "Compiling %s \"%.*s%s\"\n", 1368 description, numChars, procName, ellipsis); 1369 } 1370#endif 1371 1372 /* 1373 * Plug the current procPtr into the interpreter and coerce 1374 * the code body to byte codes. The interpreter needs to 1375 * know which proc it's compiling so that it can access its 1376 * list of compiled locals. 1377 * 1378 * TRICKY NOTE: Be careful to push a call frame with the 1379 * proper namespace context, so that the byte codes are 1380 * compiled in the appropriate class context. 1381 */ 1382 1383 if (procPtrPtr != NULL && procPtr->refCount > 1) { 1384 Tcl_Command token; 1385 Tcl_CmdInfo info; 1386 Proc *new = (Proc *) ckalloc(sizeof(Proc)); 1387 1388 new->iPtr = procPtr->iPtr; 1389 new->refCount = 1; 1390 new->cmdPtr = procPtr->cmdPtr; 1391 token = (Tcl_Command) new->cmdPtr; 1392 new->bodyPtr = Tcl_DuplicateObj(bodyPtr); 1393 bodyPtr = new->bodyPtr; 1394 Tcl_IncrRefCount(bodyPtr); 1395 new->numArgs = procPtr->numArgs; 1396 1397 new->numCompiledLocals = new->numArgs; 1398 new->firstLocalPtr = NULL; 1399 new->lastLocalPtr = NULL; 1400 localPtr = procPtr->firstLocalPtr; 1401 for (i = 0; i < new->numArgs; i++, localPtr = localPtr->nextPtr) { 1402 CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned) 1403 (sizeof(CompiledLocal) -sizeof(localPtr->name) 1404 + localPtr->nameLength + 1)); 1405 if (new->firstLocalPtr == NULL) { 1406 new->firstLocalPtr = new->lastLocalPtr = copy; 1407 } else { 1408 new->lastLocalPtr->nextPtr = copy; 1409 new->lastLocalPtr = copy; 1410 } 1411 copy->nextPtr = NULL; 1412 copy->nameLength = localPtr->nameLength; 1413 copy->frameIndex = localPtr->frameIndex; 1414 copy->flags = localPtr->flags; 1415 copy->defValuePtr = localPtr->defValuePtr; 1416 if (copy->defValuePtr) { 1417 Tcl_IncrRefCount(copy->defValuePtr); 1418 } 1419 copy->resolveInfo = localPtr->resolveInfo; 1420 strcpy(copy->name, localPtr->name); 1421 } 1422 1423 1424 /* Reset the ClientData */ 1425 Tcl_GetCommandInfoFromToken(token, &info); 1426 if (info.objClientData == (ClientData) procPtr) { 1427 info.objClientData = (ClientData) new; 1428 } 1429 if (info.clientData == (ClientData) procPtr) { 1430 info.clientData = (ClientData) new; 1431 } 1432 if (info.deleteData == (ClientData) procPtr) { 1433 info.deleteData = (ClientData) new; 1434 } 1435 Tcl_SetCommandInfoFromToken(token, &info); 1436 1437 procPtr->refCount--; 1438 *procPtrPtr = procPtr = new; 1439 } 1440 iPtr->compiledProcPtr = procPtr; 1441 1442 result = Tcl_PushCallFrame(interp, &frame, 1443 (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); 1444 1445 if (result == TCL_OK) { 1446#ifdef TCL_TIP280 1447 /* TIP #280. We get the invoking context from the cmdFrame 1448 * which was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr). 1449 */ 1450 1451 Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr); 1452 1453 /* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd. 1454 */ 1455 iPtr->invokeWord = 0; 1456 iPtr->invokeCmdFramePtr = (hePtr 1457 ? (CmdFrame*) Tcl_GetHashValue (hePtr) 1458 : NULL); 1459#endif 1460 result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); 1461#ifdef TCL_TIP280 1462 iPtr->invokeCmdFramePtr = NULL; 1463#endif 1464 Tcl_PopCallFrame(interp); 1465 } 1466 1467 if (result != TCL_OK) { 1468 if (result == TCL_ERROR) { 1469 char buf[100 + TCL_INTEGER_SPACE]; 1470 1471 numChars = strlen(procName); 1472 ellipsis = ""; 1473 if (numChars > 50) { 1474 numChars = 50; 1475 ellipsis = "..."; 1476 } 1477 while ( (procName[numChars] & 0xC0) == 0x80 ) { 1478 /* 1479 * Back up truncation point so that we don't truncate 1480 * in the middle of a multi-byte character (in UTF-8) 1481 */ 1482 numChars--; 1483 ellipsis = "..."; 1484 } 1485 sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)", 1486 description, numChars, procName, ellipsis, 1487 interp->errorLine); 1488 Tcl_AddObjErrorInfo(interp, buf, -1); 1489 } 1490 return result; 1491 } 1492 } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { 1493 1494 /* 1495 * The resolver epoch has changed, but we only need to invalidate 1496 * the resolver cache. 1497 */ 1498 1499 for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; 1500 localPtr = localPtr->nextPtr) { 1501 localPtr->flags &= ~(VAR_RESOLVED); 1502 if (localPtr->resolveInfo) { 1503 if (localPtr->resolveInfo->deleteProc) { 1504 localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); 1505 } else { 1506 ckfree((char*)localPtr->resolveInfo); 1507 } 1508 localPtr->resolveInfo = NULL; 1509 } 1510 } 1511 } 1512 return TCL_OK; 1513} 1514 1515/* 1516 *---------------------------------------------------------------------- 1517 * 1518 * ProcessProcResultCode -- 1519 * 1520 * Procedure called by TclObjInterpProc to process a return code other 1521 * than TCL_OK returned by a Tcl procedure. 1522 * 1523 * Results: 1524 * Depending on the argument return code, the result returned is 1525 * another return code and the interpreter's result is set to a value 1526 * to supplement that return code. 1527 * 1528 * Side effects: 1529 * If the result returned is TCL_ERROR, traceback information about 1530 * the procedure just executed is appended to the interpreter's 1531 * "errorInfo" variable. 1532 * 1533 *---------------------------------------------------------------------- 1534 */ 1535 1536static int 1537ProcessProcResultCode(interp, procName, nameLen, returnCode) 1538 Tcl_Interp *interp; /* The interpreter in which the procedure 1539 * was called and returned returnCode. */ 1540 char *procName; /* Name of the procedure. Used for error 1541 * messages and trace information. */ 1542 int nameLen; /* Number of bytes in procedure's name. */ 1543 int returnCode; /* The unexpected result code. */ 1544{ 1545 Interp *iPtr = (Interp *) interp; 1546 char msg[100 + TCL_INTEGER_SPACE]; 1547 char *ellipsis = ""; 1548 1549 if (returnCode == TCL_OK) { 1550 return TCL_OK; 1551 } 1552 if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) { 1553 return returnCode; 1554 } 1555 if (returnCode == TCL_RETURN) { 1556 return TclUpdateReturnInfo(iPtr); 1557 } 1558 if (returnCode != TCL_ERROR) { 1559 Tcl_ResetResult(interp); 1560 Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK) 1561 ? "invoked \"break\" outside of a loop" 1562 : "invoked \"continue\" outside of a loop"), -1); 1563 } 1564 if (nameLen > 60) { 1565 nameLen = 60; 1566 ellipsis = "..."; 1567 } 1568 while ( (procName[nameLen] & 0xC0) == 0x80 ) { 1569 /* 1570 * Back up truncation point so that we don't truncate in the 1571 * middle of a multi-byte character (in UTF-8) 1572 */ 1573 nameLen--; 1574 ellipsis = "..."; 1575 } 1576 sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", nameLen, procName, 1577 ellipsis, iPtr->errorLine); 1578 Tcl_AddObjErrorInfo(interp, msg, -1); 1579 return TCL_ERROR; 1580} 1581 1582/* 1583 *---------------------------------------------------------------------- 1584 * 1585 * TclProcDeleteProc -- 1586 * 1587 * This procedure is invoked just before a command procedure is 1588 * removed from an interpreter. Its job is to release all the 1589 * resources allocated to the procedure. 1590 * 1591 * Results: 1592 * None. 1593 * 1594 * Side effects: 1595 * Memory gets freed, unless the procedure is actively being 1596 * executed. In this case the cleanup is delayed until the 1597 * last call to the current procedure completes. 1598 * 1599 *---------------------------------------------------------------------- 1600 */ 1601 1602void 1603TclProcDeleteProc(clientData) 1604 ClientData clientData; /* Procedure to be deleted. */ 1605{ 1606 Proc *procPtr = (Proc *) clientData; 1607 1608 procPtr->refCount--; 1609 if (procPtr->refCount <= 0) { 1610 TclProcCleanupProc(procPtr); 1611 } 1612} 1613 1614/* 1615 *---------------------------------------------------------------------- 1616 * 1617 * TclProcCleanupProc -- 1618 * 1619 * This procedure does all the real work of freeing up a Proc 1620 * structure. It's called only when the structure's reference 1621 * count becomes zero. 1622 * 1623 * Results: 1624 * None. 1625 * 1626 * Side effects: 1627 * Memory gets freed. 1628 * 1629 *---------------------------------------------------------------------- 1630 */ 1631 1632void 1633TclProcCleanupProc(procPtr) 1634 register Proc *procPtr; /* Procedure to be deleted. */ 1635{ 1636 register CompiledLocal *localPtr; 1637 Tcl_Obj *bodyPtr = procPtr->bodyPtr; 1638 Tcl_Obj *defPtr; 1639 Tcl_ResolvedVarInfo *resVarInfo; 1640#ifdef TCL_TIP280 1641 Tcl_HashEntry* hePtr = NULL; 1642 CmdFrame* cfPtr = NULL; 1643 Interp* iPtr = procPtr->iPtr; 1644#endif 1645 1646 if (bodyPtr != NULL) { 1647 Tcl_DecrRefCount(bodyPtr); 1648 } 1649 for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { 1650 CompiledLocal *nextPtr = localPtr->nextPtr; 1651 1652 resVarInfo = localPtr->resolveInfo; 1653 if (resVarInfo) { 1654 if (resVarInfo->deleteProc) { 1655 (*resVarInfo->deleteProc)(resVarInfo); 1656 } else { 1657 ckfree((char *) resVarInfo); 1658 } 1659 } 1660 1661 if (localPtr->defValuePtr != NULL) { 1662 defPtr = localPtr->defValuePtr; 1663 Tcl_DecrRefCount(defPtr); 1664 } 1665 ckfree((char *) localPtr); 1666 localPtr = nextPtr; 1667 } 1668 ckfree((char *) procPtr); 1669 1670#ifdef TCL_TIP280 1671 /* TIP #280. Release the location data associated with this Proc 1672 * structure, if any. The interpreter may not exist (For example for 1673 * procbody structurues created by tbcload. 1674 */ 1675 1676 if (!iPtr) return; 1677 1678 hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr); 1679 if (!hePtr) return; 1680 1681 cfPtr = (CmdFrame*) Tcl_GetHashValue (hePtr); 1682 1683 if (cfPtr->type == TCL_LOCATION_SOURCE) { 1684 Tcl_DecrRefCount (cfPtr->data.eval.path); 1685 cfPtr->data.eval.path = NULL; 1686 } 1687 ckfree ((char*) cfPtr->line); cfPtr->line = NULL; 1688 ckfree ((char*) cfPtr); 1689 Tcl_DeleteHashEntry (hePtr); 1690#endif 1691} 1692 1693/* 1694 *---------------------------------------------------------------------- 1695 * 1696 * TclUpdateReturnInfo -- 1697 * 1698 * This procedure is called when procedures return, and at other 1699 * points where the TCL_RETURN code is used. It examines fields 1700 * such as iPtr->returnCode and iPtr->errorCode and modifies 1701 * the real return status accordingly. 1702 * 1703 * Results: 1704 * The return value is the true completion code to use for 1705 * the procedure, instead of TCL_RETURN. 1706 * 1707 * Side effects: 1708 * The errorInfo and errorCode variables may get modified. 1709 * 1710 *---------------------------------------------------------------------- 1711 */ 1712 1713int 1714TclUpdateReturnInfo(iPtr) 1715 Interp *iPtr; /* Interpreter for which TCL_RETURN 1716 * exception is being processed. */ 1717{ 1718 int code; 1719 char *errorCode; 1720 Tcl_Obj *objPtr; 1721 1722 code = iPtr->returnCode; 1723 iPtr->returnCode = TCL_OK; 1724 if (code == TCL_ERROR) { 1725 errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE"); 1726 objPtr = Tcl_NewStringObj(errorCode, -1); 1727 Tcl_IncrRefCount(objPtr); 1728 Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode, 1729 NULL, objPtr, TCL_GLOBAL_ONLY); 1730 Tcl_DecrRefCount(objPtr); 1731 iPtr->flags |= ERROR_CODE_SET; 1732 if (iPtr->errorInfo != NULL) { 1733 objPtr = Tcl_NewStringObj(iPtr->errorInfo, -1); 1734 Tcl_IncrRefCount(objPtr); 1735 Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo, 1736 NULL, objPtr, TCL_GLOBAL_ONLY); 1737 Tcl_DecrRefCount(objPtr); 1738 iPtr->flags |= ERR_IN_PROGRESS; 1739 } 1740 } 1741 return code; 1742} 1743 1744/* 1745 *---------------------------------------------------------------------- 1746 * 1747 * TclGetInterpProc -- 1748 * 1749 * Returns a pointer to the TclProcInterpProc procedure; this is different 1750 * from the value obtained from the TclProcInterpProc reference on systems 1751 * like Windows where import and export versions of a procedure exported 1752 * by a DLL exist. 1753 * 1754 * Results: 1755 * Returns the internal address of the TclProcInterpProc procedure. 1756 * 1757 * Side effects: 1758 * None. 1759 * 1760 *---------------------------------------------------------------------- 1761 */ 1762 1763TclCmdProcType 1764TclGetInterpProc() 1765{ 1766 return (TclCmdProcType) TclProcInterpProc; 1767} 1768 1769/* 1770 *---------------------------------------------------------------------- 1771 * 1772 * TclGetObjInterpProc -- 1773 * 1774 * Returns a pointer to the TclObjInterpProc procedure; this is different 1775 * from the value obtained from the TclObjInterpProc reference on systems 1776 * like Windows where import and export versions of a procedure exported 1777 * by a DLL exist. 1778 * 1779 * Results: 1780 * Returns the internal address of the TclObjInterpProc procedure. 1781 * 1782 * Side effects: 1783 * None. 1784 * 1785 *---------------------------------------------------------------------- 1786 */ 1787 1788TclObjCmdProcType 1789TclGetObjInterpProc() 1790{ 1791 return (TclObjCmdProcType) TclObjInterpProc; 1792} 1793 1794/* 1795 *---------------------------------------------------------------------- 1796 * 1797 * TclNewProcBodyObj -- 1798 * 1799 * Creates a new object, of type "procbody", whose internal 1800 * representation is the given Proc struct. 1801 * The newly created object's reference count is 0. 1802 * 1803 * Results: 1804 * Returns a pointer to a newly allocated Tcl_Obj, 0 on error. 1805 * 1806 * Side effects: 1807 * The reference count in the ByteCode attached to the Proc is bumped up 1808 * by one, since the internal rep stores a pointer to it. 1809 * 1810 *---------------------------------------------------------------------- 1811 */ 1812 1813Tcl_Obj * 1814TclNewProcBodyObj(procPtr) 1815 Proc *procPtr; /* the Proc struct to store as the internal 1816 * representation. */ 1817{ 1818 Tcl_Obj *objPtr; 1819 1820 if (!procPtr) { 1821 return (Tcl_Obj *) NULL; 1822 } 1823 1824 objPtr = Tcl_NewStringObj("", 0); 1825 1826 if (objPtr) { 1827 objPtr->typePtr = &tclProcBodyType; 1828 objPtr->internalRep.otherValuePtr = (VOID *) procPtr; 1829 1830 procPtr->refCount++; 1831 } 1832 1833 return objPtr; 1834} 1835 1836/* 1837 *---------------------------------------------------------------------- 1838 * 1839 * ProcBodyDup -- 1840 * 1841 * Tcl_ObjType's Dup function for the proc body object. 1842 * Bumps the reference count on the Proc stored in the internal 1843 * representation. 1844 * 1845 * Results: 1846 * None. 1847 * 1848 * Side effects: 1849 * Sets up the object in dupPtr to be a duplicate of the one in srcPtr. 1850 * 1851 *---------------------------------------------------------------------- 1852 */ 1853 1854static void ProcBodyDup(srcPtr, dupPtr) 1855 Tcl_Obj *srcPtr; /* object to copy */ 1856 Tcl_Obj *dupPtr; /* target object for the duplication */ 1857{ 1858 Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr; 1859 1860 dupPtr->typePtr = &tclProcBodyType; 1861 dupPtr->internalRep.otherValuePtr = (VOID *) procPtr; 1862 procPtr->refCount++; 1863} 1864 1865/* 1866 *---------------------------------------------------------------------- 1867 * 1868 * ProcBodyFree -- 1869 * 1870 * Tcl_ObjType's Free function for the proc body object. 1871 * The reference count on its Proc struct is decreased by 1; if the count 1872 * reaches 0, the proc is freed. 1873 * 1874 * Results: 1875 * None. 1876 * 1877 * Side effects: 1878 * If the reference count on the Proc struct reaches 0, the struct is freed. 1879 * 1880 *---------------------------------------------------------------------- 1881 */ 1882 1883static void 1884ProcBodyFree(objPtr) 1885 Tcl_Obj *objPtr; /* the object to clean up */ 1886{ 1887 Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr; 1888 procPtr->refCount--; 1889 if (procPtr->refCount <= 0) { 1890 TclProcCleanupProc(procPtr); 1891 } 1892} 1893 1894/* 1895 *---------------------------------------------------------------------- 1896 * 1897 * ProcBodySetFromAny -- 1898 * 1899 * Tcl_ObjType's SetFromAny function for the proc body object. 1900 * Calls panic. 1901 * 1902 * Results: 1903 * Theoretically returns a TCL result code. 1904 * 1905 * Side effects: 1906 * Calls panic, since we can't set the value of the object from a string 1907 * representation (or any other internal ones). 1908 * 1909 *---------------------------------------------------------------------- 1910 */ 1911 1912static int 1913ProcBodySetFromAny(interp, objPtr) 1914 Tcl_Interp *interp; /* current interpreter */ 1915 Tcl_Obj *objPtr; /* object pointer */ 1916{ 1917 panic("called ProcBodySetFromAny"); 1918 1919 /* 1920 * this to keep compilers happy. 1921 */ 1922 1923 return TCL_OK; 1924} 1925 1926/* 1927 *---------------------------------------------------------------------- 1928 * 1929 * ProcBodyUpdateString -- 1930 * 1931 * Tcl_ObjType's UpdateString function for the proc body object. 1932 * Calls panic. 1933 * 1934 * Results: 1935 * None. 1936 * 1937 * Side effects: 1938 * Calls panic, since we this type has no string representation. 1939 * 1940 *---------------------------------------------------------------------- 1941 */ 1942 1943static void 1944ProcBodyUpdateString(objPtr) 1945 Tcl_Obj *objPtr; /* the object to update */ 1946{ 1947 panic("called ProcBodyUpdateString"); 1948} 1949 1950 1951/* 1952 *---------------------------------------------------------------------- 1953 * 1954 * TclCompileNoOp -- 1955 * 1956 * Procedure called to compile noOp's 1957 * 1958 * Results: 1959 * The return value is TCL_OK, indicating successful compilation. 1960 * 1961 * Side effects: 1962 * Instructions are added to envPtr to execute a noOp at runtime. 1963 * 1964 *---------------------------------------------------------------------- 1965 */ 1966 1967static int 1968TclCompileNoOp(interp, parsePtr, envPtr) 1969 Tcl_Interp *interp; /* Used for error reporting. */ 1970 Tcl_Parse *parsePtr; /* Points to a parse structure for the 1971 * command created by Tcl_ParseCommand. */ 1972 CompileEnv *envPtr; /* Holds resulting instructions. */ 1973{ 1974 Tcl_Token *tokenPtr; 1975 int i, code; 1976 int savedStackDepth = envPtr->currStackDepth; 1977 1978 tokenPtr = parsePtr->tokenPtr; 1979 for(i = 1; i < parsePtr->numWords; i++) { 1980 tokenPtr = tokenPtr + tokenPtr->numComponents + 1; 1981 envPtr->currStackDepth = savedStackDepth; 1982 1983 if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { 1984 code = TclCompileTokens(interp, tokenPtr+1, 1985 tokenPtr->numComponents, envPtr); 1986 if (code != TCL_OK) { 1987 return code; 1988 } 1989 TclEmitOpcode(INST_POP, envPtr); 1990 } 1991 } 1992 envPtr->currStackDepth = savedStackDepth; 1993 TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); 1994 return TCL_OK; 1995} 1996 1997/* 1998 * Local Variables: 1999 * mode: c 2000 * c-basic-offset: 4 2001 * fill-column: 78 2002 * End: 2003 */ 2004 2005