mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-21 14:31:21 +00:00
Copy the main test files over from msdos-vf and make test-std pass.
This commit is contained in:
Philip Zembrod
parent
aef07d62f9
commit
bb041ce5dd
@ -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
|
||||
|
||||
File diff suppressed because one or more lines are too long
@ -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
|
||||
|
||||
|
||||
679
8080/CPM/tests/block.fth
Normal file
679
8080/CPM/tests/block.fth
Normal file
@ -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 ( "<char>" -- ) \ Use between <# and #>
|
||||
CHAR HOLD ; IMMEDIATE
|
||||
|
||||
: ?EXECUTE ( xt f -- )
|
||||
IF EXECUTE ELSE DROP THEN ;
|
||||
|
||||
\ SAVE-INPUT and RESTORE-INPUT within a single block
|
||||
\vf : TCSIRIR2-EXPECTED S" EDCBCBA" ; \ Remember that the string comes out backwards
|
||||
\vf : TCSIRIR2 ( blk -- )
|
||||
\vf C/L 1024 U< IF
|
||||
\vf BLANK-BUFFER
|
||||
\vf S" 0 T-CNT !" WRITE-BLOCK-LINE
|
||||
\vf S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE
|
||||
\vf S" 1 T-CNT +! MARK C ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK D" WRITE-BLOCK-LINE
|
||||
\vf S" MARK E 0 0 #>" WRITE-BLOCK-LINE
|
||||
\vf UPDATE SAVE-BUFFERS DROP
|
||||
\vf ELSE
|
||||
\vf S" 0 TCSIRIR2-EXPECTED" WRITE-BLOCK
|
||||
\vf THEN ;
|
||||
\vf T{ RND-TEST-BLOCK DUP TCSIRIR2 LOAD TCSIRIR2-EXPECTED S= -> 0 TRUE }T
|
||||
|
||||
\ REFILL across 2 blocks
|
||||
\vf : TCSIRIR3 ( blks -- )
|
||||
\vf DUP S" 1 2 3 REFILL 4 5 6" WRITE-BLOCK
|
||||
\vf 1+ S" 10 11 12" WRITE-BLOCK ;
|
||||
\vf T{ 2 RND-TEST-BLOCK-SEQ DUP TCSIRIR3 LOAD -> 1 2 3 -1 10 11 12 }T
|
||||
|
||||
\ SAVE-INPUT and RESTORE-INPUT across 2 blocks
|
||||
\vf : TCSIRIR4-EXPECTED S" HGF1ECBF1ECBA" ; \ Remember that the string comes out backwards
|
||||
\vf : TCSIRIR4 ( blks -- )
|
||||
\vf C/L 1024 U< IF
|
||||
\vf DUP BLANK-BUFFER
|
||||
\vf S" 0 T-CNT !" WRITE-BLOCK-LINE
|
||||
\vf S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE
|
||||
\vf S" MARK C REFILL MARK D" WRITE-BLOCK-LINE
|
||||
\vf DROP UPDATE 1+ BLANK-BUFFER
|
||||
\vf S" MARK E ABS CHAR 0 + HOLD" WRITE-BLOCK-LINE
|
||||
\vf S" 1 T-CNT +! MARK F ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK G" WRITE-BLOCK-LINE
|
||||
\vf S" MARK H 0 0 #>" WRITE-BLOCK-LINE
|
||||
\vf DROP UPDATE SAVE-BUFFERS
|
||||
\vf ELSE
|
||||
\vf S" 0 TCSIRIR4-EXPECTED" WRITE-BLOCK
|
||||
\vf THEN ;
|
||||
\vf T{ 2 RND-TEST-BLOCK-SEQ DUP TCSIRIR4 LOAD TCSIRIR4-EXPECTED S= -> 0 TRUE }T
|
||||
|
||||
\ ------------------------------------------------------------------------------
|
||||
TESTING THRU
|
||||
|
||||
: TT1 ( blks -- )
|
||||
DUP S" BLK" WRITE-BLOCK
|
||||
1+ S" @" WRITE-BLOCK ;
|
||||
T{ 2 RND-TEST-BLOCK-SEQ DUP TT1 DUP DUP 1+ THRU 1- = -> TRUE }T
|
||||
|
||||
\ ------------------------------------------------------------------------------
|
||||
|
||||
BLOCK-ERRORS SET-ERROR-COUNT
|
||||
|
||||
CR .( End of Block word tests) CR
|
||||
769
8080/CPM/tests/coreext.fth
Normal file
769
8080/CPM/tests/coreext.fth
Normal file
@ -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 <FALSE> and <TRUE> 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
|
||||
|
||||
|
||||
306
8080/CPM/tests/coreplus.fth
Normal file
306
8080/CPM/tests/coreplus.fth
Normal file
@ -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 <TRUE> 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 @ = -> <TRUE> }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 @ = -> <TRUE> }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 -> <TRUE> }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 = -> <TRUE> }T
|
||||
T{ HERE 0 ALLOT HERE = -> <TRUE> }T
|
||||
|
||||
\ ------------------------------------------------------------------------------
|
||||
|
||||
CR .( End of additional Core tests) CR
|
||||
438
8080/CPM/tests/doubltst.fth
Normal file
438
8080/CPM/tests/doubltst.fth
Normal file
@ -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. <TRUE> and <FALSE> 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 @ = -> <TRUE> }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 @ = -> <TRUE> }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
|
||||
|
||||
1
8080/CPM/tests/empty.fb
Normal file
1
8080/CPM/tests/empty.fb
Normal file
File diff suppressed because one or more lines are too long
627
8080/CPM/tests/empty.fth
Normal file
627
8080/CPM/tests/empty.fth
Normal file
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
88
8080/CPM/tests/errorrep.fth
Normal file
88
8080/CPM/tests/errorrep.fth
Normal file
@ -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
|
||||
;
|
||||
89
8080/CPM/tests/golden/block.golden
Normal file
89
8080/CPM/tests/golden/block.golden
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
***
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
|
||||
COREPLUS.FTH ********
|
||||
You should see 2345: 2345
|
||||
*****
|
||||
|
||||
21
8080/CPM/tests/golden/report-blk.golden
Normal file
21
8080/CPM/tests/golden/report-blk.golden
Normal file
@ -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
|
||||
---------------------------
|
||||
|
||||
22
8080/CPM/tests/golden/report-noblk.golden
Normal file
22
8080/CPM/tests/golden/report-noblk.golden
Normal file
@ -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
|
||||
---------------------------
|
||||
|
||||
|
||||
26
8080/CPM/tests/test-blk.fth
Normal file
26
8080/CPM/tests/test-blk.fth
Normal file
@ -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
|
||||
|
||||
29
8080/CPM/tests/test-std.fth
Normal file
29
8080/CPM/tests/test-std.fth
Normal file
@ -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
|
||||
143
8080/CPM/tests/util.fth
Normal file
143
8080/CPM/tests/util.fth
Normal file
@ -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<ch>" -- 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
|
||||
Loading…
Reference in New Issue
Block a user