6502/VolksForth
1
0
Fork 0
mirror of https://github.com/forth-ev/VolksForth.git synced 2024-05-31 15:41:34 +00:00
Code Issues Projects Releases Wiki Activity

Copying over the Hayes tester tests from C64 to msdos VolksForth.

Browse Source 
Names are adapted to DOS 8.3 file names, PETSCII adaptions of core.fth
are reverted (DOS uses ASCII), the input test is disabled, since no
way was yet found to inject keystrokes into dosbox. And some tweaks
were applied to ans-shim.fth and the golden files to make the first
tests (preliminary & core) to pass.
This commit is contained in:
Philip Zembrod 2022-01-16 21:16:48 +01:00
parent fe2d6e25d1
commit 9a568b3a03
27 changed files with 4251 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
8086/msdos/Makefile
View File

@ -6,7 +6,7 @@ fbfiles_uppercase = $(wildcard src/*.FB tests/*.FB)
fthfiles_caseconverted = $(patsubst %.fb, %.fth, \
$(shell ../../tools/echo-tolower.py $(fbfiles_uppercase)))
test: incltest.result logtest.result
test: incltest.result logtest.result test-min.result
fth: $(fthfiles) $(fthfiles_caseconverted)
@ -20,18 +20,29 @@ v4thfile.com: volks4th.com src/include.fb src/v4thfile.fb \
./emulator/run-in-dosbox.sh volks4th.com v4thfile.fb
mv V4THFILE.COM v4thfile.com
incltest.log: v4thfile.com tests/log2file.fb tests/incltest.fth \
emulator/run-in-dosbox.sh
./emulator/run-in-dosbox.sh v4thfile.com incltest.fth
incltest.golden: tests/golden/incltest.golden
cp -p $< $@
logtest.log: volks4th.com tests/log2file.fb tests/logtest.fb \
emulator/run-in-dosbox.sh
./emulator/run-in-dosbox.sh volks4th.com logtest.fb
logtest.golden: tests/golden/logtest.golden
incltest.log: v4thfile.com tests/log2file.fb tests/incltest.fth \
emulator/run-in-dosbox.sh
./emulator/run-in-dosbox.sh v4thfile.com incltest.fth
test-min.log: v4thfile.com tests/* emulator/run-in-dosbox.sh
rm -f TEST.LOG
./emulator/run-in-dosbox.sh v4thfile.com test-min.fth
mv TEST.LOG $@
test-min.golden: $(patsubst %, tests/golden/%.golden, prelim core)
cat $? > $@
test-std.golden: $(patsubst %, tests/golden/%.golden, \
prelim core coreext double report-noblk)
cat $? > $@
%.golden: tests/golden/%.golden
cp -p $< $@
%.result: %.log %.golden tests/evaluate-test.sh

1
8086/msdos/emulator/run-in-dosbox.sh
View File

@ -1,7 +1,6 @@
#!/bin/bash
set -e
set -x
emulatordir="$(realpath --relative-to="$PWD" "$(dirname "${BASH_SOURCE[0]}")")"
basedir="$(realpath --relative-to="$PWD" "${emulatordir}/..")"

2
8086/msdos/src/include.fb
View File

File diff suppressed because one or more lines are too long

2
8086/msdos/src/include.fth
View File

@ -103,7 +103,7 @@
r> UNTIL ;
: include ( -- )
pushfile use file? cr
pushfile use cr file?
probe-for-fb isfile@ freset IF 1 load close exit THEN
savetib >r interpret-via-tib close r> restoretib ;

101
8086/msdos/tests/ans-shim.fth Normal file
View File

@ -0,0 +1,101 @@
: cells 2* ;
: s" [compile] " compile count ; immediate restrict
: c" [compile] " ; immediate restrict
: [char] [compile] ascii ; immediate
: char [compile] ascii ;
: invert not ;
: lshift 0 ?DO 2* LOOP ;
: rshift 0 ?DO 2/ 32767 and LOOP ;
\ : 2over 3 pick 3 pick ;
: s>d extend ;
: fm/mod m/mod ;
: sm/rem dup >r 2dup xor >r m/mod
over IF r> 0< IF 1+ swap r> - swap ELSE rdrop THEN
ELSE rdrop rdrop THEN ;
: postpone ' dup >name c@ $40 and
IF , ELSE [compile] compile compile , THEN ; immediate
\ : align ;
: aligned ;
: cell+ 2+ ;
: char+ 1+ ;
: chars ;
\ : 2@ dup 2+ @ swap @ ;
\ : 2! under ! 2+ ! ;
: recurse last @ name> , ; immediate
' endloop alias unloop
: >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
BEGIN dup 0= IF exit THEN
>r count digit? WHILE accumulate r> 1- REPEAT 1- r> ;
: accept expect span @ ;
: tuck under ;
: :noname here ['] tuck @ , 0 ] ;
: <> = not ;
: 2>r r> -rot swap >r >r >r ;
: 2r> r> r> r> swap rot >r ;
: 2r@ r> r> r> 2dup >r >r swap rot >r ;
: WITHIN ( test low high -- flag ) OVER - >R - R> U< ;
: unused sp@ here - ;
: again [compile] repeat ; immediate restrict
: BUFFER: CREATE ALLOT ;
: compile, , ;
: defer! >body ! ;
: defer@ >body @ ;
: action-of
STATE @ IF
POSTPONE ['] POSTPONE DEFER@
ELSE
' DEFER@
THEN ; IMMEDIATE
: HOLDS ( addr u -- )
BEGIN DUP WHILE 1- 2DUP + C@ HOLD REPEAT 2DROP ;
: 2Variable ( --) Create 4 allot ;
( -- adr)
: 2Constant ( d --) Create , ,
Does> ( -- d) 2@ ;
: 2literal swap [compile] literal [compile] literal ;
immediate restrict
: d- dnegate d+ ;
: d0< 0. d< ;
: d2* 2dup d+ ;
: d2/ dup 1 and -rot 2/ >r
1 rshift swap IF $8000 or THEN r> ;
: dmax 2over 2over d< IF 2swap THEN 2drop ;
: dmin 2over 2over 2swap d< IF 2swap THEN 2drop ;
: d>s drop ;
: m+ extend d+ ;
: 2rot 5 roll 5 roll ;

676
8086/msdos/tests/block.fth Normal file
View File

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

1010
8086/msdos/tests/core.fr Normal file
View File

File diff suppressed because it is too large Load Diff

35
8086/msdos/tests/coreacpt.fth Normal file
View File

@ -0,0 +1,35 @@
\ From: John Hayes S1I
\ Subject: core.fr
\ Date: Mon, 27 Nov 95 13:10
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
\ VERSION 1.2
\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
CR
TESTING CORE WORDS
HEX
\ ------------------------------------------------------------------------
TESTING INPUT: ACCEPT
CREATE ABUF 50 CHARS ALLOT
: ACCEPT-TEST
CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
ABUF 50 ACCEPT
CR ." RECEIVED: " [CHAR] " EMIT
ABUF SWAP TYPE [CHAR] " EMIT CR
;
T{ ACCEPT-TEST -> }T
CR .( End of Core input word set tests) CR

769
8086/msdos/tests/coreext.fth Normal file
View 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
8086/msdos/tests/coreplus.fth Normal file
View 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
8086/msdos/tests/double.fth Normal file
View 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

88
8086/msdos/tests/errorrep.fth Normal file
View 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
;

134
8086/msdos/tests/golden/block.golden Normal file
View File

@ -0,0 +1,134 @@
blocktest.fth**=== NOT TESTED === *******Scr 21 Dr 1
0 Should show a (mostly) blank screen
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Scr 20 Dr 1
0 List of the First test block
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Scr 29 Dr 1
0 List of the Last test block
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Scr 25 Dr 1
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24 End of Screen
Scr 21 Dr 1
0 Should show another (mostly) blank scree
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
*** | exists Given Characters per Line: 41
*
End of Block word tests

23
8086/msdos/tests/golden/core.golden Normal file
View File

@ -0,0 +1,23 @@
TESTER.FTH ERROR exists
CORE.FR
*********************YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:
!"#$%&'()*+,-./0123456789:;<=>?@
ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`
abcdefghijklmnopqrstuvwxyz{|}~
YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:
0 1 2 3 4 5 6 7 8 9
YOU SHOULD SEE 0-9 (WITH NO SPACES):
0123456789
YOU SHOULD SEE A-G SEPARATED BY A SPACE:
A B C D E F G
YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:
0 1 2 3 4 5
YOU SHOULD SEE TWO SEPARATE LINES:
LINE 1
LINE 2
YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:
SIGNED: -8000 7FFF
UNSIGNED: 0 FFFF
** GDX exists
End of Core word set tests

52
8086/msdos/tests/golden/coreext.golden Normal file
View File

@ -0,0 +1,52 @@
utilities.fth ?DEFTEST1 exists
Test utilities loaded
errorreport.fth
coreexttest.fth**************
Output from .(
You should see -9876: -9876
and again: -9876
On the next 2 lines you should see First then Second messages:
First message via .(
Second message via ."
*
Output from .R and U.R
You should see lines duplicated:
indented by 0 spaces
30278
30278
-31871
-31871
30278
30278
33665
33665
indented by 0 spaces
30278
30278
-31871
-31871
30278
30278
33665
33665
indented by 5 spaces
30278
30278
-31871
-31871
30278
30278
33665
33665
***
End of Core Extension word tests

5
8086/msdos/tests/golden/coreplus.golden Normal file
View File

@ -0,0 +1,5 @@
COREPLUS.FTH********
You should see 2345: 2345
*****
End of additional Core tests

3
8086/msdos/tests/golden/double.golden Normal file
View File

@ -0,0 +1,3 @@
doubletest.fth*****************
End of Double-Number word tests

41
8086/msdos/tests/golden/prelim.golden Normal file
View File

@ -0,0 +1,41 @@
ANS-SHIM.FTH
PRELIM.FTH
CR CR SOURCE TYPE ( Preliminary test ) CR
SOURCE ( These lines test SOURCE, TYPE, CR and parenthetic comments ) TYPE CR
( The next line of output should be blank to test CR ) SOURCE TYPE CR CR
( Pass #1: testing 0 >IN +! ) 0 >IN +! SOURCE TYPE CR
( Pass #2: testing 1 >IN +! ) 1 >IN +! xSOURCE TYPE CR
( Pass #3: testing 1+ ) 1 1+ >IN +! xxSOURCE TYPE CR
( Pass #4: testing @ ! BASE ) 0 1+ 1+ BASE ! BASE @ >IN +! xxSOURCE TYPE CR
( Pass #5: testing decimal BASE ) BASE @ >IN +! xxxxxxxxxxSOURCE TYPE CR
( Pass #6: testing : ; ) : .SRC SOURCE TYPE CR ; 6 >IN +! xxxxxx.SRC
( Pass #7: testing number input ) 19 >IN +! xxxxxxxxxxxxxxxxxxx.SRC
( Pass #8: testing VARIABLE ) VARIABLE Y 2 Y ! Y @ >IN +! xx.SRC
( Pass #9: testing WORD COUNT ) 5 MSG abcdef) Y ! Y ! >IN +! xxxxx.SRC
( Pass #10: testing WORD COUNT ) MSG ab) >IN +! xxY ! .SRC
Pass #11: testing WORD COUNT .MSG
Pass #12: testing = returns all 1's for true
Pass #13: testing = returns 0 for false
Pass #14: testing -1 interpreted correctly
Pass #15: testing 2*
Pass #16: testing 2*
Pass #17: testing AND
Pass #18: testing AND
Pass #19: testing AND
PASS exists Pass #20: testing ?F~ ?~~ Pass Error
Pass #21: testing ?~
Pass #22: testing EMIT
Pass #23: testing S"
Results:
Pass messages #1 to #23 should be displayed above
and no error messages
0 tests failed out of 57 additional tests
--- End of Preliminary Tests ---

21
8086/msdos/tests/golden/report-blk.golden Normal file
View 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
---------------------------

21
8086/msdos/tests/golden/report-noblk.golden Normal file
View File

@ -0,0 +1,21 @@
---------------------------
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
---------------------------

233
8086/msdos/tests/prelim.fth Normal file
View File

@ -0,0 +1,233 @@
CR CR SOURCE TYPE ( Preliminary test ) CR
SOURCE ( These lines test SOURCE, TYPE, CR and parenthetic comments ) TYPE CR
( The next line of output should be blank to test CR ) SOURCE TYPE CR CR
( It is now assumed that SOURCE, TYPE, CR and comments work. SOURCE and )
( TYPE will be used to report test passes until something better can be )
( defined to report errors. Until then reporting failures will depend on the )
( system under test and will usually be via reporting an unrecognised word )
( or possibly the system crashing. Tests will be numbered by #n from now on )
( to assist fault finding. Test successes will be indicated by )
( 'Pass: #n ...' and failures by 'Error: #n ...' )
( Initial tests of >IN +! and 1+ )
( Check that n >IN +! acts as an interpretive IF, where n >= 0 )
( Pass #1: testing 0 >IN +! ) 0 >IN +! SOURCE TYPE CR
( Pass #2: testing 1 >IN +! ) 1 >IN +! xSOURCE TYPE CR
( Pass #3: testing 1+ ) 1 1+ >IN +! xxSOURCE TYPE CR
( Test results can now be reported using the >IN +! trick to skip )
( 1 or more characters )
( The value of BASE is unknown so it is not safe to use digits > 1, therefore )
( it will be set it to binary and then decimal, this also tests @ and ! )
( Pass #4: testing @ ! BASE ) 0 1+ 1+ BASE ! BASE @ >IN +! xxSOURCE TYPE CR
( Set BASE to decimal ) 1010 BASE !
( Pass #5: testing decimal BASE ) BASE @ >IN +! xxxxxxxxxxSOURCE TYPE CR
( Now in decimal mode and digits >1 can be used )
( A better error reporting word is needed, much like .( which can't )
( be used as it is in the Core Extension word set, similarly PARSE can't be )
( used either, only WORD is available to parse a message and must be used )
( in a colon definition. Therefore a simple colon definition is tested next )
( Pass #6: testing : ; ) : .SRC SOURCE TYPE CR ; 6 >IN +! xxxxxx.SRC
( Pass #7: testing number input ) 19 >IN +! xxxxxxxxxxxxxxxxxxx.SRC
( VARIABLE is now tested as one will be used instead of DROP e.g. Y ! )
( Pass #8: testing VARIABLE ) VARIABLE Y 2 Y ! Y @ >IN +! xx.SRC
: MSG 41 WORD COUNT ; ( 41 is the ASCII code for right parenthesis )
( The next tests MSG leaves 2 items on the data stack )
( Pass #9: testing WORD COUNT ) 5 MSG abcdef) Y ! Y ! >IN +! xxxxx.SRC
( Pass #10: testing WORD COUNT ) MSG ab) >IN +! xxY ! .SRC
( For reporting success .MSG( is now defined )
: .MSG( MSG TYPE ; .MSG( Pass #11: testing WORD COUNT .MSG) CR
( To define an error reporting word, = 2* AND will be needed, test them first )
( This assumes 2's complement arithmetic )
1 1 = 1+ 1+ >IN +! x.MSG( Pass #12: testing = returns all 1's for true) CR
1 0 = 1+ >IN +! x.MSG( Pass #13: testing = returns 0 for false) CR
1 1 = -1 = 1+ 1+ >IN +! x.MSG( Pass #14: testing -1 interpreted correctly) CR
1 2* >IN +! xx.MSG( Pass #15: testing 2*) CR
-1 2* 1+ 1+ 1+ >IN +! x.MSG( Pass #16: testing 2*) CR
-1 -1 AND 1+ 1+ >IN +! x.MSG( Pass #17: testing AND) CR
-1 0 AND 1+ >IN +! x.MSG( Pass #18: testing AND) CR
6 -1 AND >IN +! xxxxxx.MSG( Pass #19: testing AND) CR
( Define ~ to use as a 'to end of line' comment. \ cannot be used as it a )
( Core Extension word )
: ~ ( -- ) SOURCE >IN ! Y ! ;
( Rather than relying on a pass message test words can now be defined to )
( report errors in the event of a failure. For convenience words ?T~ and )
( ?F~ are defined together with a helper ?~~ to test for TRUE and FALSE )
( Usage is: <test> ?T~ Error #n: <message> )
( Success makes >IN index the ~ in ?T~ or ?F~ to skip the error message. )
( Hence it is essential there is only 1 space between ?T~ and Error )
: ?~~ ( -1 | 0 -- ) 2* >IN +! ;
: ?F~ ( f -- ) 0 = ?~~ ;
: ?T~ ( f -- ) -1 = ?~~ ;
( Errors will be counted )
VARIABLE #ERRS 0 #ERRS !
: Error 1 #ERRS +! -6 >IN +! .MSG( CR ;
: Pass -1 #ERRS +! 1 >IN +! Error ; ~ Pass is defined solely to test Error
-1 ?F~ Pass #20: testing ?F~ ?~~ Pass Error
-1 ?T~ Error #1: testing ?T~ ?~~ ~
0 0 = 0= ?F~ Error #2: testing 0=
1 0 = 0= ?T~ Error #3: testing 0=
-1 0 = 0= ?T~ Error #4: testing 0=
0 0 = ?T~ Error #5: testing =
0 1 = ?F~ Error #6: testing =
1 0 = ?F~ Error #7: testing =
-1 1 = ?F~ Error #8: testing =
1 -1 = ?F~ Error #9: testing =
-1 0< ?T~ Error #10: testing 0<
0 0< ?F~ Error #11: testing 0<
1 0< ?F~ Error #12: testing 0<
DEPTH 1+ DEPTH = ?~~ Error #13: testing DEPTH
~ Up to now whether the data stack was empty or not hasn't mattered as
~ long as it didn't overflow. Now it will be emptied - also
~ removing any unreported underflow
DEPTH 0< 0= 1+ >IN +! ~ 0 0 >IN ! Remove any underflow
DEPTH 0= 1+ >IN +! ~ Y ! 0 >IN ! Empty the stack
DEPTH 0= ?T~ Error #14: data stack not emptied
4 -5 SWAP 4 = SWAP -5 = = ?T~ Error #15: testing SWAP
111 222 333 444
DEPTH 4 = ?T~ Error #16: testing DEPTH
444 = SWAP 333 = = DEPTH 3 = = ?T~ Error #17: testing SWAP DEPTH
222 = SWAP 111 = = DEPTH 1 = = ?T~ Error #18: testing SWAP DEPTH
DEPTH 0= ?T~ Error #19: testing DEPTH = 0
~ From now on the stack is expected to be empty after a test so
~ ?~ will be defined to include a check on the stack depth. Note
~ that ?~~ was defined and used earlier instead of ?~ to avoid
~ (irritating) redefinition messages that many systems display had
~ ?~ simply been redefined
: ?~ ( -1 | 0 -- ) DEPTH 1 = AND ?~~ ; ~ -1 test success, 0 test failure
123 -1 ?~ Pass #21: testing ?~
Y ! ~ equivalent to DROP
~ Testing the remaining Core words used in the Hayes tester, with the above
~ definitions these are straightforward
1 DROP DEPTH 0= ?~ Error #20: testing DROP
123 DUP = ?~ Error #21: testing DUP
123 ?DUP = ?~ Error #22: testing ?DUP
0 ?DUP 0= ?~ Error #23: testing ?DUP
123 111 + 234 = ?~ Error #24: testing +
123 -111 + 12 = ?~ Error #25: testing +
-123 111 + -12 = ?~ Error #26: testing +
-123 -111 + -234 = ?~ Error #27: testing +
-1 NEGATE 1 = ?~ Error #28: testing NEGATE
0 NEGATE 0= ?~ Error #29: testing NEGATE
987 NEGATE -987 = ?~ Error #30: testing NEGATE
HERE DEPTH SWAP DROP 1 = ?~ Error #31: testing HERE
CREATE TST1 HERE TST1 = ?~ Error #32: testing CREATE HERE
16 ALLOT HERE TST1 NEGATE + 16 = ?~ Error #33: testing ALLOT
-16 ALLOT HERE TST1 = ?~ Error #34: testing ALLOT
0 CELLS 0= ?~ Error #35: testing CELLS
1 CELLS ALLOT HERE TST1 NEGATE + VARIABLE CSZ CSZ !
CSZ @ 0= 0= ?~ Error #36: testing CELLS
3 CELLS CSZ @ DUP 2* + = ?~ Error #37: testing CELLS
-3 CELLS CSZ @ DUP 2* + + 0= ?~ Error #38: testing CELLS
: TST2 ( f -- n ) DUP IF 1+ THEN ;
0 TST2 0= ?~ Error #39: testing IF THEN
1 TST2 2 = ?~ Error #40: testing IF THEN
: TST3 ( n1 -- n2 ) IF 123 ELSE 234 THEN ;
0 TST3 234 = ?~ Error #41: testing IF ELSE THEN
1 TST3 123 = ?~ Error #42: testing IF ELSE THEN
: TST4 ( -- n ) 0 5 0 DO 1+ LOOP ;
TST4 5 = ?~ Error #43: testing DO LOOP
: TST5 ( -- n ) 0 10 0 DO I + LOOP ;
TST5 45 = ?~ Error #44: testing I
: TST6 ( -- n ) 0 10 0 DO DUP 5 = IF LEAVE ELSE 1+ THEN LOOP ;
TST6 5 = ?~ Error #45: testing LEAVE
: TST7 ( -- n1 n2 ) 123 >R 234 R> ;
TST7 NEGATE + 111 = ?~ Error #46: testing >R R>
: TST8 ( -- ch ) [CHAR] A ;
TST8 65 = ?~ Error #47: testing [CHAR]
: TST9 ( -- ) [CHAR] s [CHAR] s [CHAR] a [CHAR] P 4 0 DO EMIT LOOP ;
TST9 .MSG( #22: testing EMIT) CR
: TST10 ( -- ) S" Pass #23: testing S" TYPE [CHAR] " EMIT CR ; TST10
~ The Hayes core test core.fr uses CONSTANT before it is tested therefore
~ we test CONSTANT here
1234 CONSTANT CTEST
CTEST 1234 = ?~ Error #48: testing CONSTANT
~ The Hayes tester uses some words from the Core extension word set
~ These will be conditionally defined following definition of a
~ word called ?DEFINED to determine whether these are already defined
VARIABLE TIMM1 0 TIMM1 !
: TIMM2 123 TIMM1 ! ; IMMEDIATE
: TIMM3 TIMM2 ; TIMM1 @ 123 = ?~ Error #49: testing IMMEDIATE
: ?DEFINED ( "name" -- 0 | -1 ) 32 WORD FIND SWAP DROP 0= 0= ;
?DEFINED SWAP ?~ Error #50: testing FIND ?DEFINED
?DEFINED <<no-such-word-hopefully>> 0= ?~ Error #51 testing FIND ?DEFINED
?DEFINED \ ?~ : \ ~ ; IMMEDIATE
\ Error #52: testing \
: TIMM4 \ Error #53: testing \ is IMMEDIATE
;
~ TRUE and FALSE are defined as colon definitions as they have been used
~ more than CONSTANT above
?DEFINED TRUE ?~ : TRUE 1 NEGATE ;
?DEFINED FALSE ?~ : FALSE 0 ;
?DEFINED HEX ?~ : HEX 16 BASE ! ;
TRUE -1 = ?~ Error #54: testing TRUE
FALSE 0= ?~ Error #55: testing FALSE
10 HEX 0A = ?~ Error #56: testing HEX
AB 0A BASE ! 171 = ?~ Error #57: testing hex number
~ Delete the ~ on the next 2 lines to check the final error report
~ Error #998: testing a deliberate failure
~ Error #999: testing a deliberate failure
~ Describe the messages that should be seen. The previously defined .MSG(
~ can be used for text messages
CR .MSG( Results: ) CR
CR .MSG( Pass messages #1 to #23 should be displayed above)
CR .MSG( and no error messages) CR
~ Finally display a message giving the number of tests that failed.
~ This is complicated by the fact that untested words including .( ." and .
~ cannot be used. Also more colon definitions shouldn't be defined than are
~ needed. To display a number, note that the number of errors will have
~ one or two digits at most and an interpretive loop can be used to
~ display those.
CR
0 #ERRS @
~ Loop to calculate the 10's digit (if any)
DUP NEGATE 9 + 0< NEGATE >IN +! ( -10 + SWAP 1+ SWAP 0 >IN ! )
~ Display the error count
SWAP ?DUP 0= 1+ >IN +! ( 48 + EMIT ( ) 48 + EMIT
.MSG( test) #ERRS @ 1 = 1+ >IN +! ~ .MSG( s)
.MSG( failed out of 57 additional tests) CR
CR CR .MSG( --- End of Preliminary Tests --- ) CR

25
8086/msdos/tests/test-blk.fth Normal file
View File

@ -0,0 +1,25 @@
include log2file.fth
logopen test.log
include ans-shim.fth
: \vf [compile] \ ; immediate
include prelimtest.fth
include tester.fth
\ 1 verbose !
include core.fr
include coreplustest.fth
include utilities.fth
include errorreport.fth
include coreexttest.fth
include doubletest.fth
1 drive include blocktest.fth
REPORT-ERRORS
logclose
dos s0:notdone

15
8086/msdos/tests/test-min.fth Normal file
View File

@ -0,0 +1,15 @@
include log2file.fth
logopen test.log
include ans-shim.fth
: \vf [compile] \ ; immediate
include prelim.fth
include tester.fth
\ 1 verbose !
include core.fr
\ include coreplus.fth
logclose

24
8086/msdos/tests/test-std.fth Normal file
View File

@ -0,0 +1,24 @@
include log2file.fth
logopen test.log
include ans-shim.fth
: \vf [compile] \ ; immediate
include prelimtest.fth
include tester.fth
\ 1 verbose !
include core.fr
include coreplustest.fth
include utilities.fth
include errorreport.fth
include coreexttest.fth
include doubletest.fth
REPORT-ERRORS
logclose
dos s0:notdone

66
8086/msdos/tests/tester.fth Normal file
View File

@ -0,0 +1,66 @@
\ From: John Hayes S1I
\ Subject: tester.fr
\ Date: Mon, 27 Nov 95 13:10:09 PST
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
\ VERSION 1.2
\ 24/11/2015 Replaced Core Ext word <> with = 0=
\ 31/3/2015 Variable #ERRORS added and incremented for each error reported.
\ 22/1/09 The words { and } have been changed to T{ and }T respectively to
\ agree with the Forth 200X file ttester.fs. This avoids clashes with
\ locals using { ... } and the FSL use of }
HEX
\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
VARIABLE VERBOSE
FALSE VERBOSE !
\ TRUE VERBOSE !
: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
VARIABLE #ERRORS 0 #ERRORS !
: ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
\ THE LINE THAT HAD THE ERROR.
CR TYPE SOURCE TYPE \ DISPLAY LINE CORRESPONDING TO ERROR
EMPTY-STACK \ THROW AWAY EVERY THING ELSE
#ERRORS @ 1 + #ERRORS !
\ QUIT \ *** Uncomment this line to QUIT on an error
;
VARIABLE ACTUAL-DEPTH \ STACK RECORD
CREATE ACTUAL-RESULTS 20 CELLS ALLOT
: T{ \ ( -- ) SYNTACTIC SUGAR.
;
: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH
?DUP IF \ IF THERE IS SOMETHING ON STACK
0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
THEN ;
: }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
\ (ACTUAL) CONTENTS.
DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH
DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK
0 DO \ FOR EACH STACK ITEM
ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED
= 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN
LOOP
THEN
ELSE \ DEPTH MISMATCH
S" WRONG NUMBER OF RESULTS: " ERROR
THEN ;
: TESTING \ ( -- ) TALKING COMMENT.
SOURCE VERBOSE @
IF DUP >R TYPE CR R> >IN !
ELSE >IN ! DROP [CHAR] * EMIT
THEN ;

143
8086/msdos/tests/util.fth Normal file
View 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

BIN
8086/msdos/v4thfile.com
View File

Binary file not shown.