Annotation of gforth/except.fs, revision 1.22

1.1       anton       1: \ catch, throw, etc.
                      2: 
1.20      anton       3: \ Copyright (C) 1999,2000,2003,2006,2007 Free Software Foundation, Inc.
1.1       anton       4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
1.21      anton       9: \ as published by the Free Software Foundation, either version 3
1.1       anton      10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
1.21      anton      18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1       anton      19: 
                     20: \ !! use a separate exception stack?           anton
                     21: 
                     22: \ has? backtrace [IF]
                     23: Defer store-backtrace
                     24: ' noop IS store-backtrace
                     25: \ [THEN]
                     26: 
1.9       anton      27: \ Ok, here's the story about how we get to the native code for the
                     28: \ recovery code in case of a THROW, and why there is all this funny
                     29: \ stuff being compiled by TRY and RECOVER:
                     30: 
                     31: \ Upon a THROW, we cannot just return through the ordinary return
                     32: \ address, but have to use a different one, for code after the
                     33: \ RECOVER.  How do we do that, in a way portable between the various
                     34: \ threaded and native code engines?  In particular, how does the
                     35: \ native code engine learn about the address of the native recovery
                     36: \ code?
                     37: 
                     38: \ On the Forth level, we can compile only references to threaded code.
                     39: \ The only thing that translates a threaded code address to a native
                     40: \ code address is docol, which is only called with EXECUTE and
                     41: \ friends.  So we start the recovery code with a docol, and invoke it
                     42: \ with PERFORM; the recovery code then rdrops the superfluously
                     43: \ generated return address and continues with the proper recovery
                     44: \ code.
                     45: 
                     46: \ At compile time, since we cannot compile a forward reference (to the
                     47: \ recovery code) as a literal (backpatching does not work for
                     48: \ native-code literals), we produce a data cell (wrapped in AHEAD
                     49: \ ... THEN) that we can backpatch, and compile the address of that as
                     50: \ literal.
                     51: 
                     52: \ Overall, this leads to the following resulting code:
                     53: 
                     54: \   ahead
                     55: \ +><recovery address>-+
                     56: \ | then               |
                     57: \ +-lit                |
                     58: \   (try)              |
                     59: \   ...                |
                     60: \   (recover)          |
                     61: \   ahead              |
                     62: \   docol: <-----------+
                     63: \   rdrop
                     64: \   ...
                     65: \   then
                     66: \   ...
                     67: 
                     68: \ !! explain handler on-stack structure
                     69: 
