crtest.fth

\ Conditions and restarts --- Test suite
\ Uses conres.fth and tester.fth

\ THROW and CATCH

: TEST-NOTHROW   ;
: TEST-NOCATCH   ['] TEST-NOTHROW CATCH ;
T{ TEST-NOCATCH -> 0 }T

: TEST-UNDERTHROW   >F THROW ;
: TEST-UNDERCATCH   1 2 >F 3   ['] TEST-UNDERTHROW CATCH AND   F> ;
T{ TEST-UNDERCATCH -> 1 2 }T

: TEST-OVERTHROW   4 5 THROW ;
: TEST-OVERCATCH   3   ['] TEST-OVERTHROW CATCH AND ;
T{ TEST-OVERCATCH -> 3 4 5 }T

: TEST-NESTTHROW   TEST-NOCATCH TEST-UNDERCATCH
  TEST-OVERCATCH THROW ;
: TEST-NESTCATCH   -2 -1 ['] TEST-NESTTHROW CATCH AND ;
T{ TEST-NESTCATCH -> -2 -1 0 1 2 3 4 5 }T

\ SIGNAL, RESPOND, and PASS

: TEST-RESPOND-S   2 SIGNAL ;
: TEST-RESPOND-R   DROP 1 - ;
: TEST-RESPOND  ['] TEST-RESPOND-S ['] TEST-RESPOND-R RESPOND
  RESPONSE @ FP0 CELL+ = AND ;
T{ TEST-RESPOND -> 1 }T

: TEST-PASS-S   1 SIGNAL ;
: TEST-PASS-R   3 SWAP PASS ;
: TEST-PASS-T   ['] TEST-PASS-S ['] TEST-PASS-R   RESPOND ;
: TEST-PASS   ['] TEST-PASS-T ['] TEST-RESPOND-R RESPOND
  RESPONSE @ FP0 CELL+ = AND ;
T{ TEST-PASS -> 1 2 }T

\ ESCAPE and RESUME

: TEST-NOESCAPE-A   DROP ;
: TEST-NOESCAPE   ['] TEST-NOESCAPE-A RESUME ;
T{ TEST-NOESCAPE -> 0 }T

: TEST-INNERESCAPE-A   1 SWAP ESCAPE ;
: TEST-INNERESCAPE   ['] TEST-INNERESCAPE-A RESUME AND ;
T{ TEST-INNERESCAPE -> 1 }T

: TEST-OUTERESCAPE-A   DROP 2 SWAP ESCAPE ;
: TEST-OUTERESCAPE-B   ['] TEST-OUTERESCAPE-A RESUME ;
: TEST-OUTERESCAPE   ['] TEST-NOESCAPE RESUME OR NIP
  ['] TEST-INNERESCAPE RESUME OR NIP
  ['] TEST-OUTERESCAPE-B RESUME AND ;
T{ TEST-OUTERESCAPE -> 0 1 2 }T

\ Class system

: TEST-TOP   TOP   DUP @ SWAP   CELL- DUP @ SWAP   DROP ;
T{ TEST-TOP -> 1 CELLS TOP }T

: >FROB   CELL+ ;
TOP CLONE FOO   2 ,
: TEST-FOO   FOO   DUP @ SWAP   CELL- DUP @ SWAP
  CELL- DUP @ SWAP   DROP   FOO >FROB @ ;
T{ TEST-FOO -> 2 CELLS TOP FOO 2 }T

FOO CLONE BAR   57 ,
: TEST-BAR   BAR   DUP @ SWAP   CELL- DUP @ SWAP
  CELL- DUP @ SWAP   CELL- DUP @ SWAP   DROP   BAR >FROB @ ;
T{ TEST-BAR -> 3 CELLS TOP FOO BAR 57 }T

BAR CLONE BAZ   179 ,
: TEST-BAZ   BAZ   DUP @ SWAP   CELL- DUP @ SWAP
  CELL- DUP @ SWAP   CELL- DUP @ SWAP   CELL- DUP @ SWAP
  DROP   BAZ >FROB @ ;
T{ TEST-BAZ -> 4 CELLS TOP FOO BAR BAZ 179 }T

: TEST-EXTENDS   FOO TOP EXTENDS   BAZ FOO EXTENDS
  BAR BAZ EXTENDS ;
T{ TEST-EXTENDS -> TRUE TRUE FALSE }T

\ HANDLE

? CLONE FOO?   ? >UNHANDLED @ , ? >DISPLAY @ ,

: TEST-HANDLE-S   1 FOO? SIGNAL ;
: TEST-HANDLE-H   ( c rf ) 2DROP 2 ;
: TEST-HANDLE   0 ['] TEST-HANDLE-S FOO? ['] TEST-HANDLE-H
  HANDLE ;
T{ TEST-HANDLE -> 0 1 2 }T

: UNHANDLED-BAR?   ( c ) DROP   1 = ;
? CLONE BAR?   ' UNHANDLED-BAR? , ? >DISPLAY @ ,

: TEST-NOHANDLE-S   1 BAR? SIGNAL ;
: TEST-NOHANDLE   0 ['] TEST-NOHANDLE-S FOO? ['] TEST-HANDLE-H
  HANDLE ;
T{ TEST-NOHANDLE -> 0 -1 }T

: TEST-NESTHANDLE   ['] TEST-NOHANDLE BAR? ['] TEST-HANDLE-H
  HANDLE ;
T{ TEST-NESTHANDLE -> 0 1 2 }T

\ RESTART

RESTART? CLONE QUUX?   RESTART? >UNHANDLED @ ,
  RESTART? >DISPLAY @ , RESTART? >NAME 2@ , ,
  RESTART? >DESCRIBE @ ,

: TEST-RESTART-S   1 QUUX? SIGNAL ;
: TEST-RESTART   0 ['] TEST-RESTART-S QUUX? RESTART IF
   QUUX? = 2 AND   THEN ;
T{ TEST-RESTART -> 0 1 2 }T