Annotation of gforth/except.fs, revision 1.15

1.1       anton       1: \ catch, throw, etc.
                      2: 
1.15    ! anton       3: \ Copyright (C) 1999,2000,2003,2006 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
                      9: \ as published by the Free Software Foundation; either version 2
                     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
                     18: \ along with this program; if not, write to the Free Software
1.3       anton      19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
1.1       anton      20: 
                     21: \ !! use a separate exception stack?           anton
                     22: 
                     23: \ user-definable rollback actions
                     24: 
                     25: Defer 'catch
                     26: Defer 'throw
                     27: 
                     28: ' noop IS 'catch
                     29: ' noop IS 'throw
                     30: 
                     31: \ has? backtrace [IF]
                     32: Defer store-backtrace
                     33: ' noop IS store-backtrace
                     34: \ [THEN]
                     35: 
1.9       anton      36: \ Ok, here's the story about how we get to the native code for the
                     37: \ recovery code in case of a THROW, and why there is all this funny
                     38: \ stuff being compiled by TRY and RECOVER:
                     39: 
                     40: \ Upon a THROW, we cannot just return through the ordinary return
                     41: \ address, but have to use a different one, for code after the
                     42: \ RECOVER.  How do we do that, in a way portable between the various
                     43: \ threaded and native code engines?  In particular, how does the
                     44: \ native code engine learn about the address of the native recovery
                     45: \ code?
                     46: 
                     47: \ On the Forth level, we can compile only references to threaded code.
                     48: \ The only thing that translates a threaded code address to a native
                     49: \ code address is docol, which is only called with EXECUTE and
                     50: \ friends.  So we start the recovery code with a docol, and invoke it
                     51: \ with PERFORM; the recovery code then rdrops the superfluously
                     52: \ generated return address and continues with the proper recovery
                     53: \ code.
                     54: 
                     55: \ At compile time, since we cannot compile a forward reference (to the
                     56: \ recovery code) as a literal (backpatching does not work for
                     57: \ native-code literals), we produce a data cell (wrapped in AHEAD
                     58: \ ... THEN) that we can backpatch, and compile the address of that as
                     59: \ literal.
                     60: 
                     61: \ Overall, this leads to the following resulting code:
                     62: 
                     63: \   ahead
                     64: \ +><recovery address>-+
                     65: \ | then               |
                     66: \ +-lit                |
                     67: \   (try)              |
                     68: \   ...                |
                     69: \   (recover)          |
                     70: \   ahead              |
                     71: \   docol: <-----------+
                     72: \   rdrop
                     73: \   ...
                     74: \   then
                     75: \   ...
                     76: 
                     77: \ !! explain handler on-stack structure
                     78: 
1.12      pazsan     79: Variable first-throw
1.13      anton      80: : nothrow ( -- ) \ gforth
                     81:     \G Use this (or the standard sequence @code{['] false catch drop})
                     82:     \G after a @code{catch} or @code{endtry} that does not rethrow;
                     83:     \G this ensures that the next @code{throw} will record a
                     84:     \G backtrace.
                     85:     first-throw on ;
1.12      pazsan     86: 
1.5       anton      87: : (try) ( ahandler -- )
1.12      pazsan     88:     first-throw on
1.1       anton      89:     r>
1.5       anton      90:     swap >r \ recovery address
1.1       anton      91:     rp@ 'catch >r
                     92:     sp@ >r
                     93:     fp@ >r
                     94:     lp@ >r
                     95:     handler @ >r
                     96:     rp@ handler !
1.5       anton      97:     >r ;
1.1       anton      98: 
                     99: : try ( compilation  -- orig ; run-time  -- ) \ gforth
1.5       anton     100:     \ !! does not work correctly for gforth-native
1.8       anton     101:     POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then
1.9       anton     102:     r> POSTPONE literal POSTPONE (try) ; immediate compile-only
1.1       anton     103: 
                    104: : (recover) ( -- )
                    105:     \ normal end of try block: restore handler, forget rest
                    106:     r>
                    107:     r> handler !
                    108:     rdrop \ lp
                    109:     rdrop \ fp
                    110:     rdrop \ sp
                    111:     r> rp!
                    112:     rdrop \ recovery address
                    113:     >r ;
                    114: 
                    115: : recover ( compilation  orig1 -- orig2 ; run-time  -- ) \ gforth
                    116:     \ !! check using a special tag
                    117:     POSTPONE (recover)
1.9       anton     118:     POSTPONE else
                    119:     docol: here 0 , 0 , code-address! \ start a colon def 
                    120:     postpone rdrop                    \ drop the return address
                    121: ; immediate compile-only
1.1       anton     122: 
                    123: : endtry ( compilation  orig -- ; run-time  -- ) \ gforth
                    124:     POSTPONE then ; immediate compile-only
                    125: 
                    126: :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
                    127:     try
                    128:        execute 0
                    129:     recover
                    130:         nip
                    131:     endtry ;
                    132: is catch
                    133: 
                    134: :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
                    135:     ?DUP IF
                    136:        [ here forthstart 9 cells + ! ]
1.12      pazsan    137:        first-throw @ IF
                    138:            store-backtrace error-stack off
                    139:            first-throw off
                    140:        THEN
1.1       anton     141:        handler @ ?dup-0=-IF
1.6       anton     142:            >stderr cr ." uncaught exception: " .error cr
1.1       anton     143:            2 (bye)
1.6       anton     144: \          quit
1.1       anton     145:        THEN
                    146:        rp!
                    147:        r> handler !
                    148:        r> lp!
                    149:        r> fp!
                    150:        r> swap >r sp! drop r>
1.9       anton     151:        rdrop 'throw r> perform
1.1       anton     152:     THEN ;
                    153: is throw
1.11      pazsan    154: [IFDEF] rethrow
1.10      pazsan    155: :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
                    156:     ?DUP IF
                    157:        handler @ ?dup-0=-IF
                    158:            >stderr cr ." uncaught exception: " .error cr
                    159:            2 (bye)
                    160: \          quit
                    161:        THEN
                    162:        rp!
                    163:        r> handler !
                    164:        r> lp!
                    165:        r> fp!
                    166:        r> swap >r sp! drop r>
                    167:        rdrop 'throw r> perform
                    168:     THEN ;
1.11      pazsan    169: is rethrow
1.14      anton     170: [THEN]

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