1.12      pazsan     70: Variable first-throw
1.13      anton      71: : nothrow ( -- ) \ gforth
                     72:     \G Use this (or the standard sequence @code{['] false catch drop})
                     73:     \G after a @code{catch} or @code{endtry} that does not rethrow;
                     74:     \G this ensures that the next @code{throw} will record a
                     75:     \G backtrace.
                     76:     first-throw on ;
1.12      pazsan     77: 
1.22    ! anton      78: : (try0) ( -- aoldhandler )
        !            79:     first-throw on
        !            80:     handler @ ;
        !            81: 
        !            82: [undefined] (try1) [if]
        !            83: : (try1) ( aoldhandler arecovery -- anewhandler )
        !            84:     r>
        !            85:     swap >r \ recovery address
        !            86:     sp@ cell+ >r
        !            87:     fp@ >r
        !            88:     lp@ >r
        !            89:     swap >r \ old handler
        !            90:     rp@ swap \ new handler
        !            91:     >r ;
        !            92: [endif]
        !            93: 
        !            94: : (try2)
        !            95:     handler ! ;
        !            96: 
1.5       anton      97: : (try) ( ahandler -- )
1.12      pazsan     98:     first-throw on
1.1       anton      99:     r>
1.5       anton     100:     swap >r \ recovery address
1.1       anton     101:     sp@ >r
                    102:     fp@ >r
                    103:     lp@ >r
                    104:     handler @ >r
                    105:     rp@ handler !
1.5       anton     106:     >r ;
1.1       anton     107: 
1.22    ! anton     108: \ : try ( compilation  -- orig ; run-time  -- R:sys1 ) \ gforth
        !           109: \     \G Start an exception-catching region.
        !           110: \     POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then
        !           111: \     r> POSTPONE literal POSTPONE (try) ; immediate compile-only
        !           112: 
1.18      anton     113: : try ( compilation  -- orig ; run-time  -- R:sys1 ) \ gforth
                    114:     \G Start an exception-catching region.
1.8       anton     115:     POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then
1.22    ! anton     116:     POSTPONE (try0) r> POSTPONE literal POSTPONE (try1) POSTPONE (try2)
        !           117: ; immediate compile-only
        !           118: 
1.1       anton     119: 
1.17      anton     120: : (endtry) ( -- )
1.1       anton     121:     \ normal end of try block: restore handler, forget rest
                    122:     r>
                    123:     r> handler !
                    124:     rdrop \ lp
                    125:     rdrop \ fp
                    126:     rdrop \ sp
                    127:     rdrop \ recovery address
                    128:     >r ;
                    129: 
1.17      anton     130: : handler-intro, ( -- )
1.9       anton     131:     docol: here 0 , 0 , code-address! \ start a colon def 
                    132:     postpone rdrop                    \ drop the return address
1.17      anton     133: ;
                    134: 
                    135: : iferror ( compilation  orig1 -- orig2 ; run-time  -- ) \ gforth
1.18      anton     136:     \G Starts the exception handling code (executed if there is an
                    137:     \G exception between @code{try} and @code{endtry}).  This part has
                    138:     \G to be finished with @code{then}.
1.17      anton     139:     \ !! check using a special tag
                    140:     POSTPONE else handler-intro,
                    141: ; immediate compile-only
                    142: 
                    143: : restore ( compilation  orig1 -- ; run-time  -- ) \ gforth
1.18      anton     144:     \G Starts restoring code, that is executed if there is an
                    145:     \G exception, and if there is no exception.
1.17      anton     146:     POSTPONE iferror POSTPONE then
1.9       anton     147: ; immediate compile-only
1.1       anton     148: 
1.18      anton     149: : endtry ( compilation  -- ; run-time  R:sys1 -- ) \ gforth
                    150:     \G End an exception-catching region.
1.17      anton     151:     POSTPONE (endtry)
1.18      anton     152: ; immediate compile-only
                    153: 
                    154: : endtry-iferror ( compilation  orig1 -- orig2 ; run-time  R:sys1 -- ) \ gforth
                    155:     \G End an exception-catching region while starting
                    156:     \G exception-handling code outside that region (executed if there
                    157:     \G is an exception between @code{try} and @code{endtry-iferror}).
                    158:     \G This part has to be finished with @code{then} (or
                    159:     \G @code{else}...@code{then}).
                    160:     POSTPONE (endtry) POSTPONE iferror POSTPONE (endtry)
1.16      anton     161: ; immediate compile-only
1.1       anton     162: 
                    163: :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
                    164:     try
                    165:        execute 0
1.17      anton     166:     iferror
                    167:        nip
                    168:     then endtry ;
1.1       anton     169: is catch
                    170: 
                    171: :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
                    172:     ?DUP IF
                    173:        [ here forthstart 9 cells + ! ]
1.12      pazsan    174:        first-throw @ IF
                    175:            store-backtrace error-stack off
                    176:            first-throw off
                    177:        THEN
1.1       anton     178:        handler @ ?dup-0=-IF
1.6       anton     179:            >stderr cr ." uncaught exception: " .error cr
1.1       anton     180:            2 (bye)
1.6       anton     181: \          quit
1.1       anton     182:        THEN
1.19      anton     183:         dup rp! ( ... ball frame )
                    184:         cell+ dup @ lp!
                    185:         cell+ dup @ fp!
                    186:         cell+ dup @ ( ... ball addr sp ) -rot 2>r sp! drop 2r>
                    187:         cell+ @ perform
1.1       anton     188:     THEN ;
                    189: is throw

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>