( Title: Forth Search-order tester File: otester.fs Test File: otester-test.fs Log File: otester.log Author: David N. Williams License: John Hayes, Public Domain Version: 1.4.3 Revised: January 18, 2021 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. ( The rest is public domain. This Forth 20xx library defines Hayes-style tests for the search- order stack, also called the ostack. Words not declared as public are considered to be private, not guaranteed to be available in future versions of otester. PUBLIC INTERFACE WORDS tests: O{ O-> }O config: MAX-OT-INITIALS MAX-OT-RESULTS PUBLIC AUXILIARY WORDS errors: OT-ERROR-XT OT-ERROR-DEFAULT OT-ERROR-INDEX arrays: OT-INITIALS OT-RESULTS OT-GOALS OT-MAX#OSTACK OT-A@ OT-A! OT-A<> OT-A= RESTORE-OT-INITIALS The basic test usage takes the form: ) \ ( o: oinitials) O{ O-> }O ( o: oinitials) ( Angle brackets around a stack data designation indicate code that produces the data. Here and stand for code that leaves oresults and ogoals wids above a logical ostack frame of oinitials wids, whose integrity must be preserved by correct and code. The oinitials are stored in an array, for checking against corruption of the intial search order. If the or code causes corruption, an exception is thrown. Otherwise oresults and ogoals are stored in arrays, removed from above the oinitials frame, and compared. The first discrepancy found is reported by executing the xt in the variable OT-ERROR-XT. The initial search order is preserved, even if there is a corruption exception. Before a discrepancy is reported, either the zero-based index into the oresults and ogoals arrays at which a mismatch was found is stored in the variable OT-ERROR-INDEX, with a plus one bias; or zero is stored if the arrays have different sizes. That can be used together with OT-ERROR-XT for more sophisticated error reporting. An example of how to do that is included in otester-test.fs. The order in which comparison errors between oresults and ogoals of equal size are found is deepest on the ostack first, corresponding to the order of execution of the and code. That is the same as the usual left to right order of stack pictures. All three words in the sequence O{ ... O-> ...}O ignore any effects that the generation of oresults or ogoals might have on other stacks. The library can be combined with ttester.fs to include tests of the data and floating-point stacks, or with other compatible testers to include other stacks. See the files otester-test.fs and order-test.fs for examples of how to use otester and ttester together. Storage of oinitials, oresults, and ogoals includes overflow exceptions. The user can change the default storage allocation by defining one or both of the following CONSTANT's *before* loading this file: MAX-OT-INITIALS MAX-OT-RESULTS The default values are the system-defined, maximum number of wids in the search order. This code does not change BASE, nor does it change the compilation word list. In particular, the initial compilation word list is not restored by O-> or }O, so the user must keep track of any changes to it generated by results or goals. ) BASE @ DECIMAL s" WORDLISTS" ENVIRONMENT? 0= [IF] cr .( ***can't determine max search order size) ABORT [THEN] ( max#wordlists) CONSTANT OT-MAX#OSTACK \ *** ERRORS \ Vectored error reporting. VARIABLE OT-ERROR-XT : OT-ERROR ( c-addr u -- ) OT-ERROR-XT @ EXECUTE ; VARIABLE OT-ERROR-INDEX \ set by }O to zero after unequal array size \ comparison, or [index+1] after deepest \ unequal element comparison at index : OT-ERROR-DEFAULT ( c-addr u -- ) ( Display an error message followed by the line that had the error. ) type source type cr ; ' OT-ERROR-DEFAULT OT-ERROR-XT ! \ *** ARRAYS ( Array indices are zero-based. Array buffers are headed by a one- cell count. The words defined below are generic for arrays with one-cell elements. The arrays used for oinitials, ogoals, and oresults are one-dimensional, with cell-sized elements. The first cell contains the count, followed by the array elements. We call this collection the array buffer. Array indices are referred to as "index" in stack specifications. Array addresses, referred to as "addr", "addr1", etc., in stack specifications, are those of array buffers, i.e., those of their count fields. ) \ USER CONFIG DEFAULTS [UNDEFINED] MAX-OT-INITIALS [IF] OT-MAX#OSTACK CONSTANT MAX-OT-INITIALS [THEN] [UNDEFINED] MAX-OT-RESULTS [IF] OT-MAX#OSTACK CONSTANT MAX-OT-RESULTS [THEN] \ ARRAY BUFFERS CREATE OT-INITIALS MAX-OT-INITIALS 1+ cells allot CREATE OT-RESULTS MAX-OT-RESULTS 1+ cells allot CREATE OT-GOALS MAX-OT-RESULTS 1+ cells allot \ Overflow checking to be done elsewhere. : OT-A! ( wid_[n-1] ... wid_0 n addr -- ) over 1+ cells over + swap DO i ! 1 cells +LOOP ; : OT-A@ ( addr -- wid_[n-1] ... wid_0 n ) dup @ cells over + DO i @ -1 cells +LOOP ; [UNDEFINED] DROPS [IF] : DROPS ( xn ... x1 n -- ) 0 ?DO drop LOOP ; [THEN] : OT-A<> ( wid_[n-1] ... wid_0 n addr -- [index+1] | -1 | 0 ) ( Nonzero returns for errors: -1 unequal array size index+1 deepest unequal elements ) 2dup @ <> IF drop drops -1 EXIT THEN ( addr) over 0 LOCALS| index+1 dim addr #left | BEGIN #left WHILE #left 1- to #left addr cell+ dup to addr @ <> IF dim #left - to index+1 THEN REPEAT index+1 ; [UNDEFINED] cell- [IF] : cell- ( addr -- addr-cell) [ 1 cells ] LITERAL - ; [THEN] : OT-A= ( addr1 addr2 -- 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 2>r 0 true 2r> ( 0 true addr1 addr2) dup @ ( count) >r r@ cells + swap r@ cells + 0 r> ( 0 true addr2_last addr1_last 0 last_index+1) ?DO 2dup @ swap @ <> IF \ unequal elements 2drop ( 0 true) 2drop i false 0 0 LEAVE THEN cell- swap cell- ( addr2' addr1') -1 +LOOP ( [0 true | i false] x1 x2) 2drop ; \ *** TESTS ( Unlike the situation for the data and other stacks, an empty search order is an ambiguous condition in Forth 2012, so the tests cannot save and clear order stack oinitials and then build oresults and ogoals on an empty order stack. Instead, the code regards the initial search order before a test as an oinitials stack frame below the oresults and ogoals, and throws an exception if the oinitials frame gets corrupted. ) \ Stack comments of the form ( o: inputs -- outputs ) refer only to \ the order stack. : RESTORE-OT-INITIALS ( o: j*wid -- oinitials ) OT-INITIALS OT-A@ set-order ; : O{ ( o: oinitials -- oinitials ) ( Store the ostack for maintaining the integrity of the initial search order frame. Clear oresults and ogoals storage. ) get-order dup MAX-OT-INITIALS > ABORT" TOO MANY OINITIALS" OT-INITIALS OT-A! 0 OT-RESULTS ! 0 OT-GOALS ! ; : O-> ( o: oinitials' oresults -- oinitials ) ( Get the current search order, both oinitials' and oresults, onto the data stack. Restore the original search order frame before testing for corruption by . Throw an exception if the number of oresults exceeds MAX-OT-RESULTS, or if it is negative, meaning there has been underflow into the oinitials frame. Store oresults, leaving oinitials' on the data stack. Throw an exception if the oinitials' do not agree with the stored oinitials. ) get-order RESTORE-OT-INITIALS ( #initials+#results) OT-INITIALS @ - ( #results) dup MAX-OT-RESULTS > ABORT" TOO MANY ORESULTS" dup 0< ABORT" ORESULTS UNDERFLOW OINITIALS" OT-RESULTS OT-A! OT-INITIALS @ ( initials #initials) OT-INITIALS OT-A<> ABORT" ORESULTS CLOBBER OINITIALS" ; : }O ( o: oinitials' ogoals -- oinitials ) ( Get the current search order, both oinitials' and ogoals, onto the data stack. Restore the initial search order before testing for corruption by . Throw an exception if the number of ogoals exceeds MAX-OT-RESULTS, or if it is negative, meaning there has been underflow into the oinitials frame. Store ogoals, leaving oinitials' on the data stack. Throw an exception if oinitials' does not agree with the stored oinitials. Compare the stored oresults and ogoals. If their number is not the same, set OT-ERROR-INDEX to zero and execute the OT-ERROR vector. Else, if there is a deepest comparison failure at the index-th element, store index+1 in OT-ERROR-INDEX and execute the OT-ERROR vector. ) get-order RESTORE-OT-INITIALS ( #initials+#goals) OT-INITIALS @ - ( #goals) dup MAX-OT-RESULTS > ABORT" TOO MANY OGOALS" dup 0< ABORT" OGOALS UNDERFLOW OINITIALS" OT-GOALS OT-A! OT-INITIALS @ ( initials #initials) OT-INITIALS OT-A<> ABORT" OGOALS CLOBBER OINITIALS" OT-RESULTS OT-GOALS OT-A= ( 0 true | 0 false | index+1 false) IF ( 0) DROP ELSE DUP OT-ERROR-INDEX ! IF S" INCORRECT RESULT: " ELSE S" WRONG NUMBER OF RESULTS: " THEN OT-ERROR THEN ; BASE ! \ END of otester.fs