level1/52_exceptions.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 $uservar "(EXC-FRAME-PTR)" ua_ofs_exc_frame_ptr 0
   8 (hidden)
   9
  10 ;; reset all exception frames
  11 : (EXC0!)  ( -- )  ... (exc-frame-ptr) 0! ; (hidden)
  12
  13 ;; this should save all necessary data to the return stack
  14 ;; the format is: ( ...data restorecfa )
  15 ;;   restorecfa:  ( restoreflag -- )
  16 ;;   if "restoreflag" is 0, drop the data
  17 : (CATCH-SAVER)  ( -- )  ... ; (hidden)
  18
  19
  20 : CATCH  ( i * x xt -- j * x 0 | i * x n )
  21   ;; this is using return stack to hold previous catch frame
  22   ;; of course, this prevents Very Smart return stack manipulation, but idc (for now)
  23   ;; exception frame consists of:
  24   ;;   return-to-catch EIP (return stack TOS)
  25   ;;   sp (frame points here)
  26   ;;   prev_self
  27   ;;   prev_frame_ptr
  28   ;;   return-to-catch-caller EIP
  29   ;; create exception frame
  30   (exc-frame-ptr) @ >r
  31   ;; section to save various custom data
  32   0 >r (catch-saver)
  33   ;;(self@) >r
  34   ;;(locptr@) >r
  35   ;; custom data section end
  36   sp@ >r
  37   rp@ (exc-frame-ptr) !  ;; update exception frame pointer
  38   execute  ;; and execute
  39   ;; we will return here only if no exception was thrown
  40   rdrop begin r> ?dup while false swap execute repeat
  41   ;;3 nrdrop  ;; drop spdepth, locptr, self
  42   r> (exc-frame-ptr) !   ;; restore previous exception frame
  43   0        ;; exception code (none)
  44 ;
  45
  46
  47 : THROW  ( k * x n -- k * x | i * x n )
  48   ?dup if
  49     ;; check if we have exception frame set
  50     (exc-frame-ptr) @ ?dup ifnot
  51       ;; panic!
  52       (exc0!)
  53       state 0!  ;; just in case
  54       fatal-error  ;; err-throw-without-catch (error)
  55       1 n-bye ;; just in case
  56     endif
  57     ;; check if return stack is not exhausted
  58     rp@ cell- over u> if
  59       ;; panic!
  60       (exc0!)
  61       state 0!  ;; just in case
  62       err-throw-chain-corrupted fatal-error
  63       1 n-bye ;; just in case
  64     endif
  65     rp!  ;; restore return stack
  66     r> swap >r  ;; exchange return stack top and data stack top (save exception code, and pop sp to data stack)
  67     ;; blindly restore data stack (let's hope it is not too badly trashed)
  68     sp! drop  ;; drop the thing that was CFA
  69     r>  ;; restore exception code
  70     ;; restore custom data
  71     begin r> ?dup while true swap execute repeat
  72     ;;r> (locptr!)
  73     ;;r> (self!)
  74     ;; restore previous exception frame
  75     r> (exc-frame-ptr) !
  76     ;; now EXIT will return to CATCH caller
  77   endif
  78 ;