\ Copyright 2021 Bradley D. Nelson 
\ 
\ Licensed under the Apache License, Version 2.0 (the "License"); 
\ you may not use this file except in compliance with the License. 
\ You may obtain a copy of the License at 
\ 
\     http://www.apache.org/licenses/LICENSE-2.0 
\ 
\ Unless required by applicable law or agreed to in writing, software 
\ distributed under the License is distributed on an "AS IS" BASIS, 
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 
\ See the License for the specific language governing permissions and 
\ limitations under the License. 
 
also ansi also internals 
 
( Support for eval tests ) 
40000 constant expect-limit 
create expect-buffer expect-limit allot 
create result-buffer expect-limit allot 
variable expect-used   variable result-used 
: till;e ( -- n ) 
   begin >in @ bl parse dup 0= >r s" ;e" str= r> or if exit then drop again ; 
: e: ( "name" -- ) create >in @ 
   till;e over - swap tib + swap dup , $place 
   does> dup cell+ swap @ evaluate ; 
: expect-emit ( ch -- ) expect-used @ expect-limit < assert 
                        expect-buffer expect-used @ + c! 
                        1 expect-used +! ; 
: result-emit ( ch -- ) result-used @ expect-limit < assert 
                        result-buffer result-used @ + c! 
                        1 result-used +! ; 
: expect-type ( a n -- ) for aft dup c@ expect-emit 1+ then next drop ; 
: result-type ( a n -- ) for aft dup c@ result-emit 1+ then next drop ; 
: expected ( -- a n ) expect-buffer expect-used @ ; 
: resulted ( -- a n ) result-buffer result-used @ ; 
: out:cr   13 expect-emit nl expect-emit ; 
: out:\ ( "line" -- ) nl parse expect-type ; 
: out: ( "line" -- ) out:\ out:cr ; 
variable confirm-old-type 
: confirm{   ['] type >body @ confirm-old-type ! ['] result-type is type ; 
: }confirm   confirm-old-type @ is type ; 
: expect-reset   0 expect-used ! 0 result-used ! ; 
: diverged ( a n a n -- a n ) 
   begin 
      dup 0= if 2drop exit then 
      >r dup c@ >r rot dup c@ >r -rot r> r> <> r> swap if 2drop exit then 
      >r >r dup 0= if rdrop rdrop exit then r> r> 
      >r >r >r 1+ r> 1- r> 1+ r> 1- 
   again 
; 
: stars ( n -- ) 1- for 42 emit next ; 
: expect-finish   expected resulted str= if exit then }confirm 
   cr ." Expected:" cr expected resulted diverged type 30 stars cr 
      ." Resulted:" cr resulted expected diverged type 30 stars cr 1 throw ; 
 
( Better error asserts ) 
: =assert ( actual expected -- ) 
  2dup <> if }confirm ."   FAILURE! EXPECTED: " . 
                      ." ACTUAL: " . space 0 assert then 2drop ; 
: ( actual expected -- ) 
  2dup >= if }confirm ."   MUST BE LESS THAN: " . 
                      ." ACTUAL: " . space 0 assert then 2drop ; 
: >assert ( actual expected -- ) 
  2dup <= if }confirm ."   MUST BE GREATER THAN: " . 
                      ." ACTUAL: " . space 0 assert then 2drop ; 
 
( Input testing ) 
create in-buffer 1000 allot 
variable in-head   variable in-tail 
: >in ( c -- ) in-buffer in-head @ + c!  1 in-head +! ; 
: in> ( -- c ) in-tail @ in-head @ @ + c@  1 in-tail +! 
               in-head @ in-tail @ = if 0 in-head ! 0 in-tail ! then ; 
: s>in ( a n -- ) for aft dup c@ >in 1+ then next drop ; 
: in: ( "line" -- ) nl parse s>in nl >in ; 
' in> is key 
 
( Testing Framework ) 
( run-tests runs all words starting with "test-", use assert to assert things. ) 
variable tests-found   variable tests-run    variable tests-passed 
: test? ( xt -- f ) >name s" test-" startswith? ; 
: for-tests ( xt -- ) 
   context @ @ begin dup while dup test? if 2dup >r >r swap execute r> r> then >link repeat 2drop ; 
: reset-test-counters   0 tests-found !   0 tests-run !   0 tests-passed ! ; 
: count-test ( xt -- ) drop 1 tests-found +! ; 
: check-fresh   depth if }confirm ."  DEPTH LEAK! " depth . 1 throw then 
                fdepth if }confirm ."  FDEPTH LEAK! " fdepth . 1 throw then ; 
: wrap-test ( xt -- ) expect-reset >r check-fresh r> execute check-fresh expect-finish ; 
: red   1 fg ;   : green   2 fg ;   : hr   40 for [char] - emit next cr ; 
: replace-line   13 emit clear-to-eol ; 
: label-test ( xt -- ) replace-line >name type ; 
: run-test ( xt -- ) dup label-test only forth confirm{ ['] wrap-test catch }confirm 
   if drop ( cause xt restored on throw ) red ."  FAILED" normal cr 
   else green ."  OK" normal 1 tests-passed +! then 1 tests-run +! ; 
: show-test-results 
   replace-line hr 
   ."   PASSED: " green tests-passed @ . normal 
   ."   RUN: " tests-run @ . 
   ."   FOUND: " tests-found @ . cr 
   tests-passed @ tests-found @ = if 
     green ."   ALL TESTS PASSED" normal cr 
   else 
     ."   FAILED: " red tests-run @ tests-passed @ - . normal cr 
   then hr ; 
: run-tests 
   reset-test-counters ['] count-test for-tests 
   ['] run-test for-tests show-test-results 
   tests-passed @ tests-found @ <> terminate ; 
only forth 
 

Legal: site web personnel sans commerce / personal site without seling