File:  [gforth] / gforth / except.fs
Revision 1.8: download - view: text, annotated - select for diffs
Sun Nov 23 22:02:46 2003 UTC (16 years, 3 months ago) by anton
Branches: MAIN
CVS tags: HEAD
documentation changes
adapt exceptions to gforth-native (part 1)

    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: : (try) ( ahandler -- )
   37:     r>
   38:     swap >r \ recovery address
   39:     rp@ 'catch >r
   40:     sp@ >r
   41:     fp@ >r
   42:     lp@ >r
   43:     handler @ >r
   44:     rp@ handler !
   45:     backtrace-empty on
   46:     >r ;
   47: 
   48: : try ( compilation  -- orig ; run-time  -- ) \ gforth
   49:     \ !! does not work correctly for gforth-native
   50:     POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then
   51:     r> POSTPONE literal POSTPONE @ POSTPONE (try) ; immediate compile-only
   52: 
   53: : (recover) ( -- )
   54:     \ normal end of try block: restore handler, forget rest
   55:     r>
   56:     r> handler !
   57:     rdrop \ lp
   58:     rdrop \ fp
   59:     rdrop \ sp
   60:     r> rp!
   61:     rdrop \ recovery address
   62:     >r ;
   63: 
   64: : recover ( compilation  orig1 -- orig2 ; run-time  -- ) \ gforth
   65:     \ !! check using a special tag
   66:     POSTPONE (recover)
   67:     POSTPONE else ; immediate compile-only
   68: 
   69: : endtry ( compilation  orig -- ; run-time  -- ) \ gforth
   70:     POSTPONE then ; immediate compile-only
   71: 
   72: :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
   73:     try
   74: 	execute 0
   75:     recover
   76:         nip
   77:     endtry ;
   78: is catch
   79: 
   80: :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
   81:     ?DUP IF
   82: 	[ here forthstart 9 cells + ! ]
   83: 	store-backtrace
   84: 	handler @ ?dup-0=-IF
   85: 	    >stderr cr ." uncaught exception: " .error cr
   86: 	    2 (bye)
   87: \	    quit
   88: 	THEN
   89: 	rp!
   90: 	r> handler !
   91: 	r> lp!
   92: 	r> fp!
   93: 	r> swap >r sp! drop r>
   94: 	rdrop 'throw
   95:     THEN ;
   96: is throw
   97: 

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