diff --git a/.Floppies/A2OSX.MAKE.po b/.Floppies/A2OSX.MAKE.po index fdd09223..c0bd3fd4 100644 Binary files a/.Floppies/A2OSX.MAKE.po and b/.Floppies/A2OSX.MAKE.po differ diff --git a/.Floppies/STABLE.32MB.po b/.Floppies/STABLE.32MB.po index 51541b87..b48bc199 100644 Binary files a/.Floppies/STABLE.32MB.po and b/.Floppies/STABLE.32MB.po differ diff --git a/FORTH/blocktest.f b/FORTH/blocktest.f new file mode 100644 index 00000000..fcc0ca33 --- /dev/null +++ b/FORTH/blocktest.f @@ -0,0 +1,675 @@ +\ 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 +: EVALUATE-BLK@ ( -- BLK@ ) + S" BLK @" EVALUATE ; +: TL4 ( blk -- ) + S" EVALUATE-BLK@" WRITE-BLOCK ; +T{ RND-TEST-BLOCK DUP TL4 LOAD -> 0 }T + +\ EVALUTE can nest with LOAD +\ u: "BLK @"; S" u LOAD" EVALUATE +: TL5 ( blk -- c-addr u ) + 0 <# \ blk 0 + [CHAR] D HOLD + [CHAR] A HOLD + [CHAR] O HOLD + [CHAR] L HOLD + BL HOLD + #S #> ; \ c-addr u +T{ RND-TEST-BLOCK DUP TL3 DUP TL5 EVALUATE = -> TRUE }T + +\ Nested LOADs +\ u2: "BLK @"; u1: "LOAD u2"; u1 LOAD +: TL6 ( blk1 blk2 -- ) + DUP TL3 \ blk1 blk2 + TL5 WRITE-BLOCK ; +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 ( "" -- ) \ Use between <# and #> + CHAR HOLD ; IMMEDIATE + +: ?EXECUTE ( xt f -- ) + IF EXECUTE ELSE DROP THEN ; + +\ SAVE-INPUT and RESTORE-INPUT within a single block +: TCSIRIR2-EXPECTED S" EDCBCBA" ; \ Remember that the string comes out backwards +: TCSIRIR2 ( blk -- ) + C/L 1024 U< IF + BLANK-BUFFER + S" 0 T-CNT !" WRITE-BLOCK-LINE + S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE +S" 1 T-CNT +! MARK C ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK D" WRITE-BLOCK-LINE + S" MARK E 0 0 #>" WRITE-BLOCK-LINE + UPDATE SAVE-BUFFERS DROP + ELSE + S" 0 TCSIRIR2-EXPECTED" WRITE-BLOCK + THEN ; +T{ RND-TEST-BLOCK DUP TCSIRIR2 LOAD TCSIRIR2-EXPECTED S= -> 0 TRUE }T + +\ REFILL across 2 blocks +: TCSIRIR3 ( blks -- ) + DUP S" 1 2 3 REFILL 4 5 6" WRITE-BLOCK + 1+ S" 10 11 12" WRITE-BLOCK ; +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 +: TCSIRIR4-EXPECTED S" HGF1ECBF1ECBA" ; \ Remember that the string comes out backwards +: TCSIRIR4 ( blks -- ) + C/L 1024 U< IF + DUP BLANK-BUFFER + S" 0 T-CNT !" WRITE-BLOCK-LINE + S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE + S" MARK C REFILL MARK D" WRITE-BLOCK-LINE + DROP UPDATE 1+ BLANK-BUFFER + S" MARK E ABS CHAR 0 + HOLD" WRITE-BLOCK-LINE +S" 1 T-CNT +! MARK F ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK G" WRITE-BLOCK-LINE + S" MARK H 0 0 #>" WRITE-BLOCK-LINE + DROP UPDATE SAVE-BUFFERS + ELSE + S" 0 TCSIRIR4-EXPECTED" WRITE-BLOCK + THEN ; +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 diff --git a/FORTH/core.f b/FORTH/core.f new file mode 100644 index 00000000..31014819 --- /dev/null +++ b/FORTH/core.f @@ -0,0 +1,1014 @@ +NEW + PREFIX +AUTO 4,1 +#!/bin/forth +\ From: John Hayes S1I +\ Subject: core.f +\ Date: Mon, 27 Nov 95 13:10 + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 +\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. +\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE +\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND +\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. +\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... +\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... + +CR +TESTING CORE WORDS +HEX + +\ ------------------------------------------------------------------------ +TESTING BASIC ASSUMPTIONS + +T{ -> }T \ START WITH CLEAN SLATE +( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) +T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T +T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR ) +T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT ) +T{ -1 BITSSET? -> 0 0 }T + +\ ------------------------------------------------------------------------ +TESTING BOOLEANS: INVERT AND OR XOR + +T{ 0 0 AND -> 0 }T +T{ 0 1 AND -> 0 }T +T{ 1 0 AND -> 0 }T +T{ 1 1 AND -> 1 }T + +T{ 0 INVERT 1 AND -> 1 }T +T{ 1 INVERT 1 AND -> 0 }T + +0 CONSTANT 0S +0 INVERT CONSTANT 1S + +T{ 0S INVERT -> 1S }T +T{ 1S INVERT -> 0S }T + +T{ 0S 0S AND -> 0S }T +T{ 0S 1S AND -> 0S }T +T{ 1S 0S AND -> 0S }T +T{ 1S 1S AND -> 1S }T + +T{ 0S 0S OR -> 0S }T +T{ 0S 1S OR -> 1S }T +T{ 1S 0S OR -> 1S }T +T{ 1S 1S OR -> 1S }T + +T{ 0S 0S XOR -> 0S }T +T{ 0S 1S XOR -> 1S }T +T{ 1S 0S XOR -> 1S }T +T{ 1S 1S XOR -> 0S }T + +\ ------------------------------------------------------------------------ +TESTING 2* 2/ LSHIFT RSHIFT + +( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) +1S 1 RSHIFT INVERT CONSTANT MSB +T{ MSB BITSSET? -> 0 0 }T + +T{ 0S 2* -> 0S }T +T{ 1 2* -> 2 }T +T{ 4000 2* -> 8000 }T +T{ 1S 2* 1 XOR -> 1S }T +T{ MSB 2* -> 0S }T + +T{ 0S 2/ -> 0S }T +T{ 1 2/ -> 0 }T +T{ 4000 2/ -> 2000 }T +T{ 1S 2/ -> 1S }T \ MSB PROPOGATED +T{ 1S 1 XOR 2/ -> 1S }T +T{ MSB 2/ MSB AND -> MSB }T + +T{ 1 0 LSHIFT -> 1 }T +T{ 1 1 LSHIFT -> 2 }T +T{ 1 2 LSHIFT -> 4 }T +T{ 1 F LSHIFT -> 8000 }T \ BIGGEST GUARANTEED SHIFT +T{ 1S 1 LSHIFT 1 XOR -> 1S }T +T{ MSB 1 LSHIFT -> 0 }T + +T{ 1 0 RSHIFT -> 1 }T +T{ 1 1 RSHIFT -> 0 }T +T{ 2 1 RSHIFT -> 1 }T +T{ 4 2 RSHIFT -> 1 }T +T{ 8000 F RSHIFT -> 1 }T \ BIGGEST +T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT ZERO FILLS MSBS +T{ MSB 1 RSHIFT 2* -> MSB }T + +\ ------------------------------------------------------------------------ +TESTING COMPARISONS: 0= = 0< < > U< MIN MAX +0 INVERT CONSTANT MAX-UINT +0 INVERT 1 RSHIFT CONSTANT MAX-INT +0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +0 INVERT 1 RSHIFT CONSTANT MID-UINT +0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +0S CONSTANT +1S CONSTANT + +T{ 0 0= -> }T +T{ 1 0= -> }T +T{ 2 0= -> }T +T{ -1 0= -> }T +T{ MAX-UINT 0= -> }T +T{ MIN-INT 0= -> }T +T{ MAX-INT 0= -> }T + +T{ 0 0 = -> }T +T{ 1 1 = -> }T +T{ -1 -1 = -> }T +T{ 1 0 = -> }T +T{ -1 0 = -> }T +T{ 0 1 = -> }T +T{ 0 -1 = -> }T + +T{ 0 0< -> }T +T{ -1 0< -> }T +T{ MIN-INT 0< -> }T +T{ 1 0< -> }T +T{ MAX-INT 0< -> }T + +T{ 0 1 < -> }T +T{ 1 2 < -> }T +T{ -1 0 < -> }T +T{ -1 1 < -> }T +T{ MIN-INT 0 < -> }T +T{ MIN-INT MAX-INT < -> }T +T{ 0 MAX-INT < -> }T +T{ 0 0 < -> }T +T{ 1 1 < -> }T +T{ 1 0 < -> }T +T{ 2 1 < -> }T +T{ 0 -1 < -> }T +T{ 1 -1 < -> }T +T{ 0 MIN-INT < -> }T +T{ MAX-INT MIN-INT < -> }T +T{ MAX-INT 0 < -> }T + +T{ 0 1 > -> }T +T{ 1 2 > -> }T +T{ -1 0 > -> }T +T{ -1 1 > -> }T +T{ MIN-INT 0 > -> }T +T{ MIN-INT MAX-INT > -> }T +T{ 0 MAX-INT > -> }T +T{ 0 0 > -> }T +T{ 1 1 > -> }T +T{ 1 0 > -> }T +T{ 2 1 > -> }T +T{ 0 -1 > -> }T +T{ 1 -1 > -> }T +T{ 0 MIN-INT > -> }T +T{ MAX-INT MIN-INT > -> }T +T{ MAX-INT 0 > -> }T + +T{ 0 1 U< -> }T +T{ 1 2 U< -> }T +T{ 0 MID-UINT U< -> }T +T{ 0 MAX-UINT U< -> }T +T{ MID-UINT MAX-UINT U< -> }T +T{ 0 0 U< -> }T +T{ 1 1 U< -> }T +T{ 1 0 U< -> }T +T{ 2 1 U< -> }T +T{ MID-UINT 0 U< -> }T +T{ MAX-UINT 0 U< -> }T +T{ MAX-UINT MID-UINT U< -> }T + +T{ 0 1 MIN -> 0 }T +T{ 1 2 MIN -> 1 }T +T{ -1 0 MIN -> -1 }T +T{ -1 1 MIN -> -1 }T +T{ MIN-INT 0 MIN -> MIN-INT }T +T{ MIN-INT MAX-INT MIN -> MIN-INT }T +T{ 0 MAX-INT MIN -> 0 }T +T{ 0 0 MIN -> 0 }T +T{ 1 1 MIN -> 1 }T +T{ 1 0 MIN -> 0 }T +T{ 2 1 MIN -> 1 }T +T{ 0 -1 MIN -> -1 }T +T{ 1 -1 MIN -> -1 }T +T{ 0 MIN-INT MIN -> MIN-INT }T +T{ MAX-INT MIN-INT MIN -> MIN-INT }T +T{ MAX-INT 0 MIN -> 0 }T + +T{ 0 1 MAX -> 1 }T +T{ 1 2 MAX -> 2 }T +T{ -1 0 MAX -> 0 }T +T{ -1 1 MAX -> 1 }T +T{ MIN-INT 0 MAX -> 0 }T +T{ MIN-INT MAX-INT MAX -> MAX-INT }T +T{ 0 MAX-INT MAX -> MAX-INT }T +T{ 0 0 MAX -> 0 }T +T{ 1 1 MAX -> 1 }T +T{ 1 0 MAX -> 1 }T +T{ 2 1 MAX -> 2 }T +T{ 0 -1 MAX -> 0 }T +T{ 1 -1 MAX -> 1 }T +T{ 0 MIN-INT MAX -> 0 }T +T{ MAX-INT MIN-INT MAX -> MAX-INT }T +T{ MAX-INT 0 MAX -> MAX-INT }T + +\ ------------------------------------------------------------------------ +TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP + +T{ 1 2 2DROP -> }T +T{ 1 2 2DUP -> 1 2 1 2 }T +T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T +T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T +T{ 0 ?DUP -> 0 }T +T{ 1 ?DUP -> 1 1 }T +T{ -1 ?DUP -> -1 -1 }T +T{ DEPTH -> 0 }T +T{ 0 DEPTH -> 0 1 }T +T{ 0 1 DEPTH -> 0 1 2 }T +T{ 0 DROP -> }T +T{ 1 2 DROP -> 1 }T +T{ 1 DUP -> 1 1 }T +T{ 1 2 OVER -> 1 2 1 }T +T{ 1 2 3 ROT -> 2 3 1 }T +T{ 1 2 SWAP -> 2 1 }T + +\ ------------------------------------------------------------------------ +TESTING >R R> R@ + +T{ : GR1 >R R> ; -> }T +T{ : GR2 >R R@ R> DROP ; -> }T +T{ 123 GR1 -> 123 }T +T{ 123 GR2 -> 123 }T +T{ 1S GR1 -> 1S }T ( RETURN STACK HOLDS CELLS ) + +\ ------------------------------------------------------------------------ +TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE + +T{ 0 5 + -> 5 }T +T{ 5 0 + -> 5 }T +T{ 0 -5 + -> -5 }T +T{ -5 0 + -> -5 }T +T{ 1 2 + -> 3 }T +T{ 1 -2 + -> -1 }T +T{ -1 2 + -> 1 }T +T{ -1 -2 + -> -3 }T +T{ -1 1 + -> 0 }T +T{ MID-UINT 1 + -> MID-UINT+1 }T + +T{ 0 5 - -> -5 }T +T{ 5 0 - -> 5 }T +T{ 0 -5 - -> 5 }T +T{ -5 0 - -> -5 }T +T{ 1 2 - -> -1 }T +T{ 1 -2 - -> 3 }T +T{ -1 2 - -> -3 }T +T{ -1 -2 - -> 1 }T +T{ 0 1 - -> -1 }T +T{ MID-UINT+1 1 - -> MID-UINT }T + +T{ 0 1+ -> 1 }T +T{ -1 1+ -> 0 }T +T{ 1 1+ -> 2 }T +T{ MID-UINT 1+ -> MID-UINT+1 }T + +T{ 2 1- -> 1 }T +T{ 1 1- -> 0 }T +T{ 0 1- -> -1 }T +T{ MID-UINT+1 1- -> MID-UINT }T + +T{ 0 NEGATE -> 0 }T +T{ 1 NEGATE -> -1 }T +T{ -1 NEGATE -> 1 }T +T{ 2 NEGATE -> -2 }T +T{ -2 NEGATE -> 2 }T + +T{ 0 ABS -> 0 }T +T{ 1 ABS -> 1 }T +T{ -1 ABS -> 1 }T +T{ MIN-INT ABS -> MID-UINT+1 }T + +\ ------------------------------------------------------------------------ +TESTING MULTIPLY: S>D * M* UM* + +T{ 0 S>D -> 0 0 }T +T{ 1 S>D -> 1 0 }T +T{ 2 S>D -> 2 0 }T +T{ -1 S>D -> -1 -1 }T +T{ -2 S>D -> -2 -1 }T +T{ MIN-INT S>D -> MIN-INT -1 }T +T{ MAX-INT S>D -> MAX-INT 0 }T + +T{ 0 0 M* -> 0 S>D }T +T{ 0 1 M* -> 0 S>D }T +T{ 1 0 M* -> 0 S>D }T +T{ 1 2 M* -> 2 S>D }T +T{ 2 1 M* -> 2 S>D }T +T{ 3 3 M* -> 9 S>D }T +T{ -3 3 M* -> -9 S>D }T +T{ 3 -3 M* -> -9 S>D }T +T{ -3 -3 M* -> 9 S>D }T +T{ 0 MIN-INT M* -> 0 S>D }T +T{ 1 MIN-INT M* -> MIN-INT S>D }T +T{ 2 MIN-INT M* -> 0 1S }T +T{ 0 MAX-INT M* -> 0 S>D }T +T{ 1 MAX-INT M* -> MAX-INT S>D }T +T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T +T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T +T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T +T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T + +T{ 0 0 * -> 0 }T \ TEST IDENTITIES +T{ 0 1 * -> 0 }T +T{ 1 0 * -> 0 }T +T{ 1 2 * -> 2 }T +T{ 2 1 * -> 2 }T +T{ 3 3 * -> 9 }T +T{ -3 3 * -> -9 }T +T{ 3 -3 * -> -9 }T +T{ -3 -3 * -> 9 }T + +T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T +T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T +T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T + +T{ 0 0 UM* -> 0 0 }T +T{ 0 1 UM* -> 0 0 }T +T{ 1 0 UM* -> 0 0 }T +T{ 1 2 UM* -> 2 0 }T +T{ 2 1 UM* -> 2 0 }T +T{ 3 3 UM* -> 9 0 }T + +T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T +T{ MID-UINT+1 2 UM* -> 0 1 }T +T{ MID-UINT+1 4 UM* -> 0 2 }T +T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T +T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T + +\ ------------------------------------------------------------------------ +TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD + +T{ 0 S>D 1 FM/MOD -> 0 0 }T +T{ 1 S>D 1 FM/MOD -> 0 1 }T +T{ 2 S>D 1 FM/MOD -> 0 2 }T +T{ -1 S>D 1 FM/MOD -> 0 -1 }T +T{ -2 S>D 1 FM/MOD -> 0 -2 }T +T{ 0 S>D -1 FM/MOD -> 0 0 }T +T{ 1 S>D -1 FM/MOD -> 0 -1 }T +T{ 2 S>D -1 FM/MOD -> 0 -2 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -1 FM/MOD -> 0 2 }T +T{ 2 S>D 2 FM/MOD -> 0 1 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -2 FM/MOD -> 0 1 }T +T{ 7 S>D 3 FM/MOD -> 1 2 }T +T{ 7 S>D -3 FM/MOD -> -2 -3 }T +T{ -7 S>D 3 FM/MOD -> 2 -3 }T +T{ -7 S>D -3 FM/MOD -> -1 2 }T +T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T +T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T +T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T +T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T +T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T +T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T +T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T +T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T +T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T +T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T + +T{ 0 S>D 1 SM/REM -> 0 0 }T +T{ 1 S>D 1 SM/REM -> 0 1 }T +T{ 2 S>D 1 SM/REM -> 0 2 }T +T{ -1 S>D 1 SM/REM -> 0 -1 }T +T{ -2 S>D 1 SM/REM -> 0 -2 }T +T{ 0 S>D -1 SM/REM -> 0 0 }T +T{ 1 S>D -1 SM/REM -> 0 -1 }T +T{ 2 S>D -1 SM/REM -> 0 -2 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -1 SM/REM -> 0 2 }T +T{ 2 S>D 2 SM/REM -> 0 1 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -2 SM/REM -> 0 1 }T +T{ 7 S>D 3 SM/REM -> 1 2 }T +T{ 7 S>D -3 SM/REM -> 1 -2 }T +T{ -7 S>D 3 SM/REM -> -1 -2 }T +T{ -7 S>D -3 SM/REM -> -1 2 }T +T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T +T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T +T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T +T{ 1S 1 4 SM/REM -> 3 MAX-INT }T +T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T +T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T + +T{ 0 0 1 UM/MOD -> 0 0 }T +T{ 1 0 1 UM/MOD -> 0 1 }T +T{ 1 0 2 UM/MOD -> 1 0 }T +T{ 3 0 2 UM/MOD -> 1 1 }T +T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T +T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T +T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T + +: IFFLOORED + [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +: IFSYM + [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. +\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. + +IFFLOORED : T/MOD >R S>D R> FM/MOD ; +IFFLOORED : T/ T/MOD SWAP DROP ; +IFFLOORED : TMOD T/MOD DROP ; +IFFLOORED : T*/MOD >R M* R> FM/MOD ; +IFFLOORED : T*/ T*/MOD SWAP DROP ; +IFSYM : T/MOD >R S>D R> SM/REM ; +IFSYM : T/ T/MOD SWAP DROP ; +IFSYM : TMOD T/MOD DROP ; +IFSYM : T*/MOD >R M* R> SM/REM ; +IFSYM : T*/ T*/MOD SWAP DROP ; + +T{ 0 1 /MOD -> 0 1 T/MOD }T +T{ 1 1 /MOD -> 1 1 T/MOD }T +T{ 2 1 /MOD -> 2 1 T/MOD }T +T{ -1 1 /MOD -> -1 1 T/MOD }T +T{ -2 1 /MOD -> -2 1 T/MOD }T +T{ 0 -1 /MOD -> 0 -1 T/MOD }T +T{ 1 -1 /MOD -> 1 -1 T/MOD }T +T{ 2 -1 /MOD -> 2 -1 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -1 /MOD -> -2 -1 T/MOD }T +T{ 2 2 /MOD -> 2 2 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -2 /MOD -> -2 -2 T/MOD }T +T{ 7 3 /MOD -> 7 3 T/MOD }T +T{ 7 -3 /MOD -> 7 -3 T/MOD }T +T{ -7 3 /MOD -> -7 3 T/MOD }T +T{ -7 -3 /MOD -> -7 -3 T/MOD }T +T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T +T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T +T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T +T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T + +T{ 0 1 / -> 0 1 T/ }T +T{ 1 1 / -> 1 1 T/ }T +T{ 2 1 / -> 2 1 T/ }T +T{ -1 1 / -> -1 1 T/ }T +T{ -2 1 / -> -2 1 T/ }T +T{ 0 -1 / -> 0 -1 T/ }T +T{ 1 -1 / -> 1 -1 T/ }T +T{ 2 -1 / -> 2 -1 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -1 / -> -2 -1 T/ }T +T{ 2 2 / -> 2 2 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -2 / -> -2 -2 T/ }T +T{ 7 3 / -> 7 3 T/ }T +T{ 7 -3 / -> 7 -3 T/ }T +T{ -7 3 / -> -7 3 T/ }T +T{ -7 -3 / -> -7 -3 T/ }T +T{ MAX-INT 1 / -> MAX-INT 1 T/ }T +T{ MIN-INT 1 / -> MIN-INT 1 T/ }T +T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T +T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T + +T{ 0 1 MOD -> 0 1 TMOD }T +T{ 1 1 MOD -> 1 1 TMOD }T +T{ 2 1 MOD -> 2 1 TMOD }T +T{ -1 1 MOD -> -1 1 TMOD }T +T{ -2 1 MOD -> -2 1 TMOD }T +T{ 0 -1 MOD -> 0 -1 TMOD }T +T{ 1 -1 MOD -> 1 -1 TMOD }T +T{ 2 -1 MOD -> 2 -1 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -1 MOD -> -2 -1 TMOD }T +T{ 2 2 MOD -> 2 2 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -2 MOD -> -2 -2 TMOD }T +T{ 7 3 MOD -> 7 3 TMOD }T +T{ 7 -3 MOD -> 7 -3 TMOD }T +T{ -7 3 MOD -> -7 3 TMOD }T +T{ -7 -3 MOD -> -7 -3 TMOD }T +T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T +T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T +T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T +T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T + +T{ 0 2 1 */ -> 0 2 1 T*/ }T +T{ 1 2 1 */ -> 1 2 1 T*/ }T +T{ 2 2 1 */ -> 2 2 1 T*/ }T +T{ -1 2 1 */ -> -1 2 1 T*/ }T +T{ -2 2 1 */ -> -2 2 1 T*/ }T +T{ 0 2 -1 */ -> 0 2 -1 T*/ }T +T{ 1 2 -1 */ -> 1 2 -1 T*/ }T +T{ 2 2 -1 */ -> 2 2 -1 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -1 */ -> -2 2 -1 T*/ }T +T{ 2 2 2 */ -> 2 2 2 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -2 */ -> -2 2 -2 T*/ }T +T{ 7 2 3 */ -> 7 2 3 T*/ }T +T{ 7 2 -3 */ -> 7 2 -3 T*/ }T +T{ -7 2 3 */ -> -7 2 3 T*/ }T +T{ -7 2 -3 */ -> -7 2 -3 T*/ }T +T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T +T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T + +T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T +T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T +T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T +T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T +T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T +T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T +T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T +T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T +T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T +T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T +T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T +T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T +T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T +T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T +T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T + +\ ------------------------------------------------------------------------ +TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT + +HERE 1 ALLOT +HERE +CONSTANT 2NDA +CONSTANT 1STA +T{ 1STA 2NDA U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT +( MISSING TEST: NEGATIVE ALLOT ) + +\ Added by GWJ so that ALIGN can be used before , (comma) is tested +1 ALIGNED CONSTANT ALMNT \ -- 1|2|4|8 for 8|16|32|64 bit alignment +ALIGN +T{ HERE 1 ALLOT ALIGN HERE SWAP - ALMNT = -> }T +\ End of extra test + +HERE 1 , +HERE 2 , +CONSTANT 2ND +CONSTANT 1ST +T{ 1ST 2ND U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL +T{ 1ST 1 CELLS + -> 2ND }T +T{ 1ST @ 2ND @ -> 1 2 }T +T{ 5 1ST ! -> }T +T{ 1ST @ 2ND @ -> 5 2 }T +T{ 6 2ND ! -> }T +T{ 1ST @ 2ND @ -> 5 6 }T +T{ 1ST 2@ -> 6 5 }T +T{ 2 1 1ST 2! -> }T +T{ 1ST 2@ -> 2 1 }T +T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE + +HERE 1 C, +HERE 2 C, +CONSTANT 2NDC +CONSTANT 1STC +T{ 1STC 2NDC U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR +T{ 1STC 1 CHARS + -> 2NDC }T +T{ 1STC C@ 2NDC C@ -> 1 2 }T +T{ 3 1STC C! -> }T +T{ 1STC C@ 2NDC C@ -> 3 2 }T +T{ 4 2NDC C! -> }T +T{ 1STC C@ 2NDC C@ -> 3 4 }T + +ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT +CONSTANT A-ADDR CONSTANT UA-ADDR +T{ UA-ADDR ALIGNED -> A-ADDR }T +T{ 1 A-ADDR C! A-ADDR C@ -> 1 }T +T{ 1234 A-ADDR ! A-ADDR @ -> 1234 }T +T{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }T +T{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }T +T{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }T +T{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }T +T{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }T + +: BITS ( X -- U ) + 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; +( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) +T{ 1 CHARS 1 < -> }T +T{ 1 CHARS 1 CELLS > -> }T +( TBD: HOW TO FIND NUMBER OF BITS? ) + +( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) +T{ 1 CELLS 1 < -> }T +T{ 1 CELLS 1 CHARS MOD -> 0 }T +T{ 1S BITS 10 < -> }T + +T{ 0 1ST ! -> }T +T{ 1 1ST +! -> }T +T{ 1ST @ -> 1 }T +T{ -1 1ST +! 1ST @ -> 0 }T + +\ ------------------------------------------------------------------------ +TESTING CHAR [CHAR] [ ] BL S" + +T{ BL -> 20 }T +T{ CHAR X -> 58 }T +T{ CHAR HELLO -> 48 }T +T{ : GC1 [CHAR] X ; -> }T +T{ : GC2 [CHAR] HELLO ; -> }T +T{ GC1 -> 58 }T +T{ GC2 -> 48 }T +T{ : GC3 [ GC1 ] LITERAL ; -> }T +T{ GC3 -> 58 }T +T{ : GC4 S" XY" ; -> }T +T{ GC4 SWAP DROP -> 2 }T +T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T + +\ ------------------------------------------------------------------------ +TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE + +T{ : GT1 123 ; -> }T +T{ ' GT1 EXECUTE -> 123 }T +T{ : GT2 ['] GT1 ; IMMEDIATE -> }T +T{ GT2 EXECUTE -> 123 }T +HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING +HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING +T{ GT1STRING FIND -> ' GT1 -1 }T +T{ GT2STRING FIND -> ' GT2 1 }T +( HOW TO SEARCH FOR NON-EXISTENT WORD? ) +T{ : GT3 GT2 LITERAL ; -> }T +T{ GT3 -> ' GT1 }T +T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T + +T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T +T{ : GT5 GT4 ; -> }T +T{ GT5 -> 123 }T +T{ : GT6 345 ; IMMEDIATE -> }T +T{ : GT7 POSTPONE GT6 ; -> }T +T{ GT7 -> 345 }T + +T{ : GT8 STATE @ ; IMMEDIATE -> }T +T{ GT8 -> 0 }T +T{ : GT9 GT8 LITERAL ; -> }T +T{ GT9 0= -> }T + +\ ------------------------------------------------------------------------ +TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE + +T{ : GI1 IF 123 THEN ; -> }T +T{ : GI2 IF 123 ELSE 234 THEN ; -> }T +T{ 0 GI1 -> }T +T{ 1 GI1 -> 123 }T +T{ -1 GI1 -> 123 }T +T{ 0 GI2 -> 234 }T +T{ 1 GI2 -> 123 }T +T{ -1 GI1 -> 123 }T + +T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T +T{ 0 GI3 -> 0 1 2 3 4 5 }T +T{ 4 GI3 -> 4 5 }T +T{ 5 GI3 -> 5 }T +T{ 6 GI3 -> 6 }T + +T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T +T{ 3 GI4 -> 3 4 5 6 }T +T{ 5 GI4 -> 5 6 }T +T{ 6 GI4 -> 6 7 }T + +T{ : GI5 BEGIN DUP 2 > + WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T +T{ 1 GI5 -> 1 345 }T +T{ 2 GI5 -> 2 345 }T +T{ 3 GI5 -> 3 4 5 123 }T +T{ 4 GI5 -> 4 5 123 }T +T{ 5 GI5 -> 5 123 }T + +T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T +T{ 0 GI6 -> 0 }T +T{ 1 GI6 -> 0 1 }T +T{ 2 GI6 -> 0 1 2 }T +T{ 3 GI6 -> 0 1 2 3 }T +T{ 4 GI6 -> 0 1 2 3 4 }T + +\ ------------------------------------------------------------------------ +TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT + +T{ : GD1 DO I LOOP ; -> }T +T{ 4 1 GD1 -> 1 2 3 }T +T{ 2 -1 GD1 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T + +T{ : GD2 DO I -1 +LOOP ; -> }T +T{ 1 4 GD2 -> 4 3 2 1 }T +T{ -1 2 GD2 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T + +T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T +T{ 4 1 GD3 -> 1 2 3 }T +T{ 2 -1 GD3 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T + +T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T +T{ 1 4 GD4 -> 4 3 2 1 }T +T{ -1 2 GD4 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T + +T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T +T{ 1 GD5 -> 123 }T +T{ 5 GD5 -> 123 }T +T{ 6 GD5 -> 234 }T + +T{ : GD6 ( PAT: T{0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) + 0 SWAP 0 DO + I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP + LOOP ; -> }T +T{ 1 GD6 -> 1 }T +T{ 2 GD6 -> 3 }T +T{ 3 GD6 -> 4 1 2 }T + +\ ------------------------------------------------------------------------ +TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY + +T{ 123 CONSTANT X123 -> }T +T{ X123 -> 123 }T +T{ : EQU CONSTANT ; -> }T +T{ X123 EQU Y123 -> }T +T{ Y123 -> 123 }T + +T{ VARIABLE V1 -> }T +T{ 123 V1 ! -> }T +T{ V1 @ -> 123 }T + +T{ : NOP : POSTPONE ; ; -> }T +T{ NOP NOP1 NOP NOP2 -> }T +T{ NOP1 -> }T +T{ NOP2 -> }T + +T{ : DOES1 DOES> @ 1 + ; -> }T +T{ : DOES2 DOES> @ 2 + ; -> }T +T{ CREATE CR1 -> }T +T{ CR1 -> HERE }T +T{ ' CR1 >BODY -> HERE }T +T{ 1 , -> }T +T{ CR1 @ -> 1 }T +T{ DOES1 -> }T +T{ CR1 -> 2 }T +T{ DOES2 -> }T +T{ CR1 -> 3 }T + +T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T +T{ WEIRD: W1 -> }T +T{ ' W1 >BODY -> HERE }T +T{ W1 -> HERE 1 + }T +T{ W1 -> HERE 2 + }T + +\ ------------------------------------------------------------------------ +TESTING EVALUATE + +: GE1 S" 123" ; IMMEDIATE +: GE2 S" 123 1+" ; IMMEDIATE +: GE3 S" : GE4 345 ;" ; +: GE5 EVALUATE ; IMMEDIATE + +T{ GE1 EVALUATE -> 123 }T ( TEST EVALUATE IN INTERP. STATE ) +T{ GE2 EVALUATE -> 124 }T +T{ GE3 EVALUATE -> }T +T{ GE4 -> 345 }T + +T{ : GE6 GE1 GE5 ; -> }T ( TEST EVALUATE IN COMPILE STATE ) +T{ GE6 -> 123 }T +T{ : GE7 GE2 GE5 ; -> }T +T{ GE7 -> 124 }T + +\ ------------------------------------------------------------------------ +TESTING SOURCE >IN WORD + +: GS1 S" SOURCE" 2DUP EVALUATE + >R SWAP >R = R> R> = ; +T{ GS1 -> }T + +VARIABLE SCANS +: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; + +T{ 2 SCANS ! +345 RESCAN? +-> 345 345 }T + +: GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; +T{ GS2 -> 123 123 123 123 123 }T + +: GS3 WORD COUNT SWAP C@ ; +T{ BL GS3 HELLO -> 5 CHAR H }T +T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T +T{ BL GS3 +DROP -> 0 }T \ BLANK LINE RETURN ZERO-LENGTH STRING + +: GS4 SOURCE >IN ! DROP ; +T{ GS4 123 456 +-> }T + +\ ------------------------------------------------------------------------ +TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL + +: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. + >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH + R> ?DUP IF \ IF NON-EMPTY STRINGS + 0 DO + OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN + SWAP CHAR+ SWAP CHAR+ + LOOP + THEN + 2DROP \ IF WE GET HERE, STRINGS MATCH + ELSE + R> DROP 2DROP \ LENGTHS MISMATCH + THEN ; + +: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; +T{ GP1 -> }T + +: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; +T{ GP2 -> }T + +: GP3 <# 1 0 # # #> S" 01" S= ; +T{ GP3 -> }T + +: GP4 <# 1 0 #S #> S" 1" S= ; +T{ GP4 -> }T + +24 CONSTANT MAX-BASE \ BASE 2 .. 36 +: COUNT-BITS + 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; +COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD + +: GP5 + BASE @ + MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE + I BASE ! \ TBD: ASSUMES BASE WORKS + I 0 <# #S #> S" 10" S= AND + LOOP + SWAP BASE ! ; +T{ GP5 -> }T + +: GP6 + BASE @ >R 2 BASE ! + MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY + R> BASE ! \ S: C-ADDR U + DUP #BITS-UD = SWAP + 0 DO \ S: C-ADDR FLAG + OVER C@ [CHAR] 1 = AND \ ALL ONES + >R CHAR+ R> + LOOP SWAP DROP ; +T{ GP6 -> }T + +: GP7 + BASE @ >R MAX-BASE BASE ! + + A 0 DO + I 0 <# #S #> + 1 = SWAP C@ I 30 + = AND AND + LOOP + MAX-BASE A DO + I 0 <# #S #> + 1 = SWAP C@ 41 I A - + = AND AND + LOOP + R> BASE ! ; + +T{ GP7 -> }T + +\ >NUMBER TESTS +CREATE GN-BUF 0 C, +: GN-STRING GN-BUF 1 ; +: GN-CONSUMED GN-BUF CHAR+ 0 ; +: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; + +T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T +T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T +T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T +T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO CONVERT THESE +T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T +T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T + +: >NUMBER-BASED + BASE @ >R BASE ! >NUMBER R> BASE ! ; + +T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T +T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T +T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T +T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T + +: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. + BASE @ >R BASE ! + <# #S #> + 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY + R> BASE ! ; +T{ 0 0 2 GN1 -> 0 0 0 }T +T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T +T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T +T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T + +: GN2 \ ( -- 16 10 ) + BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; +T{ GN2 -> 10 A }T + +\ ------------------------------------------------------------------------ +TESTING FILL MOVE + +CREATE FBUF 00 C, 00 C, 00 C, +CREATE SBUF 12 C, 34 C, 56 C, +: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; + +T{ FBUF 0 20 FILL -> }T +T{ SEEBUF -> 00 00 00 }T + +T{ FBUF 1 20 FILL -> }T +T{ SEEBUF -> 20 00 00 }T + +T{ FBUF 3 20 FILL -> }T +T{ SEEBUF -> 20 20 20 }T + +T{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE +T{ SEEBUF -> 20 20 20 }T + +T{ SBUF FBUF 0 CHARS MOVE -> }T +T{ SEEBUF -> 20 20 20 }T + +T{ SBUF FBUF 1 CHARS MOVE -> }T +T{ SEEBUF -> 12 20 20 }T + +T{ SBUF FBUF 3 CHARS MOVE -> }T +T{ SEEBUF -> 12 34 56 }T + +T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 12 34 }T + +T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 34 34 }T + +\ ------------------------------------------------------------------------ +TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. + +: OUTPUT-TEST + ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR + 41 BL DO I EMIT LOOP CR + 61 41 DO I EMIT LOOP CR + 7F 61 DO I EMIT LOOP CR + ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR + 9 1+ 0 DO I . LOOP CR + ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR + [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR + ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR + [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR + ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR + 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR + ." YOU SHOULD SEE TWO SEPARATE LINES:" CR + S" LINE 1" TYPE CR S" LINE 2" TYPE CR + ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR + ." SIGNED: " MIN-INT . MAX-INT . CR + ." UNSIGNED: " 0 U. MAX-UINT U. CR +; + +T{ OUTPUT-TEST -> }T + + +\ ------------------------------------------------------------------------ +TESTING INPUT: ACCEPT + +CREATE ABUF 50 CHARS ALLOT + +: ACCEPT-TEST + CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR + ABUF 50 ACCEPT + CR ." RECEIVED: " [CHAR] " EMIT + ABUF SWAP TYPE [CHAR] " EMIT CR +; + +T{ ACCEPT-TEST -> }T + +\ ------------------------------------------------------------------------ +TESTING DICTIONARY SEARCH RULES + +T{ : GDX 123 ; : GDX GDX 234 ; -> }T + +T{ GDX -> 123 234 }T + +CR .( End of Core word set tests) CR + +MAN +TEXT /MAKE/USR/SHARE/forth/core.f diff --git a/FORTH/coreexttest.f b/FORTH/coreexttest.f new file mode 100644 index 00000000..51fe62ef --- /dev/null +++ b/FORTH/coreexttest.f @@ -0,0 +1,770 @@ +\ To test the ANS Forth Core Extension word set + +\ This program was written by Gerry Jackson in 2006, 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.13 28 October 2015 +\ Replace and with FALSE and TRUE to avoid +\ dependence on Core tests +\ Moved SAVE-INPUT and RESTORE-INPUT tests in a file to filetest.fth +\ Use of 2VARIABLE (from optional wordset) replaced with CREATE. +\ Minor lower to upper case conversions. +\ Calls to COMPARE replaced by S= (in utilities.fth) to avoid use +\ of a word from an optional word set. +\ UNUSED tests revised as UNUSED UNUSED = may return FALSE when an +\ implementation has the data stack sharing unused dataspace. +\ Double number input dependency removed from the HOLDS tests. +\ Minor case sensitivities removed in definition names. +\ 0.11 25 April 2015 +\ Added tests for PARSE-NAME HOLDS BUFFER: +\ S\" tests added +\ DEFER IS ACTION-OF DEFER! DEFER@ tests added +\ Empty CASE statement test added +\ [COMPILE] tests removed because it is obsolescent in Forth 2012 +\ 0.10 1 August 2014 +\ Added tests contributed by James Bowman for: +\ <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R> +\ HEX WITHIN UNUSED AGAIN MARKER +\ Added tests for: +\ .R U.R ERASE PAD REFILL SOURCE-ID +\ Removed ABORT from NeverExecuted to enable Win32 +\ to continue after failure of RESTORE-INPUT. +\ Removed max-intx which is no longer used. +\ 0.7 6 June 2012 Extra CASE test added +\ 0.6 1 April 2012 Tests placed in the public domain. +\ SAVE-INPUT & RESTORE-INPUT tests, position +\ of T{ moved so that tests work with ttester.fs +\ CONVERT test deleted - obsolete word removed from Forth 200X +\ IMMEDIATE VALUEs tested +\ RECURSE with :NONAME tested +\ PARSE and .( tested +\ Parsing behaviour of C" added +\ 0.5 14 September 2011 Removed the double [ELSE] from the +\ initial SAVE-INPUT & RESTORE-INPUT test +\ 0.4 30 November 2009 max-int replaced with max-intx to +\ avoid redefinition warnings. +\ 0.3 6 March 2009 { and } replaced with T{ and }T +\ CONVERT test now independent of cell size +\ 0.2 20 April 2007 ANS Forth words changed to upper case +\ Tests qd3 to qd6 by Reinhold Straub +\ 0.1 Oct 2006 First version released +\ ----------------------------------------------------------------------------- +\ The tests are based on John Hayes test program for the core word set + +\ Words tested in this file are: +\ .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE +\ ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL +\ RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED +\ VALUE WITHIN [COMPILE] + +\ Words not tested or partially tested: +\ \ because it has been extensively used already and is, hence, unnecessary +\ REFILL and SOURCE-ID from the user input device which are not possible +\ when testing from a file such as this one +\ UNUSED (partially tested) as the value returned is system dependent +\ Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been +\ removed from the Forth 2012 standard + +\ Results from words that output to the user output device have to visually +\ checked for correctness. These are .R U.R .( + +\ ----------------------------------------------------------------------------- +\ Assumptions & dependencies: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set available +\ ----------------------------------------------------------------------------- +TESTING Core Extension words + +DECIMAL + +TESTING TRUE FALSE + +T{ TRUE -> 0 INVERT }T +T{ FALSE -> 0 }T + +\ ----------------------------------------------------------------------------- +TESTING <> U> (contributed by James Bowman) + +T{ 0 0 <> -> FALSE }T +T{ 1 1 <> -> FALSE }T +T{ -1 -1 <> -> FALSE }T +T{ 1 0 <> -> TRUE }T +T{ -1 0 <> -> TRUE }T +T{ 0 1 <> -> TRUE }T +T{ 0 -1 <> -> TRUE }T + +T{ 0 1 U> -> FALSE }T +T{ 1 2 U> -> FALSE }T +T{ 0 MID-UINT U> -> FALSE }T +T{ 0 MAX-UINT U> -> FALSE }T +T{ MID-UINT MAX-UINT U> -> FALSE }T +T{ 0 0 U> -> FALSE }T +T{ 1 1 U> -> FALSE }T +T{ 1 0 U> -> TRUE }T +T{ 2 1 U> -> TRUE }T +T{ MID-UINT 0 U> -> TRUE }T +T{ MAX-UINT 0 U> -> TRUE }T +T{ MAX-UINT MID-UINT U> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING 0<> 0> (contributed by James Bowman) + +T{ 0 0<> -> FALSE }T +T{ 1 0<> -> TRUE }T +T{ 2 0<> -> TRUE }T +T{ -1 0<> -> TRUE }T +T{ MAX-UINT 0<> -> TRUE }T +T{ MIN-INT 0<> -> TRUE }T +T{ MAX-INT 0<> -> TRUE }T + +T{ 0 0> -> FALSE }T +T{ -1 0> -> FALSE }T +T{ MIN-INT 0> -> FALSE }T +T{ 1 0> -> TRUE }T +T{ MAX-INT 0> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING NIP TUCK ROLL PICK (contributed by James Bowman) + +T{ 1 2 NIP -> 2 }T +T{ 1 2 3 NIP -> 1 3 }T + +T{ 1 2 TUCK -> 2 1 2 }T +T{ 1 2 3 TUCK -> 1 3 2 3 }T + +T{ : RO5 100 200 300 400 500 ; -> }T +T{ RO5 3 ROLL -> 100 300 400 500 200 }T +T{ RO5 2 ROLL -> RO5 ROT }T +T{ RO5 1 ROLL -> RO5 SWAP }T +T{ RO5 0 ROLL -> RO5 }T + +T{ RO5 2 PICK -> 100 200 300 400 500 300 }T +T{ RO5 1 PICK -> RO5 OVER }T +T{ RO5 0 PICK -> RO5 DUP }T + +\ ----------------------------------------------------------------------------- +TESTING 2>R 2R@ 2R> (contributed by James Bowman) + +T{ : RR0 2>R 100 R> R> ; -> }T +T{ 300 400 RR0 -> 100 400 300 }T +T{ 200 300 400 RR0 -> 200 100 400 300 }T + +T{ : RR1 2>R 100 2R@ R> R> ; -> }T +T{ 300 400 RR1 -> 100 300 400 400 300 }T +T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T + +T{ : RR2 2>R 100 2R> ; -> }T +T{ 300 400 RR2 -> 100 300 400 }T +T{ 200 300 400 RR2 -> 200 100 300 400 }T + +\ ----------------------------------------------------------------------------- +TESTING HEX (contributed by James Bowman) + +T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T + +\ ----------------------------------------------------------------------------- +TESTING WITHIN (contributed by James Bowman) + +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 MID-UINT WITHIN -> TRUE }T +T{ 0 0 MID-UINT+1 WITHIN -> TRUE }T +T{ 0 0 MAX-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT 0 WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT+1 0 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ 0 MAX-UINT 0 WITHIN -> FALSE }T +T{ 0 MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ 0 MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ 0 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 0 WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT+1 0 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 0 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 0 WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT 0 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MAX-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T + +T{ MIN-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MIN-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT MAX-INT WITHIN -> TRUE }T +T{ MIN-INT 0 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 0 0 WITHIN -> FALSE }T +T{ MIN-INT 0 1 WITHIN -> FALSE }T +T{ MIN-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT 1 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 1 0 WITHIN -> TRUE }T +T{ MIN-INT 1 1 WITHIN -> FALSE }T +T{ MIN-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 0 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MIN-INT 0 WITHIN -> FALSE }T +T{ 0 MIN-INT 1 WITHIN -> TRUE }T +T{ 0 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 0 0 MIN-INT WITHIN -> TRUE }T +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 1 WITHIN -> TRUE }T +T{ 0 0 MAX-INT WITHIN -> TRUE }T +T{ 0 1 MIN-INT WITHIN -> FALSE }T +T{ 0 1 0 WITHIN -> FALSE }T +T{ 0 1 1 WITHIN -> FALSE }T +T{ 0 1 MAX-INT WITHIN -> FALSE }T +T{ 0 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MAX-INT 0 WITHIN -> FALSE }T +T{ 0 MAX-INT 1 WITHIN -> TRUE }T +T{ 0 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 1 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MIN-INT 0 WITHIN -> FALSE }T +T{ 1 MIN-INT 1 WITHIN -> FALSE }T +T{ 1 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 1 0 MIN-INT WITHIN -> TRUE }T +T{ 1 0 0 WITHIN -> FALSE }T +T{ 1 0 1 WITHIN -> FALSE }T +T{ 1 0 MAX-INT WITHIN -> TRUE }T +T{ 1 1 MIN-INT WITHIN -> TRUE }T +T{ 1 1 0 WITHIN -> TRUE }T +T{ 1 1 1 WITHIN -> FALSE }T +T{ 1 1 MAX-INT WITHIN -> TRUE }T +T{ 1 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MAX-INT 0 WITHIN -> FALSE }T +T{ 1 MAX-INT 1 WITHIN -> FALSE }T +T{ 1 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 0 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 1 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 0 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 0 0 WITHIN -> FALSE }T +T{ MAX-INT 0 1 WITHIN -> FALSE }T +T{ MAX-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 1 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 1 0 WITHIN -> TRUE }T +T{ MAX-INT 1 1 WITHIN -> FALSE }T +T{ MAX-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MAX-INT MIN-INT WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT MAX-INT WITHIN -> FALSE }T + +\ ----------------------------------------------------------------------------- +TESTING UNUSED (contributed by James Bowman & Peter Knaggs) + +VARIABLE UNUSED0 +T{ UNUSED DROP -> }T +T{ ALIGN UNUSED UNUSED0 ! 0 , UNUSED CELL+ UNUSED0 @ = -> TRUE }T +T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = + -> TRUE }T \ aligned -> unaligned +T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = -> TRUE }T \ unaligned -> ? + +\ ----------------------------------------------------------------------------- +TESTING AGAIN (contributed by James Bowman) + +T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T +T{ AG0 -> 707 }T + +\ ----------------------------------------------------------------------------- +TESTING MARKER (contributed by James Bowman) + +T{ : MA? BL WORD FIND NIP 0<> ; -> }T +T{ MARKER MA0 -> }T +T{ : MA1 111 ; -> }T +T{ MARKER MA2 -> }T +T{ : MA1 222 ; -> }T +T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE TRUE }T +T{ MA1 MA2 MA1 -> 222 111 }T +T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE FALSE }T +T{ MA0 -> }T +T{ MA? MA0 MA? MA1 MA? MA2 -> FALSE FALSE FALSE }T + +\ ----------------------------------------------------------------------------- +TESTING ?DO + +: QD ?DO I LOOP ; +T{ 789 789 QD -> }T +T{ -9876 -9876 QD -> }T +T{ 5 0 QD -> 0 1 2 3 4 }T + +: QD1 ?DO I 10 +LOOP ; +T{ 50 1 QD1 -> 1 11 21 31 41 }T +T{ 50 0 QD1 -> 0 10 20 30 40 }T + +: QD2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ; +T{ 5 -1 QD2 -> -1 0 1 2 3 }T + +: QD3 ?DO I 1 +LOOP ; +T{ 4 4 QD3 -> }T +T{ 4 1 QD3 -> 1 2 3 }T +T{ 2 -1 QD3 -> -1 0 1 }T + +: QD4 ?DO I -1 +LOOP ; +T{ 4 4 QD4 -> }T +T{ 1 4 QD4 -> 4 3 2 1 }T +T{ -1 2 QD4 -> 2 1 0 -1 }T + +: QD5 ?DO I -10 +LOOP ; +T{ 1 50 QD5 -> 50 40 30 20 10 }T +T{ 0 50 QD5 -> 50 40 30 20 10 0 }T +T{ -25 10 QD5 -> 10 0 -10 -20 }T + +VARIABLE ITERS +VARIABLE INCRMNT + +: QD6 ( limit start increment -- ) + INCRMNT ! + 0 ITERS ! + ?DO + 1 ITERS +! + I + ITERS @ 6 = IF LEAVE THEN + INCRMNT @ + +LOOP ITERS @ +; + +T{ 4 4 -1 QD6 -> 0 }T +T{ 1 4 -1 QD6 -> 4 3 2 1 4 }T +T{ 4 1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T +T{ 4 1 0 QD6 -> 1 1 1 1 1 1 6 }T +T{ 0 0 0 QD6 -> 0 }T +T{ 1 4 0 QD6 -> 4 4 4 4 4 4 6 }T +T{ 1 4 1 QD6 -> 4 5 6 7 8 9 6 }T +T{ 4 1 1 QD6 -> 1 2 3 3 }T +T{ 4 4 1 QD6 -> 0 }T +T{ 2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T +T{ -1 2 -1 QD6 -> 2 1 0 -1 4 }T +T{ 2 -1 0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T +T{ -1 2 0 QD6 -> 2 2 2 2 2 2 6 }T +T{ -1 2 1 QD6 -> 2 3 4 5 6 7 6 }T +T{ 2 -1 1 QD6 -> -1 0 1 3 }T + +\ ----------------------------------------------------------------------------- +TESTING BUFFER: + +T{ 8 BUFFER: BUF:TEST -> }T +T{ BUF:TEST DUP ALIGNED = -> TRUE }T +T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T +T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T + +\ ----------------------------------------------------------------------------- +TESTING VALUE TO + +T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T +T{ VAL1 -> 111 }T +T{ VAL2 -> -999 }T +T{ 222 TO VAL1 -> }T +T{ VAL1 -> 222 }T +T{ : VD1 VAL1 ; -> }T +T{ VD1 -> 222 }T +T{ : VD2 TO VAL2 ; -> }T +T{ VAL2 -> -999 }T +T{ -333 VD2 -> }T +T{ VAL2 -> -333 }T +T{ VAL1 -> 222 }T +T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T +T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T + +\ ----------------------------------------------------------------------------- +TESTING CASE OF ENDOF ENDCASE + +: CS1 CASE 1 OF 111 ENDOF + 2 OF 222 ENDOF + 3 OF 333 ENDOF + >R 999 R> + ENDCASE +; + +T{ 1 CS1 -> 111 }T +T{ 2 CS1 -> 222 }T +T{ 3 CS1 -> 333 }T +T{ 4 CS1 -> 999 }T + +\ Nested CASE's + +: CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF + 2 OF 200 ENDOF + >R -300 R> + ENDCASE + ENDOF + -2 OF CASE R@ 1 OF -99 ENDOF + >R -199 R> + ENDCASE + ENDOF + >R 299 R> + ENDCASE R> DROP +; + +T{ -1 1 CS2 -> 100 }T +T{ -1 2 CS2 -> 200 }T +T{ -1 3 CS2 -> -300 }T +T{ -2 1 CS2 -> -99 }T +T{ -2 2 CS2 -> -199 }T +T{ 0 2 CS2 -> 299 }T + +\ Boolean short circuiting using CASE + +: CS3 ( N1 -- N2 ) + CASE 1- FALSE OF 11 ENDOF + 1- FALSE OF 22 ENDOF + 1- FALSE OF 33 ENDOF + 44 SWAP + ENDCASE +; + +T{ 1 CS3 -> 11 }T +T{ 2 CS3 -> 22 }T +T{ 3 CS3 -> 33 }T +T{ 9 CS3 -> 44 }T + +\ Empty CASE statements with/without default + +T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T +T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T +T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T +T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T + +\ ----------------------------------------------------------------------------- +TESTING :NONAME RECURSE + +VARIABLE NN1 +VARIABLE NN2 +:NONAME 1234 ; NN1 ! +:NONAME 9876 ; NN2 ! +T{ NN1 @ EXECUTE -> 1234 }T +T{ NN2 @ EXECUTE -> 9876 }T + +T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ; + CONSTANT RN1 -> }T +T{ 0 RN1 EXECUTE -> 0 }T +T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T + +:NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition + 1- DUP + CASE 0 OF EXIT ENDOF + 1 OF 11 SWAP RECURSE ENDOF + 2 OF 22 SWAP RECURSE ENDOF + 3 OF 33 SWAP RECURSE ENDOF + DROP ABS RECURSE EXIT + ENDCASE +; CONSTANT RN2 + +T{ 1 RN2 EXECUTE -> 0 }T +T{ 2 RN2 EXECUTE -> 11 0 }T +T{ 4 RN2 EXECUTE -> 33 22 11 0 }T +T{ 25 RN2 EXECUTE -> 33 22 11 0 }T + +\ ----------------------------------------------------------------------------- +TESTING C" + +T{ : CQ1 C" 123" ; -> }T +T{ CQ1 COUNT EVALUATE -> 123 }T +T{ : CQ2 C" " ; -> }T +T{ CQ2 COUNT EVALUATE -> }T +T{ : CQ3 C" 2345"COUNT EVALUATE ; CQ3 -> 2345 }T + +\ ----------------------------------------------------------------------------- +TESTING COMPILE, + +:NONAME DUP + ; CONSTANT DUP+ +T{ : Q DUP+ COMPILE, ; -> }T +T{ : AS1 [ Q ] ; -> }T +T{ 123 AS1 -> 246 }T + +\ ----------------------------------------------------------------------------- +\ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source + +TESTING SAVE-INPUT and RESTORE-INPUT with a string source + +VARIABLE SI_INC 0 SI_INC ! + +: SI1 + SI_INC @ >IN +! + 15 SI_INC ! +; + +: S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; + +T{ S$ EVALUATE SI_INC @ -> 0 2345 15 }T + +\ ----------------------------------------------------------------------------- +TESTING .( + +CR CR .( Output from .() +T{ CR .( You should see -9876: ) -9876 . -> }T +T{ CR .( and again: ).( -9876)CR -> }T + +CR CR .( On the next 2 lines you should see First then Second messages:) +T{ : DOTP CR ." Second message via ." [CHAR] " EMIT \ Check .( is immediate + [ CR ] .( First message via .( ) ; DOTP -> }T +CR CR +T{ : IMM? BL WORD FIND NIP ; IMM? .( -> 1 }T + +\ ----------------------------------------------------------------------------- +TESTING .R and U.R - has to handle different cell sizes + +\ Create some large integers just below/above MAX and Min INTs +MAX-INT 73 79 */ CONSTANT LI1 +MIN-INT 71 73 */ CONSTANT LI2 + +LI1 0 <# #S #> NIP CONSTANT LENLI1 + +: (.R&U.R) ( u1 u2 -- ) \ u1 <= string length, u2 is required indentation + TUCK + >R + LI1 OVER SPACES . CR R@ LI1 SWAP .R CR + LI2 OVER SPACES . CR R@ 1+ LI2 SWAP .R CR + LI1 OVER SPACES U. CR R@ LI1 SWAP U.R CR + LI2 SWAP SPACES U. CR R> LI2 SWAP U.R CR +; + +: .R&U.R ( -- ) + CR ." You should see lines duplicated:" CR + ." indented by 0 spaces" CR 0 0 (.R&U.R) CR + ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width + ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR +; + +CR CR .( Output from .R and U.R) +T{ .R&U.R -> }T + +\ ----------------------------------------------------------------------------- +TESTING PAD ERASE +\ Must handle different size characters i.e. 1 CHARS >= 1 + +84 CONSTANT CHARS/PAD \ Minimum size of PAD in chars +CHARS/PAD CHARS CONSTANT AUS/PAD +: CHECKPAD ( caddr u ch -- f ) \ f = TRUE if u chars = ch + SWAP 0 + ?DO + OVER I CHARS + C@ OVER <> + IF 2DROP UNLOOP FALSE EXIT THEN + LOOP + 2DROP TRUE +; + +T{ PAD DROP -> }T +T{ 0 INVERT PAD C! -> }T +T{ PAD C@ CONSTANT MAXCHAR -> }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> TRUE }T +T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> TRUE }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> TRUE }T +T{ PAD 43 CHARS + 9 CHARS ERASE -> }T +T{ PAD 43 MAXCHAR CHECKPAD -> TRUE }T +T{ PAD 43 CHARS + 9 0 CHECKPAD -> TRUE }T +T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> TRUE }T + +\ Check that use of WORD and pictured numeric output do not corrupt PAD +\ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively +\ where n is number of bits per cell + +PAD CHARS/PAD ERASE +2 BASE ! +MAX-UINT MAX-UINT <# #S CHAR 1 DUP HOLD HOLD #> 2DROP +DECIMAL +BL WORD 12345678123456781234567812345678 DROP +T{ PAD CHARS/PAD 0 CHECKPAD -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING PARSE + +T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T +T{ CHAR ^ PARSE 23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T +: PA1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ; +T{ PA1 3456 + DUP ROT ROT EVALUATE -> 4 3456 }T +T{ CHAR A PARSE A SWAP DROP -> 0 }T +T{ CHAR Z PARSE + SWAP DROP -> 0 }T +T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T + +\ ----------------------------------------------------------------------------- +TESTING PARSE-NAME (Forth 2012) +\ Adapted from the PARSE-NAME RfD tests + +T{ PARSE-NAME abcd STR1 S= -> TRUE }T \ No leading spaces +T{ PARSE-NAME abcde STR2 S= -> TRUE }T \ Leading spaces + +\ Test empty parse area, new lines are necessary +T{ PARSE-NAME + NIP -> 0 }T +\ Empty parse area with spaces after PARSE-NAME +T{ PARSE-NAME + NIP -> 0 }T + +T{ : PARSE-NAME-TEST ( "name1" "name2" -- n ) + PARSE-NAME PARSE-NAME S= ; -> }T +T{ PARSE-NAME-TEST abcd abcd -> TRUE }T +T{ PARSE-NAME-TEST abcd abcd -> TRUE }T \ Leading spaces +T{ PARSE-NAME-TEST abcde abcdf -> FALSE }T +T{ PARSE-NAME-TEST abcdf abcde -> FALSE }T +T{ PARSE-NAME-TEST abcde abcde + -> TRUE }T \ Parse to end of line +T{ PARSE-NAME-TEST abcde abcde + -> TRUE }T \ Leading and trailing spaces + +\ ----------------------------------------------------------------------------- +TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012) +\ Adapted from the Forth 200X RfD tests + +T{ DEFER DEFER1 -> }T +T{ : MY-DEFER DEFER ; -> }T +T{ : IS-DEFER1 IS DEFER1 ; -> }T +T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T +T{ : DEF! DEFER! ; -> }T +T{ : DEF@ DEFER@ ; -> }T + +T{ ' * ' DEFER1 DEFER! -> }T +T{ 2 3 DEFER1 -> 6 }T +T{ ' DEFER1 DEFER@ -> ' * }T +T{ ' DEFER1 DEF@ -> ' * }T +T{ ACTION-OF DEFER1 -> ' * }T +T{ ACTION-DEFER1 -> ' * }T +T{ ' + IS DEFER1 -> }T +T{ 1 2 DEFER1 -> 3 }T +T{ ' DEFER1 DEFER@ -> ' + }T +T{ ' DEFER1 DEF@ -> ' + }T +T{ ACTION-OF DEFER1 -> ' + }T +T{ ACTION-DEFER1 -> ' + }T +T{ ' - IS-DEFER1 -> }T +T{ 1 2 DEFER1 -> -1 }T +T{ ' DEFER1 DEFER@ -> ' - }T +T{ ' DEFER1 DEF@ -> ' - }T +T{ ACTION-OF DEFER1 -> ' - }T +T{ ACTION-DEFER1 -> ' - }T + +T{ MY-DEFER DEFER2 -> }T +T{ ' DUP IS DEFER2 -> }T +T{ 1 DEFER2 -> 1 1 }T + +\ ----------------------------------------------------------------------------- +TESTING HOLDS (Forth 2012) + +: HTEST S" Testing HOLDS" ; +: HTEST2 S" works" ; +: HTEST3 S" Testing HOLDS works 123" ; +T{ 0 0 <# HTEST HOLDS #> HTEST S= -> TRUE }T +T{ 123 0 <# #S BL HOLD HTEST2 HOLDS BL HOLD HTEST HOLDS #> + HTEST3 S= -> TRUE }T +T{ : HLD HOLDS ; -> }T +T{ 0 0 <# HTEST HLD #> HTEST S= -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING REFILL SOURCE-ID +\ REFILL and SOURCE-ID from the user input device can't be tested from a file, +\ can only be tested from a string via EVALUATE + +T{ : RF1 S" REFILL" EVALUATE ; RF1 -> FALSE }T +T{ : SID1 S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T + +\ ------------------------------------------------------------------------------ +TESTING S\" (Forth 2012 compilation mode) +\ Extended the Forth 200X RfD tests +\ Note this tests the Core Ext definition of S\" which has unedfined +\ interpretation semantics. S\" in interpretation mode is tested in the tests on +\ the File-Access word set + +T{ : SSQ1 S\" abc" S" abc" S= ; -> }T \ No escapes +T{ SSQ1 -> TRUE }T +T{ : SSQ2 S\" " ; SSQ2 SWAP DROP -> 0 }T \ Empty string + +T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T +T{ SSQ3 SWAP DROP -> 20 }T \ String length +T{ SSQ3 DROP C@ -> 7 }T \ \a BEL Bell +T{ SSQ3 DROP 1 CHARS + C@ -> 8 }T \ \b BS Backspace +T{ SSQ3 DROP 2 CHARS + C@ -> 27 }T \ \e ESC Escape +T{ SSQ3 DROP 3 CHARS + C@ -> 12 }T \ \f FF Form feed +T{ SSQ3 DROP 4 CHARS + C@ -> 10 }T \ \l LF Line feed +T{ SSQ3 DROP 5 CHARS + C@ -> 13 }T \ \m CR of CR/LF pair +T{ SSQ3 DROP 6 CHARS + C@ -> 10 }T \ LF of CR/LF pair +T{ SSQ3 DROP 7 CHARS + C@ -> 34 }T \ \q " Double Quote +T{ SSQ3 DROP 8 CHARS + C@ -> 13 }T \ \r CR Carriage Return +T{ SSQ3 DROP 9 CHARS + C@ -> 9 }T \ \t TAB Horizontal Tab +T{ SSQ3 DROP 10 CHARS + C@ -> 11 }T \ \v VT Vertical Tab +T{ SSQ3 DROP 11 CHARS + C@ -> 15 }T \ \x0F Given Char +T{ SSQ3 DROP 12 CHARS + C@ -> 48 }T \ 0 0 Digit follow on +T{ SSQ3 DROP 13 CHARS + C@ -> 31 }T \ \x1F Given Char +T{ SSQ3 DROP 14 CHARS + C@ -> 97 }T \ a a Hex follow on +T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T \ \xaB Insensitive Given Char +T{ SSQ3 DROP 16 CHARS + C@ -> 120 }T \ x x Non hex follow on +T{ SSQ3 DROP 17 CHARS + C@ -> 0 }T \ \z NUL No Character +T{ SSQ3 DROP 18 CHARS + C@ -> 34 }T \ \" " Double Quote +T{ SSQ3 DROP 19 CHARS + C@ -> 92 }T \ \\ \ Back Slash + +\ The above does not test \n as this is a system dependent value. +\ Check it displays a new line +CR .( The next test should display:) +CR .( One line...) +CR .( another line) +T{ : SSQ4 S\" \nOne line...\nanotherLine\n" TYPE ; SSQ4 -> }T + +\ Test bare escapable characters appear as themselves +T{ : SSQ5 S\" abeflmnqrtvxz" S" abeflmnqrtvxz" S= ; SSQ5 -> TRUE }T + +T{ : SSQ6 S\" a\""2DROP 1111 ; SSQ6 -> 1111 }T \ Parsing behaviour + +T{ : SSQ7 S\" 111 : SSQ8 S\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T +T{ SSQ7 -> 111 222 333 }T +T{ : SSQ9 S\" 11 : SSQ10 S\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T +T{ SSQ9 -> 11 22 33 }T + +\ ----------------------------------------------------------------------------- +CORE-EXT-ERRORS SET-ERROR-COUNT + +CR .( End of Core Extension word tests) CR + + diff --git a/FORTH/coreplustest.f b/FORTH/coreplustest.f new file mode 100644 index 00000000..1d128c56 --- /dev/null +++ b/FORTH/coreplustest.f @@ -0,0 +1,305 @@ +\ Additional tests on the the ANS Forth Core word set + +\ This program was written by Gerry Jackson in 2007, 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 + +\ ------------------------------------------------------------------------------ +\ The tests are based on John Hayes test program for the core word set +\ +\ This file provides some more tests on Core words where the original Hayes +\ tests are thought to be incomplete +\ +\ Words tested in this file are: +\ DO I +LOOP RECURSE ELSE >IN IMMEDIATE FIND IF...BEGIN...REPEAT ALLOT DOES> +\ and +\ Parsing behaviour +\ Number prefixes # $ % and 'A' character input +\ Definition names +\ ------------------------------------------------------------------------------ +\ Assumptions and dependencies: +\ - tester.fr or ttester.fs has been loaded prior to this file +\ - core.fr has been loaded so that constants MAX-INT, MIN-INT and +\ MAX-UINT are defined +\ ------------------------------------------------------------------------------ + +DECIMAL + +TESTING DO +LOOP with run-time increment, negative increment, infinite loop +\ Contributed by Reinhold Straub + +VARIABLE ITERATIONS +VARIABLE INCREMENT +: GD7 ( LIMIT START INCREMENT -- ) + INCREMENT ! + 0 ITERATIONS ! + DO + 1 ITERATIONS +! + I + ITERATIONS @ 6 = IF LEAVE THEN + INCREMENT @ + +LOOP ITERATIONS @ +; + +T{ 4 4 -1 GD7 -> 4 1 }T +T{ 1 4 -1 GD7 -> 4 3 2 1 4 }T +T{ 4 1 -1 GD7 -> 1 0 -1 -2 -3 -4 6 }T +T{ 4 1 0 GD7 -> 1 1 1 1 1 1 6 }T +T{ 0 0 0 GD7 -> 0 0 0 0 0 0 6 }T +T{ 1 4 0 GD7 -> 4 4 4 4 4 4 6 }T +T{ 1 4 1 GD7 -> 4 5 6 7 8 9 6 }T +T{ 4 1 1 GD7 -> 1 2 3 3 }T +T{ 4 4 1 GD7 -> 4 5 6 7 8 9 6 }T +T{ 2 -1 -1 GD7 -> -1 -2 -3 -4 -5 -6 6 }T +T{ -1 2 -1 GD7 -> 2 1 0 -1 4 }T +T{ 2 -1 0 GD7 -> -1 -1 -1 -1 -1 -1 6 }T +T{ -1 2 0 GD7 -> 2 2 2 2 2 2 6 }T +T{ -1 2 1 GD7 -> 2 3 4 5 6 7 6 }T +T{ 2 -1 1 GD7 -> -1 0 1 3 }T +T{ -20 30 -10 GD7 -> 30 20 10 0 -10 -20 6 }T +T{ -20 31 -10 GD7 -> 31 21 11 1 -9 -19 6 }T +T{ -20 29 -10 GD7 -> 29 19 9 -1 -11 5 }T + +\ ------------------------------------------------------------------------------ +TESTING DO +LOOP with large and small increments + +\ Contributed by Andrew Haley + +MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP +USTEP NEGATE CONSTANT -USTEP +MAX-INT 7 RSHIFT 1+ CONSTANT STEP +STEP NEGATE CONSTANT -STEP + +VARIABLE BUMP + +T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; -> }T + +T{ 0 MAX-UINT 0 USTEP GD8 -> 256 }T +T{ 0 0 MAX-UINT -USTEP GD8 -> 256 }T + +T{ 0 MAX-INT MIN-INT STEP GD8 -> 256 }T +T{ 0 MIN-INT MAX-INT -STEP GD8 -> 256 }T + +\ Two's complement arithmetic, wraps around modulo wordsize +\ Only tested if the Forth system does wrap around, use of conditional +\ compilation deliberately avoided + +MAX-INT 1+ MIN-INT = CONSTANT +WRAP? +MIN-INT 1- MAX-INT = CONSTANT -WRAP? +MAX-UINT 1+ 0= CONSTANT +UWRAP? +0 1- MAX-UINT = CONSTANT -UWRAP? + +: GD9 ( n limit start step f result -- ) + >R IF GD8 ELSE 2DROP 2DROP R@ THEN -> R> }T +; + +T{ 0 0 0 USTEP +UWRAP? 256 GD9 +T{ 0 0 0 -USTEP -UWRAP? 1 GD9 +T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9 +T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9 + +\ ------------------------------------------------------------------------------ +TESTING DO +LOOP with maximum and minimum increments + +: (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ; +(-MI) CONSTANT -MAX-INT + +T{ 0 1 0 MAX-INT GD8 -> 1 }T +T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 -> 2 }T + +T{ 0 MAX-INT 0 MAX-INT GD8 -> 1 }T +T{ 0 MAX-INT 1 MAX-INT GD8 -> 1 }T +T{ 0 MAX-INT -1 MAX-INT GD8 -> 2 }T +T{ 0 MAX-INT DUP 1- MAX-INT GD8 -> 1 }T + +T{ 0 MIN-INT 1+ 0 MIN-INT GD8 -> 1 }T +T{ 0 MIN-INT 1+ -1 MIN-INT GD8 -> 1 }T +T{ 0 MIN-INT 1+ 1 MIN-INT GD8 -> 2 }T +T{ 0 MIN-INT 1+ DUP MIN-INT GD8 -> 1 }T + +\ ------------------------------------------------------------------------------ +\ TESTING +LOOP setting I to an arbitrary value + +\ The specification for +LOOP permits the loop index I to be set to any value +\ including a value outside the range given to the corresponding DO. + +\ SET-I is a helper to set I in a DO ... +LOOP to a given value +\ n2 is the value of I in a DO ... +LOOP +\ n3 is a test value +\ If n2=n3 then return n1-n2 else return 1 +: SET-I ( n1 n2 n3 -- n1-n2 | 1 ) + OVER = IF - ELSE 2DROP 1 THEN +; + +: -SET-I ( n1 n2 n3 -- n1-n2 | -1 ) + SET-I DUP 1 = IF NEGATE THEN +; + +: PL1 20 1 DO I 18 I 3 SET-I +LOOP ; +T{ PL1 -> 1 2 3 18 19 }T +: PL2 20 1 DO I 20 I 2 SET-I +LOOP ; +T{ PL2 -> 1 2 }T +: PL3 20 5 DO I 19 I 2 SET-I DUP 1 = IF DROP 0 I 6 SET-I THEN +LOOP ; +T{ PL3 -> 5 6 0 1 2 19 }T +: PL4 20 1 DO I MAX-INT I 4 SET-I +LOOP ; +T{ PL4 -> 1 2 3 4 }T +: PL5 -20 -1 DO I -19 I -3 -SET-I +LOOP ; +T{ PL5 -> -1 -2 -3 -19 -20 }T +: PL6 -20 -1 DO I -21 I -4 -SET-I +LOOP ; +T{ PL6 -> -1 -2 -3 -4 }T +: PL7 -20 -1 DO I MIN-INT I -5 -SET-I +LOOP ; +T{ PL7 -> -1 -2 -3 -4 -5 }T +: PL8 -20 -5 DO I -20 I -2 -SET-I DUP -1 = IF DROP 0 I -6 -SET-I THEN +LOOP ; +T{ PL8 -> -5 -6 0 -1 -2 -20 }T + +\ ------------------------------------------------------------------------------ +TESTING multiple RECURSEs in one colon definition + +: ACK ( m n -- u ) \ Ackermann function, from Rosetta Code + OVER 0= IF NIP 1+ EXIT THEN \ ack(0, n) = n+1 + SWAP 1- SWAP ( -- m-1 n ) + DUP 0= IF 1+ RECURSE EXIT THEN \ ack(m, 0) = ack(m-1, 1) + 1- OVER 1+ SWAP RECURSE RECURSE \ ack(m, n) = ack(m-1, ack(m,n-1)) +; + +T{ 0 0 ACK -> 1 }T +T{ 3 0 ACK -> 5 }T +T{ 2 4 ACK -> 11 }T + +\ ------------------------------------------------------------------------------ +TESTING multiple ELSE's in an IF statement +\ Discussed on comp.lang.forth and accepted as valid ANS Forth + +: MELSE IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ; +T{ 0 MELSE -> 2 4 }T +T{ -1 MELSE -> 1 3 5 }T + +\ ------------------------------------------------------------------------------ +TESTING manipulation of >IN in interpreter mode + +T{ 12345 DEPTH OVER 9 < 34 AND + 3 + >IN ! -> 12345 2345 345 45 5 }T +T{ 14145 8115 ?DUP 0= 34 AND >IN +! TUCK MOD 14 >IN ! GCD CALCULATION -> 15 }T + +\ ------------------------------------------------------------------------------ +TESTING IMMEDIATE with CONSTANT VARIABLE and CREATE [ ... DOES> ] + +T{ 123 CONSTANT IW1 IMMEDIATE IW1 -> 123 }T +T{ : IW2 IW1 LITERAL ; IW2 -> 123 }T +T{ VARIABLE IW3 IMMEDIATE 234 IW3 ! IW3 @ -> 234 }T +T{ : IW4 IW3 [ @ ] LITERAL ; IW4 -> 234 }T +T{ :NONAME [ 345 ] IW3 [ ! ] ; DROP IW3 @ -> 345 }T +T{ CREATE IW5 456 , IMMEDIATE -> }T +T{ :NONAME IW5 [ @ IW3 ! ] ; DROP IW3 @ -> 456 }T +T{ : IW6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T +T{ 111 IW6 IW7 IW7 -> 112 }T +T{ : IW8 IW7 LITERAL 1+ ; IW8 -> 113 }T +T{ : IW9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T +: FIND-IW BL WORD FIND NIP ; ( -- 0 | 1 | -1 ) +T{ 222 IW9 IW10 FIND-IW IW10 -> -1 }T \ IW10 is not immediate +T{ IW10 FIND-IW IW10 -> 224 1 }T \ IW10 becomes immediate + +\ ------------------------------------------------------------------------------ +TESTING that IMMEDIATE doesn't toggle a flag + +VARIABLE IT1 0 IT1 ! +: IT2 1234 IT1 ! ; IMMEDIATE IMMEDIATE +T{ : IT3 IT2 ; IT1 @ -> 1234 }T + +\ ------------------------------------------------------------------------------ +TESTING parsing behaviour of S" ." and ( +\ which should parse to just beyond the terminating character no space needed + +T{ : GC5 S" A string"2DROP ; GC5 -> }T +T{ ( A comment)1234 -> 1234 }T +T{ : PB1 CR ." You should see 2345: "." 2345"( A comment) CR ; PB1 -> }T + +\ ------------------------------------------------------------------------------ +TESTING number prefixes # $ % and 'c' character input +\ Adapted from the Forth 200X Draft 14.5 document + +VARIABLE OLD-BASE +DECIMAL BASE @ OLD-BASE ! +T{ #1289 -> 1289 }T +T{ #-1289 -> -1289 }T +T{ $12eF -> 4847 }T +T{ $-12eF -> -4847 }T +T{ %10010110 -> 150 }T +T{ %-10010110 -> -150 }T +T{ 'z' -> 122 }T +T{ 'Z' -> 90 }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = -> }T + +\ Repeat in Hex mode +16 OLD-BASE ! 16 BASE ! +T{ #1289 -> 509 }T +T{ #-1289 -> -509 }T +T{ $12eF -> 12EF }T +T{ $-12eF -> -12EF }T +T{ %10010110 -> 96 }T +T{ %-10010110 -> -96 }T +T{ 'z' -> 7a }T +T{ 'Z' -> 5a }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = -> }T \ 2 + +DECIMAL +\ Check number prefixes in compile mode +T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp -> 8327 -11454 215 39 }T + +\ ------------------------------------------------------------------------------ +TESTING definition names +\ should support {1..31} graphical characters +: !"#$%&'()*+,-./0123456789:;<=>? 1 ; +T{ !"#$%&'()*+,-./0123456789:;<=>? -> 1 }T +: @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ 2 ; +T{ @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ -> 2 }T +: _`abcdefghijklmnopqrstuvwxyz{|} 3 ; +T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T +: _`abcdefghijklmnopqrstuvwxyz{|~ 4 ; \ Last character different +T{ _`abcdefghijklmnopqrstuvwxyz{|~ -> 4 }T +T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T + +\ ------------------------------------------------------------------------------ +TESTING FIND with a zero length string and a non-existent word + +CREATE EMPTYSTRING 0 C, +: EMPTYSTRING-FIND-CHECK ( c-addr 0 | xt 1 | xt -1 -- t|f ) + DUP IF ." FIND returns a TRUE value for an empty string!" CR THEN + 0= SWAP EMPTYSTRING = = ; +T{ EMPTYSTRING FIND EMPTYSTRING-FIND-CHECK -> }T + +CREATE NON-EXISTENT-WORD \ Same as in exceptiontest.fth + 15 C, CHAR $ C, CHAR $ C, CHAR Q C, CHAR W C, CHAR E C, CHAR Q C, + CHAR W C, CHAR E C, CHAR Q C, CHAR W C, CHAR E C, CHAR R C, CHAR T C, + CHAR $ C, CHAR $ C, +T{ NON-EXISTENT-WORD FIND -> NON-EXISTENT-WORD 0 }T + +\ ------------------------------------------------------------------------------ +TESTING IF ... BEGIN ... REPEAT (unstructured) + +T{ : UNS1 DUP 0 > IF 9 SWAP BEGIN 1+ DUP 3 > IF EXIT THEN REPEAT ; -> }T +T{ -6 UNS1 -> -6 }T +T{ 1 UNS1 -> 9 4 }T + +\ ------------------------------------------------------------------------------ +TESTING DOES> doesn't cause a problem with a CREATEd address + +: MAKE-2CONST DOES> 2@ ; +T{ CREATE 2K 3 , 2K , MAKE-2CONST 2K -> ' 2K >BODY 3 }T + +\ ------------------------------------------------------------------------------ +TESTING ALLOT ( n -- ) where n <= 0 + +T{ HERE 5 ALLOT -5 ALLOT HERE = -> }T +T{ HERE 0 ALLOT HERE = -> }T + +\ ------------------------------------------------------------------------------ + +CR .( End of additional Core tests) CR