testing.af

import' ./lang.af

\ Similar to the common Forth testing words:
\
\   https://forth-standard.org/standard/testsuite
\
\ Example tests:
\
\   T{ 10 20    <T> 10 20    } \ OK
\   T{ 10 20    <T> 10 20 30 } \ fail
\   T{ 10 20 30 <T> 10 20    } \ fail
\
\ Internal note. In intepretation, testing uses the default stack,
\ provided by the interpreter (`STACK`). In compiled code, testing
\ uses its own custom stack for compatibility with AOT compilation.

: testing_stack_eq { len0 len1 len stk -- equal }
  len 0 +for: ind
    ind len0 + stk stack_at @ { one }
    ind len1 + stk stack_at @ { two }
    one two <> if false ret end
  end
  true
;

: testing_stack_log { len0 len1 len2 stk }
  " T{ " elog

  len1 len0 +for: ind
    ind stk stack_at @ { val }
    " %zd " val elogf
  end

  " <T> " elog

  len2 ind +for: ind
    ind stk stack_at @ { val }
    " %zd " val elogf
  end

  " }T" elog elf
;

\ ## Interpretation-mode test routines (top level)

\ Used only in interpretation.
0 var: T_ST_LEN_0 \ Stack length at `T{`.
0 var: T_ST_LEN_1 \ Stack length at `<T>`.

: testing_interp_reset { stk }
  T_ST_LEN_0 @ stk stack_len_set
  T_ST_LEN_0 off!
  T_ST_LEN_1 off!
;

: T{  STACK stack_len T_ST_LEN_0 ! ;
: <T> STACK stack_len T_ST_LEN_1 ! ;

\ 10 20   T{   30 40   <T>   50 60   }T
\         ^ len0 = 2   ^ len1 = 4    ^ len2 = 6
\                      ^ rel0 = 2    ^ rel1 = 2
: }T
  STACK         { stk  }
  stk stack_len { len2 } \ Length at `}T`.
  T_ST_LEN_1 @  { len1 } \ Stack length at `<T>`.
  T_ST_LEN_0 @  { len0 } \ Stack length at `T{`.
  len1 len0 -   { rel0 } \ Relative length before `<T>`.
  len2 len1 -   { rel1 } \ Relative length after `<T>`.

  \ Does the stack length match?
  rel0 rel1 =
  if
    \ Does the content match?
    len0 len1 rel1 stk testing_stack_eq
    if stk testing_interp_reset ret end
  else
    " [test] stack length mismatch: (%zd) <T> (%zd)" rel0 rel1 elogf elf
  end

  " [test] stack content mismatch: " elog
  len0 len1 len2 stk testing_stack_log

  stk testing_interp_reset
  " test failure" throw
  unreachable
;

\ ## Compilation-mode test routines (inside words)

Stack mem: TEST_STACK
false var: TEST_STACK_INITED_AOT \ Must remain `false` in JIT.

32 TEST_STACK stack_init

\ Captured at `<T>`, used only in compilation. We could have used
\ the regular control stack for this, but using a dedicated place
\ is probably more reliable, since buggy code could clobber that.
0 var: TEST_ARG_LEN

\ Needed in AOT execution.
\
\ We initialize `TEST_STACK` in initial interpretation. AOT compilation
\ preserves the state of the stack header, but the addresses it contains
\ are no longer valid, since the memory was requested from the OS and is
\ not managed by the compiler. This re-inits the stack in AOT, making it
\ valid again.
\
\ TODO: general solution for similar cases.
: testing_stack_init_aot
  has_interp if ret end
  TEST_STACK_INITED_AOT @ if ret end
  32 TEST_STACK stack_init
  TEST_STACK_INITED_AOT on!
;

: testing_compiled_reset
  TEST_STACK stack_clear
  TEST_ARG_LEN off!
;

: testing_compile_push_args { len }
  len ifn ret end

  len     { stk_reg }
  len inc { top_reg }

  stk_reg comp_clobber
  top_reg comp_clobber

  TEST_STACK stk_reg         comp_page_addr
  len        stk_reg top_reg comp_args_to_stack
  0                          comp_args_set
;

:: T{
  " when calling `T{`" 0 comp_args_valid

  TEST_ARG_LEN @ if
    " internal error: non-empty `TEST_ARG_LEN` at `T{`"
    throw
  end

  \ Briefly disabling auto-catching allows testing to work
  \ seamlessly in tests annotated with `[ true catches ]`.
  get_catches { ok }
  ok if false catches end
  compile' testing_stack_init_aot
  ok if true catches end
;

:: <T>
  comp_args_get { len }
  len testing_compile_push_args
  len TEST_ARG_LEN !
;

\ Modified from `}T` to be more suitable for compiled code in reg-CC.
: testing_compiled_end { arg_len } [ true catches ]
  TEST_STACK  { stk  }
  0           { len0 } \ T{
  arg_len     { len1 } \ <T>
  arg_len 2 * { len2 } \ }T

  len0 len1 arg_len stk testing_stack_eq
  if
    testing_compiled_reset
    ret
  end

  " [test] mismatch: " elog
  len0 len1 len2 stk testing_stack_log

  testing_compiled_reset
  " test failure" throw
  unreachable
;

:: }T
  TEST_ARG_LEN @ { len }
  TEST_ARG_LEN off!

  " when calling `}T`" len comp_args_valid

  len testing_compile_push_args
  len comp_push

  \ Briefly disabling auto-catching allows testing to work
  \ seamlessly in tests annotated with `[ true catches ]`.
  get_catches { ok }
  ok if false catches end
  compile' testing_compiled_end
  ok if true catches end
;