Untitled

' | alias \
\ A quick implementation of tester.fs functionality.
\ neal@quartus.net August 2006, for rf 9.2.6
\ Version 0.1 fixed a small issue with what error displayed.
\ Version 0.2 has a working ?dup -- the one in the ANS rf code was broken.
\ Now {{ -> }} tests will succeed.
\ Version 0.3, added empty-stack.

\ A few helpful definitions lifted from the rf ANS compatibility file:

loc:
  : sp@ dup [ $f089 2, ]  ;
  reset sp@ constant base
 :: base sp@ - 4 / 1- ;
;loc alias depth

macro
: else  $e9 1, here 0 , swap dup here swap - 4 - swap ! ;

macro : leave x: rdrop x: rdrop x: ;; ; forth

: abort rdrop reset ['] boot execute ;

\ A working ?dup
: ?dup dup if dup then ;

\ A .s that only displays what's on the actual stack.

: (.s)  depth 0 swap < if >r (.s) r> dup . then ;
: .s  depth  ." <" # ." > " (.s) cr ;


\ tester.fs functionality:

variable actual-depth
create actual-results 20 cells allot

variable temp>in

: empty-stack
  depth ?dup if for drop next then ;

: error  
  type
  type temp>in @ >in @ over - type cr empty-stack abort
;

: {{  >in @ 3 - temp>in ! ;
: }}
  depth actual-depth @ = if
    depth ?dup if
      for
        actual-results r 1- cells + @
        <> if s" Incorrect result: " error  leave then
      next
    then
  else
    s" Wrong number of results: " error
  then ;

: ->
  depth dup actual-depth !
  ?dup if
    for actual-results r 1- cells + ! next
  then ;


\ Example tests:

{{ -> }} 
{{ 3 5 + -> 8 }}
{{ true not -> false }}
{{ 22 7 /mod -> 1 3 }}