File:  [gforth] / gforth / except.fs
Revision 1.13: download - view: text, annotated - select for diffs
Fri Oct 13 17:36:07 2006 UTC (13 years, 3 months ago) by anton
Branches: MAIN
CVS tags: HEAD
documented NOTHROW

    1: \ catch, throw, etc.
    2: 
    3: \ Copyright (C) 1999,2000,2003 Free Software Foundation, Inc.
    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
   19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   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: 
   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: 
   79: Variable first-throw
   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 ;
   86: 
   87: : (try) ( ahandler -- )
   88:     first-throw on
   89:     r>
   90:     swap >r \ recovery address
   91:     rp@ 'catch >r
   92:     sp@ >r
   93:     fp@ >r
   94:     lp@ >r
   95:     handler @ >r
   96:     rp@ handler !
   97:     >r ;
   98: 
   99: : try ( compilation  -- orig ; run-time  -- ) \ gforth
  100:     \ !! does not work correctly for gforth-native
  101:     POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then
  102:     r> POSTPONE literal POSTPONE (try) ; immediate compile-only
  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)
  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
  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 + ! ]
  137: 	first-throw @ IF
  138: 	    store-backtrace error-stack off
  139: 	    first-throw off
  140: 	THEN
  141: 	handler @ ?dup-0=-IF
  142: 	    >stderr cr ." uncaught exception: " .error cr
  143: 	    2 (bye)
  144: \	    quit
  145: 	THEN
  146: 	rp!
  147: 	r> handler !
  148: 	r> lp!
  149: 	r> fp!
  150: 	r> swap >r sp! drop r>
  151: 	rdrop 'throw r> perform
  152:     THEN ;
  153: is throw
  154: [IFDEF] rethrow
  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 ;
  169: is rethrow
  170: [THEN]

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