Tcl Source Code

Check-in [62a51cdb45]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:simplification of the catch compiler and new test
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 62a51cdb45fd987e9349fd6d0f90d237b2fa5511
User & Date: mig 2013-12-11 16:46:38
Context
2013-12-15
17:49
Improve descriptions of character escapes and ranges in Tcl.n. Improve output format handlers to cop... check-in: 35e85b0756 user: dkf tags: trunk
2013-12-12
09:13
merge trunk; document added instructions check-in: 3c12b66379 user: dkf tags: dkf-bytecode-8.6-main
2013-12-11
16:48
merge mark check-in: e0c8c98af2 user: mig tags: mig-catch-compiler
16:46
simplification of the catch compiler and new test check-in: 62a51cdb45 user: mig tags: trunk
16:43
comments check-in: 2e7bd6187e user: mig tags: mig-catch-compiler
2013-12-10
12:05
fix stack computations for lmap check-in: e4212fccc3 user: mig tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclCompCmds.c.

578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601

602
603
604
605
606
607
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
	    }
	}
    }

    /*
     * We will compile the catch command. Declare the exception range that it
     * uses.
     */

    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);

    /*
     * If the body is a simple word, compile a BEGIN_CATCH instruction,
     * followed by the instructions to eval the body.
     * Otherwise, compile instructions to substitute the body text before
     * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the
     * substituted body.
     * Care has to be taken to make sure that substitution happens outside the
     * catch range so that errors in the substitution are not caught.
     * [Bug 219184]
     * The reason for duplicating the script is that EVAL_STK would otherwise
     * begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
     */


    if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
	ExceptionRangeStarts(envPtr, range);
	BODY(cmdTokenPtr, 1);
    } else {
	SetLineInformation(1);
	CompileTokens(envPtr, cmdTokenPtr, interp);
	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
	ExceptionRangeStarts(envPtr, range);
	TclEmitOpcode(		INST_DUP,			envPtr);
	TclEmitInvoke(envPtr,	INST_EVAL_STK);
    }
    /* Stack at this point:
     *    nonsimple:  script <mark> result
     *    simple:            <mark> result
     */

    if (resultIndex == -1) {
	/*
	 * Special case when neither result nor options are being saved. In
	 * that case, we can skip quite a bit of the command epilogue; all we
	 * have to do is drop the result and push the return code (and, of
	 * course, finish the catch context).
	 */

	TclEmitOpcode(		INST_POP,			envPtr);
	PushStringLiteral(envPtr, "0");
	TclEmitInstInt1(	INST_JUMP1, 3,			envPtr);
	TclAdjustStackDepth(-1, envPtr);
	ExceptionRangeTarget(envPtr, range, catchOffset);
	TclEmitOpcode(		INST_PUSH_RETURN_CODE,		envPtr);
	ExceptionRangeEnds(envPtr, range);
	TclEmitOpcode(		INST_END_CATCH,			envPtr);

	/*
	 * Stack at this point:
	 *    nonsimple:  script <mark> returnCode
	 *    simple:            <mark> returnCode
	 */

	goto dropScriptAtEnd;
    }

    /*
     * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result,
     * and jump around the "error case" code.
     */

    PushStringLiteral(envPtr, "0");
    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
    /* Stack at this point: ?script? <mark> result TCL_OK */

    /* 
     * Emit the "error case" epilogue. Push the interpreter result and the
     * return code.
     */

    TclAdjustStackDepth(-2, envPtr);
    ExceptionRangeTarget(envPtr, range, catchOffset);
    /* Stack at this point:  ?script? */
    TclEmitOpcode(		INST_PUSH_RESULT,		envPtr);
    TclEmitOpcode(		INST_PUSH_RETURN_CODE,		envPtr);

    /*
     * Update the target of the jump after the "no errors" code. 
     */

    /* Stack at this point: ?script? result returnCode */
    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
	Tcl_Panic("TclCompileCatchCmd: bad jump distance %d",
		(int)(CurrentOffset(envPtr) - jumpFixup.codeOffset));
    }

    /*
     * Push the return options if the caller wants them.

     */

    if (optsIndex != -1) {
	TclEmitOpcode(		INST_PUSH_RETURN_OPTIONS,	envPtr);
    }

    /*
     * End the catch
     */

    ExceptionRangeEnds(envPtr, range);
    TclEmitOpcode(		INST_END_CATCH,			envPtr);

    /*
     * At this point, the top of the stack is inconveniently ordered:
     *		?script? result returnCode ?returnOptions?
     * Reverse the stack to bring the result to the top.
     */

    if (optsIndex != -1) {
	TclEmitInstInt4(	INST_REVERSE, 3,		envPtr);
    } else {
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
    }

    /*
     * Store the result and remove it from the stack.
     */

    Emit14Inst(			INST_STORE_SCALAR, resultIndex,	envPtr);
    TclEmitOpcode(		INST_POP,			envPtr);

    /*
     * Stack is now ?script? ?returnOptions? returnCode.
     * If the options dict has been requested, it is buried on the stack under
     * the return code. Reverse the stack to bring it to the top, store it and
     * remove it from the stack.
     */

    if (optsIndex != -1) {
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
	Emit14Inst(		INST_STORE_SCALAR, optsIndex,	envPtr);
	TclEmitOpcode(		INST_POP,			envPtr);
    }

  dropScriptAtEnd:

    /*

     * Stack is now ?script? result. Get rid of the subst'ed script if it's
     * hanging arond.

     */

    if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);

	TclEmitOpcode(		INST_POP,			envPtr);
    }


    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







