fth/flkexcep.fs

   1 \  FLK exception handling
   2 \
   3 \  Copyright (C) 1998 Lars Krueger
   4 \
   5 \  This file is part of FLK.
   6 \
   7 \  FLK 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., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 \ $Id: flkexcep.fs,v 1.11 1998/09/17 13:15:41 root Exp $
  22 \ $Log: flkexcep.fs,v $
  23 \ Revision 1.11  1998/09/17 13:15:41  root
  24 \ added ?THROW
  25 \
  26 \ Revision 1.10  1998/08/30 10:50:59  root
  27 \ new optimizing algorithm
  28 \
  29 \ Revision 1.9  1998/07/03 20:57:50  root
  30 \ level 2 optimimizer added
  31 \
  32 \ Revision 1.8  1998/06/05 20:02:10  root
  33 \ forget corrected (chains)
  34 \
  35 \ Revision 1.7  1998/06/01 17:51:42  root
  36 \ SEE shows the sourcefile using VIEW
  37 \
  38 \ Revision 1.6  1998/05/27 18:52:12  root
  39 \ \: commants added for SEE and HELP
  40 \
  41 \ Revision 1.5  1998/05/09 21:47:05  root
  42 \ initializer and finisher added
  43 \
  44 \ Revision 1.4  1998/05/01 18:11:25  root
  45 \ GNU license text added
  46 \ comments checked
  47 \
  48 \ Revision 1.3  1998/04/30 09:42:25  root
  49 \ Comments added.
  50 \
  51 \ Revision 1.2  1998/04/09 11:35:03  root
  52 \ all words checked and OK
  53 \
  54 \ Revision 1.1  1998/04/07 20:10:33  root
  55 \ Initial revision
  56 \
  57
  58 \ THROW and CATCH are the same as in the standard. CATCH is a bit optimized to
  59 \ throw a value if the xt is illegal.
  60 VARIABLE THROW-HANDLER
  61 -256 CONSTANT TODO-EXCEPTION
  62 -257 CONSTANT ILLEGAL-IMMEDIATE-EXCEPTION
  63 -258 CONSTANT LIT-CACHE-EXCEPTION
  64 -259 CONSTANT RB-E-UNDERFLOW
  65 -260 CONSTANT RB-E-OVERFLOW
  66 -261 CONSTANT RB-E-RANGE
  67
  68 \ See standard.
  69 : CATCH         ( xt -- exception# | 0 )
  70 ( OK )
  71   ( fake EXECUTE )
  72   >CFA @ DUP        \ call call
  73   IMAGE-BASE = IF ( invalid )     \ call
  74     DROP -14        \ excep
  75   ELSE          \ call
  76     SP@         \ call sp
  77     >R                \ call / r: sp
  78     FSP >R        \ call / r: sp fsp
  79     THROW-HANDLER @ >R      \ call / r: sp fsp oh
  80     RP@         \ call rp
  81     THROW-HANDLER !         \ call
  82     (EXECUTE)
  83     ( no throw happended )
  84     R>          \ oh / r: sp fsp
  85     THROW-HANDLER !
  86     R> DROP         \ / r: sp
  87     R> DROP             \ / r:
  88     0
  89   THEN
  90   ;
  91
  92 \ See standard.
  93 : THROW           ( ??? exception# -- ??? exception# )
  94 ( OK )
  95   ?DUP IF         \ xc
  96     THROW-HANDLER @       \ xc handler / r:
  97     RP!           \ xc / r: sp fsp oh
  98     R>          \ xc oh / r: sp
  99     THROW-HANDLER !       \ xc / r: sp fsp
 100     R> TO FSP         \ xc / r: sp
 101     R>          \ xc sp / r:
 102     SWAP        \ sp xc / r:
 103     >R          \ sp / r: xc
 104     SP!         \ xt / r: xc
 105     DROP        \ / r: xc
 106     R>          \ xc
 107   THEN ;
 108
 109 \ See standard.
 110 : ABORT -1 THROW ;
 111 ( OK )
 112
 113 \ Throw a special exception to indicate an unfinished part.
 114 : TODO TODO-EXCEPTION THROW ;
 115 ( OK )
 116
 117 \ Throw an exception if flag is TRUE.
 118 : ?THROW ( flag code -- ) SWAP IF THROW THEN DROP ;
 119
 120 \ See standard.
 121 : EXECUTE         ( xt -- )
 122 ( OK )
 123   >CFA @ DUP          \ call call
 124   IMAGE-BASE =        \ call invalid?
 125   IF -14 THROW THEN       \ call
 126   (EXECUTE) ;
 127
 128 \ No operation. Does nothing. Has no effect. Performs no task. Ignores you. It
 129 \ contains an end-of-chain marker in it's dfa.
 130 : NOOP ;
 131 0 r,
 132
 133 ' NOOP RVALUE initializer
 134 ' NOOP RVALUE finisher
 135
 136 \ See standard.
 137 : BYE finisher EXECUTE 0 (BYE) ;
 138
 139 \ quit with exit code
 140 : SYSTEM-BYE ( code -- ) >R finisher EXECUTE R> (BYE) ;