mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-07-10 05:29:03 +00:00
9a568b3a03
Names are adapted to DOS 8.3 file names, PETSCII adaptions of core.fth are reverted (DOS uses ASCII), the input test is disabled, since no way was yet found to inject keystrokes into dosbox. And some tweaks were applied to ans-shim.fth and the golden files to make the first tests (preliminary & core) to pass.
677 lines
24 KiB
Forth
677 lines
24 KiB
Forth
\ To test the ANS Forth Block word set and extension words
|
|
|
|
\ This program was written by Steve Palmer in 2015, with contributions from
|
|
\ others where indicated, and is in the public domain - it can be distributed
|
|
\ and/or modified in any way but please retain this notice.
|
|
|
|
\ This program is distributed in the hope that it will be useful,
|
|
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
\ The tests are not claimed to be comprehensive or correct
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
\ Version 0.1 23 October 2015 First Version
|
|
\ Version 0.2 15 November 2015 Updated after feedback from Gerry Jackson
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
\ The tests are based on John Hayes test program for the core word set
|
|
\
|
|
\ Words tested in this file are:
|
|
\ BLK BLOCK BUFFER EVALUATE FLUSH LOAD SAVE-BUFFERS UPDATE
|
|
\ EMPTY-BUFFERS LIST SCR THRU REFILL SAVE-INPUT RESTORE-INPUT \
|
|
\
|
|
\ ------------------------------------------------------------------------------
|
|
\ Assumptions and dependencies:
|
|
\ - tester.fr or ttester.fs has been loaded prior to this file
|
|
\ - errorreport.fth has been loaded prior to this file
|
|
\ - utilities.fth has been loaded prioir to this file
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING Block word set
|
|
|
|
DECIMAL
|
|
|
|
\ Define these constants from the system documentation provided.
|
|
\ WARNING: The contents of the test blocks will be destroyed by this test.
|
|
\ The blocks tested will be in the range
|
|
\ FIRST-TEST-BLOCK <= u < LIMIT-TEST-BLOCK
|
|
\ The tests need at least 2 test blocks in the range to complete.
|
|
20 CONSTANT FIRST-TEST-BLOCK
|
|
30 CONSTANT LIMIT-TEST-BLOCK \ one beyond the last
|
|
|
|
FIRST-TEST-BLOCK LIMIT-TEST-BLOCK U< 0= [?IF]
|
|
\? .( Error: Test Block range not identified ) CR ABORT
|
|
[?THEN]
|
|
|
|
LIMIT-TEST-BLOCK FIRST-TEST-BLOCK - CONSTANT TEST-BLOCK-COUNT
|
|
TEST-BLOCK-COUNT 2 U< [?IF]
|
|
\? .( Error: At least 2 Test Blocks are required to run the tests ) CR ABORT
|
|
[?THEN]
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING Random Number Utilities
|
|
|
|
\ The block tests make extensive use of random numbers to select blocks to test
|
|
\ and to set the contents of the block. It also makes use of a Hash code to
|
|
\ ensure the integrity of the blocks against unexpected changes.
|
|
|
|
\ == Memory Walk tools ==
|
|
|
|
: @++ ( a-addr -- a-addr+4 a-addr@ )
|
|
DUP CELL+ SWAP @ ;
|
|
|
|
: !++ ( x a-addr -- a-addr+4 )
|
|
TUCK ! CELL+ ;
|
|
|
|
: C@++ ( c-addr -- c-addr;char+ c-addr@ )
|
|
DUP CHAR+ SWAP C@ ;
|
|
|
|
: C!++ ( char c-addr -- c-addr+1 )
|
|
TUCK ! CHAR+ ;
|
|
|
|
\ == Random Numbers ==
|
|
\ Based on "Xorshift" PRNG wikipedia page
|
|
\ reporting on results by George Marsaglia
|
|
\ https://en.wikipedia.org/wiki/Xorshift
|
|
\ Note: THIS IS NOT CRYPTOGRAPHIC QUALITY
|
|
|
|
: PRNG
|
|
CREATE ( "name" -- )
|
|
4 CELLS ALLOT
|
|
DOES> ( -- prng )
|
|
;
|
|
|
|
: PRNG-ERROR-CODE ( prng -- errcode | 0 )
|
|
0 4 0 DO \ prng acc
|
|
>R @++ R> OR \ prng acc'
|
|
LOOP \ prng xORyORzORw
|
|
NIP 0= ; \ xORyORzORw=0
|
|
|
|
: PRNG-COPY ( src-prng dst-prng -- )
|
|
4 CELLS MOVE ;
|
|
|
|
: PRNG-SET-SEED ( prng w z y x -- )
|
|
4 PICK \ prng w z y x prng
|
|
4 0 DO !++ LOOP DROP \ prng
|
|
DUP PRNG-ERROR-CODE IF \ prng
|
|
1 OVER +! \ prng
|
|
THEN \ prng
|
|
DROP ; \
|
|
|
|
BITS/CELL 64 = [?IF]
|
|
\? : PRNG-RND ( prng -- rnd )
|
|
\? DUP @
|
|
\? DUP 21 LSHIFT XOR
|
|
\? DUP 35 RSHIFT XOR
|
|
\? DUP 4 LSHIFT XOR
|
|
\? TUCK SWAP ! ;
|
|
[?THEN]
|
|
|
|
BITS/CELL 32 = [?IF]
|
|
\? : PRNG-RND ( prng -- rnd )
|
|
\? DUP @ \ prng x
|
|
\? DUP 11 LSHIFT XOR \ prng t=x^(x<<11)
|
|
\? DUP 8 RSHIFT XOR \ prng t'=t^(t>>8)
|
|
\? OVER DUP CELL+ SWAP 3 CELLS MOVE \ prng t'
|
|
\? OVER 3 CELLS + @ \ prng t' w
|
|
\? DUP 19 RSHIFT XOR \ prng t' w'=w^(w>>19)
|
|
\? XOR \ prng rnd=w'^t'
|
|
\? TUCK SWAP 3 CELLS + ! ; \ rnd
|
|
[?THEN]
|
|
|
|
BITS/CELL 16 = [?IF]
|
|
\? .( === NOT TESTED === )
|
|
\? \ From http://b2d-f9r.blogspot.co.uk/2010/08/16-bit-xorshift-rng-now-with-more.html
|
|
\? : PRNG-RND ( prng -- rnd )
|
|
\? DUP @ \ prng x
|
|
\? DUP 5 LSHIFT XOR \ prng t=x^(x<<5)
|
|
\? DUP 3 RSHIFT XOR \ prng t'=t^(t>>3)
|
|
\? OVER DUP CELL+ @ TUCK SWAP ! \ prng t' y
|
|
\? DUP 1 RSHIFT XOR \ prng t' y'=y^(y>>1)
|
|
\? XOR \ prng rnd=y'^t'
|
|
\? TUCK SWAP CELL+ ! ; \ rnd
|
|
[?THEN]
|
|
|
|
[?DEF] PRNG-RND
|
|
\? .( You need to add a Psuedo Random Number Generator for your cell size: )
|
|
\? BITS/CELL U. CR
|
|
\? ABORT
|
|
[?THEN]
|
|
|
|
: PRNG-RANDOM ( lower upper prng -- rnd )
|
|
>R OVER - R> PRNG-RND UM* NIP + ;
|
|
\ PostCondition: T{ lower upper 2DUP 2>R prng PRNG-RANDOM 2R> WITHIN -> TRUE }T
|
|
|
|
PRNG BLOCK-PRNG
|
|
\ Generated by Random.org
|
|
BLOCK-PRNG -1865266521 188896058 -2021545234 -1456609962 PRNG-SET-SEED
|
|
: BLOCK-RND ( -- rnd ) BLOCK-PRNG PRNG-RND ;
|
|
: BLOCK-RANDOM ( lower upper -- rnd ) BLOCK-PRNG PRNG-RANDOM ;
|
|
|
|
: RND-TEST-BLOCK ( -- blk )
|
|
FIRST-TEST-BLOCK LIMIT-TEST-BLOCK BLOCK-RANDOM ;
|
|
\ PostCondition: T{ RND-TEST-BLOCK FIRST-TEST-BLOCK LIMIT-TEST-BLOCK WITHIN -> TRUE }T
|
|
|
|
\ Two distinct random test blocks
|
|
: 2RND-TEST-BLOCKS ( -- blk1 blk2 )
|
|
RND-TEST-BLOCK BEGIN \ blk1
|
|
RND-TEST-BLOCK \ blk1 blk2
|
|
2DUP = \ blk1 blk2 blk1==blk2
|
|
WHILE \ blk1 blk1
|
|
DROP \ blk1
|
|
REPEAT ; \ blk1 blk2
|
|
\ PostCondition: T{ 2RND-TEST-BLOCKS = -> FALSE }T
|
|
|
|
\ first random test block in a sequence of length u
|
|
: RND-TEST-BLOCK-SEQ ( u -- blks )
|
|
FIRST-TEST-BLOCK LIMIT-TEST-BLOCK ROT 1- - BLOCK-RANDOM ;
|
|
|
|
\ I'm not sure if this algorithm is correct if " 1 CHARS 1 <> ".
|
|
: ELF-HASH-ACCUMULATE ( hash c-addr u -- hash )
|
|
>R SWAP R> 0 DO \ c-addr h
|
|
4 LSHIFT \ c-addr h<<=4
|
|
SWAP C@++ ROT + \ c-addr' h+=*s
|
|
DUP [ HEX ] F0000000 [ DECIMAL ] AND \ c-addr' h high=h&0xF0000000
|
|
DUP IF \ c-addr' h high
|
|
DUP >R 24 RSHIFT XOR R> \ c-addr' h^=high>>24 high
|
|
THEN \ c-addr' h high
|
|
INVERT AND \ c-addr' h&=~high
|
|
LOOP NIP ;
|
|
|
|
: ELF-HASH ( c-addr u -- hash )
|
|
0 ROT ROT ELF-HASH-ACCUMULATE ;
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING BLOCK ( read-only mode )
|
|
|
|
\ BLOCK signature
|
|
T{ RND-TEST-BLOCK BLOCK DUP ALIGNED = -> TRUE }T
|
|
|
|
\ BLOCK accepts all blocks in the test range
|
|
: BLOCK-ALL ( blk2 blk1 -- )
|
|
DO
|
|
I BLOCK DROP
|
|
LOOP ;
|
|
T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK BLOCK-ALL -> }T
|
|
|
|
\ BLOCK twice on same block returns the same value
|
|
T{ RND-TEST-BLOCK DUP BLOCK SWAP BLOCK = -> TRUE }T
|
|
|
|
\ BLOCK twice on distinct block numbers
|
|
\ may or may not return the same value!
|
|
\ Nothing to test
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING BUFFER ( read-only mode )
|
|
|
|
\ Although it is not in the spirit of the specification,
|
|
\ a compliant definition of BUFFER would be
|
|
\ : BUFFER BLOCK ;
|
|
\ So we can only repeat the tests for BLOCK ...
|
|
|
|
\ BUFFER signature
|
|
T{ RND-TEST-BLOCK BUFFER DUP ALIGNED = -> TRUE }T
|
|
|
|
\ BUFFER accepts all blocks in the test range
|
|
: BUFFER-ALL ( blk2 blk1 -- )
|
|
DO
|
|
I BUFFER DROP
|
|
LOOP ;
|
|
T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK BUFFER-ALL -> }T
|
|
|
|
\ BUFFER twice on the same block returns the same value
|
|
T{ RND-TEST-BLOCK DUP BUFFER SWAP BUFFER = -> TRUE }T
|
|
|
|
\ BUFFER twice on distinct block numbers
|
|
\ may or may not return the same value!
|
|
\ Nothing to test
|
|
|
|
\ Combinations with BUFFER
|
|
T{ RND-TEST-BLOCK DUP BLOCK SWAP BUFFER = -> TRUE }T
|
|
T{ RND-TEST-BLOCK DUP BUFFER SWAP BLOCK = -> TRUE }T
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING Read and Write access with UPDATE and FLUSH
|
|
|
|
\ Ideally, we'd like to be able to test the persistence across power cycles
|
|
\ of the writes, but we can't do that in a simple test.
|
|
\ The tests below could be fooled by a large buffers store and a tricky FLUSH
|
|
\ but what else are you going to do?
|
|
|
|
\ Signatures
|
|
T{ RND-TEST-BLOCK BLOCK DROP UPDATE -> }T
|
|
T{ FLUSH -> }T
|
|
|
|
: BLANK-BUFFER ( blk -- blk-addr )
|
|
BUFFER DUP 1024 BL FILL ;
|
|
|
|
\ Test R/W of a Simple Blank Random Block
|
|
T{ RND-TEST-BLOCK \ blk
|
|
DUP BLANK-BUFFER \ blk blk-addr1
|
|
1024 ELF-HASH \ blk hash
|
|
UPDATE FLUSH \ blk hash
|
|
SWAP BLOCK \ hash blk-addr2
|
|
1024 ELF-HASH = -> TRUE }T
|
|
|
|
\ Boundary Test: Modify first character
|
|
T{ RND-TEST-BLOCK \ blk
|
|
DUP BLANK-BUFFER \ blk blk-addr1
|
|
CHAR \ OVER C! \ blk blk-addr1
|
|
1024 ELF-HASH \ blk hash
|
|
UPDATE FLUSH \ blk hash
|
|
SWAP BLOCK \ hash blk-addr2
|
|
1024 ELF-HASH = -> TRUE }T
|
|
|
|
\ Boundary Test: Modify last character
|
|
T{ RND-TEST-BLOCK \ blk
|
|
DUP BLANK-BUFFER \ blk blk-addr1
|
|
CHAR \ OVER 1023 CHARS + C! \ blk blk-addr1
|
|
1024 ELF-HASH \ blk hash
|
|
UPDATE FLUSH \ blk hash
|
|
SWAP BLOCK \ hash blk-addr2
|
|
1024 ELF-HASH = -> TRUE }T
|
|
|
|
\ Boundary Test: First and Last (and all other) blocks in the test range
|
|
1024 8 * BITS/CELL / CONSTANT CELLS/BLOCK
|
|
|
|
: PREPARE-RND-BLOCK ( hash blk -- hash' )
|
|
BUFFER DUP \ hash blk-addr blk-addr
|
|
CELLS/BLOCK 0 DO \ hash blk-addr blk-addr[i]
|
|
BLOCK-RND OVER ! CELL+ \ hash blk-addr blk-addr[i+1]
|
|
LOOP DROP \ hash blk-addr
|
|
1024 ELF-HASH-ACCUMULATE ; \ hash'
|
|
|
|
: WRITE-RND-BLOCKS-WITH-HASH ( blk2 blk1 -- hash )
|
|
0 ROT ROT DO \ hash
|
|
I PREPARE-RND-BLOCK UPDATE \ hash'
|
|
LOOP ; \ hash'
|
|
|
|
: READ-BLOCKS-AND-HASH ( blk2 blk1 -- hash )
|
|
0 ROT ROT DO \ hash(i)
|
|
I BLOCK 1024 ELF-HASH-ACCUMULATE \ hash(i+1)
|
|
LOOP ; \ hash
|
|
|
|
T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK WRITE-RND-BLOCKS-WITH-HASH FLUSH
|
|
LIMIT-TEST-BLOCK FIRST-TEST-BLOCK READ-BLOCKS-AND-HASH = -> TRUE }T
|
|
|
|
: TUF1 ( xt blk -- hash )
|
|
DUP BLANK-BUFFER \ xt blk blk-addr1
|
|
1024 ELF-HASH \ xt blk hash
|
|
ROT EXECUTE \ blk hash
|
|
SWAP BLOCK \ hash blk-addr2
|
|
1024 ELF-HASH = ; \ TRUE
|
|
|
|
\ Double UPDATE make no difference
|
|
: TUF1-1 ( -- ) UPDATE UPDATE FLUSH ;
|
|
T{ ' TUF1-1 RND-TEST-BLOCK TUF1 -> TRUE }T
|
|
|
|
\ Double FLUSH make no difference
|
|
: TUF1-2 ( -- ) UPDATE FLUSH FLUSH ;
|
|
T{ ' TUF1-2 RND-TEST-BLOCK TUF1 -> TRUE }T
|
|
|
|
\ FLUSH only saves UPDATEd buffers
|
|
T{ RND-TEST-BLOCK \ blk
|
|
0 OVER PREPARE-RND-BLOCK \ blk hash
|
|
UPDATE FLUSH \ blk hash
|
|
OVER 0 SWAP PREPARE-RND-BLOCK DROP \ blk hash
|
|
FLUSH ( with no preliminary UPDATE) \ blk hash
|
|
SWAP BLOCK 1024 ELF-HASH = -> TRUE }T
|
|
|
|
\ UPDATE only marks the current block buffer
|
|
\ This test needs at least 2 distinct buffers, though this is not a
|
|
\ requirement of the language specification. If 2 distinct buffers
|
|
\ are not returned, then the tests quits with a trivial Pass
|
|
: TUF2 ( xt blk1 blk2 -- hash1'' hash2'' hash1' hash2' hash1 hash2 )
|
|
OVER BUFFER OVER BUFFER = IF \ test needs 2 distinct buffers
|
|
2DROP DROP 0 0 0 0 0 0 \ Dummy result
|
|
ELSE
|
|
OVER 0 SWAP PREPARE-RND-BLOCK UPDATE \ xt blk1 blk2 hash1
|
|
OVER 0 SWAP PREPARE-RND-BLOCK UPDATE \ xt blk1 blk2 hash1 hash2
|
|
2>R \ xt blk1 blk2
|
|
FLUSH \ xt blk1 blk2
|
|
OVER 0 SWAP PREPARE-RND-BLOCK \ xt blk1 blk2 hash1'
|
|
OVER 0 SWAP PREPARE-RND-BLOCK \ xt blk1 blk2 hash1' hash2'
|
|
2>R \ xt blk1 blk2
|
|
ROT EXECUTE \ blk1 blk2
|
|
FLUSH \ blk1 blk2
|
|
SWAP BLOCK 1024 ELF-HASH \ blk2 hash1''
|
|
SWAP BLOCK 1024 ELF-HASH \ hash1'' hash2''
|
|
2R> 2R> \ hash1'' hash2'' hash1' hash2' hash1 hash2
|
|
THEN ;
|
|
|
|
: 2= ( x1 x2 x3 x4 -- flag )
|
|
ROT = ROT ROT = AND ;
|
|
|
|
: TUF2-0 ( blk1 blk2 -- blk1 blk2 ) ; \ no updates
|
|
T{ ' TUF2-0 2RND-TEST-BLOCKS TUF2 \ run test procedure
|
|
2SWAP 2DROP 2= -> TRUE }T \ compare expected and actual
|
|
|
|
: TUF2-1 ( blk1 blk2 -- blk1 blk2 ) \ update blk1 only
|
|
OVER BLOCK DROP UPDATE ;
|
|
T{ ' TUF2-1 2RND-TEST-BLOCKS TUF2 \ run test procedure
|
|
SWAP DROP SWAP DROP 2= -> TRUE }T
|
|
|
|
: TUF2-2 ( blk1 blk2 -- blk1 blk2 ) \ update blk2 only
|
|
DUP BUFFER DROP UPDATE ;
|
|
T{ ' TUF2-2 2RND-TEST-BLOCKS TUF2 \ run test procedure
|
|
DROP ROT DROP SWAP 2= -> TRUE }T
|
|
|
|
: TUF2-3 ( blk1 blk2 -- blk1 blk2 ) \ update blk1 and blk2
|
|
TUF2-1 TUF2-2 ;
|
|
T{ ' TUF2-3 2RND-TEST-BLOCKS TUF2 \ run test procedure
|
|
2DROP 2= -> TRUE }T
|
|
|
|
\ FLUSH and then UPDATE is ambiguous and untestable
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING SAVE-BUFFERS
|
|
|
|
\ In principle, all the tests above can be repeated with SAVE-BUFFERS instead of
|
|
\ FLUSH. However, only the full random test is repeated...
|
|
|
|
T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK WRITE-RND-BLOCKS-WITH-HASH SAVE-BUFFERS
|
|
LIMIT-TEST-BLOCK FIRST-TEST-BLOCK READ-BLOCKS-AND-HASH = -> TRUE }T
|
|
|
|
\ FLUSH and then SAVE-BUFFERS is harmless but undetectable
|
|
\ SAVE-BUFFERS and then FLUSH is undetectable
|
|
|
|
\ Unlike FLUSH, SAVE-BUFFERS then BUFFER/BLOCK
|
|
\ returns the original buffer address
|
|
T{ RND-TEST-BLOCK DUP BLANK-BUFFER
|
|
SAVE-BUFFERS SWAP BUFFER = -> TRUE }T
|
|
T{ RND-TEST-BLOCK DUP BLANK-BUFFER
|
|
UPDATE SAVE-BUFFERS SWAP BUFFER = -> TRUE }T
|
|
T{ RND-TEST-BLOCK DUP BLANK-BUFFER
|
|
SAVE-BUFFERS SWAP BLOCK = -> TRUE }T
|
|
T{ RND-TEST-BLOCK DUP BLANK-BUFFER
|
|
UPDATE SAVE-BUFFERS SWAP BLOCK = -> TRUE }T
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING BLK
|
|
|
|
\ Signature
|
|
T{ BLK DUP ALIGNED = -> TRUE }T
|
|
|
|
\ None of the words considered so far effect BLK
|
|
T{ BLK @ RND-TEST-BLOCK BUFFER DROP BLK @ = -> TRUE }T
|
|
T{ BLK @ RND-TEST-BLOCK BLOCK DROP BLK @ = -> TRUE }T
|
|
T{ BLK @ UPDATE BLK @ = -> TRUE }T
|
|
|
|
T{ BLK @ FLUSH BLK @ = -> TRUE }T
|
|
T{ BLK @ SAVE-BUFFERS BLK @ = -> TRUE }T
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING LOAD and EVALUATE
|
|
|
|
\ Signature: n LOAD --> blank screen
|
|
T{ RND-TEST-BLOCK DUP BLANK-BUFFER DROP UPDATE FLUSH LOAD -> }T
|
|
|
|
T{ BLK @ RND-TEST-BLOCK DUP BLANK-BUFFER DROP UPDATE FLUSH LOAD BLK @ = -> TRUE }T
|
|
|
|
: WRITE-BLOCK ( blk c-addr u -- )
|
|
ROT BLANK-BUFFER SWAP CHARS MOVE UPDATE FLUSH ;
|
|
|
|
\ blk: u; blk LOAD
|
|
: TL1 ( u blk -- )
|
|
SWAP 0 <# #S #> WRITE-BLOCK ;
|
|
T{ BLOCK-RND RND-TEST-BLOCK 2DUP TL1 LOAD = -> TRUE }T
|
|
|
|
\ Boundary Test: FIRST-TEST-BLOCK
|
|
T{ BLOCK-RND FIRST-TEST-BLOCK 2DUP TL1 LOAD = -> TRUE }T
|
|
|
|
\ Boundary Test: LIMIT-TEST-BLOCK-1
|
|
T{ BLOCK-RND LIMIT-TEST-BLOCK 1- 2DUP TL1 LOAD = -> TRUE }T
|
|
|
|
: WRITE-AT-END-OF-BLOCK ( blk c-addr u -- )
|
|
ROT BLANK-BUFFER
|
|
OVER 1024 SWAP - CHARS +
|
|
SWAP CHARS MOVE UPDATE FLUSH ;
|
|
|
|
\ Boundary Test: End of Buffer
|
|
: TL2 ( u blk -- )
|
|
SWAP 0 <# #S #> WRITE-AT-END-OF-BLOCK ;
|
|
T{ BLOCK-RND RND-TEST-BLOCK 2DUP TL2 LOAD = -> TRUE }T
|
|
|
|
\ LOAD updates BLK
|
|
\ u: "BLK @"; u LOAD
|
|
: TL3 ( blk -- )
|
|
S" BLK @" WRITE-BLOCK ;
|
|
T{ RND-TEST-BLOCK DUP TL3 DUP LOAD = -> TRUE }T
|
|
|
|
\ EVALUATE resets BLK
|
|
\ u: "EVALUATE-BLK@"; u LOAD
|
|
\vf : EVALUATE-BLK@ ( -- BLK@ )
|
|
\vf S" BLK @" EVALUATE ;
|
|
\vf : TL4 ( blk -- )
|
|
\vf S" EVALUATE-BLK@" WRITE-BLOCK ;
|
|
\vf T{ RND-TEST-BLOCK DUP TL4 LOAD -> 0 }T
|
|
|
|
\ EVALUTE can nest with LOAD
|
|
\ u: "BLK @"; S" u LOAD" EVALUATE
|
|
\vf : TL5 ( blk -- c-addr u )
|
|
\vf 0 <# \ blk 0
|
|
\vf [CHAR] D HOLD
|
|
\vf [CHAR] A HOLD
|
|
\vf [CHAR] O HOLD
|
|
\vf [CHAR] L HOLD
|
|
\vf BL HOLD
|
|
\vf #S #> ; \ c-addr u
|
|
\vf T{ RND-TEST-BLOCK DUP TL3 DUP TL5 EVALUATE = -> TRUE }T
|
|
|
|
\ Nested LOADs
|
|
\ u2: "BLK @"; u1: "LOAD u2"; u1 LOAD
|
|
\vf : TL6 ( blk1 blk2 -- )
|
|
\vf DUP TL3 \ blk1 blk2
|
|
\vf TL5 WRITE-BLOCK ;
|
|
\vf T{ 2RND-TEST-BLOCKS 2DUP TL6 SWAP LOAD = -> TRUE }T
|
|
|
|
\ LOAD changes the currect block that is effected by UPDATE
|
|
\ This test needs at least 2 distinct buffers, though this is not a
|
|
\ requirement of the language specification. If 2 distinct buffers
|
|
\ are not returned, then the tests quits with a trivial Pass
|
|
: TL7 ( blk1 blk2 -- u1 u2 rnd2 blk2-addr rnd1' rnd1 )
|
|
OVER BUFFER OVER BUFFER = IF \ test needs 2 distinct buffers
|
|
2DROP 0 0 0 0 0 0 \ Dummy result
|
|
ELSE
|
|
OVER BLOCK-RND DUP ROT TL1 >R \ blk1 blk2
|
|
DUP S" SOURCE DROP" WRITE-BLOCK \ blk1 blk2
|
|
\ change blk1 to a new rnd, but don't UPDATE
|
|
OVER BLANK-BUFFER \ blk1 blk2 blk1-addr
|
|
BLOCK-RND DUP >R \ blk1 blk2 blk1-addr rnd1'
|
|
0 <# #S #> \ blk1 blk2 blk1-addr c-addr u
|
|
ROT SWAP CHARS MOVE \ blk1 blk2
|
|
\ Now LOAD blk2
|
|
DUP LOAD DUP >R \ blk1 blk2 blk2-addr
|
|
\ Write a new blk2
|
|
DUP 1024 BL FILL \ blk1 blk2 blk2-addr
|
|
BLOCK-RND DUP >R \ blk1 blk2 blk2-addr rnd2
|
|
0 <# #S #> \ blk1 blk2 blk2-addr c-addr u
|
|
ROT SWAP CHARS MOVE \ blk1 blk2
|
|
\ The following UPDATE should refer to the LOADed blk2, not blk1
|
|
UPDATE FLUSH \ blk1 blk2
|
|
\ Finally, load both blocks then collect all results
|
|
LOAD SWAP LOAD \ u2 u1
|
|
R> R> R> R> \ u2 u1 rnd2 blk2-addr rnd1' rnd1
|
|
THEN ;
|
|
T{ 2RND-TEST-BLOCKS TL7 \ run test procedure
|
|
SWAP DROP SWAP DROP \ u2 u1 rnd2 rnd1
|
|
2= -> TRUE }T
|
|
|
|
\ I would expect LOAD to work on the contents of the buffer cache
|
|
\ and not the block device, but the specification doesn't say.
|
|
\ Similarly, I would not expect LOAD to FLUSH the buffer cache,
|
|
\ but the specification doesn't say so.
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING LIST and SCR
|
|
|
|
\ Signatures
|
|
T{ SCR DUP ALIGNED = -> TRUE }T
|
|
\ LIST signature is test implicitly in the following tests...
|
|
|
|
: TLS1 ( blk -- )
|
|
S" Should show a (mostly) blank screen" WRITE-BLOCK ;
|
|
T{ RND-TEST-BLOCK DUP TLS1 DUP LIST SCR @ = -> TRUE }T
|
|
|
|
\ Boundary Test: FIRST-TEST-BLOCK
|
|
: TLS2 ( blk -- )
|
|
S" List of the First test block" WRITE-BLOCK ;
|
|
T{ FIRST-TEST-BLOCK DUP TLS2 LIST -> }T
|
|
|
|
\ Boundary Test: LIMIT-TEST-BLOCK
|
|
: TLS3 ( blk -- )
|
|
S" List of the Last test block" WRITE-BLOCK ;
|
|
T{ LIMIT-TEST-BLOCK 1- DUP TLS3 LIST -> }T
|
|
|
|
\ Boundary Test: End of Screen
|
|
: TLS4 ( blk -- )
|
|
S" End of Screen" WRITE-AT-END-OF-BLOCK ;
|
|
T{ RND-TEST-BLOCK DUP TLS4 LIST -> }T
|
|
|
|
\ BLOCK, BUFFER, UPDATE et al don't change SCR
|
|
: TLS5 ( blk -- )
|
|
S" Should show another (mostly) blank screen" WRITE-BLOCK ;
|
|
\ the first test below sets the scenario for the subsequent tests
|
|
\ BLK is unchanged by LIST
|
|
T{ BLK @ RND-TEST-BLOCK DUP TLS5 LIST BLK @ = -> TRUE }T
|
|
\ SCR is unchanged by Earlier words
|
|
T{ SCR @ FLUSH SCR @ = -> TRUE }T
|
|
T{ SCR @ FLUSH DUP 1+ BUFFER DROP SCR @ = -> TRUE }T
|
|
T{ SCR @ FLUSH DUP 1+ BLOCK DROP SCR @ = -> TRUE }T
|
|
T{ SCR @ FLUSH DUP 1+ BLOCK DROP UPDATE SCR @ = -> TRUE }T
|
|
T{ SCR @ FLUSH DUP 1+ BLOCK DROP UPDATE SAVE-BUFFERS SCR @ = -> TRUE }T
|
|
: TLS6 ( blk -- )
|
|
S" SCR @" WRITE-BLOCK ;
|
|
T{ SCR @ RND-TEST-BLOCK DUP TLS6 LOAD SCR @ OVER 2= -> TRUE }T
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING EMPTY-BUFFERS
|
|
|
|
T{ EMPTY-BUFFERS -> }T
|
|
T{ BLK @ EMPTY-BUFFERS BLK @ = -> TRUE }T
|
|
T{ SCR @ EMPTY-BUFFERS SCR @ = -> TRUE }T
|
|
|
|
\ Test R/W, but discarded changes with EMPTY-BUFFERS
|
|
T{ RND-TEST-BLOCK \ blk
|
|
DUP BLANK-BUFFER \ blk blk-addr1
|
|
1024 ELF-HASH \ blk hash
|
|
UPDATE FLUSH \ blk hash
|
|
OVER BLOCK CHAR \ SWAP C! \ blk hash
|
|
UPDATE EMPTY-BUFFERS FLUSH \ blk hash
|
|
SWAP BLOCK \ hash blk-addr2
|
|
1024 ELF-HASH = -> TRUE }T
|
|
|
|
\ EMPTY-BUFFERS discards all buffers
|
|
: TUF2-EB ( blk1 blk2 -- blk1 blk2 )
|
|
TUF2-1 TUF2-2 EMPTY-BUFFERS ; \ c.f. TUF2-3
|
|
T{ ' TUF2-EB 2RND-TEST-BLOCKS TUF2
|
|
2SWAP 2DROP 2= -> TRUE }T
|
|
|
|
\ FLUSH and then EMPTY-BUFFERS is acceptable but untestable
|
|
\ EMPTY-BUFFERS and then UPDATE is ambiguous and untestable
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING >IN manipulation from a block source
|
|
|
|
: TIN ( blk -- )
|
|
S" 1 8 >IN +! 2 3" WRITE-BLOCK ;
|
|
T{ RND-TEST-BLOCK DUP TIN LOAD -> 1 3 }T
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING \, SAVE-INPUT, RESTORE-INPUT and REFILL from a block source
|
|
|
|
\ Try to determine the number of charaters per line
|
|
\ Assumes an even number of characters per line
|
|
: | ( u -- u-2 ) 2 - ;
|
|
: C/L-CALC ( blk -- c/l )
|
|
DUP BLANK-BUFFER \ blk blk-addr
|
|
[CHAR] \ OVER C! \ blk blk-addr blk:"\"
|
|
511 0 DO \ blk c-addr[i]
|
|
CHAR+ CHAR+ [CHAR] | OVER C! \ blk c-addr[i+1]
|
|
LOOP DROP \ blk blk:"\ | | | | ... |"
|
|
UPDATE SAVE-BUFFERS FLUSH \ blk
|
|
1024 SWAP LOAD ; \ c/l
|
|
[?DEF] C/L
|
|
[?ELSE]
|
|
\? .( Given Characters per Line: ) C/L U. CR
|
|
[?ELSE]
|
|
\? RND-TEST-BLOCK C/L-CALC CONSTANT C/L
|
|
\? C/L 1024 U< [?IF]
|
|
\? .( Calculated Characters per Line: ) C/L U. CR
|
|
[?THEN]
|
|
|
|
: WRITE-BLOCK-LINE ( lin-addr[i] c-addr u -- lin-addr[i+1] )
|
|
2>R DUP C/L CHARS + SWAP 2R> ROT SWAP MOVE ;
|
|
|
|
\ Discards to the end of the line
|
|
: TCSIRIR1 ( blk -- )
|
|
BLANK-BUFFER
|
|
C/L 1024 U< IF
|
|
S" 2222 \ 3333" WRITE-BLOCK-LINE
|
|
S" 4444" WRITE-BLOCK-LINE
|
|
THEN
|
|
DROP UPDATE SAVE-BUFFERS ;
|
|
|
|
T{ RND-TEST-BLOCK DUP TCSIRIR1 LOAD -> 2222 4444 }T
|
|
|
|
VARIABLE T-CNT 0 T-CNT !
|
|
|
|
: MARK ( "<char>" -- ) \ Use between <# and #>
|
|
CHAR HOLD ; IMMEDIATE
|
|
|
|
: ?EXECUTE ( xt f -- )
|
|
IF EXECUTE ELSE DROP THEN ;
|
|
|
|
\ SAVE-INPUT and RESTORE-INPUT within a single block
|
|
\vf : TCSIRIR2-EXPECTED S" EDCBCBA" ; \ Remember that the string comes out backwards
|
|
\vf : TCSIRIR2 ( blk -- )
|
|
\vf C/L 1024 U< IF
|
|
\vf BLANK-BUFFER
|
|
\vf S" 0 T-CNT !" WRITE-BLOCK-LINE
|
|
\vf S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE
|
|
\vf S" 1 T-CNT +! MARK C ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK D" WRITE-BLOCK-LINE
|
|
\vf S" MARK E 0 0 #>" WRITE-BLOCK-LINE
|
|
\vf UPDATE SAVE-BUFFERS DROP
|
|
\vf ELSE
|
|
\vf S" 0 TCSIRIR2-EXPECTED" WRITE-BLOCK
|
|
\vf THEN ;
|
|
\vf T{ RND-TEST-BLOCK DUP TCSIRIR2 LOAD TCSIRIR2-EXPECTED S= -> 0 TRUE }T
|
|
|
|
\ REFILL across 2 blocks
|
|
\vf : TCSIRIR3 ( blks -- )
|
|
\vf DUP S" 1 2 3 REFILL 4 5 6" WRITE-BLOCK
|
|
\vf 1+ S" 10 11 12" WRITE-BLOCK ;
|
|
\vf T{ 2 RND-TEST-BLOCK-SEQ DUP TCSIRIR3 LOAD -> 1 2 3 -1 10 11 12 }T
|
|
|
|
\ SAVE-INPUT and RESTORE-INPUT across 2 blocks
|
|
\vf : TCSIRIR4-EXPECTED S" HGF1ECBF1ECBA" ; \ Remember that the string comes out backwards
|
|
\vf : TCSIRIR4 ( blks -- )
|
|
\vf C/L 1024 U< IF
|
|
\vf DUP BLANK-BUFFER
|
|
\vf S" 0 T-CNT !" WRITE-BLOCK-LINE
|
|
\vf S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE
|
|
\vf S" MARK C REFILL MARK D" WRITE-BLOCK-LINE
|
|
\vf DROP UPDATE 1+ BLANK-BUFFER
|
|
\vf S" MARK E ABS CHAR 0 + HOLD" WRITE-BLOCK-LINE
|
|
\vf S" 1 T-CNT +! MARK F ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK G" WRITE-BLOCK-LINE
|
|
\vf S" MARK H 0 0 #>" WRITE-BLOCK-LINE
|
|
\vf DROP UPDATE SAVE-BUFFERS
|
|
\vf ELSE
|
|
\vf S" 0 TCSIRIR4-EXPECTED" WRITE-BLOCK
|
|
\vf THEN ;
|
|
\vf T{ 2 RND-TEST-BLOCK-SEQ DUP TCSIRIR4 LOAD TCSIRIR4-EXPECTED S= -> 0 TRUE }T
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
TESTING THRU
|
|
|
|
: TT1 ( blks -- )
|
|
DUP S" BLK" WRITE-BLOCK
|
|
1+ S" @" WRITE-BLOCK ;
|
|
T{ 2 RND-TEST-BLOCK-SEQ DUP TT1 DUP DUP 1+ THRU 1- = -> TRUE }T
|
|
|
|
\ ------------------------------------------------------------------------------
|
|
|
|
BLOCK-ERRORS SET-ERROR-COUNT
|
|
|
|
CR .( End of Block word tests) CR
|