Backtracking in Forth through exceptions

backtrack.fs

VARIABLE HANDLER

0 HANDLER !

: CATCH ( xt -- exception# | 0      \ return addr on stack )
   SP@ >R	            ( xt )  \ save data stack pointer
   HANDLER @ >R	      ( xt )        \ and previous handler
   RP@ HANDLER !	     ( xt ) \ set current handler
   EXECUTE	           ( )      \ execute returns if no THROW
   R> HANDLER !	      ( )           \ restore previous handler
   R> DROP	           ( )      \ discard saved stack ptr
   0                 ( 0 )          \ normal completion
;

: THROW ( ??? exception# -- ??? exception# )
    ?DUP IF	         ( exc# )         \ 0 THROW is no-op
      HANDLER @ RP!   ( exc# )            \ restore prev return stack
      R> HANDLER !	   ( exc# )       \ restore prev handler
      R> SWAP >R	     ( saved-sp ) \ exc# on return stack
      SP! DROP R>	    ( exc# )      \ restore stack
                                          \ Return to the caller of CATCH because return
                                          \ stack is restored to the state that existed
                                          \ when CATCH began execution
    THEN
;

PAGE
." Backtracking" CR

: PUSH-RETURN ( RET-STACK1 RET-ADDR -- RET-STACK2 )
 HERE 2 CELLS ALLOT
 SWAP OVER CELL+ !
 SWAP OVER ! ;

: POP-RETURN ( RET-SATCK1 -- RET-STACK2 RET-ADDR )
    DUP CELL+ @ 
    SWAP @ ;

: CHOICE
   \ WORKS LIKE RETURN ( RET-STACK1 -- RET-STACK2 ), BUT CREATES A CHOICEPOINT
   \ I.E., IT CATCHES A FAILURE; 
   \ EXITS UPON FAILURE WITH STACK EFFECT ( RET-STACK -- )
   POP-RETURN CATCH
   DUP 1 <> IF \ IT'S NOT A FAILURE, BUT SOMETHING ELSE
       THROW
   THEN
   DROP ;



: RETURN ( RET-STACK1 -- RET-STACK2 ) 
\ NEVER EXITS; STACK-EFFECT WITH RESPECT TO THE WORD RETURNED TO.
    POP-RETURN EXECUTE ;


: FAIL \ NEITHER EXITS NOR RETURNS
 1 THROW ;

: BEGIN-CHOICES ' >R , ; IMMEDIATE
: END-CHOICES  ' R> , ' RETURN , ; IMMEDIATE
: MAYBE ' R@ , ' CHOICE , ; IMMEDIATE

: ONE-TO-FOUR ( RET-STACK1 -- N RET-STACK2 )
BEGIN-CHOICES
 1 MAYBE 2 MAYBE 3 MAYBE 4
END-CHOICES
;

: FOO-PART2 ( RET-STACK -- ... ) \ NEVER EXITS, NEVER RETURNS
\ WE CAN TREAT "." AS PRIMITIVE HERE; IT DOES NOT DO CHOICEPOINTS, FAILURE ETC.
    >R . FAIL ;

: FOO ( RET-STACK -- ... ) \ NEVER EXITS, NEVER RETURNS
    ' FOO-PART2 SWAP PUSH-RETURN ONE-TO-FOUR ;


: SUCCESS-THROW
    \ GET OUT OF THE RETURN/BACKTRACKING MODE
    2 THROW ;

: WRAPPER ( XT -- )
    \ EXECUTE XT IN RETURN/BACKTRACKIN MODE
    ' SUCCESS-THROW 0 PUSH-RETURN SWAP CATCH
    CASE
      1 OF ." FAILURE" ENDOF
      2 OF ." SUCCESS" ENDOF
      THROW
    ENDCASE ;

' FOO WRAPPER

SHUTDOWN