Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | add compilation for [nextto] and [yieldto]; fix [a90d9331bc] |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
b64f6cd9a9b518758fe0f3b06312bce6 |
User & Date: | dkf 2014-01-22 09:11:07 |
Context
2014-01-22
| ||
13:48 | remove unused variable check-in: 8cf8f4d2dc user: jan.nijtmans tags: trunk | |
09:11 | add compilation for [nextto] and [yieldto]; fix [a90d9331bc] check-in: b64f6cd9a9 user: dkf tags: trunk | |
09:07 | [a90d9331bc]: must not crash when yieldto called in vanishing namespace check-in: b37441105a user: dkf tags: dkf-bytecode-8.6-main | |
2014-01-21
| ||
18:17 | merge mark check-in: 345437b24b user: dgp tags: trunk | |
Changes
Changes to generic/tclAssembly.c.
︙ | ︙ | |||
22 23 24 25 26 27 28 29 30 31 32 33 34 35 | *- returnImm, returnStk *- expandStart, expandStkTop, invokeExpanded, expandDrop *- dictFirst, dictNext, dictDone *- dictUpdateStart, dictUpdateEnd *- jumpTable testing *- syntax (?) *- returnCodeBranch */ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" /* | > | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | *- returnImm, returnStk *- expandStart, expandStkTop, invokeExpanded, expandDrop *- dictFirst, dictNext, dictDone *- dictUpdateStart, dictUpdateEnd *- jumpTable testing *- syntax (?) *- returnCodeBranch *- tclooNext, tclooNextClass */ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" /* |
︙ | ︙ |
Changes to generic/tclBasic.c.
︙ | ︙ | |||
255 256 257 258 259 260 261 | {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, CMD_IS_SAFE}, {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, CMD_IS_SAFE}, {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, CMD_IS_SAFE}, {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, CMD_IS_SAFE}, {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE}, {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE}, | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 | {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, CMD_IS_SAFE}, {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, CMD_IS_SAFE}, {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, CMD_IS_SAFE}, {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, CMD_IS_SAFE}, {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE}, {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE}, {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE}, /* * Commands in the OS-interface. Note that many of these are unsafe. */ {"after", Tcl_AfterObjCmd, NULL, NULL, CMD_IS_SAFE}, {"cd", Tcl_CdObjCmd, NULL, NULL, 0}, |
︙ | ︙ | |||
8427 8428 8429 8430 8431 8432 8433 | if (!corPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); return TCL_ERROR; } | | > | < | < > > > < < < < < < | 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 | if (!corPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); return TCL_ERROR; } if (((Namespace *) TclGetCurrentNamespace(interp))->flags & NS_DYING) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto called in deleted namespace", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", NULL); return TCL_ERROR; } /* * Add the tailcall in the caller env, then just yield. * * This is essentially code from TclNRTailcallObjCmd */ listPtr = Tcl_NewListObj(objc, objv); nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); TclListObjSetElement(interp, listPtr, 0, nsObjPtr); /* * Add the callback in the caller's env, then instruct TEBC to yield. */ iPtr->execEnvPtr = corPtr->callerEEPtr; TclSetTailcall(interp, listPtr); |
︙ | ︙ |
Changes to generic/tclCompCmdsGR.c.
︙ | ︙ | |||
3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 | for (i=0 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt1( INST_TCLOO_NEXT, i, envPtr); return TCL_OK; } int TclCompileObjectSelfCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being | > > > > > > > > > > > > > > > > > > > > > > > > > | 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 | for (i=0 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt1( INST_TCLOO_NEXT, i, envPtr); return TCL_OK; } int TclCompileObjectNextToCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; if (parsePtr->numWords < 2 || parsePtr->numWords > 255) { return TCL_ERROR; } for (i=0 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr); return TCL_OK; } int TclCompileObjectSelfCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being |
︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
︙ | ︙ | |||
3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 | Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 1); } OP( YIELD); return TCL_OK; } /* *---------------------------------------------------------------------- * * CompileUnaryOpCmd -- * * Utility routine to compile the unary operator commands. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 | Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 1); } OP( YIELD); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileYieldToCmd -- * * Procedure called to compile the "yieldto" command. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "yieldto" command at * runtime. * *---------------------------------------------------------------------- */ int TclCompileYieldToCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int i; if (parsePtr->numWords < 2) { return TCL_ERROR; } OP( NS_CURRENT); for (i = 1 ; i < parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } OP4( LIST, i); OP( YIELD_TO_INVOKE); return TCL_OK; } /* *---------------------------------------------------------------------- * * CompileUnaryOpCmd -- * * Utility routine to compile the unary operator commands. |
︙ | ︙ |
Changes to generic/tclCompile.c.
︙ | ︙ | |||
614 615 616 617 618 619 620 | {"originCmd", 1, 0, 0, {OPERAND_NONE}}, /* Reports which command was the origin (via namespace import chain) * of the command named on the top of the stack. * Stack: ... cmdName => ... fullOriginalCmdName */ {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, | > > > > > > > > > > > > | > | > > > > | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 | {"originCmd", 1, 0, 0, {OPERAND_NONE}}, /* Reports which command was the origin (via namespace import chain) * of the command named on the top of the stack. * Stack: ... cmdName => ... fullOriginalCmdName */ {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Call the next item on the TclOO call chain, passing opnd arguments * (min 1, max 255, *includes* "next"). The result of the invoked * method implementation will be pushed on the stack in place of the * arguments (similar to invokeStk). * Stack: ... "next" arg2 arg3 -- argN => ... result */ {"tclooNextClass", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Call the following item on the TclOO call chain defined by class * className, passing opnd arguments (min 2, max 255, *includes* * "nextto" and the class name). The result of the invoked method * implementation will be pushed on the stack in place of the * arguments (similar to invokeStk). * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ {"yieldToInvoke", 1, 0, 0, {OPERAND_NONE}}, /* Makes the current coroutine yield the value at the top of the * stack, invoking the given command/args with resolution in the given * namespace (all packed into a list), and places the list of values * that are the response back on top of the stack when it resumes. * Stack: ... [list ns cmd arg1 ... argN] => ... resumeList */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; /* * Prototypes for procedures defined later in this file: */ |
︙ | ︙ |
Changes to generic/tclCompile.h.
︙ | ︙ | |||
787 788 789 790 791 792 793 794 795 | #define INST_STR_LOWER 175 #define INST_STR_TITLE 176 #define INST_STR_REPLACE 177 #define INST_ORIGIN_COMMAND 178 #define INST_TCLOO_NEXT 179 /* The last opcode */ | > > > | | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 | #define INST_STR_LOWER 175 #define INST_STR_TITLE 176 #define INST_STR_REPLACE 177 #define INST_ORIGIN_COMMAND 178 #define INST_TCLOO_NEXT 179 #define INST_TCLOO_NEXT_CLASS 180 #define INST_YIELD_TO_INVOKE 181 /* The last opcode */ #define LAST_INST_OPCODE 181 /* * Table describing the Tcl bytecode instructions: their name (for displaying * code), total number of code bytes required (including operand bytes), and a * description of the type of each operand. These operand types include signed * and unsigned integers of length one and four bytes. The unsigned integers * are used for indexes or for, e.g., the count of objects to push in a "push" |
︙ | ︙ |
Changes to generic/tclExecute.c.
︙ | ︙ | |||
2490 2491 2492 2493 2494 2495 2496 | OBJ_AT_TOS = objResultPtr; Tcl_SetObjResult(interp, objResultPtr); } cleanup = 1; TRACE_APPEND(("\n")); goto processExceptionReturn; | < > | > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | > > | > > > > > > > > > > > > > > > > < < | < > | 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 | OBJ_AT_TOS = objResultPtr; Tcl_SetObjResult(interp, objResultPtr); } cleanup = 1; TRACE_APPEND(("\n")); goto processExceptionReturn; { CoroutineData *corPtr; int yieldParameter; case INST_YIELD: corPtr = iPtr->execEnvPtr->corPtr; TRACE(("%.30s => ", O2S(OBJ_AT_TOS))); if (!corPtr) { TRACE_APPEND(("ERROR: yield outside coroutine\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( "yield can only be called in a coroutine", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); CACHE_STACK_INFO(); goto gotError; } #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { if (traceInstructions) { TRACE_APPEND(("YIELD...\n")); } else { fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n", iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), Tcl_GetString(OBJ_AT_TOS)); } fflush(stdout); } #endif yieldParameter = 0; Tcl_SetObjResult(interp, OBJ_AT_TOS); goto doYield; case INST_YIELD_TO_INVOKE: corPtr = iPtr->execEnvPtr->corPtr; valuePtr = OBJ_AT_TOS; if (!corPtr) { TRACE(("[%.30s] => ERROR: yield outside coroutine\n", O2S(valuePtr))); Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto can only be called in a coroutine", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); CACHE_STACK_INFO(); goto gotError; } if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) { TRACE(("[%.30s] => ERROR: yield in deleted\n", O2S(valuePtr))); Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto called in deleted namespace", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", NULL); CACHE_STACK_INFO(); goto gotError; } #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { if (traceInstructions) { TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); } else { /* FIXME: What is the right thing to trace? */ fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), Tcl_GetString(valuePtr)); } fflush(stdout); } #endif /* * Install a tailcall record in the caller and continue with the * yield. The yield is switched into multi-return mode (via the * 'yieldParameter'). */ Tcl_IncrRefCount(valuePtr); iPtr->execEnvPtr = corPtr->callerEEPtr; TclSetTailcall(interp, valuePtr); iPtr->execEnvPtr = corPtr->eePtr; yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/ doYield: /* TIP #280: Record the last piece of info needed by * 'TclGetSrcInfoForPc', and push the frame. */ bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } pc++; cleanup = 1; TEBC_YIELD(); TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, INT2PTR(yieldParameter), NULL, NULL); return TCL_OK; } case INST_TAILCALL: { Tcl_Obj *listPtr, *nsObjPtr; opnd = TclGetUInt1AtPtr(pc+1); if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); Tcl_SetObjResult(interp, Tcl_NewStringObj( "tailcall can only be called from a proc or lambda", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); CACHE_STACK_INFO(); goto gotError; } #ifdef TCL_COMPILE_DEBUG /* FIXME: What is the right thing to trace? */ { register int i; TRACE(("%d [", opnd)); for (i=opnd-1 ; i>=0 ; i--) { TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); if (i > 0) { |
︙ | ︙ | |||
4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 | * Start of TclOO support instructions. */ { Object *oPtr; CallFrame *framePtr; CallContext *contextPtr; case INST_TCLOO_SELF: framePtr = iPtr->varFramePtr; if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE(("=> ERROR: no TclOO call context\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( | > | 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 | * Start of TclOO support instructions. */ { Object *oPtr; CallFrame *framePtr; CallContext *contextPtr; int skip, newDepth; case INST_TCLOO_SELF: framePtr = iPtr->varFramePtr; if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE(("=> ERROR: no TclOO call context\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( |
︙ | ︙ | |||
4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 | /* * Call out to get the name; it's expensive to compute but cached. */ objResultPtr = TclOOObjectName(interp, contextPtr->oPtr); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); case INST_TCLOO_NEXT: opnd = TclGetUInt1AtPtr(pc+1); framePtr = iPtr->varFramePtr; TRACE(("%d => ", opnd)); if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE_APPEND(("ERROR: no TclOO call context\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( "next may only be called from inside a method", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); CACHE_STACK_INFO(); goto gotError; } contextPtr = framePtr->clientData; | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 | /* * Call out to get the name; it's expensive to compute but cached. */ objResultPtr = TclOOObjectName(interp, contextPtr->oPtr); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); case INST_TCLOO_NEXT_CLASS: opnd = TclGetUInt1AtPtr(pc+1); framePtr = iPtr->varFramePtr; valuePtr = OBJ_AT_DEPTH(opnd - 2); objv = &OBJ_AT_DEPTH(opnd - 1); skip = 2; TRACE(("%d => ", opnd)); if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE_APPEND(("ERROR: no TclOO call context\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( "nextto may only be called from inside a method", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); CACHE_STACK_INFO(); goto gotError; } contextPtr = framePtr->clientData; oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr); if (oPtr == NULL) { TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr))); goto gotError; } else { Class *classPtr = oPtr->classPtr; struct MInvoke *miPtr; int i; const char *methodType; if (classPtr == NULL) { TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr))); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(valuePtr))); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); CACHE_STACK_INFO(); goto gotError; } for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) { miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { newDepth = i; #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); } for (i = 0; i < opnd; i++) { TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); } fprintf(stdout, "\n"); fflush(stdout); } #endif /*TCL_COMPILE_DEBUG*/ goto doInvokeNext; } } if (contextPtr->callPtr->flags & CONSTRUCTOR) { methodType = "constructor"; } else if (contextPtr->callPtr->flags & DESTRUCTOR) { methodType = "destructor"; } else { methodType = "method"; } TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", O2S(valuePtr))); for (i=contextPtr->index ; i>=0 ; i--) { miPtr = contextPtr->callPtr->chain + i; if (miPtr->isFilter || miPtr->mPtr->declaringClassPtr != classPtr) { continue; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s implementation by \"%s\" not reachable from here", methodType, TclGetString(valuePtr))); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", NULL); CACHE_STACK_INFO(); goto gotError; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s has no non-filter implementation by \"%s\"", methodType, TclGetString(valuePtr))); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); CACHE_STACK_INFO(); goto gotError; } case INST_TCLOO_NEXT: opnd = TclGetUInt1AtPtr(pc+1); objv = &OBJ_AT_DEPTH(opnd - 1); framePtr = iPtr->varFramePtr; skip = 1; TRACE(("%d => ", opnd)); if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE_APPEND(("ERROR: no TclOO call context\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( "next may only be called from inside a method", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); CACHE_STACK_INFO(); goto gotError; } contextPtr = framePtr->clientData; newDepth = contextPtr->index + 1; if (newDepth >= contextPtr->callPtr->numChain) { /* * We're at the end of the chain; generate an error message unless * the interpreter is being torn down, in which case we might be * getting here because of methods/destructors doing a [next] (or * equivalent) unexpectedly. */ |
︙ | ︙ | |||
4601 4602 4603 4604 4605 4606 4607 | TRACE_APPEND(("ERROR: no TclOO next impl\n")); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no next %s implementation", methodType)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); CACHE_STACK_INFO(); goto gotError; | < < | < | | < | > > | > > > | | | | < | 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 | TRACE_APPEND(("ERROR: no TclOO next impl\n")); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no next %s implementation", methodType)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); CACHE_STACK_INFO(); goto gotError; #ifdef TCL_COMPILE_DEBUG } else if (tclTraceExec >= 2) { int i; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); } for (i = 0; i < opnd; i++) { TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); } fprintf(stdout, "\n"); fflush(stdout); #endif /*TCL_COMPILE_DEBUG*/ } doInvokeNext: bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv); } pcAdjustment = 2; cleanup = opnd; DECACHE_STACK_INFO(); iPtr->varFramePtr = framePtr->callerVarPtr; pc += pcAdjustment; TEBC_YIELD(); oPtr = contextPtr->oPtr; if (oPtr->flags & FILTER_HANDLING) { TclNRAddCallback(interp, FinalizeOONextFilter, framePtr, contextPtr, INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip)); } else { TclNRAddCallback(interp, FinalizeOONext, framePtr, contextPtr, INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip)); } contextPtr->skip = skip; contextPtr->index = newDepth; if (contextPtr->callPtr->chain[newDepth].isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) { oPtr->flags |= FILTER_HANDLING; } else { oPtr->flags &= ~FILTER_HANDLING; } { register Method *const mPtr = contextPtr->callPtr->chain[newDepth].mPtr; return mPtr->typePtr->callProc(mPtr->clientData, interp, (Tcl_ObjectContext) contextPtr, opnd, objv); } case INST_TCLOO_IS_OBJECT: oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); objResultPtr = TCONST(oPtr != NULL ? 1 : 0); TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); NEXT_INST_F(1, 1, 1); |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); | > > > | 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileObjectNextToCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); |
︙ | ︙ | |||
3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic1ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); | > > > | 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileYieldToCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic1ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); |
︙ | ︙ |
Changes to generic/tclOO.c.
︙ | ︙ | |||
436 437 438 439 440 441 442 | * Create non-object commands and plug ourselves into the Tcl [info] * ensemble. */ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", NULL, TclOONextObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectNextCmd; | | > | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 | * Create non-object commands and plug ourselves into the Tcl [info] * ensemble. */ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", NULL, TclOONextObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectNextCmd; cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", NULL, TclOONextToObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectNextToCmd; cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectSelfCmd; Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, NULL); |
︙ | ︙ |
Changes to generic/tclOOBasic.c.
︙ | ︙ | |||
817 818 819 820 821 822 823 824 825 826 827 828 829 830 | { Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; Class *classPtr; CallContext *contextPtr; int i; Tcl_Object object; /* * Start with sanity checks on the calling context to make sure that we * are invoked from a suitable method context. If so, we can safely * retrieve the handle to the object call context. */ | > | 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 | { Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; Class *classPtr; CallContext *contextPtr; int i; Tcl_Object object; const char *methodType; /* * Start with sanity checks on the calling context to make sure that we * are invoked from a suitable method context. If so, we can safely * retrieve the handle to the object call context. */ |
︙ | ︙ | |||
881 882 883 884 885 886 887 888 889 890 891 892 893 | } } /* * Generate an appropriate error message, depending on whether the value * is on the chain but unreachable, or not on the chain at all. */ for (i=contextPtr->index ; i>=0 ; i--) { struct MInvoke *miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( | > > > > > > > > | | > > | | > | 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 | } } /* * Generate an appropriate error message, depending on whether the value * is on the chain but unreachable, or not on the chain at all. */ if (contextPtr->callPtr->flags & CONSTRUCTOR) { methodType = "constructor"; } else if (contextPtr->callPtr->flags & DESTRUCTOR) { methodType = "destructor"; } else { methodType = "method"; } for (i=contextPtr->index ; i>=0 ; i--) { struct MInvoke *miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s implementation by \"%s\" not reachable from here", methodType, TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", NULL); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s has no non-filter implementation by \"%s\"", methodType, TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); return TCL_ERROR; } static int NextRestoreFrame( ClientData data[], Tcl_Interp *interp, |
︙ | ︙ |
Changes to tests/coroutine.test.
|
| | | 1 2 3 4 5 6 7 8 | # Commands covered: coroutine, yield, yieldto, [info coroutine] # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. # # Copyright (c) 2008 by Miguel Sofer. # |
︙ | ︙ | |||
608 609 610 611 612 613 614 | set result "" coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\ {a b c d e} list $result [info command j1] [info command j2] [info command j3] } -cleanup { catch {rename juggler ""} } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} | < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 | set result "" coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\ {a b c d e} list $result [info command j1] [info command j2] [info command j3] } -cleanup { catch {rename juggler ""} } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { proc foo {a b} {catch yield; return 1} } -cleanup { rename foo {} } -body { coroutine demo lsort -command foo {a b} } -result {b a} test coroutine-7.5 {return codes} { set result {} foreach code {0 1 2 3 4 5} { lappend result [catch {coroutine demo return -level 0 -code $code}] } set result } {0 1 2 3 4 5} test coroutine-7.6 {Early yield crashes} { proc foo args {} trace add execution foo enter {catch yield} coroutine demo foo rename foo {} } {} test coroutine-7.7 {Bug 2486550} -setup { interp hide {} yield } -body { coroutine demo interp invokehidden {} yield ok } -cleanup { demo interp expose {} yield } -result ok test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup { namespace eval cotest {} set ::result "" } -body { proc cotest::body {} { lappend ::result a yield OUT lappend ::result b yieldto ::return -level 0 123 lappend ::result c return } lappend ::result [coroutine cotest cotest::body] namespace delete cotest namespace eval cotest {} lappend ::result [cotest] cotest return $result } -returnCodes error -cleanup { catch {namespace delete ::cotest} catch {rename cotest ""} } -result {yieldto called in deleted namespace} test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup { namespace eval cotest {} set ::result "" } -body { proc cotest::body {} { set y ::yieldto lappend ::result a yield OUT lappend ::result b $y ::return -level 0 123 lappend ::result c return } lappend ::result [coroutine cotest cotest::body] namespace delete cotest namespace eval cotest {} lappend ::result [cotest] cotest return $result } -returnCodes error -cleanup { catch {namespace delete ::cotest} catch {rename cotest ""} } -result {yieldto called in deleted namespace} test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup { namespace eval cotest {} set ::result "" } -body { proc cotest::body {} { lappend ::result a yield OUT lappend ::result b yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123 lappend ::result c return } lappend ::result [coroutine cotest cotest::body] lappend ::result [cotest] cotest return $result } -returnCodes error -cleanup { catch {namespace delete ::cotest} catch {rename cotest ""} } -result {yieldto called in deleted namespace} test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup { namespace eval cotest {} set ::result "" } -body { proc cotest::body {} { set y ::yieldto lappend ::result a yield OUT lappend ::result b $y ::return -level 0 -cotest [namespace delete ::cotest] 123 lappend ::result c return } lappend ::result [coroutine cotest cotest::body] lappend ::result [cotest] cotest return $result } -returnCodes error -cleanup { catch {namespace delete ::cotest} catch {rename cotest ""} } -result {yieldto called in deleted namespace} # cleanup unset lambda ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |