version 1.3, 2007/08/12 13:13:20
|
version 1.6, 2007/08/19 21:33:50
|
Line 1
|
Line 1
|
\ From: John Hayes S1I |
\ drop-in replacement for John Hayes' tester |
\ Subject: tester.fr |
|
\ Date: Mon, 27 Nov 95 13:10:09 PST |
|
|
|
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY |
S" ./ttester.fs" INCLUDED |
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. |
|
\ VERSION 1.1 |
|
|
|
\ revised by Anton Ertl 2007-08-12 |
: { T{ ; |
\ added fp comparisons (note: BASE is HEX after loading this file) |
|
\ environmental dependency on separate fp stack |
|
\ the sensitivity of the fp comparison is determined by FSENSITIVITY |
|
\ added support for non-empty stack at the start |
|
HEX |
|
|
|
\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY |
: } }T ; |
\ 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 ERROR-XT |
|
|
|
: ERROR ERROR-XT @ EXECUTE ; |
|
|
|
: "FLOATING" S" FLOATING" ; \ ONLY COMPILED S" IN CORE |
|
: "FLOATING-STACK" S" FLOATING-STACK" ; |
|
"FLOATING" ENVIRONMENT? [IF] |
|
[IF] |
|
"FLOATING-STACK" ENVIRONMENT? [IF] |
|
[IF] |
|
TRUE |
|
[ELSE] |
|
FALSE |
|
[THEN] |
|
[ELSE] \ WE DON'T KNOW WHETHER THE FP STACK IS SEPARATE |
|
TRUE \ SAFER CHOICE TO ASSUME IT IS |
|
[THEN] |
|
[ELSE] |
|
FALSE |
|
[THEN] |
|
[ELSE] |
|
FALSE |
|
[THEN] |
|
[IF] \ WE HAVE FP WORDS AND A SEPARATE FP STACK |
|
FVARIABLE FSENSITIVITY -1E-12 FSENSITIVITY F! |
|
VARIABLE ACTUAL-FDEPTH |
|
CREATE ACTUAL-FRESULTS 20 FLOATS ALLOT |
|
VARIABLE START-FDEPTH |
|
|
|
: 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 ! ; |
|
|
|
: 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@ |
|
FSENSITIVITY F@ F~ INVERT IF |
|
S" INCORRECT RESULT: " ERROR LEAVE |
|
THEN |
|
LOOP |
|
THEN |
|
ELSE |
|
S" WRONG NUMBER OF RESULTS: " ERROR |
|
THEN ; |
|
[ELSE] |
|
: EMPTY-FSTACK ; |
|
: F{ ; |
|
: F-> ; |
|
: F} ; |
|
[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 ! |
|
|
|
: { \ ( -- ) SYNTACTIC SUGAR. |
|
DEPTH START-DEPTH ! 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-> ; |
|
|
|
: } \ ( ... -- ) 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} ; |
|
|
|
: TESTING \ ( -- ) TALKING COMMENT. |
|
SOURCE VERBOSE @ |
|
IF DUP >R TYPE CR R> >IN ! |
|
ELSE >IN ! DROP |
|
THEN ; |
|
|
|