( Title: A utiility for testing %x%stack effects
File: %x%tester.fs
Author: David N. Williams
License: Public Domain, John Hayes
Version: 1.4.3, January 18, 2021
Generated: %DATE% from tester.tmpl
For any code derived from John Hayes' tester program:
)
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
(
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
The rest is public domain, based on the ttester derivative by Anton Ertl
and its xftester derivative by David N. Williams.
)
\ *** HOW TO GENERATE A NEW TESTER
(
This file is a template for generating two Hayes-style testers, for
words that operate on the Forth-gmpfr stacks of cell-sized record
pointers for big numbers or big rationals. It is to be translated by
substituting replacements for text elements including a leading and
trailing % as in %NAME%, for example, by using the search and replace
function of a text editor, or a script based on the Forth 2012 words
SUBSTITUTE and REPLACES.
There are two essential substitutions, one for %X% and one for %x%,
which are to be replaced by the upper and lower case versions,
respectively, of a text token not containing white space. The date of
generation can also be substituted for %DATE%, which appears only in the
header above; and the test file for the tester should be substituted for
%TESTER-TEST% in the USAGE section below.
The code assumes that fetch, store, equality, stack depth and a few
other words are defined for the separated stack, with names resulting
from the substitutions in patterns such as %x%@, %x%!, %x%=, and
%x%depth or %X%DEPTH.
There is a little bit of code that is needed to initialize arrays used
to store data from stacks that are consistent with our garbage-collected
record stack scheme. Although this template is currently applied only
to such stacks, that code is marked as REMOVABLE FOR STACKS WITH NO GC.
This section, HOW TO GENERATE A NEW TESTER, should be removed from the
generated file. In any case, if its text undergoes substitution, it
will become incoherent. The copyright and license in the header above
should be retained.
)
\ *** USAGE
(
PUBLIC INTERFACE WORDS
tests: %X%{ %X%-> }%X%
config: MAX-%X%T-INITIALS MAX-%X%T-RESULTS
PUBLIC AUXILIARY WORDS
errors: %X%T-ERROR-XT %X%T-ERROR-DEFAULT %X%T-ERROR-INDEX
arrays: %X%T-INITIALS %X%T-RESULTS %X%T-GOALS
%X%T-A@ %X%T-A! %X%T-A=
The public interface words are all that are needed for normal testing.
The public auxiliary words are made available for users who want to
implement more elaborate error reporting, such as counting errors, or
dumping results and goals when something is wrong, or reporting a
particular error with the help of %X%T-ERROR-INDEX. The file
%x%tester-errors.fs does that, and is loaded by %TESTER-TEST%.
The basic test usage takes the form:
)
\ ( %x%initials) %X%{ <%x%results> %X%-> <%x%goals> }%X% ( %x%initials)
(
Angle brackets around a data designation for a particular stack indicate
code that produces the data. Here %x%initials stands for possibly
nonempty %x%stack contents at the start of the test. The sequence
starting with %X%{ saves the %x%initials and removes them from the %x%stack,
executes the code <%x%results> that produces the %x%stack %x%results, saves
and removes the %x%results from the %x%stack, executes the <%x%goals> code
that produces the %x%stack %x%goals, saves and removes them, compares the
saved %x%results and %x%goals, reports when there is a discrepancy between
the two, and restores the saved %x%initials.
The words %X%{, %X%->, and }%X% ignore non-%x%stacks.
Many examples can be found in the file %TESTER-TEST%.fs.
Storage of %x%initials, %x%results, and %x%goals includes overflow checking.
The user can change the storage allocation by defining one or both of the
following CONSTANT's *before* loading this file:
MAX-%X%T-INITIALS MAX-%X%T-RESULTS
The xt in the variable %X%T-ERROR-XT can be changed only *after* loading
this file.
Loading %x%tester.fs does not change BASE.
)
BASE @ DECIMAL
\ *** ERRORS
VARIABLE %X%T-ERROR-XT
VARIABLE %X%T-ERROR-INDEX \ set to zero after unequal array size
\ comparison, or [index+1] after deepest
\ unequal element comparison at index
: %X%T-ERROR-DEFAULT ( c-addr u -- )
(
Display an error message followed by the line that had the error.
)
TYPE SOURCE TYPE CR ;
' %X%T-ERROR-DEFAULT %X%T-ERROR-XT !
: %X%T-ERROR %X%T-ERROR-XT @ EXECUTE ; \ vectored error reporting
\ *** ARRAYS
(
The first array slot has index zero. A tick prefix means "address".
)
\ USER CONFIG DEFAULTS
[UNDEFINED] MAX-%X%T-INITIALS [IF] 32 CONSTANT MAX-%X%T-INITIALS [THEN]
[UNDEFINED] MAX-%X%T-RESULTS [IF] 32 CONSTANT MAX-%X%T-RESULTS [THEN]
\ Array buffers begin with a cell-sized count.
CREATE %X%T-INITIALS MAX-%X%T-INITIALS 1+ CELLS ALLOT
CREATE %X%T-RESULTS MAX-%X%T-RESULTS 1+ CELLS ALLOT
CREATE %X%T-GOALS MAX-%X%T-RESULTS 1+ CELLS ALLOT
\ BEGIN: REMOVABLE FOR STACKS WITH NO GC
: 0%X%T-A ( +n 'buf -- ) \ assume n<>0
(
Initialize the array buffer for garbage collection by clearing the count
and n %x%element addresses.
)
swap 1+ cells over + swap DO 0 i ! 1 cells +LOOP ;
MAX-%X%T-INITIALS %X%T-INITIALS 0%X%T-A
MAX-%X%T-RESULTS %X%T-RESULTS 0%X%T-A
MAX-%X%T-RESULTS %X%T-GOALS 0%X%T-A
\ END: REMOVABLE FOR STACKS WITH NO GC
\ Overflow checking to be done elsewhere.
: %X%T-A! ( +n 'buf -- ) ( %x%: %x%_[n-1] ... %x%_0 -- )
2dup ! cell+ swap ( 'elems n) dup
IF cells over + swap
DO i %x%! 1 cells +LOOP
ELSE 2drop THEN ;
: %X%T-A@ ( 'buf -- +n ) ( %x%: -- %x%_[n-1] ... %x%_0 )
dup @ dup >r ( 'buf n r: n)
IF cell+ r@ 1- cells over +
DO i %x%@ -1 cells +LOOP
ELSE drop THEN r> ;
[UNDEFINED] CELL- [IF]
: CELL- ( addr -- addr-cell ) [ 1 CELLS ] LITERAL - ;
[THEN]
: %X%T-A= ( 'buf1 'buf2 -- 0 true | 0 false | index+1 false )
(
Returns:
0 true: equal size and elements
0 false: sizes unequal
index+1 false: sizes equal, deepest unequal elements at index
)
2dup @ swap @ <>
IF 2drop 0 false EXIT THEN \ unequal size
dup @ 0= IF 2drop 0 true EXIT THEN \ equal size and empty
2>r 0 true 2r>
( 0 true 'buf1 'buf2)
dup @ ( count) 1- ( last) >r
cell+ r@ cells + swap
cell+ r@ cells + 0 r>
( 0 true 'elems2_last 'elems1_last 0 last)
DO
2dup %x%@ %x%@ %x%= 0=
IF \ unequal elements
2drop ( 0 true) 2drop i 1+ false 0 0 LEAVE THEN
cell- swap cell- \ [i-1]th element addresses interchanged
-1 +LOOP
( [0 true | i+1 false] x1 x2) 2drop ;
\ *** TESTS
: %X%{ ( %x%: %x%initials -- )
(
Save the %x%initials for restoration by }%X%, leaving the %x%stack empty.
Clear %x%results and %x%goals storage.
)
%x%depth dup MAX-%X%T-INITIALS > ABORT" TOO MANY %X%INITIALS"
%X%T-INITIALS %X%T-A! 0 %X%T-RESULTS ! 0 %X%T-GOALS ! ;
: %X%-> ( %x%: %x%esults -- )
(
Save the %x%results, leaving the %x%stack empty.
)
%x%depth dup MAX-%X%T-RESULTS > ABORT" TOO MANY %X%RESULTS"
%X%T-RESULTS %X%T-A! ;
: }%X% ( %x%: %x%goals -- %x%initials )
(
Save the %x%goals, compare them with the saved %x%results, and restore the
%x%initials. If the number of %x%results is not the same as the number of
%x%goals, store zero in %X%T-ERROR-INDEX and execute the %X%T-ERROR vector.
Else, if the numbers are the same but there is a deepest comparison
failure at the index-th element, store index+1 in %X%T-ERROR-INDEX and
execute the %X%T-ERROR vector.
)
%x%depth dup MAX-%X%T-RESULTS > ABORT" TOO MANY %X%GOALS"
%X%T-GOALS %X%T-A!
%X%T-RESULTS %X%T-GOALS %X%T-A= ( 0 true | 0 false | index+1 false)
IF
( 0) drop
ELSE
dup %X%T-ERROR-INDEX !
IF S" INCORRECT %X%RESULT: " ELSE S" WRONG NUMBER OF %X%RESULTS: " THEN
%X%T-ERROR
THEN
%X%T-INITIALS %X%T-A@ ( len) drop ;
BASE !
\ *** END of %x%tester.fs