<
|
<
<
<












>











<
<
<
<
<
|
<
<
<
<
<
<
<
|

<
<
<
<
<
<
<
|
<
<
<
<
<
|
<
<








<








|



|
<
<

<






|
>










<



<
<
<
<
|
<
<
<
<
<
|
<
<


<
<
<
<
<
<
<
<
<
<

<




<
<

>
|
<
>


<
|
>
|

>







578
579
580
581
582
583
584

585



586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
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
	    }
	}
    }

    /*
     * We will compile the catch command. Declare the exception range that it
     * uses.

     *



     * If the body is a simple word, compile a BEGIN_CATCH instruction,
     * followed by the instructions to eval the body.
     * Otherwise, compile instructions to substitute the body text before
     * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the
     * substituted body.
     * Care has to be taken to make sure that substitution happens outside the
     * catch range so that errors in the substitution are not caught.
     * [Bug 219184]
     * The reason for duplicating the script is that EVAL_STK would otherwise
     * begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
     */

    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
    if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
	ExceptionRangeStarts(envPtr, range);
	BODY(cmdTokenPtr, 1);
    } else {
	SetLineInformation(1);
	CompileTokens(envPtr, cmdTokenPtr, interp);
	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
	ExceptionRangeStarts(envPtr, range);
	TclEmitOpcode(		INST_DUP,			envPtr);
	TclEmitInvoke(envPtr,	INST_EVAL_STK);





	/* drop the script */







	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
	TclEmitOpcode(		INST_POP,			envPtr);







    }





    ExceptionRangeEnds(envPtr, range);



    /*
     * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result,
     * and jump around the "error case" code.
     */

    PushStringLiteral(envPtr, "0");
    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);


    /* 
     * Emit the "error case" epilogue. Push the interpreter result and the
     * return code.
     */

    TclAdjustStackDepth(-2, envPtr);
    ExceptionRangeTarget(envPtr, range, catchOffset);
    /* Stack at this point is empty */
    TclEmitOpcode(		INST_PUSH_RESULT,		envPtr);
    TclEmitOpcode(		INST_PUSH_RETURN_CODE,		envPtr);

    /* Stack at this point on both branches: result returnCode */




    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
	Tcl_Panic("TclCompileCatchCmd: bad jump distance %d",
		(int)(CurrentOffset(envPtr) - jumpFixup.codeOffset));
    }

    /*
     * Push the return options if the caller wants them. This needs to happen
     * before INST_END_CATCH
     */

    if (optsIndex != -1) {
	TclEmitOpcode(		INST_PUSH_RETURN_OPTIONS,	envPtr);
    }

    /*
     * End the catch
     */


    TclEmitOpcode(		INST_END_CATCH,			envPtr);

    /*




     * Save the result and return options if the caller wants them. This needs





     * to happen after INST_END_CATCH (compile-3.6/7).


     */











    if (optsIndex != -1) {

	Emit14Inst(		INST_STORE_SCALAR, optsIndex,	envPtr);
	TclEmitOpcode(		INST_POP,			envPtr);
    }



    /*
     * At this point, the top of the stack is inconveniently ordered:
     *		result returnCode

     * Reverse the stack to store the result.
     */


    TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
    if (resultIndex != -1) {
	Emit14Inst(	INST_STORE_SCALAR, resultIndex,	envPtr);
    }
    TclEmitOpcode(	INST_POP,			envPtr);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *

Changes to tests/compile.test.

162
163
164
165
166
167
168






























169
170
171
172
173
174
175
	    list $count $result2
	}
	catchtest::x
    }
    -result {10 {can't set "result1": trace on result1 fails by request}}
    -cleanup {namespace delete catchtest}
}































test compile-4.1 {TclCompileForCmd: command substituted test expression} {
    set i 0
    set j 0
    # Should be "forever"
    for {} [expr $i < 3] {} {
	set j [incr i]







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
	    list $count $result2
	}
	catchtest::x
    }
    -result {10 {can't set "result1": trace on result1 fails by request}}
    -cleanup {namespace delete catchtest}
}

test compile-3.7 {TclCompileCatchCmd: error in storing options [Bug 3098302]} {*}{
     -setup {
	 namespace eval catchtest {
	     variable options1 {}
	 }
	 trace add variable catchtest::options1 write catchtest::failtrace
	 proc catchtest::failtrace {n1 n2 op} {
	     return -code error "trace on $n1 fails by request"
	 }
     }
    -body {
	proc catchtest::x {} {
	    variable options1
	    set count 0
	    for {set i 0} {$i < 10} {incr i} {
		set status2 [catch {
		    set status1 [catch {
			return -code error -level 0 "original failure"
		    } result1 options1]
		} result2 options2]
		incr count
	    }
	    list $count $result2
	}
	catchtest::x
    }
    -result {10 {can't set "options1": trace on options1 fails by request}}
    -cleanup {namespace delete catchtest}
}

test compile-4.1 {TclCompileForCmd: command substituted test expression} {
    set i 0
    set j 0
    # Should be "forever"
    for {} [expr $i < 3] {} {
	set j [incr i]