From 5373de9c3676247e307893d16ba3a209475ffc0c Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Thu, 6 Jan 2022 14:55:53 +0100 Subject: [PATCH 01/21] First automated make test for MSDOS volks4th.com in dosbox. --- 8086/msdos/Makefile | 18 +++++++++++++ 8086/msdos/emulator/run-in-dosbox.sh | 36 ++++++++++++++++++++++++++ 8086/msdos/tests/LOG2FILE.FB | 1 + 8086/msdos/tests/LOGTEST.FB | 1 + 8086/msdos/tests/evaluate-test.sh | 16 ++++++++++++ 8086/msdos/tests/golden/logtest.golden | 1 + 6 files changed, 73 insertions(+) create mode 100644 8086/msdos/Makefile create mode 100755 8086/msdos/emulator/run-in-dosbox.sh create mode 100644 8086/msdos/tests/LOG2FILE.FB create mode 100644 8086/msdos/tests/LOGTEST.FB create mode 100755 8086/msdos/tests/evaluate-test.sh create mode 100644 8086/msdos/tests/golden/logtest.golden diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile new file mode 100644 index 0000000..e94fd1e --- /dev/null +++ b/8086/msdos/Makefile @@ -0,0 +1,18 @@ + + +test: logtest.result + +clean: + rm -f *.log *.LOG *.result *.golden + + +logtest.log: volks4th.com tests/LOG2FILE.FB tests/LOGTEST.FB emulator/run-in-dosbox.sh + ./emulator/run-in-dosbox.sh volks4th.com logtest + +logtest.golden: tests/golden/logtest.golden + cp -p $< $@ + +%.result: %.log %.golden tests/evaluate-test.sh + rm -f $@ + tests/evaluate-test.sh $(basename $@) + diff --git a/8086/msdos/emulator/run-in-dosbox.sh b/8086/msdos/emulator/run-in-dosbox.sh new file mode 100755 index 0000000..efd0ff5 --- /dev/null +++ b/8086/msdos/emulator/run-in-dosbox.sh @@ -0,0 +1,36 @@ +#!/bin/bash + +set -e + +emulatordir="$(realpath --relative-to="$PWD" "$(dirname "${BASH_SOURCE[0]}")")" +basedir="$(realpath --relative-to="$PWD" "${emulatordir}/..")" + +forth="$1" +srcbasename="$2" +forthcmd="" +if [ -n "${srcbasename}" ]; then + forthcmd="include ${srcbasename}.fb" + logname="${srcbasename}.log" + doslogname="$(echo ${logname}|tr '[:lower:]' '[:upper:]')" + rm -f "${logname}" "${doslogname}" +fi + +exit="" +bye="" +if [ -z "${KEEPEMU}" ]; then + exit="-c exit" + bye="bye" +fi + +auto_c="" +autocmd="" +if [ -n "${forth}" ]; then + auto_c="-c" + autocmd="${forth} path f:\\;f:\\tests ${forthcmd} ${bye}" +fi + +dosbox -c "mount f ${basedir}" -c "f:" "${auto_c}" "${autocmd}" $exit + +if [ -n "${srcbasename}" ]; then + dos2unix -n "${doslogname}" "${logname}" +fi diff --git a/8086/msdos/tests/LOG2FILE.FB b/8086/msdos/tests/LOG2FILE.FB new file mode 100644 index 0000000..5f100db --- /dev/null +++ b/8086/msdos/tests/LOG2FILE.FB @@ -0,0 +1 @@ +\ logging to a text file phz 03jan22 \ load screen phz 04jan22 1 2 +thru \ log-type log-emit log-cr alsologtofile phz 04jan22 context @ dos also context ! \ vocabulary log dos also log definitions file logfile variable logfcb : log-type 2dup (type ds@ -rot logfcb @ lfputs ; : log-emit dup (emit logfcb @ fputc ; : log-cr (cr #cr logfcb @ fputc #lf logfcb @ fputc ; Output: alsologtofile log-emit log-cr log-type (del (page (at (at? ; \ logopen logclose phz 04jan22 : logopen ( -- ) logfile make isfile@ dup freset logfcb ! alsologtofile ; : logclose ( -- ) display logfcb @ fclose ; \ No newline at end of file diff --git a/8086/msdos/tests/LOGTEST.FB b/8086/msdos/tests/LOGTEST.FB new file mode 100644 index 0000000..4bf54a9 --- /dev/null +++ b/8086/msdos/tests/LOGTEST.FB @@ -0,0 +1 @@ +\ logtest.fb phz 04jan22 basic tests for log2file.fb \ loadscreen phz 04jan22 include log2file.fb logopen logtest.log .( logtest done) cr logclose \ No newline at end of file diff --git a/8086/msdos/tests/evaluate-test.sh b/8086/msdos/tests/evaluate-test.sh new file mode 100755 index 0000000..144f661 --- /dev/null +++ b/8086/msdos/tests/evaluate-test.sh @@ -0,0 +1,16 @@ +#!/bin/bash + +testsdir="$(realpath --relative-to="$PWD" "$(dirname "${BASH_SOURCE[0]}")")" +basedir="$(realpath --relative-to="$PWD" "${testsdir}/..")" + +testname="$1" + +diff --ignore-trailing-space "${basedir}/${testname}.golden" \ + "${basedir}/${testname}.log" > tmp.result +exitcode=$? +test $exitcode -eq 0 \ + && echo "PASS: ${testname}" >> tmp.result \ + || echo "FAIL: ${testname}" >> tmp.result +cat tmp.result +mv tmp.result "${basedir}/${testname}.result" +exit $exitcode diff --git a/8086/msdos/tests/golden/logtest.golden b/8086/msdos/tests/golden/logtest.golden new file mode 100644 index 0000000..6000c89 --- /dev/null +++ b/8086/msdos/tests/golden/logtest.golden @@ -0,0 +1 @@ +logtest done From 99276c12cb918d2c59ded095598e87428767790e Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Thu, 6 Jan 2022 15:52:41 +0100 Subject: [PATCH 02/21] In C64 logclose, disable log output before closing the log file. --- 6502/C64/tests/logtofile.fth | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/6502/C64/tests/logtofile.fth b/6502/C64/tests/logtofile.fth index 68b5149..fd66bbc 100644 --- a/6502/C64/tests/logtofile.fth +++ b/6502/C64/tests/logtofile.fth @@ -24,4 +24,4 @@ Output: alsologtofile alsologtofile ; : logclose - log-dev-2nd@ busclose display ; + display log-dev-2nd@ busclose ; From 1db5aedfc0966197333304f39a3ee87b753d85b1 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Thu, 6 Jan 2022 16:30:46 +0100 Subject: [PATCH 03/21] Auto-end run-in-dosbox.sh only if 2nd arg include_basename is given --- 8086/msdos/emulator/run-in-dosbox.sh | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/8086/msdos/emulator/run-in-dosbox.sh b/8086/msdos/emulator/run-in-dosbox.sh index efd0ff5..bbc00a3 100755 --- a/8086/msdos/emulator/run-in-dosbox.sh +++ b/8086/msdos/emulator/run-in-dosbox.sh @@ -6,20 +6,19 @@ emulatordir="$(realpath --relative-to="$PWD" "$(dirname "${BASH_SOURCE[0]}")")" basedir="$(realpath --relative-to="$PWD" "${emulatordir}/..")" forth="$1" -srcbasename="$2" +include_basename="$2" forthcmd="" -if [ -n "${srcbasename}" ]; then - forthcmd="include ${srcbasename}.fb" - logname="${srcbasename}.log" - doslogname="$(echo ${logname}|tr '[:lower:]' '[:upper:]')" - rm -f "${logname}" "${doslogname}" -fi - exit="" bye="" -if [ -z "${KEEPEMU}" ]; then - exit="-c exit" - bye="bye" +if [ -n "${include_basename}" ]; then + forthcmd="include ${include_basename}.fb" + logname="${include_basename}.log" + doslogname="$(echo ${logname}|tr '[:lower:]' '[:upper:]')" + rm -f "${logname}" "${doslogname}" + if [ -z "${KEEPEMU}" ]; then + exit="-c exit" + bye="bye" + fi fi auto_c="" @@ -31,6 +30,6 @@ fi dosbox -c "mount f ${basedir}" -c "f:" "${auto_c}" "${autocmd}" $exit -if [ -n "${srcbasename}" ]; then +if [ -n "${include_basename}" ]; then dos2unix -n "${doslogname}" "${logname}" fi From b0c4023a542296a3f9793eb68eff9b22d29d4b5d Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Thu, 6 Jan 2022 20:22:31 +0100 Subject: [PATCH 04/21] Some comments and naming clarifciation around C64 include's freadline --- 6502/C64/src/vf-cbm-file.fth | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/6502/C64/src/vf-cbm-file.fth b/6502/C64/src/vf-cbm-file.fth index 5e0d647..4d8bfff 100644 --- a/6502/C64/src/vf-cbm-file.fth +++ b/6502/C64/src/vf-cbm-file.fth @@ -14,14 +14,17 @@ create fload-dev 8 , create fload-2nd f , -| : eol? ( c -- f ) +| : eolf? ( c -- f ) + \ f=-1: not yet eol; store c and continue + \ f=0: eol but not yet eof; return line and flag continue + \ f=1: not eol but eof; store c, return line and flag eof 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 + DO bus@ dup eolf? under IF I c! ELSE drop THEN dup 0< IF drop ELSE I + tib - #tib ! UNLOOP @@ -29,7 +32,7 @@ LOOP /tib #tib ! ." warning: line exceeds max " /tib . cr ." extra chars ignored" cr - BEGIN bus@ eol? 1+ UNTIL + BEGIN bus@ eolf? 1+ UNTIL i/o-status? busoff ; From ab4a88aa5b878076fc8ffa01caa79d8e98cd345f Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Thu, 6 Jan 2022 20:23:09 +0100 Subject: [PATCH 05/21] First MSDOS finclude implementation --- 8086/msdos/INCLUDE.FB | 1 + 1 file changed, 1 insertion(+) create mode 100644 8086/msdos/INCLUDE.FB diff --git a/8086/msdos/INCLUDE.FB b/8086/msdos/INCLUDE.FB new file mode 100644 index 0000000..95e23ba --- /dev/null +++ b/8086/msdos/INCLUDE.FB @@ -0,0 +1 @@ +\ include for stream sources phz 06jan22 \ load screen phz 06jan22 1 3 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; \ interpret-via-tib phz 06jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : finclude ( -- ) blk @ Abort" no include from blk" pushfile use interpret-via-tib close #tib off >in off ; \ No newline at end of file From dd5db3ecd509552cdebeb3ee7c87f5127cefa3f8 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Thu, 6 Jan 2022 20:45:43 +0100 Subject: [PATCH 06/21] Make finclude file type smart (block or stream file), rename to include --- 8086/msdos/INCLUDE.FB | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/8086/msdos/INCLUDE.FB b/8086/msdos/INCLUDE.FB index 95e23ba..55f70e8 100644 --- a/8086/msdos/INCLUDE.FB +++ b/8086/msdos/INCLUDE.FB @@ -1 +1 @@ -\ include for stream sources phz 06jan22 \ load screen phz 06jan22 1 3 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; \ interpret-via-tib phz 06jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : finclude ( -- ) blk @ Abort" no include from blk" pushfile use interpret-via-tib close #tib off >in off ; \ No newline at end of file +\ include for stream sources phz 06jan22 \ load screen phz 06jan22 1 3 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline probe-for-fb phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; : probe-for-fb ( -- flag ) \ probes whether current file looks like a block file /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN LOOP true ; \ interpret-via-tib include phz 06jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) pushfile use probe-for-fb isfile@ freset IF 1 load close exit THEN blk @ Abort" no include from blk" interpret-via-tib close #tib off >in off ; \ No newline at end of file From 83173f691fb61d83479bd5a90d8e988448d0f2a5 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Mon, 10 Jan 2022 22:33:25 +0100 Subject: [PATCH 07/21] Move INCLUDE.FB into src/ subdir --- 8086/msdos/emulator/run-in-dosbox.sh | 2 +- 8086/msdos/{ => src}/INCLUDE.FB | 0 2 files changed, 1 insertion(+), 1 deletion(-) rename 8086/msdos/{ => src}/INCLUDE.FB (100%) diff --git a/8086/msdos/emulator/run-in-dosbox.sh b/8086/msdos/emulator/run-in-dosbox.sh index bbc00a3..6675b89 100755 --- a/8086/msdos/emulator/run-in-dosbox.sh +++ b/8086/msdos/emulator/run-in-dosbox.sh @@ -25,7 +25,7 @@ auto_c="" autocmd="" if [ -n "${forth}" ]; then auto_c="-c" - autocmd="${forth} path f:\\;f:\\tests ${forthcmd} ${bye}" + autocmd="${forth} path f:\\;f:\\src;f:\\tests ${forthcmd} ${bye}" fi dosbox -c "mount f ${basedir}" -c "f:" "${auto_c}" "${autocmd}" $exit diff --git a/8086/msdos/INCLUDE.FB b/8086/msdos/src/INCLUDE.FB similarity index 100% rename from 8086/msdos/INCLUDE.FB rename to 8086/msdos/src/INCLUDE.FB From e089121f22223182fe7bdb0f1987dbb8946a0f28 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Mon, 10 Jan 2022 22:42:25 +0100 Subject: [PATCH 08/21] Add Makefile rules to convert uppercase XYZ.FB block files into lowercase xyz.fth stream files, and convert files in src/ and tests/ --- 8086/msdos/Makefile | 19 ++++++- 8086/msdos/src/include.fth | 95 +++++++++++++++++++++++++++++++++++ 8086/msdos/tests/log2file.fth | 76 ++++++++++++++++++++++++++++ 8086/msdos/tests/logtest.fth | 38 ++++++++++++++ 4 files changed, 226 insertions(+), 2 deletions(-) create mode 100644 8086/msdos/src/include.fth create mode 100644 8086/msdos/tests/log2file.fth create mode 100644 8086/msdos/tests/logtest.fth diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index e94fd1e..6ab9855 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -1,12 +1,12 @@ - test: logtest.result clean: rm -f *.log *.LOG *.result *.golden -logtest.log: volks4th.com tests/LOG2FILE.FB tests/LOGTEST.FB emulator/run-in-dosbox.sh +logtest.log: volks4th.com tests/LOG2FILE.FB tests/LOGTEST.FB \ + emulator/run-in-dosbox.sh ./emulator/run-in-dosbox.sh volks4th.com logtest logtest.golden: tests/golden/logtest.golden @@ -16,3 +16,18 @@ logtest.golden: tests/golden/logtest.golden rm -f $@ tests/evaluate-test.sh $(basename $@) +fbfiles = $(wildcard src/*.FB tests/*.FB) +fthfiles = $(patsubst %.fb, %.fth, \ + $(shell ../../tools/echo-tolower.py $(fbfiles))) + +fth: $(fthfiles) + +.ONESHELL: +$(fthfiles): $(fbfiles) + set -x + for fb in $^ + do + echo fb: $$fb + fth=$$(../../tools/echo-tolower.py $$fb | sed -e 's/fb$$/fth/') + ../../tools/fb2fth.py $$fb $$fth + done diff --git a/8086/msdos/src/include.fth b/8086/msdos/src/include.fth new file mode 100644 index 0000000..292c4d5 --- /dev/null +++ b/8086/msdos/src/include.fth @@ -0,0 +1,95 @@ + +\ *** Block No. 0, Hexblock 0 + +\ include for stream sources phz 06jan22 + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ load screen phz 06jan22 + + 1 3 +thru + + + + + + + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ fib /fib #fib eolf? phz 06jan22 + + context @ dos also context ! + $50 constant /tib + variable tibeof tibeof off + + : eolf? ( c -- f ) + \ f=-1: not yet eol; store c and continue + \ f=0: eol but not yet eof; return line and flag continue + \ f=1: eof: return line and flag eof + tibeof off + dup #lf = IF drop 0 exit THEN + -1 = IF tibeof on 1 ELSE -1 THEN ; + + + + +\ *** Block No. 3, Hexblock 3 + +\ freadline probe-for-fb phz 06jan22 + + : freadline ( -- eof ) + tib /tib bounds DO + isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN + 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN + LOOP /tib #tib ! + ." warning: line exteeds max " /tib . cr + ." extra chars ignored" cr + BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; + + : probe-for-fb ( -- flag ) + \ probes whether current file looks like a block file + /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN + LOOP true ; + + +\ *** Block No. 4, Hexblock 4 + +\ interpret-via-tib include phz 06jan22 + + : interpret-via-tib + BEGIN freadline >r .status >in off interpret + r> UNTIL ; + + : include ( -- ) + pushfile use + probe-for-fb isfile@ freset IF 1 load close exit THEN + blk @ Abort" no include from blk" + interpret-via-tib close + #tib off >in off ; + + + + diff --git a/8086/msdos/tests/log2file.fth b/8086/msdos/tests/log2file.fth new file mode 100644 index 0000000..255ee47 --- /dev/null +++ b/8086/msdos/tests/log2file.fth @@ -0,0 +1,76 @@ + +\ *** Block No. 0, Hexblock 0 + +\ logging to a text file phz 03jan22 + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ load screen phz 04jan22 + + 1 2 +thru + + + + + + + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ log-type log-emit log-cr alsologtofile phz 04jan22 + context @ dos also context ! +\ vocabulary log dos also log definitions + file logfile + variable logfcb + + : log-type 2dup (type ds@ -rot logfcb @ lfputs ; + + : log-emit dup (emit logfcb @ fputc ; + + : log-cr (cr #cr logfcb @ fputc #lf logfcb @ fputc ; + +Output: alsologtofile + log-emit log-cr log-type (del (page (at (at? ; + + + +\ *** Block No. 3, Hexblock 3 + +\ logopen logclose phz 04jan22 + + : logopen ( -- ) + logfile make isfile@ dup freset logfcb ! + alsologtofile ; + + : logclose ( -- ) display logfcb @ fclose ; + + + + + + + + + diff --git a/8086/msdos/tests/logtest.fth b/8086/msdos/tests/logtest.fth new file mode 100644 index 0000000..fbcdda2 --- /dev/null +++ b/8086/msdos/tests/logtest.fth @@ -0,0 +1,38 @@ + +\ *** Block No. 0, Hexblock 0 + +\ logtest.fb phz 04jan22 + + basic tests for log2file.fb + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen phz 04jan22 + + include log2file.fb + + logopen logtest.log + .( logtest done) cr + logclose + + + + + + + + + From eb8a218bf17b6a432f660a8ea0dad90259f05d9e Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Mon, 10 Jan 2022 22:56:19 +0100 Subject: [PATCH 09/21] Rule to savesystem v4thfile.com which includes INCLUDE.FB, i.e. the stream file include --- 8086/msdos/Makefile | 5 +++++ 8086/msdos/src/V4THFILE.FB | 1 + 8086/msdos/src/v4thfile.fth | 38 ++++++++++++++++++++++++++++++++++++ 8086/msdos/v4thfile.com | Bin 0 -> 32228 bytes 4 files changed, 44 insertions(+) create mode 100644 8086/msdos/src/V4THFILE.FB create mode 100644 8086/msdos/src/v4thfile.fth create mode 100644 8086/msdos/v4thfile.com diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index 6ab9855..0a385a5 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -4,6 +4,11 @@ test: logtest.result clean: rm -f *.log *.LOG *.result *.golden +v4thfile.com: volks4th.com src/V4THFILE.FB \ + emulator/run-in-dosbox.sh + rm -f V4THFILE.COM v4thfile.com + ./emulator/run-in-dosbox.sh volks4th.com v4thfile + mv V4THFILE.COM v4thfile.com logtest.log: volks4th.com tests/LOG2FILE.FB tests/LOGTEST.FB \ emulator/run-in-dosbox.sh diff --git a/8086/msdos/src/V4THFILE.FB b/8086/msdos/src/V4THFILE.FB new file mode 100644 index 0000000..a5a81fc --- /dev/null +++ b/8086/msdos/src/V4THFILE.FB @@ -0,0 +1 @@ + \ loadscreen for creating v4thfile.com phz 10jan22 include include.fb savesystem v4thfile.com \ No newline at end of file diff --git a/8086/msdos/src/v4thfile.fth b/8086/msdos/src/v4thfile.fth new file mode 100644 index 0000000..6b578c4 --- /dev/null +++ b/8086/msdos/src/v4thfile.fth @@ -0,0 +1,38 @@ + +\ *** Block No. 0, Hexblock 0 + + + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen for creating v4thfile.com phz 10jan22 + + include include.fb + + savesystem v4thfile.com + + + + + + + + + + + diff --git a/8086/msdos/v4thfile.com b/8086/msdos/v4thfile.com new file mode 100644 index 0000000000000000000000000000000000000000..28b7ff64d25737c7030dcdeaa39084e4627f861c GIT binary patch literal 32228 zcmdqKd3;pW`9FSV?wXnGkYxganS_u)l1T_*O-M4CB^ffwOlGpOg$PLqgakvPWmA@` zEHko+3RbOtO8ua9|6=OWDzaH)S)^5wA_~eHtuZLHh~)cz?oGh<*VpU&|F3<8Irllw z+0S{-vmUozE=%8f`NK3$W*EWkbrw0xF2)?We6ycndcU~##mb9cuVNS-^M`S-WqSZ@$`5L_HqYCJU{T(x72FPo&tCDiAykwf*K&mxpZ#q^ zxG3*IPGyCs5;>8gyjROR%ao6yqP$-lZ1;NI-eOCc&1Lt#ZHN}-V_MNth>_TBZyRDo z`75nd<+duFf7=iz%6-}(htp*r01OvpEz4F?A4W*>5SI0M3P!VD|KF(pi?xzGfjZvHmLxmJgt6mbLi`+F5Vl6k#<2w2Ue4QqlKVoqUMZdJDcJ7(qS;LgM_BRNzkl_On7| zS()7juudMz@%e<3%IQzc=sZc4g#&Ejgv@CKw-UT#U(W@-Jed>iHFj%dg}sLJ-{dvmCRC69j&Ql!ca5+8iaS!%U4STr|`3+7}@Db4bQ3QD(kPkVH=_^3CsO3Hb z=yOh+RbV#M@@?WV&cPq!;sNXh&}25e!=L5a#Ipc}$~>=4HI3xas75XP4S=ycM-wGt=r zKlq3GZY zN{+G~5QfSd1-8sx@q%#u1VNq#WVgUt%53ilHHpUw^cp~2g4XRlF4X81$RR*J5ZD^G z_bZ`hyaM`Eh?4&-Nk|Ft-sN;ab84wOv) zy*Qmp?gn=HAH?a?dwOH#S46JDTWN1J^!LZge-e3z#pS~n!^Fznq9#*KofI|W8Vwr2 z&WW0=MuQfqZ$!=bMgxn~HBpn@XyA}yByBnnsVbeMb(am7-stc5-`J>b_NT>IIZ9$d zk+Y>Y7^dffK~9s_xp4j^uYah+L48e;404VnTLG<=yqku0F+CRzvPXI!0K3=XqGM-~ znEpQsHocB%4YNp@VFK40RxMe>;<-5aE=ij??O{oO;w^^h)F{JuNpW&OVl#8|ey_qi zRQPWI|E;90%-t_xoq)eoh5rHYw*k*PC2gP4bAFioS4oq5VE|{9igQdFCVweu@_r_i z3&Z5=Xf{t5G=5*tXTxMRNSm1(6QuNEnTmf^8ZL(iX{MzI)#Mz%)3wB);c{}2SXu3? zD0Y@j52~rn`Sa2s7v9#oThypx^Y!+ORm+j)La zyu2WYwPj9wCc4CD5Gr=r1aRh7M57;{+_w%535T`9FC2XaC?a*C8@^;?yypwQJ$}p zQ}S)@?K(_y=O=8odIun5qi#J~c7bPjNw@BRGT^5G{vVxC=mrt=9n{rqXZI_;dR=Fd z-_$*jLdbvD^@~eb|Gf$oIf9IjbPuMaQqGS$P0Wm*uM*@dI*n7S#|_C=YiS-Y=n~|c zI?eQGz^VndS|VVuK2Z+WKUnCslv#^2^=vi)O#mk8*XOHHhn}v$^Xeg(s2?Ry)$@6! z7H^5!AcdV4GqJfx$(4F3&ujO&T~&4hui;}w2kslnYS#0)gXr`v>!sXZpvDf=utP88 zdn`^b<~COR*c9B^y0oLcb6!Vhd&B&AE=m5qe!tUUHnfJ>^t1IBF!M?Bhx&sR#r86@ z!J@k$?$vkb33x_-&<;9bHV~*a%nWP?-=PnaDD$fRP@x@6u-OpM_bPRS2Op{~27_ca z^a8(ERO`1$xB5$kcus}>Mo%aER)1;`o$PGXX4e0spXy5pKJ2x7?3N1Zm|0&COu)Ip zhbqe|oFE8P8No)&ox%HUZUQXS&DP&Q%cJFu!3VG-2)6Y$?1|umw1#HG4W;v+=~}~H z(9yU?%dZ3zYoS1^51)_tV~_Va(%LVF_^6^9jg!7UVHtl zvW@zKlVvtUTRL_m!7eMXp&`j~Y=~y8*$@6oC`|V1}B4m|>@Jh}S%Gq=w>wL|xbl3l-=HC@^{a;`V`ij|)dcGYa zH->Oj$K$}P+2!duvF;%E;>65Ek{&H}!X{d@6(=OEsGfU2J?vH`^LQ&?_O@u_)9xP>2cT zD^;Y^*q#*%N?52+X&WqgT0Fy6ptOVUQhwvPR5>w}x0d4WE(?9s-(5FnM&E9QGx&2z zs%#4tl&rjk19?vNU+ni5@EDKYq;Ag)O_l3HIVv3(z{t6^^wdBN_lG_M;EmcjRo3;x7XIq=zE^P ze*^erD36fU_$E&HOrbX-r{n(D~w^9s$hi@MTVK> z=rBzho!zrsuQ&pS+AODqX{`!qGk0MClo!T&ESO{o*IHp8oe;S^Y`xW8>QT;6H%qK% z7ki8&vXCLq591OmoP`%-#xWW4>M$-(`Pdm|TvFe$z}Pr-Ru2A_w$G!Vj)tWjOO4H~ z^IAIRHyH29?pV;++|pofyvumkvWEYMK$;;x6vpO}a2uz|kgtTXg)Yc$8Z>$>jPrRc z$YAiH4QJ5-vtdUVamE>PSU6u^Y4_He4N>9MlIQufpzveddYXZ-EYOQgd1N@}D{*?9 z;oED!lIpI$)S-1-s{INRloFOH7a-eeDO;ds_r274Cwpdird$^;X80<+&a$FS;Wf3X z`P!AlJ0$mX3p%ZF*QCCu5&FXX$5OjHhOh7Q-xs_g zq^NKAVczKP8`w8OgeDXi_XWStGe-ZXRPFSLiSngz$>p}#NW{Dt^XZC-a(#s0b60w4 z8{fn%FXC=g|7!x!0b4;cIvY-_16Lcd>M*)FSIjBBgpS%3N#`OeRjkoIX`l33W_-*33FEDdq}s2)kluS_hh*_a$Sm9 z$vqr;EtMe4BKH%ZHSGQY6n~^8g<2ic714-;G+BNkvd}yTQOmp-X_8~(CZEgU&SwAroBQet7NC7lYMA}0+IY)}|g{tR7;uk^|JODw@<3&$8bcPr^vZObQY_%vb55LCBPJcnmQCDx?LU_NEM6SEFs@J zM6|lgARFNltrHK2+K1Tm5+e^W>woCqg_}~HfNdC(*>E^COj0MoY}f@{f>ldtYxvY4 z2l`}A4LYja+MnS#k6ME3ItU#OKPU=ZwN(5c-=hb=b!vVReM?NQNS`OraE`ot2y64; zWcK%i$KbBA+1P$IJ;!8&zN~eP>_KFzz-ySLV20L8{k9L;CM_N+4_P(z;1DMY(YH9xA9EF&my7x`^Kicv!O8R824B# z4USTaFr;a6aTHhVv|*uVL|M4!pm`{XJI2x8nkF|!30`}Zowk;mc_(X4)CbV2ReF6+ z+PIsdsLmNtG^%&_W!zC=4Zj%^OO-qk733@}wcDJ^ZmO0FUIOwo`EZm3J`(iRik(v} zttM!m{CSkl3TDWQ<8Lj|M*ABj<%X+?%#*K13B}6AXEv}EYt)M~!`Li8b< z+wRLF!tr`^wRG7U_DHl8)`mk!H*A6YUNoPN9@uD|3gmOqnw4h5mFQ#K8171R9L`LE z+#7Af3V`LM4=x64;Vc^XiimMwLT-PKj1j9X-ZI=*>Xx4zLqw9+nO1ET2#ba5NTBae zV(*U>8-CSHH}=CIZx-1cBb8c8>{U*CwJGkvG>g12MzDIp8Dlt7SZ7RT7}Y_1!NrJW zTrGb=td@+$LC*_d^_yGosc&hXZ)~k!+#rP&V(3JIb7N>6HobwlAYO@%=WF@Qu%(y+ z<4aLkFRV&7W|QQP*Q04JX&U!LTjUinQkBK)v=kCgFUP0?N}+r;hAVSe@`uFM`47A~ zlJQT|_jkl@nypRz?4errx?O8zI<)?gIj1_$KeS5g|J1Lj0>6u~%DPxSPrYM)#=_U) zJ{!&~7dTu(4n885?l*}!!8Zy5XV!n&PxQ|!TVsV3DuZP^99k`n{G+m4tn$6F`~bL? zUmfefHpg)OC|EErRBQ{HDsudHO^x&ne&U#PVjfE7a_8rj~Dxw&_LY z{z&ag<3K~#QqAbl{gG^bett(nJZF=S#)|4fOr`l)97XFeGwv)07I*~Za|R7^LJhA+ zlWzN=PGu(ZV{P&%!+SZzNs<@^W@rTMU7I}3Ac0)tbd}-M$yirRzh9mHDF(ajGYFLf zXRMYtfD!D&CDDHp#3iJ1X+wK`dqcgkv9qOxvK&B&$AsDCb^}-GvwNw+UU7xNN|kP^ z)OInfqH}IV#d{23TAdbLW^xQ|!P>#uBZ@)N*$4<=BIqXe$Ld%*J!Zo}2$KA~_WGp@ zsF4p1yv^=VTd_z#8>s94Roea}ha3{8t@2!q5g5ZTX;@2^G)(0;9db&X2omMBmw^yU z!yK{&-|jM~fHC;=xLRmf`vh7n`f3wr#>I0Exjc@8rV5f>I%XOd>QB;lrl_j6dG&X7 zw$!&TGcN6@pSMVvgqc9-71QJ5d0G%E+Zo4IxP2HTm9=m*F3OJQisV=0bkOWu3UR3t z$Et2^+TKza?aWO4dzO1W`tmbBsg)JUe~IH28^_hS$5%ZLLr;->D~|KJ-4$2kdeeH- zf`=8!;lnt0nG4mW$7M+|!&YJdMY3sF5CN64W<$y_0q{A)C}-j@J*LoE=B#jH510)! zfD)zaW`lY>i2SeNUx%KVZU?%9zQJu{HXOsnP!jtIZjNHvGmHn{M+=c2w;q!Q;;37w z3uPGnhG8_~tGX9-z2f?WlDG|MwOD?17>ALgIckEoegw8YNN}uDqgmgB7K-J=!+2sR zffg3|8Tdu&8*P&nsoNyd$)zz5r;>DXhRse$4I(yg8Fz*yj)A25PhvX~%(&XKd9%K| zpRRC~lrQ7D*wwLTa3$lQ(%nxtI(@EIKX-wP!HuMTNZ1KZ`I}*U3g*amKUnEH?VZlgIyUzlMbdlU zP$G8@hoo0#qp7CdwuYw(CPf6tJSV;b$g1H)fu85{h6^}Q&*3ghkE8srF$m&9O62{+ zHMqEmGaSQxhdZ8NeEbJ92c)*y5c=ckGAWS_@dsumE8oN!m&h6M`m#!wOO;_1K5!Yg z4Sb$O;qzQ_e!K+LwSyE@rnoQS&4v$#)AGcFV$*~OOchxD?@Yn-+7>T?EN5(MZCUo@ z&@tS?c$!=lIh>KuTNRZQro@X7qp3n2e2df~2}+4lxh_7W%xzYbbv|_i5+6^ciFZ-Q zRw^Hh7ZfqVYl>@)FO`3c4|3wfdOcn{4lOhCVnk^?P1(2FEL40e-mL7ZLLIEh_J?UZrMLV$XEHFk$y*T>cOSKJfm4EUb1}k z5=g$^Ar%y)9&A^XjqePCbqgTmN!{Q|!%ZNwmX1iJHlt;ckLiSYpifObC+`=T? zcd=7OcCpa3Alp7tG?T1V=`+RsqtYYKAIU>SNlF4uau-XYUl;rBDEgNK!Y-D?8T$7u zcN2e_i zqvojkKH*~p`qfCTqS#wW5`}|bsMCSAd_3|q&=o53FBJLD+@9OH(MD@}I_}&H;!Q}I zqzPzMs?0VDAX=UZOoShFXdC#(SaBb8NaeE2h?_;p8O0KN=m57zIbONRD5iM4P>*2i zwT@I5UC&%e#g#qVC~)6WMWB(&jcsgObOpSWS6*Wj)H0?xztJmq8Tpj*N+)V~*O(k0 zKEka3XFs7GGV;j;H^m(R*5^h}MWW8_W-~|JM9FbtFh(pTv@k+>!8b>Y&CTlv!aSCCoAILHw$<22ATyl;#wv+5s97%5~_7gb_=w*2>f9J=TjK?DDcu_z;2}P0oPY0pG(l7I0@!yp^xCyR!c!Y zNf6$N6@}E^C#YyQP%FB3D`C0d2N|Y~RV|wmS(_QR^9lYPzDD&^x?qN@^9tt!};a$XpHIvT=@ZT;IxuEhzALGuO$aJZisx$O>xocVfpuLp z%3I~z*eI~A+I5Gx{`0kR{U{JCD~u#`ZBGZELDy6^FMuPVD@$UUN0EkOI%p~_aIL&z z6#Nnfi>w_**U#*A-)d`~^fwAK=O{vK!pNEO3!?<5&oQ8Hn<@Wwl;i+?xdS*iio;D; zbus4nMLKsg<*TFMhEZ7QXf#ONOqolfFINeyr}&CYV!as<*ql>m%Elx?IT6Znohhd! z>GEw(Ux@-U#Th5el5>)T6sy~7&#z6Y@#s%?>a+s6aZTjg*nP&NE|1{ zicOz@D=#3fQJfh_EI$UKKRSuHwF_c#l39PQf4zchk^1ldBlHC%62^0L=WoPbQK*50es{`Y>;Pr=+WN?ox? zhPX*`tRR(+O@F2T)~L0}dlnmknxSgX;L2PBu6MBVGq@z^2BYS0je32QS|8OzFYc1RN!B^M zcKa_YIGG%rgu5Ih#LQ5!XOq+Hyhc5PY@h>TqPqNy4c~uIO zc4V|ti5D$JHqfZ4Q0Pb1E|?*9-%!%jNfN@<$t2$Nc?eO5A%D;?24%LvhVsV@Hl&`- zV{l4R3`vIRFdjWQW;#prYQ|OjCdU9{4vdO3w1`6W%S3m6FimGK{)_rN*Vp7T?v@GIY%Jv4pc}tT2c|Vgf`7 z4e8Z^x}?3WqhVf0!~Bw1bsc^w1yIqK#`4NxBj%1uQPUP_JW>XQi*J%IkLBp(QqL%J zIy*!IZxxLzRF&Ib7isyP`wzLjN!F)wiFTj0(J+iL8`h>dQNsa%hS-u^=SgEEl~58r=g{X)8KpJv0E$3(}ZR?>2f|rS8kCE!)Qk}%P*&m zB3(?%ux5FGT9TrY5s*HTmZT^4g9QQ(5o6aX=8X($JxgnbA zth!;K`ygebhtqYjQQ>FUO`*8pAheOFL_){HVZTY)n~XbRSV&s66uUklN=pp>mDGrI zOs0Rtsbu}%JA_xczxG%Uyv>9kxN&p*zRf2uecd1EW>0NC@Ft^uhhhA;`hNGmu$z5% zR3P+O_I-h2o(TzrYMBFrNd)a z8T2RVi{*c&>mmDBdduo)-ia%UGv7d)`z|d}+x)xIAR6xb-A{X6=BK00M@*L<>0c}h zX11^vXJ&8m_hUoSV$Jc~B~L%vK8do~{p$``_D(-yS}GnEqRrtwFZlD&nfHZvqBL(B znZDn>Q<8qUs=rk(Fmp7Gt>z{217_A`E!b%usT%aDCc2t`NM9mvr7Y9`F^{bA-`K!Y zj>7W&FG~I1taTL}p+f$s!6N$sKMc6(yi#K0of4aDBUbbhn)tZa#|EFwIIwelXL-waddZ_!MmBg4r41 zEZiBoYn{Sg@rY^D@h)b=L{A0{rzE3Y_Ni$3@@=#sul4U0j+i<*IL?WC`+w`s=<46} z3E|(9u~c53p;Ng9)a`pS;|(VGi0QE4$x!^wo(01586351HZ+e~n_<)6=%1NErZ-AU z%*+f4M!VA>GoA8>8C+ta9a4eFbjm+uu!)6`3M8a8nQ%t16gC=y@DY;9Cc3~A>yVB^ z+UjjIgdjaSQ%q6Mr`aHa#L>k@3NKCCF0?>IPlW`9pM@<%fF^@v!ZYCFH-pdnGPO?W zLl$aL&owkYz&wq+nS2ZAqSP^K)1F8prh(R>Q~p(^gmD$RA)Viyb|PbKMsDWX%zNbB znWDAW;spVGKXdhs{!Z3LZjLC0j^41Ixtww`~xko-lU)W@g1_Qn>W%4OR z9qFdYPM|hPFTVPya40jLyGOp3$)*q;PRl%$X~ZAFqQ-F;Hb|ZbKz72RO!}paG2_@2 za&Mx(-Xj+R4MdZ+6;1X%vS%EhLbMe|+DsClBnVKdjC-$KKaRsXpw6E%sIGhERpYn{ zrw1l9lIDV;l3B*78zVXKTekK2Y90w(&>G-(4 zJZ6Bl%=;O?lHVW4daMQK$9=Quc$VVl@Y%Ru$)6L@bYoo2KNP%wj9Vu6jf2h}ZZviq zO-L9ltc~H>ij6OxTPE{aLLNB>%rG043tbBHp<@n*o?-Xm?=-Z#heP{>&5%b3IWdbL zz`Y1pfwZi6Zn^BqVr_2U)j0Dk^Q`z`%R$7&M4J~zO>8@XSuS^E>EN_su|j8V_g##6 zg?oh?H*DOnFxVKL$@=KryANlv15VwVtk<$O?VnNWtE}>W_NJEk=-iQ{Idf*uBnMDo z(}mwoN>W@WU&{LIKhZ|_d`e@xFN@e*SR3wYSk~4$-#EX$`JM*jy!s{e^O{Mkw^Ej~ zgbbx~ssw&t7A=|)JDkz~ChHxZ_6l*9-vyI-i*#qSm=0WmE9HpsBIHJtt^#kG`x}gX zr92;#H&9&X(RF!H!Cm#aRF@Cy&{#MDZ@sfiK zTP}N9qhSQIO8#E}AmS42VoY#Vc11CLnxU~~@Z%`_f4BqvGJBQ$#(2q60UoZf5|V-l zHs=0F32NE4c4MNEEbtjaCM1zUfNpw9RZEd{$~myQ7sMq&P>qr!l2J8x_9~E21wty` z#WTcKudZU=MN*1oJ-il7Yrz3pwS zO)73Se}5!rYhJo&Xm*1sp1WV>vvn!A<$AM$RH;vnCyj)TnUHjr%g7eM-?&Ep34cRP zyTFQvz?#UxY&YKw6sS<{ZEx;q7@B>5WC#LhI@*`z8&j5Lw2oPuhLaDsi`rDhs4Ldr z)z%J%HJ)2751GK<=l0mkwocf-ciN02rtR&VcfgbQMeO?m=ri_~9Wl}Q&?vr8$C3ZH3F3WF zq#$~SnYh=|^W_@(2S9w-T-J)niF-o_C`d0*g^9v_G#B|}Cwli9)Ju%0%dm-S<&hKl z`zQ{`jx6^t+n9vRoQWI?dg~|pZ_U|Tbj0Mpey0x=6NzD51E#i508<m$}zY)UJ~snkYHUY8cPjiR?Og*F?c#CYgKfM1Gz89DP+dOYtSHlm9?pKIaU4 z1+9}0(H9+zwG%_u$$y;)b&kV|OD&a=<+I46EJS;pp4bJ-Rm;CN{%eVh?2+n@g@xTn zJF*2Eq#GoT_B@HfszPEpY?-QbN(u?HA#oDPeslpon?%BTuOidQ@^@%QSsr!&)bhJ0 zk~B$2UX@GN@Y5!}H(~cgRq0YKJ^mwP<9O}?xq6b6f~Y5p*9tZIf$?cswS0K?G4AsT zl(}t^IFM(G`y=Qv?M)9%y}3CgFsCt#qewGwj0=TG^9=Uvs;OiMCR6;N40d4r;ZOVx%EHQ&Uk|<#E$r) zT~xMg$HeWIKKOt-wEm0Q86)@RA29_!*!-FQi|wibX5HjV&#T$8Z?fQWKtlArsn*?d zWWD^-WY+EmpVHsIUfw^Mr)(?v$DI~Ou}i>pT)++Whsk4LML+}cQDA^jDj`6yfKKja zKS8IYDgGO3;|0{Q?SW&PzkoGpywYsyN1bX%e>?e-=>t$DA{Isj$ib4dLGGn4A^gne zLLC@x&mT6(mMJ`ely2PV#Plg7J8h6Fk&7;13(^cz7iLe1=QheqrwGtHLL>UfEl#Q}~iZE8eduPh{eGh)};DzH~e{_QW6nEp7r%=67 zklY7Uuy9@)f0p~}lv@6eQ;3euoVjGQ^>LBuT#{08J9%xcy5#Yf2N2I zr4h{3xha2`OkLk3$4(u9qVwmbOh>o<^4#%U3RI+U`$46o+#}hSSk8p0C%_O+R{rgR zXIR|$o-DfE1m=}2f%_EKBN@P+K^YhipkN|{7FAd{6>fEKe8Q$YEv}jx&jsX%r;;}> zcqloBHnB*_{+|eCqe-T<51%M-Jz2knX_+iOYw zm}y!&QfS*WP3u64-y)|@(-t8mY>_8S(-tEoZk6+=fextpBcj@;#g{-7>3|DUy4m+Y zy|>EFX%Zo*OHPN74DB@O4Gr^`D!yIbX@u7@O-FdXT3>}76CatnH<|PbQrNx7CbPsg zxiBXvWzd^Uwd;}yMy6!C66g@n)PysyP9xI{N<+306cV^i{=+oBfV|MmhLTvi8tCAV zVIdTHKr$1&IxQwtP%f+QOuB~V)~1Gz<|RuyNSxUwU!BJ1sRN(})l)}BmkZP=-9rCR zT)fB@zQTkZqwMLR_@Aat&Qq<_+vOe8IJNznyj$QYx62)Q@EmkO?5W9vH3}UjFm~^4 zMp=|ybP4eS;&tt$khOks(a*QJw&GzPe2EyJAhOuHMWedxdC-9G+<3C)I|^Kb%7!E1jvH8h`P zm=8Q_D09{TbP(}Be$9q`A?iHSpz=fL|CG8re_se$#5IAO{2-icdnx?$yjSB!mX0i4 zlEnrPo}Nd_83;&k zKx;`Sg##B@TA;Ne8HD701zH=DIwUt1XuU}4k=y~?)J8)vlD`2ik|9Vw4_qWek$fGv zNQNP~4-KU6D&PViB9VFsiN6)#>|#_JF7P=@BdJ01Qi0Zoq!!7ms0c|`L$>(aL}Jay z%Q(?OGsp#Q6>x>M74{((G+@M?3je7g7L-i0unvoNh(${}A1bZ>a;QbL9OLXtandEO zMz|xLFS0$;*I977WZxfeq2KWq@+=Vt{5uI^;Z`X*cGR*<+;ThJE2hGCmc%oG<0-_6 z+{!uWq_hSc4$v>g&LggnGvNoz)*c?*#X0j5ea`J!%`D0qsgp6aUyJ=O0mB$DRD zbZoIWF|7{1bYODfGL96Lf%}>TbDkwxBoXsX^Egl=B|j}hhs`C zMJauM#;WcH#Yce#Q!Py%9P6vrJ6>lrc2N8))T36*e__wU<^Oe3F z6{zJwcYc~4aD~G4e08cQtqxXzqN0-&DU$nUgp5~Z#q1u+Cu zxLWOIH%qtH2u3Xtt=QdWTZj$NA$=69kR?&EJlkEiPD?i%Yny@JcupUvE@Uk>TZfHV ztq=TYL)>_WO=9!`jU8ZXhbAR|f}*?TEaC4(MBDfa%HrhcmBQtEE?{S2R9SH!7o|u2oBigV8rNsT@c> zvi~R6mWRy0VqRkK8Mw0&G#fOOYH7pZm`LEc$NHFp9mTwbrUX@yM5{qFN0S_(^uco! zSt^iFDE?y$DK6miLX+FC)*a6U2P*8G>ehBzeBVxh;SSbAv6tvO0n|pRX2ZZDs4W!S zX`x!W6>OvC)Ts{%q&r}Af?$LyavgYkA+W^3f@dUFpT2L?;Gd7dC$8{0>$yT2_cqMc z7A)a1?7G34);L&~-S?Q|U`XICN?IOsJQNZ*grp77L!p7=4z9*p4BsTR9x~CYlb@y> z1a+gV&p(KxuLndqO#}>4rfI7>MIei`HneYU_pSaI`MlnPNxt^W!G#9??toRSbbL{G zXrQ!+#e)Iki(*3qHAO7qe8v|ULj&`QIH!_M2@SL&ZF5$QFPa=0SY8BjiDYJI;K3pm zFM`m`!D!BcAX=oGplDkxtMaR*(bT7SE-bLEh^v70W^juoC|fK-IYYE{_5=@XCiHJ` zU&(idL47aB?%7W?j!xP)v_iqkj)KcD(fO}c2%T%%J=A7b5erp2abx4XV zdf;njG-7#=u8NkCJ=1ILlHAUQca@b}_G zpT+edG%5pfz*9$-ftJ&d+3*1GgjbRc=@-HS5l)IsMS6F5Al^xl zj7Yx}9vFi(oY1coKOYg8;N*!xfOT`AYAdRyRf-5$oQl7-l0~lcms5_wzd^~G<;18h z<<3bFfqN-wYjJ+8iwLZxbZLw8Z%A*Zw6ENm9}#%m$yy7m%bhzT0>4AjWi5C9Ga~Q` zC2i%-n-PJxDd{YC-iQbsMzRzLKSl&TLb4hNyCMRoove-8OO6O!q$KLihzRsK*ciBfFFwp44sZ3r(#FB^EVLzBhpY$lskJP0%_CnCWoio zxium%c{&HG0F);q0@mrgBGr~VpNI&!r^BF5WuJ-&%$m;nD$uQeMFbX565aYaBCwQ_ z==V<%f%~R&)fOij{dGiO<8-bDfpO)|Pa^`4OlOt89Eb=!gZ7p5hY^7n2#ogoA_8wr z7w|sB;MalaeC9Oe<0{doa*KME`$nbYD7Vbd`Q)xj`4l&z zULp;K~tdOQ~y zm{Y<|FI6aLxC&@1(YnD<-_1k@R+nh4NG?UvUxJq~8V#LDK3by9L-JlEp8+(t(Xb53 z7fQ4qy!5dG$v>2609=LC{t|62Q13_bFD0y%YB-1VrzKpz^6@1;zAB-&R7gB0=3+>o zw}eZ@oDxCaPq!_>7#AFd2Y}rwka&vO7DOVob#{>Ey}ce{A>j^nY4hO}ek1>9%nAVt zT-w=CbNrl7@dL49vdh7<1(Z>a3}9kH?SNIe2)5A0=FbF>AoP8oOG}?WE8WE78DiGmEMul5R$Ht$*4e1seK?uO^pkBJ$h4A=7^%wcrGeXUJ5%mRWHZ< zoL>uH5~e`SSX?UPxh${+lJm(A(Q?d*C;QX zHml|)YqrLh@yVn&Z!}zu&}>aEOSHOtA!*vJ6UyKlXDNddXLbU`(`&cpm%+Qm;wzq6 zhG%?~*L^;kqTO0vCgu&Aduz+oF!D7#Y1g$|o5}CQg zZe3T#!X`~lF|jbIs!(?8|CDJfvFPOO8qcv?-zc+MY_QnUa^8ttX1BgyCMcfGDQ1HW zxBP37ByMSqrl%vR)E8wz7H?5yDT0^asMluPB~m2Pkma4mdmCDtn;MLs`gYg@IvUy` z3U2+mEXYOvb0lO>ar^wI_7=mnLD*j7d$@<6=^3!s%q!!zrn-3-`N`F}h0Xi-I)TM* z?_q(UghrRU`K^_1n4@7>X*4_?#&5mXEmR>q)LpREjmN+Ch8+oC|JT=;ToIlCuk^61 z55GYsm!&B7fIEmZLkcn-fg6+DBz;gEi@&@fzoW z8XKYB>_0a|DH{Ce-NM#*j{qB@#adhe+* zSw%6H>4umY@|?KJ(1L=5yk7FV5SJ8ZVzhPB-^@>#BVIdyJL-E40}+&Eod5N5ad!Z-$2M)f@@;4}DX^ z*h@R2_G*uW-`YPl`s>V&AVi7n4LTCub7|wy895XGT;8em52gHCDlr@G-~FSTN3lB= zqY2fsV-$Nq?DW$9=5`$Sl8?qeyfvG8{r4F+M&;z8f?!`IwN91Ho~i7}&ph0Y3tq*6 zBhKdqrax-a;l0eJ9~8?zP5;S&(;2nUa;KCe$HjgHU6gIEt9R&Y{%{EiGC2OL;P zXz~tY)?VS}D_JcU{q3tJZ5 zL{M(9`h~~~3aNnRLv3O~rGWO8fEfkb);y15rzAX_#%TH=sX@x$sc6cD%7n__Rkl^u zR<`9(Td`LY>sA$+ms7Nt!%UPcrAmNbkHS{0E{Ff&2cCAQ&za%@=zpVO zfN6H-R>44w=K{%sLve3+jDMP)9aXHY0-EU6P^9AB3YraR3436CwUj$5ki^nha5QBCuz_2*hYCZtcGFbR;Lom;DT7{P4d5>k^7hsGuCg7-~Pxcc@79($}J zD>rx>r3>UyJrV@_tE!Jp(H-^euz48oYH33hGFilwkU#jtCwGme>z3NojMgNRvOr?U zJk=*?k{{t|Eayj~53!<-&r7DO;f5IGo{JzqayO?)ijxw#!|jv0S<=Xjg7f(qmY(?_ zTUaC$2L0u&{$iYx>s90nL^?$^j~o=QS6zU+O|cSAH8+{u&DfoPuL4Kufi3KUIJ=qv z?^X-STOj~Z+teC4VRx}Bt0>fmI2=v#bI_NrtU_EE`t(cKQMh-J@su>a5;WGN1o+s* zwZaHQk&V;>2?B;>1dJpVm1&ZXPORmBS}qg#*gI=n=qNuCUgEw}S{HAH8xLVtqX zWXp?X-pY0GuY$2 z8gQXWer+%xl2;75+0q5Y@BH5y-dwFbcBZ;4y={lxM+_}3JD%ldW@Knyl2u<=o zC%&Sz^GU7p1ch49i;8c^W3g2nWi}d8V8R&Uz=Kox^LefGLpmnke?7+ZYyN7(Q7{N0R!}FOO=%VpfOE#7>rzpI(3_p$GwEn7(A>9oL3^}DxNB}t# zQUKvTk9O)T3fG$@g^l*8w#%TMLaokY0UJ2rA4B%lCngb}Mcmg_R^S>1a=cV;hUyur z$4w}Bw{Fmow5(q6XJ_E`Lu|6w^TZ@7_cz!p)#qq}c79vSo2h=Yfx1qM8niQXCVb-w zG{_!C&lI>xGsqUhFsqsM%q;x1;15yhGpl@+8%LMSe0v&rf)e<#bZ%b#LerHfQE~L@3lpatH#q|9U3v!4M3e08mZ- zdM3Hq=y$#|lXDR1HauDdb^7(t`baio9v;Yev}$iC{phi6Xq#iT(2 zyz|;j4#gA(b8IA7#Ok+HZ=!*hp}Zcvw1AEU?@X8pg{F7fEDkOZ#^9aRv!Jah!zaA) z@Yy&^TWXs&i(Nb)ADy$bR{EGnA8Ti6z4XyeA6sT&bf9k2X7TgdmMjD0iCG8@aM>&D zRC7ZMATI%jSW4h@EL+lG4B5GF7GLU92KScx&M5XKKU$R~(OAB5L+!lt#H<0$%*BYo zhqTToaypuTN2?yKO3TXT4@BN6J~#!M4gZ`K1o0NWBg(y3R3+YK--q7G_-|)M^TfE> zq&D<)&VJv)Y`uK>ABQzhw9MA|5I>6{p-z${nzi^-9APw1+&^0t2nO>OjT+3;KJmnC z*#j#v1(G6O;W7njb;F|ow`CuQI7QV_uvMFwA94nyNG0ib84P23Ib zTT({*v{1)a;CW@=^g3_gGm6siN4IdBKcf@8Yo_+;f;y!FD9*u#G>@v~i|b-Vg*|z? zt`5H5Bq1%Vv*~XtcZ2rnJ+soPHNqnIs!ah2PpwpJU!!Kkwz3* zq)RLhqOX1WRZsLmOJ((j)CJw1p3K|u|2jRI z-AQwKrR3GPn)x;Je+S0}(9FEM=Q5p2^x6?EHkNH5FtAO09ME_UvH0FsF2C6^R|&=sMlinrqts6~R{q@cj~NHp z-3%ky+-ltZmARKbQXb7jy-1bS#deXMUV;+@RdA5 zL6Jb)z!64;)5}-ez=Q2Z=pj9+LDuGrM#3UTt-*&LG?A1hMjS6r;9u%Mrm1Z%G4G?n zA3lmy7rIIRj;N@si4J))h)`6Lw)F^zSxhL_J;zTdgickP*9qxVd%DX=@VqSe~GI;w2qYYuKMNJL!)ebyx zmpWC^^;y!Tx!|F8|2P+VWU{f*xTwx-zHKf&ZX)iEn>X-4K8__ok7J4nJYk-QZKXa> zOND695ZpBnk6)lMQcnu=2r_>juWUYoC_ZBIy4fl&)0Br?nha$U!MK8zR_Ernq*sea zorrs-jA|)mPZ@;E-S^DX;LLBIcLSo|OY>;X4~H%nuBC#zM}^YvL-RDS)NP;ljFLxl zO_R|ks=4RqX>1hQ;o#L891sTSL6Dc`)hV(D)pvrwma1a2^EIGZ+vlN2>l2=tH(1HI z`5G8;FNorN6|H!_2HZ3?NzJVRrB#NYq6h7+o6EZ$cu^WpTc(at;^Ndp7qt7{`3f<@ zcvQa7KcC`X_em>K=@}x4@z1A6X)cKV`SDQ53Cx}Hy4~C6bGAw{uaE=~JA{Od;mUgj zkQBuE*?8!PWWMi$@u}W>q;ck?og^bnCB5jo3AYCRe;jWa&~z?gtD!>+AC;l}>>qfA ziPm6eBC)VEIZ75Wi@M!M=JT#!c7bM+y0BchH6PXV3IEXrlHxQQ+zml^yAOI=g{R1x z3khjJMZf1x#($%*BtnozH!28zI)4<%;qa~8Sj3`}qMXE-x*FOj?=+-B8fEu9&~Q6c zmEH4g0}pMK8%t0v>8qvSdwqm*qk$A$c;=nJVDVLGcq6za4^)i|b4|!-)O50!+n+x` zvv(3U+%t#?B7u<(CT*iyMc6$7j@1Qbz8kMeDNpSh=yi-i{51nukMIj1BG5Z4X5^m? zq7=Vpbfch7$kn)6OJ^-zjEmqw6P@X!5^O|I7w@ih`;-pSV-`ebA&j z*i&hOlYZr^21ETzsjs;TphA2$+2-=s#h>YG&c__vKinvM+MBsQH-B!W+P z=M#rDQJfAvGqFh#g(^bRcoh{A7?i7iL3FlL{Z!L~T(Y2?K&+6FtSElED>C6rZ4u zct}&7c%*Tc_#+!iL{f+9Gb2Mqq!(hI*ocT-ef`}kgA5bDHpnVBIDp4R?b ztkP!p;|r*%Ax&+!b>(m!(2dc2SpMA1N`HNpdsolEA| zDnI&J)m$;A_q6=m^9KX4I*I>1X@`| zczNnF|nADg0T+hEgb>ui~ixR#|2aPe+wZdH!K z;8vmcTj>2-BQvDw-34S1`u~=hx1b(|FzWU#w9#mQ!fFr0Xq`4XfB*SE7B*u@%gk@d=yGr%TsNeISWnzrAB)$*FD0oTIk?k@u=;r zQu;vZynlZKMYHIrGKu4w$8dSc>ckFPL=!_j8@A~C#34OA~lsYkos)FUne*=wCE!RvuM%W zWHog`tgE4*1Jyl;CB$y-h?NUR7%=-sOf6cu%;vUdk1^#5njcmm*HYs8-CTHY;fbfhze9RxQ)#n zrktie_)|UCavo*R_^lCBfVTeO&_R6SA+i%A2H zfX81}r)aG|X>MqFWibtDuoG8qccORkF4RPt0;MZ-ynophx;uIo)64c(2D)-%F^vYA z<;Ci3gh`asyBM#9V-6_i%3w!+S((z2tcB@|b6N-XOY(b-XE~yAhww{x^9T5)^6!D3 zk>d3be(8m?5AZv9#}N@!cPe2J<)a$@q||hldsD$YhF_{ttxd%q#G-a6S3TQzFT5bG zFvatOUt!WOzn*I)xM5GhLIL(VSU1%ZN{Va=itK$M0+-UJvJ`hOOl!j%nyCCF;s}Yf zNx!Jr0%kR%>@4>RxGUB8qv|T>vgyVcjd@AZFg8Dv*GK3 zK3^L6C0!19-<43JlY0d@T#(aLLfRSjX4`Vy-e+*hpHEc%HHaSpwil1IzEF4L@!I$8m3{qpYUN-^(iheSyc9 zyl`pBk5dnJj>dmJ<6>2HxyRrA!lgMsK6sEyR8fv}?jQKiGR^7vfc`yq+|jeoZ1|x~ z4L7BM)|Q=NH!dN+(ywv%(SNyQn?$Y@WHM17EY~#In|^4!fv%bjBkm@jfZip7nz6&pnFz{ zxl)3pO?PH=1!k07{A1GArq%LknZ&_G+`gIzYd|ouSM_VB1^=N<(aD4V+qB@Y?^>$5 z<-WmiX~?m-v{kHScq{*Z8;NEUJh$;1l%ubOjl&dbK5fa^yVZ?IE3RYiUZ|c7+Neug z58b^5)4(xb+)ekP`cyi2BHSX|6o!HVerOxoVav>tRA$88z83GssA;O1TrpZYNqC{> zD+xkRTApttt;fA!F^qdgH`}ZgUXaX-5%dbJ@My9dl zEXba7e&M|Ayym>>yyCpz?00O(&u$*OkkeLxI?Q@nSZHihK0rEE*saLchEn-dI#o`M zjog_zG4epBj2rfcN5Yxyxs@X;@k!l0Yz&{solHHJ`a$Zwq_Xpd+~V}#(ihS{&30w~ zmC>?`vwz6EiEZzx;g^PQb~n*Po_L^Jad7#c91DC7;(@%JT#uQ&D_>2ai6@U+y7l|9 zjmgv1kMeRW8m!A>^az4~5Q@`0#_&>poA%f2SxlRDox@&rWUCQg-)vo8$?fQ>!C69g-IVt!H9Bf!%C2`pm=#zwY@==x! z!&=5}D=M*m_>|}=UcCt?+exSBtAhI#Up;_DNv(SJC5wT+t#B&Xzo9k0b<^M1eRoG- zULmk%Vb--gHxAdu_lh-fI8=d&&p(!(H_w|#k{-dB8VB|X?O`7AK@sqWazpcoi$wsb zqO>d8w^mJ8|s+T62F5zlbK7$-LfHutXVQ^XOjM;4^qr--ARepQ_EKwieE8&k@u(DxNjw4TAp5pXF^FY7=qH(BjhgX{Khb zNDcucxJ@18c3jFx8`IIU;d5WDCf+oF0|SGUHr~l+YA&PrT#**ACjM=xaeP`^m#*Y< zMPgA%n>1IX6{U#=Q;SPHn;5^03e`$c6Mm1NE!_q(#Kh2N7iUv`>Ublg1wrxilX9`o)WTJmo_DvtZBW_|O(jg-J~qHiioam0K=eXq zw+}3L6ON;j?BM$Yce^RSM-}QC86Ry%%5?Z`gPGrtE;sKsH=EyaQ;wJ~BjpYAv^i@w zfmid1-xW1?X@FxeX)E=KWtJ~oN%C2gL>DG$QAySs?xG&-wP;O(k2Odc&|%;bczg(k zq|M!yv>t#(!DwhteI4NkR2=NWzb=jpw9!zuv&WdJ>9#(tb>el>P?B**70d7*3-{fS z*K3hRmA>_o$(;>v=hAMe5F!-_oTEUw?(vY;EvB8@K}H^fbtEaA+d*dP6uyX)WJ-}G z3AdHnn*{>daRU%3qoJinhe4`Q4i!oLXozka@)frlJ;rQU>U)CF^s&H%Me~uAm=M^l zcAa`Jd-Vm2;=L9Lg_u&Z%-OZAtsu5NjaR_n^K*B1X&r8o&E{*sDAO=_rG zx)+0qn=$H7(12?%CAqgc{h-wv_|Un>I%r9*mwM$YNQg`Fi#se07}NxMt@FLN5P(a_ zy01haK4g8v0tc->mT3P;l&G~AD`A}zT&G`rSi)%%eD=Uvm{=ELjYtwWT{?@wxt83G zE;$xBT_Uw*mGI*W2tQt`5)PMZ2#nXoQ9e^cG!N8tl(7?tZ7RdCoVQTmho8Wf;=@41!Kp|<>80&s@KDX4fQK@J_SDoA zm#_EF4?k=UC-KPAI3tugdB6C+x;hB{6@%Ido KPbTN%_WuC=d|EI7 literal 0 HcmV?d00001 From 6616904fbbed2aac875f7f26ba14dff60e61779d Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Tue, 11 Jan 2022 23:32:30 +0100 Subject: [PATCH 10/21] Fix log2file.fb logopen so that it restores isfile after opening the logfile --- 8086/msdos/tests/LOG2FILE.FB | 2 +- 8086/msdos/tests/log2file.fth | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/8086/msdos/tests/LOG2FILE.FB b/8086/msdos/tests/LOG2FILE.FB index 5f100db..052e86a 100644 --- a/8086/msdos/tests/LOG2FILE.FB +++ b/8086/msdos/tests/LOG2FILE.FB @@ -1 +1 @@ -\ logging to a text file phz 03jan22 \ load screen phz 04jan22 1 2 +thru \ log-type log-emit log-cr alsologtofile phz 04jan22 context @ dos also context ! \ vocabulary log dos also log definitions file logfile variable logfcb : log-type 2dup (type ds@ -rot logfcb @ lfputs ; : log-emit dup (emit logfcb @ fputc ; : log-cr (cr #cr logfcb @ fputc #lf logfcb @ fputc ; Output: alsologtofile log-emit log-cr log-type (del (page (at (at? ; \ logopen logclose phz 04jan22 : logopen ( -- ) logfile make isfile@ dup freset logfcb ! alsologtofile ; : logclose ( -- ) display logfcb @ fclose ; \ No newline at end of file +\ logging to a text file phz 03jan22 \ load screen phz 04jan22 1 2 +thru \ log-type log-emit log-cr alsologtofile phz 04jan22 context @ dos also context ! \ vocabulary log dos also log definitions file logfile variable logfcb : log-type 2dup (type ds@ -rot logfcb @ lfputs ; : log-emit dup (emit logfcb @ fputc ; : log-cr (cr #cr logfcb @ fputc #lf logfcb @ fputc ; Output: alsologtofile log-emit log-cr log-type (del (page (at (at? ; \ logopen logclose phz 11jan22 : logopen ( -- ) isfile push logfile make isfile@ dup freset logfcb ! alsologtofile ; : logclose ( -- ) display logfcb @ fclose ; \ No newline at end of file diff --git a/8086/msdos/tests/log2file.fth b/8086/msdos/tests/log2file.fth index 255ee47..968255d 100644 --- a/8086/msdos/tests/log2file.fth +++ b/8086/msdos/tests/log2file.fth @@ -58,9 +58,10 @@ Output: alsologtofile \ *** Block No. 3, Hexblock 3 -\ logopen logclose phz 04jan22 +\ logopen logclose phz 11jan22 : logopen ( -- ) + isfile push logfile make isfile@ dup freset logfcb ! alsologtofile ; @@ -73,4 +74,3 @@ Output: alsologtofile - From 16857ea57a7cee642bdfeb020a7405b5522bb378 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Tue, 11 Jan 2022 23:34:29 +0100 Subject: [PATCH 11/21] Let fb2fth.py replace zero bytes in block files with a ^@ sequence. Zero bytes in text files can't be handled by at least some editors. --- tools/fb2fth.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/fb2fth.py b/tools/fb2fth.py index 5403cad..5493000 100755 --- a/tools/fb2fth.py +++ b/tools/fb2fth.py @@ -15,7 +15,7 @@ def readToString(inFile): while(offset < len(block)): # sys.stderr.write("block %d offset %d\n" % (blockNo, offset)) line = block[offset:offset+64].decode(encoding="cp437") - result.append(line.rstrip()) + result.append(line.rstrip().replace('\0', '^@')) offset += 64 blockNo += 1 return result From 533e73c29dfc9dcea448442fd08c6abd8bf64f7c Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Tue, 11 Jan 2022 23:40:24 +0100 Subject: [PATCH 12/21] - enable run-in-dosbox.sh to include either .fb or .fth files - add first test for including an .fth file - add generic rules to convert lowercase .fb files to .fth files - check in the tools/echo-toupper/tolower.py files that I left out earlier --- 8086/msdos/Makefile | 17 +++++++++++++++-- 8086/msdos/emulator/run-in-dosbox.sh | 6 ++++-- 8086/msdos/tests/golden/incltest.golden | 2 ++ 8086/msdos/tests/incltest.fth | 9 +++++++++ 8086/msdos/v4thfile.com | Bin 32228 -> 32228 bytes tools/echo-tolower.py | 5 +++++ tools/echo-toupper.py | 5 +++++ 7 files changed, 40 insertions(+), 4 deletions(-) create mode 100644 8086/msdos/tests/golden/incltest.golden create mode 100644 8086/msdos/tests/incltest.fth create mode 100755 tools/echo-tolower.py create mode 100755 tools/echo-toupper.py diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index 0a385a5..8fbfd2c 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -7,12 +7,19 @@ clean: v4thfile.com: volks4th.com src/V4THFILE.FB \ emulator/run-in-dosbox.sh rm -f V4THFILE.COM v4thfile.com - ./emulator/run-in-dosbox.sh volks4th.com v4thfile + ./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 + ./emulator/run-in-dosbox.sh volks4th.com logtest.fb logtest.golden: tests/golden/logtest.golden cp -p $< $@ @@ -21,6 +28,12 @@ logtest.golden: tests/golden/logtest.golden rm -f $@ tests/evaluate-test.sh $(basename $@) +src/%.fth: src/%.fb ../../tools/fb2fth.py + ../../tools/fb2fth.py $< $@ + +tests/%.fth: tests/%.fb ../../tools/fb2fth.py + ../../tools/fb2fth.py $< $@ + fbfiles = $(wildcard src/*.FB tests/*.FB) fthfiles = $(patsubst %.fb, %.fth, \ $(shell ../../tools/echo-tolower.py $(fbfiles))) diff --git a/8086/msdos/emulator/run-in-dosbox.sh b/8086/msdos/emulator/run-in-dosbox.sh index 6675b89..6b7d176 100755 --- a/8086/msdos/emulator/run-in-dosbox.sh +++ b/8086/msdos/emulator/run-in-dosbox.sh @@ -1,17 +1,19 @@ #!/bin/bash set -e +set -x emulatordir="$(realpath --relative-to="$PWD" "$(dirname "${BASH_SOURCE[0]}")")" basedir="$(realpath --relative-to="$PWD" "${emulatordir}/..")" forth="$1" -include_basename="$2" +include_filename="$2" +include_basename="${include_filename%.*}" forthcmd="" exit="" bye="" if [ -n "${include_basename}" ]; then - forthcmd="include ${include_basename}.fb" + forthcmd="include ${include_filename}" logname="${include_basename}.log" doslogname="$(echo ${logname}|tr '[:lower:]' '[:upper:]')" rm -f "${logname}" "${doslogname}" diff --git a/8086/msdos/tests/golden/incltest.golden b/8086/msdos/tests/golden/incltest.golden new file mode 100644 index 0000000..eb978d3 --- /dev/null +++ b/8086/msdos/tests/golden/incltest.golden @@ -0,0 +1,2 @@ +hello, world +hello, world, from test-hello diff --git a/8086/msdos/tests/incltest.fth b/8086/msdos/tests/incltest.fth new file mode 100644 index 0000000..27cfcfd --- /dev/null +++ b/8086/msdos/tests/incltest.fth @@ -0,0 +1,9 @@ + +include log2file.fb +logopen incltest.log + +.( hello, world) cr +: test-hello ." hello, world, from test-hello" cr ; +test-hello + +logclose diff --git a/8086/msdos/v4thfile.com b/8086/msdos/v4thfile.com index 28b7ff64d25737c7030dcdeaa39084e4627f861c..3f2412ec39aa57535fb4a55f59973520cdedb812 100644 GIT binary patch delta 23 fcmaFzoAJqS#tof(jJlJ%_^c;7DsO(l_a_ekhGz<- delta 28 kcmaFzoAJqS#tof(jE0lD_^eqJk}6XtI?8W;!S^Q*0JYQ%2mk;8 diff --git a/tools/echo-tolower.py b/tools/echo-tolower.py new file mode 100755 index 0000000..a46699f --- /dev/null +++ b/tools/echo-tolower.py @@ -0,0 +1,5 @@ +#!/usr/bin/python3 + +import sys + +print(' '.join(a.lower() for a in sys.argv[1:])) diff --git a/tools/echo-toupper.py b/tools/echo-toupper.py new file mode 100755 index 0000000..655fa3e --- /dev/null +++ b/tools/echo-toupper.py @@ -0,0 +1,5 @@ +#!/usr/bin/python3 + +import sys + +print(' '.join(a.upper() for a in sys.argv[1:])) From 7dafbfcc3ed6fafdbc5b44ed6cfb5c29aa8f3829 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Wed, 12 Jan 2022 22:25:40 +0100 Subject: [PATCH 13/21] Rename DOS-created uppercase *.FB files to lowercase, with corresponding Makefile changes. --- 8086/msdos/Makefile | 27 ++++++++++++------- 8086/msdos/src/{INCLUDE.FB => include.fb} | 0 8086/msdos/src/{V4THFILE.FB => v4thfile.fb} | 0 8086/msdos/tests/{LOG2FILE.FB => log2file.fb} | 0 8086/msdos/tests/{LOGTEST.FB => logtest.fb} | 0 5 files changed, 18 insertions(+), 9 deletions(-) rename 8086/msdos/src/{INCLUDE.FB => include.fb} (100%) rename 8086/msdos/src/{V4THFILE.FB => v4thfile.fb} (100%) rename 8086/msdos/tests/{LOG2FILE.FB => log2file.fb} (100%) rename 8086/msdos/tests/{LOGTEST.FB => logtest.fb} (100%) diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index 8fbfd2c..a1c3acf 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -1,23 +1,33 @@ -test: logtest.result +fbfiles = $(wildcard src/*.fb tests/*.fb) +fthfiles = $(patsubst %.fb, %.fth, $(fbfiles)) + +fbfiles_uppercase = $(wildcard src/*.FB tests/*.FB) +fthfiles_caseconverted = $(patsubst %.fb, %.fth, \ + $(shell ../../tools/echo-tolower.py $(fbfiles_uppercase))) + +test: incltest.result logtest.result + +fth: $(fthfiles) $(fthfiles_caseconverted) clean: rm -f *.log *.LOG *.result *.golden -v4thfile.com: volks4th.com src/V4THFILE.FB \ + +v4thfile.com: volks4th.com src/include.fb src/v4thfile.fb \ emulator/run-in-dosbox.sh rm -f V4THFILE.COM v4thfile.com ./emulator/run-in-dosbox.sh volks4th.com v4thfile.fb mv V4THFILE.COM v4thfile.com -incltest.log: v4thfile.com tests/LOG2FILE.FB tests/incltest.fth \ +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 \ +logtest.log: volks4th.com tests/log2file.fb tests/logtest.fb \ emulator/run-in-dosbox.sh ./emulator/run-in-dosbox.sh volks4th.com logtest.fb @@ -34,11 +44,10 @@ src/%.fth: src/%.fb ../../tools/fb2fth.py tests/%.fth: tests/%.fb ../../tools/fb2fth.py ../../tools/fb2fth.py $< $@ -fbfiles = $(wildcard src/*.FB tests/*.FB) -fthfiles = $(patsubst %.fb, %.fth, \ - $(shell ../../tools/echo-tolower.py $(fbfiles))) - -fth: $(fthfiles) +# Collective rule for converting uppercase *.FB to lowercase *.fth. +# Because make doesn't provide case changing pattern matching, +# file-by-file dependencies as with the src/%.fth and tests/%.fth +# rules doesn't seem feasible here, hence the one collective rule. .ONESHELL: $(fthfiles): $(fbfiles) diff --git a/8086/msdos/src/INCLUDE.FB b/8086/msdos/src/include.fb similarity index 100% rename from 8086/msdos/src/INCLUDE.FB rename to 8086/msdos/src/include.fb diff --git a/8086/msdos/src/V4THFILE.FB b/8086/msdos/src/v4thfile.fb similarity index 100% rename from 8086/msdos/src/V4THFILE.FB rename to 8086/msdos/src/v4thfile.fb diff --git a/8086/msdos/tests/LOG2FILE.FB b/8086/msdos/tests/log2file.fb similarity index 100% rename from 8086/msdos/tests/LOG2FILE.FB rename to 8086/msdos/tests/log2file.fb diff --git a/8086/msdos/tests/LOGTEST.FB b/8086/msdos/tests/logtest.fb similarity index 100% rename from 8086/msdos/tests/LOGTEST.FB rename to 8086/msdos/tests/logtest.fb From c612a614551c11a36b8832f8ff4a368fca3748f0 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sat, 15 Jan 2022 23:44:11 +0100 Subject: [PATCH 14/21] Change INCLUDE so that it saves and restores the tib before and after interpret-via-tib instead of clearing it after. This way, commands after a .fth include can be passed to v4fthfile.com, e.g. a bye to terminate a make-controlled test run. --- 8086/msdos/src/include.fb | 2 +- 8086/msdos/src/include.fth | 33 ++++++++++++++++++++++++++------- 2 files changed, 27 insertions(+), 8 deletions(-) diff --git a/8086/msdos/src/include.fb b/8086/msdos/src/include.fb index 55f70e8..71dccdd 100644 --- a/8086/msdos/src/include.fb +++ b/8086/msdos/src/include.fb @@ -1 +1 @@ -\ include for stream sources phz 06jan22 \ load screen phz 06jan22 1 3 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline probe-for-fb phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; : probe-for-fb ( -- flag ) \ probes whether current file looks like a block file /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN LOOP true ; \ interpret-via-tib include phz 06jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) pushfile use probe-for-fb isfile@ freset IF 1 load close exit THEN blk @ Abort" no include from blk" interpret-via-tib close #tib off >in off ; \ No newline at end of file +\ include for stream sources phz 06jan22 \ load screen phz 15jan22 1 4 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline probe-for-fb phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; : probe-for-fb ( -- flag ) \ probes whether current file looks like a block file /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN LOOP true ; \ save/restoretib phz 15jan22 100 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib include phz 15jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) pushfile use probe-for-fb isfile@ freset IF 1 load close exit THEN savetib >r interpret-via-tib close r> restoretib ; \ No newline at end of file diff --git a/8086/msdos/src/include.fth b/8086/msdos/src/include.fth index 292c4d5..98f6273 100644 --- a/8086/msdos/src/include.fth +++ b/8086/msdos/src/include.fth @@ -20,9 +20,9 @@ \ *** Block No. 1, Hexblock 1 -\ load screen phz 06jan22 +\ load screen phz 15jan22 - 1 3 +thru + 1 4 +thru @@ -77,18 +77,37 @@ \ *** Block No. 4, Hexblock 4 -\ interpret-via-tib include phz 06jan22 +\ save/restoretib phz 15jan22 + + 100 constant /stash + create stash[ /stash allot here constant ]stash + variable stash> stash[ stash> ! + + : savetib ( -- n ) + #tib @ >in @ - dup stash> @ + ]stash u> + abort" tib stash overflow" >r + tib >in @ + stash> @ r@ cmove + r@ stash> +! r> ; + + : restoretib ( n -- ) + dup >r negate stash> +! stash> @ tib r@ cmove + r> #tib ! >in off ; + + +\ *** Block No. 5, Hexblock 5 + +\ interpret-via-tib include phz 15jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) - pushfile use + pushfile use probe-for-fb isfile@ freset IF 1 load close exit THEN - blk @ Abort" no include from blk" - interpret-via-tib close - #tib off >in off ; + savetib >r interpret-via-tib close r> restoretib ; + + From 5dc52454a63c5a27c9ef4bde8fbbae3b9a9c0468 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 16 Jan 2022 00:29:52 +0100 Subject: [PATCH 15/21] Add proper initialization of stash> after abort/error/restart. --- 8086/msdos/src/include.fb | 2 +- 8086/msdos/src/include.fth | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/8086/msdos/src/include.fb b/8086/msdos/src/include.fb index 71dccdd..41a06b7 100644 --- a/8086/msdos/src/include.fb +++ b/8086/msdos/src/include.fb @@ -1 +1 @@ -\ include for stream sources phz 06jan22 \ load screen phz 15jan22 1 4 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline probe-for-fb phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; : probe-for-fb ( -- flag ) \ probes whether current file looks like a block file /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN LOOP true ; \ save/restoretib phz 15jan22 100 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib include phz 15jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) pushfile use probe-for-fb isfile@ freset IF 1 load close exit THEN savetib >r interpret-via-tib close r> restoretib ; \ No newline at end of file +\ include for stream sources phz 06jan22 \ load screen phz 15jan22 1 4 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline probe-for-fb phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; : probe-for-fb ( -- flag ) \ probes whether current file looks like a block file /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN LOOP true ; \ save/restoretib phz 16jan22 $50 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib include phz 16jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) pushfile use probe-for-fb isfile@ freset IF 1 load close exit THEN savetib >r interpret-via-tib close r> restoretib ; : (stashquit stash[ stash> ! (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart \ No newline at end of file diff --git a/8086/msdos/src/include.fth b/8086/msdos/src/include.fth index 98f6273..97399d4 100644 --- a/8086/msdos/src/include.fth +++ b/8086/msdos/src/include.fth @@ -77,9 +77,9 @@ \ *** Block No. 4, Hexblock 4 -\ save/restoretib phz 15jan22 +\ save/restoretib phz 16jan22 - 100 constant /stash + $50 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! @@ -96,7 +96,7 @@ \ *** Block No. 5, Hexblock 5 -\ interpret-via-tib include phz 15jan22 +\ interpret-via-tib include phz 16jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret @@ -107,8 +107,8 @@ probe-for-fb isfile@ freset IF 1 load close exit THEN savetib >r interpret-via-tib close r> restoretib ; - - - + : (stashquit stash[ stash> ! (quit ; + : stashrestore ['] (stashquit IS 'quit ; + ' stashrestore IS 'restart From 53beef0d01f332d018688dd8384f53f421b52fbf Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 16 Jan 2022 00:30:36 +0100 Subject: [PATCH 16/21] Update v4thfile.com binary - v4th with include *.fth file interface --- 8086/msdos/v4thfile.com | Bin 32228 -> 32530 bytes 1 file changed, 0 insertions(+), 0 deletions(-) diff --git a/8086/msdos/v4thfile.com b/8086/msdos/v4thfile.com index 3f2412ec39aa57535fb4a55f59973520cdedb812..7df6e127a3342770b267f18a81a9bc85cae2b02a 100644 GIT binary patch delta 667 zcmaFzn{m=V#tDi{LiHP!)A$$-CwK8#vnV80rcQK}-~574ft%%f-S@i9JW|X;Ol`D4E9Kq3}9f{l2^+H=0!gjXLa=P@eff@_;;+0 zN5UZC(6N6&JwRY%00u@TmgXj_Yk>j{2Obny$ndc-fu$L2c%Z-r$hXLW2m(o#Ew#05 zu~55i)Us^31-7d`*u(C*cn6UGvX(vAG0Zi@(@9UVo&P+`2OySUk7WH+d!FSJ+vD0B z99I>EN-~oaic1oUGZga6Qj5}Z^2@g|iwc00eqsYDyvOXrcaQl~tt{&)W?2@NEkA0x zf?R_`{DUCoMzU^W=3oa&gA|Jj++!B<;XB3L&i@c-oe_sD3+oo&y2%AK8bC%}-Q+nn z3iV8N+n6WS&9gqm990LBUscDY0ro{;sAq_tWLxd0+J`J>6+lvV>Uh91P#g6m9XVds z#mPMfO7eu6gm}1l`nc*j`}-;YDL1DC3!Y;&kl+z8F!%!sRWliQaGe2zGKPAX$T1Me zv4C+Ijvc#p?b<&?_yXlDEOL$^$%8c1vGM$X2>m+)j73-^@<~WY6acXVA4C$wga8O1 wBnMI>QNRimD7!P!QAA$=X!H_NQrS+$#aq?m=6DwsA4>ahEB zsD;d2%D})NvRR=zfN^p|tp*Frmb}`@YibqL{_vk?xvD6fm#>hSmz-0YlB$qal%K1R zl#|_5JI}hE--zP_5Kk7U6RiiD00$L3HD}J8DTDAIBqUViqya$y>LH2|>VZn${JRDO#~}KF Date: Sun, 16 Jan 2022 11:06:28 +0100 Subject: [PATCH 17/21] Missing Makefile rule fix for fthfiles_caseconverted --- 8086/msdos/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index a1c3acf..0e88d50 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -50,7 +50,7 @@ tests/%.fth: tests/%.fb ../../tools/fb2fth.py # rules doesn't seem feasible here, hence the one collective rule. .ONESHELL: -$(fthfiles): $(fbfiles) +$(fthfiles_caseconverted): $(fbfiles_uppercase) set -x for fb in $^ do From 69a959d618aed0157ffd65b6b97d547ecaa87eac Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 16 Jan 2022 11:06:55 +0100 Subject: [PATCH 18/21] Print file name when including file --- 8086/msdos/src/include.fb | 2 +- 8086/msdos/src/include.fth | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/8086/msdos/src/include.fb b/8086/msdos/src/include.fb index 41a06b7..5430313 100644 --- a/8086/msdos/src/include.fb +++ b/8086/msdos/src/include.fb @@ -1 +1 @@ -\ include for stream sources phz 06jan22 \ load screen phz 15jan22 1 4 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline probe-for-fb phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; : probe-for-fb ( -- flag ) \ probes whether current file looks like a block file /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN LOOP true ; \ save/restoretib phz 16jan22 $50 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib include phz 16jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) pushfile use probe-for-fb isfile@ freset IF 1 load close exit THEN savetib >r interpret-via-tib close r> restoretib ; : (stashquit stash[ stash> ! (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart \ No newline at end of file +\ include for stream sources phz 06jan22 \ load screen phz 15jan22 1 4 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline probe-for-fb phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; : probe-for-fb ( -- flag ) \ probes whether current file looks like a block file /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN LOOP true ; \ save/restoretib phz 16jan22 $50 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib include phz 16jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) pushfile use file? cr probe-for-fb isfile@ freset IF 1 load close exit THEN savetib >r interpret-via-tib close r> restoretib ; : (stashquit stash[ stash> ! (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart \ No newline at end of file diff --git a/8086/msdos/src/include.fth b/8086/msdos/src/include.fth index 97399d4..9debffd 100644 --- a/8086/msdos/src/include.fth +++ b/8086/msdos/src/include.fth @@ -103,7 +103,7 @@ r> UNTIL ; : include ( -- ) - pushfile use + pushfile use file? cr probe-for-fb isfile@ freset IF 1 load close exit THEN savetib >r interpret-via-tib close r> restoretib ; From 48f488e58429f5569352f22fc7685b43cacc0157 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 16 Jan 2022 13:42:34 +0100 Subject: [PATCH 19/21] Add fixed \ definition that can comment out tib lines, too. --- 8086/msdos/src/include.fb | 2 +- 8086/msdos/src/include.fth | 23 +++++++++++++++++++++-- 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/8086/msdos/src/include.fb b/8086/msdos/src/include.fb index 5430313..b7b8838 100644 --- a/8086/msdos/src/include.fb +++ b/8086/msdos/src/include.fb @@ -1 +1 @@ -\ include for stream sources phz 06jan22 \ load screen phz 15jan22 1 4 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline probe-for-fb phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; : probe-for-fb ( -- flag ) \ probes whether current file looks like a block file /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN LOOP true ; \ save/restoretib phz 16jan22 $50 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib include phz 16jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) pushfile use file? cr probe-for-fb isfile@ freset IF 1 load close exit THEN savetib >r interpret-via-tib close r> restoretib ; : (stashquit stash[ stash> ! (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart \ No newline at end of file +\ include for stream sources phz 06jan22 \ load screen phz 16jan22 1 5 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline probe-for-fb phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; : probe-for-fb ( -- flag ) \ probes whether current file looks like a block file /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN LOOP true ; \ save/restoretib phz 16jan22 $50 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib include phz 16jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) pushfile use file? cr probe-for-fb isfile@ freset IF 1 load close exit THEN savetib >r interpret-via-tib close r> restoretib ; : (stashquit stash[ stash> ! (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart \ \ phz 16jan22 : \ blk @ IF >in @ negate c/l mod >in +! ELSE #tib @ >in ! THEN ; immediate \ No newline at end of file diff --git a/8086/msdos/src/include.fth b/8086/msdos/src/include.fth index 9debffd..2055900 100644 --- a/8086/msdos/src/include.fth +++ b/8086/msdos/src/include.fth @@ -20,9 +20,9 @@ \ *** Block No. 1, Hexblock 1 -\ load screen phz 15jan22 +\ load screen phz 16jan22 - 1 4 +thru + 1 5 +thru @@ -112,3 +112,22 @@ ' stashrestore IS 'restart + +\ *** Block No. 6, Hexblock 6 + +\ \ phz 16jan22 + + : \ blk @ IF >in @ negate c/l mod >in +! + ELSE #tib @ >in ! THEN ; immediate + + + + + + + + + + + + From fe2d6e25d1ebffd8129e59013a268de4f5d118b4 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 16 Jan 2022 13:43:38 +0100 Subject: [PATCH 20/21] Add a tweak to log2file.fb such that it can also be included as log2file.fth --- 8086/msdos/tests/log2file.fb | 2 +- 8086/msdos/tests/log2file.fth | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/8086/msdos/tests/log2file.fb b/8086/msdos/tests/log2file.fb index 052e86a..50cdd7d 100644 --- a/8086/msdos/tests/log2file.fb +++ b/8086/msdos/tests/log2file.fb @@ -1 +1 @@ -\ logging to a text file phz 03jan22 \ load screen phz 04jan22 1 2 +thru \ log-type log-emit log-cr alsologtofile phz 04jan22 context @ dos also context ! \ vocabulary log dos also log definitions file logfile variable logfcb : log-type 2dup (type ds@ -rot logfcb @ lfputs ; : log-emit dup (emit logfcb @ fputc ; : log-cr (cr #cr logfcb @ fputc #lf logfcb @ fputc ; Output: alsologtofile log-emit log-cr log-type (del (page (at (at? ; \ logopen logclose phz 11jan22 : logopen ( -- ) isfile push logfile make isfile@ dup freset logfcb ! alsologtofile ; : logclose ( -- ) display logfcb @ fclose ; \ No newline at end of file +\ logging to a text file phz 03jan22 \ load screen phz 16jan22 : (blk blk @ 0= IF ascii ) parse 2drop THEN ; (blk 1 2 +thru ( ) \ log-type log-emit log-cr alsologtofile phz 04jan22 context @ dos also context ! \ vocabulary log dos also log definitions file logfile variable logfcb : log-type 2dup (type ds@ -rot logfcb @ lfputs ; : log-emit dup (emit logfcb @ fputc ; : log-cr (cr #cr logfcb @ fputc #lf logfcb @ fputc ; Output: alsologtofile log-emit log-cr log-type (del (page (at (at? ; \ logopen logclose phz 11jan22 : logopen ( -- ) isfile push logfile make isfile@ dup freset logfcb ! alsologtofile ; : logclose ( -- ) display logfcb @ fclose ; \ No newline at end of file diff --git a/8086/msdos/tests/log2file.fth b/8086/msdos/tests/log2file.fth index 968255d..8f246c7 100644 --- a/8086/msdos/tests/log2file.fth +++ b/8086/msdos/tests/log2file.fth @@ -20,11 +20,11 @@ \ *** Block No. 1, Hexblock 1 -\ load screen phz 04jan22 - - 1 2 +thru +\ load screen phz 16jan22 + : (blk blk @ 0= IF ascii ) parse 2drop THEN ; + (blk 1 2 +thru ( ) From 9a568b3a03f50a12859310e3e2f5691a88120dda Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 16 Jan 2022 21:16:48 +0100 Subject: [PATCH 21/21] Copying over the Hayes tester tests from C64 to msdos VolksForth. 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. --- 8086/msdos/Makefile | 29 +- 8086/msdos/emulator/run-in-dosbox.sh | 1 - 8086/msdos/src/include.fb | 2 +- 8086/msdos/src/include.fth | 2 +- 8086/msdos/tests/ans-shim.fth | 101 ++ 8086/msdos/tests/block.fth | 676 +++++++++++++ 8086/msdos/tests/core.fr | 1010 +++++++++++++++++++ 8086/msdos/tests/coreacpt.fth | 35 + 8086/msdos/tests/coreext.fth | 769 ++++++++++++++ 8086/msdos/tests/coreplus.fth | 306 ++++++ 8086/msdos/tests/double.fth | 438 ++++++++ 8086/msdos/tests/errorrep.fth | 88 ++ 8086/msdos/tests/golden/block.golden | 134 +++ 8086/msdos/tests/golden/core.golden | 23 + 8086/msdos/tests/golden/coreext.golden | 52 + 8086/msdos/tests/golden/coreplus.golden | 5 + 8086/msdos/tests/golden/double.golden | 3 + 8086/msdos/tests/golden/prelim.golden | 41 + 8086/msdos/tests/golden/report-blk.golden | 21 + 8086/msdos/tests/golden/report-noblk.golden | 21 + 8086/msdos/tests/prelim.fth | 233 +++++ 8086/msdos/tests/test-blk.fth | 25 + 8086/msdos/tests/test-min.fth | 15 + 8086/msdos/tests/test-std.fth | 24 + 8086/msdos/tests/tester.fth | 66 ++ 8086/msdos/tests/util.fth | 143 +++ 8086/msdos/v4thfile.com | Bin 32530 -> 32578 bytes 27 files changed, 4251 insertions(+), 12 deletions(-) create mode 100644 8086/msdos/tests/ans-shim.fth create mode 100644 8086/msdos/tests/block.fth create mode 100644 8086/msdos/tests/core.fr create mode 100644 8086/msdos/tests/coreacpt.fth create mode 100644 8086/msdos/tests/coreext.fth create mode 100644 8086/msdos/tests/coreplus.fth create mode 100644 8086/msdos/tests/double.fth create mode 100644 8086/msdos/tests/errorrep.fth create mode 100644 8086/msdos/tests/golden/block.golden create mode 100644 8086/msdos/tests/golden/core.golden create mode 100644 8086/msdos/tests/golden/coreext.golden create mode 100644 8086/msdos/tests/golden/coreplus.golden create mode 100644 8086/msdos/tests/golden/double.golden create mode 100644 8086/msdos/tests/golden/prelim.golden create mode 100644 8086/msdos/tests/golden/report-blk.golden create mode 100644 8086/msdos/tests/golden/report-noblk.golden create mode 100644 8086/msdos/tests/prelim.fth create mode 100644 8086/msdos/tests/test-blk.fth create mode 100644 8086/msdos/tests/test-min.fth create mode 100644 8086/msdos/tests/test-std.fth create mode 100644 8086/msdos/tests/tester.fth create mode 100644 8086/msdos/tests/util.fth diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index 0e88d50..6d85891 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -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 diff --git a/8086/msdos/emulator/run-in-dosbox.sh b/8086/msdos/emulator/run-in-dosbox.sh index 6b7d176..2162aa6 100755 --- a/8086/msdos/emulator/run-in-dosbox.sh +++ b/8086/msdos/emulator/run-in-dosbox.sh @@ -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}/..")" diff --git a/8086/msdos/src/include.fb b/8086/msdos/src/include.fb index b7b8838..2a80fc0 100644 --- a/8086/msdos/src/include.fb +++ b/8086/msdos/src/include.fb @@ -1 +1 @@ -\ include for stream sources phz 06jan22 \ load screen phz 16jan22 1 5 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline probe-for-fb phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; : probe-for-fb ( -- flag ) \ probes whether current file looks like a block file /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN LOOP true ; \ save/restoretib phz 16jan22 $50 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib include phz 16jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) pushfile use file? cr probe-for-fb isfile@ freset IF 1 load close exit THEN savetib >r interpret-via-tib close r> restoretib ; : (stashquit stash[ stash> ! (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart \ \ phz 16jan22 : \ blk @ IF >in @ negate c/l mod >in +! ELSE #tib @ >in ! THEN ; immediate \ No newline at end of file +\ include for stream sources phz 06jan22 \ load screen phz 16jan22 1 5 +thru \ fib /fib #fib eolf? phz 06jan22 context @ dos also context ! $50 constant /tib variable tibeof tibeof off : eolf? ( c -- f ) \ f=-1: not yet eol; store c and continue \ f=0: eol but not yet eof; return line and flag continue \ f=1: eof: return line and flag eof tibeof off dup #lf = IF drop 0 exit THEN -1 = IF tibeof on 1 ELSE -1 THEN ; \ freadline probe-for-fb phz 06jan22 : freadline ( -- eof ) tib /tib bounds DO isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN isfile@ fgetc eolf? 1+ UNTIL tibeof @ ; : probe-for-fb ( -- flag ) \ probes whether current file looks like a block file /tib 2+ 0 DO isfile@ fgetc #lf = IF ENDLOOP false exit THEN LOOP true ; \ save/restoretib phz 16jan22 $50 constant /stash create stash[ /stash allot here constant ]stash variable stash> stash[ stash> ! : savetib ( -- n ) #tib @ >in @ - dup stash> @ + ]stash u> abort" tib stash overflow" >r tib >in @ + stash> @ r@ cmove r@ stash> +! r> ; : restoretib ( n -- ) dup >r negate stash> +! stash> @ tib r@ cmove r> #tib ! >in off ; \ interpret-via-tib include phz 16jan22 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : include ( -- ) pushfile use cr file? probe-for-fb isfile@ freset IF 1 load close exit THEN savetib >r interpret-via-tib close r> restoretib ; : (stashquit stash[ stash> ! (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart \ \ phz 16jan22 : \ blk @ IF >in @ negate c/l mod >in +! ELSE #tib @ >in ! THEN ; immediate \ No newline at end of file diff --git a/8086/msdos/src/include.fth b/8086/msdos/src/include.fth index 2055900..6b32681 100644 --- a/8086/msdos/src/include.fth +++ b/8086/msdos/src/include.fth @@ -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 ; diff --git a/8086/msdos/tests/ans-shim.fth b/8086/msdos/tests/ans-shim.fth new file mode 100644 index 0000000..2c9c976 --- /dev/null +++ b/8086/msdos/tests/ans-shim.fth @@ -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 ; diff --git a/8086/msdos/tests/block.fth b/8086/msdos/tests/block.fth new file mode 100644 index 0000000..7def227 --- /dev/null +++ b/8086/msdos/tests/block.fth @@ -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 ( "" -- ) \ Use between <# and #> + CHAR HOLD ; IMMEDIATE + +: ?EXECUTE ( xt f -- ) + IF EXECUTE ELSE DROP THEN ; + +\ SAVE-INPUT and RESTORE-INPUT within a single block +\vf : TCSIRIR2-EXPECTED S" EDCBCBA" ; \ Remember that the string comes out backwards +\vf : TCSIRIR2 ( blk -- ) +\vf C/L 1024 U< IF +\vf BLANK-BUFFER +\vf S" 0 T-CNT !" WRITE-BLOCK-LINE +\vf S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE +\vf S" 1 T-CNT +! MARK C ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK D" WRITE-BLOCK-LINE +\vf S" MARK E 0 0 #>" WRITE-BLOCK-LINE +\vf UPDATE SAVE-BUFFERS DROP +\vf ELSE +\vf S" 0 TCSIRIR2-EXPECTED" WRITE-BLOCK +\vf THEN ; +\vf T{ RND-TEST-BLOCK DUP TCSIRIR2 LOAD TCSIRIR2-EXPECTED S= -> 0 TRUE }T + +\ REFILL across 2 blocks +\vf : TCSIRIR3 ( blks -- ) +\vf DUP S" 1 2 3 REFILL 4 5 6" WRITE-BLOCK +\vf 1+ S" 10 11 12" WRITE-BLOCK ; +\vf T{ 2 RND-TEST-BLOCK-SEQ DUP TCSIRIR3 LOAD -> 1 2 3 -1 10 11 12 }T + +\ SAVE-INPUT and RESTORE-INPUT across 2 blocks +\vf : TCSIRIR4-EXPECTED S" HGF1ECBF1ECBA" ; \ Remember that the string comes out backwards +\vf : TCSIRIR4 ( blks -- ) +\vf C/L 1024 U< IF +\vf DUP BLANK-BUFFER +\vf S" 0 T-CNT !" WRITE-BLOCK-LINE +\vf S" <# MARK A SAVE-INPUT MARK B" WRITE-BLOCK-LINE +\vf S" MARK C REFILL MARK D" WRITE-BLOCK-LINE +\vf DROP UPDATE 1+ BLANK-BUFFER +\vf S" MARK E ABS CHAR 0 + HOLD" WRITE-BLOCK-LINE +\vf S" 1 T-CNT +! MARK F ' RESTORE-INPUT T-CNT @ 2 < ?EXECUTE MARK G" WRITE-BLOCK-LINE +\vf S" MARK H 0 0 #>" WRITE-BLOCK-LINE +\vf DROP UPDATE SAVE-BUFFERS +\vf ELSE +\vf S" 0 TCSIRIR4-EXPECTED" WRITE-BLOCK +\vf THEN ; +\vf T{ 2 RND-TEST-BLOCK-SEQ DUP TCSIRIR4 LOAD TCSIRIR4-EXPECTED S= -> 0 TRUE }T + +\ ------------------------------------------------------------------------------ +TESTING THRU + +: TT1 ( blks -- ) + DUP S" BLK" WRITE-BLOCK + 1+ S" @" WRITE-BLOCK ; +T{ 2 RND-TEST-BLOCK-SEQ DUP TT1 DUP DUP 1+ THRU 1- = -> TRUE }T + +\ ------------------------------------------------------------------------------ + +BLOCK-ERRORS SET-ERROR-COUNT + +CR .( End of Block word tests) CR diff --git a/8086/msdos/tests/core.fr b/8086/msdos/tests/core.fr new file mode 100644 index 0000000..7c529d5 --- /dev/null +++ b/8086/msdos/tests/core.fr @@ -0,0 +1,1010 @@ +\ 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 BASIC ASSUMPTIONS + +T{ -> }T \ START WITH CLEAN SLATE +( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) +T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T +T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR ) +T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT ) +T{ -1 BITSSET? -> 0 0 }T + +\ ------------------------------------------------------------------------ +TESTING BOOLEANS: INVERT AND OR XOR + +T{ 0 0 AND -> 0 }T +T{ 0 1 AND -> 0 }T +T{ 1 0 AND -> 0 }T +T{ 1 1 AND -> 1 }T + +T{ 0 INVERT 1 AND -> 1 }T +T{ 1 INVERT 1 AND -> 0 }T + +0 CONSTANT 0S +0 INVERT CONSTANT 1S + +T{ 0S INVERT -> 1S }T +T{ 1S INVERT -> 0S }T + +T{ 0S 0S AND -> 0S }T +T{ 0S 1S AND -> 0S }T +T{ 1S 0S AND -> 0S }T +T{ 1S 1S AND -> 1S }T + +T{ 0S 0S OR -> 0S }T +T{ 0S 1S OR -> 1S }T +T{ 1S 0S OR -> 1S }T +T{ 1S 1S OR -> 1S }T + +T{ 0S 0S XOR -> 0S }T +T{ 0S 1S XOR -> 1S }T +T{ 1S 0S XOR -> 1S }T +T{ 1S 1S XOR -> 0S }T + +\ ------------------------------------------------------------------------ +TESTING 2* 2/ LSHIFT RSHIFT + +( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) +1S 1 RSHIFT INVERT CONSTANT MSB +T{ MSB BITSSET? -> 0 0 }T + +T{ 0S 2* -> 0S }T +T{ 1 2* -> 2 }T +T{ 4000 2* -> 8000 }T +T{ 1S 2* 1 XOR -> 1S }T +T{ MSB 2* -> 0S }T + +T{ 0S 2/ -> 0S }T +T{ 1 2/ -> 0 }T +T{ 4000 2/ -> 2000 }T +T{ 1S 2/ -> 1S }T \ MSB PROPOGATED +T{ 1S 1 XOR 2/ -> 1S }T +T{ MSB 2/ MSB AND -> MSB }T + +T{ 1 0 LSHIFT -> 1 }T +T{ 1 1 LSHIFT -> 2 }T +T{ 1 2 LSHIFT -> 4 }T +T{ 1 F LSHIFT -> 8000 }T \ BIGGEST GUARANTEED SHIFT +T{ 1S 1 LSHIFT 1 XOR -> 1S }T +T{ MSB 1 LSHIFT -> 0 }T + +T{ 1 0 RSHIFT -> 1 }T +T{ 1 1 RSHIFT -> 0 }T +T{ 2 1 RSHIFT -> 1 }T +T{ 4 2 RSHIFT -> 1 }T +T{ 8000 F RSHIFT -> 1 }T \ BIGGEST +T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT ZERO FILLS MSBS +T{ MSB 1 RSHIFT 2* -> MSB }T + +\ ------------------------------------------------------------------------ +TESTING COMPARISONS: 0= = 0< < > U< MIN MAX +0 INVERT CONSTANT MAX-UINT +0 INVERT 1 RSHIFT CONSTANT MAX-INT +0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +0 INVERT 1 RSHIFT CONSTANT MID-UINT +0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +0S CONSTANT +1S CONSTANT + +T{ 0 0= -> }T +T{ 1 0= -> }T +T{ 2 0= -> }T +T{ -1 0= -> }T +T{ MAX-UINT 0= -> }T +T{ MIN-INT 0= -> }T +T{ MAX-INT 0= -> }T + +T{ 0 0 = -> }T +T{ 1 1 = -> }T +T{ -1 -1 = -> }T +T{ 1 0 = -> }T +T{ -1 0 = -> }T +T{ 0 1 = -> }T +T{ 0 -1 = -> }T + +T{ 0 0< -> }T +T{ -1 0< -> }T +T{ MIN-INT 0< -> }T +T{ 1 0< -> }T +T{ MAX-INT 0< -> }T + +T{ 0 1 < -> }T +T{ 1 2 < -> }T +T{ -1 0 < -> }T +T{ -1 1 < -> }T +T{ MIN-INT 0 < -> }T +T{ MIN-INT MAX-INT < -> }T +T{ 0 MAX-INT < -> }T +T{ 0 0 < -> }T +T{ 1 1 < -> }T +T{ 1 0 < -> }T +T{ 2 1 < -> }T +T{ 0 -1 < -> }T +T{ 1 -1 < -> }T +T{ 0 MIN-INT < -> }T +T{ MAX-INT MIN-INT < -> }T +T{ MAX-INT 0 < -> }T + +T{ 0 1 > -> }T +T{ 1 2 > -> }T +T{ -1 0 > -> }T +T{ -1 1 > -> }T +T{ MIN-INT 0 > -> }T +T{ MIN-INT MAX-INT > -> }T +T{ 0 MAX-INT > -> }T +T{ 0 0 > -> }T +T{ 1 1 > -> }T +T{ 1 0 > -> }T +T{ 2 1 > -> }T +T{ 0 -1 > -> }T +T{ 1 -1 > -> }T +T{ 0 MIN-INT > -> }T +T{ MAX-INT MIN-INT > -> }T +T{ MAX-INT 0 > -> }T + +T{ 0 1 U< -> }T +T{ 1 2 U< -> }T +T{ 0 MID-UINT U< -> }T +T{ 0 MAX-UINT U< -> }T +T{ MID-UINT MAX-UINT U< -> }T +T{ 0 0 U< -> }T +T{ 1 1 U< -> }T +T{ 1 0 U< -> }T +T{ 2 1 U< -> }T +T{ MID-UINT 0 U< -> }T +T{ MAX-UINT 0 U< -> }T +T{ MAX-UINT MID-UINT U< -> }T + +T{ 0 1 MIN -> 0 }T +T{ 1 2 MIN -> 1 }T +T{ -1 0 MIN -> -1 }T +T{ -1 1 MIN -> -1 }T +T{ MIN-INT 0 MIN -> MIN-INT }T +T{ MIN-INT MAX-INT MIN -> MIN-INT }T +T{ 0 MAX-INT MIN -> 0 }T +T{ 0 0 MIN -> 0 }T +T{ 1 1 MIN -> 1 }T +T{ 1 0 MIN -> 0 }T +T{ 2 1 MIN -> 1 }T +T{ 0 -1 MIN -> -1 }T +T{ 1 -1 MIN -> -1 }T +T{ 0 MIN-INT MIN -> MIN-INT }T +T{ MAX-INT MIN-INT MIN -> MIN-INT }T +T{ MAX-INT 0 MIN -> 0 }T + +T{ 0 1 MAX -> 1 }T +T{ 1 2 MAX -> 2 }T +T{ -1 0 MAX -> 0 }T +T{ -1 1 MAX -> 1 }T +T{ MIN-INT 0 MAX -> 0 }T +T{ MIN-INT MAX-INT MAX -> MAX-INT }T +T{ 0 MAX-INT MAX -> MAX-INT }T +T{ 0 0 MAX -> 0 }T +T{ 1 1 MAX -> 1 }T +T{ 1 0 MAX -> 1 }T +T{ 2 1 MAX -> 2 }T +T{ 0 -1 MAX -> 0 }T +T{ 1 -1 MAX -> 1 }T +T{ 0 MIN-INT MAX -> 0 }T +T{ MAX-INT MIN-INT MAX -> MAX-INT }T +T{ MAX-INT 0 MAX -> MAX-INT }T + +\ ------------------------------------------------------------------------ +TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP + +T{ 1 2 2DROP -> }T +T{ 1 2 2DUP -> 1 2 1 2 }T +T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T +T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T +T{ 0 ?DUP -> 0 }T +T{ 1 ?DUP -> 1 1 }T +T{ -1 ?DUP -> -1 -1 }T +T{ DEPTH -> 0 }T +T{ 0 DEPTH -> 0 1 }T +T{ 0 1 DEPTH -> 0 1 2 }T +T{ 0 DROP -> }T +T{ 1 2 DROP -> 1 }T +T{ 1 DUP -> 1 1 }T +T{ 1 2 OVER -> 1 2 1 }T +T{ 1 2 3 ROT -> 2 3 1 }T +T{ 1 2 SWAP -> 2 1 }T + +\ ------------------------------------------------------------------------ +TESTING >R R> R@ + +T{ : GR1 >R R> ; -> }T +T{ : GR2 >R R@ R> DROP ; -> }T +T{ 123 GR1 -> 123 }T +T{ 123 GR2 -> 123 }T +T{ 1S GR1 -> 1S }T ( RETURN STACK HOLDS CELLS ) + +\ ------------------------------------------------------------------------ +TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE + +T{ 0 5 + -> 5 }T +T{ 5 0 + -> 5 }T +T{ 0 -5 + -> -5 }T +T{ -5 0 + -> -5 }T +T{ 1 2 + -> 3 }T +T{ 1 -2 + -> -1 }T +T{ -1 2 + -> 1 }T +T{ -1 -2 + -> -3 }T +T{ -1 1 + -> 0 }T +T{ MID-UINT 1 + -> MID-UINT+1 }T + +T{ 0 5 - -> -5 }T +T{ 5 0 - -> 5 }T +T{ 0 -5 - -> 5 }T +T{ -5 0 - -> -5 }T +T{ 1 2 - -> -1 }T +T{ 1 -2 - -> 3 }T +T{ -1 2 - -> -3 }T +T{ -1 -2 - -> 1 }T +T{ 0 1 - -> -1 }T +T{ MID-UINT+1 1 - -> MID-UINT }T + +T{ 0 1+ -> 1 }T +T{ -1 1+ -> 0 }T +T{ 1 1+ -> 2 }T +T{ MID-UINT 1+ -> MID-UINT+1 }T + +T{ 2 1- -> 1 }T +T{ 1 1- -> 0 }T +T{ 0 1- -> -1 }T +T{ MID-UINT+1 1- -> MID-UINT }T + +T{ 0 NEGATE -> 0 }T +T{ 1 NEGATE -> -1 }T +T{ -1 NEGATE -> 1 }T +T{ 2 NEGATE -> -2 }T +T{ -2 NEGATE -> 2 }T + +T{ 0 ABS -> 0 }T +T{ 1 ABS -> 1 }T +T{ -1 ABS -> 1 }T +T{ MIN-INT ABS -> MID-UINT+1 }T + +\ ------------------------------------------------------------------------ +TESTING MULTIPLY: S>D * M* UM* + +T{ 0 S>D -> 0 0 }T +T{ 1 S>D -> 1 0 }T +T{ 2 S>D -> 2 0 }T +T{ -1 S>D -> -1 -1 }T +T{ -2 S>D -> -2 -1 }T +T{ MIN-INT S>D -> MIN-INT -1 }T +T{ MAX-INT S>D -> MAX-INT 0 }T + +T{ 0 0 M* -> 0 S>D }T +T{ 0 1 M* -> 0 S>D }T +T{ 1 0 M* -> 0 S>D }T +T{ 1 2 M* -> 2 S>D }T +T{ 2 1 M* -> 2 S>D }T +T{ 3 3 M* -> 9 S>D }T +T{ -3 3 M* -> -9 S>D }T +T{ 3 -3 M* -> -9 S>D }T +T{ -3 -3 M* -> 9 S>D }T +T{ 0 MIN-INT M* -> 0 S>D }T +T{ 1 MIN-INT M* -> MIN-INT S>D }T +T{ 2 MIN-INT M* -> 0 1S }T +T{ 0 MAX-INT M* -> 0 S>D }T +T{ 1 MAX-INT M* -> MAX-INT S>D }T +T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T +T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T +T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T +T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T + +T{ 0 0 * -> 0 }T \ TEST IDENTITIES +T{ 0 1 * -> 0 }T +T{ 1 0 * -> 0 }T +T{ 1 2 * -> 2 }T +T{ 2 1 * -> 2 }T +T{ 3 3 * -> 9 }T +T{ -3 3 * -> -9 }T +T{ 3 -3 * -> -9 }T +T{ -3 -3 * -> 9 }T + +T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T +T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T +T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T + +T{ 0 0 UM* -> 0 0 }T +T{ 0 1 UM* -> 0 0 }T +T{ 1 0 UM* -> 0 0 }T +T{ 1 2 UM* -> 2 0 }T +T{ 2 1 UM* -> 2 0 }T +T{ 3 3 UM* -> 9 0 }T + +T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T +T{ MID-UINT+1 2 UM* -> 0 1 }T +T{ MID-UINT+1 4 UM* -> 0 2 }T +T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T +T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T + +\ ------------------------------------------------------------------------ +TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD + +T{ 0 S>D 1 FM/MOD -> 0 0 }T +T{ 1 S>D 1 FM/MOD -> 0 1 }T +T{ 2 S>D 1 FM/MOD -> 0 2 }T +T{ -1 S>D 1 FM/MOD -> 0 -1 }T +T{ -2 S>D 1 FM/MOD -> 0 -2 }T +T{ 0 S>D -1 FM/MOD -> 0 0 }T +T{ 1 S>D -1 FM/MOD -> 0 -1 }T +T{ 2 S>D -1 FM/MOD -> 0 -2 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -1 FM/MOD -> 0 2 }T +T{ 2 S>D 2 FM/MOD -> 0 1 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -2 FM/MOD -> 0 1 }T +T{ 7 S>D 3 FM/MOD -> 1 2 }T +T{ 7 S>D -3 FM/MOD -> -2 -3 }T +T{ -7 S>D 3 FM/MOD -> 2 -3 }T +T{ -7 S>D -3 FM/MOD -> -1 2 }T +T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T +T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T +T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T +T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T +T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T +T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T +T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T +T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T +T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T +T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T + +T{ 0 S>D 1 SM/REM -> 0 0 }T +T{ 1 S>D 1 SM/REM -> 0 1 }T +T{ 2 S>D 1 SM/REM -> 0 2 }T +T{ -1 S>D 1 SM/REM -> 0 -1 }T +T{ -2 S>D 1 SM/REM -> 0 -2 }T +T{ 0 S>D -1 SM/REM -> 0 0 }T +T{ 1 S>D -1 SM/REM -> 0 -1 }T +T{ 2 S>D -1 SM/REM -> 0 -2 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -1 SM/REM -> 0 2 }T +T{ 2 S>D 2 SM/REM -> 0 1 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -2 SM/REM -> 0 1 }T +T{ 7 S>D 3 SM/REM -> 1 2 }T +T{ 7 S>D -3 SM/REM -> 1 -2 }T +T{ -7 S>D 3 SM/REM -> -1 -2 }T +T{ -7 S>D -3 SM/REM -> -1 2 }T +T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T +T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T +T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T +T{ 1S 1 4 SM/REM -> 3 MAX-INT }T +T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T +T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T + +T{ 0 0 1 UM/MOD -> 0 0 }T +T{ 1 0 1 UM/MOD -> 0 1 }T +T{ 1 0 2 UM/MOD -> 1 0 }T +T{ 3 0 2 UM/MOD -> 1 1 }T +T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T +T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T +T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T + +: IFFLOORED + [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +: IFSYM + [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. +\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. + +IFFLOORED : T/MOD >R S>D R> FM/MOD ; +IFFLOORED : T/ T/MOD SWAP DROP ; +IFFLOORED : TMOD T/MOD DROP ; +IFFLOORED : T*/MOD >R M* R> FM/MOD ; +IFFLOORED : T*/ T*/MOD SWAP DROP ; +IFSYM : T/MOD >R S>D R> SM/REM ; +IFSYM : T/ T/MOD SWAP DROP ; +IFSYM : TMOD T/MOD DROP ; +IFSYM : T*/MOD >R M* R> SM/REM ; +IFSYM : T*/ T*/MOD SWAP DROP ; + +T{ 0 1 /MOD -> 0 1 T/MOD }T +T{ 1 1 /MOD -> 1 1 T/MOD }T +T{ 2 1 /MOD -> 2 1 T/MOD }T +T{ -1 1 /MOD -> -1 1 T/MOD }T +T{ -2 1 /MOD -> -2 1 T/MOD }T +T{ 0 -1 /MOD -> 0 -1 T/MOD }T +T{ 1 -1 /MOD -> 1 -1 T/MOD }T +T{ 2 -1 /MOD -> 2 -1 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -1 /MOD -> -2 -1 T/MOD }T +T{ 2 2 /MOD -> 2 2 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -2 /MOD -> -2 -2 T/MOD }T +T{ 7 3 /MOD -> 7 3 T/MOD }T +T{ 7 -3 /MOD -> 7 -3 T/MOD }T +T{ -7 3 /MOD -> -7 3 T/MOD }T +T{ -7 -3 /MOD -> -7 -3 T/MOD }T +T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T +T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T +T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T +T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T + +T{ 0 1 / -> 0 1 T/ }T +T{ 1 1 / -> 1 1 T/ }T +T{ 2 1 / -> 2 1 T/ }T +T{ -1 1 / -> -1 1 T/ }T +T{ -2 1 / -> -2 1 T/ }T +T{ 0 -1 / -> 0 -1 T/ }T +T{ 1 -1 / -> 1 -1 T/ }T +T{ 2 -1 / -> 2 -1 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -1 / -> -2 -1 T/ }T +T{ 2 2 / -> 2 2 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -2 / -> -2 -2 T/ }T +T{ 7 3 / -> 7 3 T/ }T +T{ 7 -3 / -> 7 -3 T/ }T +T{ -7 3 / -> -7 3 T/ }T +T{ -7 -3 / -> -7 -3 T/ }T +T{ MAX-INT 1 / -> MAX-INT 1 T/ }T +T{ MIN-INT 1 / -> MIN-INT 1 T/ }T +T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T +T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T + +T{ 0 1 MOD -> 0 1 TMOD }T +T{ 1 1 MOD -> 1 1 TMOD }T +T{ 2 1 MOD -> 2 1 TMOD }T +T{ -1 1 MOD -> -1 1 TMOD }T +T{ -2 1 MOD -> -2 1 TMOD }T +T{ 0 -1 MOD -> 0 -1 TMOD }T +T{ 1 -1 MOD -> 1 -1 TMOD }T +T{ 2 -1 MOD -> 2 -1 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -1 MOD -> -2 -1 TMOD }T +T{ 2 2 MOD -> 2 2 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -2 MOD -> -2 -2 TMOD }T +T{ 7 3 MOD -> 7 3 TMOD }T +T{ 7 -3 MOD -> 7 -3 TMOD }T +T{ -7 3 MOD -> -7 3 TMOD }T +T{ -7 -3 MOD -> -7 -3 TMOD }T +T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T +T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T +T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T +T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T + +T{ 0 2 1 */ -> 0 2 1 T*/ }T +T{ 1 2 1 */ -> 1 2 1 T*/ }T +T{ 2 2 1 */ -> 2 2 1 T*/ }T +T{ -1 2 1 */ -> -1 2 1 T*/ }T +T{ -2 2 1 */ -> -2 2 1 T*/ }T +T{ 0 2 -1 */ -> 0 2 -1 T*/ }T +T{ 1 2 -1 */ -> 1 2 -1 T*/ }T +T{ 2 2 -1 */ -> 2 2 -1 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -1 */ -> -2 2 -1 T*/ }T +T{ 2 2 2 */ -> 2 2 2 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -2 */ -> -2 2 -2 T*/ }T +T{ 7 2 3 */ -> 7 2 3 T*/ }T +T{ 7 2 -3 */ -> 7 2 -3 T*/ }T +T{ -7 2 3 */ -> -7 2 3 T*/ }T +T{ -7 2 -3 */ -> -7 2 -3 T*/ }T +T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T +T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T + +T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T +T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T +T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T +T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T +T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T +T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T +T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T +T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T +T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T +T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T +T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T +T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T +T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T +T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T +T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T + +\ ------------------------------------------------------------------------ +TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT + +HERE 1 ALLOT +HERE +CONSTANT 2NDA +CONSTANT 1STA +T{ 1STA 2NDA U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT +( MISSING TEST: NEGATIVE ALLOT ) + +\ Added by GWJ so that ALIGN can be used before , (comma) is tested +1 ALIGNED CONSTANT ALMNT \ -- 1|2|4|8 for 8|16|32|64 bit alignment +ALIGN +T{ HERE 1 ALLOT ALIGN HERE SWAP - ALMNT = -> }T +\ End of extra test + +HERE 1 , +HERE 2 , +CONSTANT 2ND +CONSTANT 1ST +T{ 1ST 2ND U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL +T{ 1ST 1 CELLS + -> 2ND }T +T{ 1ST @ 2ND @ -> 1 2 }T +T{ 5 1ST ! -> }T +T{ 1ST @ 2ND @ -> 5 2 }T +T{ 6 2ND ! -> }T +T{ 1ST @ 2ND @ -> 5 6 }T +T{ 1ST 2@ -> 6 5 }T +T{ 2 1 1ST 2! -> }T +T{ 1ST 2@ -> 2 1 }T +T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE + +HERE 1 C, +HERE 2 C, +CONSTANT 2NDC +CONSTANT 1STC +T{ 1STC 2NDC U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR +T{ 1STC 1 CHARS + -> 2NDC }T +T{ 1STC C@ 2NDC C@ -> 1 2 }T +T{ 3 1STC C! -> }T +T{ 1STC C@ 2NDC C@ -> 3 2 }T +T{ 4 2NDC C! -> }T +T{ 1STC C@ 2NDC C@ -> 3 4 }T + +ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT +CONSTANT A-ADDR CONSTANT UA-ADDR +T{ UA-ADDR ALIGNED -> A-ADDR }T +T{ 1 A-ADDR C! A-ADDR C@ -> 1 }T +T{ 1234 A-ADDR ! A-ADDR @ -> 1234 }T +T{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }T +T{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }T +T{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }T +T{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }T +T{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }T + +: BITS ( X -- U ) + 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; +( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) +T{ 1 CHARS 1 < -> }T +T{ 1 CHARS 1 CELLS > -> }T +( TBD: HOW TO FIND NUMBER OF BITS? ) + +( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) +T{ 1 CELLS 1 < -> }T +T{ 1 CELLS 1 CHARS MOD -> 0 }T +T{ 1S BITS 10 < -> }T + +T{ 0 1ST ! -> }T +T{ 1 1ST +! -> }T +T{ 1ST @ -> 1 }T +T{ -1 1ST +! 1ST @ -> 0 }T + +\ ------------------------------------------------------------------------ +TESTING CHAR [CHAR] [ ] BL S" + +T{ BL -> 20 }T +T{ CHAR X -> 58 }T \ vf: for CBM: s/X/x/ +T{ CHAR HELLO -> 48 }T \ vf: for CBM: s/HELLO/hello/ +T{ : GC1 [CHAR] X ; -> }T \ vf: for CBM: s/X/x/ +T{ : GC2 [CHAR] HELLO ; -> }T \ vf: for CBM: s/HELLO/hello/ +T{ GC1 -> 58 }T +T{ GC2 -> 48 }T +T{ : GC3 [ GC1 ] LITERAL ; -> }T +T{ GC3 -> 58 }T +T{ : GC4 S" XY" ; -> }T \ vf: for CBM: s/XY/xy/ +T{ GC4 SWAP DROP -> 2 }T +T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T + +\ ------------------------------------------------------------------------ +TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE + +T{ : GT1 123 ; -> }T +T{ ' GT1 EXECUTE -> 123 }T +T{ : GT2 ['] GT1 ; IMMEDIATE -> }T +T{ GT2 EXECUTE -> 123 }T +HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING +HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING +T{ GT1STRING FIND -> ' GT1 -1 }T +T{ GT2STRING FIND -> ' GT2 1 }T +( HOW TO SEARCH FOR NON-EXISTENT WORD? ) +T{ : GT3 GT2 LITERAL ; -> }T +T{ GT3 -> ' GT1 }T +T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T + +T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T +T{ : GT5 GT4 ; -> }T +T{ GT5 -> 123 }T +T{ : GT6 345 ; IMMEDIATE -> }T +T{ : GT7 POSTPONE GT6 ; -> }T +T{ GT7 -> 345 }T + +T{ : GT8 STATE @ ; IMMEDIATE -> }T +T{ GT8 -> 0 }T +T{ : GT9 GT8 LITERAL ; -> }T +T{ GT9 0= -> }T + +\ ------------------------------------------------------------------------ +TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE + +T{ : GI1 IF 123 THEN ; -> }T +T{ : GI2 IF 123 ELSE 234 THEN ; -> }T +T{ 0 GI1 -> }T +T{ 1 GI1 -> 123 }T +T{ -1 GI1 -> 123 }T +T{ 0 GI2 -> 234 }T +T{ 1 GI2 -> 123 }T +T{ -1 GI1 -> 123 }T + +T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T +T{ 0 GI3 -> 0 1 2 3 4 5 }T +T{ 4 GI3 -> 4 5 }T +T{ 5 GI3 -> 5 }T +T{ 6 GI3 -> 6 }T + +T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T +T{ 3 GI4 -> 3 4 5 6 }T +T{ 5 GI4 -> 5 6 }T +T{ 6 GI4 -> 6 7 }T + +\vf T{ : GI5 BEGIN DUP 2 > +\vf WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T +\vf T{ 1 GI5 -> 1 345 }T +\vf T{ 2 GI5 -> 2 345 }T +\vf T{ 3 GI5 -> 3 4 5 123 }T +\vf T{ 4 GI5 -> 4 5 123 }T +\vf T{ 5 GI5 -> 5 123 }T + +T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T +T{ 0 GI6 -> 0 }T +T{ 1 GI6 -> 0 1 }T +T{ 2 GI6 -> 0 1 2 }T +T{ 3 GI6 -> 0 1 2 3 }T +T{ 4 GI6 -> 0 1 2 3 4 }T + +\ ------------------------------------------------------------------------ +TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT + +T{ : GD1 DO I LOOP ; -> }T +T{ 4 1 GD1 -> 1 2 3 }T +T{ 2 -1 GD1 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T + +T{ : GD2 DO I -1 +LOOP ; -> }T +T{ 1 4 GD2 -> 4 3 2 1 }T +T{ -1 2 GD2 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T + +T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T +T{ 4 1 GD3 -> 1 2 3 }T +T{ 2 -1 GD3 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T + +T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T +T{ 1 4 GD4 -> 4 3 2 1 }T +T{ -1 2 GD4 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T + +T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T +T{ 1 GD5 -> 123 }T +T{ 5 GD5 -> 123 }T +T{ 6 GD5 -> 234 }T + +T{ : GD6 ( PAT: T{0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) + 0 SWAP 0 DO + I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP + LOOP ; -> }T +T{ 1 GD6 -> 1 }T +T{ 2 GD6 -> 3 }T +T{ 3 GD6 -> 4 1 2 }T + +\ ------------------------------------------------------------------------ +TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY + +T{ 123 CONSTANT X123 -> }T +T{ X123 -> 123 }T +T{ : EQU CONSTANT ; -> }T +T{ X123 EQU Y123 -> }T +T{ Y123 -> 123 }T + +T{ VARIABLE V1 -> }T +T{ 123 V1 ! -> }T +T{ V1 @ -> 123 }T + +T{ : NOP : POSTPONE ; ; -> }T +T{ NOP NOP1 NOP NOP2 -> }T +T{ NOP1 -> }T +T{ NOP2 -> }T + +T{ : DOES1 DOES> @ 1 + ; -> }T +T{ : DOES2 DOES> @ 2 + ; -> }T +T{ CREATE CR1 -> }T +T{ CR1 -> HERE }T +T{ ' CR1 >BODY -> HERE }T +T{ 1 , -> }T +T{ CR1 @ -> 1 }T +T{ DOES1 -> }T +T{ CR1 -> 2 }T +T{ DOES2 -> }T +T{ CR1 -> 3 }T + +T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T +T{ WEIRD: W1 -> }T +T{ ' W1 >BODY -> HERE }T +T{ W1 -> HERE 1 + }T +T{ W1 -> HERE 2 + }T + +\ ------------------------------------------------------------------------ +TESTING EVALUATE + +\vf : GE1 S" 123" ; IMMEDIATE +\vf : GE2 S" 123 1+" ; IMMEDIATE +\vf : GE3 S" : GE4 345 ;" ; +\vf : GE5 EVALUATE ; IMMEDIATE + +\vf T{ GE1 EVALUATE -> 123 }T ( TEST EVALUATE IN INTERP. STATE ) +\vf T{ GE2 EVALUATE -> 124 }T +\vf T{ GE3 EVALUATE -> }T +\vf T{ GE4 -> 345 }T + +\vf T{ : GE6 GE1 GE5 ; -> }T ( TEST EVALUATE IN COMPILE STATE ) +\vf T{ GE6 -> 123 }T +\vf T{ : GE7 GE2 GE5 ; -> }T +\vf T{ GE7 -> 124 }T + +\ ------------------------------------------------------------------------ +TESTING SOURCE >IN WORD + +\vf : GS1 S" SOURCE" 2DUP EVALUATE +\vf >R SWAP >R = R> R> = ; +\vf T{ GS1 -> }T + +VARIABLE SCANS +: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; + +T{ 2 SCANS ! +345 RESCAN? +-> 345 345 }T + +\vf : GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; +\vf T{ GS2 -> 123 123 123 123 123 }T + +: GS3 WORD COUNT SWAP C@ ; +T{ BL GS3 HELLO -> 5 CHAR H }T +T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T +T{ BL GS3 +DROP -> 0 }T \ BLANK LINE RETURN ZERO-LENGTH STRING + +: GS4 SOURCE >IN ! DROP ; +T{ GS4 123 456 +-> }T + +\ ------------------------------------------------------------------------ +TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL + +: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. + >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH + R> ?DUP IF \ IF NON-EMPTY STRINGS + 0 DO + OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN + SWAP CHAR+ SWAP CHAR+ + LOOP + THEN + 2DROP \ IF WE GET HERE, STRINGS MATCH + ELSE + R> DROP 2DROP \ LENGTHS MISMATCH + THEN ; + +: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; \ vf: for CBM: s/BA/ba/ +T{ GP1 -> }T + +: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; +T{ GP2 -> }T + +: GP3 <# 1 0 # # #> S" 01" S= ; +T{ GP3 -> }T + +: GP4 <# 1 0 #S #> S" 1" S= ; +T{ GP4 -> }T + +24 CONSTANT MAX-BASE \ BASE 2 .. 36 +: COUNT-BITS + 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; +COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD + +: GP5 + BASE @ + MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE + I BASE ! \ TBD: ASSUMES BASE WORKS + I 0 <# #S #> S" 10" S= AND + LOOP + SWAP BASE ! ; +T{ GP5 -> }T + +: GP6 + BASE @ >R 2 BASE ! + MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY + R> BASE ! \ S: C-ADDR U + DUP #BITS-UD = SWAP + 0 DO \ S: C-ADDR FLAG + OVER C@ [CHAR] 1 = AND \ ALL ONES + >R CHAR+ R> + LOOP SWAP DROP ; +T{ GP6 -> }T + +: GP7 + BASE @ >R MAX-BASE BASE ! + + A 0 DO + I 0 <# #S #> + 1 = SWAP C@ I 30 + = AND AND + LOOP + MAX-BASE A DO + I 0 <# #S #> + 1 = SWAP C@ 41 I A - + = AND AND \ vf: for CBM: s/41/C1/ + LOOP + R> BASE ! ; + +T{ GP7 -> }T + +\ >NUMBER TESTS +CREATE GN-BUF 0 C, +: GN-STRING GN-BUF 1 ; +: GN-CONSUMED GN-BUF CHAR+ 0 ; +: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; + +T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T +T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T +T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T +T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO CONVERT THESE +T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T +T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T + +: >NUMBER-BASED + BASE @ >R BASE ! >NUMBER R> BASE ! ; + +T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T +T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T +T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T +T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T + +: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. + BASE @ >R BASE ! + <# #S #> + 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY + R> BASE ! ; +T{ 0 0 2 GN1 -> 0 0 0 }T +T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T +T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T +T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T + +: GN2 \ ( -- 16 10 ) + BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; +T{ GN2 -> 10 A }T + +\ ------------------------------------------------------------------------ +TESTING FILL MOVE + +CREATE FBUF 00 C, 00 C, 00 C, +CREATE SBUF 12 C, 34 C, 56 C, +: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; + +T{ FBUF 0 20 FILL -> }T +T{ SEEBUF -> 00 00 00 }T + +T{ FBUF 1 20 FILL -> }T +T{ SEEBUF -> 20 00 00 }T + +T{ FBUF 3 20 FILL -> }T +T{ SEEBUF -> 20 20 20 }T + +T{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE +T{ SEEBUF -> 20 20 20 }T + +T{ SBUF FBUF 0 CHARS MOVE -> }T +T{ SEEBUF -> 20 20 20 }T + +T{ SBUF FBUF 1 CHARS MOVE -> }T +T{ SEEBUF -> 12 20 20 }T + +T{ SBUF FBUF 3 CHARS MOVE -> }T +T{ SEEBUF -> 12 34 56 }T + +T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 12 34 }T + +T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 34 34 }T + +\ ------------------------------------------------------------------------ +TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. + +: OUTPUT-TEST + ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR + 41 BL DO I EMIT LOOP CR + 61 41 DO I EMIT LOOP CR + 7F 61 DO I EMIT LOOP CR + ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR + 9 1+ 0 DO I . LOOP CR + ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR + [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR + ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR + [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR + ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR + 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR + ." YOU SHOULD SEE TWO SEPARATE LINES:" CR + S" LINE 1" TYPE CR S" LINE 2" TYPE CR + ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR + ." SIGNED: " MIN-INT . MAX-INT . CR + ." UNSIGNED: " 0 U. MAX-UINT U. CR +; + +T{ OUTPUT-TEST -> }T + + +\ ------------------------------------------------------------------------ +TESTING INPUT: ACCEPT + +CREATE ABUF 50 CHARS ALLOT + +: ACCEPT-TEST + CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR + ABUF 50 ACCEPT + CR ." RECEIVED: " [CHAR] " EMIT + ABUF SWAP TYPE [CHAR] " EMIT CR +; + +\vf No way found yet to inject key strokes into dosbox from Makefile. +\vf T{ ACCEPT-TEST -> }T + +\ ------------------------------------------------------------------------ +TESTING DICTIONARY SEARCH RULES + +T{ : GDX 123 ; : GDX GDX 234 ; -> }T + +T{ GDX -> 123 234 }T + +CR .( End of Core word set tests) CR + + diff --git a/8086/msdos/tests/coreacpt.fth b/8086/msdos/tests/coreacpt.fth new file mode 100644 index 0000000..d629533 --- /dev/null +++ b/8086/msdos/tests/coreacpt.fth @@ -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 + + diff --git a/8086/msdos/tests/coreext.fth b/8086/msdos/tests/coreext.fth new file mode 100644 index 0000000..990ba89 --- /dev/null +++ b/8086/msdos/tests/coreext.fth @@ -0,0 +1,769 @@ +\ To test the ANS Forth Core Extension word set + +\ This program was written by Gerry Jackson in 2006, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ Version 0.13 28 October 2015 +\ Replace and with FALSE and TRUE to avoid +\ dependence on Core tests +\ Moved SAVE-INPUT and RESTORE-INPUT tests in a file to filetest.fth +\ Use of 2VARIABLE (from optional wordset) replaced with CREATE. +\ Minor lower to upper case conversions. +\ Calls to COMPARE replaced by S= (in utilities.fth) to avoid use +\ of a word from an optional word set. +\ UNUSED tests revised as UNUSED UNUSED = may return FALSE when an +\ implementation has the data stack sharing unused dataspace. +\ Double number input dependency removed from the HOLDS tests. +\ Minor case sensitivities removed in definition names. +\ 0.11 25 April 2015 +\ Added tests for PARSE-NAME HOLDS BUFFER: +\ S\" tests added +\ DEFER IS ACTION-OF DEFER! DEFER@ tests added +\ Empty CASE statement test added +\ [COMPILE] tests removed because it is obsolescent in Forth 2012 +\ 0.10 1 August 2014 +\ Added tests contributed by James Bowman for: +\ <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R> +\ HEX WITHIN UNUSED AGAIN MARKER +\ Added tests for: +\ .R U.R ERASE PAD REFILL SOURCE-ID +\ Removed ABORT from NeverExecuted to enable Win32 +\ to continue after failure of RESTORE-INPUT. +\ Removed max-intx which is no longer used. +\ 0.7 6 June 2012 Extra CASE test added +\ 0.6 1 April 2012 Tests placed in the public domain. +\ SAVE-INPUT & RESTORE-INPUT tests, position +\ of T{ moved so that tests work with ttester.fs +\ CONVERT test deleted - obsolete word removed from Forth 200X +\ IMMEDIATE VALUEs tested +\ RECURSE with :NONAME tested +\ PARSE and .( tested +\ Parsing behaviour of C" added +\ 0.5 14 September 2011 Removed the double [ELSE] from the +\ initial SAVE-INPUT & RESTORE-INPUT test +\ 0.4 30 November 2009 max-int replaced with max-intx to +\ avoid redefinition warnings. +\ 0.3 6 March 2009 { and } replaced with T{ and }T +\ CONVERT test now independent of cell size +\ 0.2 20 April 2007 ANS Forth words changed to upper case +\ Tests qd3 to qd6 by Reinhold Straub +\ 0.1 Oct 2006 First version released +\ ----------------------------------------------------------------------------- +\ The tests are based on John Hayes test program for the core word set + +\ Words tested in this file are: +\ .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE +\ ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL +\ RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED +\ VALUE WITHIN [COMPILE] + +\ Words not tested or partially tested: +\ \ because it has been extensively used already and is, hence, unnecessary +\ REFILL and SOURCE-ID from the user input device which are not possible +\ when testing from a file such as this one +\ UNUSED (partially tested) as the value returned is system dependent +\ Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been +\ removed from the Forth 2012 standard + +\ Results from words that output to the user output device have to visually +\ checked for correctness. These are .R U.R .( + +\ ----------------------------------------------------------------------------- +\ Assumptions & dependencies: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set available +\ ----------------------------------------------------------------------------- +TESTING Core Extension words + +DECIMAL + +TESTING TRUE FALSE + +T{ TRUE -> 0 INVERT }T +T{ FALSE -> 0 }T + +\ ----------------------------------------------------------------------------- +TESTING <> U> (contributed by James Bowman) + +T{ 0 0 <> -> FALSE }T +T{ 1 1 <> -> FALSE }T +T{ -1 -1 <> -> FALSE }T +T{ 1 0 <> -> TRUE }T +T{ -1 0 <> -> TRUE }T +T{ 0 1 <> -> TRUE }T +T{ 0 -1 <> -> TRUE }T + +T{ 0 1 U> -> FALSE }T +T{ 1 2 U> -> FALSE }T +T{ 0 MID-UINT U> -> FALSE }T +T{ 0 MAX-UINT U> -> FALSE }T +T{ MID-UINT MAX-UINT U> -> FALSE }T +T{ 0 0 U> -> FALSE }T +T{ 1 1 U> -> FALSE }T +T{ 1 0 U> -> TRUE }T +T{ 2 1 U> -> TRUE }T +T{ MID-UINT 0 U> -> TRUE }T +T{ MAX-UINT 0 U> -> TRUE }T +T{ MAX-UINT MID-UINT U> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING 0<> 0> (contributed by James Bowman) + +T{ 0 0<> -> FALSE }T +T{ 1 0<> -> TRUE }T +T{ 2 0<> -> TRUE }T +T{ -1 0<> -> TRUE }T +T{ MAX-UINT 0<> -> TRUE }T +T{ MIN-INT 0<> -> TRUE }T +T{ MAX-INT 0<> -> TRUE }T + +T{ 0 0> -> FALSE }T +T{ -1 0> -> FALSE }T +T{ MIN-INT 0> -> FALSE }T +T{ 1 0> -> TRUE }T +T{ MAX-INT 0> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING NIP TUCK ROLL PICK (contributed by James Bowman) + +T{ 1 2 NIP -> 2 }T +T{ 1 2 3 NIP -> 1 3 }T + +T{ 1 2 TUCK -> 2 1 2 }T +T{ 1 2 3 TUCK -> 1 3 2 3 }T + +T{ : RO5 100 200 300 400 500 ; -> }T +T{ RO5 3 ROLL -> 100 300 400 500 200 }T +T{ RO5 2 ROLL -> RO5 ROT }T +T{ RO5 1 ROLL -> RO5 SWAP }T +T{ RO5 0 ROLL -> RO5 }T + +T{ RO5 2 PICK -> 100 200 300 400 500 300 }T +T{ RO5 1 PICK -> RO5 OVER }T +T{ RO5 0 PICK -> RO5 DUP }T + +\ ----------------------------------------------------------------------------- +TESTING 2>R 2R@ 2R> (contributed by James Bowman) + +T{ : RR0 2>R 100 R> R> ; -> }T +T{ 300 400 RR0 -> 100 400 300 }T +T{ 200 300 400 RR0 -> 200 100 400 300 }T + +T{ : RR1 2>R 100 2R@ R> R> ; -> }T +T{ 300 400 RR1 -> 100 300 400 400 300 }T +T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T + +T{ : RR2 2>R 100 2R> ; -> }T +T{ 300 400 RR2 -> 100 300 400 }T +T{ 200 300 400 RR2 -> 200 100 300 400 }T + +\ ----------------------------------------------------------------------------- +TESTING HEX (contributed by James Bowman) + +T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T + +\ ----------------------------------------------------------------------------- +TESTING WITHIN (contributed by James Bowman) + +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 MID-UINT WITHIN -> TRUE }T +T{ 0 0 MID-UINT+1 WITHIN -> TRUE }T +T{ 0 0 MAX-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT 0 WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT+1 0 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ 0 MAX-UINT 0 WITHIN -> FALSE }T +T{ 0 MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ 0 MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ 0 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 0 WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT+1 0 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 0 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 0 WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT 0 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MAX-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T + +T{ MIN-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MIN-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT MAX-INT WITHIN -> TRUE }T +T{ MIN-INT 0 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 0 0 WITHIN -> FALSE }T +T{ MIN-INT 0 1 WITHIN -> FALSE }T +T{ MIN-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT 1 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 1 0 WITHIN -> TRUE }T +T{ MIN-INT 1 1 WITHIN -> FALSE }T +T{ MIN-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 0 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MIN-INT 0 WITHIN -> FALSE }T +T{ 0 MIN-INT 1 WITHIN -> TRUE }T +T{ 0 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 0 0 MIN-INT WITHIN -> TRUE }T +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 1 WITHIN -> TRUE }T +T{ 0 0 MAX-INT WITHIN -> TRUE }T +T{ 0 1 MIN-INT WITHIN -> FALSE }T +T{ 0 1 0 WITHIN -> FALSE }T +T{ 0 1 1 WITHIN -> FALSE }T +T{ 0 1 MAX-INT WITHIN -> FALSE }T +T{ 0 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MAX-INT 0 WITHIN -> FALSE }T +T{ 0 MAX-INT 1 WITHIN -> TRUE }T +T{ 0 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 1 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MIN-INT 0 WITHIN -> FALSE }T +T{ 1 MIN-INT 1 WITHIN -> FALSE }T +T{ 1 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 1 0 MIN-INT WITHIN -> TRUE }T +T{ 1 0 0 WITHIN -> FALSE }T +T{ 1 0 1 WITHIN -> FALSE }T +T{ 1 0 MAX-INT WITHIN -> TRUE }T +T{ 1 1 MIN-INT WITHIN -> TRUE }T +T{ 1 1 0 WITHIN -> TRUE }T +T{ 1 1 1 WITHIN -> FALSE }T +T{ 1 1 MAX-INT WITHIN -> TRUE }T +T{ 1 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MAX-INT 0 WITHIN -> FALSE }T +T{ 1 MAX-INT 1 WITHIN -> FALSE }T +T{ 1 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 0 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 1 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 0 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 0 0 WITHIN -> FALSE }T +T{ MAX-INT 0 1 WITHIN -> FALSE }T +T{ MAX-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 1 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 1 0 WITHIN -> TRUE }T +T{ MAX-INT 1 1 WITHIN -> FALSE }T +T{ MAX-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MAX-INT MIN-INT WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT MAX-INT WITHIN -> FALSE }T + +\ ----------------------------------------------------------------------------- +TESTING UNUSED (contributed by James Bowman & Peter Knaggs) + +VARIABLE UNUSED0 +T{ UNUSED DROP -> }T +T{ ALIGN UNUSED UNUSED0 ! 0 , UNUSED CELL+ UNUSED0 @ = -> TRUE }T +T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = + -> TRUE }T \ aligned -> unaligned +T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = -> TRUE }T \ unaligned -> ? + +\ ----------------------------------------------------------------------------- +TESTING AGAIN (contributed by James Bowman) + +T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T +T{ AG0 -> 707 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING MARKER (contributed by James Bowman) + +\vf T{ : MA? BL WORD FIND NIP 0<> ; -> }T +\vf T{ MARKER MA0 -> }T +\vf T{ : MA1 111 ; -> }T +\vf T{ MARKER MA2 -> }T +\vf T{ : MA1 222 ; -> }T +\vf T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE TRUE }T +\vf T{ MA1 MA2 MA1 -> 222 111 }T +\vf T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE FALSE }T +\vf T{ MA0 -> }T +\vf T{ MA? MA0 MA? MA1 MA? MA2 -> FALSE FALSE FALSE }T + +\ ----------------------------------------------------------------------------- +TESTING ?DO + +: QD ?DO I LOOP ; +T{ 789 789 QD -> }T +T{ -9876 -9876 QD -> }T +T{ 5 0 QD -> 0 1 2 3 4 }T + +: QD1 ?DO I 10 +LOOP ; +T{ 50 1 QD1 -> 1 11 21 31 41 }T +T{ 50 0 QD1 -> 0 10 20 30 40 }T + +: QD2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ; +T{ 5 -1 QD2 -> -1 0 1 2 3 }T + +: QD3 ?DO I 1 +LOOP ; +T{ 4 4 QD3 -> }T +T{ 4 1 QD3 -> 1 2 3 }T +T{ 2 -1 QD3 -> -1 0 1 }T + +: QD4 ?DO I -1 +LOOP ; +T{ 4 4 QD4 -> }T +T{ 1 4 QD4 -> 4 3 2 1 }T +T{ -1 2 QD4 -> 2 1 0 -1 }T + +: QD5 ?DO I -10 +LOOP ; +T{ 1 50 QD5 -> 50 40 30 20 10 }T +T{ 0 50 QD5 -> 50 40 30 20 10 0 }T +T{ -25 10 QD5 -> 10 0 -10 -20 }T + +VARIABLE ITERS +VARIABLE INCRMNT + +: QD6 ( limit start increment -- ) + INCRMNT ! + 0 ITERS ! + ?DO + 1 ITERS +! + I + ITERS @ 6 = IF LEAVE THEN + INCRMNT @ + +LOOP ITERS @ +; + +T{ 4 4 -1 QD6 -> 0 }T +T{ 1 4 -1 QD6 -> 4 3 2 1 4 }T +T{ 4 1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T +T{ 4 1 0 QD6 -> 1 1 1 1 1 1 6 }T +T{ 0 0 0 QD6 -> 0 }T +T{ 1 4 0 QD6 -> 4 4 4 4 4 4 6 }T +T{ 1 4 1 QD6 -> 4 5 6 7 8 9 6 }T +T{ 4 1 1 QD6 -> 1 2 3 3 }T +T{ 4 4 1 QD6 -> 0 }T +T{ 2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T +T{ -1 2 -1 QD6 -> 2 1 0 -1 4 }T +T{ 2 -1 0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T +T{ -1 2 0 QD6 -> 2 2 2 2 2 2 6 }T +T{ -1 2 1 QD6 -> 2 3 4 5 6 7 6 }T +T{ 2 -1 1 QD6 -> -1 0 1 3 }T + +\ ----------------------------------------------------------------------------- +TESTING BUFFER: + +T{ 8 BUFFER: BUF:TEST -> }T +T{ BUF:TEST DUP ALIGNED = -> TRUE }T +T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T +T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING VALUE TO + +\vf T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T +\vf T{ VAL1 -> 111 }T +\vf T{ VAL2 -> -999 }T +\vf T{ 222 TO VAL1 -> }T +\vf T{ VAL1 -> 222 }T +\vf T{ : VD1 VAL1 ; -> }T +\vf T{ VD1 -> 222 }T +\vf T{ : VD2 TO VAL2 ; -> }T +\vf T{ VAL2 -> -999 }T +\vf T{ -333 VD2 -> }T +\vf T{ VAL2 -> -333 }T +\vf T{ VAL1 -> 222 }T +\vf T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T +\vf T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING CASE OF ENDOF ENDCASE + +\vf : CS1 CASE 1 OF 111 ENDOF +\vf 2 OF 222 ENDOF +\vf 3 OF 333 ENDOF +\vf >R 999 R> +\vf ENDCASE +\vf ; + +\vf T{ 1 CS1 -> 111 }T +\vf T{ 2 CS1 -> 222 }T +\vf T{ 3 CS1 -> 333 }T +\vf T{ 4 CS1 -> 999 }T + +\ Nested CASE's + +\vf : CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF +\vf 2 OF 200 ENDOF +\vf >R -300 R> +\vf ENDCASE +\vf ENDOF +\vf -2 OF CASE R@ 1 OF -99 ENDOF +\vf >R -199 R> +\vf ENDCASE +\vf ENDOF +\vf >R 299 R> +\vf ENDCASE R> DROP +\vf ; + +\vf T{ -1 1 CS2 -> 100 }T +\vf T{ -1 2 CS2 -> 200 }T +\vf T{ -1 3 CS2 -> -300 }T +\vf T{ -2 1 CS2 -> -99 }T +\vf T{ -2 2 CS2 -> -199 }T +\vf T{ 0 2 CS2 -> 299 }T + +\ Boolean short circuiting using CASE + +\vf : CS3 ( N1 -- N2 ) +\vf CASE 1- FALSE OF 11 ENDOF +\vf 1- FALSE OF 22 ENDOF +\vf 1- FALSE OF 33 ENDOF +\vf 44 SWAP +\vf ENDCASE +\vf ; + +\vf T{ 1 CS3 -> 11 }T +\vf T{ 2 CS3 -> 22 }T +\vf T{ 3 CS3 -> 33 }T +\vf T{ 9 CS3 -> 44 }T + +\ Empty CASE statements with/without default + +\vf T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T +\vf T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T +\vf T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T +\vf T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING :NONAME RECURSE + +\vf VARIABLE NN1 +\vf VARIABLE NN2 +\vf :NONAME 1234 ; NN1 ! +\vf :NONAME 9876 ; NN2 ! +\vf T{ NN1 @ EXECUTE -> 1234 }T +\vf T{ NN2 @ EXECUTE -> 9876 }T + +\vf T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ; +\vf CONSTANT RN1 -> }T +\vf T{ 0 RN1 EXECUTE -> 0 }T +\vf T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T + +\vf :NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition +\vf 1- DUP +\vf CASE 0 OF EXIT ENDOF +\vf 1 OF 11 SWAP RECURSE ENDOF +\vf 2 OF 22 SWAP RECURSE ENDOF +\vf 3 OF 33 SWAP RECURSE ENDOF +\vf DROP ABS RECURSE EXIT +\vf ENDCASE +\vf ; CONSTANT RN2 + +\vf T{ 1 RN2 EXECUTE -> 0 }T +\vf T{ 2 RN2 EXECUTE -> 11 0 }T +\vf T{ 4 RN2 EXECUTE -> 33 22 11 0 }T +\vf T{ 25 RN2 EXECUTE -> 33 22 11 0 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING C" + +T{ : CQ1 C" 123" ; -> }T +\vf T{ CQ1 COUNT EVALUATE -> 123 }T +T{ : CQ2 C" " ; -> }T +\vf T{ CQ2 COUNT EVALUATE -> }T +\vf T{ : CQ3 C" 2345"COUNT EVALUATE ; CQ3 -> 2345 }T + +\ ----------------------------------------------------------------------------- +TESTING COMPILE, + +:NONAME DUP + ; CONSTANT DUP+ +T{ : Q DUP+ COMPILE, ; -> }T +T{ : AS1 [ Q ] ; -> }T +T{ 123 AS1 -> 246 }T + +\ ----------------------------------------------------------------------------- +\ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source + +\vf TESTING SAVE-INPUT and RESTORE-INPUT with a string source + +\vf VARIABLE SI_INC 0 SI_INC ! + +\vf : SI1 +\vf SI_INC @ >IN +! +\vf 15 SI_INC ! +\vf ; + +\vf : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; + +\vf T{ S$ EVALUATE SI_INC @ -> 0 2345 15 }T + +\ ----------------------------------------------------------------------------- +TESTING .( + +CR CR .( Output from .() +T{ CR .( You should see -9876: ) -9876 . -> }T +T{ CR .( and again: ).( -9876)CR -> }T + +CR CR .( On the next 2 lines you should see First then Second messages:) +T{ : DOTP CR ." Second message via ." [CHAR] " EMIT \ Check .( is immediate + [ CR ] .( First message via .( ) ; DOTP -> }T +CR CR +T{ : IMM? BL WORD FIND NIP ; IMM? .( -> 1 }T + +\ ----------------------------------------------------------------------------- +TESTING .R and U.R - has to handle different cell sizes + +\ Create some large integers just below/above MAX and Min INTs +MAX-INT 73 79 */ CONSTANT LI1 +MIN-INT 71 73 */ CONSTANT LI2 + +LI1 0 <# #S #> NIP CONSTANT LENLI1 + +: (.R&U.R) ( u1 u2 -- ) \ u1 <= string length, u2 is required indentation + TUCK + >R + LI1 OVER SPACES . CR R@ LI1 SWAP .R CR + LI2 OVER SPACES . CR R@ 1+ LI2 SWAP .R CR + LI1 OVER SPACES U. CR R@ LI1 SWAP U.R CR + LI2 SWAP SPACES U. CR R> LI2 SWAP U.R CR +; + +: .R&U.R ( -- ) + CR ." You should see lines duplicated:" CR + ." indented by 0 spaces" CR 0 0 (.R&U.R) CR + ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width + ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR +; + +CR CR .( Output from .R and U.R) +T{ .R&U.R -> }T + +\ ----------------------------------------------------------------------------- +TESTING PAD ERASE +\ Must handle different size characters i.e. 1 CHARS >= 1 + +84 CONSTANT CHARS/PAD \ Minimum size of PAD in chars +CHARS/PAD CHARS CONSTANT AUS/PAD +: CHECKPAD ( caddr u ch -- f ) \ f = TRUE if u chars = ch + SWAP 0 + ?DO + OVER I CHARS + C@ OVER <> + IF 2DROP UNLOOP FALSE EXIT THEN + LOOP + 2DROP TRUE +; + +T{ PAD DROP -> }T +T{ 0 INVERT PAD C! -> }T +T{ PAD C@ CONSTANT MAXCHAR -> }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> TRUE }T +T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> TRUE }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> TRUE }T +T{ PAD 43 CHARS + 9 CHARS ERASE -> }T +T{ PAD 43 MAXCHAR CHECKPAD -> TRUE }T +T{ PAD 43 CHARS + 9 0 CHECKPAD -> TRUE }T +T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> TRUE }T + +\ Check that use of WORD and pictured numeric output do not corrupt PAD +\ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively +\ where n is number of bits per cell + +PAD CHARS/PAD ERASE +2 BASE ! +MAX-UINT MAX-UINT <# #S CHAR 1 DUP HOLD HOLD #> 2DROP +DECIMAL +BL WORD 12345678123456781234567812345678 DROP +T{ PAD CHARS/PAD 0 CHECKPAD -> TRUE }T + +\ ----------------------------------------------------------------------------- +\vf TESTING PARSE + +\vf T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T +\vf T{ CHAR ^ PARSE 23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T +\vf : PA1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ; +\vf T{ PA1 3456 +\vf DUP ROT ROT EVALUATE -> 4 3456 }T +\vf T{ CHAR A PARSE A SWAP DROP -> 0 }T +\vf T{ CHAR Z PARSE +\vf SWAP DROP -> 0 }T +\vf T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T + +\ ----------------------------------------------------------------------------- +\vf TESTING PARSE-NAME (Forth 2012) +\ Adapted from the PARSE-NAME RfD tests +\vf T{ PARSE-NAME abcd STR1 S= -> TRUE }T \ No leading spaces +\vf T{ PARSE-NAME abcde STR2 S= -> TRUE }T \ Leading spaces + +\ Test empty parse area, new lines are necessary +\vf T{ PARSE-NAME +\vf NIP -> 0 }T +\ Empty parse area with spaces after PARSE-NAME +\vf T{ PARSE-NAME +\vf NIP -> 0 }T + +\vf T{ : PARSE-NAME-TEST ( "name1" "name2" -- n ) +\vf PARSE-NAME PARSE-NAME S= ; -> }T +\vf T{ PARSE-NAME-TEST abcd abcd -> TRUE }T +\vf T{ PARSE-NAME-TEST abcd abcd -> TRUE }T \ Leading spaces +\vf T{ PARSE-NAME-TEST abcde abcdf -> FALSE }T +\vf T{ PARSE-NAME-TEST abcdf abcde -> FALSE }T +\vf T{ PARSE-NAME-TEST abcde abcde +\vf -> TRUE }T \ Parse to end of line +\vf T{ PARSE-NAME-TEST abcde abcde +\vf -> TRUE }T \ Leading and trailing spaces + +\ ----------------------------------------------------------------------------- +TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012) +\ Adapted from the Forth 200X RfD tests + +T{ DEFER DEFER1 -> }T +T{ : MY-DEFER DEFER ; -> }T +T{ : IS-DEFER1 IS DEFER1 ; -> }T +T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T +T{ : DEF! DEFER! ; -> }T +T{ : DEF@ DEFER@ ; -> }T + +T{ ' * ' DEFER1 DEFER! -> }T +T{ 2 3 DEFER1 -> 6 }T +T{ ' DEFER1 DEFER@ -> ' * }T +T{ ' DEFER1 DEF@ -> ' * }T +T{ ACTION-OF DEFER1 -> ' * }T +T{ ACTION-DEFER1 -> ' * }T +T{ ' + IS DEFER1 -> }T +T{ 1 2 DEFER1 -> 3 }T +T{ ' DEFER1 DEFER@ -> ' + }T +T{ ' DEFER1 DEF@ -> ' + }T +T{ ACTION-OF DEFER1 -> ' + }T +T{ ACTION-DEFER1 -> ' + }T +T{ ' - IS-DEFER1 -> }T +T{ 1 2 DEFER1 -> -1 }T +T{ ' DEFER1 DEFER@ -> ' - }T +T{ ' DEFER1 DEF@ -> ' - }T +T{ ACTION-OF DEFER1 -> ' - }T +T{ ACTION-DEFER1 -> ' - }T + +T{ MY-DEFER DEFER2 -> }T +T{ ' DUP IS DEFER2 -> }T +T{ 1 DEFER2 -> 1 1 }T + +\ ----------------------------------------------------------------------------- +TESTING HOLDS (Forth 2012) + +: HTEST S" Testing HOLDS" ; +: HTEST2 S" works" ; +: HTEST3 S" Testing HOLDS works 123" ; +T{ 0 0 <# HTEST HOLDS #> HTEST S= -> TRUE }T +T{ 123 0 <# #S BL HOLD HTEST2 HOLDS BL HOLD HTEST HOLDS #> + HTEST3 S= -> TRUE }T +T{ : HLD HOLDS ; -> }T +T{ 0 0 <# HTEST HLD #> HTEST S= -> TRUE }T + +\ ----------------------------------------------------------------------------- +\vf TESTING REFILL SOURCE-ID +\ REFILL and SOURCE-ID from the user input device can't be tested from a file, +\ can only be tested from a string via EVALUATE + +\vf T{ : RF1 S" REFILL" EVALUATE ; RF1 -> FALSE }T +\vf T{ : SID1 S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T + +\ ------------------------------------------------------------------------------ +\vf TESTING S\" (Forth 2012 compilation mode) +\ Extended the Forth 200X RfD tests +\ Note this tests the Core Ext definition of S\" which has unedfined +\ interpretation semantics. S\" in interpretation mode is tested in the tests on +\ the File-Access word set + +\vf T{ : SSQ1 S\" abc" S" abc" S= ; -> }T \ No escapes +\vf T{ SSQ1 -> TRUE }T +\vf T{ : SSQ2 S\" " ; SSQ2 SWAP DROP -> 0 }T \ Empty string + +\vf T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T +\vf T{ SSQ3 SWAP DROP -> 20 }T \ String length +\vf T{ SSQ3 DROP C@ -> 7 }T \ \a BEL Bell +\vf T{ SSQ3 DROP 1 CHARS + C@ -> 8 }T \ \b BS Backspace +\vf T{ SSQ3 DROP 2 CHARS + C@ -> 27 }T \ \e ESC Escape +\vf T{ SSQ3 DROP 3 CHARS + C@ -> 12 }T \ \f FF Form feed +\vf T{ SSQ3 DROP 4 CHARS + C@ -> 10 }T \ \l LF Line feed +\vf T{ SSQ3 DROP 5 CHARS + C@ -> 13 }T \ \m CR of CR/LF pair +\vf T{ SSQ3 DROP 6 CHARS + C@ -> 10 }T \ LF of CR/LF pair +\vf T{ SSQ3 DROP 7 CHARS + C@ -> 34 }T \ \q " Double Quote +\vf T{ SSQ3 DROP 8 CHARS + C@ -> 13 }T \ \r CR Carriage Return +\vf T{ SSQ3 DROP 9 CHARS + C@ -> 9 }T \ \t TAB Horizontal Tab +\vf T{ SSQ3 DROP 10 CHARS + C@ -> 11 }T \ \v VT Vertical Tab +\vf T{ SSQ3 DROP 11 CHARS + C@ -> 15 }T \ \x0F Given Char +\vf T{ SSQ3 DROP 12 CHARS + C@ -> 48 }T \ 0 0 Digit follow on +\vf T{ SSQ3 DROP 13 CHARS + C@ -> 31 }T \ \x1F Given Char +\vf T{ SSQ3 DROP 14 CHARS + C@ -> 97 }T \ a a Hex follow on +\vf T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T \ \xaB Insensitive Given Char +\vf T{ SSQ3 DROP 16 CHARS + C@ -> 120 }T \ x x Non hex follow on +\vf T{ SSQ3 DROP 17 CHARS + C@ -> 0 }T \ \z NUL No Character +\vf T{ SSQ3 DROP 18 CHARS + C@ -> 34 }T \ \" " Double Quote +\vf T{ SSQ3 DROP 19 CHARS + C@ -> 92 }T \ \\ \ Back Slash + +\ The above does not test \n as this is a system dependent value. +\ Check it displays a new line +\vf CR .( The next test should display:) +\vf CR .( One line...) +\vf CR .( another line) +\vf T{ : SSQ4 S\" \nOne line...\nanotherLine\n" type ; SSQ4 -> }T + +\ Test bare escapable characters appear as themselves +\vf T{ : SSQ5 S\" abeflmnqrtvxz" S" abeflmnqrtvxz" S= ; SSQ5 -> TRUE }T + +\vf T{ : SSQ6 S\" a\""2DROP 1111 ; SSQ6 -> 1111 }T \ Parsing behaviour + +\vf T{ : SSQ7 S\" 111 : SSQ8 s\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T +\vf T{ SSQ7 -> 111 222 333 }T +\vf T{ : SSQ9 S\" 11 : SSQ10 s\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T +\vf T{ SSQ9 -> 11 22 33 }T + +\ ----------------------------------------------------------------------------- +CORE-EXT-ERRORS SET-ERROR-COUNT + +CR .( End of Core Extension word tests) CR + + diff --git a/8086/msdos/tests/coreplus.fth b/8086/msdos/tests/coreplus.fth new file mode 100644 index 0000000..82b1be2 --- /dev/null +++ b/8086/msdos/tests/coreplus.fth @@ -0,0 +1,306 @@ +\ Additional tests on the the ANS Forth Core word set + +\ This program was written by Gerry Jackson in 2007, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ The tests are based on John Hayes test program for the core word set +\ +\ This file provides some more tests on Core words where the original Hayes +\ tests are thought to be incomplete +\ +\ Words tested in this file are: +\ DO I +LOOP RECURSE ELSE >IN IMMEDIATE FIND IF...BEGIN...REPEAT ALLOT DOES> +\ and +\ Parsing behaviour +\ Number prefixes # $ % and 'A' character input +\ Definition names +\ ------------------------------------------------------------------------------ +\ Assumptions and dependencies: +\ - tester.fr or ttester.fs has been loaded prior to this file +\ - core.fr has been loaded so that constants MAX-INT, MIN-INT and +\ MAX-UINT are defined +\ ------------------------------------------------------------------------------ + +DECIMAL + +TESTING DO +LOOP with run-time increment, negative increment, infinite loop +\ Contributed by Reinhold Straub + +VARIABLE ITERATIONS +VARIABLE INCREMENT +: GD7 ( LIMIT START INCREMENT -- ) + INCREMENT ! + 0 ITERATIONS ! + DO + 1 ITERATIONS +! + I + ITERATIONS @ 6 = IF LEAVE THEN + INCREMENT @ + +LOOP ITERATIONS @ +; + +T{ 4 4 -1 GD7 -> 4 1 }T +T{ 1 4 -1 GD7 -> 4 3 2 1 4 }T +T{ 4 1 -1 GD7 -> 1 0 -1 -2 -3 -4 6 }T +T{ 4 1 0 GD7 -> 1 1 1 1 1 1 6 }T +T{ 0 0 0 GD7 -> 0 0 0 0 0 0 6 }T +T{ 1 4 0 GD7 -> 4 4 4 4 4 4 6 }T +T{ 1 4 1 GD7 -> 4 5 6 7 8 9 6 }T +T{ 4 1 1 GD7 -> 1 2 3 3 }T +T{ 4 4 1 GD7 -> 4 5 6 7 8 9 6 }T +T{ 2 -1 -1 GD7 -> -1 -2 -3 -4 -5 -6 6 }T +T{ -1 2 -1 GD7 -> 2 1 0 -1 4 }T +T{ 2 -1 0 GD7 -> -1 -1 -1 -1 -1 -1 6 }T +T{ -1 2 0 GD7 -> 2 2 2 2 2 2 6 }T +T{ -1 2 1 GD7 -> 2 3 4 5 6 7 6 }T +T{ 2 -1 1 GD7 -> -1 0 1 3 }T +T{ -20 30 -10 GD7 -> 30 20 10 0 -10 -20 6 }T +T{ -20 31 -10 GD7 -> 31 21 11 1 -9 -19 6 }T +T{ -20 29 -10 GD7 -> 29 19 9 -1 -11 5 }T + +\ ------------------------------------------------------------------------------ +TESTING DO +LOOP with large and small increments + +\ Contributed by Andrew Haley + +MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP +USTEP NEGATE CONSTANT -USTEP +MAX-INT 7 RSHIFT 1+ CONSTANT STEP +STEP NEGATE CONSTANT -STEP + +VARIABLE BUMP + +T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; -> }T + +T{ 0 MAX-UINT 0 USTEP GD8 -> 256 }T +T{ 0 0 MAX-UINT -USTEP GD8 -> 256 }T + +T{ 0 MAX-INT MIN-INT STEP GD8 -> 256 }T +T{ 0 MIN-INT MAX-INT -STEP GD8 -> 256 }T + +\ Two's complement arithmetic, wraps around modulo wordsize +\ Only tested if the Forth system does wrap around, use of conditional +\ compilation deliberately avoided + +MAX-INT 1+ MIN-INT = CONSTANT +WRAP? +MIN-INT 1- MAX-INT = CONSTANT -WRAP? +MAX-UINT 1+ 0= CONSTANT +UWRAP? +0 1- MAX-UINT = CONSTANT -UWRAP? + +: GD9 ( n limit start step f result -- ) + >R IF GD8 ELSE 2DROP 2DROP R@ THEN -> R> }T +; + +T{ 0 0 0 USTEP +UWRAP? 256 GD9 +T{ 0 0 0 -USTEP -UWRAP? 1 GD9 +T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9 +T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9 + +\ ------------------------------------------------------------------------------ +TESTING DO +LOOP with maximum and minimum increments + +: (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ; +(-MI) CONSTANT -MAX-INT + +T{ 0 1 0 MAX-INT GD8 -> 1 }T +T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 -> 2 }T + +T{ 0 MAX-INT 0 MAX-INT GD8 -> 1 }T +T{ 0 MAX-INT 1 MAX-INT GD8 -> 1 }T +T{ 0 MAX-INT -1 MAX-INT GD8 -> 2 }T +T{ 0 MAX-INT DUP 1- MAX-INT GD8 -> 1 }T + +T{ 0 MIN-INT 1+ 0 MIN-INT GD8 -> 1 }T +T{ 0 MIN-INT 1+ -1 MIN-INT GD8 -> 1 }T +T{ 0 MIN-INT 1+ 1 MIN-INT GD8 -> 2 }T +T{ 0 MIN-INT 1+ DUP MIN-INT GD8 -> 1 }T + +\ ------------------------------------------------------------------------------ +\ TESTING +LOOP setting I to an arbitrary value + +\ The specification for +LOOP permits the loop index I to be set to any value +\ including a value outside the range given to the corresponding DO. + +\ SET-I is a helper to set I in a DO ... +LOOP to a given value +\ n2 is the value of I in a DO ... +LOOP +\ n3 is a test value +\ If n2=n3 then return n1-n2 else return 1 +: SET-I ( n1 n2 n3 -- n1-n2 | 1 ) + OVER = IF - ELSE 2DROP 1 THEN +; + +: -SET-I ( n1 n2 n3 -- n1-n2 | -1 ) + SET-I DUP 1 = IF NEGATE THEN +; + +: PL1 20 1 DO I 18 I 3 SET-I +LOOP ; +T{ PL1 -> 1 2 3 18 19 }T +: PL2 20 1 DO I 20 I 2 SET-I +LOOP ; +T{ PL2 -> 1 2 }T +: PL3 20 5 DO I 19 I 2 SET-I DUP 1 = IF DROP 0 I 6 SET-I THEN +LOOP ; +T{ PL3 -> 5 6 0 1 2 19 }T +: PL4 20 1 DO I MAX-INT I 4 SET-I +LOOP ; +T{ PL4 -> 1 2 3 4 }T +: PL5 -20 -1 DO I -19 I -3 -SET-I +LOOP ; +T{ PL5 -> -1 -2 -3 -19 -20 }T +: PL6 -20 -1 DO I -21 I -4 -SET-I +LOOP ; +T{ PL6 -> -1 -2 -3 -4 }T +: PL7 -20 -1 DO I MIN-INT I -5 -SET-I +LOOP ; +T{ PL7 -> -1 -2 -3 -4 -5 }T +: PL8 -20 -5 DO I -20 I -2 -SET-I DUP -1 = IF DROP 0 I -6 -SET-I THEN +LOOP ; +T{ PL8 -> -5 -6 0 -1 -2 -20 }T + +\ ------------------------------------------------------------------------------ +TESTING multiple RECURSEs in one colon definition + +: ACK ( m n -- u ) \ Ackermann function, from Rosetta Code + OVER 0= IF NIP 1+ EXIT THEN \ ack(0, n) = n+1 + SWAP 1- SWAP ( -- m-1 n ) + DUP 0= IF 1+ RECURSE EXIT THEN \ ack(m, 0) = ack(m-1, 1) + 1- OVER 1+ SWAP RECURSE RECURSE \ ack(m, n) = ack(m-1, ack(m,n-1)) +; + +T{ 0 0 ACK -> 1 }T +T{ 3 0 ACK -> 5 }T +T{ 2 4 ACK -> 11 }T + +\ ------------------------------------------------------------------------------ +\vf TESTING multiple ELSE's in an IF statement +\ Discussed on comp.lang.forth and accepted as valid ANS Forth + +\vf : MELSE IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ; +\vf T{ 0 MELSE -> 2 4 }T +\vf T{ -1 MELSE -> 1 3 5 }T + +\ ------------------------------------------------------------------------------ +TESTING manipulation of >IN in interpreter mode + +T{ 12345 DEPTH OVER 9 < 34 AND + 3 + >IN ! -> 12345 2345 345 45 5 }T +T{ 14145 8115 ?DUP 0= 34 AND >IN +! TUCK MOD 14 >IN ! GCD CALCULATION -> 15 }T + +\ ------------------------------------------------------------------------------ +TESTING IMMEDIATE with CONSTANT VARIABLE and CREATE [ ... DOES> ] + +T{ 123 CONSTANT IW1 IMMEDIATE IW1 -> 123 }T +T{ : IW2 IW1 LITERAL ; IW2 -> 123 }T +T{ VARIABLE IW3 IMMEDIATE 234 IW3 ! IW3 @ -> 234 }T +T{ : IW4 IW3 [ @ ] LITERAL ; IW4 -> 234 }T +T{ :NONAME [ 345 ] IW3 [ ! ] ; DROP IW3 @ -> 345 }T +T{ CREATE IW5 456 , IMMEDIATE -> }T +T{ :NONAME IW5 [ @ IW3 ! ] ; DROP IW3 @ -> 456 }T +T{ : IW6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T +T{ 111 IW6 IW7 IW7 -> 112 }T +T{ : IW8 IW7 LITERAL 1+ ; IW8 -> 113 }T +T{ : IW9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T +: FIND-IW BL WORD FIND NIP ; ( -- 0 | 1 | -1 ) +T{ 222 IW9 IW10 FIND-IW IW10 -> -1 }T \ IW10 is not immediate +T{ IW10 FIND-IW IW10 -> 224 1 }T \ IW10 becomes immediate + +\ ------------------------------------------------------------------------------ +TESTING that IMMEDIATE doesn't toggle a flag + +VARIABLE IT1 0 IT1 ! +: IT2 1234 IT1 ! ; IMMEDIATE IMMEDIATE +T{ : IT3 IT2 ; IT1 @ -> 1234 }T + +\ ------------------------------------------------------------------------------ +TESTING parsing behaviour of S" ." and ( +\ which should parse to just beyond the terminating character no space needed + +T{ : GC5 S" A string"2DROP ; GC5 -> }T +T{ ( A comment)1234 -> 1234 }T +T{ : PB1 CR ." You should see 2345: "." 2345"( A comment) CR ; PB1 -> }T + +\ ------------------------------------------------------------------------------ +TESTING number prefixes # $ % and 'c' character input +\ Adapted from the Forth 200X Draft 14.5 document + +VARIABLE OLD-BASE +DECIMAL BASE @ OLD-BASE ! +T{ &1289 -> 1289 }T \ vf: s/#/&/ +T{ -&1289 -> -1289 }T \ vf: s/#-/-&/ +T{ $12eF -> 4847 }T +T{ -$12eF -> -4847 }T \ vf: s/$-/-$/ +T{ %10010110 -> 150 }T +T{ -%10010110 -> -150 }T \ vf: s/%-/-%/ +\vf T{ 'z' -> 122 }T +\vf T{ 'Z' -> 90 }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = -> }T + +\ Repeat in Hex mode +16 OLD-BASE ! 16 BASE ! +T{ &1289 -> 509 }T \ vf: s/#/&/ +T{ -&1289 -> -509 }T \ vf: s/#/&/ +T{ $12eF -> 12EF }T +T{ -$12eF -> -12EF }T \ vf: s/$-/-$/ +T{ %10010110 -> 96 }T +T{ -%10010110 -> -96 }T \ vf: s/%-/-%/ +\vf T{ 'z' -> 7a }T +\vf T{ 'Z' -> 5a }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = -> }T \ 2 + +DECIMAL +\ Check number prefixes in compile mode +\ vf: s/#/&/ s/$-/-$/ s/'''/ascii '/ +T{ : nmp &8327 -$2cbe %011010111 ascii ' ; nmp -> 8327 -11454 215 39 }T + +\ ------------------------------------------------------------------------------ +TESTING definition names +\ should support {1..31} graphical characters +: !"#$%&'()*+,-./0123456789:;<=>? 1 ; +T{ !"#$%&'()*+,-./0123456789:;<=>? -> 1 }T +: @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ 2 ; +T{ @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^ -> 2 }T +: _`abcdefghijklmnopqrstuvwxyz{|} 3 ; +T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T +: _`abcdefghijklmnopqrstuvwxyz{|~ 4 ; \ Last character different +T{ _`abcdefghijklmnopqrstuvwxyz{|~ -> 4 }T +T{ _`abcdefghijklmnopqrstuvwxyz{|} -> 3 }T + +\ ------------------------------------------------------------------------------ +TESTING FIND with a zero length string and a non-existent word + +CREATE EMPTYSTRING 0 C, +: EMPTYSTRING-FIND-CHECK ( c-addr 0 | xt 1 | xt -1 -- t|f ) + DUP IF ." FIND returns a TRUE value for an empty string!" CR THEN + 0= SWAP EMPTYSTRING = = ; +T{ EMPTYSTRING FIND EMPTYSTRING-FIND-CHECK -> }T + +CREATE NON-EXISTENT-WORD \ Same as in exceptiontest.fth + 15 C, CHAR $ C, CHAR $ C, CHAR Q C, CHAR W C, CHAR E C, CHAR Q C, + CHAR W C, CHAR E C, CHAR Q C, CHAR W C, CHAR E C, CHAR R C, CHAR T C, + CHAR $ C, CHAR $ C, +T{ NON-EXISTENT-WORD FIND -> NON-EXISTENT-WORD 0 }T + +\ ------------------------------------------------------------------------------ +\vf TESTING IF ... BEGIN ... REPEAT (unstructured) + +\vf T{ : UNS1 DUP 0 > IF 9 SWAP BEGIN 1+ DUP 3 > IF EXIT THEN REPEAT ; -> }T +\vf T{ -6 UNS1 -> -6 }T +\vf T{ 1 UNS1 -> 9 4 }T + +\ ------------------------------------------------------------------------------ +TESTING DOES> doesn't cause a problem with a CREATEd address + +: MAKE-2CONST DOES> 2@ ; +T{ CREATE 2K 3 , 2K , MAKE-2CONST 2K -> ' 2K >BODY 3 }T + +\ ------------------------------------------------------------------------------ +TESTING ALLOT ( n -- ) where n <= 0 + +T{ HERE 5 ALLOT -5 ALLOT HERE = -> }T +T{ HERE 0 ALLOT HERE = -> }T + +\ ------------------------------------------------------------------------------ + +CR .( End of additional Core tests) CR diff --git a/8086/msdos/tests/double.fth b/8086/msdos/tests/double.fth new file mode 100644 index 0000000..0f3f3b3 --- /dev/null +++ b/8086/msdos/tests/double.fth @@ -0,0 +1,438 @@ +\ To test the ANS Forth Double-Number word set and double number extensions + +\ This program was written by Gerry Jackson in 2006, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct +\ ------------------------------------------------------------------------------ +\ Version 0.13 Assumptions and dependencies changed +\ 0.12 1 August 2015 test D< acts on MS cells of double word +\ 0.11 7 April 2015 2VALUE tested +\ 0.6 1 April 2012 Tests placed in the public domain. +\ Immediate 2CONSTANTs and 2VARIABLEs tested +\ 0.5 20 November 2009 Various constants renamed to avoid +\ redefinition warnings. and replaced +\ with TRUE and FALSE +\ 0.4 6 March 2009 { and } replaced with T{ and }T +\ Tests rewritten to be independent of word size and +\ tests re-ordered +\ 0.3 20 April 2007 ANS Forth words changed to upper case +\ 0.2 30 Oct 2006 Updated following GForth test to include +\ various constants from core.fr +\ 0.1 Oct 2006 First version released +\ ------------------------------------------------------------------------------ +\ The tests are based on John Hayes test program for the core word set + +\ Words tested in this file are: +\ 2CONSTANT 2LITERAL 2VARIABLE D+ D- D. D.R D0< D0= D2* D2/ +\ D< D= D>S DABS DMAX DMIN DNEGATE M*/ M+ 2ROT DU< +\ Also tests the interpreter and compiler reading a double number +\ ------------------------------------------------------------------------------ +\ Assumptions and dependencies: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set is available and tested +\ ------------------------------------------------------------------------------ +\ Constant definitions + +DECIMAL +0 INVERT CONSTANT 1SD +1SD 1 RSHIFT CONSTANT MAX-INTD \ 01...1 +MAX-INTD INVERT CONSTANT MIN-INTD \ 10...0 +MAX-INTD 2/ CONSTANT HI-INT \ 001...1 +MIN-INTD 2/ CONSTANT LO-INT \ 110...1 + +\ ------------------------------------------------------------------------------ +TESTING interpreter and compiler reading double numbers, with/without prefixes + +T{ 1. -> 1 0 }T +T{ -2. -> -2 -1 }T +T{ : RDL1 3. ; RDL1 -> 3 0 }T +T{ : RDL2 -4. ; RDL2 -> -4 -1 }T + +VARIABLE OLD-DBASE +DECIMAL BASE @ OLD-DBASE ! +T{ &12346789. -> 12346789. }T \ vf: s/#/&/ +T{ -&12346789. -> -12346789. }T \ vf: s/#-/-&/ +T{ $12aBcDeF. -> 313249263. }T +T{ -$12AbCdEf. -> -313249263. }T \ vf: s/$-/-$/ +T{ %10010110. -> 150. }T +T{ -%10010110. -> -150. }T \ vf: s/%-/-%/ +\ Check BASE is unchanged +T{ BASE @ OLD-DBASE @ = -> }T + +\ Repeat in Hex mode +16 OLD-DBASE ! 16 BASE ! +T{ &12346789. -> BC65A5. }T \ vf: s/#/&/ +T{ -&12346789. -> -BC65A5. }T \ vf: s/#-/-&/ +T{ $12aBcDeF. -> 12AbCdeF. }T +T{ -$12AbCdEf. -> -12ABCDef. }T \ vf: s/$-/-$/ +T{ %10010110. -> 96. }T +T{ -%10010110. -> -96. }T \ vf: s/%-/-%/ +\ Check BASE is unchanged +T{ BASE @ OLD-DBASE @ = -> }T \ 2 + +DECIMAL +\ Check number prefixes in compile mode +\ vf: s/#/&/ s/$-/-$/ +T{ : dnmp &8327. -$2cbe. %011010111. ; dnmp -> 8327. -11454. 215. }T + +\ ------------------------------------------------------------------------------ +TESTING 2CONSTANT + +T{ 1 2 2CONSTANT 2C1 -> }T +T{ 2C1 -> 1 2 }T +T{ : CD1 2C1 ; -> }T +T{ CD1 -> 1 2 }T +T{ : CD2 2CONSTANT ; -> }T +T{ -1 -2 CD2 2C2 -> }T +T{ 2C2 -> -1 -2 }T +T{ 4 5 2CONSTANT 2C3 IMMEDIATE 2C3 -> 4 5 }T +T{ : CD6 2C3 2LITERAL ; CD6 -> 4 5 }T + +\ ------------------------------------------------------------------------------ +\ Some 2CONSTANTs for the following tests + +1SD MAX-INTD 2CONSTANT MAX-2INT \ 01...1 +0 MIN-INTD 2CONSTANT MIN-2INT \ 10...0 +MAX-2INT 2/ 2CONSTANT HI-2INT \ 001...1 +MIN-2INT 2/ 2CONSTANT LO-2INT \ 110...0 + +\ ------------------------------------------------------------------------------ +TESTING DNEGATE + +T{ 0. DNEGATE -> 0. }T +T{ 1. DNEGATE -> -1. }T +T{ -1. DNEGATE -> 1. }T +T{ MAX-2INT DNEGATE -> MIN-2INT SWAP 1+ SWAP }T +T{ MIN-2INT SWAP 1+ SWAP DNEGATE -> MAX-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D+ with small integers + +T{ 0. 5. D+ -> 5. }T +T{ -5. 0. D+ -> -5. }T +T{ 1. 2. D+ -> 3. }T +T{ 1. -2. D+ -> -1. }T +T{ -1. 2. D+ -> 1. }T +T{ -1. -2. D+ -> -3. }T +T{ -1. 1. D+ -> 0. }T + +TESTING D+ with mid range integers + +T{ 0 0 0 5 D+ -> 0 5 }T +T{ -1 5 0 0 D+ -> -1 5 }T +T{ 0 0 0 -5 D+ -> 0 -5 }T +T{ 0 -5 -1 0 D+ -> -1 -5 }T +T{ 0 1 0 2 D+ -> 0 3 }T +T{ -1 1 0 -2 D+ -> -1 -1 }T +T{ 0 -1 0 2 D+ -> 0 1 }T +T{ 0 -1 -1 -2 D+ -> -1 -3 }T +T{ -1 -1 0 1 D+ -> -1 0 }T +T{ MIN-INTD 0 2DUP D+ -> 0 1 }T +T{ MIN-INTD S>D MIN-INTD 0 D+ -> 0 0 }T + +TESTING D+ with large double integers + +T{ HI-2INT 1. D+ -> 0 HI-INT 1+ }T +T{ HI-2INT 2DUP D+ -> 1SD 1- MAX-INTD }T +T{ MAX-2INT MIN-2INT D+ -> -1. }T +T{ MAX-2INT LO-2INT D+ -> HI-2INT }T +T{ HI-2INT MIN-2INT D+ 1. D+ -> LO-2INT }T +T{ LO-2INT 2DUP D+ -> MIN-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D- with small integers + +T{ 0. 5. D- -> -5. }T +T{ 5. 0. D- -> 5. }T +T{ 0. -5. D- -> 5. }T +T{ 1. 2. D- -> -1. }T +T{ 1. -2. D- -> 3. }T +T{ -1. 2. D- -> -3. }T +T{ -1. -2. D- -> 1. }T +T{ -1. -1. D- -> 0. }T + +TESTING D- with mid-range integers + +T{ 0 0 0 5 D- -> 0 -5 }T +T{ -1 5 0 0 D- -> -1 5 }T +T{ 0 0 -1 -5 D- -> 1 4 }T +T{ 0 -5 0 0 D- -> 0 -5 }T +T{ -1 1 0 2 D- -> -1 -1 }T +T{ 0 1 -1 -2 D- -> 1 2 }T +T{ 0 -1 0 2 D- -> 0 -3 }T +T{ 0 -1 0 -2 D- -> 0 1 }T +T{ 0 0 0 1 D- -> 0 -1 }T +T{ MIN-INTD 0 2DUP D- -> 0. }T +T{ MIN-INTD S>D MAX-INTD 0 D- -> 1 1SD }T + +TESTING D- with large integers + +T{ MAX-2INT MAX-2INT D- -> 0. }T +T{ MIN-2INT MIN-2INT D- -> 0. }T +T{ MAX-2INT HI-2INT D- -> LO-2INT DNEGATE }T +T{ HI-2INT LO-2INT D- -> MAX-2INT }T +T{ LO-2INT HI-2INT D- -> MIN-2INT 1. D+ }T +T{ MIN-2INT MIN-2INT D- -> 0. }T +T{ MIN-2INT LO-2INT D- -> LO-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D0< D0= + +T{ 0. D0< -> FALSE }T +T{ 1. D0< -> FALSE }T +T{ MIN-INTD 0 D0< -> FALSE }T +T{ 0 MAX-INTD D0< -> FALSE }T +T{ MAX-2INT D0< -> FALSE }T +T{ -1. D0< -> TRUE }T +T{ MIN-2INT D0< -> TRUE }T + +T{ 1. D0= -> FALSE }T +T{ MIN-INTD 0 D0= -> FALSE }T +T{ MAX-2INT D0= -> FALSE }T +T{ -1 MAX-INTD D0= -> FALSE }T +T{ 0. D0= -> TRUE }T +T{ -1. D0= -> FALSE }T +T{ 0 MIN-INTD D0= -> FALSE }T + +\ ------------------------------------------------------------------------------ +TESTING D2* D2/ + +T{ 0. D2* -> 0. D2* }T +T{ MIN-INTD 0 D2* -> 0 1 }T +T{ HI-2INT D2* -> MAX-2INT 1. D- }T +T{ LO-2INT D2* -> MIN-2INT }T + +T{ 0. D2/ -> 0. }T +T{ 1. D2/ -> 0. }T +T{ 0 1 D2/ -> MIN-INTD 0 }T +T{ MAX-2INT D2/ -> HI-2INT }T +T{ -1. D2/ -> -1. }T +T{ MIN-2INT D2/ -> LO-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D< D= + +T{ 0. 1. D< -> TRUE }T +T{ 0. 0. D< -> FALSE }T +T{ 1. 0. D< -> FALSE }T +T{ -1. 1. D< -> TRUE }T +T{ -1. 0. D< -> TRUE }T +T{ -2. -1. D< -> TRUE }T +T{ -1. -2. D< -> FALSE }T +T{ 0 1 1. D< -> FALSE }T \ Suggested by Helmut Eller +T{ 1. 0 1 D< -> TRUE }T +T{ 0 -1 1 -2 D< -> FALSE }T +T{ 1 -2 0 -1 D< -> TRUE }T +T{ -1. MAX-2INT D< -> TRUE }T +T{ MIN-2INT MAX-2INT D< -> TRUE }T +T{ MAX-2INT -1. D< -> FALSE }T +T{ MAX-2INT MIN-2INT D< -> FALSE }T +T{ MAX-2INT 2DUP -1. D+ D< -> FALSE }T +T{ MIN-2INT 2DUP 1. D+ D< -> TRUE }T +T{ MAX-INTD S>D 2DUP 1. D+ D< -> TRUE }T \ Ensure D< acts on MS cells + +T{ -1. -1. D= -> TRUE }T +T{ -1. 0. D= -> FALSE }T +T{ -1. 1. D= -> FALSE }T +T{ 0. -1. D= -> FALSE }T +T{ 0. 0. D= -> TRUE }T +T{ 0. 1. D= -> FALSE }T +T{ 1. -1. D= -> FALSE }T +T{ 1. 0. D= -> FALSE }T +T{ 1. 1. D= -> TRUE }T + +T{ 0 -1 0 -1 D= -> TRUE }T +T{ 0 -1 0 0 D= -> FALSE }T +T{ 0 -1 0 1 D= -> FALSE }T +T{ 0 0 0 -1 D= -> FALSE }T +T{ 0 0 0 0 D= -> TRUE }T +T{ 0 0 0 1 D= -> FALSE }T +T{ 0 1 0 -1 D= -> FALSE }T +T{ 0 1 0 0 D= -> FALSE }T +T{ 0 1 0 1 D= -> TRUE }T + +T{ MAX-2INT MIN-2INT D= -> FALSE }T +T{ MAX-2INT 0. D= -> FALSE }T +T{ MAX-2INT MAX-2INT D= -> TRUE }T +T{ MAX-2INT HI-2INT D= -> FALSE }T +T{ MAX-2INT MIN-2INT D= -> FALSE }T +T{ MIN-2INT MIN-2INT D= -> TRUE }T +T{ MIN-2INT LO-2INT D= -> FALSE }T +T{ MIN-2INT MAX-2INT D= -> FALSE }T + +\ ------------------------------------------------------------------------------ +TESTING 2LITERAL 2VARIABLE + +T{ : CD3 [ MAX-2INT ] 2LITERAL ; -> }T +T{ CD3 -> MAX-2INT }T +T{ 2VARIABLE 2V1 -> }T +T{ 0. 2V1 2! -> }T +T{ 2V1 2@ -> 0. }T +T{ -1 -2 2V1 2! -> }T +T{ 2V1 2@ -> -1 -2 }T +T{ : CD4 2VARIABLE ; -> }T +T{ CD4 2V2 -> }T +T{ : CD5 2V2 2! ; -> }T +T{ -2 -1 CD5 -> }T +T{ 2V2 2@ -> -2 -1 }T +T{ 2VARIABLE 2V3 IMMEDIATE 5 6 2V3 2! -> }T +T{ 2V3 2@ -> 5 6 }T +T{ : CD7 2V3 [ 2@ ] 2LITERAL ; CD7 -> 5 6 }T +T{ : CD8 [ 6 7 ] 2V3 [ 2! ] ; 2V3 2@ -> 6 7 }T + +\ ------------------------------------------------------------------------------ +TESTING DMAX DMIN + +T{ 1. 2. DMAX -> 2. }T +T{ 1. 0. DMAX -> 1. }T +T{ 1. -1. DMAX -> 1. }T +T{ 1. 1. DMAX -> 1. }T +T{ 0. 1. DMAX -> 1. }T +T{ 0. -1. DMAX -> 0. }T +T{ -1. 1. DMAX -> 1. }T +T{ -1. -2. DMAX -> -1. }T + +T{ MAX-2INT HI-2INT DMAX -> MAX-2INT }T +T{ MAX-2INT MIN-2INT DMAX -> MAX-2INT }T +T{ MIN-2INT MAX-2INT DMAX -> MAX-2INT }T +T{ MIN-2INT LO-2INT DMAX -> LO-2INT }T + +T{ MAX-2INT 1. DMAX -> MAX-2INT }T +T{ MAX-2INT -1. DMAX -> MAX-2INT }T +T{ MIN-2INT 1. DMAX -> 1. }T +T{ MIN-2INT -1. DMAX -> -1. }T + + +T{ 1. 2. DMIN -> 1. }T +T{ 1. 0. DMIN -> 0. }T +T{ 1. -1. DMIN -> -1. }T +T{ 1. 1. DMIN -> 1. }T +T{ 0. 1. DMIN -> 0. }T +T{ 0. -1. DMIN -> -1. }T +T{ -1. 1. DMIN -> -1. }T +T{ -1. -2. DMIN -> -2. }T + +T{ MAX-2INT HI-2INT DMIN -> HI-2INT }T +T{ MAX-2INT MIN-2INT DMIN -> MIN-2INT }T +T{ MIN-2INT MAX-2INT DMIN -> MIN-2INT }T +T{ MIN-2INT LO-2INT DMIN -> MIN-2INT }T + +T{ MAX-2INT 1. DMIN -> 1. }T +T{ MAX-2INT -1. DMIN -> -1. }T +T{ MIN-2INT 1. DMIN -> MIN-2INT }T +T{ MIN-2INT -1. DMIN -> MIN-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING D>S DABS + +T{ 1234 0 D>S -> 1234 }T +T{ -1234 -1 D>S -> -1234 }T +T{ MAX-INTD 0 D>S -> MAX-INTD }T +T{ MIN-INTD -1 D>S -> MIN-INTD }T + +T{ 1. DABS -> 1. }T +T{ -1. DABS -> 1. }T +T{ MAX-2INT DABS -> MAX-2INT }T +T{ MIN-2INT 1. D+ DABS -> MAX-2INT }T + +\ ------------------------------------------------------------------------------ +TESTING M+ M*/ + +T{ HI-2INT 1 M+ -> HI-2INT 1. D+ }T +T{ MAX-2INT -1 M+ -> MAX-2INT -1. D+ }T +T{ MIN-2INT 1 M+ -> MIN-2INT 1. D+ }T +T{ LO-2INT -1 M+ -> LO-2INT -1. D+ }T + +\ To correct the result if the division is floored, only used when +\ necessary i.e. negative quotient and remainder <> 0 + +: ?FLOORED [ -3 2 / -2 = ] LITERAL IF 1. D- THEN ; + +\vf T{ 5. 7 11 M*/ -> 3. }T +\vf T{ 5. -7 11 M*/ -> -3. ?FLOORED }T \ FLOORED -4. +\vf T{ -5. 7 11 M*/ -> -3. ?FLOORED }T \ FLOORED -4. +\vf T{ -5. -7 11 M*/ -> 3. }T +\vf T{ MAX-2INT 8 16 M*/ -> HI-2INT }T +\vf T{ MAX-2INT -8 16 M*/ -> HI-2INT DNEGATE ?FLOORED }T \ FLOORED SUBTRACT 1 +\vf T{ MIN-2INT 8 16 M*/ -> LO-2INT }T +\vf T{ MIN-2INT -8 16 M*/ -> LO-2INT DNEGATE }T +\vf T{ MAX-2INT MAX-INTD MAX-INTD M*/ -> MAX-2INT }T +\vf T{ MAX-2INT MAX-INTD 2/ MAX-INTD M*/ -> MAX-INTD 1- HI-2INT NIP }T +\vf T{ MIN-2INT LO-2INT NIP 1+ DUP 1- NEGATE M*/ -> 0 MAX-INTD 1- }T +\vf T{ MIN-2INT LO-2INT NIP 1- MAX-INTD M*/ -> MIN-INTD 3 + HI-2INT NIP 2 + }T +\vf T{ MAX-2INT LO-2INT NIP DUP NEGATE M*/ -> MAX-2INT DNEGATE }T +\vf T{ MIN-2INT MAX-INTD DUP M*/ -> MIN-2INT }T + +\ ------------------------------------------------------------------------------ +\vf TESTING D. D.R + +\ Create some large double numbers +\vf MAX-2INT 71 73 M*/ 2CONSTANT DBL1 +\vf MIN-2INT 73 79 M*/ 2CONSTANT DBL2 + +\vf : D>ASCII ( D -- CADDR U ) +\vf DUP >R <# DABS #S R> SIGN #> ( -- CADDR1 U ) +\vf HERE SWAP 2DUP 2>R CHARS DUP ALLOT MOVE 2R> +\vf ; + +\vf DBL1 D>ASCII 2CONSTANT "DBL1" +\vf DBL2 D>ASCII 2CONSTANT "DBL2" + +\vf : DOUBLEOUTPUT +\vf CR ." You should see lines duplicated:" CR +\vf 5 SPACES "DBL1" TYPE CR +\vf 5 SPACES DBL1 D. CR +\vf 8 SPACES "DBL1" DUP >R TYPE CR +\vf 5 SPACES DBL1 R> 3 + D.R CR +\vf 5 SPACES "DBL2" TYPE CR +\vf 5 SPACES DBL2 D. CR +\vf 10 SPACES "DBL2" DUP >R TYPE CR +\vf 5 SPACES DBL2 R> 5 + D.R CR +\vf ; + +\vf T{ DOUBLEOUTPUT -> }T + +\ ------------------------------------------------------------------------------ +TESTING 2ROT DU< (Double Number extension words) + +T{ 1. 2. 3. 2ROT -> 2. 3. 1. }T +T{ MAX-2INT MIN-2INT 1. 2ROT -> MIN-2INT 1. MAX-2INT }T + +\vf T{ 1. 1. DU< -> FALSE }T +\vf T{ 1. -1. DU< -> TRUE }T +\vf T{ -1. 1. DU< -> FALSE }T +\vf T{ -1. -2. DU< -> FALSE }T +\vf T{ 0 1 1. DU< -> FALSE }T +\vf T{ 1. 0 1 DU< -> TRUE }T +\vf T{ 0 -1 1 -2 DU< -> FALSE }T +\vf T{ 1 -2 0 -1 DU< -> TRUE }T + +\vf T{ MAX-2INT HI-2INT DU< -> FALSE }T +\vf T{ HI-2INT MAX-2INT DU< -> TRUE }T +\vf T{ MAX-2INT MIN-2INT DU< -> TRUE }T +\vf T{ MIN-2INT MAX-2INT DU< -> FALSE }T +\vf T{ MIN-2INT LO-2INT DU< -> TRUE }T + +\ ------------------------------------------------------------------------------ +\vf TESTING 2VALUE + +\vf T{ 1111 2222 2VALUE 2VAL -> }T +\vf T{ 2VAL -> 1111 2222 }T +\vf T{ 3333 4444 TO 2VAL -> }T +\vf T{ 2VAL -> 3333 4444 }T +\vf T{ : TO-2VAL TO 2VAL ; 5555 6666 TO-2VAL -> }T +\vf T{ 2VAL -> 5555 6666 }T + +\ ------------------------------------------------------------------------------ + +DOUBLE-ERRORS SET-ERROR-COUNT + +CR .( End of Double-Number word tests) CR + diff --git a/8086/msdos/tests/errorrep.fth b/8086/msdos/tests/errorrep.fth new file mode 100644 index 0000000..24e7bd1 --- /dev/null +++ b/8086/msdos/tests/errorrep.fth @@ -0,0 +1,88 @@ +\ To collect and report on the number of errors resulting from running the +\ ANS Forth and Forth 2012 test programs + +\ This program was written by Gerry Jackson in 2015, and is in the public +\ domain - it can be distributed and/or modified in any way but please +\ retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ ------------------------------------------------------------------------------ +\ This file is INCLUDED after Core tests are complete and only uses Core words +\ already tested. The purpose of this file is to count errors in test results +\ and present them as a summary at the end of the tests. + +DECIMAL + +VARIABLE TOTAL-ERRORS + +: ERROR-COUNT ( "name" n1 -- n2 ) \ n2 = n1 + 1cell + CREATE DUP , CELL+ + DOES> ( -- offset ) @ \ offset in address units +; + +0 \ Offset into ERRORS[] array +ERROR-COUNT CORE-ERRORS ERROR-COUNT CORE-EXT-ERRORS +ERROR-COUNT DOUBLE-ERRORS ERROR-COUNT EXCEPTION-ERRORS +ERROR-COUNT FACILITY-ERRORS ERROR-COUNT FILE-ERRORS +ERROR-COUNT LOCALS-ERRORS ERROR-COUNT MEMORY-ERRORS +ERROR-COUNT SEARCHORDER-ERRORS ERROR-COUNT STRING-ERRORS +ERROR-COUNT TOOLS-ERRORS ERROR-COUNT BLOCK-ERRORS +CREATE ERRORS[] DUP ALLOT CONSTANT #ERROR-COUNTS + +\ SET-ERROR-COUNT called at the end of each test file with its own offset into +\ the ERRORS[] array. #ERRORS is in files tester.fr and ttester.fs + +: SET-ERROR-COUNT ( offset -- ) + #ERRORS @ SWAP ERRORS[] + ! + #ERRORS @ TOTAL-ERRORS +! + 0 #ERRORS ! +; + +: INIT-ERRORS ( -- ) + ERRORS[] #ERROR-COUNTS OVER + SWAP DO -1 I ! 1 CELLS +LOOP + 0 TOTAL-ERRORS ! + CORE-ERRORS SET-ERROR-COUNT +; + +INIT-ERRORS + +\ Report summary of errors + +25 CONSTANT MARGIN + +: SHOW-ERROR-LINE ( n caddr u -- ) + CR SWAP OVER TYPE MARGIN - ABS >R + DUP -1 = IF DROP R> 1- SPACES ." -" ELSE + R> .R THEN +; + +: SHOW-ERROR-COUNT ( caddr u offset -- ) + ERRORS[] + @ ROT ROT SHOW-ERROR-LINE +; + +: HLINE ( -- ) CR ." ---------------------------" ; + +: REPORT-ERRORS + HLINE + CR 8 SPACES ." Error Report" + CR ." Word Set" 13 SPACES ." Errors" + HLINE + S" Core" CORE-ERRORS SHOW-ERROR-COUNT + S" Core extension" CORE-EXT-ERRORS SHOW-ERROR-COUNT + S" Block" BLOCK-ERRORS SHOW-ERROR-COUNT + S" Double number" DOUBLE-ERRORS SHOW-ERROR-COUNT + S" Exception" EXCEPTION-ERRORS SHOW-ERROR-COUNT + S" Facility" FACILITY-ERRORS SHOW-ERROR-COUNT + S" File-access" FILE-ERRORS SHOW-ERROR-COUNT + S" Locals" LOCALS-ERRORS SHOW-ERROR-COUNT + S" Memory-allocation" MEMORY-ERRORS SHOW-ERROR-COUNT + S" Programming-tools" TOOLS-ERRORS SHOW-ERROR-COUNT + S" Search-order" SEARCHORDER-ERRORS SHOW-ERROR-COUNT + S" String" STRING-ERRORS SHOW-ERROR-COUNT + HLINE + TOTAL-ERRORS @ S" Total" SHOW-ERROR-LINE + HLINE CR CR +; diff --git a/8086/msdos/tests/golden/block.golden b/8086/msdos/tests/golden/block.golden new file mode 100644 index 0000000..998ca33 --- /dev/null +++ b/8086/msdos/tests/golden/block.golden @@ -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 diff --git a/8086/msdos/tests/golden/core.golden b/8086/msdos/tests/golden/core.golden new file mode 100644 index 0000000..607d2cd --- /dev/null +++ b/8086/msdos/tests/golden/core.golden @@ -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 diff --git a/8086/msdos/tests/golden/coreext.golden b/8086/msdos/tests/golden/coreext.golden new file mode 100644 index 0000000..ddf90a8 --- /dev/null +++ b/8086/msdos/tests/golden/coreext.golden @@ -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 diff --git a/8086/msdos/tests/golden/coreplus.golden b/8086/msdos/tests/golden/coreplus.golden new file mode 100644 index 0000000..b6ea7aa --- /dev/null +++ b/8086/msdos/tests/golden/coreplus.golden @@ -0,0 +1,5 @@ + +COREPLUS.FTH******** +You should see 2345: 2345 +***** +End of additional Core tests diff --git a/8086/msdos/tests/golden/double.golden b/8086/msdos/tests/golden/double.golden new file mode 100644 index 0000000..ad02caf --- /dev/null +++ b/8086/msdos/tests/golden/double.golden @@ -0,0 +1,3 @@ + +doubletest.fth***************** +End of Double-Number word tests diff --git a/8086/msdos/tests/golden/prelim.golden b/8086/msdos/tests/golden/prelim.golden new file mode 100644 index 0000000..cd2bedb --- /dev/null +++ b/8086/msdos/tests/golden/prelim.golden @@ -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 --- diff --git a/8086/msdos/tests/golden/report-blk.golden b/8086/msdos/tests/golden/report-blk.golden new file mode 100644 index 0000000..80361e9 --- /dev/null +++ b/8086/msdos/tests/golden/report-blk.golden @@ -0,0 +1,21 @@ + +--------------------------- + Error Report +Word Set Errors +--------------------------- +Core 0 +Core extension 0 +Block 0 +Double number 0 +Exception - +Facility - +File-access - +Locals - +Memory-allocation - +Programming-tools - +Search-order - +String - +--------------------------- +Total 0 +--------------------------- + diff --git a/8086/msdos/tests/golden/report-noblk.golden b/8086/msdos/tests/golden/report-noblk.golden new file mode 100644 index 0000000..acdc397 --- /dev/null +++ b/8086/msdos/tests/golden/report-noblk.golden @@ -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 +--------------------------- + diff --git a/8086/msdos/tests/prelim.fth b/8086/msdos/tests/prelim.fth new file mode 100644 index 0000000..8ca9ef5 --- /dev/null +++ b/8086/msdos/tests/prelim.fth @@ -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: ?T~ Error #n: ) +( 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 <> 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 diff --git a/8086/msdos/tests/test-blk.fth b/8086/msdos/tests/test-blk.fth new file mode 100644 index 0000000..ed2799d --- /dev/null +++ b/8086/msdos/tests/test-blk.fth @@ -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 diff --git a/8086/msdos/tests/test-min.fth b/8086/msdos/tests/test-min.fth new file mode 100644 index 0000000..08b8962 --- /dev/null +++ b/8086/msdos/tests/test-min.fth @@ -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 diff --git a/8086/msdos/tests/test-std.fth b/8086/msdos/tests/test-std.fth new file mode 100644 index 0000000..0f9bfc7 --- /dev/null +++ b/8086/msdos/tests/test-std.fth @@ -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 diff --git a/8086/msdos/tests/tester.fth b/8086/msdos/tests/tester.fth new file mode 100644 index 0000000..2cf108d --- /dev/null +++ b/8086/msdos/tests/tester.fth @@ -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 ; + diff --git a/8086/msdos/tests/util.fth b/8086/msdos/tests/util.fth new file mode 100644 index 0000000..b224c79 --- /dev/null +++ b/8086/msdos/tests/util.fth @@ -0,0 +1,143 @@ +( The ANS/Forth 2012 test suite is being modified so that the test programs ) +( for the optional word sets only use standard words from the Core word set. ) +( This file, which is included *after* the Core test programs, contains ) +( various definitions for use by the optional word set test programs to ) +( remove any dependencies between word sets. ) + +DECIMAL + +( First a definition to see if a word is already defined. Note that ) +( [DEFINED] [IF] [ELSE] and [THEN] are in the optional Programming Tools ) +( word set. ) + +VARIABLE (\?) 0 (\?) ! ( Flag: Word defined = 0 | word undefined = -1 ) + +( [?DEF] followed by [?IF] cannot be used again until after [THEN] ) +: [?DEF] ( "name" -- ) + BL WORD FIND SWAP DROP 0= (\?) ! +; + +\ Test [?DEF] +T{ 0 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> -1 }T +: ?DEFTEST1 1 ; +T{ -1 (\?) ! [?DEF] ?DEFTEST1 (\?) @ -> 0 }T + +: [?UNDEF] [?DEF] (\?) @ 0= (\?) ! ; + +\ Equivalents of [IF] [ELSE] [THEN], these must not be nested +: [?IF] ( f -- ) (\?) ! ; IMMEDIATE +: [?ELSE] ( -- ) (\?) @ 0= (\?) ! ; IMMEDIATE +: [?THEN] ( -- ) 0 (\?) ! ; IMMEDIATE + +( A conditional comment and \ will be defined. Note that these definitions ) +( are inadequate for use in Forth blocks. If needed in the blocks test ) +( program they will need to be modified here or redefined there ) + +( \? is a conditional comment ) +: \? ( "..." -- ) (\?) @ IF EXIT THEN SOURCE >IN ! DROP ; IMMEDIATE + +\ Test \? +T{ [?DEF] ?DEFTEST1 \? : ?DEFTEST1 2 ; \ Should not be redefined + ?DEFTEST1 -> 1 }T +T{ [?DEF] ?DEFTEST2 \? : ?DEFTEST1 2 ; \ Should be redefined + ?DEFTEST1 -> 2 }T + +[?DEF] TRUE \? -1 CONSTANT TRUE +[?DEF] FALSE \? 0 CONSTANT FALSE +[?DEF] NIP \? : NIP SWAP DROP ; +[?DEF] TUCK \? : TUCK SWAP OVER ; + +[?DEF] PARSE +\? : BUMP ( caddr u n -- caddr+n u-n ) +\? TUCK - >R CHARS + R> +\? ; + +\? : PARSE ( ch "ccc" -- caddr u ) +\? >R SOURCE >IN @ BUMP +\? OVER R> SWAP >R >R ( -- start u1 ) ( R: -- start ch ) +\? BEGIN +\? DUP +\? WHILE +\? OVER C@ R@ = 0= +\? WHILE +\? 1 BUMP +\? REPEAT +\? 1- ( end u2 ) \ delimiter found +\? THEN +\? SOURCE NIP SWAP - >IN ! ( -- end ) +\? R> DROP R> ( -- end start ) +\? TUCK - 1 CHARS / ( -- start u ) +\? ; + +[?DEF] .( \? : .( [CHAR] ) PARSE TYPE ; IMMEDIATE + +\ S= to compare (case sensitive) two strings to avoid use of COMPARE from +\ the String word set. It is defined in core.fr and conditionally defined +\ here if core.fr has not been included by the user + +[?DEF] S= +\? : S= ( caddr1 u1 caddr2 u2 -- f ) \ f = TRUE if strings are equal +\? ROT OVER = 0= IF DROP 2DROP FALSE EXIT THEN +\? DUP 0= IF DROP 2DROP TRUE EXIT THEN +\? 0 DO +\? OVER C@ OVER C@ = 0= IF 2DROP FALSE UNLOOP EXIT THEN +\? CHAR+ SWAP CHAR+ +\? LOOP 2DROP TRUE +\? ; + +\ Buffer for strings in interpretive mode since S" only valid in compilation +\ mode when File-Access word set is defined + +64 CONSTANT SBUF-SIZE +CREATE SBUF1 SBUF-SIZE CHARS ALLOT +CREATE SBUF2 SBUF-SIZE CHARS ALLOT + +\ ($") saves a counted string at (caddr) +: ($") ( caddr "ccc" -- caddr' u ) + [CHAR] " PARSE ROT 2DUP C! ( -- ca2 u2 ca) + CHAR+ SWAP 2DUP 2>R CHARS MOVE ( -- ) ( R: -- ca' u2 ) + 2R> +; + +: $" ( "ccc" -- caddr u ) SBUF1 ($") ; +: $2" ( "ccc" -- caddr u ) SBUF2 ($") ; +: $CLEAR ( caddr -- ) SBUF-SIZE BL FILL ; +: CLEAR-SBUFS ( -- ) SBUF1 $CLEAR SBUF2 $CLEAR ; + +\ More definitions in core.fr used in other test programs, conditionally +\ defined here if core.fr has not been loaded + +[?DEF] MAX-UINT \? 0 INVERT CONSTANT MAX-UINT +[?DEF] MAX-INT \? 0 INVERT 1 RSHIFT CONSTANT MAX-INT +[?DEF] MIN-INT \? 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +[?DEF] MID-UINT \? 0 INVERT 1 RSHIFT CONSTANT MID-UINT +[?DEF] MID-UINT+1 \? 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +[?DEF] 2CONSTANT \? : 2CONSTANT CREATE , , DOES> 2@ ; + +BASE @ 2 BASE ! -1 0 <# #S #> SWAP DROP CONSTANT BITS/CELL BASE ! + + +\ ------------------------------------------------------------------------------ +\ Tests + +: STR1 S" abcd" ; : STR2 S" abcde" ; +: STR3 S" abCd" ; : STR4 S" wbcd" ; +: S"" S" " ; + +T{ STR1 2DUP S= -> TRUE }T +T{ STR2 2DUP S= -> TRUE }T +T{ S"" 2DUP S= -> TRUE }T +T{ STR1 STR2 S= -> FALSE }T +T{ STR1 STR3 S= -> FALSE }T +T{ STR1 STR4 S= -> FALSE }T + +T{ CLEAR-SBUFS -> }T +T{ $" abcdefghijklm" SBUF1 COUNT S= -> TRUE }T +T{ $" nopqrstuvwxyz" SBUF2 OVER S= -> FALSE }T +T{ $2" abcdefghijklm" SBUF1 COUNT S= -> FALSE }T +T{ $2" nopqrstuvwxyz" SBUF1 COUNT S= -> TRUE }T + +\ ------------------------------------------------------------------------------ + +CR $" Test utilities loaded" TYPE CR diff --git a/8086/msdos/v4thfile.com b/8086/msdos/v4thfile.com index 7df6e127a3342770b267f18a81a9bc85cae2b02a..802505c25ffadd44b9726ea815d0eb761d94e9ac 100644 GIT binary patch delta 196 zcmbRAkMYny#tDjyP8*e;NwP@POVn@Xk@~>NbmR5rf69U!j9i-qbl$5lN^J_1(qiMT zV_;yA*{o1Ki;4M_cK+m@wRWx#>Ue@f9D_ZAT!TaWgIx6_9Xa0C#mPNakY!=p^1IG4 zMo;n&|9KV{ZV`qLK$?U7sqzEf5B##MdfZ$L?Ld(a{0~_s3)G1+n}ya-j;PyZz)*AS j-+=?iYJhezFbG)WFjVl=oH=u*49sU>ID^7JkYE4+!`(qq delta 147 zcmX@~k8#pJ#tDjyLK~HyNwR#e`(C%1N9qG7(}m}o|0xS{FtTkH(0Q-ID6lC|N{ej* zGXn#I#Ab!+Sxl4n)!ItlspAO_aSZkdat#jg4|3I$bmVwh7bo{zVX{M=sBwY?&#@Yy f1|SeHF!*Bt1ZFZ2K9D>E24!&mF%Xy>QMU^KuKqAG