Return to except.fs CVS log

Up to [gforth] / gforth

fixed missing [if]

    1: \ catch, throw, etc.
    2: 
    3: \ Copyright (C) 1999,2000,2003,2006,2007 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 3
   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, see http://www.gnu.org/licenses/.
   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: 
   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: 
   70: Variable first-throw
   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 ;
   77: 
   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: 
   97: : (try) ( ahandler -- )
   98:     first-throw on
   99:     r>
  100:     swap >r \ recovery address
  101:     sp@ >r
  102:     fp@ >r
  103:     lp@ >r
  104:     handler @ >r
  105:     rp@ handler !
  106:     >r ;
  107: 
  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: 
  113: : try ( compilation  -- orig ; run-time  -- R:sys1 ) \ gforth
  114:     \G Start an exception-catching region.
  115:     POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then
  116:     POSTPONE (try0) r> POSTPONE literal POSTPONE (try1) POSTPONE (try2)
  117: ; immediate compile-only
  118: 
  119: 
  120: : (endtry) ( -- )
  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: 
  130: : handler-intro, ( -- )
  131:     docol: here 0 , 0 , code-address! \ start a colon def 
  132:     postpone rdrop                    \ drop the return address
  133: ;
  134: 
  135: : iferror ( compilation  orig1 -- orig2 ; run-time  -- ) \ gforth
  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}.
  139:     \ !! check using a special tag
  140:     POSTPONE else handler-intro,
  141: ; immediate compile-only
  142: 
  143: : restore ( compilation  orig1 -- ; run-time  -- ) \ gforth
  144:     \G Starts restoring code, that is executed if there is an
  145:     \G exception, and if there is no exception.
  146:     POSTPONE iferror POSTPONE then
  147: ; immediate compile-only
  148: 
  149: : endtry ( compilation  -- ; run-time  R:sys1 -- ) \ gforth
  150:     \G End an exception-catching region.
  151:     POSTPONE (endtry)
  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)
  161: ; immediate compile-only
  162: 
  163: :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
  164:     try
  165: 	execute 0
  166:     iferror
  167: 	nip
  168:     then endtry ;
  169: is catch
  170: 
  171: [undefined] (throw1) [if]
  172: : (throw1) ( ... ball frame -- ... ball )
  173:     dup rp! ( ... ball frame )
  174:     cell+ dup @ lp!
  175:     cell+ dup @ fp!
  176:     cell+ dup @ ( ... ball addr sp ) -rot 2>r sp! drop 2r>
  177:     cell+ @ perform ;
  178: [endif]
  179:     
  180: :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
  181:     ?DUP IF
  182: 	[ here forthstart 9 cells + ! ]
  183: 	first-throw @ IF
  184: 	    store-backtrace error-stack off
  185: 	    first-throw off
  186: 	THEN
  187: 	handler @ ?dup-0=-IF
  188: 	    >stderr cr ." uncaught exception: " .error cr
  189: 	    2 (bye)
  190: \	    quit
  191: 	THEN
  192: 	\ cr .s dup 64 dump
  193:         (throw1)
  194:     THEN ;
  195: is throw