( Title: A utiility for testing qstack effects File: qtester.fs Author: David N. Williams License: Public Domain, John Hayes Version: 1.4.3, January 18, 2021 Generated: January 18, 2021 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. ) \ *** USAGE ( PUBLIC INTERFACE WORDS tests: Q{ Q-> }Q config: MAX-QT-INITIALS MAX-QT-RESULTS PUBLIC AUXILIARY WORDS errors: QT-ERROR-XT QT-ERROR-DEFAULT QT-ERROR-INDEX arrays: QT-INITIALS QT-RESULTS QT-GOALS QT-A@ QT-A! QT-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 QT-ERROR-INDEX. The file qtester-errors.fs does that, and is loaded by gmpfr-test.fs. The basic test usage takes the form: ) \ ( qinitials) Q{ Q-> }Q ( qinitials) ( Angle brackets around a data designation for a particular stack indicate code that produces the data. Here qinitials stands for possibly nonempty qstack contents at the start of the test. The sequence starting with Q{ saves the qinitials and removes them from the qstack, executes the code that produces the qstack qresults, saves and removes the qresults from the qstack, executes the code that produces the qstack qgoals, saves and removes them, compares the saved qresults and qgoals, reports when there is a discrepancy between the two, and restores the saved qinitials. The words Q{, Q->, and }Q ignore non-qstacks. Many examples can be found in the file gmpfr-test.fs. Storage of qinitials, qresults, and qgoals 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-QT-INITIALS MAX-QT-RESULTS The xt in the variable QT-ERROR-XT can be changed only *after* loading this file. Loading qtester.fs does not change BASE. ) BASE @ DECIMAL \ *** ERRORS VARIABLE QT-ERROR-XT VARIABLE QT-ERROR-INDEX \ set to zero after unequal array size \ comparison, or [index+1] after deepest \ unequal element comparison at index : QT-ERROR-DEFAULT ( c-addr u -- ) ( Display an error message followed by the line that had the error. ) TYPE SOURCE TYPE CR ; ' QT-ERROR-DEFAULT QT-ERROR-XT ! : QT-ERROR QT-ERROR-XT @ EXECUTE ; \ vectored error reporting \ *** ARRAYS ( The first array slot has index zero. A tick prefix means "address". ) \ USER CONFIG DEFAULTS [UNDEFINED] MAX-QT-INITIALS [IF] 32 CONSTANT MAX-QT-INITIALS [THEN] [UNDEFINED] MAX-QT-RESULTS [IF] 32 CONSTANT MAX-QT-RESULTS [THEN] \ Array buffers begin with a cell-sized count. CREATE QT-INITIALS MAX-QT-INITIALS 1+ CELLS ALLOT CREATE QT-RESULTS MAX-QT-RESULTS 1+ CELLS ALLOT CREATE QT-GOALS MAX-QT-RESULTS 1+ CELLS ALLOT : 0QT-A ( +n 'buf -- ) \ assume n<>0 ( Initialize the array buffer for garbage collection by clearing the count and n qelement addresses. ) swap 1+ cells over + swap DO 0 i ! 1 cells +LOOP ; MAX-QT-INITIALS QT-INITIALS 0QT-A MAX-QT-RESULTS QT-RESULTS 0QT-A MAX-QT-RESULTS QT-GOALS 0QT-A \ Overflow checking to be done elsewhere. : QT-A! ( +n 'buf -- ) ( q: q_[n-1] ... q_0 -- ) 2dup ! cell+ swap ( 'elems n) dup IF cells over + swap DO i q! 1 cells +LOOP ELSE 2drop THEN ; : QT-A@ ( 'buf -- +n ) ( q: -- q_[n-1] ... q_0 ) dup @ dup >r ( 'buf n r: n) IF cell+ r@ 1- cells over + DO i q@ -1 cells +LOOP ELSE drop THEN r> ; [UNDEFINED] CELL- [IF] : CELL- ( addr -- addr-cell ) [ 1 CELLS ] LITERAL - ; [THEN] : QT-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 q@ q@ q= 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 : Q{ ( q: qinitials -- ) ( Save the qinitials for restoration by }Q, leaving the qstack empty. Clear qresults and qgoals storage. ) qdepth dup MAX-QT-INITIALS > ABORT" TOO MANY QINITIALS" QT-INITIALS QT-A! 0 QT-RESULTS ! 0 QT-GOALS ! ; : Q-> ( q: qesults -- ) ( Save the qresults, leaving the qstack empty. ) qdepth dup MAX-QT-RESULTS > ABORT" TOO MANY QRESULTS" QT-RESULTS QT-A! ; : }Q ( q: qgoals -- qinitials ) ( Save the qgoals, compare them with the saved qresults, and restore the qinitials. If the number of qresults is not the same as the number of qgoals, store zero in QT-ERROR-INDEX and execute the QT-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 QT-ERROR-INDEX and execute the QT-ERROR vector. ) qdepth dup MAX-QT-RESULTS > ABORT" TOO MANY QGOALS" QT-GOALS QT-A! QT-RESULTS QT-GOALS QT-A= ( 0 true | 0 false | index+1 false) IF ( 0) drop ELSE dup QT-ERROR-INDEX ! IF S" INCORRECT QRESULT: " ELSE S" WRONG NUMBER OF QRESULTS: " THEN QT-ERROR THEN QT-INITIALS QT-A@ ( len) drop ; BASE ! \ *** END of qtester.fs