1/* 2 * tclProc.c -- 3 * 4 * This file contains routines that implement Tcl procedures, including 5 * 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) 2004-2006 Miguel Sofer 10 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> 11 * 12 * See the file "license.terms" for information on usage and redistribution of 13 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 14 * 15 * RCS: @(#) $Id: tclProc.c,v 1.139.2.7 2010/08/15 16:16:07 dkf Exp $ 16 */ 17 18#include "tclInt.h" 19#include "tclCompile.h" 20 21/* 22 * Prototypes for static functions in this file 23 */ 24 25static void DupLambdaInternalRep(Tcl_Obj *objPtr, 26 Tcl_Obj *copyPtr); 27static void FreeLambdaInternalRep(Tcl_Obj *objPtr); 28static int InitArgsAndLocals(Tcl_Interp *interp, 29 Tcl_Obj *procNameObj, int skip); 30static void InitResolvedLocals(Tcl_Interp *interp, 31 ByteCode *codePtr, Var *defPtr, 32 Namespace *nsPtr); 33static void InitLocalCache(Proc *procPtr); 34static int PushProcCallFrame(ClientData clientData, 35 register Tcl_Interp *interp, int objc, 36 Tcl_Obj *CONST objv[], int isLambda); 37static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); 38static void ProcBodyFree(Tcl_Obj *objPtr); 39static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); 40static void MakeProcError(Tcl_Interp *interp, 41 Tcl_Obj *procNameObj); 42static void MakeLambdaError(Tcl_Interp *interp, 43 Tcl_Obj *procNameObj); 44static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); 45static int ProcCompileProc(Tcl_Interp *interp, Proc *procPtr, 46 Tcl_Obj *bodyPtr, Namespace *nsPtr, 47 CONST char *description, CONST char *procName, 48 Proc **procPtrPtr); 49 50/* 51 * The ProcBodyObjType type 52 */ 53 54Tcl_ObjType tclProcBodyType = { 55 "procbody", /* name for this type */ 56 ProcBodyFree, /* FreeInternalRep function */ 57 ProcBodyDup, /* DupInternalRep function */ 58 NULL, /* UpdateString function; Tcl_GetString and 59 * Tcl_GetStringFromObj should panic 60 * instead. */ 61 NULL /* SetFromAny function; Tcl_ConvertToType 62 * should panic instead. */ 63}; 64 65/* 66 * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field, 67 * encoding the type of level reference in ptr1 and the actual parsed out 68 * offset in ptr2. 69 * 70 * Uses the default behaviour throughout, and never disposes of the string 71 * rep; it's just a cache type. 72 */ 73 74static Tcl_ObjType levelReferenceType = { 75 "levelReference", 76 NULL, NULL, NULL, NULL 77}; 78 79/* 80 * The type of lambdas. Note that every lambda will *always* have a string 81 * representation. 82 * 83 * Internally, ptr1 is a pointer to a Proc instance that is not bound to a 84 * command name, and ptr2 is a pointer to the namespace that the Proc instance 85 * will execute within. 86 */ 87 88static Tcl_ObjType lambdaType = { 89 "lambdaExpr", /* name */ 90 FreeLambdaInternalRep, /* freeIntRepProc */ 91 DupLambdaInternalRep, /* dupIntRepProc */ 92 NULL, /* updateStringProc */ 93 SetLambdaFromAny /* setFromAnyProc */ 94}; 95 96/* 97 *---------------------------------------------------------------------- 98 * 99 * Tcl_ProcObjCmd -- 100 * 101 * This object-based function is invoked to process the "proc" Tcl 102 * command. See the user documentation for details on what it does. 103 * 104 * Results: 105 * A standard Tcl object result value. 106 * 107 * Side effects: 108 * A new procedure gets created. 109 * 110 *---------------------------------------------------------------------- 111 */ 112 113 /* ARGSUSED */ 114int 115Tcl_ProcObjCmd( 116 ClientData dummy, /* Not used. */ 117 Tcl_Interp *interp, /* Current interpreter. */ 118 int objc, /* Number of arguments. */ 119 Tcl_Obj *CONST objv[]) /* Argument objects. */ 120{ 121 register Interp *iPtr = (Interp *) interp; 122 Proc *procPtr; 123 char *fullName; 124 CONST char *procName, *procArgs, *procBody; 125 Namespace *nsPtr, *altNsPtr, *cxtNsPtr; 126 Tcl_Command cmd; 127 Tcl_DString ds; 128 129 if (objc != 4) { 130 Tcl_WrongNumArgs(interp, 1, objv, "name args body"); 131 return TCL_ERROR; 132 } 133 134 /* 135 * Determine the namespace where the procedure should reside. Unless the 136 * command name includes namespace qualifiers, this will be the current 137 * namespace. 138 */ 139 140 fullName = TclGetString(objv[1]); 141 TclGetNamespaceForQualName(interp, fullName, NULL, 0, 142 &nsPtr, &altNsPtr, &cxtNsPtr, &procName); 143 144 if (nsPtr == NULL) { 145 Tcl_AppendResult(interp, "can't create procedure \"", fullName, 146 "\": unknown namespace", NULL); 147 return TCL_ERROR; 148 } 149 if (procName == NULL) { 150 Tcl_AppendResult(interp, "can't create procedure \"", fullName, 151 "\": bad procedure name", NULL); 152 return TCL_ERROR; 153 } 154 if ((nsPtr != iPtr->globalNsPtr) 155 && (procName != NULL) && (procName[0] == ':')) { 156 Tcl_AppendResult(interp, "can't create procedure \"", procName, 157 "\" in non-global namespace with name starting with \":\"", 158 NULL); 159 return TCL_ERROR; 160 } 161 162 /* 163 * Create the data structure to represent the procedure. 164 */ 165 166 if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], 167 &procPtr) != TCL_OK) { 168 Tcl_AddErrorInfo(interp, "\n (creating proc \""); 169 Tcl_AddErrorInfo(interp, procName); 170 Tcl_AddErrorInfo(interp, "\")"); 171 return TCL_ERROR; 172 } 173 174 /* 175 * Now create a command for the procedure. This will initially be in the 176 * current namespace unless the procedure's name included namespace 177 * qualifiers. To create the new command in the right namespace, we 178 * generate a fully qualified name for it. 179 */ 180 181 Tcl_DStringInit(&ds); 182 if (nsPtr != iPtr->globalNsPtr) { 183 Tcl_DStringAppend(&ds, nsPtr->fullName, -1); 184 Tcl_DStringAppend(&ds, "::", 2); 185 } 186 Tcl_DStringAppend(&ds, procName, -1); 187 188 cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), 189 TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); 190 191 Tcl_DStringFree(&ds); 192 193 /* 194 * Now initialize the new procedure's cmdPtr field. This will be used 195 * later when the procedure is called to determine what namespace the 196 * procedure will run in. This will be different than the current 197 * namespace if the proc was renamed into a different namespace. 198 */ 199 200 procPtr->cmdPtr = (Command *) cmd; 201 202 /* 203 * TIP #280: Remember the line the procedure body is starting on. In a 204 * bytecode context we ask the engine to provide us with the necessary 205 * information. This is for the initialization of the byte code compiler 206 * when the body is used for the first time. 207 * 208 * This code is nearly identical to the #280 code in SetLambdaFromAny, see 209 * this file. The differences are the different index of the body in the 210 * line array of the context, and the lamdba code requires some special 211 * processing. Find a way to factor the common elements into a single 212 * function. 213 */ 214 215 if (iPtr->cmdFramePtr) { 216 CmdFrame *contextPtr; 217 218 contextPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); 219 *contextPtr = *iPtr->cmdFramePtr; 220 221 if (contextPtr->type == TCL_LOCATION_BC) { 222 /* 223 * Retrieve source information from the bytecode, if possible. If 224 * the information is retrieved successfully, context.type will be 225 * TCL_LOCATION_SOURCE and the reference held by 226 * context.data.eval.path will be counted. 227 */ 228 229 TclGetSrcInfoForPc(contextPtr); 230 } else if (contextPtr->type == TCL_LOCATION_SOURCE) { 231 /* 232 * The copy into 'context' up above has created another reference 233 * to 'context.data.eval.path'; account for it. 234 */ 235 236 Tcl_IncrRefCount(contextPtr->data.eval.path); 237 } 238 239 if (contextPtr->type == TCL_LOCATION_SOURCE) { 240 /* 241 * We can account for source location within a proc only if the 242 * proc body was not created by substitution. 243 */ 244 245 if (contextPtr->line 246 && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) { 247 int isNew; 248 Tcl_HashEntry* hePtr; 249 CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); 250 251 cfPtr->level = -1; 252 cfPtr->type = contextPtr->type; 253 cfPtr->line = (int *) ckalloc(sizeof(int)); 254 cfPtr->line[0] = contextPtr->line[3]; 255 cfPtr->nline = 1; 256 cfPtr->framePtr = NULL; 257 cfPtr->nextPtr = NULL; 258 259 cfPtr->data.eval.path = contextPtr->data.eval.path; 260 Tcl_IncrRefCount(cfPtr->data.eval.path); 261 262 cfPtr->cmd.str.cmd = NULL; 263 cfPtr->cmd.str.len = 0; 264 265 hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, &isNew); 266 if (!isNew) { 267 /* 268 * Get the old command frame and release it. See also 269 * TclProcCleanupProc in this file. Currently it seems as 270 * if only the procbodytest::proc command of the testsuite 271 * is able to trigger this situation. 272 */ 273 274 CmdFrame* cfOldPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); 275 276 if (cfOldPtr->type == TCL_LOCATION_SOURCE) { 277 Tcl_DecrRefCount(cfOldPtr->data.eval.path); 278 cfOldPtr->data.eval.path = NULL; 279 } 280 ckfree((char *) cfOldPtr->line); 281 cfOldPtr->line = NULL; 282 ckfree((char *) cfOldPtr); 283 } 284 Tcl_SetHashValue(hePtr, cfPtr); 285 } 286 287 /* 288 * 'contextPtr' is going out of scope; account for the reference that 289 * it's holding to the path name. 290 */ 291 292 Tcl_DecrRefCount(contextPtr->data.eval.path); 293 contextPtr->data.eval.path = NULL; 294 } 295 TclStackFree(interp, contextPtr); 296 } 297 298 /* 299 * Optimize for no-op procs: if the body is not precompiled (like a TclPro 300 * procbody), and the argument list is just "args" and the body is empty, 301 * define a compileProc to compile a no-op. 302 * 303 * Notes: 304 * - cannot be done for any argument list without having different 305 * compiled/not-compiled behaviour in the "wrong argument #" case, or 306 * making this code much more complicated. In any case, it doesn't 307 * seem to make a lot of sense to verify the number of arguments we 308 * are about to ignore ... 309 * - could be enhanced to handle also non-empty bodies that contain only 310 * comments; however, parsing the body will slow down the compilation 311 * of all procs whose argument list is just _args_ 312 */ 313 314 if (objv[3]->typePtr == &tclProcBodyType) { 315 goto done; 316 } 317 318 procArgs = TclGetString(objv[2]); 319 320 while (*procArgs == ' ') { 321 procArgs++; 322 } 323 324 if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { 325 procArgs +=4; 326 while(*procArgs != '\0') { 327 if (*procArgs != ' ') { 328 goto done; 329 } 330 procArgs++; 331 } 332 333 /* 334 * The argument list is just "args"; check the body 335 */ 336 337 procBody = TclGetString(objv[3]); 338 while (*procBody != '\0') { 339 if (!isspace(UCHAR(*procBody))) { 340 goto done; 341 } 342 procBody++; 343 } 344 345 /* 346 * The body is just spaces: link the compileProc 347 */ 348 349 ((Command *) cmd)->compileProc = TclCompileNoOp; 350 } 351 352 done: 353 return TCL_OK; 354} 355 356/* 357 *---------------------------------------------------------------------- 358 * 359 * TclCreateProc -- 360 * 361 * Creates the data associated with a Tcl procedure definition. This 362 * function knows how to handle two types of body objects: strings and 363 * procbody. Strings are the traditional (and common) value for bodies, 364 * procbody are values created by extensions that have loaded a 365 * previously compiled script. 366 * 367 * Results: 368 * Returns TCL_OK on success, along with a pointer to a Tcl procedure 369 * definition in procPtrPtr where the cmdPtr field is not initialised. 370 * This definition should be freed by calling TclProcCleanupProc() when 371 * it is no longer needed. Returns TCL_ERROR if anything goes wrong. 372 * 373 * Side effects: 374 * If anything goes wrong, this function returns an error message in the 375 * interpreter. 376 * 377 *---------------------------------------------------------------------- 378 */ 379 380int 381TclCreateProc( 382 Tcl_Interp *interp, /* Interpreter containing proc. */ 383 Namespace *nsPtr, /* Namespace containing this proc. */ 384 CONST char *procName, /* Unqualified name of this proc. */ 385 Tcl_Obj *argsPtr, /* Description of arguments. */ 386 Tcl_Obj *bodyPtr, /* Command body. */ 387 Proc **procPtrPtr) /* Returns: pointer to proc data. */ 388{ 389 Interp *iPtr = (Interp *) interp; 390 CONST char **argArray = NULL; 391 392 register Proc *procPtr; 393 int i, length, result, numArgs; 394 CONST char *args, *bytes, *p; 395 register CompiledLocal *localPtr = NULL; 396 Tcl_Obj *defPtr; 397 int precompiled = 0; 398 399 if (bodyPtr->typePtr == &tclProcBodyType) { 400 /* 401 * Because the body is a TclProProcBody, the actual body is already 402 * compiled, and it is not shared with anyone else, so it's OK not to 403 * unshare it (as a matter of fact, it is bad to unshare it, because 404 * there may be no source code). 405 * 406 * We don't create and initialize a Proc structure for the procedure; 407 * rather, we use what is in the body object. We increment the ref 408 * count of the Proc struct since the command (soon to be created) 409 * will be holding a reference to it. 410 */ 411 412 procPtr = bodyPtr->internalRep.otherValuePtr; 413 procPtr->iPtr = iPtr; 414 procPtr->refCount++; 415 precompiled = 1; 416 } else { 417 /* 418 * If the procedure's body object is shared because its string value 419 * is identical to, e.g., the body of another procedure, we must 420 * create a private copy for this procedure to use. Such sharing of 421 * procedure bodies is rare but can cause problems. A procedure body 422 * is compiled in a context that includes the number of "slots" 423 * allocated by the compiler for local variables. There is a local 424 * variable slot for each formal parameter (the 425 * "procPtr->numCompiledLocals = numArgs" assignment below). This 426 * means that the same code can not be shared by two procedures that 427 * have a different number of arguments, even if their bodies are 428 * identical. Note that we don't use Tcl_DuplicateObj since we would 429 * not want any bytecode internal representation. 430 */ 431 432 if (Tcl_IsShared(bodyPtr)) { 433 Tcl_Obj* sharedBodyPtr = bodyPtr; 434 435 bytes = TclGetStringFromObj(bodyPtr, &length); 436 bodyPtr = Tcl_NewStringObj(bytes, length); 437 438 /* 439 * TIP #280. 440 * Ensure that the continuation line data for the original body is 441 * not lost and applies to the new body as well. 442 */ 443 444 TclContinuationsCopy (bodyPtr, sharedBodyPtr); 445 } 446 447 /* 448 * Create and initialize a Proc structure for the procedure. We 449 * increment the ref count of the procedure's body object since there 450 * will be a reference to it in the Proc structure. 451 */ 452 453 Tcl_IncrRefCount(bodyPtr); 454 455 procPtr = (Proc *) ckalloc(sizeof(Proc)); 456 procPtr->iPtr = iPtr; 457 procPtr->refCount = 1; 458 procPtr->bodyPtr = bodyPtr; 459 procPtr->numArgs = 0; /* Actual argument count is set below. */ 460 procPtr->numCompiledLocals = 0; 461 procPtr->firstLocalPtr = NULL; 462 procPtr->lastLocalPtr = NULL; 463 } 464 465 /* 466 * Break up the argument list into argument specifiers, then process each 467 * argument specifier. If the body is precompiled, processing is limited 468 * to checking that the parsed argument is consistent with the one stored 469 * in the Proc. 470 * 471 * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. 472 */ 473 474 args = TclGetStringFromObj(argsPtr, &length); 475 result = Tcl_SplitList(interp, args, &numArgs, &argArray); 476 if (result != TCL_OK) { 477 goto procError; 478 } 479 480 if (precompiled) { 481 if (numArgs > procPtr->numArgs) { 482 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 483 "procedure \"%s\": arg list contains %d entries, " 484 "precompiled header expects %d", procName, numArgs, 485 procPtr->numArgs)); 486 goto procError; 487 } 488 localPtr = procPtr->firstLocalPtr; 489 } else { 490 procPtr->numArgs = numArgs; 491 procPtr->numCompiledLocals = numArgs; 492 } 493 494 for (i = 0; i < numArgs; i++) { 495 int fieldCount, nameLength, valueLength; 496 CONST char **fieldValues; 497 498 /* 499 * Now divide the specifier up into name and default. 500 */ 501 502 result = Tcl_SplitList(interp, argArray[i], &fieldCount, 503 &fieldValues); 504 if (result != TCL_OK) { 505 goto procError; 506 } 507 if (fieldCount > 2) { 508 ckfree((char *) fieldValues); 509 Tcl_AppendResult(interp, 510 "too many fields in argument specifier \"", 511 argArray[i], "\"", NULL); 512 goto procError; 513 } 514 if ((fieldCount == 0) || (*fieldValues[0] == 0)) { 515 ckfree((char *) fieldValues); 516 Tcl_AppendResult(interp, "argument with no name", NULL); 517 goto procError; 518 } 519 520 nameLength = strlen(fieldValues[0]); 521 if (fieldCount == 2) { 522 valueLength = strlen(fieldValues[1]); 523 } else { 524 valueLength = 0; 525 } 526 527 /* 528 * Check that the formal parameter name is a scalar. 529 */ 530 531 p = fieldValues[0]; 532 while (*p != '\0') { 533 if (*p == '(') { 534 CONST char *q = p; 535 do { 536 q++; 537 } while (*q != '\0'); 538 q--; 539 if (*q == ')') { /* We have an array element. */ 540 Tcl_AppendResult(interp, "formal parameter \"", 541 fieldValues[0], 542 "\" is an array element", NULL); 543 ckfree((char *) fieldValues); 544 goto procError; 545 } 546 } else if ((*p == ':') && (*(p+1) == ':')) { 547 Tcl_AppendResult(interp, "formal parameter \"", 548 fieldValues[0], 549 "\" is not a simple name", NULL); 550 ckfree((char *) fieldValues); 551 goto procError; 552 } 553 p++; 554 } 555 556 if (precompiled) { 557 /* 558 * Compare the parsed argument with the stored one. Note that the 559 * only flag value that makes sense at this point is VAR_ARGUMENT 560 * (its value was kept the same as pre VarReform to simplify 561 * tbcload's processing of older byetcodes). 562 * 563 * The only other flag vlaue that is important to retrieve from 564 * precompiled procs is VAR_TEMPORARY (also unchanged). It is 565 * needed later when retrieving the variable names. 566 */ 567 568 if ((localPtr->nameLength != nameLength) 569 || (strcmp(localPtr->name, fieldValues[0])) 570 || (localPtr->frameIndex != i) 571 || !(localPtr->flags & VAR_ARGUMENT) 572 || (localPtr->defValuePtr == NULL && fieldCount == 2) 573 || (localPtr->defValuePtr != NULL && fieldCount != 2)) { 574 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 575 "procedure \"%s\": formal parameter %d is " 576 "inconsistent with precompiled body", procName, i)); 577 ckfree((char *) fieldValues); 578 goto procError; 579 } 580 581 /* 582 * Compare the default value if any. 583 */ 584 585 if (localPtr->defValuePtr != NULL) { 586 int tmpLength; 587 char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, 588 &tmpLength); 589 590 if ((valueLength != tmpLength) || 591 strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { 592 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 593 "procedure \"%s\": formal parameter \"%s\" has " 594 "default value inconsistent with precompiled body", 595 procName, fieldValues[0])); 596 ckfree((char *) fieldValues); 597 goto procError; 598 } 599 } 600 if ((i == numArgs - 1) 601 && (localPtr->nameLength == 4) 602 && (localPtr->name[0] == 'a') 603 && (strcmp(localPtr->name, "args") == 0)) { 604 localPtr->flags |= VAR_IS_ARGS; 605 } 606 607 localPtr = localPtr->nextPtr; 608 } else { 609 /* 610 * Allocate an entry in the runtime procedure frame's array of 611 * local variables for the argument. 612 */ 613 614 localPtr = (CompiledLocal *) ckalloc((unsigned) 615 (sizeof(CompiledLocal) - sizeof(localPtr->name) 616 + nameLength + 1)); 617 if (procPtr->firstLocalPtr == NULL) { 618 procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; 619 } else { 620 procPtr->lastLocalPtr->nextPtr = localPtr; 621 procPtr->lastLocalPtr = localPtr; 622 } 623 localPtr->nextPtr = NULL; 624 localPtr->nameLength = nameLength; 625 localPtr->frameIndex = i; 626 localPtr->flags = VAR_ARGUMENT; 627 localPtr->resolveInfo = NULL; 628 629 if (fieldCount == 2) { 630 localPtr->defValuePtr = 631 Tcl_NewStringObj(fieldValues[1], valueLength); 632 Tcl_IncrRefCount(localPtr->defValuePtr); 633 } else { 634 localPtr->defValuePtr = NULL; 635 } 636 strcpy(localPtr->name, fieldValues[0]); 637 if ((i == numArgs - 1) 638 && (localPtr->nameLength == 4) 639 && (localPtr->name[0] == 'a') 640 && (strcmp(localPtr->name, "args") == 0)) { 641 localPtr->flags |= VAR_IS_ARGS; 642 } 643 } 644 645 ckfree((char *) fieldValues); 646 } 647 648 *procPtrPtr = procPtr; 649 ckfree((char *) argArray); 650 return TCL_OK; 651 652 procError: 653 if (precompiled) { 654 procPtr->refCount--; 655 } else { 656 Tcl_DecrRefCount(bodyPtr); 657 while (procPtr->firstLocalPtr != NULL) { 658 localPtr = procPtr->firstLocalPtr; 659 procPtr->firstLocalPtr = localPtr->nextPtr; 660 661 defPtr = localPtr->defValuePtr; 662 if (defPtr != NULL) { 663 Tcl_DecrRefCount(defPtr); 664 } 665 666 ckfree((char *) localPtr); 667 } 668 ckfree((char *) procPtr); 669 } 670 if (argArray != NULL) { 671 ckfree((char *) argArray); 672 } 673 return TCL_ERROR; 674} 675 676/* 677 *---------------------------------------------------------------------- 678 * 679 * TclGetFrame -- 680 * 681 * Given a description of a procedure frame, such as the first argument 682 * to an "uplevel" or "upvar" command, locate the call frame for the 683 * appropriate level of procedure. 684 * 685 * Results: 686 * The return value is -1 if an error occurred in finding the frame (in 687 * this case an error message is left in the interp's result). 1 is 688 * returned if string was either a number or a number preceded by "#" and 689 * it specified a valid frame. 0 is returned if string isn't one of the 690 * two things above (in this case, the lookup acts as if string were 691 * "1"). The variable pointed to by framePtrPtr is filled in with the 692 * address of the desired frame (unless an error occurs, in which case it 693 * isn't modified). 694 * 695 * Side effects: 696 * None. 697 * 698 *---------------------------------------------------------------------- 699 */ 700 701int 702TclGetFrame( 703 Tcl_Interp *interp, /* Interpreter in which to find frame. */ 704 CONST char *name, /* String describing frame. */ 705 CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if 706 * global frame indicated). */ 707{ 708 register Interp *iPtr = (Interp *) interp; 709 int curLevel, level, result; 710 CallFrame *framePtr; 711 712 /* 713 * Parse string to figure out which level number to go to. 714 */ 715 716 result = 1; 717 curLevel = iPtr->varFramePtr->level; 718 if (*name== '#') { 719 if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { 720 goto levelError; 721 } 722 } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ 723 if (Tcl_GetInt(interp, name, &level) != TCL_OK) { 724 goto levelError; 725 } 726 level = curLevel - level; 727 } else { 728 level = curLevel - 1; 729 result = 0; 730 } 731 732 /* 733 * Figure out which frame to use, and return it to the caller. 734 */ 735 736 for (framePtr = iPtr->varFramePtr; framePtr != NULL; 737 framePtr = framePtr->callerVarPtr) { 738 if (framePtr->level == level) { 739 break; 740 } 741 } 742 if (framePtr == NULL) { 743 goto levelError; 744 } 745 746 *framePtrPtr = framePtr; 747 return result; 748 749 levelError: 750 Tcl_ResetResult(interp); 751 Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); 752 return -1; 753} 754 755/* 756 *---------------------------------------------------------------------- 757 * 758 * TclObjGetFrame -- 759 * 760 * Given a description of a procedure frame, such as the first argument 761 * to an "uplevel" or "upvar" command, locate the call frame for the 762 * appropriate level of procedure. 763 * 764 * Results: 765 * The return value is -1 if an error occurred in finding the frame (in 766 * this case an error message is left in the interp's result). 1 is 767 * returned if objPtr was either a number or a number preceded by "#" and 768 * it specified a valid frame. 0 is returned if objPtr isn't one of the 769 * two things above (in this case, the lookup acts as if objPtr were 770 * "1"). The variable pointed to by framePtrPtr is filled in with the 771 * address of the desired frame (unless an error occurs, in which case it 772 * isn't modified). 773 * 774 * Side effects: 775 * None. 776 * 777 *---------------------------------------------------------------------- 778 */ 779 780int 781TclObjGetFrame( 782 Tcl_Interp *interp, /* Interpreter in which to find frame. */ 783 Tcl_Obj *objPtr, /* Object describing frame. */ 784 CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if 785 * global frame indicated). */ 786{ 787 register Interp *iPtr = (Interp *) interp; 788 int curLevel, level, result; 789 CallFrame *framePtr; 790 CONST char *name = TclGetString(objPtr); 791 792 /* 793 * Parse object to figure out which level number to go to. 794 */ 795 796 result = 1; 797 curLevel = iPtr->varFramePtr->level; 798 if (objPtr->typePtr == &levelReferenceType) { 799 if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr1)) { 800 level = curLevel - PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); 801 } else { 802 level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); 803 } 804 if (level < 0) { 805 goto levelError; 806 } 807 /* TODO: Consider skipping the typePtr checks */ 808 } else if (objPtr->typePtr == &tclIntType 809#ifndef NO_WIDE_TYPE 810 || objPtr->typePtr == &tclWideIntType 811#endif 812 ) { 813 if (TclGetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { 814 goto levelError; 815 } 816 level = curLevel - level; 817 } else if (*name == '#') { 818 if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { 819 goto levelError; 820 } 821 822 /* 823 * Cache for future reference. 824 * 825 * TODO: Use the new ptrAndLongRep intrep 826 */ 827 828 TclFreeIntRep(objPtr); 829 objPtr->typePtr = &levelReferenceType; 830 objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0; 831 objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); 832 } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ 833 if (Tcl_GetInt(interp, name, &level) != TCL_OK) { 834 return -1; 835 } 836 837 /* 838 * Cache for future reference. 839 * 840 * TODO: Use the new ptrAndLongRep intrep 841 */ 842 843 TclFreeIntRep(objPtr); 844 objPtr->typePtr = &levelReferenceType; 845 objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1; 846 objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); 847 level = curLevel - level; 848 } else { 849 /* 850 * Don't cache as the object *isn't* a level reference. 851 */ 852 853 level = curLevel - 1; 854 result = 0; 855 } 856 857 /* 858 * Figure out which frame to use, and return it to the caller. 859 */ 860 861 for (framePtr = iPtr->varFramePtr; framePtr != NULL; 862 framePtr = framePtr->callerVarPtr) { 863 if (framePtr->level == level) { 864 break; 865 } 866 } 867 if (framePtr == NULL) { 868 goto levelError; 869 } 870 *framePtrPtr = framePtr; 871 return result; 872 873 levelError: 874 Tcl_ResetResult(interp); 875 Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); 876 return -1; 877} 878 879/* 880 *---------------------------------------------------------------------- 881 * 882 * Tcl_UplevelObjCmd -- 883 * 884 * This object function is invoked to process the "uplevel" Tcl command. 885 * See the user documentation for details on what it does. 886 * 887 * Results: 888 * A standard Tcl object result value. 889 * 890 * Side effects: 891 * See the user documentation. 892 * 893 *---------------------------------------------------------------------- 894 */ 895 896 /* ARGSUSED */ 897int 898Tcl_UplevelObjCmd( 899 ClientData dummy, /* Not used. */ 900 Tcl_Interp *interp, /* Current interpreter. */ 901 int objc, /* Number of arguments. */ 902 Tcl_Obj *CONST objv[]) /* Argument objects. */ 903{ 904 register Interp *iPtr = (Interp *) interp; 905 int result; 906 CallFrame *savedVarFramePtr, *framePtr; 907 908 if (objc < 2) { 909 uplevelSyntax: 910 Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); 911 return TCL_ERROR; 912 } 913 914 /* 915 * Find the level to use for executing the command. 916 */ 917 918 result = TclObjGetFrame(interp, objv[1], &framePtr); 919 if (result == -1) { 920 return TCL_ERROR; 921 } 922 objc -= (result+1); 923 if (objc == 0) { 924 goto uplevelSyntax; 925 } 926 objv += (result+1); 927 928 /* 929 * Modify the interpreter state to execute in the given frame. 930 */ 931 932 savedVarFramePtr = iPtr->varFramePtr; 933 iPtr->varFramePtr = framePtr; 934 935 /* 936 * Execute the residual arguments as a command. 937 */ 938 939 if (objc == 1) { 940 /* 941 * TIP #280. Make argument location available to eval'd script 942 */ 943 944 CmdFrame* invoker = NULL; 945 int word = 0; 946 947 TclArgumentGet (interp, objv[0], &invoker, &word); 948 result = TclEvalObjEx(interp, objv[0], 0, invoker, word); 949 } else { 950 /* 951 * More than one argument: concatenate them together with spaces 952 * between, then evaluate the result. Tcl_EvalObjEx will delete the 953 * object when it decrements its refcount after eval'ing it. 954 */ 955 956 Tcl_Obj *objPtr; 957 958 objPtr = Tcl_ConcatObj(objc, objv); 959 result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); 960 } 961 if (result == TCL_ERROR) { 962 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 963 "\n (\"uplevel\" body line %d)", interp->errorLine)); 964 } 965 966 /* 967 * Restore the variable frame, and return. 968 */ 969 970 iPtr->varFramePtr = savedVarFramePtr; 971 return result; 972} 973 974/* 975 *---------------------------------------------------------------------- 976 * 977 * TclFindProc -- 978 * 979 * Given the name of a procedure, return a pointer to the record 980 * describing the procedure. The procedure will be looked up using the 981 * usual rules: first in the current namespace and then in the global 982 * namespace. 983 * 984 * Results: 985 * NULL is returned if the name doesn't correspond to any procedure. 986 * Otherwise, the return value is a pointer to the procedure's record. If 987 * the name is found but refers to an imported command that points to a 988 * "real" procedure defined in another namespace, a pointer to that 989 * "real" procedure's structure is returned. 990 * 991 * Side effects: 992 * None. 993 * 994 *---------------------------------------------------------------------- 995 */ 996 997Proc * 998TclFindProc( 999 Interp *iPtr, /* Interpreter in which to look. */ 1000 CONST char *procName) /* Name of desired procedure. */ 1001{ 1002 Tcl_Command cmd; 1003 Tcl_Command origCmd; 1004 Command *cmdPtr; 1005 1006 cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0); 1007 if (cmd == (Tcl_Command) NULL) { 1008 return NULL; 1009 } 1010 cmdPtr = (Command *) cmd; 1011 1012 origCmd = TclGetOriginalCommand(cmd); 1013 if (origCmd != NULL) { 1014 cmdPtr = (Command *) origCmd; 1015 } 1016 if (cmdPtr->objProc != TclObjInterpProc) { 1017 return NULL; 1018 } 1019 return (Proc *) cmdPtr->objClientData; 1020} 1021 1022/* 1023 *---------------------------------------------------------------------- 1024 * 1025 * TclIsProc -- 1026 * 1027 * Tells whether a command is a Tcl procedure or not. 1028 * 1029 * Results: 1030 * If the given command is actually a Tcl procedure, the return value is 1031 * the address of the record describing the procedure. Otherwise the 1032 * return value is 0. 1033 * 1034 * Side effects: 1035 * None. 1036 * 1037 *---------------------------------------------------------------------- 1038 */ 1039 1040Proc * 1041TclIsProc( 1042 Command *cmdPtr) /* Command to test. */ 1043{ 1044 Tcl_Command origCmd; 1045 1046 origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); 1047 if (origCmd != NULL) { 1048 cmdPtr = (Command *) origCmd; 1049 } 1050 if (cmdPtr->objProc == TclObjInterpProc) { 1051 return (Proc *) cmdPtr->objClientData; 1052 } 1053 return (Proc *) 0; 1054} 1055 1056/* 1057 *---------------------------------------------------------------------- 1058 * 1059 * InitArgsAndLocals -- 1060 * 1061 * This routine is invoked in order to initialize the arguments and other 1062 * compiled locals table for a new call frame. 1063 * 1064 * Results: 1065 * A standard Tcl result. 1066 * 1067 * Side effects: 1068 * Allocates memory on the stack for the compiled local variables, the 1069 * caller is responsible for freeing them. Initialises all variables. May 1070 * invoke various name resolvers in order to determine which variables 1071 * are being referenced at runtime. 1072 * 1073 *---------------------------------------------------------------------- 1074 */ 1075 1076static int 1077ProcWrongNumArgs( 1078 Tcl_Interp *interp, int skip) 1079{ 1080 CallFrame *framePtr = ((Interp *)interp)->varFramePtr; 1081 register Proc *procPtr = framePtr->procPtr; 1082 register Var *defPtr; 1083 int localCt = procPtr->numCompiledLocals, numArgs, i; 1084 Tcl_Obj **desiredObjs; 1085 const char *final = NULL; 1086 1087 /* 1088 * Build up desired argument list for Tcl_WrongNumArgs 1089 */ 1090 1091 numArgs = framePtr->procPtr->numArgs; 1092 desiredObjs = (Tcl_Obj **) TclStackAlloc(interp, 1093 (int) sizeof(Tcl_Obj *) * (numArgs+1)); 1094 1095 if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { 1096 desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); 1097 } else { 1098#ifdef AVOID_HACKS_FOR_ITCL 1099 desiredObjs[0] = framePtr->objv[skip-1]; 1100#else 1101 desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv); 1102#endif /* AVOID_HACKS_FOR_ITCL */ 1103 } 1104 Tcl_IncrRefCount(desiredObjs[0]); 1105 1106 defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); 1107 for (i=1 ; i<=numArgs ; i++, defPtr++) { 1108 Tcl_Obj *argObj; 1109 Tcl_Obj *namePtr = localName(framePtr, i-1); 1110 1111 if (defPtr->value.objPtr != NULL) { 1112 TclNewObj(argObj); 1113 Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL); 1114 } else if (defPtr->flags & VAR_IS_ARGS) { 1115 numArgs--; 1116 final = "..."; 1117 break; 1118 } else { 1119 argObj = namePtr; 1120 Tcl_IncrRefCount(namePtr); 1121 } 1122 desiredObjs[i] = argObj; 1123 } 1124 1125 Tcl_ResetResult(interp); 1126 Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final); 1127 1128 for (i=0 ; i<=numArgs ; i++) { 1129 Tcl_DecrRefCount(desiredObjs[i]); 1130 } 1131 TclStackFree(interp, desiredObjs); 1132 return TCL_ERROR; 1133} 1134 1135/* 1136 *---------------------------------------------------------------------- 1137 * 1138 * TclInitCompiledLocals -- 1139 * 1140 * This routine is invoked in order to initialize the compiled locals 1141 * table for a new call frame. 1142 * 1143 * DEPRECATED: functionality has been inlined elsewhere; this function 1144 * remains to insure binary compatibility with Itcl. 1145 * 1146 1147 * Results: 1148 * None. 1149 * 1150 * Side effects: 1151 * May invoke various name resolvers in order to determine which 1152 * variables are being referenced at runtime. 1153 * 1154 *---------------------------------------------------------------------- 1155 */ 1156void 1157TclInitCompiledLocals( 1158 Tcl_Interp *interp, /* Current interpreter. */ 1159 CallFrame *framePtr, /* Call frame to initialize. */ 1160 Namespace *nsPtr) /* Pointer to current namespace. */ 1161{ 1162 Var *varPtr = framePtr->compiledLocals; 1163 Tcl_Obj *bodyPtr; 1164 ByteCode *codePtr; 1165 1166 bodyPtr = framePtr->procPtr->bodyPtr; 1167 if (bodyPtr->typePtr != &tclByteCodeType) { 1168 Tcl_Panic("body object for proc attached to frame is not a byte code type"); 1169 } 1170 codePtr = bodyPtr->internalRep.otherValuePtr; 1171 1172 if (framePtr->numCompiledLocals) { 1173 if (!codePtr->localCachePtr) { 1174 InitLocalCache(framePtr->procPtr) ; 1175 } 1176 framePtr->localCachePtr = codePtr->localCachePtr; 1177 framePtr->localCachePtr->refCount++; 1178 } 1179 1180 InitResolvedLocals(interp, codePtr, varPtr, nsPtr); 1181} 1182 1183/* 1184 *---------------------------------------------------------------------- 1185 * 1186 * InitResolvedLocals -- 1187 * 1188 * This routine is invoked in order to initialize the compiled locals 1189 * table for a new call frame. 1190 * 1191 * Results: 1192 * None. 1193 * 1194 * Side effects: 1195 * May invoke various name resolvers in order to determine which 1196 * variables are being referenced at runtime. 1197 * 1198 *---------------------------------------------------------------------- 1199 */ 1200 1201static void 1202InitResolvedLocals( 1203 Tcl_Interp *interp, /* Current interpreter. */ 1204 ByteCode *codePtr, 1205 Var *varPtr, 1206 Namespace *nsPtr) /* Pointer to current namespace. */ 1207{ 1208 Interp *iPtr = (Interp *) interp; 1209 int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr); 1210 CompiledLocal *firstLocalPtr, *localPtr; 1211 int varNum; 1212 Tcl_ResolvedVarInfo *resVarInfo; 1213 1214 /* 1215 * Find the localPtr corresponding to varPtr 1216 */ 1217 1218 varNum = varPtr - iPtr->framePtr->compiledLocals; 1219 localPtr = iPtr->framePtr->procPtr->firstLocalPtr; 1220 while (varNum--) { 1221 localPtr = localPtr->nextPtr; 1222 } 1223 1224 if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) { 1225 /* 1226 * Initialize the array of local variables stored in the call frame. 1227 * Some variables may have special resolution rules. In that case, we 1228 * call their "resolver" procs to get our hands on the variable, and 1229 * we make the compiled local a link to the real variable. 1230 */ 1231 1232 doInitResolvedLocals: 1233 for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { 1234 varPtr->flags = 0; 1235 varPtr->value.objPtr = NULL; 1236 1237 /* 1238 * Now invoke the resolvers to determine the exact variables 1239 * that should be used. 1240 */ 1241 1242 resVarInfo = localPtr->resolveInfo; 1243 if (resVarInfo && resVarInfo->fetchProc) { 1244 Var *resolvedVarPtr = (Var *) 1245 (*resVarInfo->fetchProc)(interp, resVarInfo); 1246 if (resolvedVarPtr) { 1247 if (TclIsVarInHash(resolvedVarPtr)) { 1248 VarHashRefCount(resolvedVarPtr)++; 1249 } 1250 varPtr->flags = VAR_LINK; 1251 varPtr->value.linkPtr = resolvedVarPtr; 1252 } 1253 } 1254 } 1255 return; 1256 } 1257 1258 /* 1259 * This is the first run after a recompile, or else the resolver epoch 1260 * has changed: update the resolver cache. 1261 */ 1262 1263 firstLocalPtr = localPtr; 1264 for (; localPtr != NULL; localPtr = localPtr->nextPtr) { 1265 if (localPtr->resolveInfo) { 1266 if (localPtr->resolveInfo->deleteProc) { 1267 localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); 1268 } else { 1269 ckfree((char *) localPtr->resolveInfo); 1270 } 1271 localPtr->resolveInfo = NULL; 1272 } 1273 localPtr->flags &= ~VAR_RESOLVED; 1274 1275 if (haveResolvers && 1276 !(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) { 1277 ResolverScheme *resPtr = iPtr->resolverPtr; 1278 Tcl_ResolvedVarInfo *vinfo; 1279 int result; 1280 1281 if (nsPtr->compiledVarResProc) { 1282 result = (*nsPtr->compiledVarResProc)(nsPtr->interp, 1283 localPtr->name, localPtr->nameLength, 1284 (Tcl_Namespace *) nsPtr, &vinfo); 1285 } else { 1286 result = TCL_CONTINUE; 1287 } 1288 1289 while ((result == TCL_CONTINUE) && resPtr) { 1290 if (resPtr->compiledVarResProc) { 1291 result = (*resPtr->compiledVarResProc)(nsPtr->interp, 1292 localPtr->name, localPtr->nameLength, 1293 (Tcl_Namespace *) nsPtr, &vinfo); 1294 } 1295 resPtr = resPtr->nextPtr; 1296 } 1297 if (result == TCL_OK) { 1298 localPtr->resolveInfo = vinfo; 1299 localPtr->flags |= VAR_RESOLVED; 1300 } 1301 } 1302 } 1303 localPtr = firstLocalPtr; 1304 codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS; 1305 goto doInitResolvedLocals; 1306} 1307 1308void 1309TclFreeLocalCache( 1310 Tcl_Interp *interp, 1311 LocalCache *localCachePtr) 1312{ 1313 int i; 1314 Tcl_Obj **namePtrPtr = &localCachePtr->varName0; 1315 1316 for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { 1317 Tcl_Obj *objPtr = *namePtrPtr; 1318 /* 1319 * Note that this can be called with interp==NULL, on interp 1320 * deletion. In that case, the literal table and objects go away 1321 * on their own. 1322 */ 1323 if (objPtr) { 1324 if (interp) { 1325 TclReleaseLiteral(interp, objPtr); 1326 } else { 1327 Tcl_DecrRefCount(objPtr); 1328 } 1329 } 1330 } 1331 ckfree((char *) localCachePtr); 1332} 1333 1334static void 1335InitLocalCache(Proc *procPtr) 1336{ 1337 Interp *iPtr = procPtr->iPtr; 1338 ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; 1339 int localCt = procPtr->numCompiledLocals; 1340 int numArgs = procPtr->numArgs, i = 0; 1341 1342 Tcl_Obj **namePtr; 1343 Var *varPtr; 1344 LocalCache *localCachePtr; 1345 CompiledLocal *localPtr; 1346 int new; 1347 1348 /* 1349 * Cache the names and initial values of local variables; store the 1350 * cache in both the framePtr for this execution and in the codePtr 1351 * for future calls. 1352 */ 1353 1354 localCachePtr = (LocalCache *) ckalloc(sizeof(LocalCache) 1355 + (localCt-1)*sizeof(Tcl_Obj *) 1356 + numArgs*sizeof(Var)); 1357 1358 namePtr = &localCachePtr->varName0; 1359 varPtr = (Var *) (namePtr + localCt); 1360 localPtr = procPtr->firstLocalPtr; 1361 while (localPtr) { 1362 if (TclIsVarTemporary(localPtr)) { 1363 *namePtr = NULL; 1364 } else { 1365 *namePtr = TclCreateLiteral(iPtr, localPtr->name, 1366 localPtr->nameLength, /* hash */ (unsigned int) -1, 1367 &new, /* nsPtr */ NULL, 0, NULL); 1368 Tcl_IncrRefCount(*namePtr); 1369 } 1370 1371 if (i < numArgs) { 1372 varPtr->flags = (localPtr->flags & VAR_IS_ARGS); 1373 varPtr->value.objPtr = localPtr->defValuePtr; 1374 varPtr++; 1375 i++; 1376 } 1377 namePtr++; 1378 localPtr=localPtr->nextPtr; 1379 } 1380 codePtr->localCachePtr = localCachePtr; 1381 localCachePtr->refCount = 1; 1382 localCachePtr->numVars = localCt; 1383} 1384 1385static int 1386InitArgsAndLocals( 1387 register Tcl_Interp *interp,/* Interpreter in which procedure was 1388 * invoked. */ 1389 Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ 1390 int skip) /* Number of initial arguments to be skipped, 1391 * i.e., words in the "command name". */ 1392{ 1393 CallFrame *framePtr = ((Interp *)interp)->varFramePtr; 1394 register Proc *procPtr = framePtr->procPtr; 1395 ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; 1396 register Var *varPtr, *defPtr; 1397 int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; 1398 Tcl_Obj *const *argObjs; 1399 1400 /* 1401 * Make sure that the local cache of variable names and initial values has 1402 * been initialised properly . 1403 */ 1404 1405 if (localCt) { 1406 if (!codePtr->localCachePtr) { 1407 InitLocalCache(procPtr) ; 1408 } 1409 framePtr->localCachePtr = codePtr->localCachePtr; 1410 framePtr->localCachePtr->refCount++; 1411 defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); 1412 } else { 1413 defPtr = NULL; 1414 } 1415 1416 /* 1417 * Create the "compiledLocals" array. Make sure it is large enough to hold 1418 * all the procedure's compiled local variables, including its formal 1419 * parameters. 1420 */ 1421 1422 varPtr = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var))); 1423 framePtr->compiledLocals = varPtr; 1424 framePtr->numCompiledLocals = localCt; 1425 1426 /* 1427 * Match and assign the call's actual parameters to the procedure's formal 1428 * arguments. The formal arguments are described by the first numArgs 1429 * entries in both the Proc structure's local variable list and the call 1430 * frame's local variable array. 1431 */ 1432 1433 numArgs = procPtr->numArgs; 1434 argCt = framePtr->objc - skip; /* Set it to the number of args to the 1435 * procedure. */ 1436 argObjs = framePtr->objv + skip; 1437 if (numArgs == 0) { 1438 if (argCt) { 1439 goto incorrectArgs; 1440 } else { 1441 goto correctArgs; 1442 } 1443 } 1444 imax = ((argCt < numArgs-1) ? argCt : numArgs-1); 1445 for (i = 0; i < imax; i++, varPtr++, defPtr++) { 1446 /* 1447 * "Normal" arguments; last formal is special, depends on it being 1448 * 'args'. 1449 */ 1450 1451 Tcl_Obj *objPtr = argObjs[i]; 1452 1453 varPtr->flags = 0; 1454 varPtr->value.objPtr = objPtr; 1455 Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ 1456 } 1457 for (; i < numArgs-1; i++, varPtr++, defPtr++) { 1458 /* 1459 * This loop is entered if argCt < (numArgs-1). Set default values; 1460 * last formal is special. 1461 */ 1462 1463 Tcl_Obj *objPtr = defPtr->value.objPtr; 1464 1465 if (objPtr) { 1466 varPtr->flags = 0; 1467 varPtr->value.objPtr = objPtr; 1468 Tcl_IncrRefCount(objPtr); /* Local var reference. */ 1469 } else { 1470 goto incorrectArgs; 1471 } 1472 } 1473 1474 /* 1475 * When we get here, the last formal argument remains to be defined: 1476 * defPtr and varPtr point to the last argument to be initialized. 1477 */ 1478 1479 1480 varPtr->flags = 0; 1481 if (defPtr->flags & VAR_IS_ARGS) { 1482 Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i); 1483 1484 varPtr->value.objPtr = listPtr; 1485 Tcl_IncrRefCount(listPtr); /* Local var is a reference. */ 1486 } else if (argCt == numArgs) { 1487 Tcl_Obj *objPtr = argObjs[i]; 1488 1489 varPtr->value.objPtr = objPtr; 1490 Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ 1491 } else if ((argCt < numArgs) && (defPtr->value.objPtr != NULL)) { 1492 Tcl_Obj *objPtr = defPtr->value.objPtr; 1493 1494 varPtr->value.objPtr = objPtr; 1495 Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ 1496 } else { 1497 goto incorrectArgs; 1498 } 1499 varPtr++; 1500 1501 /* 1502 * Initialise and resolve the remaining compiledLocals. In the absence of 1503 * resolvers, they are undefined local vars: (flags=0, value=NULL). 1504 */ 1505 1506 correctArgs: 1507 if (numArgs < localCt) { 1508 if (!framePtr->nsPtr->compiledVarResProc && !((Interp *)interp)->resolverPtr) { 1509 memset(varPtr, 0, (localCt - numArgs)*sizeof(Var)); 1510 } else { 1511 InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr); 1512 } 1513 } 1514 1515 return TCL_OK; 1516 1517 1518 incorrectArgs: 1519 /* 1520 * Initialise all compiled locals to avoid problems at DeleteLocalVars. 1521 */ 1522 1523 memset(varPtr, 0, ((framePtr->compiledLocals + localCt)-varPtr)*sizeof(Var)); 1524 return ProcWrongNumArgs(interp, skip); 1525} 1526 1527/* 1528 *---------------------------------------------------------------------- 1529 * 1530 * PushProcCallFrame -- 1531 * 1532 * Compiles a proc body if necessary, then pushes a CallFrame suitable 1533 * for executing it. 1534 * 1535 * Results: 1536 * A standard Tcl object result value. 1537 * 1538 * Side effects: 1539 * The proc's body may be recompiled. A CallFrame is pushed, it will have 1540 * to be popped by the caller. 1541 * 1542 *---------------------------------------------------------------------- 1543 */ 1544 1545static int 1546PushProcCallFrame( 1547 ClientData clientData, /* Record describing procedure to be 1548 * interpreted. */ 1549 register Tcl_Interp *interp,/* Interpreter in which procedure was 1550 * invoked. */ 1551 int objc, /* Count of number of arguments to this 1552 * procedure. */ 1553 Tcl_Obj *CONST objv[], /* Argument value objects. */ 1554 int isLambda) /* 1 if this is a call by ApplyObjCmd: it 1555 * needs special rules for error msg */ 1556{ 1557 Proc *procPtr = (Proc *) clientData; 1558 Namespace *nsPtr = procPtr->cmdPtr->nsPtr; 1559 CallFrame *framePtr, **framePtrPtr; 1560 int result; 1561 ByteCode *codePtr; 1562 1563 /* 1564 * If necessary (i.e. if we haven't got a suitable compilation already 1565 * cached) compile the procedure's body. The compiler will allocate frame 1566 * slots for the procedure's non-argument local variables. Note that 1567 * compiling the body might increase procPtr->numCompiledLocals if new 1568 * local variables are found while compiling. 1569 */ 1570 1571 if (procPtr->bodyPtr->typePtr == &tclByteCodeType) { 1572 Interp *iPtr = (Interp *) interp; 1573 1574 /* 1575 * When we've got bytecode, this is the check for validity. That is, 1576 * the bytecode must be for the right interpreter (no cross-leaks!), 1577 * the code must be from the current epoch (so subcommand compilation 1578 * is up-to-date), the namespace must match (so variable handling 1579 * is right) and the resolverEpoch must match (so that new shadowed 1580 * commands and/or resolver changes are considered). 1581 */ 1582 1583 codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; 1584 if (((Interp *) *codePtr->interpHandle != iPtr) 1585 || (codePtr->compileEpoch != iPtr->compileEpoch) 1586 || (codePtr->nsPtr != nsPtr) 1587 || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { 1588 goto doCompilation; 1589 } 1590 } else { 1591 doCompilation: 1592 result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, 1593 (isLambda ? "body of lambda term" : "body of proc"), 1594 TclGetString(objv[isLambda]), &procPtr); 1595 if (result != TCL_OK) { 1596 return result; 1597 } 1598 } 1599 1600 /* 1601 * Set up and push a new call frame for the new procedure invocation. 1602 * This call frame will execute in the proc's namespace, which might be 1603 * different than the current namespace. The proc's namespace is that of 1604 * its command, which can change if the command is renamed from one 1605 * namespace to another. 1606 */ 1607 1608 framePtrPtr = &framePtr; 1609 result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, 1610 (Tcl_Namespace *) nsPtr, 1611 (isLambda? (FRAME_IS_PROC|FRAME_IS_LAMBDA) : FRAME_IS_PROC)); 1612 if (result != TCL_OK) { 1613 return result; 1614 } 1615 1616 framePtr->objc = objc; 1617 framePtr->objv = objv; 1618 framePtr->procPtr = procPtr; 1619 1620 return TCL_OK; 1621} 1622 1623/* 1624 *---------------------------------------------------------------------- 1625 * 1626 * TclObjInterpProc -- 1627 * 1628 * When a Tcl procedure gets invoked during bytecode evaluation, this 1629 * object-based routine gets invoked to interpret the procedure. 1630 * 1631 * Results: 1632 * A standard Tcl object result value. 1633 * 1634 * Side effects: 1635 * Depends on the commands in the procedure. 1636 * 1637 *---------------------------------------------------------------------- 1638 */ 1639 1640int 1641TclObjInterpProc( 1642 ClientData clientData, /* Record describing procedure to be 1643 * interpreted. */ 1644 register Tcl_Interp *interp,/* Interpreter in which procedure was 1645 * invoked. */ 1646 int objc, /* Count of number of arguments to this 1647 * procedure. */ 1648 Tcl_Obj *CONST objv[]) /* Argument value objects. */ 1649{ 1650 int result; 1651 1652 result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); 1653 if (result == TCL_OK) { 1654 return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError); 1655 } else { 1656 return TCL_ERROR; 1657 } 1658} 1659 1660/* 1661 *---------------------------------------------------------------------- 1662 * 1663 * TclObjInterpProcCore -- 1664 * 1665 * When a Tcl procedure, lambda term or anything else that works like a 1666 * procedure gets invoked during bytecode evaluation, this object-based 1667 * routine gets invoked to interpret the body. 1668 * 1669 * Results: 1670 * A standard Tcl object result value. 1671 * 1672 * Side effects: 1673 * Nearly anything; depends on the commands in the procedure body. 1674 * 1675 *---------------------------------------------------------------------- 1676 */ 1677 1678int 1679TclObjInterpProcCore( 1680 register Tcl_Interp *interp,/* Interpreter in which procedure was 1681 * invoked. */ 1682 Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ 1683 int skip, /* Number of initial arguments to be skipped, 1684 * i.e., words in the "command name". */ 1685 ProcErrorProc errorProc) /* How to convert results from the script into 1686 * results of the overall procedure. */ 1687{ 1688 Interp *iPtr = (Interp *) interp; 1689 register Proc *procPtr = iPtr->varFramePtr->procPtr; 1690 int result; 1691 CallFrame *freePtr; 1692 1693 result = InitArgsAndLocals(interp, procNameObj, skip); 1694 if (result != TCL_OK) { 1695 goto procDone; 1696 } 1697 1698#if defined(TCL_COMPILE_DEBUG) 1699 if (tclTraceExec >= 1) { 1700 register CallFrame *framePtr = iPtr->varFramePtr; 1701 register int i; 1702 1703 if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { 1704 fprintf(stdout, "Calling lambda "); 1705 } else { 1706 fprintf(stdout, "Calling proc "); 1707 } 1708 for (i = 0; i < framePtr->objc; i++) { 1709 TclPrintObject(stdout, framePtr->objv[i], 15); 1710 fprintf(stdout, " "); 1711 } 1712 fprintf(stdout, "\n"); 1713 fflush(stdout); 1714 } 1715#endif /*TCL_COMPILE_DEBUG*/ 1716 1717 if (TCL_DTRACE_PROC_ARGS_ENABLED()) { 1718 char *a[10]; 1719 int i = 0; 1720 int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; 1721 1722 while (i < 10) { 1723 a[i] = (l < iPtr->varFramePtr->objc ? 1724 TclGetString(iPtr->varFramePtr->objv[l]) : NULL); i++; l++; 1725 } 1726 TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], 1727 a[8], a[9]); 1728 } 1729 if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { 1730 Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); 1731 char *a[4]; int i[2]; 1732 1733 TclDTraceInfo(info, a, i); 1734 TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1]); 1735 TclDecrRefCount(info); 1736 } 1737 1738 /* 1739 * Invoke the commands in the procedure's body. 1740 */ 1741 1742 procPtr->refCount++; 1743 iPtr->numLevels++; 1744 1745 if (TclInterpReady(interp) == TCL_ERROR) { 1746 result = TCL_ERROR; 1747 } else { 1748 register ByteCode *codePtr = 1749 procPtr->bodyPtr->internalRep.otherValuePtr; 1750 1751 codePtr->refCount++; 1752 if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { 1753 int l; 1754 1755 l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1; 1756 TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj), 1757 iPtr->varFramePtr->objc - l, 1758 (Tcl_Obj **)(iPtr->varFramePtr->objv + l)); 1759 } 1760 result = TclExecuteByteCode(interp, codePtr); 1761 if (TCL_DTRACE_PROC_RETURN_ENABLED()) { 1762 TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result); 1763 } 1764 codePtr->refCount--; 1765 if (codePtr->refCount <= 0) { 1766 TclCleanupByteCode(codePtr); 1767 } 1768 } 1769 1770 iPtr->numLevels--; 1771 procPtr->refCount--; 1772 if (procPtr->refCount <= 0) { 1773 TclProcCleanupProc(procPtr); 1774 } 1775 1776 /* 1777 * Process the result code. 1778 */ 1779 1780 switch (result) { 1781 case TCL_RETURN: 1782 /* 1783 * If it is a 'return', do the TIP#90 processing now. 1784 */ 1785 1786 result = TclUpdateReturnInfo((Interp *) interp); 1787 break; 1788 1789 case TCL_CONTINUE: 1790 case TCL_BREAK: 1791 /* 1792 * It's an error to get to this point from a 'break' or 'continue', so 1793 * transform to an error now. 1794 */ 1795 1796 Tcl_ResetResult(interp); 1797 Tcl_AppendResult(interp, "invoked \"", 1798 ((result == TCL_BREAK) ? "break" : "continue"), 1799 "\" outside of a loop", NULL); 1800 result = TCL_ERROR; 1801 1802 /* 1803 * Fall through to the TCL_ERROR handling code. 1804 */ 1805 1806 case TCL_ERROR: 1807 /* 1808 * Now it _must_ be an error, so we need to log it as such. This means 1809 * filling out the error trace. Luckily, we just hand this off to the 1810 * function handed to us as an argument. 1811 */ 1812 1813 (*errorProc)(interp, procNameObj); 1814 1815 default: 1816 /* 1817 * Process other results (OK and non-standard) by doing nothing 1818 * special, skipping directly to the code afterwards that cleans up 1819 * associated memory. 1820 * 1821 * Non-standard results are processed by passing them through quickly. 1822 * This means they all work as exceptions, unwinding the stack quickly 1823 * and neatly. Who knows how well they are handled by third-party code 1824 * though... 1825 */ 1826 1827 (void) 0; /* do nothing */ 1828 } 1829 1830 if (TCL_DTRACE_PROC_RESULT_ENABLED()) { 1831 Tcl_Obj *r; 1832 1833 r = Tcl_GetObjResult(interp); 1834 TCL_DTRACE_PROC_RESULT(TclGetString(procNameObj), result, 1835 TclGetString(r), r); 1836 } 1837 1838 procDone: 1839 /* 1840 * Free the stack-allocated compiled locals and CallFrame. It is important 1841 * to pop the call frame without freeing it first: the compiledLocals 1842 * cannot be freed before the frame is popped, as the local variables must 1843 * be deleted. But the compiledLocals must be freed first, as they were 1844 * allocated later on the stack. 1845 */ 1846 1847 freePtr = iPtr->framePtr; 1848 Tcl_PopCallFrame(interp); /* Pop but do not free. */ 1849 TclStackFree(interp, freePtr->compiledLocals); 1850 /* Free compiledLocals. */ 1851 TclStackFree(interp, freePtr); /* Free CallFrame. */ 1852 return result; 1853} 1854 1855/* 1856 *---------------------------------------------------------------------- 1857 * 1858 * TclProcCompileProc -- 1859 * 1860 * Called just before a procedure is executed to compile the body to byte 1861 * codes. If the type of the body is not "byte code" or if the compile 1862 * conditions have changed (namespace context, epoch counters, etc.) then 1863 * the body is recompiled. Otherwise, this function does nothing. 1864 * 1865 * Results: 1866 * None. 1867 * 1868 * Side effects: 1869 * May change the internal representation of the body object to compiled 1870 * code. 1871 * 1872 *---------------------------------------------------------------------- 1873 */ 1874 1875int 1876TclProcCompileProc( 1877 Tcl_Interp *interp, /* Interpreter containing procedure. */ 1878 Proc *procPtr, /* Data associated with procedure. */ 1879 Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, 1880 * but could be any code fragment compiled in 1881 * the context of this procedure.) */ 1882 Namespace *nsPtr, /* Namespace containing procedure. */ 1883 CONST char *description, /* string describing this body of code. */ 1884 CONST char *procName) /* Name of this procedure. */ 1885{ 1886 return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, 1887 procName, NULL); 1888} 1889 1890static int 1891ProcCompileProc( 1892 Tcl_Interp *interp, /* Interpreter containing procedure. */ 1893 Proc *procPtr, /* Data associated with procedure. */ 1894 Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, 1895 * but could be any code fragment compiled in 1896 * the context of this procedure.) */ 1897 Namespace *nsPtr, /* Namespace containing procedure. */ 1898 CONST char *description, /* string describing this body of code. */ 1899 CONST char *procName, /* Name of this procedure. */ 1900 Proc **procPtrPtr) /* Points to storage where a replacement 1901 * (Proc *) value may be written. */ 1902{ 1903 Interp *iPtr = (Interp *) interp; 1904 int i; 1905 Tcl_CallFrame *framePtr; 1906 ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr; 1907 CompiledLocal *localPtr; 1908 1909 /* 1910 * If necessary, compile the procedure's body. The compiler will allocate 1911 * frame slots for the procedure's non-argument local variables. If the 1912 * ByteCode already exists, make sure it hasn't been invalidated by 1913 * someone redefining a core command (this might make the compiled code 1914 * wrong). Also, if the code was compiled in/for a different interpreter, 1915 * we recompile it. Note that compiling the body might increase 1916 * procPtr->numCompiledLocals if new local variables are found while 1917 * compiling. 1918 * 1919 * Precompiled procedure bodies, however, are immutable and therefore they 1920 * are not recompiled, even if things have changed. 1921 */ 1922 1923 if (bodyPtr->typePtr == &tclByteCodeType) { 1924 if (((Interp *) *codePtr->interpHandle == iPtr) 1925 && (codePtr->compileEpoch == iPtr->compileEpoch) 1926 && (codePtr->nsPtr == nsPtr) 1927 && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { 1928 return TCL_OK; 1929 } else { 1930 if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { 1931 if ((Interp *) *codePtr->interpHandle != iPtr) { 1932 Tcl_AppendResult(interp, 1933 "a precompiled script jumped interps", NULL); 1934 return TCL_ERROR; 1935 } 1936 codePtr->compileEpoch = iPtr->compileEpoch; 1937 codePtr->nsPtr = nsPtr; 1938 } else { 1939 bodyPtr->typePtr->freeIntRepProc(bodyPtr); 1940 bodyPtr->typePtr = NULL; 1941 } 1942 } 1943 } 1944 if (bodyPtr->typePtr != &tclByteCodeType) { 1945 Tcl_HashEntry *hePtr; 1946 1947#ifdef TCL_COMPILE_DEBUG 1948 if (tclTraceCompile >= 1) { 1949 /* 1950 * Display a line summarizing the top level command we are about 1951 * to compile. 1952 */ 1953 1954 Tcl_Obj *message; 1955 1956 TclNewLiteralStringObj(message, "Compiling "); 1957 Tcl_IncrRefCount(message); 1958 Tcl_AppendStringsToObj(message, description, " \"", NULL); 1959 Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL); 1960 fprintf(stdout, "%s\"\n", TclGetString(message)); 1961 Tcl_DecrRefCount(message); 1962 } 1963#endif 1964 1965 /* 1966 * Plug the current procPtr into the interpreter and coerce the code 1967 * body to byte codes. The interpreter needs to know which proc it's 1968 * compiling so that it can access its list of compiled locals. 1969 * 1970 * TRICKY NOTE: Be careful to push a call frame with the proper 1971 * namespace context, so that the byte codes are compiled in the 1972 * appropriate class context. 1973 */ 1974 1975 if (procPtrPtr != NULL && procPtr->refCount > 1) { 1976 Tcl_Command token; 1977 Tcl_CmdInfo info; 1978 Proc *newProc = (Proc *) ckalloc(sizeof(Proc)); 1979 1980 newProc->iPtr = procPtr->iPtr; 1981 newProc->refCount = 1; 1982 newProc->cmdPtr = procPtr->cmdPtr; 1983 token = (Tcl_Command) newProc->cmdPtr; 1984 newProc->bodyPtr = Tcl_DuplicateObj(bodyPtr); 1985 bodyPtr = newProc->bodyPtr; 1986 Tcl_IncrRefCount(bodyPtr); 1987 newProc->numArgs = procPtr->numArgs; 1988 1989 newProc->numCompiledLocals = newProc->numArgs; 1990 newProc->firstLocalPtr = NULL; 1991 newProc->lastLocalPtr = NULL; 1992 localPtr = procPtr->firstLocalPtr; 1993 for (i=0; i<newProc->numArgs; i++, localPtr=localPtr->nextPtr) { 1994 CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned) 1995 (sizeof(CompiledLocal) - sizeof(localPtr->name) 1996 + localPtr->nameLength + 1)); 1997 1998 if (newProc->firstLocalPtr == NULL) { 1999 newProc->firstLocalPtr = newProc->lastLocalPtr = copy; 2000 } else { 2001 newProc->lastLocalPtr->nextPtr = copy; 2002 newProc->lastLocalPtr = copy; 2003 } 2004 copy->nextPtr = NULL; 2005 copy->nameLength = localPtr->nameLength; 2006 copy->frameIndex = localPtr->frameIndex; 2007 copy->flags = localPtr->flags; 2008 copy->defValuePtr = localPtr->defValuePtr; 2009 if (copy->defValuePtr) { 2010 Tcl_IncrRefCount(copy->defValuePtr); 2011 } 2012 copy->resolveInfo = localPtr->resolveInfo; 2013 strcpy(copy->name, localPtr->name); 2014 } 2015 2016 /* 2017 * Reset the ClientData 2018 */ 2019 2020 Tcl_GetCommandInfoFromToken(token, &info); 2021 if (info.objClientData == (ClientData) procPtr) { 2022 info.objClientData = (ClientData) newProc; 2023 } 2024 if (info.clientData == (ClientData) procPtr) { 2025 info.clientData = (ClientData) newProc; 2026 } 2027 if (info.deleteData == (ClientData) procPtr) { 2028 info.deleteData = (ClientData) newProc; 2029 } 2030 Tcl_SetCommandInfoFromToken(token, &info); 2031 2032 procPtr->refCount--; 2033 *procPtrPtr = procPtr = newProc; 2034 } 2035 iPtr->compiledProcPtr = procPtr; 2036 2037 (void) TclPushStackFrame(interp, &framePtr, 2038 (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); 2039 2040 /* 2041 * TIP #280: We get the invoking context from the cmdFrame which 2042 * was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr). 2043 */ 2044 2045 hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr); 2046 2047 /* 2048 * Constructed saved frame has body as word 0. See Tcl_ProcObjCmd. 2049 */ 2050 2051 iPtr->invokeWord = 0; 2052 iPtr->invokeCmdFramePtr = 2053 (hePtr ? (CmdFrame *) Tcl_GetHashValue(hePtr) : NULL); 2054 (void) tclByteCodeType.setFromAnyProc(interp, bodyPtr); 2055 iPtr->invokeCmdFramePtr = NULL; 2056 TclPopStackFrame(interp); 2057 } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { 2058 /* 2059 * The resolver epoch has changed, but we only need to invalidate the 2060 * resolver cache. 2061 */ 2062 2063 codePtr->nsEpoch = nsPtr->resolverEpoch; 2064 codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS; 2065 } 2066 return TCL_OK; 2067} 2068 2069/* 2070 *---------------------------------------------------------------------- 2071 * 2072 * MakeProcError -- 2073 * 2074 * Function called by TclObjInterpProc to create the stack information 2075 * upon an error from a procedure. 2076 * 2077 * Results: 2078 * The interpreter's error info trace is set to a value that supplements 2079 * the error code. 2080 * 2081 * Side effects: 2082 * none. 2083 * 2084 *---------------------------------------------------------------------- 2085 */ 2086 2087static void 2088MakeProcError( 2089 Tcl_Interp *interp, /* The interpreter in which the procedure was 2090 * called. */ 2091 Tcl_Obj *procNameObj) /* Name of the procedure. Used for error 2092 * messages and trace information. */ 2093{ 2094 int overflow, limit = 60, nameLen; 2095 const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); 2096 2097 overflow = (nameLen > limit); 2098 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 2099 "\n (procedure \"%.*s%s\" line %d)", 2100 (overflow ? limit : nameLen), procName, 2101 (overflow ? "..." : ""), interp->errorLine)); 2102} 2103 2104/* 2105 *---------------------------------------------------------------------- 2106 * 2107 * TclProcDeleteProc -- 2108 * 2109 * This function is invoked just before a command procedure is removed 2110 * from an interpreter. Its job is to release all the resources allocated 2111 * to the procedure. 2112 * 2113 * Results: 2114 * None. 2115 * 2116 * Side effects: 2117 * Memory gets freed, unless the procedure is actively being executed. 2118 * In this case the cleanup is delayed until the last call to the current 2119 * procedure completes. 2120 * 2121 *---------------------------------------------------------------------- 2122 */ 2123 2124void 2125TclProcDeleteProc( 2126 ClientData clientData) /* Procedure to be deleted. */ 2127{ 2128 Proc *procPtr = (Proc *) clientData; 2129 2130 procPtr->refCount--; 2131 if (procPtr->refCount <= 0) { 2132 TclProcCleanupProc(procPtr); 2133 } 2134} 2135 2136/* 2137 *---------------------------------------------------------------------- 2138 * 2139 * TclProcCleanupProc -- 2140 * 2141 * This function does all the real work of freeing up a Proc structure. 2142 * It's called only when the structure's reference count becomes zero. 2143 * 2144 * Results: 2145 * None. 2146 * 2147 * Side effects: 2148 * Memory gets freed. 2149 * 2150 *---------------------------------------------------------------------- 2151 */ 2152 2153void 2154TclProcCleanupProc( 2155 register Proc *procPtr) /* Procedure to be deleted. */ 2156{ 2157 register CompiledLocal *localPtr; 2158 Tcl_Obj *bodyPtr = procPtr->bodyPtr; 2159 Tcl_Obj *defPtr; 2160 Tcl_ResolvedVarInfo *resVarInfo; 2161 Tcl_HashEntry *hePtr = NULL; 2162 CmdFrame *cfPtr = NULL; 2163 Interp *iPtr = procPtr->iPtr; 2164 2165 if (bodyPtr != NULL) { 2166 Tcl_DecrRefCount(bodyPtr); 2167 } 2168 for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { 2169 CompiledLocal *nextPtr = localPtr->nextPtr; 2170 2171 resVarInfo = localPtr->resolveInfo; 2172 if (resVarInfo) { 2173 if (resVarInfo->deleteProc) { 2174 (*resVarInfo->deleteProc)(resVarInfo); 2175 } else { 2176 ckfree((char *) resVarInfo); 2177 } 2178 } 2179 2180 if (localPtr->defValuePtr != NULL) { 2181 defPtr = localPtr->defValuePtr; 2182 Tcl_DecrRefCount(defPtr); 2183 } 2184 ckfree((char *) localPtr); 2185 localPtr = nextPtr; 2186 } 2187 ckfree((char *) procPtr); 2188 2189 /* 2190 * TIP #280: Release the location data associated with this Proc 2191 * structure, if any. The interpreter may not exist (For example for 2192 * procbody structures created by tbcload. See also Tcl_ProcObjCmd(), when 2193 * the same ProcPtr is overwritten with a new CmdFrame. 2194 */ 2195 2196 if (!iPtr) { 2197 return; 2198 } 2199 2200 hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr); 2201 if (!hePtr) { 2202 return; 2203 } 2204 2205 cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); 2206 2207 if (cfPtr->type == TCL_LOCATION_SOURCE) { 2208 Tcl_DecrRefCount(cfPtr->data.eval.path); 2209 cfPtr->data.eval.path = NULL; 2210 } 2211 ckfree((char *) cfPtr->line); 2212 cfPtr->line = NULL; 2213 ckfree((char *) cfPtr); 2214 Tcl_DeleteHashEntry(hePtr); 2215} 2216 2217/* 2218 *---------------------------------------------------------------------- 2219 * 2220 * TclUpdateReturnInfo -- 2221 * 2222 * This function is called when procedures return, and at other points 2223 * where the TCL_RETURN code is used. It examines the returnLevel and 2224 * returnCode to determine the real return status. 2225 * 2226 * Results: 2227 * The return value is the true completion code to use for the procedure 2228 * or script, instead of TCL_RETURN. 2229 * 2230 * Side effects: 2231 * None. 2232 * 2233 *---------------------------------------------------------------------- 2234 */ 2235 2236int 2237TclUpdateReturnInfo( 2238 Interp *iPtr) /* Interpreter for which TCL_RETURN exception 2239 * is being processed. */ 2240{ 2241 int code = TCL_RETURN; 2242 2243 iPtr->returnLevel--; 2244 if (iPtr->returnLevel < 0) { 2245 Tcl_Panic("TclUpdateReturnInfo: negative return level"); 2246 } 2247 if (iPtr->returnLevel == 0) { 2248 /* 2249 * Now we've reached the level to return the requested -code. 2250 * Since iPtr->returnLevel and iPtr->returnCode have completed 2251 * their task, we now reset them to default values so that any 2252 * bare "return TCL_RETURN" that may follow will work [Bug 2152286]. 2253 */ 2254 2255 code = iPtr->returnCode; 2256 iPtr->returnLevel = 1; 2257 iPtr->returnCode = TCL_OK; 2258 if (code == TCL_ERROR) { 2259 iPtr->flags |= ERR_LEGACY_COPY; 2260 } 2261 } 2262 return code; 2263} 2264 2265/* 2266 *---------------------------------------------------------------------- 2267 * 2268 * TclGetObjInterpProc -- 2269 * 2270 * Returns a pointer to the TclObjInterpProc function; this is different 2271 * from the value obtained from the TclObjInterpProc reference on systems 2272 * like Windows where import and export versions of a function exported 2273 * by a DLL exist. 2274 * 2275 * Results: 2276 * Returns the internal address of the TclObjInterpProc function. 2277 * 2278 * Side effects: 2279 * None. 2280 * 2281 *---------------------------------------------------------------------- 2282 */ 2283 2284TclObjCmdProcType 2285TclGetObjInterpProc(void) 2286{ 2287 return (TclObjCmdProcType) TclObjInterpProc; 2288} 2289 2290/* 2291 *---------------------------------------------------------------------- 2292 * 2293 * TclNewProcBodyObj -- 2294 * 2295 * Creates a new object, of type "procbody", whose internal 2296 * representation is the given Proc struct. The newly created object's 2297 * reference count is 0. 2298 * 2299 * Results: 2300 * Returns a pointer to a newly allocated Tcl_Obj, NULL on error. 2301 * 2302 * Side effects: 2303 * The reference count in the ByteCode attached to the Proc is bumped up 2304 * by one, since the internal rep stores a pointer to it. 2305 * 2306 *---------------------------------------------------------------------- 2307 */ 2308 2309Tcl_Obj * 2310TclNewProcBodyObj( 2311 Proc *procPtr) /* the Proc struct to store as the internal 2312 * representation. */ 2313{ 2314 Tcl_Obj *objPtr; 2315 2316 if (!procPtr) { 2317 return NULL; 2318 } 2319 2320 TclNewObj(objPtr); 2321 if (objPtr) { 2322 objPtr->typePtr = &tclProcBodyType; 2323 objPtr->internalRep.otherValuePtr = procPtr; 2324 2325 procPtr->refCount++; 2326 } 2327 2328 return objPtr; 2329} 2330 2331/* 2332 *---------------------------------------------------------------------- 2333 * 2334 * ProcBodyDup -- 2335 * 2336 * Tcl_ObjType's Dup function for the proc body object. Bumps the 2337 * reference count on the Proc stored in the internal representation. 2338 * 2339 * Results: 2340 * None. 2341 * 2342 * Side effects: 2343 * Sets up the object in dupPtr to be a duplicate of the one in srcPtr. 2344 * 2345 *---------------------------------------------------------------------- 2346 */ 2347 2348static void 2349ProcBodyDup( 2350 Tcl_Obj *srcPtr, /* Object to copy. */ 2351 Tcl_Obj *dupPtr) /* Target object for the duplication. */ 2352{ 2353 Proc *procPtr = srcPtr->internalRep.otherValuePtr; 2354 2355 dupPtr->typePtr = &tclProcBodyType; 2356 dupPtr->internalRep.otherValuePtr = procPtr; 2357 procPtr->refCount++; 2358} 2359 2360/* 2361 *---------------------------------------------------------------------- 2362 * 2363 * ProcBodyFree -- 2364 * 2365 * Tcl_ObjType's Free function for the proc body object. The reference 2366 * count on its Proc struct is decreased by 1; if the count reaches 0, 2367 * the proc is freed. 2368 * 2369 * Results: 2370 * None. 2371 * 2372 * Side effects: 2373 * If the reference count on the Proc struct reaches 0, the struct is 2374 * freed. 2375 * 2376 *---------------------------------------------------------------------- 2377 */ 2378 2379static void 2380ProcBodyFree( 2381 Tcl_Obj *objPtr) /* The object to clean up. */ 2382{ 2383 Proc *procPtr = objPtr->internalRep.otherValuePtr; 2384 2385 procPtr->refCount--; 2386 if (procPtr->refCount <= 0) { 2387 TclProcCleanupProc(procPtr); 2388 } 2389} 2390 2391/* 2392 *---------------------------------------------------------------------- 2393 * 2394 * DupLambdaInternalRep, FreeLambdaInternalRep, SetLambdaFromAny -- 2395 * 2396 * How to manage the internal representations of lambda term objects. 2397 * Syntactically they look like a two- or three-element list, where the 2398 * first element is the formal arguments, the second is the the body, and 2399 * the (optional) third is the namespace to execute the lambda term 2400 * within (the global namespace is assumed if it is absent). 2401 * 2402 *---------------------------------------------------------------------- 2403 */ 2404 2405static void 2406DupLambdaInternalRep( 2407 Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ 2408 register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ 2409{ 2410 Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; 2411 Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2; 2412 2413 copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; 2414 copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; 2415 2416 procPtr->refCount++; 2417 Tcl_IncrRefCount(nsObjPtr); 2418 copyPtr->typePtr = &lambdaType; 2419} 2420 2421static void 2422FreeLambdaInternalRep( 2423 register Tcl_Obj *objPtr) /* CmdName object with internal representation 2424 * to free. */ 2425{ 2426 Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; 2427 Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; 2428 2429 procPtr->refCount--; 2430 if (procPtr->refCount == 0) { 2431 TclProcCleanupProc(procPtr); 2432 } 2433 TclDecrRefCount(nsObjPtr); 2434} 2435 2436static int 2437SetLambdaFromAny( 2438 Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 2439 register Tcl_Obj *objPtr) /* The object to convert. */ 2440{ 2441 Interp *iPtr = (Interp *) interp; 2442 char *name; 2443 Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; 2444 int objc, result; 2445 Proc *procPtr; 2446 2447 /* 2448 * Convert objPtr to list type first; if it cannot be converted, or if its 2449 * length is not 2, then it cannot be converted to lambdaType. 2450 */ 2451 2452 result = TclListObjGetElements(interp, objPtr, &objc, &objv); 2453 if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { 2454 TclNewLiteralStringObj(errPtr, "can't interpret \""); 2455 Tcl_AppendObjToObj(errPtr, objPtr); 2456 Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); 2457 Tcl_SetObjResult(interp, errPtr); 2458 return TCL_ERROR; 2459 } 2460 2461 argsPtr = objv[0]; 2462 bodyPtr = objv[1]; 2463 2464 /* 2465 * Create and initialize the Proc struct. The cmdPtr field is set to NULL 2466 * to signal that this is an anonymous function. 2467 */ 2468 2469 name = TclGetString(objPtr); 2470 2471 if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr, bodyPtr, 2472 &procPtr) != TCL_OK) { 2473 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 2474 "\n (parsing lambda expression \"%s\")", name)); 2475 return TCL_ERROR; 2476 } 2477 2478 /* 2479 * CAREFUL: TclCreateProc returns refCount==1! [Bug 1578454] 2480 * procPtr->refCount = 1; 2481 */ 2482 2483 procPtr->cmdPtr = NULL; 2484 2485 /* 2486 * TIP #280: Remember the line the apply body is starting on. In a Byte 2487 * code context we ask the engine to provide us with the necessary 2488 * information. This is for the initialization of the byte code compiler 2489 * when the body is used for the first time. 2490 * 2491 * NOTE: The body is the second word in the 'objPtr'. Its location, 2492 * accessible through 'context.line[1]' (see below) is therefore only the 2493 * first approximation of the actual line the body is on. We have to use 2494 * the string rep of the 'objPtr' to determine the exact line. This is 2495 * available already through 'name'. Use 'TclListLines', see 'switch' 2496 * (tclCmdMZ.c). 2497 * 2498 * This code is nearly identical to the #280 code in Tcl_ProcObjCmd, see 2499 * this file. The differences are the different index of the body in the 2500 * line array of the context, and the special processing mentioned in the 2501 * previous paragraph to track into the list. Find a way to factor the 2502 * common elements into a single function. 2503 */ 2504 2505 if (iPtr->cmdFramePtr) { 2506 CmdFrame *contextPtr; 2507 2508 contextPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); 2509 *contextPtr = *iPtr->cmdFramePtr; 2510 2511 if (contextPtr->type == TCL_LOCATION_BC) { 2512 /* 2513 * Retrieve the source context from the bytecode. This call 2514 * accounts for the reference to the source file, if any, held in 2515 * 'context.data.eval.path'. 2516 */ 2517 2518 TclGetSrcInfoForPc(contextPtr); 2519 } else if (contextPtr->type == TCL_LOCATION_SOURCE) { 2520 /* 2521 * We created a new reference to the source file path name when we 2522 * created 'context' above. Account for the reference. 2523 */ 2524 2525 Tcl_IncrRefCount(contextPtr->data.eval.path); 2526 2527 } 2528 2529 if (contextPtr->type == TCL_LOCATION_SOURCE) { 2530 /* 2531 * We can record source location within a lambda only if the body 2532 * was not created by substitution. 2533 */ 2534 2535 if (contextPtr->line 2536 && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) { 2537 int isNew, buf[2]; 2538 CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); 2539 2540 /* 2541 * Move from approximation (line of list cmd word) to actual 2542 * location (line of 2nd list element). 2543 */ 2544 2545 TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); 2546 2547 cfPtr->level = -1; 2548 cfPtr->type = contextPtr->type; 2549 cfPtr->line = (int *) ckalloc(sizeof(int)); 2550 cfPtr->line[0] = buf[1]; 2551 cfPtr->nline = 1; 2552 cfPtr->framePtr = NULL; 2553 cfPtr->nextPtr = NULL; 2554 2555 cfPtr->data.eval.path = contextPtr->data.eval.path; 2556 Tcl_IncrRefCount(cfPtr->data.eval.path); 2557 2558 cfPtr->cmd.str.cmd = NULL; 2559 cfPtr->cmd.str.len = 0; 2560 2561 Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, 2562 (char *) procPtr, &isNew), cfPtr); 2563 } 2564 2565 /* 2566 * 'contextPtr' is going out of scope. Release the reference that 2567 * it's holding to the source file path 2568 */ 2569 2570 Tcl_DecrRefCount(contextPtr->data.eval.path); 2571 } 2572 TclStackFree(interp, contextPtr); 2573 } 2574 2575 /* 2576 * Set the namespace for this lambda: given by objv[2] understood as a 2577 * global reference, or else global per default. 2578 */ 2579 2580 if (objc == 2) { 2581 TclNewLiteralStringObj(nsObjPtr, "::"); 2582 } else { 2583 char *nsName = TclGetString(objv[2]); 2584 2585 if ((*nsName != ':') || (*(nsName+1) != ':')) { 2586 TclNewLiteralStringObj(nsObjPtr, "::"); 2587 Tcl_AppendObjToObj(nsObjPtr, objv[2]); 2588 } else { 2589 nsObjPtr = objv[2]; 2590 } 2591 } 2592 2593 Tcl_IncrRefCount(nsObjPtr); 2594 2595 /* 2596 * Free the list internalrep of objPtr - this will free argsPtr, but 2597 * bodyPtr retains a reference from the Proc structure. Then finish the 2598 * conversion to lambdaType. 2599 */ 2600 2601 objPtr->typePtr->freeIntRepProc(objPtr); 2602 2603 objPtr->internalRep.twoPtrValue.ptr1 = procPtr; 2604 objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; 2605 objPtr->typePtr = &lambdaType; 2606 return TCL_OK; 2607} 2608 2609/* 2610 *---------------------------------------------------------------------- 2611 * 2612 * Tcl_ApplyObjCmd -- 2613 * 2614 * This object-based function is invoked to process the "apply" Tcl 2615 * command. See the user documentation for details on what it does. 2616 * 2617 * Results: 2618 * A standard Tcl object result value. 2619 * 2620 * Side effects: 2621 * Depends on the content of the lambda term (i.e., objv[1]). 2622 * 2623 *---------------------------------------------------------------------- 2624 */ 2625 2626int 2627Tcl_ApplyObjCmd( 2628 ClientData dummy, /* Not used. */ 2629 Tcl_Interp *interp, /* Current interpreter. */ 2630 int objc, /* Number of arguments. */ 2631 Tcl_Obj *CONST objv[]) /* Argument objects. */ 2632{ 2633 Interp *iPtr = (Interp *) interp; 2634 Proc *procPtr = NULL; 2635 Tcl_Obj *lambdaPtr, *nsObjPtr; 2636 int result, isRootEnsemble; 2637 Command cmd; 2638 Tcl_Namespace *nsPtr; 2639 ExtraFrameInfo efi; 2640 2641 if (objc < 2) { 2642 Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?"); 2643 return TCL_ERROR; 2644 } 2645 2646 /* 2647 * Set lambdaPtr, convert it to lambdaType in the current interp if 2648 * necessary. 2649 */ 2650 2651 lambdaPtr = objv[1]; 2652 if (lambdaPtr->typePtr == &lambdaType) { 2653 procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; 2654 } 2655 2656#define JOE_EXTENSION 0 2657#if JOE_EXTENSION 2658 else { 2659 /* 2660 * Joe English's suggestion to allow cmdNames to function as lambdas. 2661 * Also requires making tclCmdNameType non-static in tclObj.c 2662 */ 2663 2664 Tcl_Obj *elemPtr; 2665 int numElem; 2666 2667 if ((lambdaPtr->typePtr == &tclCmdNameType) || 2668 (TclListObjGetElements(interp, lambdaPtr, &numElem, 2669 &elemPtr) == TCL_OK && numElem == 1)) { 2670 return Tcl_EvalObjv(interp, objc-1, objv+1, 0); 2671 } 2672 } 2673#endif 2674 2675 if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { 2676 result = SetLambdaFromAny(interp, lambdaPtr); 2677 if (result != TCL_OK) { 2678 return result; 2679 } 2680 procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; 2681 } 2682 2683 memset(&cmd, 0, sizeof(Command)); 2684 procPtr->cmdPtr = &cmd; 2685 2686 /* 2687 * TIP#280 (semi-)HACK! 2688 * 2689 * Using cmd.clientData to tell [info frame] how to render the 2690 * 'lambdaPtr'. The InfoFrameCmd will detect this case by testing cmd.hPtr 2691 * for NULL. This condition holds here because of the 'memset' above, and 2692 * nowhere else (in the core). Regular commands always have a valid 2693 * 'hPtr', and lambda's never. 2694 */ 2695 2696 efi.length = 1; 2697 efi.fields[0].name = "lambda"; 2698 efi.fields[0].proc = NULL; 2699 efi.fields[0].clientData = lambdaPtr; 2700 cmd.clientData = &efi; 2701 2702 /* 2703 * Find the namespace where this lambda should run, and push a call frame 2704 * for that namespace. Note that TclObjInterpProc() will pop it. 2705 */ 2706 2707 nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; 2708 result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); 2709 if (result != TCL_OK) { 2710 return result; 2711 } 2712 2713 cmd.nsPtr = (Namespace *) nsPtr; 2714 2715 isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); 2716 if (isRootEnsemble) { 2717 iPtr->ensembleRewrite.sourceObjs = objv; 2718 iPtr->ensembleRewrite.numRemovedObjs = 1; 2719 iPtr->ensembleRewrite.numInsertedObjs = 0; 2720 } else { 2721 iPtr->ensembleRewrite.numInsertedObjs -= 1; 2722 } 2723 2724 result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1); 2725 if (result == TCL_OK) { 2726 result = TclObjInterpProcCore(interp, objv[1], 2, &MakeLambdaError); 2727 } 2728 2729 if (isRootEnsemble) { 2730 iPtr->ensembleRewrite.sourceObjs = NULL; 2731 iPtr->ensembleRewrite.numRemovedObjs = 0; 2732 iPtr->ensembleRewrite.numInsertedObjs = 0; 2733 } 2734 2735 return result; 2736} 2737 2738/* 2739 *---------------------------------------------------------------------- 2740 * 2741 * MakeLambdaError -- 2742 * 2743 * Function called by TclObjInterpProc to create the stack information 2744 * upon an error from a lambda term. 2745 * 2746 * Results: 2747 * The interpreter's error info trace is set to a value that supplements 2748 * the error code. 2749 * 2750 * Side effects: 2751 * none. 2752 * 2753 *---------------------------------------------------------------------- 2754 */ 2755 2756static void 2757MakeLambdaError( 2758 Tcl_Interp *interp, /* The interpreter in which the procedure was 2759 * called. */ 2760 Tcl_Obj *procNameObj) /* Name of the procedure. Used for error 2761 * messages and trace information. */ 2762{ 2763 int overflow, limit = 60, nameLen; 2764 const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); 2765 2766 overflow = (nameLen > limit); 2767 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 2768 "\n (lambda term \"%.*s%s\" line %d)", 2769 (overflow ? limit : nameLen), procName, 2770 (overflow ? "..." : ""), interp->errorLine)); 2771} 2772 2773 2774/* 2775 *---------------------------------------------------------------------- 2776 * 2777 * Tcl_DisassembleObjCmd -- 2778 * 2779 * Implementation of the "::tcl::unsupported::disassemble" command. This 2780 * command is not documented, but will disassemble procedures, lambda 2781 * terms and general scripts. Note that will compile terms if necessary 2782 * in order to disassemble them. 2783 * 2784 *---------------------------------------------------------------------- 2785 */ 2786 2787int 2788Tcl_DisassembleObjCmd( 2789 ClientData dummy, /* Not used. */ 2790 Tcl_Interp *interp, /* Current interpreter. */ 2791 int objc, /* Number of arguments. */ 2792 Tcl_Obj *CONST objv[]) /* Argument objects. */ 2793{ 2794 static const char *types[] = { 2795 "lambda", "proc", "script", NULL 2796 }; 2797 enum Types { 2798 DISAS_LAMBDA, DISAS_PROC, DISAS_SCRIPT 2799 }; 2800 int idx, result; 2801 2802 if (objc != 3) { 2803 Tcl_WrongNumArgs(interp, 1, objv, "type procName|lambdaTerm|script"); 2804 return TCL_ERROR; 2805 } 2806 if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ 2807 return TCL_ERROR; 2808 } 2809 2810 switch ((enum Types) idx) { 2811 case DISAS_LAMBDA: { 2812 Proc *procPtr = NULL; 2813 Command cmd; 2814 Tcl_Obj *nsObjPtr; 2815 Tcl_Namespace *nsPtr; 2816 2817 /* 2818 * Compile (if uncompiled) and disassemble a lambda term. 2819 */ 2820 2821 if (objv[2]->typePtr == &lambdaType) { 2822 procPtr = objv[2]->internalRep.twoPtrValue.ptr1; 2823 } 2824 if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { 2825 result = SetLambdaFromAny(interp, objv[2]); 2826 if (result != TCL_OK) { 2827 return result; 2828 } 2829 procPtr = objv[2]->internalRep.twoPtrValue.ptr1; 2830 } 2831 2832 memset(&cmd, 0, sizeof(Command)); 2833 nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; 2834 result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); 2835 if (result != TCL_OK) { 2836 return result; 2837 } 2838 cmd.nsPtr = (Namespace *) nsPtr; 2839 procPtr->cmdPtr = &cmd; 2840 result = PushProcCallFrame(procPtr, interp, objc, objv, 1); 2841 if (result != TCL_OK) { 2842 return result; 2843 } 2844 TclPopStackFrame(interp); 2845 if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags 2846 & TCL_BYTECODE_PRECOMPILED) { 2847 Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode", 2848 NULL); 2849 return TCL_ERROR; 2850 } 2851 Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr)); 2852 break; 2853 } 2854 case DISAS_PROC: { 2855 Proc *procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); 2856 2857 if (procPtr == NULL) { 2858 Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), 2859 "\" isn't a procedure", NULL); 2860 return TCL_ERROR; 2861 } 2862 2863 /* 2864 * Compile (if uncompiled) and disassemble a procedure. 2865 */ 2866 2867 result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); 2868 if (result != TCL_OK) { 2869 return result; 2870 } 2871 TclPopStackFrame(interp); 2872 if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags 2873 & TCL_BYTECODE_PRECOMPILED) { 2874 Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode", 2875 NULL); 2876 return TCL_ERROR; 2877 } 2878 Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr)); 2879 break; 2880 } 2881 case DISAS_SCRIPT: 2882 /* 2883 * Compile and disassemble a script. 2884 */ 2885 2886 if (objv[2]->typePtr != &tclByteCodeType) { 2887 if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){ 2888 return TCL_ERROR; 2889 } 2890 } 2891 Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(objv[2])); 2892 break; 2893 } 2894 return TCL_OK; 2895} 2896 2897/* 2898 * Local Variables: 2899 * mode: c 2900 * c-basic-offset: 4 2901 * fill-column: 78 2902 * End: 2903 */ 2904