( Title: A utility for testing Forth data stack effects File: xtester.fs Test file: xftester-test.fs Log file: xftester.log 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 file revises the code for ttester, a utility for testing Forth words, as developed by several authors. See the file ttester-xf.fs, version 1.3.0 or later, for history. This file extracts the part of ttester-xf that deals with the data stack into an independent xtester module. Here "x" stands for the generic ANS/ISO Forth "unspecified cell" data type. An independent ftester module extracts the part that deals with the floating-point stack. The file xftester.fs loads the two components, and is functionally equivalent to ttester-xf.fs. Both are drop-in compatible with ttester, unless the user redefines error reporting by using the ttester words ERROR-XT or ERROR1. Words not declared as public are considered to be private, not guaranteed to be available in future versions of xtester. PUBLIC INTERFACE WORDS tests: X{ X-> }X config: MAX-XT-INITIALS MAX-XT-RESULTS PUBLIC AUXILIARY WORDS errors: XT-ERROR-XT XT-ERROR-DEFAULT XT-ERROR-INDEX arrays: XT-INITIALS XT-RESULTS XT-GOALS XT-A@ XT-A! XT-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 XT-ERROR-INDEX. The file xtester-errors.fs does that, and is loaded by xftester-test.fs. The basic test usage takes the form: ) \ ( xinitials) X{ X-> }X ( xinitials) ( Angle brackets around a stack data designation indicate code that produces the data. Here xinitials stands for possibly nonempty data stack contents at the start of the test. The sequence starting with X{ saves the xinitials and removes them from the stack, executes the code that produces the stack xresults, saves and removes the xresults from the stack, executes the code that produces the stack xgoals, saves and removes them, compares the saved xresults and xgoals, reports when there is a discrepancy between the two, and restores the saved xinitials. The three X test words have the same basic functionality as the original Hayes words {, ->, and }. The key differences are that they save and restore xinitials, save xgoals, and have a user interface for error-reporting. They have evolved from ttester. A usage example: X{ 1 2 3 swap X-> 1 3 2 }X ok X{ 1 2 3 swap X-> 1 2 2 }X INCORRECT XRESULT: X{ 1 2 3 swap X-> 1 2 2 }X ok X{ 1 2 3 swap X-> 1 2 }X WRONG NUMBER OF XRESULTS: X{ 1 2 3 swap X-> 1 2 }X ok Effects present or produced on non-data stacks before X{, X->, or }X are simply ignored. More examples can be found in the file xftester-test.fs. Storage of xinitials, xresults, and xgoals includes overflow checking. The user can change the default storage allocation by defining one or both of the following CONSTANT's *before* loading this file: MAX-XT-INITIALS MAX-XT-RESULTS The default xt in the variable XT-ERROR-XT can be changed only *after* loading this file. Loading xtester.fs does not change BASE. Xtester uses the same limited set of non-CORE words as the data stack section of ttester, plus [UNDEFINED], 2>R, and 2R>. See ttester-xf.fs or xftester.fs for the list. Xtester uses the following non-CORE words: TOOLS EXT: [IF] [THEN] [UNDEFINED] CORE EXT: 2>R 2R> ?DO FILE: ( TABLE OF CONTENTS XTESTER X.1 ERRORS X.2 ARRAYS X.3 TESTS ) BASE @ DECIMAL \ *** XTESTER \ *** X.1 ERRORS \ PUBLIC VARIABLE XT-ERROR-XT VARIABLE XT-ERROR-INDEX \ set to zero after unequal array size \ comparison, or [index+1] after deepest \ unequal element comparison at index : XT-ERROR-DEFAULT ( c-addr u -- ) ( Display an error message followed by the line that had the error. ) TYPE SOURCE TYPE CR ; ' XT-ERROR-DEFAULT XT-ERROR-XT ! \ PRIVATE : XT-ERROR ( c-addr u -- ) XT-ERROR-XT @ EXECUTE ; \ *** X.2 ARRAYS ( The arrays used for stack xinitials, xgoals, and xresults 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, referred to as "index" in stack specifications, are zero-based. A tick prefix in stack comments means "address". ) \ PUBLIC \ USER CONFIG DEFAULTS [UNDEFINED] MAX-XT-INITIALS [IF] 32 CONSTANT MAX-XT-INITIALS [THEN] [UNDEFINED] MAX-XT-RESULTS [IF] 32 CONSTANT MAX-XT-RESULTS [THEN] \ ARRAY BUFFERS CREATE XT-INITIALS MAX-XT-INITIALS 1+ CELLS ALLOT CREATE XT-RESULTS MAX-XT-RESULTS 1+ CELLS ALLOT CREATE XT-GOALS MAX-XT-RESULTS 1+ CELLS ALLOT \ Overflow checking to be done elsewhere. : XT-A! ( x_[n-1] ... x_0 +n 'buf -- ) OVER 1+ CELLS OVER + SWAP DO I ! 1 CELLS +LOOP ; : XT-A@ ( 'buf -- x_[n-1] ... x_0 +n ) DUP @ CELLS OVER + DO I @ -1 CELLS +LOOP ; [UNDEFINED] CELL- [IF] : CELL- ( addr -- addr-cell ) [ 1 CELLS ] LITERAL - ; [THEN] : XT-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 2>R 0 TRUE 2R> ( 0 true 'buf1 'buf2) DUP @ ( count) >R \ count = last+1 R@ CELLS + SWAP R@ CELLS + 0 R> ( 0 true 'elems2_last 'elems1_last 0 last+1) ?DO ( 0 true 'x_index 'y_index) \ i = index+1 2DUP @ SWAP @ <> IF \ unequal elements 2DROP ( 0 true) 2DROP I FALSE 0 0 LEAVE THEN CELL- SWAP CELL- ( 'y_[index-1] 'x_[index-1]) -1 +LOOP ( [0 true | i false] x1 x2) 2DROP ; \ *** X.3 TESTS \ PUBLIC : X{ ( xinitials -- ) ( Save the data stack xinitials for restoration by }X, leaving the data stack empty. Clear results and goals storage. ) DEPTH DUP MAX-XT-INITIALS > ABORT" TOO MANY XINITIALS" XT-INITIALS XT-A! 0 XT-RESULTS ! 0 XT-GOALS ! ; : X-> ( xresults -- ) ( Save the data stack xresults, leaving the data stack empty. ) DEPTH DUP MAX-XT-RESULTS > ABORT" TOO MANY XRESULTS" XT-RESULTS XT-A! ; : }X ( xgoals -- xinitials ) ( Save the data stack xgoals, compare them with the saved xresults, and restore the xinitials. If the number of xresults is not the same as the number of xgoals, store zero in XT-ERROR-INDEX and execute the XT-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 XT-ERROR-INDEX and execute the XT-ERROR vector. ) DEPTH DUP MAX-XT-RESULTS > ABORT" TOO MANY XGOALS" XT-GOALS XT-A! XT-RESULTS XT-GOALS XT-A= ( 0 true | 0 false | index+1 false) IF ( 0) DROP ELSE DUP XT-ERROR-INDEX ! IF S" INCORRECT XRESULT: " ELSE S" WRONG NUMBER OF XRESULTS: " THEN XT-ERROR THEN XT-INITIALS XT-A@ ( len) DROP ; BASE ! \ *** END of xtester.fs