( John Hayes' Forth testing words. ) \ (C) 1993 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. \ VERSION 1.0 ( Modified by David N. Williams to work with xstacks. Starting date: February 25, 2001 Last revision: September 17, 2002 ) decimal 0 value xstack \ Put the pointer for the xstack instance to be \ displayed here. [UNDEFINED] cell [IF] 1 cells constant cell [THEN] [UNDEFINED] -cell [IF] cell negate constant -cell [THEN] : xstack-depth ( -- depth ) xstack >xs-ptr0 @ xstack >xs-ptr @ - cell / ; : xstack> ( xs: a -- s: a ) xstack >xs-ptr @ @ ( xstack.item) cell xstack >xs-ptr +! ; \ 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 ! true verbose ! : empty-stack \ ( ... -- ) empty stack. depth ?dup IF 0 DO drop LOOP THEN ; : empty-xstack ( -- ) xstack-depth ?dup IF 0 DO -cell xstack >xs-ptr +! LOOP THEN ; : error ( c-addr u -- ) ( Display an error message followed by the line that had the error. ) cr source type \ display line corresponding to error empty-stack \ throw away every thing else empty-xstack ; \ variable actual-depth variable relative-depth \ stack record variable first-depth \ paramater stack depth origin create actual-results 32 cells allot \ variable actual-xdepth variable relative-xdepth \ stack record variable first-xdepth \ paramater stack depth origin create actual-xresults 32 cells allot : { ( -- ) depth first-depth ! xstack-depth first-xdepth ! ; : -> ( ... -- ) ( Record depth and content of stacks. ) depth first-depth @ - dup relative-depth ! \ record relative depth dup 0< IF s" Too few ds-results: " type source type ABORT THEN \ if there are things on stack save them 0 ?DO actual-results i cells + ! LOOP \ repeat the above for the xstack xstack-depth first-xdepth @ - dup relative-xdepth ! \ record relative depth dup 0< IF s" Too few xs-results: " type source type ABORT THEN \ if there are things on xstack save them 0 ?DO xstack> actual-xresults i cells + ! LOOP ; variable success~ variable xsuccess~ : } ( ... -- ) ( Compare stack [expected] contents with saved [actual] contents. ) depth first-depth @ - relative-depth @ = IF \ if depths match true success~ ! relative-depth @ \ if there is something on the stack 0 ?DO \ for each stack item actual-results i cells + @ <> \ compare actual with expected IF false success~ ! error ." Incorrect data result." LEAVE THEN LOOP ELSE \ depth mismatch false success~ ! error ." Wrong number of data results." THEN \ repeat the above for the xstack xstack-depth first-xdepth @ - relative-xdepth @ = IF \ if depths match true xsuccess~ ! relative-xdepth @ \ if there is something on the stack 0 ?DO \ for each stack item actual-xresults i cells + @ \ compare actual with expected xstack> <> IF false xsuccess~ ! error ." Incorrect x result." LEAVE THEN LOOP ELSE \ depth mismatch false xsuccess~ ! error ." Wrong number of x results." THEN success~ @ xsuccess~ @ and IF cr source type ." check!" THEN ; : testing ( -- ) ( Talking comment. ) source verbose @ IF dup >r cr type r> >in ! ELSE >in ! drop THEN ; cr \ testing core words \ { 0 0 and -> 0 } \ { 0 1 or -> 1 }