From f02d240ad318c88dc8da079e488584289bc34836 Mon Sep 17 00:00:00 2001 From: Patrick Kloepfer Date: Thu, 15 Apr 2021 16:45:28 -0400 Subject: [PATCH] --- FORTH/blocktest.f | 675 ---------------------------- FORTH/core.f | 1014 ------------------------------------------ FORTH/coreexttest.f | 770 -------------------------------- FORTH/coreplustest.f | 305 ------------- 4 files changed, 2764 deletions(-) delete mode 100644 FORTH/blocktest.f delete mode 100644 FORTH/core.f delete mode 100644 FORTH/coreexttest.f delete mode 100644 FORTH/coreplustest.f diff --git a/FORTH/blocktest.f b/FORTH/blocktest.f deleted file mode 100644 index fcc0ca33..00000000 --- a/FORTH/blocktest.f +++ /dev/null @@ -1,675 +0,0 @@ -\ 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 deleted file mode 100644 index 31014819..00000000 --- a/FORTH/core.f +++ /dev/null @@ -1,1014 +0,0 @@ -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 deleted file mode 100644 index 51fe62ef..00000000 --- a/FORTH/coreexttest.f +++ /dev/null @@ -1,770 +0,0 @@ -\ 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 deleted file mode 100644 index 1d128c56..00000000 --- a/FORTH/coreplustest.f +++ /dev/null @@ -1,305 +0,0 @@ -\ 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