Tcl Source Code: Diff

Differences From Artifact [a94352bba4]:

File generic/tclProc.c — part of check-in [6cbe02a1d6] at 2011-03-24 23:42:09 on branch mig-no280 — branch with tip #280 removed, for perf impact measurements (user: mig size: 77140)

To Artifact [cad41aff4d]:

File generic/tclProc.c — part of check-in [e058edf908] at 2011-04-04 14:22:16 on branch mig-no280 — Merge to feature branch (user: dkf size: 78640) [more...]

︙
149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174	149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177	+ + +	fullName = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, fullName, NULL, 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { Tcl_AppendResult(interp, "can't create procedure \"", fullName, "\": unknown namespace", NULL); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if (procName == NULL) { Tcl_AppendResult(interp, "can't create procedure \"", fullName, "\": bad procedure name", NULL); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) && (procName != NULL) && (procName[0] == ':')) { Tcl_AppendResult(interp, "can't create procedure \"", procName, "\" in non-global namespace with name starting with \":\"", NULL); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } /* * Create the data structure to represent the procedure. */
︙
380 381 382 383 384 385 386 387 388 389 390 391 392 393	383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398	+ +	if (precompiled) { if (numArgs > procPtr->numArgs) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": arg list contains %d entries, " "precompiled header expects %d", procName, numArgs, procPtr->numArgs)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; } localPtr = procPtr->firstLocalPtr; } else { procPtr->numArgs = numArgs; procPtr->numCompiledLocals = numArgs; }
︙
406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424	411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433	+ + + +	goto procError; } if (fieldCount > 2) { ckfree(fieldValues); Tcl_AppendResult(interp, "too many fields in argument specifier \"", argArray[i], "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } if ((fieldCount == 0) \|\| (*fieldValues[0] == 0)) { ckfree(fieldValues); Tcl_AppendResult(interp, "argument with no name", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } nameLength = strlen(fieldValues[0]); if (fieldCount == 2) { valueLength = strlen(fieldValues[1]); } else {
︙
437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456	446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469	+ + + +	q++; } while (q != '\0'); q--; if (q == ')') { /* We have an array element. / Tcl_AppendResult(interp, "formal parameter \"", fieldValues[0], "\" is an array element", NULL); ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } } else if ((p == ':') && ((p+1) == ':')) { Tcl_AppendResult(interp, "formal parameter \"", fieldValues[0], "\" is not a simple name", NULL); ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } p++; } if (precompiled) { /
︙
470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502	483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519	+ + + +	\|\| !(localPtr->flags & VAR_ARGUMENT) \|\| (localPtr->defValuePtr == NULL && fieldCount == 2) \|\| (localPtr->defValuePtr != NULL && fieldCount != 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; } /* * Compare the default value if any. / if (localPtr->defValuePtr != NULL) { int tmpLength; const char tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength); if ((valueLength != tmpLength) \|\| strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter \"%s\" has " "default value inconsistent with precompiled body", procName, fieldValues[0])); ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; } } if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') && (strcmp(localPtr->name, "args") == 0)) {
︙
642 643 644 645 646 647 648 649 650 651 652 653 654 655	659 660 661 662 663 664 665 666 667 668 669 670 671 672 673	+	framePtrPtr = framePtr; return result; levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } / ---------------------------------------------------------------------- * TclObjGetFrame --
︙
774 775 776 777 778 779 780 ~~781~~ 782 783 784 785 786 787 788	792 793 794 795 796 797 798 799 800 801 802 803 804 805 806	- +	} framePtrPtr = framePtr; return result; levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); ~~Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL);~~ Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } / ---------------------------------------------------------------------- * Tcl_UplevelObjCmd --
︙
1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750	1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769	+	* transform to an error now. / Tcl_ResetResult(interp); Tcl_AppendResult(interp, "invoked \"", ((result == TCL_BREAK) ? "break" : "continue"), "\" outside of a loop", NULL); Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); result = TCL_ERROR; / * Fall through to the TCL_ERROR handling code. */ case TCL_ERROR:
︙
1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867	1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888	+ +	return TCL_OK; } if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { if ((Interp ) codePtr->interpHandle != iPtr) { Tcl_AppendResult(interp, "a precompiled script jumped interps", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "CROSSINTERPBYTECODE", NULL); return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { bodyPtr->typePtr->freeIntRepProc(bodyPtr); bodyPtr->typePtr = NULL;
︙
2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309	2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331	+	result = TclListObjGetElements(interp, objPtr, &objc, &objv); if ((result != TCL_OK) \|\| ((objc != 2) && (objc != 3))) { TclNewLiteralStringObj(errPtr, "can't interpret \""); Tcl_AppendObjToObj(errPtr, objPtr); Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); Tcl_SetObjResult(interp, errPtr); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); return TCL_ERROR; } argsPtr = objv[0]; bodyPtr = objv[1]; /*
︙
2617 2618 2619 2620 2621 2622 2623 ~~2624 2625 2626 2627 2628 2629 2630~~ 2631 ~~2632 2633 2634~~ 2635 ~~2636 2637 2638 2639 2640 2641 2642~~ ~~2643~~ 2644 2645 2646 2647 2648 2649 2650	2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674	+ - - - - - - - + + + + + + + + + - - - + + + - - - - - - - + + + + + + + -	codeObjPtr = procPtr->bodyPtr; break; } case DISAS_PROC: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "procName"); return TCL_ERROR; } ~~} else {~~ procPtr = TclFindProc((Interp ) interp, TclGetString(objv[2])); if (procPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), "\" isn't a procedure", NULL); return TCL_ERROR; } procPtr = TclFindProc((Interp ) interp, TclGetString(objv[2])); if (procPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), "\" isn't a procedure", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", TclGetString(objv[2]), NULL); return TCL_ERROR; } ~~/* * Compile (if uncompiled) and disassemble a procedure. /~~ / * Compile (if uncompiled) and disassemble a procedure. / ~~result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); if (result != TCL_OK) { return result; } TclPopStackFrame(interp); codeObjPtr = procPtr->bodyPtr; break;~~ result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); if (result != TCL_OK) { return result; } TclPopStackFrame(interp); codeObjPtr = procPtr->bodyPtr; break; } case DISAS_SCRIPT: / * Compile and disassemble a script. */ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "script");
︙
2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684	2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710	+ +	oPtr = (Object ) Tcl_GetObjectFromObj(interp, objv[2]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), "\" is not a class", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objv[2]), NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, (char ) objv[3]); goto methodBody; case DISAS_OBJECT_METHOD: if (objc != 4) {
︙
2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723	2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753	+ + + +	/ methodBody: if (hPtr == NULL) { unknownMethod: Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[3]), "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[3]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { Tcl_AppendResult(interp, "body not available for this kind of method", NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "METHODTYPE", NULL); return TCL_ERROR; } if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { Command cmd; / * Yes, this is ugly, but we need to pass the namespace in to the
︙
2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762	2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794	+ +	/* * Do the actual disassembly. / if (((ByteCode ) codeObjPtr->internalRep.otherValuePtr)->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "BYTECODE", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */