6502/VolksForth
1
0
Fork 0
mirror of https://github.com/forth-ev/VolksForth.git synced 2025-01-31 20:38:49 +00:00
Code Issues Projects Releases Wiki Activity

Merge branch 'c64-390' of github.com:forth-ev/VolksForth into c64-390

Browse Source
This commit is contained in:
Carsten Strotmann 2020-08-03 13:09:55 +02:00
commit bedf27adb6
53 changed files with 1752 additions and 801 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
6502/C64/Makefile
View File

@ -3,17 +3,18 @@
# the file format conversion tools from the tools/ subdir of
# https://github.com/pzembrod/cc64 to be installed.
# VERSION=volksforth83
VERSION=vf-latest
vf_blk_d64_files = $(wildcard disks/*.d64)
vf_blk_fth_files = $(patsubst %.d64, %.fth, $(vf_blk_d64_files))
vf_fth_files = $(wildcard src/vf-*.fth)
vf_fth_files_petscii = $(patsubst src/%, cbmfiles/%, $(vf_fth_files))
vf_flavours = full-c64 full-c16+ full-c16- lite-c64 lite-c16+ lite-c16-
vf_binaries = $(patsubst %, cbmfiles/vf-%, $(vf_flavours))
test_files = $(wildcard tests/*.f*)
test_files_petscii = $(patsubst tests/%, cbmfiles/%, $(test_files))
test_logs = $(patsubst %, test-%.log, $(vf_flavours))
working_vf_flavours = full-c64 full-c16+ lite-c64 lite-c16+
test_resuls = $(patsubst %, test-%.result, $(working_vf_flavours))
# Target to convert all .d64 images into .fth files for easier reading,
# and to update all PETSCII files in cbmfiles to the latest state of
@ -22,32 +23,24 @@ update: $(vf_blk_fth_files) $(vf_fth_files_petscii)
clean:
rm -f cbmfiles/*.fr cbmfiles/*.fth cbmfiles/*.log *.log *.result
rm -f cbmfiles/*.fr cbmfiles/*.fth cbmfiles/*.log
rm -f *.log *.result *.golden
rm -f cbmfiles/c??-testbase
rm -f disks/scratch.d64
# Convenience targets
test: test-c64.result test-c16.result
test: $(test_resuls)
test64: test-c64.result
test64: test-full-c64.result
lite64: test-lite-c64.result
debug-64: emulator/tcbase.T64 emulator/build-vf.sh \
disks/vforth4_2.d64 disks/tc38q.d64 $(vf_fth_files_petscii)
emulator/build-vf.sh vf-c64-main.fth
# Temporary bincmp target while the old and the new binaries are still
# expected to be binary identical.
# Note: There is now 1 byte difference between the
# old c64/c16-volksforth83 and the new c64/c16-vf-reference:
# Byte $1b64 changed from $7c (old) to $dc (new).
# This corresponds to the ." |" string in .name (blk/page $4e).
# Since both represent the same character in PETSCII, namely | ,
# the difference is acceptable, and a new reference binary was set.
bincmp: cbmfiles/c64-vf-latest cbmfiles/c16-vf-latest
cmp -b -l cbmfiles/c64-vf-latest tests/c64-vf-reference
cmp -b -l cbmfiles/c16-vf-latest tests/c16-vf-reference
run-devenv: emulator/devenv.T64
emulator/run-in-vice.sh devenv
@ -60,43 +53,80 @@ run-testbase16: emulator/testbase16.T64
# Targetcompiler targets
cbmfiles/tcbase: emulator/c64-volksforth83.T64 emulator/build-tcbase.sh \
cbmfiles/tcbase: emulator/c64-vf-390.T64 emulator/build-tcbase.sh \
disks/tc38q.d64 disks/file-words.d64 cbmfiles/tc-base.fth
emulator/build-tcbase.sh
cbmfiles/c64-vf-latest: emulator/tcbase.T64 emulator/build-vf.sh \
disks/vforth4_2.d64 disks/tc38q.d64 $(vf_fth_files_petscii)
emulator/build-vf.sh vf-c64-main.fth c64-vf-latest
$(vf_binaries): emulator/tcbase.T64 emulator/build-vf.sh \
disks/tc38q.d64 $(vf_fth_files_petscii)
# C16 with 64 kB RAM or Plus4 - called (C16+ in the sources.
cbmfiles/c16-vf-latest: emulator/tcbase.T64 emulator/build-vf.sh \
disks/vforth4_2.d64 disks/tc38q.d64 $(vf_fth_files_petscii)
emulator/build-vf.sh vf-c16-main.fth c16-vf-latest
cbmfiles/vf-full-c64:
emulator/build-vf.sh vf-full-c64.fth vf-full-c64
# C16 with 32 kB RAM - called (C16- in the sources.
cbmfiles/c16-vf-32k: emulator/tcbase.T64 emulator/build-vf.sh \
disks/vforth4_2.d64 disks/tc38q.d64 $(vf_fth_files_petscii)
emulator/build-vf.sh vf-c16-32k.fth c16-vf-32k
cbmfiles/vf-full-c16+:
emulator/build-vf.sh vf-full-c16+.fth vf-full-c16+
cbmfiles/vf-full-c16-:
emulator/build-vf.sh vf-full-c16-.fth vf-full-c16-
cbmfiles/vf-lite-c64:
emulator/build-vf.sh vf-lite-c64.fth vf-lite-c64
cbmfiles/vf-lite-c16+:
emulator/build-vf.sh vf-lite-c16+.fth vf-lite-c16+
cbmfiles/vf-lite-c16-:
emulator/build-vf.sh vf-lite-c16-.fth vf-lite-c16-
# Core test targets
test-c64.result: emulator/c64-testbase.T64 $(test_files_petscii) \
emulator/run-in-vice.sh tests/evaluate-test.sh tests/test-c64.golden
rm -f test-c64.log test-c64.result
emulator/run-in-vice.sh c64-testbase \
"include run-vf-tests.fth\n1234567890\ndos s0:notdone\n"
petscii2ascii cbmfiles/test.log test-c64.log
tests/evaluate-test.sh test-c64
$(test_logs): $(test_files_petscii) emulator/run-in-vice.sh
test-c16.result: emulator/c16-testbase.T64 $(test_files_petscii) \
emulator/run-in-vice.sh tests/evaluate-test.sh tests/test-c16.golden
rm -f test-c16.log test-c16.result
VICE=xplus4 emulator/run-in-vice.sh c16-testbase \
"include run-vf-tests.fth\n1234567890\ndos s0:notdone\n"
petscii2ascii cbmfiles/test.log test-c16.log
tests/evaluate-test.sh test-c16
test-full-c64.log: emulator/vf-full-c64.T64 disks/scratch.d64
DISK9=scratch emulator/run-in-vice.sh vf-full-c64 \
"include run-full-tests.fth\n1234567890\n"
petscii2ascii cbmfiles/test.log $@
test-lite-c64.log: emulator/vf-lite-c64.T64
emulator/run-in-vice.sh vf-lite-c64 \
"include run-lite-tests.fth\n1234567890\n"
petscii2ascii cbmfiles/test.log $@
test-full-c16+.log: emulator/vf-full-c16+.T64
VICE=xplus4 emulator/run-in-vice.sh vf-full-c16+ \
"include run-min-tests.fth\n1234567890\n"
petscii2ascii cbmfiles/test.log $@
test-lite-c16+.log: emulator/vf-lite-c16+.T64
VICE=xplus4 emulator/run-in-vice.sh vf-lite-c16+ \
"include run-min-tests.fth\n1234567890\n"
petscii2ascii cbmfiles/test.log $@
test-%.result: test-%.log test-%.golden tests/evaluate-test.sh
rm -f $@
tests/evaluate-test.sh $(basename $@)
disks/scratch.d64: disks/empty.d64
cp $< $@
test-full-c64.golden: $(patsubst %, tests/golden/%.golden, \
prelim core coreext double block report-blk)
cat $? > $@
test-lite-c64.golden: $(patsubst %, tests/golden/%.golden, \
prelim core coreext double report-noblk)
cat $? > $@
c16_golden_parts = $(patsubst %, tests/golden/%.golden, \
prelim core)
test-full-c16+.golden: $(c16_golden_parts)
cat $? > $@
test-lite-c16+.golden: $(c16_golden_parts)
cat $? > $@
# Rules for building Forth binaries on top of the plain vanilla
# c64-volksforth83.
@ -106,14 +136,6 @@ cbmfiles/devenv: emulator/run-in-vice.sh emulator/build-devenv.sh \
disks/vforth4_1.d64 disks/vforth4_3.d64 disks/file-words.d64
emulator/build-devenv.sh
cbmfiles/c64-testbase: emulator/run-in-vice.sh emulator/build-testbase.sh \
emulator/c64-$(VERSION).T64 disks/file-words.d64
emulator/build-testbase.sh c64 $(VERSION)
cbmfiles/c16-testbase: emulator/run-in-vice.sh emulator/build-testbase.sh \
emulator/c16-$(VERSION).T64 disks/file-words.d64
VICE=xplus4 emulator/build-testbase.sh c16 $(VERSION)
# Generic T64 tape image rule

BIN
6502/C64/cbmfiles/c16-vf-latest
View File

Binary file not shown.

BIN
6502/C64/cbmfiles/c16-volksforth83
View File

Binary file not shown.

BIN
6502/C64/cbmfiles/c64-vf-390 Normal file
View File

Binary file not shown.

BIN
6502/C64/cbmfiles/c64-vf-latest
View File

Binary file not shown.

BIN
6502/C64/cbmfiles/c64-volksforth83
View File

Binary file not shown.

BIN
6502/C64/cbmfiles/tcbase
View File

Binary file not shown.

BIN
6502/C64/cbmfiles/vf-full-c16+ Normal file
View File

Binary file not shown.

BIN
6502/C64/cbmfiles/vf-full-c64 Normal file
View File

Binary file not shown.

BIN
6502/C64/cbmfiles/vf-lite-c16+ Normal file
View File

Binary file not shown.

BIN
6502/C64/cbmfiles/vf-lite-c64 Normal file
View File

Binary file not shown.

BIN
6502/C64/disks/file-words.d64
View File

Binary file not shown.

6
6502/C64/disks/file-words.fth
View File

@ -281,17 +281,17 @@
\ *** Block No. 10, Hexblock a
\ include loadscreen 30jun20pz
\ include loadscreen 19jul20pz
: i/o-status? $90 c@ ;
\ : i/o-status? $90 c@ ;
: dos-error ( dev -- )
15 busin
BEGIN bus@ con! i/o-status? UNTIL
busoff ;
: unloop r> rdrop rdrop rdrop >r ;
\ : unloop r> rdrop rdrop rdrop >r ;
: lo/hi> ( lo hi -- u )
255 and 256 * swap 255 and + ;

2
6502/C64/emulator/build-tcbase.sh
View File

@ -14,4 +14,4 @@ keybuf="3 drive 20 load\n3 drive 10 load\nsave\n\
savesystem tcbase\ndos s0:notdone\n"
DISK10=tc38q DISK11=file-words "${emulatordir}/run-in-vice.sh" \
"c64-volksforth83" "${keybuf}"
"c64-vf-390" "${keybuf}"

35
6502/C64/src/vf-c16-32k.fth
View File

@ -1,35 +0,0 @@
hex
\ load transient part of target compiler
2 drive 27 30 thru
Onlyforth hex
\ clear memory and clr labels .status
include vf-tc-prep.fth
\ Host and target settings and display
cr .( Host is: )
(64 .( C64) C)
(16 .( C16) C)
: ) ; immediate
: (C ; immediate
: (C16 ; immediate
: (C16- ; immediate
: (C64 [compile] ( ; immediate
: (C16+ [compile] ( ; immediate
\ ) - just to unconfuse my editor
include vf-pr-target.fth
\ The actual volksForth sources
include vf-head-c16.fth
include vf-cbm-core.fth
include vf-sys-c16.fth
include vf-finalize.fth
include vf-pr-target.fth
quit

38
6502/C64/src/vf-c16-main.fth
View File

@ -1,38 +0,0 @@
hex
\ load transient part of target compiler
2 drive 27 30 thru
Onlyforth hex
\ clear memory and clr labels .status
include vf-tc-prep.fth
\ Host and target settings and display
cr .( Host is: )
(64 .( C64) C)
(16 .( C16) C)
: ) ; immediate
: (C ; immediate
: (C16 ; immediate
: (C16+ ; immediate
: (C64 [compile] ( ; immediate
: (C16- [compile] ( ; immediate
\ ) - just to unconfuse my editor
include vf-pr-target.fth
\ The actual volksForth sources
\ including an initial C16+ tweak
include vf-c16+jsr.fth
include vf-head-c16.fth
include vf-cbm-core.fth
include vf-sys-c16.fth
include vf-finalize.fth
include vf-pr-target.fth
quit

35
6502/C64/src/vf-c64-main.fth
View File

@ -1,35 +0,0 @@
hex
\ load transient part of target compiler
2 drive 27 30 thru
Onlyforth hex
\ clear memory and clr labels .status
include vf-tc-prep.fth
\ Host and target settings and display
cr .( Host is: )
(64 .( C64) C)
(16 .( C16) C)
: ) ; immediate
: (C ; immediate
: (C64 ; immediate
: (C16 [compile] ( ; immediate
: (C16+ [compile] ( ; immediate
: (C16- [compile] ( ; immediate
\ ) - just to unconfuse my editor
include vf-pr-target.fth
\ The actual volksForth sources
include vf-head-c64.fth
include vf-cbm-core.fth
include vf-sys-c64.fth
include vf-finalize.fth
include vf-pr-target.fth
quit

301
6502/C64/src/vf-cbm-bufs.fth Normal file
View File

@ -0,0 +1,301 @@
\ *** Block No. 102, Hexblock 66
66 fthpage
( buffer mechanism 15dec83ks)
User file 0 file !
\ adr of file control block
Variable prev 0 prev !
\ Listhead
0408 Constant b/buf
\ Physical Size
\ Structure of Buffer:
\ 0 : link
\ 2 : file
\ 4 : blocknr
\ 6 : statusflags
\ 8 : Data .. 1 KB ..
\ Statusflag bits: 15 1 -> updated
\ file = -1 empty buffer
\ = 0 no fcb , direct access
\ = else adr of fcb
\ ( system dependent )
\ *** Block No. 103, Hexblock 67
67 fthpage
( search for blocks in memory 11jun85bp)
Label thisbuffer? 2 # ldy
[[ N 4 + )Y lda N 2- ,Y cmp
0= ?[[ iny 6 # cpy 0= ?] ]? rts
\ zero if this buffer )
| Code (core?
( blk file -- addr / blk file )
\ N-Area : 0 blk 2 file 4 buffer
\ 6 predecessor
3 # ldy
[[ SP )Y lda N ,Y sta dey 0< ?]
user' offset # ldy
clc UP )Y lda N 2+ adc N 2+ sta
iny UP )Y lda N 3 + adc N 3 + sta
prev lda N 4 + sta
prev 1+ lda N 5 + sta
thisbuffer? jsr 0= ?[
\ *** Block No. 104, Hexblock 68
68 fthpage
( " 11jun85bp)
Label blockfound SP 2inc
1 # ldy
8 # lda clc N 4 + adc SP X) sta
N 5 + lda 0 # adc SP )Y sta
' exit @ jmp ]?
[[ N 4 + lda N 6 + sta
N 5 + lda N 7 + sta
N 6 + X) lda N 4 + sta 1 # ldy
N 6 + )Y lda N 5 + sta N 4 + ora
0= ?[ ( list empty ) Next jmp ]?
thisbuffer? jsr 0= ?] \ found, relink
N 4 + X) lda N 6 + X) sta 1 # ldy
N 4 + )Y lda N 6 + )Y sta
prev lda N 4 + X) sta
prev 1+ lda N 4 + )Y sta
N 4 + lda prev sta
N 5 + lda prev 1+ sta
blockfound jmp end-code
\ *** Block No. 105, Hexblock 69
69 fthpage
\ (core? 23sep85bp
\ | : this? ( blk file bufadr -- flag )
\ dup 4+ @ swap 2+ @ d= ;
\ | : (core?
\ ( blk file -- dataaddr / blk file )
\ BEGIN over offset @ + over prev @
\ this? IF rdrop 2drop prev @ 8 + exit
\ THEN
\ 2dup >r offset @ + >r prev @
\ BEGIN dup @ ?dup
\ 0= IF rdrop rdrop drop exit THEN
\ dup r> r> 2dup >r >r rot this? 0=
\ WHILE nip REPEAT
\ dup @ rot ! prev @ over ! prev !
\ rdrop rdrop
\ REPEAT ;
\ *** Block No. 106, Hexblock 6a
6a fthpage
( (diskerr 11jun85bp)
: (diskerr ." error ! r to retry "
key dup Ascii r = swap Ascii R =
or not Abort" aborted" ;
Defer diskerr ' (diskerr Is diskerr
\ *** Block No. 107, Hexblock 6b
6b fthpage
( backup emptybuf readblk 11jun85bp)
| : backup ( bufaddr --)
dup 6+ @ 0<
IF 2+ dup @ 1+
\ buffer empty if file = -1
IF input push output push standardi/o
BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w
WHILE ." write " diskerr
REPEAT THEN
080 over 4+ 1+ ctoggle THEN
drop ;
| : emptybuf ( bufaddr --)
2+ dup on 4+ off ;
| : readblk
( blk file addr -- blk file addr)
dup emptybuf input push output push
standardi/o >r
BEGIN over offset @ + over
r@ 8 + -rot 1 r/w
WHILE ." read " diskerr
REPEAT r> ;
\ *** Block No. 108, Hexblock 6c
6c fthpage
( take mark updates? full? core? bp)
| : take ( -- bufaddr) prev
BEGIN dup @ WHILE @ dup 2+ @ -1 =
UNTIL
buffers lock dup backup ;
| : mark
( blk file bufaddr -- blk file )
2+ >r 2dup r@ ! offset @ + r@ 2+ !
r> 4+ off buffers unlock ;
| : updates? ( -- bufaddr / flag)
prev BEGIN @ dup WHILE dup 6+ @
0< UNTIL ;
| : full? ( -- flag)
prev BEGIN @ dup @ 0= UNTIL 6+ @ 0< ;
: core? ( blk file -- addr /false)
(core? 2drop false ;
\ *** Block No. 109, Hexblock 6d
6d fthpage
( block & buffer manipulation 11jun85bp)
: (buffer ( blk file -- addr)
BEGIN (core? take mark
REPEAT ;
: (block ( blk file -- addr)
BEGIN (core? take readblk mark
REPEAT ;
| Code file@ ( -- n )
user' file # ldy
UP )Y lda pha iny UP )Y lda
Push jmp end-code
: buffer ( blk -- addr )
file@ (buffer ;
: block ( blk -- addr )
file@ (block ;
: (blk-source ( -- addr len)
blk @ ?dup IF block b/blk exit THEN
tib #tib @ ;
' (blk-source IS source
\ *** Block No. 110, Hexblock 6e
6e fthpage
( block & buffer manipulation 09sep84ks)
: update 080 prev @ 6+ 1+ c! ;
: (save-buffers
buffers lock BEGIN updates? ?dup
WHILE backup REPEAT
buffers unlock ;
' (save-buffers IS save-buffers
| : (init-buffers
0 prev ! limit first ! all-buffers ;
' (init-buffers IS init-buffers
: empty-buffers
buffers lock prev
BEGIN @ ?dup
WHILE dup emptybuf
REPEAT buffers unlock ;
: flush save-buffers empty-buffers ;
: list ( blk --)
scr ! ." Scr " scr @ dup blk/drv mod u.
." Dr " drv? .
l/s 0 DO stop? IF leave THEN
cr I 2 .r space scr @ block
I c/l * + c/l (C 1- )
-trailing type LOOP cr ;
\ *** Block No. 111, Hexblock 6f
6f fthpage
( moving blocks 15dec83ks)
: (copy ( from to --)
dup file@
core? IF prev @ emptybuf THEN
full? IF save-buffers THEN
offset @ + swap block 2- 2- ! update ;
: blkmove ( from to quan --)
save-buffers >r
over r@ + over u> >r 2dup u< r> and
IF r@ r@ d+ r> 0 ?DO -1 -2 d+
2dup (copy LOOP
ELSE r> 0 ?DO 2dup (copy 1
1 d+ LOOP
THEN save-buffers 2drop ;
: copy ( from to --) 1 blkmove ;
: convey ( [blk1 blk2] [to.blk --)
swap 1+ 2 pick - dup 0> not
Abort" no!!" blkmove ;
\ *** Block No. 112, Hexblock 70
70 fthpage
\ Allocating buffers clv12jul87
: allotbuffer ( -- )
first @ r0 @ - b/buf 2+ u< ?exit
b/buf negate first +!
first @ dup emptybuf
prev @ over ! prev ! ;
: freebuffer ( -- )
first @ limit b/buf - u<
IF first @ backup prev
BEGIN dup @ first @ -
WHILE @ REPEAT
first @ @ swap ! b/buf first +!
THEN ;
: all-buffers
BEGIN first @ allotbuffer
first @ = UNTIL ;
include vf-sys-cbmrw.fth

352
6502/C64/src/vf-cbm-core.fth
View File

@ -511,7 +511,7 @@ Code 2+ ( n1 -- n2)
2 # lda n+ bne end-code
Code 3+ ( n1 -- n2)
3 # lda n+ bne end-code
| Code 4+ ( n1 -- n2)
Code 4+ ( n1 -- n2)
4 # lda n+ bne end-code
| Code 6+ ( n1 -- n2)
6 # lda n+ bne end-code
@ -648,7 +648,7 @@ Code u< ( u1 u2 -- flag)
: > ( n1 n2 -- flag) swap < ;
: 0> ( n -- flag) negate 0< ;
: 0> ( n -- flag) dup 0< swap 0= or not ;
: 0<> ( n -- flag) 0= not ;
@ -911,6 +911,9 @@ Code case?
: LEAVE endloop r> 2- dup @ + >r ;
restrict
code UNLOOP clc rp lda 6 # adc rp sta
cs ?[ rp 1+ inc ]? Next jmp end-code
\ Returnstack: calladr | index
\ limit | adr of DO
@ -1173,8 +1176,9 @@ Code fill ( addr quan 8b -- )
( input strings 24dec83ks)
| $84 Constant /tib
Variable #tib 0 #tib !
Variable >tib here >tib ! $50 allot
Variable >tib here >tib ! /tib allot
Variable >in 0 >in !
Variable blk 0 blk !
Variable span 0 span !
@ -1375,10 +1379,13 @@ Code capitalize ( string -- string )
( source word parse name 08apr85bp)
: source ( -- addr len)
blk @ ?dup IF block b/blk exit THEN
defer source
: (source ( -- addr len)
tib #tib @ ;
' (source IS source
: word ( char -- addr) source (word ;
: parse ( char -- addr len)
@ -1442,8 +1449,8 @@ Variable state 0 state !
: .( Ascii ) parse type ;
immediate
: \ >in @ c/l / 1+ c/l * >in ! ;
immediate
: \ blk @ IF >in @ c/l / 1+ c/l *
ELSE #tib @ THEN >in ! ; immediate
: \\ b/blk >in ! ; immediate
@ -2332,13 +2339,6 @@ Label (-trail
10 (C drop 19 ) Constant l/s
\ lines per screen
: list ( blk --)
scr ! ." Scr " scr @ dup blk/drv mod u.
." Dr " drv? .
l/s 0 DO stop? IF leave THEN
cr I 2 .r space scr @ block
I c/l * + c/l (C 1- )
-trailing type LOOP cr ;
@ -2374,320 +2374,19 @@ Label wake wake >wake !
end-code
\ *** Block No. 102, Hexblock 66
66 fthpage
( buffer mechanism 15dec83ks)
User file 0 file !
\ adr of file control block
Variable prev 0 prev !
\ Listhead
Variable buffers 0 buffers !
\ Semaphore
0408 Constant b/buf
\ Physical Size
\ Structure of Buffer:
\ 0 : link
\ 2 : file
\ 4 : blocknr
\ 6 : statusflags
\ 8 : Data .. 1 KB ..
\ Statusflag bits: 15 1 -> updated
\ file = -1 empty buffer
\ = 0 no fcb , direct access
\ = else adr of fcb
\ ( system dependent )
\ *** Block No. 103, Hexblock 67
67 fthpage
( search for blocks in memory 11jun85bp)
Label thisbuffer? 2 # ldy
[[ N 4 + )Y lda N 2- ,Y cmp
0= ?[[ iny 6 # cpy 0= ?] ]? rts
\ zero if this buffer )
| Code (core?
( blk file -- addr / blk file )
\ N-Area : 0 blk 2 file 4 buffer
\ 6 predecessor
3 # ldy
[[ SP )Y lda N ,Y sta dey 0< ?]
user' offset # ldy
clc UP )Y lda N 2+ adc N 2+ sta
iny UP )Y lda N 3 + adc N 3 + sta
prev lda N 4 + sta
prev 1+ lda N 5 + sta
thisbuffer? jsr 0= ?[
\ *** Block No. 104, Hexblock 68
68 fthpage
( " 11jun85bp)
Label blockfound SP 2inc
1 # ldy
8 # lda clc N 4 + adc SP X) sta
N 5 + lda 0 # adc SP )Y sta
' exit @ jmp ]?
[[ N 4 + lda N 6 + sta
N 5 + lda N 7 + sta
N 6 + X) lda N 4 + sta 1 # ldy
N 6 + )Y lda N 5 + sta N 4 + ora
0= ?[ ( list empty ) Next jmp ]?
thisbuffer? jsr 0= ?] \ found, relink
N 4 + X) lda N 6 + X) sta 1 # ldy
N 4 + )Y lda N 6 + )Y sta
prev lda N 4 + X) sta
prev 1+ lda N 4 + )Y sta
N 4 + lda prev sta
N 5 + lda prev 1+ sta
blockfound jmp end-code
\ *** Block No. 105, Hexblock 69
69 fthpage
\ (core? 23sep85bp
\ | : this? ( blk file bufadr -- flag )
\ dup 4+ @ swap 2+ @ d= ;
\ | : (core?
\ ( blk file -- dataaddr / blk file )
\ BEGIN over offset @ + over prev @
\ this? IF rdrop 2drop prev @ 8 + exit
\ THEN
\ 2dup >r offset @ + >r prev @
\ BEGIN dup @ ?dup
\ 0= IF rdrop rdrop drop exit THEN
\ dup r> r> 2dup >r >r rot this? 0=
\ WHILE nip REPEAT
\ dup @ rot ! prev @ over ! prev !
\ rdrop rdrop
\ REPEAT ;
\ *** Block No. 106, Hexblock 6a
6a fthpage
( (diskerr 11jun85bp)
: (diskerr ." error ! r to retry "
key dup Ascii r = swap Ascii R =
or not Abort" aborted" ;
Defer diskerr ' (diskerr Is diskerr
Defer r/w
\ *** Block No. 107, Hexblock 6b
6b fthpage
( backup emptybuf readblk 11jun85bp)
| : backup ( bufaddr --)
dup 6+ @ 0<
IF 2+ dup @ 1+
\ buffer empty if file = -1
IF input push output push standardi/o
BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w
WHILE ." write " diskerr
REPEAT THEN
080 over 4+ 1+ ctoggle THEN
drop ;
| : emptybuf ( bufaddr --)
2+ dup on 4+ off ;
| : readblk
( blk file addr -- blk file addr)
dup emptybuf input push output push
standardi/o >r
BEGIN over offset @ + over
r@ 8 + -rot 1 r/w
WHILE ." read " diskerr
REPEAT r> ;
\ *** Block No. 108, Hexblock 6c
6c fthpage
( take mark updates? full? core? bp)
| : take ( -- bufaddr) prev
BEGIN dup @ WHILE @ dup 2+ @ -1 =
UNTIL
buffers lock dup backup ;
| : mark
( blk file bufaddr -- blk file )
2+ >r 2dup r@ ! offset @ + r@ 2+ !
r> 4+ off buffers unlock ;
| : updates? ( -- bufaddr / flag)
prev BEGIN @ dup WHILE dup 6+ @
0< UNTIL ;
| : full? ( -- flag)
prev BEGIN @ dup @ 0= UNTIL 6+ @ 0< ;
: core? ( blk file -- addr /false)
(core? 2drop false ;
\ *** Block No. 109, Hexblock 6d
6d fthpage
( block & buffer manipulation 11jun85bp)
: (buffer ( blk file -- addr)
BEGIN (core? take mark
REPEAT ;
: (block ( blk file -- addr)
BEGIN (core? take readblk mark
REPEAT ;
| Code file@ ( -- n )
user' file # ldy
UP )Y lda pha iny UP )Y lda
Push jmp end-code
: buffer ( blk -- addr )
file@ (buffer ;
: block ( blk -- addr )
file@ (block ;
\ *** Block No. 110, Hexblock 6e
6e fthpage
( block & buffer manipulation 09sep84ks)
: update 080 prev @ 6+ 1+ c! ;
: save-buffers
buffers lock BEGIN updates? ?dup
WHILE backup REPEAT
buffers unlock ;
: empty-buffers
buffers lock prev
BEGIN @ ?dup
WHILE dup emptybuf
REPEAT buffers unlock ;
: flush save-buffers empty-buffers ;
\ *** Block No. 111, Hexblock 6f
6f fthpage
( moving blocks 15dec83ks)
: (copy ( from to --)
dup file@
core? IF prev @ emptybuf THEN
full? IF save-buffers THEN
offset @ + swap block 2- 2- ! update ;
: blkmove ( from to quan --)
save-buffers >r
over r@ + over u> >r 2dup u< r> and
IF r@ r@ d+ r> 0 ?DO -1 -2 d+
2dup (copy LOOP
ELSE r> 0 ?DO 2dup (copy 1
1 d+ LOOP
THEN save-buffers 2drop ;
: copy ( from to --) 1 blkmove ;
: convey ( [blk1 blk2] [to.blk --)
swap 1+ 2 pick - dup 0> not
Abort" no!!" blkmove ;
\ *** Block No. 112, Hexblock 70
70 fthpage
\ Allocating buffers clv12jul87
\ Hooks for buffer mechanism to hook into the
\ overall system.
\ Needed somewhere around here so that
\ loading vf-cbm-bufs.fth o can be ptional.
E400 Constant limit Variable first
: allotbuffer ( -- )
first @ r0 @ - b/buf 2+ u< ?exit
b/buf negate first +!
first @ dup emptybuf
prev @ over ! prev ! ;
: freebuffer ( -- )
first @ limit b/buf - u<
IF first @ backup prev
BEGIN dup @ first @ -
WHILE @ REPEAT
first @ @ swap ! b/buf first +!
THEN ;
: all-buffers
BEGIN first @ allotbuffer
first @ = UNTIL ;
Variable buffers 0 buffers !
\ Semaphore
Defer r/w
Defer save-buffers ' noop IS save-buffers
Defer init-buffers ' noop IS init-buffers
\ *** Block No. 113, Hexblock 71
@ -2702,7 +2401,7 @@ E400 Constant limit Variable first
name> under 1+ u< swap heap? or ;
| : endpoints ( addr -- addr symb)
heap voc-link @ >r
heap voc-link >r
BEGIN r> @ ?dup \ through all Vocabs
WHILE dup >r 4 - >r \ link on returnst.
BEGIN r> @ >r over 1- dup r@ u<
@ -2898,9 +2597,6 @@ Host Target
BEGIN dup 2- @ over 4 - !
@ ?dup 0= UNTIL ;
| : init-buffers
0 prev ! limit first ! all-buffers ;
Defer 'cold ' noop Is 'cold
| : (cold

23
6502/C64/src/vf-cbm-dos.fth Normal file
View File

@ -0,0 +1,23 @@
\ dir dos cat 09jun20pz
: dev fload-dev @ ;
: dir ( -- )
dev 0 busopen ascii $ bus! busoff
dev 0 busin bus@ bus@ 2drop
BEGIN cr bus@ bus@ 2drop
i/o-status? 0= WHILE
bus@ bus@ lo/hi> u.
BEGIN bus@ ?dup WHILE con! REPEAT
REPEAT busoff dev 0 busclose ;
: dos ( -- )
bl word count ?dup
IF dev $f busout bustype
busoff cr ELSE drop THEN
dev dos-error ;
: cat ( -- ) cr
dev 2 busopen bl word count bustype busoff
i/o-status? IF cr dev dos-error abort THEN
dev 2 busin BEGIN bus@ con! i/o-status? UNTIL busoff
dev 2 busclose ;

79
6502/C64/src/vf-cbm-file.fth Normal file
View File

@ -0,0 +1,79 @@
: dos-error ( dev -- )
f busin
BEGIN bus@ con! i/o-status? UNTIL
busoff ;
: lo/hi> ( lo hi -- u )
ff and 100 * swap ff and + ;
\ fload-dev freadline 25apr20pz
create fload-dev 8 ,
create fload-2nd f ,
| : eol? ( c -- f )
dup 0= swap #cr = or IF 0 exit THEN
i/o-status? IF 1 exit THEN -1 ;
| : freadline ( -- eof )
fload-dev @ fload-2nd @ busin
tib /tib bounds
DO bus@ dup eol? under
IF I c! ELSE drop THEN
dup 0<
IF drop ELSE I + tib - #tib ! UNLOOP
i/o-status? busoff exit THEN
LOOP /tib #tib !
." warning: line exceeds max " /tib .
cr ." extra chars ignored" cr
BEGIN bus@ eol? 1+ UNTIL
i/o-status? busoff ;
\ fload-open fload-close 30jun20pz
| : i/o-status?abort i/o-status? IF cr
fload-dev @ dos-error abort THEN ;
defer on-fload ' noop is on-fload
| : fload-open ( addr c -- )
on-fload fload-dev @
fload-2nd @ 1- dup fload-2nd !
busopen bustype
" ,s,r" count bustype busoff
i/o-status?abort ;
| : fload-close ( -- )
fload-dev @ fload-2nd @
dup 1+ fload-2nd !
busclose ;
: factive? ( -- flag )
fload-2nd @ f < ;
: fload-close-all ( -- )
factive? IF f fload-2nd @ DO
fload-dev @ I busclose -1 +LOOP
f fload-2nd ! THEN ;
\ include 09jun20pz
: interpret-via-tib
BEGIN freadline >r >in off
interpret r> UNTIL ;
: include ( -- )
blk @ Abort" no include from blk"
bl parse fload-open
interpret-via-tib
fload-close
#tib off >in off ;
: .filename 2dup cr type ;
' .filename IS on-fload

5
6502/C64/src/vf-finalize.fth
View File

@ -13,9 +13,10 @@ Forth also definitions
(C16 : (64 ) \ jumps belhind C)
(C64 : (16 )
BEGIN name count 0= abort" C) missing"
BEGIN name count dup 0=
abort" C) missing" 2 = >r
@ [ Ascii C Ascii ) $100 * + ] Literal
= UNTIL ; immediate
= r> and UNTIL ; immediate
: C) ; immediate

16
6502/C64/src/vf-full-c16+.fth Normal file
View File

@ -0,0 +1,16 @@
include vf-tc-prep.fth
include vf-trg-c16+.fth
\ The actual volksForth sources
include vf-head-c16.fth
include vf-cbm-core.fth
include vf-sys-c16.fth
include vf-cbm-file.fth
include vf-cbm-bufs.fth
include vf-finalize.fth
include vf-pr-target.fth
quit

16
6502/C64/src/vf-full-c16-.fth Normal file
View File

@ -0,0 +1,16 @@
include vf-tc-prep.fth
include vf-trg-c16-.fth
\ The actual volksForth sources
include vf-head-c16.fth
include vf-cbm-core.fth
include vf-sys-c16.fth
include vf-cbm-file.fth
include vf-cbm-bufs.fth
include vf-finalize.fth
include vf-pr-target.fth
quit

16
6502/C64/src/vf-full-c64.fth Normal file
View File

@ -0,0 +1,16 @@
include vf-tc-prep.fth
include vf-trg-c64.fth
\ The actual volksForth sources
include vf-head-c64.fth
include vf-cbm-core.fth
include vf-sys-c64.fth
include vf-cbm-file.fth
include vf-cbm-bufs.fth
include vf-finalize.fth
include vf-pr-target.fth
quit

4
6502/C64/src/vf-head-c16.fth
View File

@ -28,5 +28,5 @@ here dup origin!
$100 allot
Create logo
(C16+ ," volksFORTH-83 3.80.1-C16+ " )
(C16- ," volksFORTH-83 3.80.1-C16- " )
(C16+ ," volksFORTH-83 3.90-C16+ " )
(C16- ," volksFORTH-83 3.90-C16- " )

2
6502/C64/src/vf-head-c64.fth
View File

@ -28,4 +28,4 @@ here dup origin!
$100 allot
Create logo
," volksFORTH-83 3.80.1-C64 "
," volksFORTH-83 3.90-C64 "

15
6502/C64/src/vf-lite-c16+.fth Normal file
View File

@ -0,0 +1,15 @@
include vf-tc-prep.fth
include vf-trg-c16+.fth
\ The actual volksForth sources
include vf-head-c16.fth
include vf-cbm-core.fth
include vf-sys-c16.fth
include vf-cbm-file.fth
include vf-finalize.fth
include vf-pr-target.fth
quit

15
6502/C64/src/vf-lite-c16-.fth Normal file
View File

@ -0,0 +1,15 @@
include vf-tc-prep.fth
include vf-trg-c16-.fth
\ The actual volksForth sources
include vf-head-c16.fth
include vf-cbm-core.fth
include vf-sys-c16.fth
include vf-cbm-file.fth
include vf-finalize.fth
include vf-pr-target.fth
quit

15
6502/C64/src/vf-lite-c64.fth Normal file
View File

@ -0,0 +1,15 @@
include vf-tc-prep.fth
include vf-trg-c64.fth
\ The actual volksForth sources
include vf-head-c64.fth
include vf-cbm-core.fth
include vf-sys-c64.fth
include vf-cbm-file.fth
include vf-finalize.fth
include vf-pr-target.fth
quit

2
6502/C64/src/vf-sys-c16.fth
View File

@ -12,7 +12,7 @@ include vf-lbls-cbm.fth
098 >label InDev
0ff19 >label BrdCol
0ff15 >label BkgCol
0540 >label PenCol
053b >label PenCol
09d >label PrgEnd
0b2 >label IOBeg
0cb >label CurFlg

102
6502/C64/src/vf-sys-cbm.fth
View File

@ -217,102 +217,10 @@ Code bus@ ( -- 8b)
: businput ( adr n --)
bounds ?DO bus@ I c! LOOP pause ;
: i/o-status? $90 c@ ;
: derror? ( -- flag )
disk $F busin bus@ dup Ascii 0 -
IF BEGIN emit bus@ dup #cr = UNTIL
0= cr THEN 0= busoff ;
\ *** Block No. 140, Hexblock 8c
8c fthpage
( s#>s+t x,x 28may85re)
165 | Constant 1.t
1EA | Constant 2.t
256 | Constant 3.t
| : (s#>s+t ( sector# -- sect track)
dup 1.t u< IF 15 /mod exit THEN
3 + dup 2.t u< IF 1.t - 13 /mod 11 +
exit THEN
dup 3.t u< IF 2.t - 12 /mod 18 +
exit THEN
3.t - 11 /mod 1E + ;
| : s#>t+s ( sector# -- track sect )
(s#>s+t 1+ swap ;
| : x,x ( sect track -- adr count)
base push decimal
0 <# #s drop Ascii , hold #s #> ;
\ *** Block No. 141, Hexblock 8d
8d fthpage
( readsector writesector 28may85re)
100 | Constant b/sek
: readsector ( adr tra# sect# -- flag)
disk 0F busout
" u1:13,0," count bustype
x,x bustype busoff pause
derror? ?exit
disk 0D busin b/sek businput busoff
false ;
: writesector ( adr tra# sect# -- flag)
rot disk 0F busout
" b-p:13,0" count bustype busoff
disk 0D busout b/sek bustype busoff
disk 0F busout
" u2:13,0," count bustype
x,x bustype busoff pause derror? ;
\ *** Block No. 142, Hexblock 8e
8e fthpage
( 1541r/w 28may85re)
: diskopen ( -- flag)
disk 0D busopen Ascii # bus! busoff
derror? ;
: diskclose ( -- )
disk 0D busclose busoff ;
: 1541r/w ( adr blk file r/wf -- flag)
swap Abort" no file"
-rot blk/drv /mod dup (drv ! 3 u>
IF . ." beyond capacity" nip exit THEN
diskopen IF drop nip exit THEN
0 swap 2* 2* 4 bounds
DO drop 2dup I rot
IF s#>t+s readsector
ELSE s#>t+s writesector THEN
>r b/sek + r> dup IF LEAVE THEN
LOOP -rot 2drop diskclose ;
' 1541r/w Is r/w
\ *** Block No. 143, Hexblock 8f
8f fthpage
\ index findex ink-pot 05nov87re
: index ( from to --)
1+ swap DO
cr I 2 .r I block 1+ 25 type
stop? IF LEAVE THEN LOOP ;
: findex ( from to --)
diskopen IF 2drop exit THEN
1+ swap DO cr I 2 .r
pad dup I 2* 2* s#>t+s readsector
>r 1+ 25 type
r> stop? or IF LEAVE THEN
LOOP diskclose ;
IF BEGIN emit bus@ dup #cr = UNTIL
0= cr ELSE BEGIN bus@ #cr = UNTIL
THEN 0= busoff ;

94
6502/C64/src/vf-sys-cbmrw.fth Normal file
View File

@ -0,0 +1,94 @@
\ *** Block No. 140, Hexblock 8c
8c fthpage
( s#>s+t x,x 28may85re)
165 | Constant 1.t
1EA | Constant 2.t
256 | Constant 3.t
| : (s#>s+t ( sector# -- sect track)
dup 1.t u< IF 15 /mod exit THEN
3 + dup 2.t u< IF 1.t - 13 /mod 11 +
exit THEN
dup 3.t u< IF 2.t - 12 /mod 18 +
exit THEN
3.t - 11 /mod 1E + ;
| : s#>t+s ( sector# -- track sect )
(s#>s+t 1+ swap ;
| : x,x ( sect track -- adr count)
base push decimal
0 <# #s drop Ascii , hold #s #> ;
\ *** Block No. 141, Hexblock 8d
8d fthpage
( readsector writesector 28may85re)
100 | Constant b/sek
: readsector ( adr tra# sect# -- flag)
disk 0F busout
" u1:13,0," count bustype
x,x bustype busoff pause
derror? ?exit
disk 0D busin b/sek businput busoff
false ;
: writesector ( adr tra# sect# -- flag)
rot disk 0F busout
" b-p:13,0" count bustype busoff
disk 0D busout b/sek bustype busoff
disk 0F busout
" u2:13,0," count bustype
x,x bustype busoff pause derror? ;
\ *** Block No. 142, Hexblock 8e
8e fthpage
( 1541r/w 28may85re)
: diskopen ( -- flag)
disk 0D busopen Ascii # bus! busoff
derror? ;
: diskclose ( -- )
disk 0D busclose busoff ;
: 1541r/w ( adr blk file r/wf -- flag)
swap Abort" no file"
-rot blk/drv /mod dup (drv ! 3 u>
IF . ." beyond capacity" nip exit THEN
diskopen IF drop nip exit THEN
0 swap 2* 2* 4 bounds
DO drop 2dup I rot
IF s#>t+s readsector
ELSE s#>t+s writesector THEN
>r b/sek + r> dup IF LEAVE THEN
LOOP -rot 2drop diskclose ;
' 1541r/w Is r/w
\ *** Block No. 143, Hexblock 8f
8f fthpage
\ index findex ink-pot 05nov87re
: index ( from to --)
1+ swap DO
cr I 3 .r I block 28 type
stop? IF LEAVE THEN LOOP ;
: findex ( from to --)
diskopen IF 2drop exit THEN
1+ swap DO cr I 3 .r
pad dup I 2* 2* s#>t+s readsector
>r 28 type
r> stop? or IF LEAVE THEN
LOOP diskclose ;

15
6502/C64/src/vf-tc-prep.fth
View File

@ -1,3 +1,13 @@
hex
\ load transient part of target compiler
2 drive 27 30 thru
Onlyforth hex
\ clear memory and clr labels .status
\ *** Block No. 12, Hexblock c
\ ramfill 3:
@ -73,3 +83,8 @@ variable current-page 0 current-page !
current-page @ ;
' blk-or-page@ is blk@
\ Host and target settings and display
cr .( Host is: )
(64 .( C64) C)
(16 .( C16) C)

13
6502/C64/src/vf-trg-c16+.fth Normal file
View File

@ -0,0 +1,13 @@
: ) ; immediate
: (C ; immediate
: (C16 ; immediate
: (C16+ ; immediate
: (C64 [compile] ( ; immediate
: (C16- [compile] ( ; immediate
include vf-pr-target.fth
\ C16+ jsr tweak
include vf-c16+jsr.fth

10
6502/C64/src/vf-trg-c16-.fth Normal file
View File

@ -0,0 +1,10 @@
: ) ; immediate
: (C ; immediate
: (C16 ; immediate
: (C16- ; immediate
: (C64 [compile] ( ; immediate
: (C16+ [compile] ( ; immediate
include vf-pr-target.fth

10
6502/C64/src/vf-trg-c64.fth Normal file
View File

@ -0,0 +1,10 @@
: ) ; immediate
: (C ; immediate
: (C64 ; immediate
: (C16 [compile] ( ; immediate
: (C16+ [compile] ( ; immediate
: (C16- [compile] ( ; immediate
include vf-pr-target.fth

2
6502/C64/tests/ans-shim.fth
View File

@ -48,8 +48,6 @@
: :noname here ['] tuck @ , 0 ] ;
: <> = not ;
\ Wrong for -32768: : 0> ( n -- flag) negate 0< ;
: 0> dup 0< swap 0= or not ;
: 2>r r> -rot swap >r >r >r ;
: 2r> r> r> r> swap rot >r ;

676
6502/C64/tests/blocktest.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

BIN
6502/C64/tests/c16-vf-reference
View File

Binary file not shown.

BIN
6502/C64/tests/c64-vf-reference
View File

Binary file not shown.

3
6502/C64/tests/evaluate-test.sh
View File

@ -5,7 +5,8 @@ basedir="$(realpath --relative-to="$PWD" "${testsdir}/..")"
testname="$1"
diff "${testsdir}/${testname}.golden" "${basedir}/${testname}.log" > tmp.result
diff --ignore-trailing-space "${basedir}/${testname}.golden" \
"${basedir}/${testname}.log" > tmp.result
exitcode=$?
test $exitcode -eq 0 \
&& echo "PASS: ${testname}" >> tmp.result \

134
6502/C64/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

32
6502/C64/tests/golden/core.golden Normal file
View File

@ -0,0 +1,32 @@
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
*
PLEASE TYPE UP TO 80 CHARACTERS:
1234567890
RECEIVED: "1234567890"
* GDX exists
End of Core word set tests
coreplustest.fth********
You should see 2345: 2345
*****
End of additional Core tests

52
6502/C64/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

3
6502/C64/tests/golden/double.golden Normal file
View File

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

39
6502/C64/tests/test-c16.golden → 6502/C64/tests/golden/prelim.golden
View File

@ -1,6 +1,5 @@
ans-shim.fth CHAR exists 0> exists
ans-shim.fth CHAR exists
prelimtest.fth
CR CR SOURCE TYPE ( Preliminary test ) CR
@ -31,7 +30,7 @@ Pass #21: testing ?~
Pass #22: testing EMIT
Pass #23: testing S"
Results:
Results:
Pass messages #1 to #23 should be displayed above
and no error messages
@ -39,36 +38,4 @@ and no error messages
0 tests failed out of 57 additional tests
--- End of Preliminary Tests ---
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
*
PLEASE TYPE UP TO 80 CHARACTERS:
1234567890
RECEIVED: "1234567890"
* GDX exists
End of Core word set tests
coreplustest.fth********
You should see 2345: 2345
*****
End of additional Core tests
--- End of Preliminary Tests ---

21
6502/C64/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
6502/C64/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
---------------------------

26
6502/C64/tests/run-full-tests.fth Normal file
View File

@ -0,0 +1,26 @@
include vf-cbm-dos.fth
include logtofile.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

25
6502/C64/tests/run-lite-tests.fth Normal file
View File

@ -0,0 +1,25 @@
include vf-cbm-dos.fth
include logtofile.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

20
6502/C64/tests/run-vf-tests.fth → 6502/C64/tests/run-min-tests.fth
View File

@ -1,32 +1,20 @@
include vf-cbm-dos.fth
include logtofile.fth
logopen" test.log"
include ans-shim.fth
: \vf [compile] \ ; immediate
include ans-shim.fth
include prelimtest.fth
include tester.fth
\ 1 verbose !
include core.fr
include coreplustest.fth
\ The C16 VolksForth has LIMIT at $8000.
\ More tests than up to here fill the dictionary.
(64 include utilities.fth C)
(64 include errorreport.fth C)
(64 include coreexttest.fth C)
(64 include doubletest.fth C)
(64 REPORT-ERRORS C)
logclose
dos s0:notdone

150
6502/C64/tests/test-c64.golden
View File

@ -1,150 +0,0 @@
ans-shim.fth CHAR exists 0> exists
prelimtest.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 #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 ---
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
*
PLEASE TYPE UP TO 80 CHARACTERS:
1234567890
RECEIVED: "1234567890"
* GDX exists
End of Core word set tests
coreplustest.fth********
You should see 2345: 2345
*****
End of additional Core tests
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
doubletest.fth*****************
End of Double-Number word tests
---------------------------
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
---------------------------