diff --git a/8080/CPM/Makefile b/8080/CPM/Makefile index 3ee43fb..115e69d 100644 --- a/8080/CPM/Makefile +++ b/8080/CPM/Makefile @@ -21,7 +21,7 @@ clean: veryclean: clean rm -rf $(cpmfilesdir) -test: test-v4th.result +test: test-min.result test-std.result alltests: logtest.result inctest.result test-min.result test-v4th.result @@ -88,6 +88,7 @@ $(cpmfilesdir)/v4th.com: \ "volks4th" \ "include log2file.fb" \ "logopen" \ + "$50 constant /tib" \ "include include.fb" \ "include target.fb" \ "include v4th.fth" \ @@ -114,7 +115,7 @@ v4th2.com: \ dos2unix -n $(runcpmdir)/logfile.txt $@.log cp $(runcpmdir)/A/0/KERNEL.COM $@ -test-min.log: \ +test-kernel.log: \ $(patsubst %, $(cpmfilesdir)/%, kernel.com fileint.fb \ include.fb log2file.fb \ ans-shim.fth prelim.fth tester.fth core.fr test-min.fth) \ @@ -128,7 +129,7 @@ test-min.log: \ "exit" dos2unix -n $(runcpmdir)/logfile.txt $@ -test-v4th.log: \ +test-min.log: \ $(patsubst %, $(cpmfilesdir)/%, v4th.com fileint.fb \ include.fb log2file.fb \ ans-shim.fth prelim.fth tester.fth core.fr test-min.fth) \ @@ -142,12 +143,34 @@ test-v4th.log: \ "exit" dos2unix -n $(runcpmdir)/logfile.txt $@ +test-std.log: \ + $(patsubst %, $(cpmfilesdir)/%, v4th.com fileint.fb \ + include.fb log2file.fb core.fr) \ + $(patsubst tests/%, $(cpmfilesdir)/%, $(wildcard tests/*.fth)) \ + | emu + ./emulator/run-in-runcpm.sh \ + "v4th fileint.fb" \ + "1 load onlyforth" \ + "include include.fb" \ + "include test-std.fth" \ + "bye" \ + "exit" + dos2unix -n $(runcpmdir)/logfile.txt $@ + emu: $(runcpmdir)/RunCPM test-min.golden: $(patsubst %, tests/golden/%.golden, prelim core) cat $^ > $@ -test-v4th.golden: $(patsubst %, tests/golden/%.golden, prelim core) +test-std.golden: $(patsubst %, tests/golden/%.golden, \ + prelim core coreplus coreext doubltst report-noblk) + cat $^ > $@ + +test-blk.golden: $(patsubst %, tests/golden/%.golden, \ + prelim core coreplus coreext doubltst block report-blk) + cat $^ > $@ + +test-kernel.golden: $(patsubst %, tests/golden/%.golden, prelim core) cat $^ > $@ %.golden: tests/golden/%.golden diff --git a/8080/CPM/src/include.fb b/8080/CPM/src/include.fb index ee99b71..b6ef618 100644 --- a/8080/CPM/src/include.fb +++ b/8080/CPM/src/include.fb @@ -1 +1 @@ -\ include for stream sources for cp/m phz 30aug23 \ load screen phz 02sep23 onlyforth dos also forth definitions : idos-error? ( n -- f ) 0<> ; : iread-seq ( dosfcb -- f ) $14 bdosa idos-error? ; : cr+ex@ ( fcb -- cr+256*ex ) dup &34 + c@ swap &14 + c@ $100 * + ; : cr+ex! ( cr+256*ex fcb -- ) >r $100 u/mod r@ &14 + c! r> &34 + c! ; 1 7 +thru \ fib /fib #fib eolf? phz 07mai23 context @ dos also context ! $50 constant /tib variable tibeof tibeof off $1a constant ctrl-z : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN ctrl-z = IF tibeof on 1 ELSE -1 THEN ; \ incfile incpos inc-fgetc phz 02sep23 variable incfile variable increc variable rec-offset $80 constant dmabuf | $ff constant dmabuf-last : readrec ( fcb -- f ) dup cr+ex@ increc ! rec-offset off dmabuf dma! drive iread-seq ; : inc-fgetc ( -- c ) rec-offset @ b/rec u< 0= IF incfile @ readrec IF ctrl-z exit THEN THEN rec-offset @ dmabuf + c@ 1 rec-offset +! ; \ freadline probe-for-fb phz 25aug23 : freadline ( -- eof ) tib /tib bounds DO inc-fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN inc-fgetc eolf? 1+ UNTIL tibeof @ ; | : probe-for-fb ( -- flag ) dmabuf BEGIN dup c@ #lf = IF drop 0 exit THEN 1+ dup dmabuf-last u> UNTIL drop 1 ; \ save/restoretib phz 06okt22 $50 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib inner-include phz 02sep23 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include-inner ( -- ) increc push 0 isfile@ cr+ex! isfile@ readrec Abort" can't read start of file" probe-for-fb IF 1 load exit THEN incfile push isfile@ incfile ! savetib >r interpret-via-tib close r> restoretib ; \ include phz 02sep23 : include ( -- ) rec-offset push isfile push fromfile push use cr file? include-inner incfile @ IF increc @ incfile @ cr+ex! incfile @ readrec Abort" error re-reading after include" THEN ; \ \ phz 02sep23 : (stashquit stash[ stash> ! incfile off increc off (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart : \ blk @ IF >in @ negate c/l mod >in +! ELSE #tib @ >in ! THEN ; immediate \ : \needs have 0=exit \ blk @ IF >in @ negate c/l mod >in +! \ ELSE #tib @ >in ! THEN ; \ No newline at end of file +\ include for stream sources for cp/m phz 30aug23 \ load screen phz 02sep23 onlyforth dos also forth definitions : idos-error? ( n -- f ) 0<> ; : iread-seq ( dosfcb -- f ) $14 bdosa idos-error? ; : cr+ex@ ( fcb -- cr+256*ex ) dup &34 + c@ swap &14 + c@ $100 * + ; : cr+ex! ( cr+256*ex fcb -- ) >r $100 u/mod r@ &14 + c! r> &34 + c! ; 1 7 +thru \ fib /fib #fib eolf? phz 09okt24 context @ dos also context ! \ $50 constant /tib variable tibeof tibeof off $1a constant ctrl-z : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN ctrl-z = IF tibeof on 1 ELSE -1 THEN ; \ incfile incpos inc-fgetc phz 02sep23 variable incfile variable increc variable rec-offset $80 constant dmabuf | $ff constant dmabuf-last : readrec ( fcb -- f ) dup cr+ex@ increc ! rec-offset off dmabuf dma! drive iread-seq ; : inc-fgetc ( -- c ) rec-offset @ b/rec u< 0= IF incfile @ readrec IF ctrl-z exit THEN THEN rec-offset @ dmabuf + c@ 1 rec-offset +! ; \ freadline probe-for-fb phz 25aug23 : freadline ( -- eof ) tib /tib bounds DO inc-fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN inc-fgetc eolf? 1+ UNTIL tibeof @ ; | : probe-for-fb ( -- flag ) dmabuf BEGIN dup c@ #lf = IF drop 0 exit THEN 1+ dup dmabuf-last u> UNTIL drop 1 ; \ save/restoretib phz 06okt22 $50 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib inner-include phz 02sep23 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include-inner ( -- ) increc push 0 isfile@ cr+ex! isfile@ readrec Abort" can't read start of file" probe-for-fb IF 1 load exit THEN incfile push isfile@ incfile ! savetib >r interpret-via-tib close r> restoretib ; \ include phz 02sep23 : include ( -- ) rec-offset push isfile push fromfile push use cr file? include-inner incfile @ IF increc @ incfile @ cr+ex! incfile @ readrec Abort" error re-reading after include" THEN ; \ \ phz 02sep23 : (stashquit stash[ stash> ! incfile off increc off (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart : \ blk @ IF >in @ negate c/l mod >in +! ELSE #tib @ >in ! THEN ; immediate \ : \needs have 0=exit \ blk @ IF >in @ negate c/l mod >in +! \ ELSE #tib @ >in ! THEN ; \ No newline at end of file diff --git a/8080/CPM/src/include.fth b/8080/CPM/src/include.fth index d9d2d02..476e496 100644 --- a/8080/CPM/src/include.fth +++ b/8080/CPM/src/include.fth @@ -39,10 +39,10 @@ \ *** Block No. 2, Hexblock 2 -\ fib /fib #fib eolf? phz 07mai23 +\ fib /fib #fib eolf? phz 09okt24 context @ dos also context ! - $50 constant /tib + \ $50 constant /tib variable tibeof tibeof off $1a constant ctrl-z diff --git a/8080/CPM/tests/block.fth b/8080/CPM/tests/block.fth new file mode 100644 index 0000000..cb1b450 --- /dev/null +++ b/8080/CPM/tests/block.fth @@ -0,0 +1,679 @@ +\ 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 +\ ------------------------------------------------------------------------------ + +use empty.fb + +TESTING Block word set + +DECIMAL + +\ Define these constants from the system documentation provided. +\ WARNING: The contents of the test blocks will be destroyed by this test. +\ The blocks tested will be in the range +\ FIRST-TEST-BLOCK <= u < LIMIT-TEST-BLOCK +\ The tests need at least 2 test blocks in the range to complete. +20 CONSTANT FIRST-TEST-BLOCK +30 CONSTANT LIMIT-TEST-BLOCK \ one beyond the last + +FIRST-TEST-BLOCK LIMIT-TEST-BLOCK U< 0= [?IF] +\? .( Error: Test Block range not identified ) CR ABORT +[?THEN] + +LIMIT-TEST-BLOCK FIRST-TEST-BLOCK - CONSTANT TEST-BLOCK-COUNT +TEST-BLOCK-COUNT 2 U< [?IF] +\? .( Error: At least 2 Test Blocks are required to run the tests ) CR ABORT +[?THEN] + +\ ------------------------------------------------------------------------------ +TESTING Random Number Utilities + +\ The block tests make extensive use of random numbers to select blocks to test +\ and to set the contents of the block. It also makes use of a Hash code to +\ ensure the integrity of the blocks against unexpected changes. + +\ == Memory Walk tools == + +: @++ ( a-addr -- a-addr+4 a-addr@ ) + DUP CELL+ SWAP @ ; + +: !++ ( x a-addr -- a-addr+4 ) + TUCK ! CELL+ ; + +: C@++ ( c-addr -- c-addr;char+ c-addr@ ) + DUP CHAR+ SWAP C@ ; + +: C!++ ( char c-addr -- c-addr+1 ) + TUCK ! CHAR+ ; + +\ == Random Numbers == +\ Based on "Xorshift" PRNG wikipedia page +\ reporting on results by George Marsaglia +\ https://en.wikipedia.org/wiki/Xorshift +\ Note: THIS IS NOT CRYPTOGRAPHIC QUALITY + +: PRNG + CREATE ( "name" -- ) + 4 CELLS ALLOT + DOES> ( -- prng ) +; + +: PRNG-ERROR-CODE ( prng -- errcode | 0 ) + 0 4 0 DO \ prng acc + >R @++ R> OR \ prng acc' + LOOP \ prng xORyORzORw + NIP 0= ; \ xORyORzORw=0 + +: PRNG-COPY ( src-prng dst-prng -- ) + 4 CELLS MOVE ; + +: PRNG-SET-SEED ( prng w z y x -- ) + 4 PICK \ prng w z y x prng + 4 0 DO !++ LOOP DROP \ prng + DUP PRNG-ERROR-CODE IF \ prng + 1 OVER +! \ prng + THEN \ prng + DROP ; \ + +BITS/CELL 64 = [?IF] +\? : PRNG-RND ( prng -- rnd ) +\? DUP @ +\? DUP 21 LSHIFT XOR +\? DUP 35 RSHIFT XOR +\? DUP 4 LSHIFT XOR +\? TUCK SWAP ! ; +[?THEN] + +BITS/CELL 32 = [?IF] +\? : PRNG-RND ( prng -- rnd ) +\? DUP @ \ prng x +\? DUP 11 LSHIFT XOR \ prng t=x^(x<<11) +\? DUP 8 RSHIFT XOR \ prng t'=t^(t>>8) +\? OVER DUP CELL+ SWAP 3 CELLS MOVE \ prng t' +\? OVER 3 CELLS + @ \ prng t' w +\? DUP 19 RSHIFT XOR \ prng t' w'=w^(w>>19) +\? XOR \ prng rnd=w'^t' +\? TUCK SWAP 3 CELLS + ! ; \ rnd +[?THEN] + +BITS/CELL 16 = [?IF] +\? .( === NOT TESTED === ) +\? \ From http://b2d-f9r.blogspot.co.uk/2010/08/16-bit-xorshift-rng-now-with-more.html +\? : PRNG-RND ( prng -- rnd ) +\? DUP @ \ prng x +\? DUP 5 LSHIFT XOR \ prng t=x^(x<<5) +\? DUP 3 RSHIFT XOR \ prng t'=t^(t>>3) +\? OVER DUP CELL+ @ TUCK SWAP ! \ prng t' y +\? DUP 1 RSHIFT XOR \ prng t' y'=y^(y>>1) +\? XOR \ prng rnd=y'^t' +\? TUCK SWAP CELL+ ! ; \ rnd +[?THEN] + +[?DEF] PRNG-RND +\? .( You need to add a Psuedo Random Number Generator for your cell size: ) +\? BITS/CELL U. CR +\? ABORT +[?THEN] + +: PRNG-RANDOM ( lower upper prng -- rnd ) + >R OVER - R> PRNG-RND UM* NIP + ; +\ PostCondition: T{ lower upper 2DUP 2>R prng PRNG-RANDOM 2R> WITHIN -> TRUE }T + +PRNG BLOCK-PRNG +\ Generated by Random.org +BLOCK-PRNG -1865266521 188896058 -2021545234 -1456609962 PRNG-SET-SEED +: BLOCK-RND ( -- rnd ) BLOCK-PRNG PRNG-RND ; +: BLOCK-RANDOM ( lower upper -- rnd ) BLOCK-PRNG PRNG-RANDOM ; + +: RND-TEST-BLOCK ( -- blk ) + FIRST-TEST-BLOCK LIMIT-TEST-BLOCK BLOCK-RANDOM ; +\ PostCondition: T{ RND-TEST-BLOCK FIRST-TEST-BLOCK LIMIT-TEST-BLOCK WITHIN -> TRUE }T + +\ Two distinct random test blocks +: 2RND-TEST-BLOCKS ( -- blk1 blk2 ) + RND-TEST-BLOCK BEGIN \ blk1 + RND-TEST-BLOCK \ blk1 blk2 + 2DUP = \ blk1 blk2 blk1==blk2 + WHILE \ blk1 blk1 + DROP \ blk1 + REPEAT ; \ blk1 blk2 +\ PostCondition: T{ 2RND-TEST-BLOCKS = -> FALSE }T + +\ first random test block in a sequence of length u +: RND-TEST-BLOCK-SEQ ( u -- blks ) + FIRST-TEST-BLOCK LIMIT-TEST-BLOCK ROT 1- - BLOCK-RANDOM ; + +\ I'm not sure if this algorithm is correct if " 1 CHARS 1 <> ". +: ELF-HASH-ACCUMULATE ( hash c-addr u -- hash ) + >R SWAP R> 0 DO \ c-addr h + 4 LSHIFT \ c-addr h<<=4 + SWAP C@++ ROT + \ c-addr' h+=*s + DUP [ HEX ] F0000000 [ DECIMAL ] AND \ c-addr' h high=h&0xF0000000 + DUP IF \ c-addr' h high + DUP >R 24 RSHIFT XOR R> \ c-addr' h^=high>>24 high + THEN \ c-addr' h high + INVERT AND \ c-addr' h&=~high + LOOP NIP ; + +: ELF-HASH ( c-addr u -- hash ) + 0 ROT ROT ELF-HASH-ACCUMULATE ; + +\ ------------------------------------------------------------------------------ +TESTING BLOCK ( read-only mode ) + +\ BLOCK signature +T{ RND-TEST-BLOCK BLOCK DUP ALIGNED = -> TRUE }T + +\ BLOCK accepts all blocks in the test range +: BLOCK-ALL ( blk2 blk1 -- ) + DO + I BLOCK DROP + LOOP ; +T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK BLOCK-ALL -> }T + +\ BLOCK twice on same block returns the same value +T{ RND-TEST-BLOCK DUP BLOCK SWAP BLOCK = -> TRUE }T + +\ BLOCK twice on distinct block numbers +\ may or may not return the same value! +\ Nothing to test + +\ ------------------------------------------------------------------------------ +TESTING BUFFER ( read-only mode ) + +\ Although it is not in the spirit of the specification, +\ a compliant definition of BUFFER would be +\ : BUFFER BLOCK ; +\ So we can only repeat the tests for BLOCK ... + +\ BUFFER signature +T{ RND-TEST-BLOCK BUFFER DUP ALIGNED = -> TRUE }T + +\ BUFFER accepts all blocks in the test range +: BUFFER-ALL ( blk2 blk1 -- ) + DO + I BUFFER DROP + LOOP ; +T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK BUFFER-ALL -> }T + +\ BUFFER twice on the same block returns the same value +T{ RND-TEST-BLOCK DUP BUFFER SWAP BUFFER = -> TRUE }T + +\ BUFFER twice on distinct block numbers +\ may or may not return the same value! +\ Nothing to test + +\ Combinations with BUFFER +T{ RND-TEST-BLOCK DUP BLOCK SWAP BUFFER = -> TRUE }T +T{ RND-TEST-BLOCK DUP BUFFER SWAP BLOCK = -> TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING Read and Write access with UPDATE and FLUSH + +\ Ideally, we'd like to be able to test the persistence across power cycles +\ of the writes, but we can't do that in a simple test. +\ The tests below could be fooled by a large buffers store and a tricky FLUSH +\ but what else are you going to do? + +\ Signatures +T{ RND-TEST-BLOCK BLOCK DROP UPDATE -> }T +T{ FLUSH -> }T + +: BLANK-BUFFER ( blk -- blk-addr ) + BUFFER DUP 1024 BL FILL ; + +\ Test R/W of a Simple Blank Random Block +T{ RND-TEST-BLOCK \ blk + DUP BLANK-BUFFER \ blk blk-addr1 + 1024 ELF-HASH \ blk hash + UPDATE FLUSH \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = -> TRUE }T + +\ Boundary Test: Modify first character +T{ RND-TEST-BLOCK \ blk + DUP BLANK-BUFFER \ blk blk-addr1 + CHAR \ OVER C! \ blk blk-addr1 + 1024 ELF-HASH \ blk hash + UPDATE FLUSH \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = -> TRUE }T + +\ Boundary Test: Modify last character +T{ RND-TEST-BLOCK \ blk + DUP BLANK-BUFFER \ blk blk-addr1 + CHAR \ OVER 1023 CHARS + C! \ blk blk-addr1 + 1024 ELF-HASH \ blk hash + UPDATE FLUSH \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = -> TRUE }T + +\ Boundary Test: First and Last (and all other) blocks in the test range +1024 8 * BITS/CELL / CONSTANT CELLS/BLOCK + +: PREPARE-RND-BLOCK ( hash blk -- hash' ) + BUFFER DUP \ hash blk-addr blk-addr + CELLS/BLOCK 0 DO \ hash blk-addr blk-addr[i] + BLOCK-RND OVER ! CELL+ \ hash blk-addr blk-addr[i+1] + LOOP DROP \ hash blk-addr + 1024 ELF-HASH-ACCUMULATE ; \ hash' + +: WRITE-RND-BLOCKS-WITH-HASH ( blk2 blk1 -- hash ) + 0 ROT ROT DO \ hash + I PREPARE-RND-BLOCK UPDATE \ hash' + LOOP ; \ hash' + +: READ-BLOCKS-AND-HASH ( blk2 blk1 -- hash ) + 0 ROT ROT DO \ hash(i) + I BLOCK 1024 ELF-HASH-ACCUMULATE \ hash(i+1) + LOOP ; \ hash + +T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK WRITE-RND-BLOCKS-WITH-HASH FLUSH + LIMIT-TEST-BLOCK FIRST-TEST-BLOCK READ-BLOCKS-AND-HASH = -> TRUE }T + +: TUF1 ( xt blk -- hash ) + DUP BLANK-BUFFER \ xt blk blk-addr1 + 1024 ELF-HASH \ xt blk hash + ROT EXECUTE \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = ; \ TRUE + +\ Double UPDATE make no difference +: TUF1-1 ( -- ) UPDATE UPDATE FLUSH ; +T{ ' TUF1-1 RND-TEST-BLOCK TUF1 -> TRUE }T + +\ Double FLUSH make no difference +: TUF1-2 ( -- ) UPDATE FLUSH FLUSH ; +T{ ' TUF1-2 RND-TEST-BLOCK TUF1 -> TRUE }T + +\ FLUSH only saves UPDATEd buffers +T{ RND-TEST-BLOCK \ blk + 0 OVER PREPARE-RND-BLOCK \ blk hash + UPDATE FLUSH \ blk hash + OVER 0 SWAP PREPARE-RND-BLOCK DROP \ blk hash + FLUSH ( with no preliminary UPDATE) \ blk hash + SWAP BLOCK 1024 ELF-HASH = -> TRUE }T + +\ UPDATE only marks the current block buffer +\ This test needs at least 2 distinct buffers, though this is not a +\ requirement of the language specification. If 2 distinct buffers +\ are not returned, then the tests quits with a trivial Pass +: TUF2 ( xt blk1 blk2 -- hash1'' hash2'' hash1' hash2' hash1 hash2 ) + OVER BUFFER OVER BUFFER = IF \ test needs 2 distinct buffers + 2DROP DROP 0 0 0 0 0 0 \ Dummy result + ELSE + OVER 0 SWAP PREPARE-RND-BLOCK UPDATE \ xt blk1 blk2 hash1 + OVER 0 SWAP PREPARE-RND-BLOCK UPDATE \ xt blk1 blk2 hash1 hash2 + 2>R \ xt blk1 blk2 + FLUSH \ xt blk1 blk2 + OVER 0 SWAP PREPARE-RND-BLOCK \ xt blk1 blk2 hash1' + OVER 0 SWAP PREPARE-RND-BLOCK \ xt blk1 blk2 hash1' hash2' + 2>R \ xt blk1 blk2 + ROT EXECUTE \ blk1 blk2 + FLUSH \ blk1 blk2 + SWAP BLOCK 1024 ELF-HASH \ blk2 hash1'' + SWAP BLOCK 1024 ELF-HASH \ hash1'' hash2'' + 2R> 2R> \ hash1'' hash2'' hash1' hash2' hash1 hash2 + THEN ; + +: 2= ( x1 x2 x3 x4 -- flag ) + ROT = ROT ROT = AND ; + +: TUF2-0 ( blk1 blk2 -- blk1 blk2 ) ; \ no updates +T{ ' TUF2-0 2RND-TEST-BLOCKS TUF2 \ run test procedure + 2SWAP 2DROP 2= -> TRUE }T \ compare expected and actual + +: TUF2-1 ( blk1 blk2 -- blk1 blk2 ) \ update blk1 only + OVER BLOCK DROP UPDATE ; +T{ ' TUF2-1 2RND-TEST-BLOCKS TUF2 \ run test procedure + SWAP DROP SWAP DROP 2= -> TRUE }T + +: TUF2-2 ( blk1 blk2 -- blk1 blk2 ) \ update blk2 only + DUP BUFFER DROP UPDATE ; +T{ ' TUF2-2 2RND-TEST-BLOCKS TUF2 \ run test procedure + DROP ROT DROP SWAP 2= -> TRUE }T + +: TUF2-3 ( blk1 blk2 -- blk1 blk2 ) \ update blk1 and blk2 + TUF2-1 TUF2-2 ; +T{ ' TUF2-3 2RND-TEST-BLOCKS TUF2 \ run test procedure + 2DROP 2= -> TRUE }T + +\ FLUSH and then UPDATE is ambiguous and untestable + +\ ------------------------------------------------------------------------------ +TESTING SAVE-BUFFERS + +\ In principle, all the tests above can be repeated with SAVE-BUFFERS instead of +\ FLUSH. However, only the full random test is repeated... + +T{ LIMIT-TEST-BLOCK FIRST-TEST-BLOCK WRITE-RND-BLOCKS-WITH-HASH SAVE-BUFFERS + LIMIT-TEST-BLOCK FIRST-TEST-BLOCK READ-BLOCKS-AND-HASH = -> TRUE }T + +\ FLUSH and then SAVE-BUFFERS is harmless but undetectable +\ SAVE-BUFFERS and then FLUSH is undetectable + +\ Unlike FLUSH, SAVE-BUFFERS then BUFFER/BLOCK +\ returns the original buffer address +T{ RND-TEST-BLOCK DUP BLANK-BUFFER + SAVE-BUFFERS SWAP BUFFER = -> TRUE }T +T{ RND-TEST-BLOCK DUP BLANK-BUFFER + UPDATE SAVE-BUFFERS SWAP BUFFER = -> TRUE }T +T{ RND-TEST-BLOCK DUP BLANK-BUFFER + SAVE-BUFFERS SWAP BLOCK = -> TRUE }T +T{ RND-TEST-BLOCK DUP BLANK-BUFFER + UPDATE SAVE-BUFFERS SWAP BLOCK = -> TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING BLK + +\ Signature +T{ BLK DUP ALIGNED = -> TRUE }T + +\ None of the words considered so far effect BLK +T{ BLK @ RND-TEST-BLOCK BUFFER DROP BLK @ = -> TRUE }T +T{ BLK @ RND-TEST-BLOCK BLOCK DROP BLK @ = -> TRUE }T +T{ BLK @ UPDATE BLK @ = -> TRUE }T + +T{ BLK @ FLUSH BLK @ = -> TRUE }T +T{ BLK @ SAVE-BUFFERS BLK @ = -> TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING LOAD and EVALUATE + +\ Signature: n LOAD --> blank screen +T{ RND-TEST-BLOCK DUP BLANK-BUFFER DROP UPDATE FLUSH LOAD -> }T + +T{ BLK @ RND-TEST-BLOCK DUP BLANK-BUFFER DROP UPDATE FLUSH LOAD BLK @ = -> TRUE }T + +: WRITE-BLOCK ( blk c-addr u -- ) + ROT BLANK-BUFFER SWAP CHARS MOVE UPDATE FLUSH ; + +\ blk: u; blk LOAD +: TL1 ( u blk -- ) + SWAP 0 <# #S #> WRITE-BLOCK ; +T{ BLOCK-RND RND-TEST-BLOCK 2DUP TL1 LOAD = -> TRUE }T + +\ Boundary Test: FIRST-TEST-BLOCK +T{ BLOCK-RND FIRST-TEST-BLOCK 2DUP TL1 LOAD = -> TRUE }T + +\ Boundary Test: LIMIT-TEST-BLOCK-1 +T{ BLOCK-RND LIMIT-TEST-BLOCK 1- 2DUP TL1 LOAD = -> TRUE }T + +: WRITE-AT-END-OF-BLOCK ( blk c-addr u -- ) + ROT BLANK-BUFFER + OVER 1024 SWAP - CHARS + + SWAP CHARS MOVE UPDATE FLUSH ; + +\ Boundary Test: End of Buffer +: TL2 ( u blk -- ) + SWAP 0 <# #S #> WRITE-AT-END-OF-BLOCK ; +T{ BLOCK-RND RND-TEST-BLOCK 2DUP TL2 LOAD = -> TRUE }T + +\ LOAD updates BLK +\ u: "BLK @"; u LOAD +: TL3 ( blk -- ) + S" BLK @" WRITE-BLOCK ; +T{ RND-TEST-BLOCK DUP TL3 DUP LOAD = -> TRUE }T + +\ EVALUATE resets BLK +\ u: "EVALUATE-BLK@"; u LOAD +\vf : EVALUATE-BLK@ ( -- BLK@ ) +\vf S" BLK @" EVALUATE ; +\vf : TL4 ( blk -- ) +\vf S" EVALUATE-BLK@" WRITE-BLOCK ; +\vf T{ RND-TEST-BLOCK DUP TL4 LOAD -> 0 }T + +\ EVALUTE can nest with LOAD +\ u: "BLK @"; S" u LOAD" EVALUATE +\vf : TL5 ( blk -- c-addr u ) +\vf 0 <# \ blk 0 +\vf [CHAR] D HOLD +\vf [CHAR] A HOLD +\vf [CHAR] O HOLD +\vf [CHAR] L HOLD +\vf BL HOLD +\vf #S #> ; \ c-addr u +\vf T{ RND-TEST-BLOCK DUP TL3 DUP TL5 EVALUATE = -> TRUE }T + +\ Nested LOADs +\ u2: "BLK @"; u1: "LOAD u2"; u1 LOAD +\vf : TL6 ( blk1 blk2 -- ) +\vf DUP TL3 \ blk1 blk2 +\vf TL5 WRITE-BLOCK ; +\vf T{ 2RND-TEST-BLOCKS 2DUP TL6 SWAP LOAD = -> TRUE }T + +\ LOAD changes the currect block that is effected by UPDATE +\ This test needs at least 2 distinct buffers, though this is not a +\ requirement of the language specification. If 2 distinct buffers +\ are not returned, then the tests quits with a trivial Pass +: TL7 ( blk1 blk2 -- u1 u2 rnd2 blk2-addr rnd1' rnd1 ) + OVER BUFFER OVER BUFFER = IF \ test needs 2 distinct buffers + 2DROP 0 0 0 0 0 0 \ Dummy result + ELSE + OVER BLOCK-RND DUP ROT TL1 >R \ blk1 blk2 + DUP S" SOURCE DROP" WRITE-BLOCK \ blk1 blk2 + \ change blk1 to a new rnd, but don't UPDATE + OVER BLANK-BUFFER \ blk1 blk2 blk1-addr + BLOCK-RND DUP >R \ blk1 blk2 blk1-addr rnd1' + 0 <# #S #> \ blk1 blk2 blk1-addr c-addr u + ROT SWAP CHARS MOVE \ blk1 blk2 + \ Now LOAD blk2 + DUP LOAD DUP >R \ blk1 blk2 blk2-addr + \ Write a new blk2 + DUP 1024 BL FILL \ blk1 blk2 blk2-addr + BLOCK-RND DUP >R \ blk1 blk2 blk2-addr rnd2 + 0 <# #S #> \ blk1 blk2 blk2-addr c-addr u + ROT SWAP CHARS MOVE \ blk1 blk2 + \ The following UPDATE should refer to the LOADed blk2, not blk1 + UPDATE FLUSH \ blk1 blk2 + \ Finally, load both blocks then collect all results + LOAD SWAP LOAD \ u2 u1 + R> R> R> R> \ u2 u1 rnd2 blk2-addr rnd1' rnd1 + THEN ; +T{ 2RND-TEST-BLOCKS TL7 \ run test procedure + SWAP DROP SWAP DROP \ u2 u1 rnd2 rnd1 + 2= -> TRUE }T + +\ I would expect LOAD to work on the contents of the buffer cache +\ and not the block device, but the specification doesn't say. +\ Similarly, I would not expect LOAD to FLUSH the buffer cache, +\ but the specification doesn't say so. + +\ ------------------------------------------------------------------------------ +TESTING LIST and SCR + +\ Signatures +T{ SCR DUP ALIGNED = -> TRUE }T +\ LIST signature is test implicitly in the following tests... + +: TLS1 ( blk -- ) + S" Should show a (mostly) blank screen" WRITE-BLOCK ; +T{ RND-TEST-BLOCK DUP TLS1 DUP LIST SCR @ = -> TRUE }T + +\ Boundary Test: FIRST-TEST-BLOCK +: TLS2 ( blk -- ) + S" List of the First test block" WRITE-BLOCK ; +T{ FIRST-TEST-BLOCK DUP TLS2 LIST -> }T + +\ Boundary Test: LIMIT-TEST-BLOCK +: TLS3 ( blk -- ) + S" List of the Last test block" WRITE-BLOCK ; +T{ LIMIT-TEST-BLOCK 1- DUP TLS3 LIST -> }T + +\ Boundary Test: End of Screen +: TLS4 ( blk -- ) + S" End of Screen" WRITE-AT-END-OF-BLOCK ; +T{ RND-TEST-BLOCK DUP TLS4 LIST -> }T + +\ BLOCK, BUFFER, UPDATE et al don't change SCR +: TLS5 ( blk -- ) + S" Should show another (mostly) blank screen" WRITE-BLOCK ; +\ the first test below sets the scenario for the subsequent tests +\ BLK is unchanged by LIST +T{ BLK @ RND-TEST-BLOCK DUP TLS5 LIST BLK @ = -> TRUE }T +\ SCR is unchanged by Earlier words +T{ SCR @ FLUSH SCR @ = -> TRUE }T +T{ SCR @ FLUSH DUP 1+ BUFFER DROP SCR @ = -> TRUE }T +T{ SCR @ FLUSH DUP 1+ BLOCK DROP SCR @ = -> TRUE }T +T{ SCR @ FLUSH DUP 1+ BLOCK DROP UPDATE SCR @ = -> TRUE }T +T{ SCR @ FLUSH DUP 1+ BLOCK DROP UPDATE SAVE-BUFFERS SCR @ = -> TRUE }T +: TLS6 ( blk -- ) + S" SCR @" WRITE-BLOCK ; +T{ SCR @ RND-TEST-BLOCK DUP TLS6 LOAD SCR @ OVER 2= -> TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING EMPTY-BUFFERS + +T{ EMPTY-BUFFERS -> }T +T{ BLK @ EMPTY-BUFFERS BLK @ = -> TRUE }T +T{ SCR @ EMPTY-BUFFERS SCR @ = -> TRUE }T + +\ Test R/W, but discarded changes with EMPTY-BUFFERS +T{ RND-TEST-BLOCK \ blk + DUP BLANK-BUFFER \ blk blk-addr1 + 1024 ELF-HASH \ blk hash + UPDATE FLUSH \ blk hash + OVER BLOCK CHAR \ SWAP C! \ blk hash + UPDATE EMPTY-BUFFERS FLUSH \ blk hash + SWAP BLOCK \ hash blk-addr2 + 1024 ELF-HASH = -> TRUE }T + +\ EMPTY-BUFFERS discards all buffers +: TUF2-EB ( blk1 blk2 -- blk1 blk2 ) + TUF2-1 TUF2-2 EMPTY-BUFFERS ; \ c.f. TUF2-3 +T{ ' TUF2-EB 2RND-TEST-BLOCKS TUF2 + 2SWAP 2DROP 2= -> TRUE }T + +\ FLUSH and then EMPTY-BUFFERS is acceptable but untestable +\ EMPTY-BUFFERS and then UPDATE is ambiguous and untestable + +\ ------------------------------------------------------------------------------ +TESTING >IN manipulation from a block source + +: TIN ( blk -- ) + S" 1 8 >IN +! 2 3" WRITE-BLOCK ; +T{ RND-TEST-BLOCK DUP TIN LOAD -> 1 3 }T + +\ ------------------------------------------------------------------------------ +TESTING \, SAVE-INPUT, RESTORE-INPUT and REFILL from a block source + +\ Try to determine the number of charaters per line +\ Assumes an even number of characters per line +: | ( u -- u-2 ) 2 - ; +: C/L-CALC ( blk -- c/l ) + DUP BLANK-BUFFER \ blk blk-addr + [CHAR] \ OVER C! \ blk blk-addr blk:"\" + 511 0 DO \ blk c-addr[i] + CHAR+ CHAR+ [CHAR] | OVER C! \ blk c-addr[i+1] + LOOP DROP \ blk blk:"\ | | | | ... |" + UPDATE SAVE-BUFFERS FLUSH \ blk + 1024 SWAP LOAD ; \ c/l +[?DEF] C/L +[?ELSE] +\? .( Given Characters per Line: ) C/L U. CR +[?ELSE] +\? RND-TEST-BLOCK C/L-CALC CONSTANT C/L +\? C/L 1024 U< [?IF] +\? .( Calculated Characters per Line: ) C/L U. CR +[?THEN] + +: WRITE-BLOCK-LINE ( lin-addr[i] c-addr u -- lin-addr[i+1] ) + 2>R DUP C/L CHARS + SWAP 2R> ROT SWAP MOVE ; + +\ Discards to the end of the line +: TCSIRIR1 ( blk -- ) + BLANK-BUFFER + C/L 1024 U< IF + S" 2222 \ 3333" WRITE-BLOCK-LINE + S" 4444" WRITE-BLOCK-LINE + THEN + DROP UPDATE SAVE-BUFFERS ; + +T{ RND-TEST-BLOCK DUP TCSIRIR1 LOAD -> 2222 4444 }T + +VARIABLE T-CNT 0 T-CNT ! + +: MARK ( "" -- ) \ Use between <# and #> + CHAR HOLD ; IMMEDIATE + +: ?EXECUTE ( xt f -- ) + IF EXECUTE ELSE DROP THEN ; + +\ SAVE-INPUT and RESTORE-INPUT within a single block +\vf : TCSIRIR2-EXPECTED S" EDCBCBA" ; \ Remember that the string comes out backwards +\vf : TCSIRIR2 ( blk -- ) +\vf C/L 1024 U< IF +\vf BLANK-BUFFER +\vf S" 0 T-CNT !" WRITE-BLOCK-LINE +\vf S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE +\vf S" 1 T-CNT +! MARK C ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK D" WRITE-BLOCK-LINE +\vf S" MARK E 0 0 #>" WRITE-BLOCK-LINE +\vf UPDATE SAVE-BUFFERS DROP +\vf ELSE +\vf S" 0 TCSIRIR2-EXPECTED" WRITE-BLOCK +\vf THEN ; +\vf T{ RND-TEST-BLOCK DUP TCSIRIR2 LOAD TCSIRIR2-EXPECTED S= -> 0 TRUE }T + +\ REFILL across 2 blocks +\vf : TCSIRIR3 ( blks -- ) +\vf DUP S" 1 2 3 REFILL 4 5 6" WRITE-BLOCK +\vf 1+ S" 10 11 12" WRITE-BLOCK ; +\vf T{ 2 RND-TEST-BLOCK-SEQ DUP TCSIRIR3 LOAD -> 1 2 3 -1 10 11 12 }T + +\ SAVE-INPUT and RESTORE-INPUT across 2 blocks +\vf : TCSIRIR4-EXPECTED S" HGF1ECBF1ECBA" ; \ Remember that the string comes out backwards +\vf : TCSIRIR4 ( blks -- ) +\vf C/L 1024 U< IF +\vf DUP BLANK-BUFFER +\vf S" 0 T-CNT !" WRITE-BLOCK-LINE +\vf S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE +\vf S" MARK C REFILL MARK D" WRITE-BLOCK-LINE +\vf DROP UPDATE 1+ BLANK-BUFFER +\vf S" MARK E ABS CHAR 0 + HOLD" WRITE-BLOCK-LINE +\vf S" 1 T-CNT +! MARK F ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK G" WRITE-BLOCK-LINE +\vf S" MARK H 0 0 #>" WRITE-BLOCK-LINE +\vf DROP UPDATE SAVE-BUFFERS +\vf ELSE +\vf S" 0 TCSIRIR4-EXPECTED" WRITE-BLOCK +\vf THEN ; +\vf T{ 2 RND-TEST-BLOCK-SEQ DUP TCSIRIR4 LOAD TCSIRIR4-EXPECTED S= -> 0 TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING THRU + +: TT1 ( blks -- ) + DUP S" BLK" WRITE-BLOCK + 1+ S" @" WRITE-BLOCK ; +T{ 2 RND-TEST-BLOCK-SEQ DUP TT1 DUP DUP 1+ THRU 1- = -> TRUE }T + +\ ------------------------------------------------------------------------------ + +BLOCK-ERRORS SET-ERROR-COUNT + +CR .( End of Block word tests) CR diff --git a/8080/CPM/tests/coreext.fth b/8080/CPM/tests/coreext.fth new file mode 100644 index 0000000..990ba89 --- /dev/null +++ b/8080/CPM/tests/coreext.fth @@ -0,0 +1,769 @@ +\ 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 + +\ ----------------------------------------------------------------------------- +\vf TESTING MARKER (contributed by James Bowman) + +\vf T{ : MA? BL WORD FIND NIP 0<> ; -> }T +\vf T{ MARKER MA0 -> }T +\vf T{ : MA1 111 ; -> }T +\vf T{ MARKER MA2 -> }T +\vf T{ : MA1 222 ; -> }T +\vf T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE TRUE }T +\vf T{ MA1 MA2 MA1 -> 222 111 }T +\vf T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE FALSE }T +\vf T{ MA0 -> }T +\vf 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 + +\ ----------------------------------------------------------------------------- +\vf TESTING VALUE TO + +\vf T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T +\vf T{ VAL1 -> 111 }T +\vf T{ VAL2 -> -999 }T +\vf T{ 222 TO VAL1 -> }T +\vf T{ VAL1 -> 222 }T +\vf T{ : VD1 VAL1 ; -> }T +\vf T{ VD1 -> 222 }T +\vf T{ : VD2 TO VAL2 ; -> }T +\vf T{ VAL2 -> -999 }T +\vf T{ -333 VD2 -> }T +\vf T{ VAL2 -> -333 }T +\vf T{ VAL1 -> 222 }T +\vf T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T +\vf T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING CASE OF ENDOF ENDCASE + +\vf : CS1 CASE 1 OF 111 ENDOF +\vf 2 OF 222 ENDOF +\vf 3 OF 333 ENDOF +\vf >R 999 R> +\vf ENDCASE +\vf ; + +\vf T{ 1 CS1 -> 111 }T +\vf T{ 2 CS1 -> 222 }T +\vf T{ 3 CS1 -> 333 }T +\vf T{ 4 CS1 -> 999 }T + +\ Nested CASE's + +\vf : CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF +\vf 2 OF 200 ENDOF +\vf >R -300 R> +\vf ENDCASE +\vf ENDOF +\vf -2 OF CASE R@ 1 OF -99 ENDOF +\vf >R -199 R> +\vf ENDCASE +\vf ENDOF +\vf >R 299 R> +\vf ENDCASE R> DROP +\vf ; + +\vf T{ -1 1 CS2 -> 100 }T +\vf T{ -1 2 CS2 -> 200 }T +\vf T{ -1 3 CS2 -> -300 }T +\vf T{ -2 1 CS2 -> -99 }T +\vf T{ -2 2 CS2 -> -199 }T +\vf T{ 0 2 CS2 -> 299 }T + +\ Boolean short circuiting using CASE + +\vf : CS3 ( N1 -- N2 ) +\vf CASE 1- FALSE OF 11 ENDOF +\vf 1- FALSE OF 22 ENDOF +\vf 1- FALSE OF 33 ENDOF +\vf 44 SWAP +\vf ENDCASE +\vf ; + +\vf T{ 1 CS3 -> 11 }T +\vf T{ 2 CS3 -> 22 }T +\vf T{ 3 CS3 -> 33 }T +\vf T{ 9 CS3 -> 44 }T + +\ Empty CASE statements with/without default + +\vf T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T +\vf T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T +\vf T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T +\vf T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING :NONAME RECURSE + +\vf VARIABLE NN1 +\vf VARIABLE NN2 +\vf :NONAME 1234 ; NN1 ! +\vf :NONAME 9876 ; NN2 ! +\vf T{ NN1 @ EXECUTE -> 1234 }T +\vf T{ NN2 @ EXECUTE -> 9876 }T + +\vf T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ; +\vf CONSTANT RN1 -> }T +\vf T{ 0 RN1 EXECUTE -> 0 }T +\vf T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T + +\vf :NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition +\vf 1- DUP +\vf CASE 0 OF EXIT ENDOF +\vf 1 OF 11 SWAP RECURSE ENDOF +\vf 2 OF 22 SWAP RECURSE ENDOF +\vf 3 OF 33 SWAP RECURSE ENDOF +\vf DROP ABS RECURSE EXIT +\vf ENDCASE +\vf ; CONSTANT RN2 + +\vf T{ 1 RN2 EXECUTE -> 0 }T +\vf T{ 2 RN2 EXECUTE -> 11 0 }T +\vf T{ 4 RN2 EXECUTE -> 33 22 11 0 }T +\vf T{ 25 RN2 EXECUTE -> 33 22 11 0 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING C" + +T{ : CQ1 C" 123" ; -> }T +\vf T{ CQ1 COUNT EVALUATE -> 123 }T +T{ : CQ2 C" " ; -> }T +\vf T{ CQ2 COUNT EVALUATE -> }T +\vf 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 + +\vf TESTING SAVE-INPUT and RESTORE-INPUT with a string source + +\vf VARIABLE SI_INC 0 SI_INC ! + +\vf : SI1 +\vf SI_INC @ >IN +! +\vf 15 SI_INC ! +\vf ; + +\vf : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; + +\vf 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 + +\ ----------------------------------------------------------------------------- +\vf TESTING PARSE + +\vf T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T +\vf T{ CHAR ^ PARSE 23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T +\vf : PA1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ; +\vf T{ PA1 3456 +\vf DUP ROT ROT EVALUATE -> 4 3456 }T +\vf T{ CHAR A PARSE A SWAP DROP -> 0 }T +\vf T{ CHAR Z PARSE +\vf SWAP DROP -> 0 }T +\vf T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING PARSE-NAME (Forth 2012) +\ Adapted from the PARSE-NAME RfD tests +\vf T{ PARSE-NAME abcd STR1 S= -> TRUE }T \ No leading spaces +\vf T{ PARSE-NAME abcde STR2 S= -> TRUE }T \ Leading spaces + +\ Test empty parse area, new lines are necessary +\vf T{ PARSE-NAME +\vf NIP -> 0 }T +\ Empty parse area with spaces after PARSE-NAME +\vf T{ PARSE-NAME +\vf NIP -> 0 }T + +\vf T{ : PARSE-NAME-TEST ( "name1" "name2" -- n ) +\vf PARSE-NAME PARSE-NAME S= ; -> }T +\vf T{ PARSE-NAME-TEST abcd abcd -> TRUE }T +\vf T{ PARSE-NAME-TEST abcd abcd -> TRUE }T \ Leading spaces +\vf T{ PARSE-NAME-TEST abcde abcdf -> FALSE }T +\vf T{ PARSE-NAME-TEST abcdf abcde -> FALSE }T +\vf T{ PARSE-NAME-TEST abcde abcde +\vf -> TRUE }T \ Parse to end of line +\vf T{ PARSE-NAME-TEST abcde abcde +\vf -> 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 + +\ ----------------------------------------------------------------------------- +\vf 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 + +\vf T{ : RF1 S" REFILL" EVALUATE ; RF1 -> FALSE }T +\vf T{ : SID1 S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T + +\ ------------------------------------------------------------------------------ +\vf 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 + +\vf T{ : SSQ1 S\" abc" S" abc" S= ; -> }T \ No escapes +\vf T{ SSQ1 -> TRUE }T +\vf T{ : SSQ2 S\" " ; SSQ2 SWAP DROP -> 0 }T \ Empty string + +\vf T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T +\vf T{ SSQ3 SWAP DROP -> 20 }T \ String length +\vf T{ SSQ3 DROP C@ -> 7 }T \ \a BEL Bell +\vf T{ SSQ3 DROP 1 CHARS + C@ -> 8 }T \ \b BS Backspace +\vf T{ SSQ3 DROP 2 CHARS + C@ -> 27 }T \ \e ESC Escape +\vf T{ SSQ3 DROP 3 CHARS + C@ -> 12 }T \ \f FF Form feed +\vf T{ SSQ3 DROP 4 CHARS + C@ -> 10 }T \ \l LF Line feed +\vf T{ SSQ3 DROP 5 CHARS + C@ -> 13 }T \ \m CR of CR/LF pair +\vf T{ SSQ3 DROP 6 CHARS + C@ -> 10 }T \ LF of CR/LF pair +\vf T{ SSQ3 DROP 7 CHARS + C@ -> 34 }T \ \q " Double Quote +\vf T{ SSQ3 DROP 8 CHARS + C@ -> 13 }T \ \r CR Carriage Return +\vf T{ SSQ3 DROP 9 CHARS + C@ -> 9 }T \ \t TAB Horizontal Tab +\vf T{ SSQ3 DROP 10 CHARS + C@ -> 11 }T \ \v VT Vertical Tab +\vf T{ SSQ3 DROP 11 CHARS + C@ -> 15 }T \ \x0F Given Char +\vf T{ SSQ3 DROP 12 CHARS + C@ -> 48 }T \ 0 0 Digit follow on +\vf T{ SSQ3 DROP 13 CHARS + C@ -> 31 }T \ \x1F Given Char +\vf T{ SSQ3 DROP 14 CHARS + C@ -> 97 }T \ a a Hex follow on +\vf T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T \ \xaB Insensitive Given Char +\vf T{ SSQ3 DROP 16 CHARS + C@ -> 120 }T \ x x Non hex follow on +\vf T{ SSQ3 DROP 17 CHARS + C@ -> 0 }T \ \z NUL No Character +\vf T{ SSQ3 DROP 18 CHARS + C@ -> 34 }T \ \" " Double Quote +\vf 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 +\vf CR .( The next test should display:) +\vf CR .( One line...) +\vf CR .( another line) +\vf T{ : SSQ4 S\" \nOne line...\nanotherLine\n" type ; SSQ4 -> }T + +\ Test bare escapable characters appear as themselves +\vf T{ : SSQ5 S\" abeflmnqrtvxz" S" abeflmnqrtvxz" S= ; SSQ5 -> TRUE }T + +\vf T{ : SSQ6 S\" a\""2DROP 1111 ; SSQ6 -> 1111 }T \ Parsing behaviour + +\vf T{ : SSQ7 S\" 111 : SSQ8 s\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T +\vf T{ SSQ7 -> 111 222 333 }T +\vf T{ : SSQ9 S\" 11 : SSQ10 s\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T +\vf T{ SSQ9 -> 11 22 33 }T + +\ ----------------------------------------------------------------------------- +CORE-EXT-ERRORS SET-ERROR-COUNT + +CR .( End of Core Extension word tests) CR + + diff --git a/8080/CPM/tests/coreplus.fth b/8080/CPM/tests/coreplus.fth new file mode 100644 index 0000000..82b1be2 --- /dev/null +++ b/8080/CPM/tests/coreplus.fth @@ -0,0 +1,306 @@ +\ 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 + +\ ------------------------------------------------------------------------------ +\vf TESTING multiple ELSE's in an IF statement +\ Discussed on comp.lang.forth and accepted as valid ANS Forth + +\vf : MELSE IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ; +\vf T{ 0 MELSE -> 2 4 }T +\vf 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 \ vf: s/#/&/ +T{ -&1289 -> -1289 }T \ vf: s/#-/-&/ +T{ $12eF -> 4847 }T +T{ -$12eF -> -4847 }T \ vf: s/$-/-$/ +T{ %10010110 -> 150 }T +T{ -%10010110 -> -150 }T \ vf: s/%-/-%/ +\vf T{ 'z' -> 122 }T +\vf 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 \ vf: s/#/&/ +T{ -&1289 -> -509 }T \ vf: s/#/&/ +T{ $12eF -> 12EF }T +T{ -$12eF -> -12EF }T \ vf: s/$-/-$/ +T{ %10010110 -> 96 }T +T{ -%10010110 -> -96 }T \ vf: s/%-/-%/ +\vf T{ 'z' -> 7a }T +\vf T{ 'Z' -> 5a }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = -> }T \ 2 + +DECIMAL +\ Check number prefixes in compile mode +\ vf: s/#/&/ s/$-/-$/ s/'''/ascii '/ +T{ : nmp &8327 -$2cbe %011010111 ascii ' ; 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 + +\ ------------------------------------------------------------------------------ +\vf TESTING IF ... BEGIN ... REPEAT (unstructured) + +\vf T{ : UNS1 DUP 0 > IF 9 SWAP BEGIN 1+ DUP 3 > IF EXIT THEN REPEAT ; -> }T +\vf T{ -6 UNS1 -> -6 }T +\vf 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 diff --git a/8080/CPM/tests/doubltst.fth b/8080/CPM/tests/doubltst.fth new file mode 100644 index 0000000..0f3f3b3 --- /dev/null +++ b/8080/CPM/tests/doubltst.fth @@ -0,0 +1,438 @@ +\ To test the ANS Forth Double-Number word set and double number extensions + +\ 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 Assumptions and dependencies changed +\ 0.12 1 August 2015 test D< acts on MS cells of double word +\ 0.11 7 April 2015 2VALUE tested +\ 0.6 1 April 2012 Tests placed in the public domain. +\ Immediate 2CONSTANTs and 2VARIABLEs tested +\ 0.5 20 November 2009 Various constants renamed to avoid +\ redefinition warnings. and replaced +\ with TRUE and FALSE +\ 0.4 6 March 2009 { and } replaced with T{ and }T +\ Tests rewritten to be independent of word size and +\ tests re-ordered +\ 0.3 20 April 2007 ANS Forth words changed to upper case +\ 0.2 30 Oct 2006 Updated following GForth test to include +\ various constants from core.fr +\ 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: +\ 2CONSTANT 2LITERAL 2VARIABLE D+ D- D. D.R D0< D0= D2* D2/ +\ D< D= D>S DABS DMAX DMIN DNEGATE M*/ M+ 2ROT DU< +\ Also tests the interpreter and compiler reading a double number +\ ------------------------------------------------------------------------------ +\ Assumptions and dependencies: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set is available and tested +\ ------------------------------------------------------------------------------ +\ Constant definitions + +DECIMAL +0 INVERT CONSTANT 1SD +1SD 1 RSHIFT CONSTANT MAX-INTD \ 01...1 +MAX-INTD INVERT CONSTANT MIN-INTD \ 10...0 +MAX-INTD 2/ CONSTANT HI-INT \ 001...1 +MIN-INTD 2/ CONSTANT LO-INT \ 110...1 + +\ ------------------------------------------------------------------------------ +TESTING interpreter and compiler reading double numbers, with/without prefixes + +T{ 1. -> 1 0 }T +T{ -2. -> -2 -1 }T +T{ : RDL1 3. ; RDL1 -> 3 0 }T +T{ : RDL2 -4. ; RDL2 -> -4 -1 }T + +VARIABLE OLD-DBASE +DECIMAL BASE @ OLD-DBASE ! +T{ &12346789. -> 12346789. }T \ vf: s/#/&/ +T{ -&12346789. -> -12346789. }T \ vf: s/#-/-&/ +T{ $12aBcDeF. -> 313249263. }T +T{ -$12AbCdEf. -> -313249263. }T \ vf: s/$-/-$/ +T{ %10010110. -> 150. }T +T{ -%10010110. -> -150. }T \ vf: s/%-/-%/ +\ Check BASE is unchanged +T{ BASE @ OLD-DBASE @ = -> }T + +\ Repeat in Hex mode +16 OLD-DBASE ! 16 BASE ! +T{ &12346789. -> BC65A5. }T \ vf: s/#/&/ +T{ -&12346789. -> -BC65A5. }T \ vf: s/#-/-&/ +T{ $12aBcDeF. -> 12AbCdeF. }T +T{ -$12AbCdEf. -> -12ABCDef. }T \ vf: s/$-/-$/ +T{ %10010110. -> 96. }T +T{ -%10010110. -> -96. }T \ vf: s/%-/-%/ +\ Check BASE is unchanged +T{ BASE @ OLD-DBASE @ = -> }T \ 2 + +DECIMAL +\ Check number prefixes in compile mode +\ vf: s/#/&/ s/$-/-$/ +T{ : dnmp &8327. -$2cbe. %011010111. ; dnmp -> 8327. -11454. 215. }T + +\ ------------------------------------------------------------------------------ +TESTING 2CONSTANT + +T{ 1 2 2CONSTANT 2C1 -> }T +T{ 2C1 -> 1 2 }T +T{ : CD1 2C1 ; -> }T +T{ CD1 -> 1 2 }T +T{ : CD2 2CONSTANT ; -> }T +T{ -1 -2 CD2 2C2 -> }T +T{ 2C2 -> -1 -2 }T +T{ 4 5 2CONSTANT 2C3 IMMEDIATE 2C3 -> 4 5 }T +T{ : CD6 2C3 2LITERAL ; CD6 -> 4 5 }T + +\ ------------------------------------------------------------------------------ +\ Some 2CONSTANTs for the following tests + +1SD MAX-INTD 2CONSTANT MAX-2INT \ 01...1 +0 MIN-INTD 2CONSTANT MIN-2INT \ 10...0 +MAX-2INT 2/ 2CONSTANT HI-2INT \ 001...1 +MIN-2INT 2/ 2CONSTANT LO-2INT \ 110...0 + +\ ------------------------------------------------------------------------------ +TESTING DNEGATE + +T{ 0. DNEGATE -> 0. }T +T{ 1. DNEGATE -> -1. }T +T{ -1. DNEGATE -> 1. }T +T{ MAX-2INT DNEGATE -> MIN-2INT SWAP 1+ SWAP }T +T{ MIN-2INT SWAP 1+ SWAP DNEGATE -> MAX-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D+ with small integers + +T{ 0. 5. D+ -> 5. }T +T{ -5. 0. D+ -> -5. }T +T{ 1. 2. D+ -> 3. }T +T{ 1. -2. D+ -> -1. }T +T{ -1. 2. D+ -> 1. }T +T{ -1. -2. D+ -> -3. }T +T{ -1. 1. D+ -> 0. }T + +TESTING D+ with mid range integers + +T{ 0 0 0 5 D+ -> 0 5 }T +T{ -1 5 0 0 D+ -> -1 5 }T +T{ 0 0 0 -5 D+ -> 0 -5 }T +T{ 0 -5 -1 0 D+ -> -1 -5 }T +T{ 0 1 0 2 D+ -> 0 3 }T +T{ -1 1 0 -2 D+ -> -1 -1 }T +T{ 0 -1 0 2 D+ -> 0 1 }T +T{ 0 -1 -1 -2 D+ -> -1 -3 }T +T{ -1 -1 0 1 D+ -> -1 0 }T +T{ MIN-INTD 0 2DUP D+ -> 0 1 }T +T{ MIN-INTD S>D MIN-INTD 0 D+ -> 0 0 }T + +TESTING D+ with large double integers + +T{ HI-2INT 1. D+ -> 0 HI-INT 1+ }T +T{ HI-2INT 2DUP D+ -> 1SD 1- MAX-INTD }T +T{ MAX-2INT MIN-2INT D+ -> -1. }T +T{ MAX-2INT LO-2INT D+ -> HI-2INT }T +T{ HI-2INT MIN-2INT D+ 1. D+ -> LO-2INT }T +T{ LO-2INT 2DUP D+ -> MIN-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D- with small integers + +T{ 0. 5. D- -> -5. }T +T{ 5. 0. D- -> 5. }T +T{ 0. -5. D- -> 5. }T +T{ 1. 2. D- -> -1. }T +T{ 1. -2. D- -> 3. }T +T{ -1. 2. D- -> -3. }T +T{ -1. -2. D- -> 1. }T +T{ -1. -1. D- -> 0. }T + +TESTING D- with mid-range integers + +T{ 0 0 0 5 D- -> 0 -5 }T +T{ -1 5 0 0 D- -> -1 5 }T +T{ 0 0 -1 -5 D- -> 1 4 }T +T{ 0 -5 0 0 D- -> 0 -5 }T +T{ -1 1 0 2 D- -> -1 -1 }T +T{ 0 1 -1 -2 D- -> 1 2 }T +T{ 0 -1 0 2 D- -> 0 -3 }T +T{ 0 -1 0 -2 D- -> 0 1 }T +T{ 0 0 0 1 D- -> 0 -1 }T +T{ MIN-INTD 0 2DUP D- -> 0. }T +T{ MIN-INTD S>D MAX-INTD 0 D- -> 1 1SD }T + +TESTING D- with large integers + +T{ MAX-2INT MAX-2INT D- -> 0. }T +T{ MIN-2INT MIN-2INT D- -> 0. }T +T{ MAX-2INT HI-2INT D- -> LO-2INT DNEGATE }T +T{ HI-2INT LO-2INT D- -> MAX-2INT }T +T{ LO-2INT HI-2INT D- -> MIN-2INT 1. D+ }T +T{ MIN-2INT MIN-2INT D- -> 0. }T +T{ MIN-2INT LO-2INT D- -> LO-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D0< D0= + +T{ 0. D0< -> FALSE }T +T{ 1. D0< -> FALSE }T +T{ MIN-INTD 0 D0< -> FALSE }T +T{ 0 MAX-INTD D0< -> FALSE }T +T{ MAX-2INT D0< -> FALSE }T +T{ -1. D0< -> TRUE }T +T{ MIN-2INT D0< -> TRUE }T + +T{ 1. D0= -> FALSE }T +T{ MIN-INTD 0 D0= -> FALSE }T +T{ MAX-2INT D0= -> FALSE }T +T{ -1 MAX-INTD D0= -> FALSE }T +T{ 0. D0= -> TRUE }T +T{ -1. D0= -> FALSE }T +T{ 0 MIN-INTD D0= -> FALSE }T + +\ ------------------------------------------------------------------------------ +TESTING D2* D2/ + +T{ 0. D2* -> 0. D2* }T +T{ MIN-INTD 0 D2* -> 0 1 }T +T{ HI-2INT D2* -> MAX-2INT 1. D- }T +T{ LO-2INT D2* -> MIN-2INT }T + +T{ 0. D2/ -> 0. }T +T{ 1. D2/ -> 0. }T +T{ 0 1 D2/ -> MIN-INTD 0 }T +T{ MAX-2INT D2/ -> HI-2INT }T +T{ -1. D2/ -> -1. }T +T{ MIN-2INT D2/ -> LO-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D< D= + +T{ 0. 1. D< -> TRUE }T +T{ 0. 0. D< -> FALSE }T +T{ 1. 0. D< -> FALSE }T +T{ -1. 1. D< -> TRUE }T +T{ -1. 0. D< -> TRUE }T +T{ -2. -1. D< -> TRUE }T +T{ -1. -2. D< -> FALSE }T +T{ 0 1 1. D< -> FALSE }T \ Suggested by Helmut Eller +T{ 1. 0 1 D< -> TRUE }T +T{ 0 -1 1 -2 D< -> FALSE }T +T{ 1 -2 0 -1 D< -> TRUE }T +T{ -1. MAX-2INT D< -> TRUE }T +T{ MIN-2INT MAX-2INT D< -> TRUE }T +T{ MAX-2INT -1. D< -> FALSE }T +T{ MAX-2INT MIN-2INT D< -> FALSE }T +T{ MAX-2INT 2DUP -1. D+ D< -> FALSE }T +T{ MIN-2INT 2DUP 1. D+ D< -> TRUE }T +T{ MAX-INTD S>D 2DUP 1. D+ D< -> TRUE }T \ Ensure D< acts on MS cells + +T{ -1. -1. D= -> TRUE }T +T{ -1. 0. D= -> FALSE }T +T{ -1. 1. D= -> FALSE }T +T{ 0. -1. D= -> FALSE }T +T{ 0. 0. D= -> TRUE }T +T{ 0. 1. D= -> FALSE }T +T{ 1. -1. D= -> FALSE }T +T{ 1. 0. D= -> FALSE }T +T{ 1. 1. D= -> TRUE }T + +T{ 0 -1 0 -1 D= -> TRUE }T +T{ 0 -1 0 0 D= -> FALSE }T +T{ 0 -1 0 1 D= -> FALSE }T +T{ 0 0 0 -1 D= -> FALSE }T +T{ 0 0 0 0 D= -> TRUE }T +T{ 0 0 0 1 D= -> FALSE }T +T{ 0 1 0 -1 D= -> FALSE }T +T{ 0 1 0 0 D= -> FALSE }T +T{ 0 1 0 1 D= -> TRUE }T + +T{ MAX-2INT MIN-2INT D= -> FALSE }T +T{ MAX-2INT 0. D= -> FALSE }T +T{ MAX-2INT MAX-2INT D= -> TRUE }T +T{ MAX-2INT HI-2INT D= -> FALSE }T +T{ MAX-2INT MIN-2INT D= -> FALSE }T +T{ MIN-2INT MIN-2INT D= -> TRUE }T +T{ MIN-2INT LO-2INT D= -> FALSE }T +T{ MIN-2INT MAX-2INT D= -> FALSE }T + +\ ------------------------------------------------------------------------------ +TESTING 2LITERAL 2VARIABLE + +T{ : CD3 [ MAX-2INT ] 2LITERAL ; -> }T +T{ CD3 -> MAX-2INT }T +T{ 2VARIABLE 2V1 -> }T +T{ 0. 2V1 2! -> }T +T{ 2V1 2@ -> 0. }T +T{ -1 -2 2V1 2! -> }T +T{ 2V1 2@ -> -1 -2 }T +T{ : CD4 2VARIABLE ; -> }T +T{ CD4 2V2 -> }T +T{ : CD5 2V2 2! ; -> }T +T{ -2 -1 CD5 -> }T +T{ 2V2 2@ -> -2 -1 }T +T{ 2VARIABLE 2V3 IMMEDIATE 5 6 2V3 2! -> }T +T{ 2V3 2@ -> 5 6 }T +T{ : CD7 2V3 [ 2@ ] 2LITERAL ; CD7 -> 5 6 }T +T{ : CD8 [ 6 7 ] 2V3 [ 2! ] ; 2V3 2@ -> 6 7 }T + +\ ------------------------------------------------------------------------------ +TESTING DMAX DMIN + +T{ 1. 2. DMAX -> 2. }T +T{ 1. 0. DMAX -> 1. }T +T{ 1. -1. DMAX -> 1. }T +T{ 1. 1. DMAX -> 1. }T +T{ 0. 1. DMAX -> 1. }T +T{ 0. -1. DMAX -> 0. }T +T{ -1. 1. DMAX -> 1. }T +T{ -1. -2. DMAX -> -1. }T + +T{ MAX-2INT HI-2INT DMAX -> MAX-2INT }T +T{ MAX-2INT MIN-2INT DMAX -> MAX-2INT }T +T{ MIN-2INT MAX-2INT DMAX -> MAX-2INT }T +T{ MIN-2INT LO-2INT DMAX -> LO-2INT }T + +T{ MAX-2INT 1. DMAX -> MAX-2INT }T +T{ MAX-2INT -1. DMAX -> MAX-2INT }T +T{ MIN-2INT 1. DMAX -> 1. }T +T{ MIN-2INT -1. DMAX -> -1. }T + + +T{ 1. 2. DMIN -> 1. }T +T{ 1. 0. DMIN -> 0. }T +T{ 1. -1. DMIN -> -1. }T +T{ 1. 1. DMIN -> 1. }T +T{ 0. 1. DMIN -> 0. }T +T{ 0. -1. DMIN -> -1. }T +T{ -1. 1. DMIN -> -1. }T +T{ -1. -2. DMIN -> -2. }T + +T{ MAX-2INT HI-2INT DMIN -> HI-2INT }T +T{ MAX-2INT MIN-2INT DMIN -> MIN-2INT }T +T{ MIN-2INT MAX-2INT DMIN -> MIN-2INT }T +T{ MIN-2INT LO-2INT DMIN -> MIN-2INT }T + +T{ MAX-2INT 1. DMIN -> 1. }T +T{ MAX-2INT -1. DMIN -> -1. }T +T{ MIN-2INT 1. DMIN -> MIN-2INT }T +T{ MIN-2INT -1. DMIN -> MIN-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D>S DABS + +T{ 1234 0 D>S -> 1234 }T +T{ -1234 -1 D>S -> -1234 }T +T{ MAX-INTD 0 D>S -> MAX-INTD }T +T{ MIN-INTD -1 D>S -> MIN-INTD }T + +T{ 1. DABS -> 1. }T +T{ -1. DABS -> 1. }T +T{ MAX-2INT DABS -> MAX-2INT }T +T{ MIN-2INT 1. D+ DABS -> MAX-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING M+ M*/ + +T{ HI-2INT 1 M+ -> HI-2INT 1. D+ }T +T{ MAX-2INT -1 M+ -> MAX-2INT -1. D+ }T +T{ MIN-2INT 1 M+ -> MIN-2INT 1. D+ }T +T{ LO-2INT -1 M+ -> LO-2INT -1. D+ }T + +\ To correct the result if the division is floored, only used when +\ necessary i.e. negative quotient and remainder <> 0 + +: ?FLOORED [ -3 2 / -2 = ] LITERAL IF 1. D- THEN ; + +\vf T{ 5. 7 11 M*/ -> 3. }T +\vf T{ 5. -7 11 M*/ -> -3. ?FLOORED }T \ FLOORED -4. +\vf T{ -5. 7 11 M*/ -> -3. ?FLOORED }T \ FLOORED -4. +\vf T{ -5. -7 11 M*/ -> 3. }T +\vf T{ MAX-2INT 8 16 M*/ -> HI-2INT }T +\vf T{ MAX-2INT -8 16 M*/ -> HI-2INT DNEGATE ?FLOORED }T \ FLOORED SUBTRACT 1 +\vf T{ MIN-2INT 8 16 M*/ -> LO-2INT }T +\vf T{ MIN-2INT -8 16 M*/ -> LO-2INT DNEGATE }T +\vf T{ MAX-2INT MAX-INTD MAX-INTD M*/ -> MAX-2INT }T +\vf T{ MAX-2INT MAX-INTD 2/ MAX-INTD M*/ -> MAX-INTD 1- HI-2INT NIP }T +\vf T{ MIN-2INT LO-2INT NIP 1+ DUP 1- NEGATE M*/ -> 0 MAX-INTD 1- }T +\vf T{ MIN-2INT LO-2INT NIP 1- MAX-INTD M*/ -> MIN-INTD 3 + HI-2INT NIP 2 + }T +\vf T{ MAX-2INT LO-2INT NIP DUP NEGATE M*/ -> MAX-2INT DNEGATE }T +\vf T{ MIN-2INT MAX-INTD DUP M*/ -> MIN-2INT }T + +\ ------------------------------------------------------------------------------ +\vf TESTING D. D.R + +\ Create some large double numbers +\vf MAX-2INT 71 73 M*/ 2CONSTANT DBL1 +\vf MIN-2INT 73 79 M*/ 2CONSTANT DBL2 + +\vf : D>ASCII ( D -- CADDR U ) +\vf DUP >R <# DABS #S R> SIGN #> ( -- CADDR1 U ) +\vf HERE SWAP 2DUP 2>R CHARS DUP ALLOT MOVE 2R> +\vf ; + +\vf DBL1 D>ASCII 2CONSTANT "DBL1" +\vf DBL2 D>ASCII 2CONSTANT "DBL2" + +\vf : DOUBLEOUTPUT +\vf CR ." You should see lines duplicated:" CR +\vf 5 SPACES "DBL1" TYPE CR +\vf 5 SPACES DBL1 D. CR +\vf 8 SPACES "DBL1" DUP >R TYPE CR +\vf 5 SPACES DBL1 R> 3 + D.R CR +\vf 5 SPACES "DBL2" TYPE CR +\vf 5 SPACES DBL2 D. CR +\vf 10 SPACES "DBL2" DUP >R TYPE CR +\vf 5 SPACES DBL2 R> 5 + D.R CR +\vf ; + +\vf T{ DOUBLEOUTPUT -> }T + +\ ------------------------------------------------------------------------------ +TESTING 2ROT DU< (Double Number extension words) + +T{ 1. 2. 3. 2ROT -> 2. 3. 1. }T +T{ MAX-2INT MIN-2INT 1. 2ROT -> MIN-2INT 1. MAX-2INT }T + +\vf T{ 1. 1. DU< -> FALSE }T +\vf T{ 1. -1. DU< -> TRUE }T +\vf T{ -1. 1. DU< -> FALSE }T +\vf T{ -1. -2. DU< -> FALSE }T +\vf T{ 0 1 1. DU< -> FALSE }T +\vf T{ 1. 0 1 DU< -> TRUE }T +\vf T{ 0 -1 1 -2 DU< -> FALSE }T +\vf T{ 1 -2 0 -1 DU< -> TRUE }T + +\vf T{ MAX-2INT HI-2INT DU< -> FALSE }T +\vf T{ HI-2INT MAX-2INT DU< -> TRUE }T +\vf T{ MAX-2INT MIN-2INT DU< -> TRUE }T +\vf T{ MIN-2INT MAX-2INT DU< -> FALSE }T +\vf T{ MIN-2INT LO-2INT DU< -> TRUE }T + +\ ------------------------------------------------------------------------------ +\vf TESTING 2VALUE + +\vf T{ 1111 2222 2VALUE 2VAL -> }T +\vf T{ 2VAL -> 1111 2222 }T +\vf T{ 3333 4444 TO 2VAL -> }T +\vf T{ 2VAL -> 3333 4444 }T +\vf T{ : TO-2VAL TO 2VAL ; 5555 6666 TO-2VAL -> }T +\vf T{ 2VAL -> 5555 6666 }T + +\ ------------------------------------------------------------------------------ + +DOUBLE-ERRORS SET-ERROR-COUNT + +CR .( End of Double-Number word tests) CR + diff --git a/8080/CPM/tests/empty.fb b/8080/CPM/tests/empty.fb new file mode 100644 index 0000000..f5b7445 --- /dev/null +++ b/8080/CPM/tests/empty.fb @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/8080/CPM/tests/empty.fth b/8080/CPM/tests/empty.fth new file mode 100644 index 0000000..b68ea09 --- /dev/null +++ b/8080/CPM/tests/empty.fth @@ -0,0 +1,627 @@ + +\ *** Block No. 0, Hexblock 0 + + + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + + + + + + + + + + + + + + + + + + +\ *** Block No. 2, Hexblock 2 + + + + + + + + + + + + + + + + + + +\ *** Block No. 3, Hexblock 3 + + + + + + + + + + + + + + + + + + +\ *** Block No. 4, Hexblock 4 + + + + + + + + + + + + + + + + + + +\ *** Block No. 5, Hexblock 5 + + + + + + + + + + + + + + + + + + +\ *** Block No. 6, Hexblock 6 + + + + + + + + + + + + + + + + + + +\ *** Block No. 7, Hexblock 7 + + + + + + + + + + + + + + + + + + +\ *** Block No. 8, Hexblock 8 + + + + + + + + + + + + + + + + + + +\ *** Block No. 9, Hexblock 9 + + + + + + + + + + + + + + + + + + +\ *** Block No. 10, Hexblock a + + + + + + + + + + + + + + + + + + +\ *** Block No. 11, Hexblock b + + + + + + + + + + + + + + + + + + +\ *** Block No. 12, Hexblock c + + + + + + + + + + + + + + + + + + +\ *** Block No. 13, Hexblock d + + + + + + + + + + + + + + + + + + +\ *** Block No. 14, Hexblock e + + + + + + + + + + + + + + + + + + +\ *** Block No. 15, Hexblock f + + + + + + + + + + + + + + + + + + +\ *** Block No. 16, Hexblock 10 + + + + + + + + + + + + + + + + + + +\ *** Block No. 17, Hexblock 11 + + + + + + + + + + + + + + + + + + +\ *** Block No. 18, Hexblock 12 + + + + + + + + + + + + + + + + + + +\ *** Block No. 19, Hexblock 13 + + + + + + + + + + + + + + + + + + +\ *** Block No. 20, Hexblock 14 + + + + + + + + + + + + + + + + + + +\ *** Block No. 21, Hexblock 15 + + + + + + + + + + + + + + + + + + +\ *** Block No. 22, Hexblock 16 + + + + + + + + + + + + + + + + + + +\ *** Block No. 23, Hexblock 17 + + + + + + + + + + + + + + + + + + +\ *** Block No. 24, Hexblock 18 + + + + + + + + + + + + + + + + + + +\ *** Block No. 25, Hexblock 19 + + + + + + + + + + + + + + + + + + +\ *** Block No. 26, Hexblock 1a + + + + + + + + + + + + + + + + + + +\ *** Block No. 27, Hexblock 1b + + + + + + + + + + + + + + + + + + +\ *** Block No. 28, Hexblock 1c + + + + + + + + + + + + + + + + + + +\ *** Block No. 29, Hexblock 1d + + + + + + + + + + + + + + + + + + +\ *** Block No. 30, Hexblock 1e + + + + + + + + + + + + + + + + + + +\ *** Block No. 31, Hexblock 1f + + + + + + + + + + + + + + + + + + +\ *** Block No. 32, Hexblock 20 + + + + + + + + + + + + + + + + + diff --git a/8080/CPM/tests/errorrep.fth b/8080/CPM/tests/errorrep.fth new file mode 100644 index 0000000..24e7bd1 --- /dev/null +++ b/8080/CPM/tests/errorrep.fth @@ -0,0 +1,88 @@ +\ To collect and report on the number of errors resulting from running the +\ ANS Forth and Forth 2012 test programs + +\ This program was written by Gerry Jackson in 2015, 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. + +\ ------------------------------------------------------------------------------ +\ This file is INCLUDED after Core tests are complete and only uses Core words +\ already tested. The purpose of this file is to count errors in test results +\ and present them as a summary at the end of the tests. + +DECIMAL + +VARIABLE TOTAL-ERRORS + +: ERROR-COUNT ( "name" n1 -- n2 ) \ n2 = n1 + 1cell + CREATE DUP , CELL+ + DOES> ( -- offset ) @ \ offset in address units +; + +0 \ Offset into ERRORS[] array +ERROR-COUNT CORE-ERRORS ERROR-COUNT CORE-EXT-ERRORS +ERROR-COUNT DOUBLE-ERRORS ERROR-COUNT EXCEPTION-ERRORS +ERROR-COUNT FACILITY-ERRORS ERROR-COUNT FILE-ERRORS +ERROR-COUNT LOCALS-ERRORS ERROR-COUNT MEMORY-ERRORS +ERROR-COUNT SEARCHORDER-ERRORS ERROR-COUNT STRING-ERRORS +ERROR-COUNT TOOLS-ERRORS ERROR-COUNT BLOCK-ERRORS +CREATE ERRORS[] DUP ALLOT CONSTANT #ERROR-COUNTS + +\ SET-ERROR-COUNT called at the end of each test file with its own offset into +\ the ERRORS[] array. #ERRORS is in files tester.fr and ttester.fs + +: SET-ERROR-COUNT ( offset -- ) + #ERRORS @ SWAP ERRORS[] + ! + #ERRORS @ TOTAL-ERRORS +! + 0 #ERRORS ! +; + +: INIT-ERRORS ( -- ) + ERRORS[] #ERROR-COUNTS OVER + SWAP DO -1 I ! 1 CELLS +LOOP + 0 TOTAL-ERRORS ! + CORE-ERRORS SET-ERROR-COUNT +; + +INIT-ERRORS + +\ Report summary of errors + +25 CONSTANT MARGIN + +: SHOW-ERROR-LINE ( n caddr u -- ) + CR SWAP OVER TYPE MARGIN - ABS >R + DUP -1 = IF DROP R> 1- SPACES ." -" ELSE + R> .R THEN +; + +: SHOW-ERROR-COUNT ( caddr u offset -- ) + ERRORS[] + @ ROT ROT SHOW-ERROR-LINE +; + +: HLINE ( -- ) CR ." ---------------------------" ; + +: REPORT-ERRORS + HLINE + CR 8 SPACES ." Error Report" + CR ." Word Set" 13 SPACES ." Errors" + HLINE + S" Core" CORE-ERRORS SHOW-ERROR-COUNT + S" Core extension" CORE-EXT-ERRORS SHOW-ERROR-COUNT + S" Block" BLOCK-ERRORS SHOW-ERROR-COUNT + S" Double number" DOUBLE-ERRORS SHOW-ERROR-COUNT + S" Exception" EXCEPTION-ERRORS SHOW-ERROR-COUNT + S" Facility" FACILITY-ERRORS SHOW-ERROR-COUNT + S" File-access" FILE-ERRORS SHOW-ERROR-COUNT + S" Locals" LOCALS-ERRORS SHOW-ERROR-COUNT + S" Memory-allocation" MEMORY-ERRORS SHOW-ERROR-COUNT + S" Programming-tools" TOOLS-ERRORS SHOW-ERROR-COUNT + S" Search-order" SEARCHORDER-ERRORS SHOW-ERROR-COUNT + S" String" STRING-ERRORS SHOW-ERROR-COUNT + HLINE + TOTAL-ERRORS @ S" Total" SHOW-ERROR-LINE + HLINE CR CR +; diff --git a/8080/CPM/tests/golden/block.golden b/8080/CPM/tests/golden/block.golden new file mode 100644 index 0000000..d241942 --- /dev/null +++ b/8080/CPM/tests/golden/block.golden @@ -0,0 +1,89 @@ + FLUSH exists +BLOCK.FTH **=== NOT TESTED === ******* Scr 21 Dr 5 EMPTY.FB + 0 Should show a (mostly) blank screen + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 + Scr 20 Dr 5 EMPTY.FB + 0 List of the First test block + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 + Scr 29 Dr 5 EMPTY.FB + 0 List of the Last test block + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 + Scr 25 Dr 5 EMPTY.FB + 0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 End of Screen + Scr 21 Dr 5 EMPTY.FB + 0 Should show another (mostly) blank screen + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 +10 +11 +12 +13 +14 +15 +*** | exists Given Characters per Line: 64 +* +End of Block word tests diff --git a/8080/CPM/tests/golden/coreext.golden b/8080/CPM/tests/golden/coreext.golden index 4b81e2d..929c241 100644 --- a/8080/CPM/tests/golden/coreext.golden +++ b/8080/CPM/tests/golden/coreext.golden @@ -1,17 +1,17 @@ -UTIL.FTH ?DEFTEST1 exists +UTIL.FTH ?DEFTEST1 exists Test utilities loaded -ERRORREP.FTH +ERRORREP.FTH COREEXT.FTH ************** Output from .( -You should see -9876: -9876 +You should see -9876: -9876 and again: -9876 On the next 2 lines you should see First then Second messages: -First message via .( +First message via .( Second message via ." * @@ -19,33 +19,33 @@ Second message via ." Output from .R and U.R You should see lines duplicated: indented by 0 spaces +30278 30278 -30278 --31871 +-31871 -31871 +30278 30278 -30278 -33665 +33665 33665 indented by 0 spaces +30278 30278 -30278 --31871 +-31871 -31871 +30278 30278 -30278 -33665 +33665 33665 indented by 5 spaces + 30278 30278 - 30278 - -31871 + -31871 -31871 + 30278 30278 - 30278 - 33665 + 33665 33665 *** diff --git a/8080/CPM/tests/golden/coreplus.golden b/8080/CPM/tests/golden/coreplus.golden index 0c3fde5..d70ee3a 100644 --- a/8080/CPM/tests/golden/coreplus.golden +++ b/8080/CPM/tests/golden/coreplus.golden @@ -1,4 +1,3 @@ - COREPLUS.FTH ******** You should see 2345: 2345 ***** diff --git a/8080/CPM/tests/golden/report-blk.golden b/8080/CPM/tests/golden/report-blk.golden new file mode 100644 index 0000000..80361e9 --- /dev/null +++ b/8080/CPM/tests/golden/report-blk.golden @@ -0,0 +1,21 @@ + +--------------------------- + Error Report +Word Set Errors +--------------------------- +Core 0 +Core extension 0 +Block 0 +Double number 0 +Exception - +Facility - +File-access - +Locals - +Memory-allocation - +Programming-tools - +Search-order - +String - +--------------------------- +Total 0 +--------------------------- + diff --git a/8080/CPM/tests/golden/report-noblk.golden b/8080/CPM/tests/golden/report-noblk.golden new file mode 100644 index 0000000..e1a8782 --- /dev/null +++ b/8080/CPM/tests/golden/report-noblk.golden @@ -0,0 +1,22 @@ + +--------------------------- + Error Report +Word Set Errors +--------------------------- +Core 0 +Core extension 0 +Block - +Double number 0 +Exception - +Facility - +File-access - +Locals - +Memory-allocation - +Programming-tools - +Search-order - +String - +--------------------------- +Total 0 +--------------------------- + + diff --git a/8080/CPM/tests/test-blk.fth b/8080/CPM/tests/test-blk.fth new file mode 100644 index 0000000..76840f0 --- /dev/null +++ b/8080/CPM/tests/test-blk.fth @@ -0,0 +1,26 @@ + +include log2file.fth +logopen output.log + +include ans-shim.fth +: \vf [compile] \ ; immediate + +include prelim.fth +include tester.fth +\ 1 verbose ! +include core.fr +include coreplus.fth + +include util.fth +include errorrep.fth + +include coreext.fth +include doubltst.fth + +: flush logclose flush logreopen ; +include block.fth + +REPORT-ERRORS + +logclose + diff --git a/8080/CPM/tests/test-std.fth b/8080/CPM/tests/test-std.fth new file mode 100644 index 0000000..dd1818a --- /dev/null +++ b/8080/CPM/tests/test-std.fth @@ -0,0 +1,29 @@ + +\ : .blk|tib +\ blk @ ?dup IF ." Blk " u. ?cr exit THEN +\ incfile @ IF tib #tib @ cr type THEN ; + +include log2file.fb +logopen + +include ans-shim.fth +: \vf [compile] \ ; immediate + +include prelim.fth +include tester.fth +\ 1 verbose ! +include core.fr +include coreplus.fth + +include util.fth +include errorrep.fth + +include coreext.fth + +\ ' .blk|tib Is .status + +include doubltst.fth + +REPORT-ERRORS + +logclose diff --git a/8080/CPM/tests/util.fth b/8080/CPM/tests/util.fth new file mode 100644 index 0000000..b224c79 --- /dev/null +++ b/8080/CPM/tests/util.fth @@ -0,0 +1,143 @@ +( The ANS/Forth 2012 test suite is being modified so that the test programs ) +( for the optional word sets only use standard words from the Core word set. ) +( This file, which is included *after* the Core test programs, contains ) +( various definitions for use by the optional word set test programs to ) +( remove any dependencies between word sets. ) + +DECIMAL + +( First a definition to see if a word is already defined. Note that ) +( [DEFINED] [IF] [ELSE] and [THEN] are in the optional Programming Tools ) +( word set. ) + +VARIABLE (\?) 0 (\?) ! ( Flag: Word defined = 0 | word undefined = -1 ) + +( [?DEF] followed by [?IF] cannot be used again until after [THEN] ) +: [?DEF] ( "name" -- ) + BL WORD FIND SWAP DROP 0= (\?) ! +; + +\ Test [?DEF] +T{ 0 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> -1 }T +: ?DEFTEST1 1 ; +T{ -1 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> 0 }T + +: [?UNDEF] [?DEF] (\?) @ 0= (\?) ! ; + +\ Equivalents of [IF] [ELSE] [THEN], these must not be nested +: [?IF] ( f -- ) (\?) ! ; IMMEDIATE +: [?ELSE] ( -- ) (\?) @ 0= (\?) ! ; IMMEDIATE +: [?THEN] ( -- ) 0 (\?) ! ; IMMEDIATE + +( A conditional comment and \ will be defined. Note that these definitions ) +( are inadequate for use in Forth blocks. If needed in the blocks test ) +( program they will need to be modified here or redefined there ) + +( \? is a conditional comment ) +: \? ( "..." -- ) (\?) @ IF EXIT THEN SOURCE >IN ! DROP ; IMMEDIATE + +\ Test \? +T{ [?DEF] ?DEFTEST1 \? : ?DEFTEST1 2 ; \ Should not be redefined + ?DEFTEST1 -> 1 }T +T{ [?DEF] ?DEFTEST2 \? : ?DEFTEST1 2 ; \ Should be redefined + ?DEFTEST1 -> 2 }T + +[?DEF] TRUE \? -1 CONSTANT TRUE +[?DEF] FALSE \? 0 CONSTANT FALSE +[?DEF] NIP \? : NIP SWAP DROP ; +[?DEF] TUCK \? : TUCK SWAP OVER ; + +[?DEF] PARSE +\? : BUMP ( caddr u n -- caddr+n u-n ) +\? TUCK - >R CHARS + R> +\? ; + +\? : PARSE ( ch "ccc" -- caddr u ) +\? >R SOURCE >IN @ BUMP +\? OVER R> SWAP >R >R ( -- start u1 ) ( R: -- start ch ) +\? BEGIN +\? DUP +\? WHILE +\? OVER C@ R@ = 0= +\? WHILE +\? 1 BUMP +\? REPEAT +\? 1- ( end u2 ) \ delimiter found +\? THEN +\? SOURCE NIP SWAP - >IN ! ( -- end ) +\? R> DROP R> ( -- end start ) +\? TUCK - 1 CHARS / ( -- start u ) +\? ; + +[?DEF] .( \? : .( [CHAR] ) PARSE TYPE ; IMMEDIATE + +\ S= to compare (case sensitive) two strings to avoid use of COMPARE from +\ the String word set. It is defined in core.fr and conditionally defined +\ here if core.fr has not been included by the user + +[?DEF] S= +\? : S= ( caddr1 u1 caddr2 u2 -- f ) \ f = TRUE if strings are equal +\? ROT OVER = 0= IF DROP 2DROP FALSE EXIT THEN +\? DUP 0= IF DROP 2DROP TRUE EXIT THEN +\? 0 DO +\? OVER C@ OVER C@ = 0= IF 2DROP FALSE UNLOOP EXIT THEN +\? CHAR+ SWAP CHAR+ +\? LOOP 2DROP TRUE +\? ; + +\ Buffer for strings in interpretive mode since S" only valid in compilation +\ mode when File-Access word set is defined + +64 CONSTANT SBUF-SIZE +CREATE SBUF1 SBUF-SIZE CHARS ALLOT +CREATE SBUF2 SBUF-SIZE CHARS ALLOT + +\ ($") saves a counted string at (caddr) +: ($") ( caddr "ccc" -- caddr' u ) + [CHAR] " PARSE ROT 2DUP C! ( -- ca2 u2 ca) + CHAR+ SWAP 2DUP 2>R CHARS MOVE ( -- ) ( R: -- ca' u2 ) + 2R> +; + +: $" ( "ccc" -- caddr u ) SBUF1 ($") ; +: $2" ( "ccc" -- caddr u ) SBUF2 ($") ; +: $CLEAR ( caddr -- ) SBUF-SIZE BL FILL ; +: CLEAR-SBUFS ( -- ) SBUF1 $CLEAR SBUF2 $CLEAR ; + +\ More definitions in core.fr used in other test programs, conditionally +\ defined here if core.fr has not been loaded + +[?DEF] MAX-UINT \? 0 INVERT CONSTANT MAX-UINT +[?DEF] MAX-INT \? 0 INVERT 1 RSHIFT CONSTANT MAX-INT +[?DEF] MIN-INT \? 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +[?DEF] MID-UINT \? 0 INVERT 1 RSHIFT CONSTANT MID-UINT +[?DEF] MID-UINT+1 \? 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +[?DEF] 2CONSTANT \? : 2CONSTANT CREATE , , DOES> 2@ ; + +BASE @ 2 BASE ! -1 0 <# #S #> SWAP DROP CONSTANT BITS/CELL BASE ! + + +\ ------------------------------------------------------------------------------ +\ Tests + +: STR1 S" abcd" ; : STR2 S" abcde" ; +: STR3 S" abCd" ; : STR4 S" wbcd" ; +: S"" S" " ; + +T{ STR1 2DUP S= -> TRUE }T +T{ STR2 2DUP S= -> TRUE }T +T{ S"" 2DUP S= -> TRUE }T +T{ STR1 STR2 S= -> FALSE }T +T{ STR1 STR3 S= -> FALSE }T +T{ STR1 STR4 S= -> FALSE }T + +T{ CLEAR-SBUFS -> }T +T{ $" abcdefghijklm" SBUF1 COUNT S= -> TRUE }T +T{ $" nopqrstuvwxyz" SBUF2 OVER S= -> FALSE }T +T{ $2" abcdefghijklm" SBUF1 COUNT S= -> FALSE }T +T{ $2" nopqrstuvwxyz" SBUF1 COUNT S= -> TRUE }T + +\ ------------------------------------------------------------------------------ + +CR $" Test utilities loaded" TYPE CR