\ FOR THE ORIGINAL TESTER \ FROM: JOHN HAYES S1I \ SUBJECT: TESTER.FR \ DATE: MON, 27 NOV 95 13:10:09 PST \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. \ VERSION 1.1 \ FOR THE FNEARLY= STUFF: \ FROM FTESTER.FS WRITTEN BY DAVID N. WILLIAMS, BASED ON THE IDEA OF \ APPROXIMATE EQUALITY IN DIRK ZOLLER'S FLOAT.4TH \ PUBLIC DOMAIN \ FOR THE REST: \ REVISED BY ANTON ERTL 2007-08-12, 2007-08-19, 2007-08-28 \ PUBLIC DOMAIN \ THE ORIGINAL HAS THE FOLLOWING SHORTCOMINGS: \ - IT DOES NOT WORK AS EXPECTED IF THE STACK IS NON-EMPTY BEFORE THE {. \ - IT DOES NOT CHECK FP RESULTS IF THE SYSTEM HAS A SEPARATE FP STACK. \ - THERE IS A CONFLICT WITH THE USE OF } FOR FSL ARRAYS AND { FOR LOCALS. \ I HAVE REVISED IT TO ADDRESS THESE SHORTCOMINGS. YOU CAN FIND THE \ RESULT AT \ HTTP://WWW.FORTH200X.ORG/TESTS/TESTER.FS \ HTTP://WWW.FORTH200X.ORG/TESTS/TTESTER.FS \ TESTER.FS IS INTENDED TO BE A DROP-IN REPLACEMENT OF THE ORIGINAL. \ TTESTER.FS IS A VERSION THAT USES T{ AND }T INSTEAD OF { AND } AND \ KEEPS THE BASE AS IT WAS BEFORE LOADING TTESTER.FS \ IN SPIRIT OF THE ORIGINAL, I HAVE STRIVED TO AVOID ANY POTENTIAL \ NON-PORTABILITIES AND STAYED AS MUCH WITHIN THE CORE WORDS AS \ POSSIBLE; E.G., FLOATING WORDS ARE USED ONLY IF THE FLOATING WORDSET \ IS PRESENT \ THERE ARE A FEW THINGS TO BE NOTED: \ - LOADING TTESTER.FS DOES NOT CHANGE BASE. LOADING TESTER.FS \ CHANGES BASE TO HEX (LIKE THE ORIGINAL TESTER). FLOATING-POINT \ INPUT IS AMBIGUOUS WHEN THE BASE IS NOT DECIMAL, SO YOU HAVE TO SET \ IT TO DECIMAL YOURSELF WHEN YOU WANT TO DEAL WITH DECIMAL NUMBERS. \ - FOR FP IT IS OFTEN USEFUL TO USE APPROXIMATE EQUALITY FOR CHECKING \ THE RESULTS. YOU CAN TURN ON APPROXIMATE MATCHING WITH SET-NEAR \ (AND TURN IT OFF (DEFAULT) WITH SET-EXACT, AND YOU CAN TUNE IT BY \ SETTING THE VARIABLES REL-NEAR AND ABS-NEAR. IF YOU WANT YOUR TESTS \ TO WORK WITH A SHARED STACK, YOU HAVE TO SPECIFY THE TYPES OF THE \ ELEMENTS ON THE STACK BY USING ONE OF THE CLOSING WORDS THAT SPECIFY \ TYPES, E.G. RRRX}T FOR CHECKING THE STACK PICTURE ( R R R X ). \ THERE ARE SUCH WORDS FOR ALL COMBINATION OF R AND X WITH UP TO 4 \ STACK ITEMS, AND DEFINING MORE IF YOU NEED THEM IS STRAIGHTFORWARD \ (SEE SOURCE). IF YOUR TESTS ARE ONLY INTENDED FOR A SEPARATE-STACK \ SYSTEM OR IF YOU NEED ONLY EXACT MATCHING, YOU CAN USE THE PLAIN }T \ INSTEAD. BASE @ HEX \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. VARIABLE VERBOSE FALSE VERBOSE ! VARIABLE ACTUAL-DEPTH \ STACK RECORD CREATE ACTUAL-RESULTS 20 CELLS ALLOT VARIABLE START-DEPTH VARIABLE XCURSOR \ FOR ...}T VARIABLE ERROR-XT : ERROR ERROR-XT @ EXECUTE ; : "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE : "FLOATING-STACK" S" FLOATING-STACK" ; "FLOATING" ENVIRONMENT? [IF] [IF] TRUE [ELSE] FALSE [THEN] [ELSE] FALSE [THEN] CONSTANT HAS-FLOATING "FLOATING-STACK" ENVIRONMENT? [IF] [IF] TRUE [ELSE] FALSE [THEN] [ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE HAS-FLOATING \ IF WE HAVE FLOATING, WE ASSUME IT IS [THEN] CONSTANT HAS-FLOATING-STACK HAS-FLOATING [IF] \ SET THE FOLLOWING TO THE RELATIVE AND ABSOLUTE TOLERANCES YOU \ WANT FOR APPROXIMATE FLOAT EQUALITY, TO BE USED WITH F~ IN \ FNEARLY=. KEEP THE SIGNS, BECAUSE F~ NEEDS THEM. FVARIABLE REL-NEAR DECIMAL 1E-12 HEX REL-NEAR F! FVARIABLE ABS-NEAR DECIMAL 0E HEX ABS-NEAR F! \ WHEN EXACT? IS TRUE, }F USES FEXACTLY=, OTHERWISE FNEARLY=. TRUE VALUE EXACT? : SET-EXACT ( -- ) TRUE TO EXACT? ; : SET-NEAR ( -- ) FALSE TO EXACT? ; DECIMAL : FEXACTLY= ( F: X Y -- S: FLAG ) ( LEAVE TRUE IF THE TWO FLOATS ARE IDENTICAL. ) 0E F~ ; HEX : FABS= ( F: X Y -- S: FLAG ) ( LEAVE TRUE IF THE TWO FLOATS ARE EQUAL WITHIN THE TOLERANCE STORED IN ABS-NEAR. ) ABS-NEAR F@ F~ ; : FREL= ( F: X Y -- S: FLAG ) ( LEAVE TRUE IF THE TWO FLOATS ARE RELATIVELY EQUAL BASED ON THE TOLERANCE STORED IN ABS-NEAR. ) REL-NEAR F@ FNEGATE F~ ; : F2DUP FOVER FOVER ; : F2DROP FDROP FDROP ; : FNEARLY= ( F: X Y -- S: FLAG ) ( LEAVE TRUE IF THE TWO FLOATS ARE NEARLY EQUAL. THIS IS A REFINEMENT OF DIRK ZOLLER'S FEQ TO ALSO ALLOW X = Y, INCLUDING BOTH ZERO, OR TO ALLOW APPROXIMATE EQUALITY WHEN X AND Y ARE TOO SMALL TO SATISFY THE RELATIVE APPROXIMATION MODE IN THE F~ SPECIFICATION. ) F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN F2DUP FREL= IF F2DROP TRUE EXIT THEN FABS= ; : FCONF= ( R1 R2 -- F ) EXACT? IF FEXACTLY= ELSE FNEARLY= THEN ; [THEN] HAS-FLOATING-STACK [IF] VARIABLE ACTUAL-FDEPTH CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT VARIABLE START-FDEPTH VARIABLE FCURSOR : EMPTY-FSTACK ( ... -- ... ) FDEPTH START-FDEPTH @ < IF FDEPTH START-FDEPTH @ SWAP DO 0E LOOP THEN FDEPTH START-FDEPTH @ > IF FDEPTH START-FDEPTH @ DO FDROP LOOP THEN ; : F{ ( -- ) FDEPTH START-FDEPTH ! 0 FCURSOR ! ; : F-> ( ... -- ... ) FDEPTH DUP ACTUAL-FDEPTH ! START-FDEPTH @ > IF FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F! LOOP THEN ; : F} ( ... -- ... ) FDEPTH ACTUAL-FDEPTH @ = IF FDEPTH START-FDEPTH @ > IF FDEPTH START-FDEPTH @ DO ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF S" INCORRECT FP RESULT: " ERROR LEAVE THEN LOOP THEN ELSE S" WRONG NUMBER OF FP RESULTS: " ERROR THEN ; : F...}T ( -- ) FDEPTH START-FDEPTH @ = 0= IF S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR THEN FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR THEN ; : FTESTER ( R -- ) FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT THEN ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF S" INCORRECT FP RESULT: " ERROR THEN 1 FCURSOR +! ; [ELSE] : EMPTY-FSTACK ; : F{ ; : F-> ; : F} ; : F...}T ; DECIMAL : COMPUTE-CELLS-PER-FP ( -- U ) DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ; HEX COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP : FTESTER ( R -- ) DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT THEN ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF S" INCORRECT FP RESULT: " ERROR THEN CELLS-PER-FP XCURSOR +! ; [THEN] : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. DEPTH START-DEPTH @ < IF DEPTH START-DEPTH @ SWAP DO 0 LOOP THEN DEPTH START-DEPTH @ > IF DEPTH START-DEPTH @ DO DROP LOOP THEN EMPTY-FSTACK ; : ERROR1 \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY \ THE LINE THAT HAD THE ERROR. TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR EMPTY-STACK \ THROW AWAY EVERY THING ELSE ; ' ERROR1 ERROR-XT ! : T{ \ ( -- ) SYNTACTIC SUGAR. DEPTH START-DEPTH ! 0 XCURSOR ! F{ ; : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH START-DEPTH @ > IF \ IF THERE IS SOMETHING ON STACK DEPTH START-DEPTH @ DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM THEN F-> ; : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED \ (ACTUAL) CONTENTS. DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH DEPTH START-DEPTH @ > IF \ IF THERE IS SOMETHING ON THE STACK DEPTH START-DEPTH @ DO \ FOR EACH STACK ITEM ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN LOOP THEN ELSE \ DEPTH MISMATCH S" WRONG NUMBER OF RESULTS: " ERROR THEN F} ; : ...}T ( -- ) DEPTH START-DEPTH @ = 0= IF S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR THEN XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPRECIFICATION: " ERROR THEN F...}T ; : XTESTER ( X -- ) DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT THEN ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF S" INCORRECT CELL RESULT: " ERROR THEN 1 XCURSOR +! ; : X}T XTESTER ...}T ; : R}T FTESTER ...}T ; : XX}T XTESTER XTESTER ...}T ; : XR}T FTESTER XTESTER ...}T ; : RX}T XTESTER FTESTER ...}T ; : RR}T FTESTER FTESTER ...}T ; : XXX}T XTESTER XTESTER XTESTER ...}T ; : XXR}T FTESTER XTESTER XTESTER ...}T ; : XRX}T XTESTER FTESTER XTESTER ...}T ; : XRR}T FTESTER FTESTER XTESTER ...}T ; : RXX}T XTESTER XTESTER FTESTER ...}T ; : RXR}T FTESTER XTESTER FTESTER ...}T ; : RRX}T XTESTER FTESTER FTESTER ...}T ; : RRR}T FTESTER FTESTER FTESTER ...}T ; : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ; : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ; : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ; : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ; : XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ; : XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ; : XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ; : XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ; : RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ; : RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ; : RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ; : RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ; : RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ; : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ; : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ; : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ; : TESTING \ ( -- ) TALKING COMMENT. SOURCE VERBOSE @ IF DUP >R TYPE CR R> >IN ! ELSE >IN ! DROP THEN ; BASE !