From 7dc1c341505e2c971e9ceb108863b2bcbba74c43 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Thu, 20 Jan 2022 00:00:40 +0100 Subject: [PATCH 01/17] Make rule to target compile a new v4th.com --- 8086/msdos/Makefile | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index 6d85891..c4f598e 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -13,6 +13,11 @@ fth: $(fthfiles) $(fthfiles_caseconverted) clean: rm -f *.log *.LOG *.result *.golden +v4th.com: volks4th.com kernel.fb \ + emulator/run-in-dosbox.sh + rm -f FORTH.COM forth.com v4th.com + ./emulator/run-in-dosbox.sh volks4th.com kernel.fb + mv FORTH.COM v4th.com v4thfile.com: volks4th.com src/include.fb src/v4thfile.fb \ emulator/run-in-dosbox.sh From d8b8f0366edc3297653d34eed1c7200d0c77c572 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Mon, 31 Jan 2022 00:14:47 +0100 Subject: [PATCH 02/17] First test rule for the freshly-built-from-fb-src v4th.com, including a good deal of Makefile and run-in-dosbox.sh refactoring, e.g. the introduction of a dosfiles/ subdir in which dosbox runs, to eliminate the need for the Forth PATH word to run tests. --- 8086/msdos/Makefile | 64 ++++++++++++++----- 8086/msdos/emulator/run-in-dosbox.sh | 24 +++---- 8086/msdos/tests/golden/prelim.golden | 2 +- .../msdos/tests/golden/volks4th-prelim.golden | 41 ++++++++++++ 8086/msdos/tests/incltest.fth | 2 +- 8086/msdos/tests/logtest.fb | 2 +- 8086/msdos/tests/logtest.fth | 4 +- 8086/msdos/tests/test-min.fth | 2 +- 8086/msdos/tests/test-std.fth | 14 ++-- 8086/msdos/tests/testprep.fb | 1 + 8086/msdos/tests/testprep.fth | 38 +++++++++++ 11 files changed, 150 insertions(+), 44 deletions(-) create mode 100644 8086/msdos/tests/golden/volks4th-prelim.golden create mode 100644 8086/msdos/tests/testprep.fb create mode 100644 8086/msdos/tests/testprep.fth diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index c4f598e..b82e4ef 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -6,38 +6,54 @@ 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-min.result +test: incltest.result logtest.result test-min.result \ + test-volks4th-min.result fth: $(fthfiles) $(fthfiles_caseconverted) clean: rm -f *.log *.LOG *.result *.golden + rm -f dosfiles/* -v4th.com: volks4th.com kernel.fb \ - emulator/run-in-dosbox.sh +*.log: emulator/run-in-dosbox.sh + +# TODO: Make v4th.log contain something and check its contents +v4th.com v4th.log: volks4th.com kernel.fb tests/log2file.fb rm -f FORTH.COM forth.com v4th.com - ./emulator/run-in-dosbox.sh volks4th.com kernel.fb + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ + volks4th.com "include kernel.fb" + dos2unix -n OUTPUT.LOG v4th.log mv FORTH.COM v4th.com 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 + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh volks4th.com "include v4thfile.fb" mv V4THFILE.COM v4thfile.com -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.log: volks4th.com tests/log2file.fb tests/logtest.fb + rm -f OUTPUT.LOG + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh volks4th.com "include logtest.fb" + dos2unix -n OUTPUT.LOG $@ -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.log: v4thfile.com tests/log2file.fb tests/incltest.fth + rm -f OUTPUT.LOG + FORTHPATH="f:\\;f:\\tests" ./emulator/run-in-dosbox.sh \ + v4thfile.com "include incltest.fth" + dos2unix -n OUTPUT.LOG $@ -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-volks4th-min.log: v4thfile.com tests/* emulator/run-in-dosbox.sh + rm -f OUTPUT.LOG + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh v4thfile.com "include test-min.fth" + dos2unix -n OUTPUT.LOG $@ +test-min.log: dosfiles/v4th.com dosfiles/asm.fb dosfiles/extend.fb \ + dosfiles/multi.vid dosfiles/dos.fb dosfiles/include.fb \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \ + "include testprep.fb include test-min.fth") + dos2unix -n dosfiles/OUTPUT.LOG $@ test-min.golden: $(patsubst %, tests/golden/%.golden, prelim core) cat $? > $@ @@ -46,6 +62,10 @@ test-std.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double report-noblk) cat $? > $@ +test-volks4th-min.golden: $(patsubst %, tests/golden/%.golden, \ + volks4th-prelim core) + cat $? > $@ + %.golden: tests/golden/%.golden cp -p $< $@ @@ -54,6 +74,20 @@ test-std.golden: $(patsubst %, tests/golden/%.golden, \ rm -f $@ tests/evaluate-test.sh $(basename $@) + +dosfiles/%: % + test -d dosfiles || mkdir dosfiles + cp $< $@ + +dosfiles/%: src/% + test -d dosfiles || mkdir dosfiles + cp $< $@ + +dosfiles/%: tests/% + test -d dosfiles || mkdir dosfiles + cp $< $@ + + src/%.fth: src/%.fb ../../tools/fb2fth.py ../../tools/fb2fth.py $< $@ diff --git a/8086/msdos/emulator/run-in-dosbox.sh b/8086/msdos/emulator/run-in-dosbox.sh index 2162aa6..8613f8e 100755 --- a/8086/msdos/emulator/run-in-dosbox.sh +++ b/8086/msdos/emulator/run-in-dosbox.sh @@ -2,18 +2,12 @@ set -e -emulatordir="$(realpath --relative-to="$PWD" "$(dirname "${BASH_SOURCE[0]}")")" -basedir="$(realpath --relative-to="$PWD" "${emulatordir}/..")" - forth="$1" -include_filename="$2" -include_basename="${include_filename%.*}" -forthcmd="" +forthcmd="$2" exit="" bye="" -if [ -n "${include_basename}" ]; then - forthcmd="include ${include_filename}" - logname="${include_basename}.log" +if [ -n "${forthcmd}" ]; then + logname="output.log" doslogname="$(echo ${logname}|tr '[:lower:]' '[:upper:]')" rm -f "${logname}" "${doslogname}" if [ -z "${KEEPEMU}" ]; then @@ -24,13 +18,13 @@ fi auto_c="" autocmd="" +pathcmd="" if [ -n "${forth}" ]; then auto_c="-c" - autocmd="${forth} path f:\\;f:\\src;f:\\tests ${forthcmd} ${bye}" + if [ -n "${FORTHPATH}" ]; then + pathcmd="path ${FORTHPATH}" + fi + autocmd="${forth} ${pathcmd} ${forthcmd} ${bye}" fi -dosbox -c "mount f ${basedir}" -c "f:" "${auto_c}" "${autocmd}" $exit - -if [ -n "${include_basename}" ]; then - dos2unix -n "${doslogname}" "${logname}" -fi +dosbox -c "mount f ." -c "f:" "${auto_c}" "${autocmd}" $exit diff --git a/8086/msdos/tests/golden/prelim.golden b/8086/msdos/tests/golden/prelim.golden index cd2bedb..d381a31 100644 --- a/8086/msdos/tests/golden/prelim.golden +++ b/8086/msdos/tests/golden/prelim.golden @@ -25,7 +25,7 @@ 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 #20: testing ?F~ ?~~ Pass Error Pass #21: testing ?~ Pass #22: testing EMIT Pass #23: testing S" diff --git a/8086/msdos/tests/golden/volks4th-prelim.golden b/8086/msdos/tests/golden/volks4th-prelim.golden new file mode 100644 index 0000000..cd2bedb --- /dev/null +++ b/8086/msdos/tests/golden/volks4th-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/incltest.fth b/8086/msdos/tests/incltest.fth index 27cfcfd..2a0dd94 100644 --- a/8086/msdos/tests/incltest.fth +++ b/8086/msdos/tests/incltest.fth @@ -1,6 +1,6 @@ include log2file.fb -logopen incltest.log +logopen output.log .( hello, world) cr : test-hello ." hello, world, from test-hello" cr ; diff --git a/8086/msdos/tests/logtest.fb b/8086/msdos/tests/logtest.fb index 4bf54a9..9db9527 100644 --- a/8086/msdos/tests/logtest.fb +++ b/8086/msdos/tests/logtest.fb @@ -1 +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 +\ logtest.fb phz 04jan22 basic tests for log2file.fb \ loadscreen phz 22jan22 include log2file.fb logopen output.log .( logtest done) cr logclose \ No newline at end of file diff --git a/8086/msdos/tests/logtest.fth b/8086/msdos/tests/logtest.fth index fbcdda2..57a43d0 100644 --- a/8086/msdos/tests/logtest.fth +++ b/8086/msdos/tests/logtest.fth @@ -20,11 +20,11 @@ \ *** Block No. 1, Hexblock 1 -\ loadscreen phz 04jan22 +\ loadscreen phz 22jan22 include log2file.fb - logopen logtest.log + logopen output.log .( logtest done) cr logclose diff --git a/8086/msdos/tests/test-min.fth b/8086/msdos/tests/test-min.fth index 08b8962..b78ff86 100644 --- a/8086/msdos/tests/test-min.fth +++ b/8086/msdos/tests/test-min.fth @@ -1,6 +1,6 @@ include log2file.fth -logopen test.log +logopen output.log include ans-shim.fth : \vf [compile] \ ; immediate diff --git a/8086/msdos/tests/test-std.fth b/8086/msdos/tests/test-std.fth index 0f9bfc7..97bb1fb 100644 --- a/8086/msdos/tests/test-std.fth +++ b/8086/msdos/tests/test-std.fth @@ -1,6 +1,6 @@ include log2file.fth -logopen test.log +logopen output.log include ans-shim.fth : \vf [compile] \ ; immediate @@ -9,16 +9,14 @@ include prelimtest.fth include tester.fth \ 1 verbose ! include core.fr -include coreplustest.fth +include coreplus.fth -include utilities.fth -include errorreport.fth +include util.fth +include errorrep.fth -include coreexttest.fth -include doubletest.fth +include coreext.fth +include double.fth REPORT-ERRORS logclose - -dos s0:notdone diff --git a/8086/msdos/tests/testprep.fb b/8086/msdos/tests/testprep.fb new file mode 100644 index 0000000..64c92b4 --- /dev/null +++ b/8086/msdos/tests/testprep.fb @@ -0,0 +1 @@ +\ include file to bundle what test-*.fth need phz 30jan22\ on top of kernel.com \ loadscreen to prepare kernel.com for test-*.fth phz 30jan22 include extend.fb include multi.vid include dos.fb include include.fb include log2file.fb \ No newline at end of file diff --git a/8086/msdos/tests/testprep.fth b/8086/msdos/tests/testprep.fth new file mode 100644 index 0000000..d438799 --- /dev/null +++ b/8086/msdos/tests/testprep.fth @@ -0,0 +1,38 @@ + +\ *** Block No. 0, Hexblock 0 + +\ include file to bundle what test-*.fth need phz 30jan22 +\ on top of kernel.com + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen to prepare kernel.com for test-*.fth phz 30jan22 + + include extend.fb + include multi.vid + include dos.fb + include include.fb + include log2file.fb + + + + + + + + + From 081ed82c25501d482398155b704d7f247bdc0f74 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Mon, 31 Jan 2022 07:21:14 +0100 Subject: [PATCH 03/17] Run incltest.fth on new-built minimal v4th.com --- 8086/msdos/Makefile | 40 ++++++++++++++++++++++++++--------- 8086/msdos/multi.vid | 2 +- 8086/msdos/tests/incltest.fth | 1 + 3 files changed, 32 insertions(+), 11 deletions(-) diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index b82e4ef..5e5c104 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -7,7 +7,7 @@ fthfiles_caseconverted = $(patsubst %.fb, %.fth, \ $(shell ../../tools/echo-tolower.py $(fbfiles_uppercase))) test: incltest.result logtest.result test-min.result \ - test-volks4th-min.result + incltest-volks4th.result test-volks4th-min.result fth: $(fthfiles) $(fthfiles_caseconverted) @@ -36,7 +36,26 @@ logtest.log: volks4th.com tests/log2file.fb tests/logtest.fb FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh volks4th.com "include logtest.fb" dos2unix -n OUTPUT.LOG $@ -incltest.log: v4thfile.com tests/log2file.fb tests/incltest.fth +prepsrcs = asm.fb extend.fb multi.vid dos.fb include.fb + +incltest.log: \ + $(patsubst %, dosfiles/%, v4th.com $(prepsrcs) log2file.fb \ + incltest.fth) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh \ + v4th.com "include include.fb include incltest.fth") + dos2unix -n dosfiles/OUTPUT.LOG $@ + +test-min.log: \ + $(patsubst %, dosfiles/%, v4th.com $(prepsrcs)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \ + "include testprep.fb include test-min.fth") + dos2unix -n dosfiles/OUTPUT.LOG $@ + + +incltest-volks4th.log: v4thfile.com tests/log2file.fb tests/incltest.fth rm -f OUTPUT.LOG FORTHPATH="f:\\;f:\\tests" ./emulator/run-in-dosbox.sh \ v4thfile.com "include incltest.fth" @@ -44,16 +63,14 @@ incltest.log: v4thfile.com tests/log2file.fb tests/incltest.fth test-volks4th-min.log: v4thfile.com tests/* emulator/run-in-dosbox.sh rm -f OUTPUT.LOG - FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh v4thfile.com "include test-min.fth" + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ + v4thfile.com "include test-min.fth" dos2unix -n OUTPUT.LOG $@ -test-min.log: dosfiles/v4th.com dosfiles/asm.fb dosfiles/extend.fb \ - dosfiles/multi.vid dosfiles/dos.fb dosfiles/include.fb \ - $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) - rm -f dosfiles/OUTPUT.LOG - (cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \ - "include testprep.fb include test-min.fth") - dos2unix -n dosfiles/OUTPUT.LOG $@ + +run-editor: volks4th.com emulator/run-in-dosbox.sh + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh volks4th.com + test-min.golden: $(patsubst %, tests/golden/%.golden, prelim core) cat $? > $@ @@ -70,6 +87,9 @@ test-volks4th-min.golden: $(patsubst %, tests/golden/%.golden, \ %.golden: tests/golden/%.golden cp -p $< $@ +%-volks4th.golden: tests/golden/%.golden + cp -p $< $@ + %.result: %.log %.golden tests/evaluate-test.sh rm -f $@ tests/evaluate-test.sh $(basename $@) diff --git a/8086/msdos/multi.vid b/8086/msdos/multi.vid index 00988ce..827af07 100644 --- a/8086/msdos/multi.vid +++ b/8086/msdos/multi.vid @@ -1 +1 @@ - This display interface uses BIOS call $10 functions for a fast display interface. A couple of state variables is contained in a vector that is task specific such that different tasks may use different windows. For simplicity windows always span the whole width of the screen. They can be defined by top and bottom line. This mechanism is used for a convenient status display line on the bottom of the screen. \ Multitsking display interface loadscreen ks cas 10nov05 Onlyforth \needs Assembler 2 loadfrom asm.scr User area area off \ points at active window Variable status \ to switch status on/off | Variable cursor \ points at area with active cursor 1 8 +thru .( Multitasking display driver loaded ) cr \ Multitsking display interface ks 6 sep 86 : Area: Create 0 , 0 , 7 c, Does> area ! ; \ | col | row | top | bot | att | Area: terminal terminal area @ cursor ! : (area Create dup c, 1+ Does> c@ area @ + ; 0 | (area ccol | (area crow | (area ctop | (area cbot (area catt drop : window ( topline botline -- ) cbot c! ctop c! ; : full 0 c/col 2- window ; full \ Multitask (type (emit ks 20 dez 87 Code (type ( addr len -- ) W pop I push R push u' area U D) I mov U push D U mov $F # A+ mov $10 int u' catt I D) R- mov 3 # A+ mov $10 int C push D push $E0E # C mov 1 # A+ mov $10 int I ) D mov 1 # C mov U inc [[ U dec 0= not ?[[ 2 # A+ mov $10 int D- inc ' c/row >body #) D- cmp 0= not ?[[ W ) A- mov W inc 9 # A+ mov $10 int ]]? ]? D I ) mov D pop cursor #) I cmp 0= ?[ I ) D mov ]? 2 # A+ mov $10 int C pop 1 # A+ mov $10 int U pop R pop I pop D pop ' pause #) jmp end-code : (emit ( char -- ) sp@ 1 (type drop ; \ Multitask (at (at? ks 04 aug 87 Code (at ( row col -- ) A pop A- D+ mov u' area U D) W mov D W ) mov cursor #) W cmp 0= ?[ R push U push $F # A+ mov $10 int 2 # A+ mov $10 int U pop R pop ]? D pop Next end-code Code (at? ( -- row col ) D push u' area U D) W mov W ) D mov D+ A- mov 0 # A+ mov A+ D+ mov A push Next end-code Code curat? ( -- row col ) D push R push $F # A+ mov $10 int 3 # A+ mov $10 int R pop 0 # A mov D+ A- xchg A push Next end-code \ cur! curshape setpage ks 28 jun 87 : cur! \ set cursor into current task's window area @ cursor ! (at? (at ; cur! Code curshape ( top bot -- ) D C mov D pop D- C+ mov 1 # A+ mov $10 int D pop Next end-code Code setpage ( n -- ) $503 # A mov D- A- and $10 int D pop Next end-code \ Multitask normal invers blankline ks 01 nov 88 : normal 7 catt c! ; : invers $70 catt c! ; : underline 1 catt c! ; : bright $F catt c! ; Code blankline D push R push U push $F # A+ mov $10 int u' area U D) W mov u' catt W D) R- mov 3 # A+ mov $10 int C push D push $E0E # C mov 1 # A+ mov $10 int W ) D mov 2 # A+ mov $10 int ' c/row >body #) C mov D- C- sub bl # A- mov 9 # A+ mov C- C- or 0= not ?[ $10 int ]? D pop 2 # A+ mov $10 int \ set cursor back C pop 1 # A+ mov $10 int \ cursor visible again U pop R pop D pop ' pause #) jmp end-code | : lineerase ( line# -- ) 0 (at blankline ; \ Multitask (del scroll (cr (page ks 04 okt 87 : (del (at? ?dup IF 1- 2dup (at bl (emit (at exit THEN drop ; Code scroll D push R push U push u' area U D) W mov u' catt W D) R+ mov u' ctop W D) D mov D- C+ mov 0 # C- mov ' c/row >body #) D- mov D- dec $601 # A mov $10 int U pop R pop D pop Next end-code : (cr (at? drop 1+ dup cbot c@ u> IF scroll drop cbot c@ THEN lineerase ; : (page ctop c@ cbot c@ DO I lineerase -1 +LOOP ; \ Multitask status display ks 10 okt 87 ' (emit ' display 2 + ! ' (cr ' display 4 + ! ' (type ' display 6 + ! ' (del ' display 8 + ! ' (page ' display &10 + ! ' (at ' display &12 + ! ' (at? ' display &14 + ! : .base base @ decimal dup 2 .r base ! ; : .sp ( n -- ) ." s" depth swap 1+ - 2 .r ; : (.drv ( n -- ) Ascii A + emit ." : " ; : .dr ." " drv (.drv ; : .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN @ 5 .r ; : .space ." Dic" s0 @ here $100 + - 6 u.r ; \ statuszeile ks ks 04 aug 87 | : fstat ( n -- ) .base .sp .space .scr .dr file? 2 spaces order ; | Area: statusline statusline c/col 1- dup window page invers terminal : (.status output @ display area @ statusline status @ IF (at? drop 0 (at 2 fstat blankline ELSE normal page invers THEN area ! output ! ; ' (.status Is .status : bye status off .status bye ; \ No newline at end of file + This display interface uses BIOS call $10 functions for a fast display interface. A couple of state variables is contained in a vector that is task specific such that different tasks may use different windows. For simplicity windows always span the whole width of the screen. They can be defined by top and bottom line. This mechanism is used for a convenient status display line on the bottom of the screen. \ Multitsking display interface loadscreen ks phz 31jan22 Onlyforth \needs Assembler 2 loadfrom asm.fb User area area off \ points at active window Variable status \ to switch status on/off | Variable cursor \ points at area with active cursor 1 8 +thru .( Multitasking display driver loaded ) cr \ Multitsking display interface ks 6 sep 86 : Area: Create 0 , 0 , 7 c, Does> area ! ; \ | col | row | top | bot | att | Area: terminal terminal area @ cursor ! : (area Create dup c, 1+ Does> c@ area @ + ; 0 | (area ccol | (area crow | (area ctop | (area cbot (area catt drop : window ( topline botline -- ) cbot c! ctop c! ; : full 0 c/col 2- window ; full \ Multitask (type (emit ks 20 dez 87 Code (type ( addr len -- ) W pop I push R push u' area U D) I mov U push D U mov $F # A+ mov $10 int u' catt I D) R- mov 3 # A+ mov $10 int C push D push $E0E # C mov 1 # A+ mov $10 int I ) D mov 1 # C mov U inc [[ U dec 0= not ?[[ 2 # A+ mov $10 int D- inc ' c/row >body #) D- cmp 0= not ?[[ W ) A- mov W inc 9 # A+ mov $10 int ]]? ]? D I ) mov D pop cursor #) I cmp 0= ?[ I ) D mov ]? 2 # A+ mov $10 int C pop 1 # A+ mov $10 int U pop R pop I pop D pop ' pause #) jmp end-code : (emit ( char -- ) sp@ 1 (type drop ; \ Multitask (at (at? ks 04 aug 87 Code (at ( row col -- ) A pop A- D+ mov u' area U D) W mov D W ) mov cursor #) W cmp 0= ?[ R push U push $F # A+ mov $10 int 2 # A+ mov $10 int U pop R pop ]? D pop Next end-code Code (at? ( -- row col ) D push u' area U D) W mov W ) D mov D+ A- mov 0 # A+ mov A+ D+ mov A push Next end-code Code curat? ( -- row col ) D push R push $F # A+ mov $10 int 3 # A+ mov $10 int R pop 0 # A mov D+ A- xchg A push Next end-code \ cur! curshape setpage ks 28 jun 87 : cur! \ set cursor into current task's window area @ cursor ! (at? (at ; cur! Code curshape ( top bot -- ) D C mov D pop D- C+ mov 1 # A+ mov $10 int D pop Next end-code Code setpage ( n -- ) $503 # A mov D- A- and $10 int D pop Next end-code \ Multitask normal invers blankline ks 01 nov 88 : normal 7 catt c! ; : invers $70 catt c! ; : underline 1 catt c! ; : bright $F catt c! ; Code blankline D push R push U push $F # A+ mov $10 int u' area U D) W mov u' catt W D) R- mov 3 # A+ mov $10 int C push D push $E0E # C mov 1 # A+ mov $10 int W ) D mov 2 # A+ mov $10 int ' c/row >body #) C mov D- C- sub bl # A- mov 9 # A+ mov C- C- or 0= not ?[ $10 int ]? D pop 2 # A+ mov $10 int \ set cursor back C pop 1 # A+ mov $10 int \ cursor visible again U pop R pop D pop ' pause #) jmp end-code | : lineerase ( line# -- ) 0 (at blankline ; \ Multitask (del scroll (cr (page ks 04 okt 87 : (del (at? ?dup IF 1- 2dup (at bl (emit (at exit THEN drop ; Code scroll D push R push U push u' area U D) W mov u' catt W D) R+ mov u' ctop W D) D mov D- C+ mov 0 # C- mov ' c/row >body #) D- mov D- dec $601 # A mov $10 int U pop R pop D pop Next end-code : (cr (at? drop 1+ dup cbot c@ u> IF scroll drop cbot c@ THEN lineerase ; : (page ctop c@ cbot c@ DO I lineerase -1 +LOOP ; \ Multitask status display ks 10 okt 87 ' (emit ' display 2 + ! ' (cr ' display 4 + ! ' (type ' display 6 + ! ' (del ' display 8 + ! ' (page ' display &10 + ! ' (at ' display &12 + ! ' (at? ' display &14 + ! : .base base @ decimal dup 2 .r base ! ; : .sp ( n -- ) ." s" depth swap 1+ - 2 .r ; : (.drv ( n -- ) Ascii A + emit ." : " ; : .dr ." " drv (.drv ; : .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN @ 5 .r ; : .space ." Dic" s0 @ here $100 + - 6 u.r ; \ statuszeile ks ks 04 aug 87 | : fstat ( n -- ) .base .sp .space .scr .dr file? 2 spaces order ; | Area: statusline statusline c/col 1- dup window page invers terminal : (.status output @ display area @ statusline status @ IF (at? drop 0 (at 2 fstat blankline ELSE normal page invers THEN area ! output ! ; ' (.status Is .status : bye status off .status bye ; \ No newline at end of file diff --git a/8086/msdos/tests/incltest.fth b/8086/msdos/tests/incltest.fth index 2a0dd94..02da693 100644 --- a/8086/msdos/tests/incltest.fth +++ b/8086/msdos/tests/incltest.fth @@ -1,4 +1,5 @@ +\needs (type include extend.fb include multi.vid include dos.fb include log2file.fb logopen output.log From 5dc3bbef7ccec83b98bd4b7b5bca12384a346250 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Tue, 1 Feb 2022 09:11:14 +0100 Subject: [PATCH 04/17] Move all msdos block file Forth sources (.fb, .vid, .sys, .prn) to the msdos/src subdir and generate .fth copies of the .fb files. --- 8086/msdos/Makefile | 2 +- 8086/msdos/{ => src}/ansi.vid | 0 8086/msdos/{ => src}/asm.fb | 0 8086/msdos/src/asm.fth | 437 +++++ 8086/msdos/{ => src}/bios.vid | 0 8086/msdos/{ => src}/blocking.fb | 0 8086/msdos/src/blocking.fth | 57 + 8086/msdos/{ => src}/ced.fb | 0 8086/msdos/src/ced.fth | 152 ++ 8086/msdos/{ => src}/disasm.fb | 0 8086/msdos/src/disasm.fth | 836 ++++++++ 8086/msdos/{ => src}/disks.cfg | 0 8086/msdos/{ => src}/dos.fb | 0 8086/msdos/src/dos.fth | 342 ++++ 8086/msdos/{ => src}/double.fb | 0 8086/msdos/src/double.fth | 95 + 8086/msdos/{ => src}/editor.fb | 0 8086/msdos/src/editor.fth | 798 ++++++++ 8086/msdos/{ => src}/epson.prn | 0 8086/msdos/{ => src}/extend.fb | 0 8086/msdos/src/extend.fth | 209 ++ 8086/msdos/{ => src}/f83asm.fb | 0 8086/msdos/src/f83asm.fth | 646 ++++++ 8086/msdos/{ => src}/graphic.prn | 0 8086/msdos/{ => src}/install.fb | 0 8086/msdos/src/install.fth | 342 ++++ 8086/msdos/{ => src}/kernel.fb | Bin 8086/msdos/src/kernel.fth | 3040 +++++++++++++++++++++++++++++ 8086/msdos/{ => src}/m130i.prn | 0 8086/msdos/{ => src}/meta.fb | 0 8086/msdos/src/meta.fth | 1007 ++++++++++ 8086/msdos/{ => src}/minimal.sys | 0 8086/msdos/{ => src}/miniterm.fb | 0 8086/msdos/src/miniterm.fth | 380 ++++ 8086/msdos/{ => src}/multi.vid | 0 8086/msdos/{ => src}/nec8023.prn | 0 8086/msdos/{ => src}/primed.fb | 0 8086/msdos/src/primed.fth | 133 ++ 8086/msdos/{ => src}/see.fb | 0 8086/msdos/src/see.fth | 2318 ++++++++++++++++++++++ 8086/msdos/{ => src}/serial.fb | 0 8086/msdos/src/serial.fth | 418 ++++ 8086/msdos/{ => src}/stream.fb | 0 8086/msdos/src/stream.fth | 209 ++ 8086/msdos/{ => src}/system.cfg | 0 8086/msdos/{ => src}/tasker.fb | 0 8086/msdos/src/tasker.fth | 95 + 8086/msdos/{ => src}/timer.fb | 0 8086/msdos/src/timer.fth | 95 + 8086/msdos/{ => src}/tools.fb | 0 8086/msdos/src/tools.fth | 247 +++ 8086/msdos/{ => src}/volks4th.sys | 0 52 files changed, 11857 insertions(+), 1 deletion(-) rename 8086/msdos/{ => src}/ansi.vid (100%) rename 8086/msdos/{ => src}/asm.fb (100%) create mode 100644 8086/msdos/src/asm.fth rename 8086/msdos/{ => src}/bios.vid (100%) rename 8086/msdos/{ => src}/blocking.fb (100%) create mode 100644 8086/msdos/src/blocking.fth rename 8086/msdos/{ => src}/ced.fb (100%) create mode 100644 8086/msdos/src/ced.fth rename 8086/msdos/{ => src}/disasm.fb (100%) create mode 100644 8086/msdos/src/disasm.fth rename 8086/msdos/{ => src}/disks.cfg (100%) rename 8086/msdos/{ => src}/dos.fb (100%) create mode 100644 8086/msdos/src/dos.fth rename 8086/msdos/{ => src}/double.fb (100%) create mode 100644 8086/msdos/src/double.fth rename 8086/msdos/{ => src}/editor.fb (100%) create mode 100644 8086/msdos/src/editor.fth rename 8086/msdos/{ => src}/epson.prn (100%) rename 8086/msdos/{ => src}/extend.fb (100%) create mode 100644 8086/msdos/src/extend.fth rename 8086/msdos/{ => src}/f83asm.fb (100%) create mode 100644 8086/msdos/src/f83asm.fth rename 8086/msdos/{ => src}/graphic.prn (100%) rename 8086/msdos/{ => src}/install.fb (100%) create mode 100644 8086/msdos/src/install.fth rename 8086/msdos/{ => src}/kernel.fb (100%) create mode 100644 8086/msdos/src/kernel.fth rename 8086/msdos/{ => src}/m130i.prn (100%) rename 8086/msdos/{ => src}/meta.fb (100%) create mode 100644 8086/msdos/src/meta.fth rename 8086/msdos/{ => src}/minimal.sys (100%) rename 8086/msdos/{ => src}/miniterm.fb (100%) create mode 100644 8086/msdos/src/miniterm.fth rename 8086/msdos/{ => src}/multi.vid (100%) rename 8086/msdos/{ => src}/nec8023.prn (100%) rename 8086/msdos/{ => src}/primed.fb (100%) create mode 100644 8086/msdos/src/primed.fth rename 8086/msdos/{ => src}/see.fb (100%) create mode 100644 8086/msdos/src/see.fth rename 8086/msdos/{ => src}/serial.fb (100%) create mode 100644 8086/msdos/src/serial.fth rename 8086/msdos/{ => src}/stream.fb (100%) create mode 100644 8086/msdos/src/stream.fth rename 8086/msdos/{ => src}/system.cfg (100%) rename 8086/msdos/{ => src}/tasker.fb (100%) create mode 100644 8086/msdos/src/tasker.fth rename 8086/msdos/{ => src}/timer.fb (100%) create mode 100644 8086/msdos/src/timer.fth rename 8086/msdos/{ => src}/tools.fb (100%) create mode 100644 8086/msdos/src/tools.fth rename 8086/msdos/{ => src}/volks4th.sys (100%) diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index 5e5c104..7dad4fe 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -18,7 +18,7 @@ clean: *.log: emulator/run-in-dosbox.sh # TODO: Make v4th.log contain something and check its contents -v4th.com v4th.log: volks4th.com kernel.fb tests/log2file.fb +v4th.com v4th.log: volks4th.com src/kernel.fb tests/log2file.fb rm -f FORTH.COM forth.com v4th.com FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ volks4th.com "include kernel.fb" diff --git a/8086/msdos/ansi.vid b/8086/msdos/src/ansi.vid similarity index 100% rename from 8086/msdos/ansi.vid rename to 8086/msdos/src/ansi.vid diff --git a/8086/msdos/asm.fb b/8086/msdos/src/asm.fb similarity index 100% rename from 8086/msdos/asm.fb rename to 8086/msdos/src/asm.fb diff --git a/8086/msdos/src/asm.fth b/8086/msdos/src/asm.fth new file mode 100644 index 0000000..5b0e289 --- /dev/null +++ b/8086/msdos/src/asm.fth @@ -0,0 +1,437 @@ + +\ *** Block No. 0, Hexblock 0 + +\ 8086 Assembler cas 10nov05 +This 8086 Assembler was written by Klaus Schleisiek. +Assembler Definitions are created with the definig word +CODE and closed with the word END-CODE. + +The 8086 Registers naming and usage in volksFORTH + +Intel vForth Used for 8bit-Register +AX A free A+ A- +DX D topmost Stackitem D+ D- +CX C free C+ C- +BX R Returnstack Pointer R+ R- +BP U User Pointer +SP S Stack Pointer +SI I Instruction Pointer +DI W Word Pointer, mostly free + +\ *** Block No. 1, Hexblock 1 + +\ 8086 Assembler loadscreen cas 10nov05 + Onlyforth + +| : u2/ ( 16b -- 15b ) 2/ $7FFF and ; +| : 8* ( 15b -- 16b ) 2* 2* 2* ; +| : 8/ ( 16b -- 13b ) u2/ 2/ 2/ ; + + Vocabulary Assembler + Assembler also definitions + + 3 &21 thru clear .( Assembler loaded ) cr + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ conditional Assembler compiler cas 10nov05 + here + + : temp-assembler ( addr -- ) hide last off dp ! + " ASSEMBLER" find nip ?exit here $1800 + sp@ u> + IF display cr ." Assembler won't fit" abort THEN + here sp@ $1800 - dp ! 1 load dp ! ; + + temp-assembler \\ + + : blocks ( n -- addr / ff ) + first @ >r dup 0 ?DO freebuffer LOOP + [ b/blk negate ] Literal * first @ + r@ u> r> and ; + + + + +\ *** Block No. 3, Hexblock 3 + +\ Code generating primitives cas 10nov05 + + Variable >codes \ points at table of execution vectors + +| Create nrc ] c, , here ! c! [ + + : nonrelocate nrc >codes ! ; nonrelocate + +| : >exec ( n -- n+2 ) Create dup c, 2+ + Does> c@ >codes @ + perform ; + +0 | >exec >c, | >exec >, | >exec >here + | >exec >! | >exec >c! drop + + + + +\ *** Block No. 4, Hexblock 4 + +\ 8086 Registers cas 10nov05 + + 0 Constant A 1 Constant C 2 Constant D 3 Constant R + 4 Constant S 5 Constant U 6 Constant I 7 Constant W +' I Alias SI ' W Alias DI ' R Alias BX + + 8 Constant A- 9 Constant C- $A Constant D- $B Constant R- +$C Constant A+ $D Constant C+ $E Constant D+ $F Constant R+ +' R- Alias B- ' R+ Alias B+ + + $100 Constant E: $101 Constant C: + $102 Constant S: $103 Constant D: + +| Variable isize ( specifies Size by prefix) +| : Size: ( n -- ) Create c, Does> c@ isize ! ; + 0 Size: byte 1 Size: word word 2 Size: far + +\ *** Block No. 5, Hexblock 5 + +\ 8086 Assembler System variables cas 10nov05 + +| Variable direction \ 0 reg>EA, -1 EA>reg +| Variable size \ 1 word, 0 byte, -1 undefined +| Variable displaced \ 1 direct, 0 nothing, -1 displaced +| Variable displacement + +| : setsize isize @ size ! ; +| : long? ( n -- f ) $FF80 and dup 0< not ?exit $FF80 xor ; +| : wexit rdrop word ; +| : moderr word true Abort" invalid" ; +| : ?moderr ( f -- ) 0=exit moderr ; +| : ?word size @ 1- ?moderr ; +| : far? ( -- f ) size @ 2 = ; + + + +\ *** Block No. 6, Hexblock 6 + +\ 8086 addressing modes cas 10nov05 + +| Create (EA 7 c, 0 c, 6 c, 4 c, 5 c, +| : () ( 8b1 -- 8b2 ) + 3 - dup 4 u> over 1 = or ?moderr (EA + c@ ; + + -1 Constant # $C6 Constant #) -1 Constant C* + + : ) ( u1 -- u2 ) + () 6 case? IF 0 $86 exit THEN $C0 or ; + : I) ( u1 u2 -- u3 ) + 9 - dup 3 u> ?moderr $C0 or ; + + : D) ( n u1 -- n u2 ) + () over long? IF $40 ELSE $80 THEN or ; + : DI) ( n u1 u2 -- n u3 ) + I) over long? IF $80 ELSE $40 THEN xor ; + +\ *** Block No. 7, Hexblock 7 + +\ 8086 Registers and addressing modes cas 10nov05 + +| : displaced? ( [n] u1 -- [n] u1 f ) + dup #) = IF 1 exit THEN + dup $C0 and dup $40 = swap $80 = or ; + +| : displace ( [n] u1 -- u1 ) displaced? ?dup 0=exit + displaced @ ?moderr displaced ! swap displacement ! ; + +| : rmode ( u1 -- u2 ) 1 size ! dup 8 and 0=exit + size off $FF07 and ; + +| : mmode? ( 9b - 9b f) dup $C0 and ; + +| : rmode? ( 8b1 - 8b1 f) mmode? $C0 = ; + + +\ *** Block No. 8, Hexblock 8 + +\ 8086 decoding addressing modes cas 10nov05 + +| : 2address ( [n] source [displ] dest -- 15b / [n] 16b ) + size on displaced off dup # = ?moderr mmode? + IF displace False ELSE rmode True THEN direction ! + >r # case? IF r> $80C0 xor size @ 1+ ?exit setsize exit + THEN direction @ + IF r> 8* >r mmode? IF displace + ELSE dup 8/ 1 and size @ = ?moderr $FF07 and THEN + ELSE rmode 8* + THEN r> or $C0 xor ; + +| : 1address ( [displ] 9b -- 9b ) + # case? ?moderr size on displaced off direction off + mmode? IF displace setsize ELSE rmode THEN $C0 xor ; + + +\ *** Block No. 9, Hexblock 9 + +\ 8086 assembler cas 10nov05 +| : immediate? ( u -- u f ) dup 0< ; + +| : nonimmediate ( u -- u ) immediate? ?moderr ; + +| : r/m 7 and ; + +| : reg $38 and ; + +| : ?akku ( u -- u ff / tf ) dup r/m 0= dup 0=exit nip ; + +| : smode? ( u1 -- u1 ff / u2 tf ) dup $F00 and + IF dup $100 and IF dup r/m 8* swap reg 8/ + or $C0 or direction off + THEN True exit + THEN False ; + +\ *** Block No. 10, Hexblock a + +\ 8086 Registers and addressing modes cas 10nov05 + +| : w, size @ or >c, ; + +| : dw, size @ or direction @ IF 2 xor THEN >c, ; + +| : ?word, ( u1 f -- ) IF >, exit THEN >c, ; + +| : direct, displaced @ 0=exit + displacement @ dup long? displaced @ 1+ or ?word, ; + +| : r/m, >c, direct, ; + +| : data, size @ ?word, ; + + + +\ *** Block No. 11, Hexblock b + +\ 8086 Arithmetic instructions cas 10nov05 + +| : Arith: ( code -- ) Create , + Does> @ >r 2address immediate? + IF rmode? IF ?akku IF r> size @ + IF 5 or >c, >, wexit THEN + 4 or >c, >c, wexit THEN THEN + r@ or $80 size @ or r> 0< + IF size @ IF 2 pick long? 0= IF 2 or size off THEN + THEN THEN >c, >c, direct, data, wexit + THEN r> dw, r/m, wexit ; + + $8000 Arith: add $0008 Arith: or + $8010 Arith: adc $8018 Arith: sbb + $0020 Arith: and $8028 Arith: sub + $0030 Arith: xor $8038 Arith: cmp + +\ *** Block No. 12, Hexblock c + +\ 8086 move push pop cas 10nov05 + + : mov [ Forth ] 2address immediate? + IF rmode? IF r/m $B0 or size @ IF 8 or THEN + >c, data, wexit + THEN $C6 w, r/m, data, wexit + THEN 6 case? IF $A2 dw, direct, wexit THEN + smode? IF $8C direction @ IF 2 or THEN >c, r/m, wexit + THEN $88 dw, r/m, wexit ; + +| : pupo [ Forth ] >r 1address ?word + smode? IF reg 6 r> IF 1+ THEN or >c, wexit THEN + rmode? IF r/m $50 or r> or >c, wexit THEN + r> IF $8F ELSE $30 or $FF THEN >c, r/m, wexit ; + + : push 0 pupo ; : pop 8 pupo ; + +\ *** Block No. 13, Hexblock d + +\ 8086 inc & dec , effective addresses cas 10nov05 + +| : inc/dec [ Forth ] >r 1address rmode? + IF size @ IF r/m $40 or r> or >c, wexit THEN + THEN $FE w, r> or r/m, wexit ; + + : dec 8 inc/dec ; : inc 0 inc/dec ; + +| : EA: ( code -- ) Create c, [ Forth ] + Does> >r 2address nonimmediate + rmode? direction @ 0= or ?moderr r> c@ >c, r/m, wexit ; + + $C4 EA: les $8D EA: lea $C5 EA: lds + + + + +\ *** Block No. 14, Hexblock e + +\ 8086 xchg segment prefix cas 10nov05 + : xchg [ Forth ] 2address nonimmediate rmode? + IF size @ IF dup r/m 0= + IF 8/ true ELSE dup $38 and 0= THEN + IF r/m $90 or >c, wexit THEN + THEN THEN $86 w, r/m, wexit ; + +| : 1addr: ( code -- ) Create c, [ Forth ] + Does> c@ >r 1address $F6 w, r> or r/m, wexit ; + + $10 1addr: com $18 1addr: neg + $20 1addr: mul $28 1addr: imul + $38 1addr: idiv $30 1addr: div + + : seg ( 8b -) [ Forth ] + $100 xor dup $FFFC and ?moderr 8* $26 or >c, ; + +\ *** Block No. 15, Hexblock f + +\ 8086 test not neg mul imul div idiv cas 10nov05 + + : test [ Forth ] 2address immediate? + IF rmode? IF ?akku IF $A8 w, data, wexit THEN THEN + $F6 w, r/m, data, wexit + THEN $84 w, r/m, wexit ; + +| : in/out [ Forth ] >r 1address setsize + $C2 case? IF $EC r> or w, wexit THEN + 6 - ?moderr $E4 r> or w, displacement @ >c, wexit ; + + : out 2 in/out ; : in 0 in/out ; + + : int 3 case? IF $CC >c, wexit THEN $CD >c, >c, wexit ; + + + +\ *** Block No. 16, Hexblock 10 + +\ 8086 shifts and string instructions cas 10nov05 + +| : Shifts: ( code -- ) Create c, [ Forth ] + Does> c@ >r C* case? >r 1address + r> direction ! $D0 dw, r> or r/m, wexit ; + + $00 Shifts: rol $08 Shifts: ror + $10 Shifts: rcl $18 Shifts: rcr + $20 Shifts: shl $28 Shifts: shr + $38 Shifts: sar ' shl Alias sal + +| : Str: ( code -- ) Create c, + Does> c@ setsize w, wexit ; + + $A6 Str: cmps $AC Str: lods $A4 Str: movs + $AE Str: scas $AA Str: stos + +\ *** Block No. 17, Hexblock 11 + +\ implied 8086 instructions cas 10nov05 + + : Byte: ( code -- ) Create c, Does> c@ >c, ; + : Word: ( code -- ) Create , Does> @ >, ; + + $37 Byte: aaa $AD5 Word: aad $AD4 Word: aam + $3F Byte: aas $98 Byte: cbw $F8 Byte: clc + $FC Byte: cld $FA Byte: cli $F5 Byte: cmc + $99 Byte: cwd $27 Byte: daa $2F Byte: das + $F4 Byte: hlt $CE Byte: into $CF Byte: iret + $9F Byte: lahf $F0 Byte: lock $90 Byte: nop + $9D Byte: popf $9C Byte: pushf $9E Byte: sahf + $F9 Byte: stc $FD Byte: std $FB Byte: sti + $9B Byte: wait $D7 Byte: xlat + $C3 Byte: ret $CB Byte: lret + $F2 Byte: rep $F2 Byte: 0<>rep $F3 Byte: 0=rep + +\ *** Block No. 18, Hexblock 12 + +\ 8086 jmp call conditions cas 10nov05 +| : jmp/call >r setsize # case? [ Forth ] + IF far? IF r> IF $EA ELSE $9A THEN >c, swap >, >, wexit + THEN >here 2+ - r> + IF dup long? 0= IF $EB >c, >c, wexit THEN $E9 + ELSE $E8 THEN >c, 1- >, wexit + THEN 1address $FF >c, $10 or r> + + far? IF 8 or THEN r/m, wexit ; + : call 0 jmp/call ; : jmp $10 jmp/call ; + + $71 Constant OS $73 Constant CS + $75 Constant 0= $77 Constant >= + $79 Constant 0< $7B Constant PE + $7D Constant < $7F Constant <= + $E2 Constant C0= $E0 Constant ?C0= + : not 1 [ Forth ] xor ; + +\ *** Block No. 19, Hexblock 13 + +\ 8086 conditional branching cas 10nov05 + + : +ret $C2 >c, >, ; + : +lret $CA >c, >, ; + +| : ?range dup long? abort" out of range" ; + + : ?[ >, >here 1- ; + : ]? >here over 1+ - ?range swap >c! ; + : ][ $EB ?[ swap ]? ; + : ?[[ ?[ swap ; + : [[ >here ; + : ?] >c, >here 1+ - ?range >c, ; + : ]] $EB ?] ; + : ]]? ]] ]? ; + + +\ *** Block No. 20, Hexblock 14 + +\ Next user' end-code ;c: cas 10nov05 + + : Next lods A W xchg W ) jmp + >here next-link @ >, next-link ! ; + + : u' ' >body c@ ; + + Forth definitions + +\needs end-code : end-code toss also ; + + Assembler definitions + + : ;c: recover # call last off end-code 0 ] ; + + + +\ *** Block No. 21, Hexblock 15 + +\ 8086 Assembler, Forth words cas 10nov05 + Onlyforth + + : Assembler Assembler [ Assembler ] wexit ; + + : ;code 0 ?pairs compile (;code + reveal [compile] [ Assembler ; immediate + + : Code Create [ Assembler ] >here dup 2- >! Assembler ; + + : >label ( addr -- ) + here | Create immediate swap , 4 hallot + here 4 - heap 4 cmove heap last @ (name> ! dp ! + Does> ( -- addr ) @ state @ 0=exit [compile] Literal ; + + : Label [ Assembler ] >here >label Assembler ; + +\ *** Block No. 22, Hexblock 16 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/bios.vid b/8086/msdos/src/bios.vid similarity index 100% rename from 8086/msdos/bios.vid rename to 8086/msdos/src/bios.vid diff --git a/8086/msdos/blocking.fb b/8086/msdos/src/blocking.fb similarity index 100% rename from 8086/msdos/blocking.fb rename to 8086/msdos/src/blocking.fb diff --git a/8086/msdos/src/blocking.fth b/8086/msdos/src/blocking.fth new file mode 100644 index 0000000..657d78b --- /dev/null +++ b/8086/msdos/src/blocking.fth @@ -0,0 +1,57 @@ + +\ *** Block No. 0, Hexblock 0 + +\ cas 11nov05 +Routines to copy physical blocks into files. + +The copy will done from the current file and drive into a new +file created in on the current MS-DOS drive and sub-directory. +So there can be a different drives used in the DIRECT Mode and +in the FILE Mode. + +This command sequence will copy the physical blocks 10-20 on +driver C: into file "TEST.FB" on drive D: in Subdirectory +"\VOLKS". + + +KERNEL.FB D: CD \VOLKS +DIRECT C: +10 20 BLOCKS>FILE TEST.FB + +\ *** Block No. 1, Hexblock 1 + +\ copy physical blocks to file cas 10nov05 + +| File outfile + + : blocks>file ( from to -- ) [ Dos ] + isfile@ -rot outfile make 1+ swap + ?DO I over (block + ds@ swap b/blk isfile@ lfputs + LOOP close isfile ! ; + + + + + + + + +\ *** Block No. 2, Hexblock 2 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/ced.fb b/8086/msdos/src/ced.fb similarity index 100% rename from 8086/msdos/ced.fb rename to 8086/msdos/src/ced.fb diff --git a/8086/msdos/src/ced.fth b/8086/msdos/src/ced.fth new file mode 100644 index 0000000..e2ada58 --- /dev/null +++ b/8086/msdos/src/ced.fth @@ -0,0 +1,152 @@ + +\ *** Block No. 0, Hexblock 0 + +\ Commandline EDitor for volksFORTH rev. 3.80 cas 10nov05 +This File contains definitions to create an editable Forth +command line with history. +The commandline histroy allows older commands to be recalled. +These older commands will be stored in Screen 0 in a file called +"history" and will be preserved even when calling SAVE-SYSTEM. + + +Keys: + Cursor left/right   + Delete Char und <- + Delete Line + toggle Insert + finish line + Jump to Beginning/End of Line + recall older commands   + +\ *** Block No. 1, Hexblock 1 + +\ Commandline EDitor LOAD-Screen cas 10nov05 + + +: curleft ( -- ) at? 1- at ; +: currite ( -- ) at? 1+ at ; + +1 5 +thru \ enhanced Input + +.( Commandline Editor loaded ) cr + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ History -- Commandhistory cas 10nov05 +makefile history 1 more + +| Variable line# line# off +| Variable lastline# lastline# off + +| : 'history ( n -- addr ) isfile push history + c/l * b/blk /mod block + ; + +| : @line ( n -- addr len ) 'history c/l -trailing ; +| : !history ( addr line# -- ) + 'history dup c/l blank span @ c/l min cmove update ; +| : @history ( addr line# -- ) + @line rot swap dup span ! cmove ; + +| : +line ( n addr -- ) dup @ rot + l/s mod swap ! ; + +\ *** Block No. 3, Hexblock 3 + +\ End of input cas 10nov05 + +| Variable maxchars | Variable insert insert on + +| : -text ( a1 a2 l -- 0=equal ) bounds + ?DO count I c@ - ?dup IF nip ENDLOOP exit THEN LOOP 0= ; + +| : done ( a p1 -- a p2 ) 2dup + at? rot - span @ dup maxchars ! + at space blankline + line# @ @line span @ = IF span @ -text 0=exit 2dup THEN + drop lastline# @ !history 1 lastline# +line ; + + + + + + +\ *** Block No. 4, Hexblock 4 + +\ enhanced input cas 10nov05 +| : redisplay ( addr pos -- ) + at? 2swap span @ swap /string type blankline at ; + +| : del ( addr pos -- ) span @ 0=exit dup >r + dup 1+ swap + span @ r> - cmove -1 span +! ; +| : ins ( addr pos1 -- ) dup >r + dup dup 1+ + span @ r> - cmove> bl swap c! 1 span +! ; + +| : delete ( a p1 -- a p2 ) 2dup del 2dup redisplay ; +| : back ( a p1 -- a p2 ) 1- curleft delete ; + +| : recall ( a p1 -- a p2 ) at? rot - at dup line# @ @history + dup 0 redisplay at? span @ + at span @ ; + +| : r insert @ IF 2dup ins THEN 2dup + + r> swap c! 1+ dup span @ max span ! 2dup redisplay ; + +\ *** Block No. 6, Hexblock 6 + +\ Patch cas 10nov05 + +: showcur ( -- ) + insert @ IF &11 ELSE &6 THEN &12 curshape ; + +: (expect ( addr len -- ) maxchars ! span off + lastline# @ line# ! 0 + BEGIN span @ maxchars @ u< + WHILE key decode showcur REPEAT 2drop ; + +' (decode ' keyboard 6 + ! +' (expect ' keyboard 8 + ! + + + + + +\ *** Block No. 7, Hexblock 7 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/disasm.fb b/8086/msdos/src/disasm.fb similarity index 100% rename from 8086/msdos/disasm.fb rename to 8086/msdos/src/disasm.fb diff --git a/8086/msdos/src/disasm.fth b/8086/msdos/src/disasm.fth new file mode 100644 index 0000000..17fb9d5 --- /dev/null +++ b/8086/msdos/src/disasm.fth @@ -0,0 +1,836 @@ + +\ *** Block No. 0, Hexblock 0 + +\ + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ A disassembler for the 8086 by Charles Curley cas 10nov05 +\ adapted to volksFORTH-83 by B. Molte + + | : internal 1 ?head ! ; + | : external ?head off ; + + onlyFORTH forth DEFINITIONS DECIMAL + + VOCABULARY DISAM DISAM also DEFINITIONS + + 2 capacity 1- thru + onlyforth + + cr .( Use DIS to disassemble word. ) + cr .( ESC will stop the output. ) + + +\ *** Block No. 2, Hexblock 2 + +\ cas 10nov05 + + internal + + : [and] and ; \ the forth and + : [or] or ; + + : mask ( n maskb -- n n' ) over and ; + + 5 constant 5 \ save some space + 6 constant 6 + 7 constant 7 + 8 constant 8 + + + + +\ *** Block No. 3, Hexblock 3 + +\ + internal + + : EXEC [and] 2* R> + PERFORM ; + + : STOP[ + 0 ?pairs [compile] [ reveal ; immediate restrict + + code shift> \ n ct --- n' | shift n right ct times + D C mov D pop D C* shr next end-code +\ : shift> 0 ?DO 2/ ( shift's artihm.!) $7FFF and LOOP ; + + code SEXT \ n --- n' | sign extend lower half of n to upper + D A mov cbw A D mov next end-code +\ : hsext $FF and dup $80 and IF $FF00 or THEN ; + + +\ *** Block No. 4, Hexblock 4 + +\ + external + VARIABLE RELOC 0 , ds@ 0 RELOC 2! \ keeps relocation factor + internal + + VARIABLE CP + VARIABLE OPS \ operand count + + : cp@ cp @ ; + : C? C@ . ; + + : (T@) RELOC 2@ ROT + L@ ; \ in first word, seg in 2nd. You + \ dump/dis any segment w/ any + : (TC@) RELOC 2@ ROT + LC@ ; \ relocation you want by setting + \ RELOC correctly. + : SETSEG RELOC 2+ ! ; + +\ *** Block No. 5, Hexblock 5 + +\ + external + + DEFER T@ DEFER TC@ + + : HOMESEG ds@ SETSEG ; HOMESEG + + : SEG? RELOC 2+ @ 4 U.r ; + + : .seg:off seg? ." :" cp@ 4 u.r 2 spaces ; + + : MEMORY ['] (TC@) IS TC@ ['] (T@) IS T@ ; MEMORY + + + + + +\ *** Block No. 6, Hexblock 6 + +\ + internal + + + : oops ." ??? " ; + + : OOPS0 oops ; + : OOPS1 oops drop ; + : OOPS2 oops 2drop ; + + + + + + + + +\ *** Block No. 7, Hexblock 7 + +\ + + : NEXTB CP@ TC@ 1 CP +! ; + : NEXTW CP@ T@ 2 CP +! ; + + : .myself \ --- | have the current word print out its name. + LAST @ [COMPILE] LITERAL COMPILE .name ; IMMEDIATE + + + + + + + + + + +\ *** Block No. 8, Hexblock 8 + +\ + internal + + VARIABLE IM \ 2nd operand extension flag/ct + + : ?DISP \ op ext --- op ext | does MOD operand have a disp? + DUP 6 shift> DUP 3 = OVER 0= [or] 0= IF IM ! exit then + 0= IF DUP 7 [and] 6 = IF 2 IM ! THEN THEN ; + + +: .SELF \ -- | create a word which prints its name + CREATE LAST @ , DOES> @ .name ; \ the ultimate in self-doc! + + + + + +\ *** Block No. 9, Hexblock 9 + +\ register byte/word + internal + + create wreg-tab ," ACDRSUIW" + create breg-tab ," A-C-D-R-A+C+D+R+" + + : .16REG \ r# --- | register printed out + 7 and wreg-tab 1+ + c@ emit space ; + + : .8REG \ r# --- | register printed out + 7 and 2* breg-tab 1+ + 2 type space ; + + : .A 0 .16reg ; : .A- 0 .8reg ; + : .D 2 .16reg ; + + + +\ *** Block No. 10, Hexblock a + +\ indizierte/indirekte Adressierung cas 10nov05 + + internal + + : ?d DUP 6 shift> 3 [and] 1 3 uwithin ; + + : .D) ( disp_flag ext -- op ) \ indirect + ?d IF ." D" THEN ." ) " ; \ with/without Displacement + + : .I) ( disp_flag ext -- op ) \ indexted indirect + ?d IF ." D" THEN ." I) " ; \ with/without Displacement + + + + + + +\ *** Block No. 11, Hexblock b + +\ indexed/indirect addressing cas 10nov05 + internal + + : I) 6 .16reg .D) ; + : W) 7 .16reg .D) ; + : R) 3 .16reg .D) ; + : S) 4 .16reg .D) ; + : U) 5 .16reg .D) ; + + : U+W) 5 .16reg 7 .16reg .I) ; + : R+I) 3 .16reg 6 .16reg .I) ; + : U+I) 5 .16reg 6 .16reg .I) ; + : R+W) 3 .16reg 7 .16reg .I) ; + + : .# ." # " ; + + +\ *** Block No. 12, Hexblock c + +\ + internal + + : (.R/M) \ op ext --- | print a register + IM OFF SWAP 1 [and] IF .16REG exit then .8REG ; + + : .R/M \ op ext --- op ext | print r/m as register + 2DUP (.R/M) ; + + : .REG \ op ext --- op ext | print reg as register + 2DUP 3 shift> (.R/M) ; + + + + + + +\ *** Block No. 13, Hexblock d + +\ + internal + + CREATE SEGTB ," ECSD" + + : (.seg ( n -- ) + 3 shift> 3 and segtb + 1+ c@ emit ; + + : .SEG \ s# --- | register printed out + (.seg ." : " ; + + : SEG: \ op --- | print segment overrides + (.seg ." S:" ; + + + + +\ *** Block No. 14, Hexblock e + +\ + internal + : disp@ ( ops-cnt -- ) + ops +! CP@ IM @ + IM off ." $" ; + + : BDISP \ --- | do if displacement is byte + 1 disp@ TC@ sext U. ; + + : WDisp \ --- | do if displacement is word + 2 disp@ T@ U. ; + + : .DISP \ op ext --- op ext | print displacement + DUP 6 shift> 3 EXEC noop BDISP WDISP .R/M STOP[ + + : BIMM \ --- | do if immed. value is byte + 1 disp@ TC@ . ; + +\ *** Block No. 15, Hexblock f + +\ + internal + + + : .MREG \ op ext --- op ext | register(s) printed out + disp + $C7 mask 6 = IF WDISP ." ) " exit then + $C0 mask $C0 - 0= IF .R/M exit THEN + .DISP DUP 7 exec + R+I) R+W) U+I) U+W) \ I) oder DI) + I) W) U) R) \ ) oder D) + ; + + + + + + +\ *** Block No. 16, Hexblock 10 + +\ + internal + + : .SIZE \ op --- | decodes for size; WORD is default + 1 [and] 0= IF ." BYTE " THEN ; + + create adj-tab ," DAADASAAAAASAAMAAD" + + : .adj-tab 3 * adj-tab 1+ + 3 type space ; + + : ADJUSTS \ op --- | the adjusts + 3 shift> 3 [and] .adj-tab ; + + : .AAM 4 .adj-tab nextb 2drop ; + : .AAD 5 .adj-tab nextb 2drop ; + + +\ *** Block No. 17, Hexblock 11 + +\ + internal + : .POP \ op --- | print pops + DUP 8 = IF OOPS1 THEN .SEG ." POP " ; + + : .PUSH \ op --- | print pushes + .SEG ." PUSH " ; + + : P/P \ op --- | pushes or pops + 1 mask IF .pop ELSE .push THEN ; + + + + + + + +\ *** Block No. 18, Hexblock 12 + +\ +internal + : P/SEG \ op --- | push or seg overrides + DUP 5 shift> 1 exec P/P SEG: STOP[ + + : P/ADJ \ op --- | pop or adjusts + DUP 5 shift> 1 exec P/P ADJUSTS STOP[ + + : 0GP \ op --- op | opcode decoded & printed + 4 mask IF 1 mask + IF WDISP ELSE BIMM THEN .# + 1 [and] IF .A ELSE .A- THEN ELSE + NEXTB OVER 2 [and] + IF .MREG .REG ELSE ?DISP .REG .MREG + THEN 2DROP THEN ; + + +\ *** Block No. 19, Hexblock 13 + +\ + external + .SELF ADD .SELF ADC .SELF AND .SELF XOR + .SELF OR .SELF SBB .SELF SUB .SELF CMP + + internal + + : 0GROUP \ op --- | select 0 group to print + DUP 0GP 3 shift> 7 EXEC + ADD OR ADC SBB AND SUB XOR CMP STOP[ + + : LOWS \ op --- | 0-3f opcodes printed out + DUP 7 EXEC + 0GROUP 0GROUP 0GROUP 0GROUP + 0GROUP 0GROUP P/SEG P/ADJ STOP[ + + +\ *** Block No. 20, Hexblock 14 + +\ + internal + + : .REGGP \ op --- | register group defining word + CREATE LAST @ , DOES> @ SWAP .16REG .name ; + + external + + .REGGP INC .REGGP DEC .REGGP PUSH .REGGP POP + + : POPs \ op --- | handle illegal opcode for cs pop + $38 mask 8 = IF ." illegal" DROP ELSE POP THEN ; + +: REGS \ op --- | 40-5f opcodes printed out + DUP 3 shift> 3 exec INC DEC PUSH POPs STOP[ + + +\ *** Block No. 21, Hexblock 15 + +\ conditional branches + + create branch-tab + ," O NO B NB E NE BE NBES NS P NP L GE LE NLE" + + : .BRANCH \ op --- | branch printed out w/ dest. + NEXTB SEXT CP@ + u. ASCII J EMIT + &15 [and] 3 * branch-tab 1+ + 3 type ; + + + + + + + + + +\ *** Block No. 22, Hexblock 16 + +\ +\\ + + + + + + + + + + + + + + + +\ *** Block No. 23, Hexblock 17 + +\ +internal + + : MEDS \ op --- | 40-7f opcodes printed out + DUP 4 shift> 3 exec + REGS REGS OOPS1 .BRANCH STOP[ + + : 80/81 \ op --- | secondary at 80 or 81 + NEXTB ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# .MREG + SWAP .SIZE 3 shift> 7 EXEC + ADD OR ADC SBB AND SUB XOR CMP STOP[ + + + + + + +\ *** Block No. 24, Hexblock 18 + +\ + internal + : 83S \ op --- | secondary at 83 + NEXTB ?DISP BIMM .# .MREG + SWAP .SIZE 3 shift> 7 EXEC + ADD OOPS0 ADC SBB oops0 SUB OOPS0 CMP STOP[ + + : 1GP \ op --- | r/m reg opcodes + CREATE LAST @ , DOES> @ >R NEXTB ?DISP .REG .MREG 2DROP + R> .name ; + + external 1GP TEST 1GP XCHG .SELF LEA .SELF MOV internal + +: MOVRM/REG NEXTB ?DISP .REG .MREG 2DROP MOV ; \ 88-89 +: MOVD NEXTB .MREG .REG 2DROP MOV ; \ 8A-8B + + +\ *** Block No. 25, Hexblock 19 + +\ + internal +: MOVS>M \ op --- | display instructions 8C-8E + NEXTB OVER $8D = IF .MREG .REG LEA ELSE + OVER $8F = IF .MREG [ ' POP >NAME ] LITERAL .name ELSE + SWAP 1 [or] SWAP \ 16 bit moves only, folks! + OVER 2 [and] IF .MREG DUP .SEG ELSE + DUP .SEG .MREG THEN MOV THEN THEN 2DROP ; + + + : 8MOVS \ op --- | display instructions 80-8F + DUP 2/ 7 exec + 80/81 83S TEST XCHG MOVRM/REG MOVD MOVS>M MOVS>M STOP[ + + + + +\ *** Block No. 26, Hexblock 1a + +\ + external + .SELF XCHG .SELF CBW .SELF CWD .SELF CALL .SELF NOP + .SELF WAIT .SELF PUSHF .SELF POPF .SELF SAHF .SELF LAHF + internal + + : INTER \ --- | decode interseg jmp or call + NEXTW 4 u.r ." :" NEXTW U. ; + + : CALLINTER \ --- | decode interseg call + INTER CALL ; + + : 9HIS \ op --- | 98-9F decodes + 7 exec + CBW CWD CALLINTER WAIT PUSHF POPF SAHF LAHF STOP[ + + +\ *** Block No. 27, Hexblock 1b + +\ + internal + : XCHGA \ op --- | 98-9F decodes + dup $90 = IF drop NOP ELSE .A .16REG XCHG THEN ; + + : 90S \ op --- | 90-9F decodes + DUP 3 shift> 1 exec XCHGA 9HIS STOP[ + + : MOVSs \ op --- | A4-A5 decodes + .SIZE ." MOVS " ; + + : CMPSs \ op --- | A6-A7 decodes + .SIZE ." CMPS " ; + + + + +\ *** Block No. 28, Hexblock 1c + +\ + internal + : .AL/AX \ op --- | decodes for size + 1 EXEC .A- .A STOP[ + + : MOVS/ACC \ op --- | A0-A3 decodes + 2 mask + IF .AL/AX WDISP ." ) " ELSE WDISP ." ) " .AL/AX THEN MOV ; + + create ss-tab ," TESTSTOSLODSSCAS" + + : .ss-tab 3 [and] 4 * ss-tab 1+ + 4 type space ; + + : .TEST \ op --- | A8-A9 decodes + 1 mask IF WDISP ELSE BIMM THEN .# .AL/AX 0 .ss-tab ; + + +\ *** Block No. 29, Hexblock 1d + +\ + internal + : STOSs ( op --- ) .SIZE 1 .ss-tab ; \ STOS + : LODSs ( op --- ) .SIZE 2 .ss-tab ; \ LODS + : SCASs ( op --- ) .SIZE 3 .ss-tab ; \ SCAS + + : A0S \ op --- | A0-AF decodes + DUP 2/ 7 exec + MOVS/ACC MOVS/ACC MOVSs CMPSs .TEST STOSs LODSs SCASs STOP[ + + : MOVS/IMM \ op --- | B0-BF decodes + 8 mask + IF WDISP .# .16REG ELSE BIMM .# .8REG THEN MOV ; + + : HMEDS \ op --- | op codes 80 - C0 displayed + DUP 4 shift> 3 exec 8MOVS 90S A0S MOVS/IMM STOP[ + +\ *** Block No. 30, Hexblock 1e + +\ + external + .SELF LES .SELF LDS .SELF INTO .SELF IRET + internal + + : LES/LDS \ op --- | les/lds instruction C4-C5 + NEXTB .MREG .REG DROP 1 exec LES LDS STOP[ + external + : RET \ op --- | return instruction C2-C3, CA-CB + 1 mask 0= IF WDISP ." SP+" THEN + 8 [and] IF ." FAR " THEN .myself ; + + internal + : MOV#R/M \ op --- | return instruction C2-C3, CA-CB + NEXTB ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# + .MREG MOV 2DROP ; + +\ *** Block No. 31, Hexblock 1f + +\ + external + + : INT \ op --- | int instruction CC-CD + 1 [and] IF NEXTB ELSE 3 THEN U. .myself ; + + internal + : INTO/IRET \ op --- | int & iret instructions CE-CF + 1 exec INTO IRET STOP[ + + : C0S \ op --- | display instructions C0-CF + DUP 2/ 7 exec + OOPS1 RET LES/LDS MOV#R/M OOPS1 RET INT INTO/IRET STOP[ + + + + +\ *** Block No. 32, Hexblock 20 + +\ + external + .SELF ROL .SELF ROR .SELF RCL .SELF RCR + .SELF SHL/SAL .SELF SHR .SELF SAR + internal + + : SHIFTS \ op --- | secondary instructions d0-d3 + 2 mask IF 0 .8reg ( C-) THEN + NEXTB .MREG NIP 3 shift> 7 exec + ROL ROR RCL RCR SHL/SAL SHR OOPS0 SAR STOP[ + + : XLAT DROP ." XLAT " ; + + : ESC \ op --- | esc instructions d8-DF + NEXTB .MREG 3 shift> 7 [and] U. 7 [and] U. ." ESC " ; + + +\ *** Block No. 33, Hexblock 21 + +\ + internal + : D0S \ op --- | display instructions D0-DF + 8 mask IF ESC EXIT THEN + DUP 7 exec + SHIFTS SHIFTS SHIFTS SHIFTS .AAM .AAD OOPS1 XLAT STOP[ + + external + .SELF LOOPE/Z .SELF LOOP .SELF JCXZ .SELF LOOPNE/NZ + internal + + : LOOPS \ op --- | display instructions E0-E3 + NEXTB SEXT CP@ + u. 3 exec + LOOPNE/NZ LOOPE/Z LOOP JCXZ STOP[ + + external .SELF IN .SELF OUT .SELF JMP + +\ *** Block No. 34, Hexblock 22 + +\ + internal + + : IN/OUT \ op --- | display instructions E4-E6,EC-EF + 8 mask + IF 2 mask IF .AL/AX .D OUT ELSE .D .AL/AX IN THEN + ELSE 2 mask + IF .AL/AX BIMM .# OUT ELSE BIMM .# .AL/AX IN THEN + THEN ; + + + + + + + + +\ *** Block No. 35, Hexblock 23 + +\ + internal + : CALLs \ op --- | display instructions E7-EB + 2 mask IF 1 mask IF NEXTB SEXT CP@ + u. + ELSE INTER THEN + ELSE NEXTW CP@ + u. THEN + 3 exec CALL JMP JMP JMP STOP[ + + : E0S \ op --- | display instructions E0-EF + DUP 2 shift> 3 EXEC LOOPS IN/OUT CALLs IN/OUT STOP[ + + : FTEST \ op --- | display instructions F6,7:0 + ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# + .MREG DROP .SIZE 0 .ss-tab ; \ TEST + + + +\ *** Block No. 36, Hexblock 24 + +\ + external + .SELF NOT .SELF NEG .SELF MUL .SELF IMUL + .SELF DIV .SELF IDIV .SELF REP/NZ .SELF REPZ + .SELF LOCK .SELF HLT .SELF CMC .SELF CLC + .SELF STC .SELF CLI .SELF STI .SELF CLD + .SELF STD .SELF INC .SELF DEC .SELF PUSH + internal + +: MUL/DIV \ op ext --- | secondary instructions F6,7:4-7 + .MREG .A OVER 1 [and] IF .D THEN NIP + 3 shift> 3 exec MUL IMUL DIV IDIV STOP[ + + + + + +\ *** Block No. 37, Hexblock 25 + +\ + internal + : NOT/NEG \ op ext --- | secondary instructions F6,7:2,3 + .MREG SWAP .SIZE 3 shift> 1 exec NOT NEG STOP[ + + : F6-F7S \ op --- | display instructions F6,7 + NEXTB DUP 3 shift> 7 exec FTEST OOPS2 NOT/NEG NOT/NEG + MUL/DIV MUL/DIV MUL/DIV MUL/DIV STOP[ + + : FES \ op --- | display instructions FE + NEXTB .MREG ." BYTE " NIP 3 shift> + 3 exec INC DEC oops oops STOP[ + + : FCALL/JMP \ op ext --- | display call instructions FF + .MREG 3 shift> 1 mask IF ." FAR " THEN + NIP 2/ 1 exec JMP CALL STOP[ + +\ *** Block No. 38, Hexblock 26 + +\ + internal + + : FPUSH \ op ext --- | display push instructions FF + dup $FF = IF oops2 exit THEN \ FF FF gibt's nicht! + 4 mask IF .MREG 2DROP PUSH EXIT THEN OOPS2 ; + + : FINC \ op ext --- | display inc/dec instructions FF + .MREG NIP 3 shift> 1 exec INC DEC STOP[ + + : FFS \ op --- | display instructions FF + NEXTB DUP 4 shift> 3 exec + FINC FCALL/JMP FCALL/JMP FPUSH STOP[ + + + + +\ *** Block No. 39, Hexblock 27 + +\ + internal + + : F0S \ op --- | display instructions F0-FF + &15 mask 7 mask 6 < IF NIP THEN -1 exec + LOCK OOPS0 REP/NZ REPZ HLT CMC F6-F7S F6-F7S + CLC STC CLI STI CLD STD FES FFS STOP[ + + : HIGHS \ op -- | op codes C0 - FF displayed + DUP 4 shift> 3 exec C0S D0S E0S F0S STOP[ + + : (INST) \ op --- | highest level vector table + &255 [and] DUP 6 shift> + -1 exec LOWS MEDS HMEDS HIGHS STOP[ + + + +\ *** Block No. 40, Hexblock 28 + +\ + internal + + : INST \ --- | display opcode at ip, advancing as needed + [ disam ] .seg:off + NEXTB (INST) OPS @ CP +! OPS OFF IM OFF ; + + : (DUMP) \ addr ct --- | dump as pointed to by reloc + [ forth ] BOUNDS ?do I TC@ u. LOOP ; + + + + + + + + +\ *** Block No. 41, Hexblock 29 + +\ + internal + + : steps? + 1+ dup &10 mod 0= IF key #esc = exit THEN 0 ; + + create next-code assembler next forth + + : ?next ( steps-count -- steps-count ) + cp@ 2@ next-code 2@ D= + IF cr .seg:off ." NEXT Link= " cp@ 4+ @ U. + cp@ 6 + cp ! \ 4 bytes code, 2 byte link + drop 9 \ forces stop at steps? + THEN ; + + + +\ *** Block No. 42, Hexblock 2a + +\ ks 28 feb 89 + forth definitions + + external + + : DISASM \ addr --- | disassemble until esc key + [ disam ] CP ! base [ forth ] push hex 0 + BEGIN CP@ >R + CR INST R> CP@ OVER - &35 tab (DUMP) + ?next ?stack steps? + UNTIL drop ; + + : dis ( -- ) ' @ disasm ; + + + + +\ *** Block No. 43, Hexblock 2b + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/disks.cfg b/8086/msdos/src/disks.cfg similarity index 100% rename from 8086/msdos/disks.cfg rename to 8086/msdos/src/disks.cfg diff --git a/8086/msdos/dos.fb b/8086/msdos/src/dos.fb similarity index 100% rename from 8086/msdos/dos.fb rename to 8086/msdos/src/dos.fb diff --git a/8086/msdos/src/dos.fth b/8086/msdos/src/dos.fth new file mode 100644 index 0000000..20bfd2b --- /dev/null +++ b/8086/msdos/src/dos.fth @@ -0,0 +1,342 @@ + +\ *** Block No. 0, Hexblock 0 + +\ 28 jun 88 + +DOS loads higher level file functions which go beyond +including a screen file. Calls to MS-DOS are implemented +and used for directory manipulation. These functions may +not work for versions before MS-DOS 3.0. + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ MS-DOS file handli cas 09jun20 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + : fswap isfile@ fromfile @ isfile ! fromfile ! ; + + $80 Constant dta + +| : COMSPEC ( -- string ) [ dos ] + $2C @ ( DOS-environment:seg) 8 ds@ filename &60 lmove + filename counted &60 min filename place filename ; + + 1 &12 +thru .( MS-DOS functions loaed ) cr + + Onlyforth + + + +\ *** Block No. 2, Hexblock 2 + +\ moving blocks ks 04 okt 87 + +| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ; + + : used? ( blk -- f ) + block count b/blk 1- swap skip nip 0<> ; + +| : (copy ( from to -- ) + full? IF save-buffers THEN isfile@ fromfile @ - + IF dup used? Abort" target block not empty" THEN + dup isfile@ core? IF prev @ emptybuf THEN + isfile@ 0= IF offset @ + THEN + isfile@ rot fromfile @ (block 6 - 2! update ; + + + + +\ *** Block No. 3, Hexblock 3 + +\ moving blocks ks 04 okt 87 + +| : blkmove ( from to quan -- ) 3 arguments save-buffers + >r over r@ + over u> >r 2dup u< r> and + IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP + ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP + THEN save-buffers 2drop ; + + : copy ( from to -- ) 1 blkmove ; + + : convey ( blk1 blk2 to.blk -- ) + 3 arguments >r 2dup swap - >r + fswap dup capacity 1- > isfile@ 0<> and + fswap r> r@ + capacity 1- > isfile@ 0<> and or >r + 1+ over - dup 0> not r> or Abort" nein" r> swap blkmove ; + + +\ *** Block No. 4, Hexblock 4 + +\ MORE extending forth files ks 10 okt 87 + Dos also definitions + +| : addblock ( blk -- ) dup buffer dup b/blk blank + isfile@ f.size dup 2@ b/blk 0 d+ rot 2! + swap isfile@ fblock! ; + + Forth definitions + + : more ( n -- ) 1 arguments isfile@ + IF capacity swap bounds ?DO I addblock LOOP close exit + THEN drop ; + + + + + +\ *** Block No. 5, Hexblock 5 + +\ file eof? create dta-addressing ks 03 apr 88 + Dos definitions + + : ftime ( -- mm hh ) + isfile@ f.time @ $20 u/mod nip $40 u/mod ; + + : fdate ( -- dd mm yy ) + isfile@ f.date @ $20 u/mod $10 u/mod &80 + ; + + : .when base push decimal + fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r + ftime 3 .r ." :" 2 .r ; + + + + + +\ *** Block No. 6, Hexblock 6 + +\ ks 20mar88 + + : (.fcb ( fcb -- ) + dup .file ?dup 0=exit pushfile + isfile ! &13 tab ." is" + isfile@ f.handle @ 2 .r + isfile@ f.size 2@ 7 d.r .when + space isfile@ f.name count type ; + + Forth definitions + + : files file-link + BEGIN @ dup WHILE cr dup (.fcb stop? UNTIL drop ; + + : ?file isfile@ (.fcb ; + + +\ *** Block No. 7, Hexblock 7 + +\ dir make makefile ks 25 okt 87 + Forth definitions + + : killfile close + isfile@ f.name filename >asciz ~unlink drop ; + + : emptyfile isfile@ 0=exit + isfile@ f.name filename >asciz 0 ~creat ?diskerror + isfile@ f.handle ! isfile@ f.size 4 erase ; + + : make close name isfile@ fname! emptyfile ; + + : makefile File last @ name> execute emptyfile ; + + + + +\ *** Block No. 8, Hexblock 8 + +\ getpath ks 10 okt 87 + Dos definitions + +| &40 Constant pathlen +| Create pathes 0 c, pathlen allot + +| : (setpath ( string -- ) count + dup pathlen u> Abort" path too long" pathes place ; + +| : getpath ( +n -- string / ff ) + >r 0 pathes count r> 0 + DO rot drop Ascii ; skip stash Ascii ; scan LOOP + drop over - ?dup + IF here place here dup count + 1- c@ + ?" :\" ?exit Ascii \ here append exit + THEN 0= ; + +\ *** Block No. 9, Hexblock 9 + +\ pathsearch .path path ks 09 okt 87 + + : pathsearch ( string -- asciz *f ) dup >r + (fsearch dup 0= IF rdrop exit THEN 2drop 0 0 + BEGIN drop 1+ dup getpath ?dup 0= + IF drop r> filename >asciz 2 exit THEN + r@ count 2 pick attach (fsearch + 0= UNTIL nip rdrop false ; + + ' pathsearch Is fsearch + + Forth definitions + + : .path pathes count type ; + + : path name nullstring? IF .path exit THEN (setpath ; + +\ *** Block No. 10, Hexblock a + +\ call another executable file ks 04 aug 87 + Dos definitions + +| Create cpb 0 , \ inherit parent environment + dta , ds@ , $5C , ds@ , $6C , ds@ , Label ssave 0 , + +| Code ~exec ( asciz -- *f ) + I push R push U push S ssave #) mov cpb # R mov + $4B00 # A mov $21 int C: D mov D D: mov D S: mov + D E: mov ssave #) S mov CS not + ?[ A A xor A push $2F # A+ mov $21 int E: A mov + A D: mov C: A mov A E: mov R I mov dta # W mov + $40 # C mov rep movs A D: mov A pop + ]? A W xchg dta # D mov $1A # A+ mov $21 int + W D mov U pop R pop I pop Next + end-code + +\ *** Block No. 11, Hexblock b + +\ calling MS-DOS thru forth interpreter ks 19 mr 88 + +| : execute? ( extension -- *f ) + count filename count Ascii . scan drop swap + 2dup 1+ erase move filename 1+ ~exec ; + + : fcall ( string -- ) count filename place ds@ cpb 4+ ! + " .EXE" execute? dup IF drop " .COM" execute? THEN + ?diskerror ; + + : fdos ( string -- ) + dta $80 erase " /c " count dta place count dta attach + status push status off .status COMSPEC fcall curat? at ; + + + + +\ *** Block No. 12, Hexblock c + +\ einige MS-DOS Funktionen msdos call ks 10 okt 87 + + : dos: Create ," Does> count here place + Ascii " parse here attach here fdos ; + + Forth definitions + + dos: dir dir " + dos: ren ren " + dos: md md " + dos: cd cd " + dos: rd rd " + dos: fcopy copy " + dos: delete del " + dos: ftype type " + + +\ *** Block No. 13, Hexblock d + +\ msdos call ks 23 okt 88 + + : msdos savevideo status push status off .status + flush dta off COMSPEC fcall restorevideo ; + + : call name source >in @ /string c/l umin + dta place dta dta >asciz drop [compile] \ + status push status off .status fcall curat? at ; + + + + + + + + + +\ *** Block No. 14, Hexblock e + +\ time date ks 19 mr 88 + Dos definitions + + : ftime ( -- mm hh ) + open isfile@ f.time @ $20 u/mod nip $40 u/mod ; + + : fdate ( -- dd mm yy ) + open isfile@ f.date @ $20 u/mod $10 u/mod &80 + ; + + + + + + + + + +\ *** Block No. 15, Hexblock f + +\ ~lseek position? ks 10 okt 87 + Dos definitions + + Code ~lseek ( d handle method -- d' ) + R W mov D A mov R pop C pop D pop + $42 # A+ mov $21 int W R mov CS not + ?[ A push Next ]? A D xchg ;c: ?diskerror ; + + Forth definitions + + : position? ( -- dfaddr ) + isfile@ f.handle @ 0= Abort" file not open" + 0 0 isfile@ f.handle @ 1 ~lseek ; + + + + +\ *** Block No. 16, Hexblock 10 + + + + + + + + + + + + + + + + + + +\ *** Block No. 17, Hexblock 11 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/double.fb b/8086/msdos/src/double.fb similarity index 100% rename from 8086/msdos/double.fb rename to 8086/msdos/src/double.fb diff --git a/8086/msdos/src/double.fth b/8086/msdos/src/double.fth new file mode 100644 index 0000000..55765cd --- /dev/null +++ b/8086/msdos/src/double.fth @@ -0,0 +1,95 @@ + +\ *** Block No. 0, Hexblock 0 + +\\ Double words cas 10nov05 + +This File contains definitions for 32Bit Math + +This definitions are already included in the volksFORTH Kernel: + + 2! 2@ 2drop 2dup 2over 2swap d+ d. d.r + d0= d< d= dabs dnegate + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ 2constant 2rot 2variable d- d2/ ks 22 dez 87 + + : 2constant Create , , does> 2@ ; + + : 2rot ( d1 d2 d3 -- d2 d3 d1 ) 5 roll 5 roll ; + + : 2variable Variable 2 allot ; + + : d- ( d1 d2 -- d3 ) dnegate d+ ; + + Code d2/ ( d1 -- d2 ) + A pop D sar A rcr A push Next end-code + + + + + +\ *** Block No. 2, Hexblock 2 + +\ dmax dmin du< ks 22 dez 87 + + : dmax ( d1 d2 -- d3 ) + 2over 2over d< IF 2swap THEN 2drop ; + + : dmin ( d1 d2 -- d3 ) + 2over 2over d< IF 2drop exit THEN 2swap 2drop ; + + : du< ( 32b1 32b2 -- f ) + rot 2dup = IF 2drop u< exit THEN u> -rot 2drop ; + + + + + + + +\ *** Block No. 3, Hexblock 3 + + + + + + + + + + + + + + + + + + +\ *** Block No. 4, Hexblock 4 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/editor.fb b/8086/msdos/src/editor.fb similarity index 100% rename from 8086/msdos/editor.fb rename to 8086/msdos/src/editor.fb diff --git a/8086/msdos/src/editor.fth b/8086/msdos/src/editor.fth new file mode 100644 index 0000000..b04dc97 --- /dev/null +++ b/8086/msdos/src/editor.fth @@ -0,0 +1,798 @@ + +\ *** Block No. 0, Hexblock 0 + + volksFORTH Full-Screen-Editor HELP Screen cas 11nov05 + +Quit Editor : flushed: ESC updated: ^E +discard changes : ^U (UNDO) +move cursor : Cursorkeys (delete with DEL or <- ) +insert : INS (toggle), ^ENTER (insert Screen) +Tabs : TAB (to right), SHIFT TAB (to left) +paging : Pg Dn (next screen), Pg Up (previous scr) + : F9 (alternate), SHIFT F9 (shadow scr) +mark alternate Scr. : F10 +delete/insert line : ^Y (delete), ^N (insert) +split line : ^PgDn (split), ^PgUp (join) +search and replace : F2 (stop with ESC, replace with 'R' ) +linebuffer : F3 (push&delete), F5 (push), F7 (pop) +charbuffer : F4 (push&delete), F6 (push), F8 (pop) +misc : ^F (Fix), ^L (Showload), ^S (Screen #) + +\ *** Block No. 1, Hexblock 1 + +--> \ Full-Screen Editor cas 10nov05 +This is the Full-Screen Editor for MS-DOS volksFORTH + +Features: Line- and Char-Buffer, Find- and Replace, Support for +"Shadow-Screens", View Function and loading of screens with +visual feedback (showload) + +The Keybinding can be easily changed by using the integrated +Keytable. + + +Ported to the MS-DOS volksFORTH by K.Schleisiek on 22 dez 87 +Original design by Ullrich Hoffmann + + + + +\ *** Block No. 2, Hexblock 2 + +\ Load Screen for the Editor cas 10nov05 + + Onlyforth \needs Assembler 2 loadfrom asm.scr + + 3 load \ PC adaption + 4 9 thru \ Editor + +\ &10 load \ ANSI display interface +\ &11 load \ BIOS display interface + &12 load \ MULTItasking display interface + +&13 &39 thru \ Editor + +Onlyforth .( Screen Editor loaded ) cr + + + +\ *** Block No. 3, Hexblock 3 + +\ BIM adaption UH 11dez88 + +| : ?range ( n -- n ) isfile@ 0=exit dup 0< 9 and ?diskerror + dup capacity - 1+ 0 max ?dup 0=exit more ; +| : block ( n -- adr ) ?range block ; + + $1B Constant #esc + + : curon &11 &12 curshape ; + + : curoff &14 dup curshape ; + + Variable caps caps off + + Label ?capital 1 # caps #) byte test + 0= ?[ (capital # jmp ]? ret end-code + +\ *** Block No. 4, Hexblock 4 + +\ search delete insert replace ks 20 dez 87 + +| : delete ( buffer size count -- ) + over min >r r@ - ( left over ) dup 0> + IF 2dup swap dup r@ + -rot swap cmove THEN + + r> bl fill ; + +| : insert ( string length buffer size -- ) + rot over min >r r@ - ( left over ) + over dup r@ + rot cmove> r> cmove ; + +| : replace ( string length buffer size -- ) + rot min cmove ; + + + + +\ *** Block No. 5, Hexblock 5 + +\ usefull definitions and Editor vocabulary UH 11mai88 + +Vocabulary Editor + +' Forth | Alias [F] immediate +' Editor | Alias [E] immediate + +Editor also definitions + +| : c ( n --) \ moves cyclic thru the screen + r# @ + b/blk mod r# ! ; + +| Variable r#' r#' off +| Variable scr' scr' off +' fromfile | Alias isfile' +| Variable lastfile | Variable lastscr | Variable lastr# + +\ *** Block No. 6, Hexblock 6 + +\\ move cursor with position-checking ks 18 dez 87 +\ different versions of cursor positioning error reporting + +| : c ( n --) \ checks the cursor position + r# @ + dup 0 b/blk uwithin not + Abort" There is a border!" r# ! ; + +| : c ( n --) \ goes thru the screens + r# @ + dup b/blk 1- > IF 1 scr +! THEN + dup 0< IF -1 scr +! THEN b/blk mod r# ! ; + +| : c ( n --) \ moves cyclic thru the screen + r# @ + b/blk mod r# ! ; + + + + +\ *** Block No. 7, Hexblock 7 + +\ calculate addresses ks 20 dez 87 +| : *line ( l -- adr ) c/l * ; +| : /line ( n -- c l ) c/l /mod ; +| : top ( -- ) r# off ; +| : cursor ( -- n ) r# @ ; +| : 'start ( -- adr ) scr @ block ; +| : 'end ( -- adr ) 'start b/blk + ; +| : 'cursor ( -- adr ) 'start cursor + ; +| : position ( -- c l ) cursor /line ; +| : line# ( -- l ) position nip ; +| : col# ( -- c ) position drop ; +| : 'line ( -- adr ) 'start line# *line + ; +| : 'line-end ( -- adr ) 'line c/l + 1- ; +| : #after ( -- n ) c/l col# - ; +| : #remaining ( -- n ) b/blk cursor - ; +| : #end ( -- n ) b/blk line# *line - ; + +\ *** Block No. 8, Hexblock 8 + +\ move cursor directed UH 11dez88 +| Create >at 0 , 0 , +| : curup c/l negate c ; +| : curdown c/l c ; +| : curleft -1 c ; +| : curright 1 c ; + +| : +tab ( 1/4 -> ) cursor $10 / 1+ $10 * cursor - c ; +| : -tab ( 1/8 <- ) cursor 8 mod negate dup 0= 8 * + c ; + +| : >last ( adr len -- ) -trailing nip b/blk min r# ! ; +| : #after c ; +| : ( -- ) 'start line# 1+ *line 1- >last ; +| : >""end ( -- ) 'start b/blk >last ; + +\ *** Block No. 9, Hexblock 9 + +\ show border UH 29Sep87 + +&14 | Constant dx 1 | Constant dy + +| : horizontal ( row eck1 eck2 -- row' ) + rot dup >r dx 1- at swap emit + c/l 0 DO Ascii - emit LOOP emit r> 1+ ; + +| : vertical ( row -- row' ) + l/s 0 DO dup dx 1- at Ascii | emit + row dx c/l + at Ascii | emit 1+ LOOP ; + +| : border dy 1- Ascii / Ascii \ horizontal + vertical Ascii \ Ascii / horizontal drop ; + +| : edit-at ( -- ) position swap dy dx d+ at ; + +\ *** Block No. 10, Hexblock a + +\ ANSI display interface ks 03 feb 88 + + + + + + + +| : redisplay ( line# -- ) + dup dy + dx at *line 'start + c/l type ; + +| : (done ( -- ) ; immediate + + +| : install-screen ( -- ) l/s 6 + 0 >at 2! page ; + + +\ *** Block No. 11, Hexblock b + +\ BIOS-display interface ks 03 feb 88 +| Code (.line ( line addr videoseg -- ) + A pop W pop I push E: push D E: mov + $0E # W add W W add A I xchg c/l # C mov + attribut #) A+ mov [[ byte lods stos C0= ?] + E: pop I pop D pop Next end-code + + +| : redisplay ( line# -- ) + dup 1+ c/row * swap c/l * 'start + video@ (.line ; + +| : (done ( -- ) ; immediate + + +| : install-screen ( -- ) l/s 6 + 0 >at 2! page ; + + +\ *** Block No. 12, Hexblock c + +\ MULTI-display interface ks UH 10Sep87 +| Code (.line ( line addr videoseg -- ) + C pop W pop I push E: push D E: mov + $0E # W add W W add u' area U D) I mov + u' catt I D) A+ mov C I mov + c/l # C mov [[ byte lods stos C0= ?] + E: pop I pop D pop Next end-code + +| : redisplay ( line# -- ) + dup 1+ c/row * swap c/l * 'start + video@ (.line ; + +| : (done ( -- ) line# 2+ c/col 2- window ; + +| : cleartop ( -- ) 0 l/s 5 + window (page ; +| : install-screen ( -- ) row l/s 6 + u< + IF l/s 6 + 0 full page ELSE at? cleartop THEN >at 2! ; + +\ *** Block No. 13, Hexblock d + +\ display screen UH 11mai88 +Forth definitions +: updated? ( -- f) 'start 2- @ 0< ; +Editor definitions +| : .updated ( -- ) 9 0 at + updated? IF 4 spaces ELSE ." not " THEN ." updated" ; + +| : .screen l/s 0 DO I redisplay LOOP ; +\ | : .file ( fcb -- ) +\ ?dup IF body> >name .name exit THEN ." direct" ; +| : .title [ DOS ] 1 0 at isfile@ .file dx 1- tab + 2 0 at drv (.drv scr @ 6 .r + 4 0 at fromfile @ .file dx 1- tab + 5 0 at fswap drv (.drv scr' @ 6 .r fswap .updated ; + +| : .all .title .screen ; + +\ *** Block No. 14, Hexblock e + +\ check errors UH 02Nov86 + +| : ?bottom ( -- ) 'end c/l - c/l -trailing nip + Abort" You would lose a line" ; + +| : ?fit ( n -- ) 'line c/l -trailing nip + c/l > + IF line# redisplay + true Abort" You would lose a char" THEN ; + +| : ?end 1 ?fit ; + + + + + + + +\ *** Block No. 15, Hexblock f + +\ programmer's id ks 18 dez 87 + +$12 | Constant id-len +Create id id-len allot id id-len erase + +| : stamp ( -- ) id 1+ count 'start c/l + over - swap cmove ; + +| : ?stamp ( -- ) updated? IF stamp THEN ; + +| : ## ( n -- ) base push decimal 0 <# # # #> id 1+ attach ; + +| : get-id ( -- ) id c@ ?exit ID on + cr ." Enter your ID : " at? 3 0 DO Ascii . emit LOOP at + id 2+ 3 expect normal span @ dup id 1+ c! 0=exit + bl id 1+ append date@ rot ## swap >months id 1+ attach ## ; + + +\ *** Block No. 16, Hexblock 10 + +\ update screen-display UH 28Aug87 + +| : emptybuf prev @ 2+ dup on 4+ off ; + +| : undo emptybuf .all ; + +| : modified updated? ?exit update .updated ; + +| : linemodified modified line# redisplay ; + +| : screenmodified modified + l/s line# ?DO I redisplay LOOP ; + +| : .modified ( -- ) >at 2@ at space scr @ . + updated? not IF ." un" THEN ." modified" ?stamp ; + + +\ *** Block No. 17, Hexblock 11 + +\ leave editor UH 10Sep87 +| Variable (pad (pad off +| : memtop ( -- adr) sp@ $100 - ; + +| Create char 1 allot +| Variable imode imode off +| : .imode at? 7 0 at + imode @ IF ." insert " ELSE ." overwrite" THEN at ; +| : setimode imode on .imode ; +| : clrimode imode off .imode ; + +| : done ( -- ) (done + ['] (quit is 'quit ['] (error errorhandler ! quit ; + +| : update-exit ( -- ) .modified done ; +| : flushed-exit ( -- ) .modified save-buffers done ; + +\ *** Block No. 18, Hexblock 12 + +\ handle screens UH 21jan89 + +| : insert-screen ( scr -- ) \ before scr + 1 more fromfile push isfile@ fromfile ! + capacity 2- over 1+ convey ; + +| : wipe-screen ( -- ) 'start b/blk blank ; + +| : new-screen ( -- ) + scr @ insert-screen wipe-screen top screenmodified ; + + + + + + + +\ *** Block No. 19, Hexblock 13 + +\ handle lines UH 01Nov86 + +| : (clear-line 'line c/l blank ; +| : clear-line (clear-line linemodified ; + +| : clear> 'cursor #after blank linemodified ; + +| : delete-line 'line #end c/l delete screenmodified ; + +| : backline curup delete-line ; + +| : (insert-line + ?bottom 'line c/l over #end insert (clear-line ; + +| : insert-line (insert-line screenmodified ; + + +\ *** Block No. 20, Hexblock 14 + +\ join and split lines UH 11dez88 + +| : insert-spaces ( n -- ) 'cursor swap + 2dup over #remaining insert blank ; + +| : split ( -- ) ?bottom cursor col# insert-spaces r# ! + #after insert-spaces screenmodified ; + +| : delete-characters ( n -- ) 'cursor #remaining rot delete ; + +| : join ( -- ) cursor line> col# Abort" next line will not fit!" + #after + dup delete-characters + cursor c/l rot - dup 0< + IF negate insert-spaces ELSE delete-characters THEN r# ! + screenmodified ; + +\ *** Block No. 21, Hexblock 15 + +\ handle characters UH 01Nov86 + +| : delete-char 'cursor #after 1 delete linemodified ; + +| : backspace curleft delete-char ; + +| : (insert-char ?end 'cursor 1 over #after insert ; + + +| : insert-char (insert-char bl 'cursor c! linemodified ; + +| : putchar ( --) char c@ + imode @ IF (insert-char THEN + 'cursor c! linemodified curright ; + + + +\ *** Block No. 22, Hexblock 16 + +\ stack lines UH 31Oct86 + +| Create lines 4 allot \ { 2+pointer | 2base } +| : 'lines ( -- adr) lines 2@ + ; + +| : @line 'lines memtop u> Abort" line buffer full" + 'line 'lines c/l cmove c/l lines +! ; + +| : copyline @line curdown ; +| : line>buf @line delete-line ; + +| : !line c/l negate lines +! 'lines 'line c/l cmove ; + +| : buf>line lines @ 0= Abort" line buffer empty" + ?bottom (insert-line !line screenmodified ; + + +\ *** Block No. 23, Hexblock 17 + +\ stack characters UH 01Nov86 + +| Create chars 4 allot \ { 2+pointer | 2base } +| : 'chars ( -- adr) chars 2@ + ; + +| : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" + 'cursor c@ 'chars c! 1 chars +! ; + +| : copychar @char curright ; +| : char>buf @char delete-char ; + +| : !char -1 chars +! 'chars c@ 'cursor c! ; + +| : buf>char chars @ 0= Abort" char buffer empty" + ?end (insert-char !char linemodified ; + + +\ *** Block No. 24, Hexblock 18 + +\ switch screens UH 11mai88 + +| : imprint ( -- ) \ remember valid file + isfile@ lastfile ! scr @ lastscr ! r# @ lastr# ! ; + +| : remember ( -- ) + lastfile @ isfile ! lastscr @ scr ! lastr# @ r# ! ; + +| : associate \ switch to alternate screen + isfile' @ isfile@ isfile' ! isfile ! + scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; + +| : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .all ; +| : n ?stamp 1 scr +! .all ; +| : b ?stamp -1 scr +! .all ; +| : a ?stamp associate .all ; + +\ *** Block No. 25, Hexblock 19 + +\ shadow screens UH 03Nov86 + +Variable shadow shadow off + +| : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; + +| : >shadow ?stamp \ switch to shadow screen + (shadow dup scr @ u> not IF negate THEN scr +! .all ; + + + + + + + + + +\ *** Block No. 26, Hexblock 1a + +\ load and show screens ks 02 mar 88 + +| : showoff ['] exit 'name ! normal ; + +| : show ( -- ) blk @ 0= IF showoff exit THEN + >in @ 1- r# ! edit-at imprint blk @ scr @ - 0=exit + blk @ scr ! normal curoff .all invers curon ; + +| : showload ( -- ) ?stamp save-buffers + ['] show 'name ! curon invers + adr .status push ['] noop is .status + scr @ scr push scr off r# push r# @ (load showoff ; + + + + + +\ *** Block No. 27, Hexblock 1b + +\ find strings ks 20 dez 87 +| Variable insert-buffer +| Variable find-buffer + +| : 'insert ( -- addr ) insert-buffer @ ; +| : 'find ( -- addr ) find-buffer @ ; + +| : .buf ( addr -- ) count type ." |" &80 col - spaces ; + +| : get ( addr -- ) >r at? r@ .buf + 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN + at r> .buf ; + +| : get-buffers dy l/s + 2+ dx 1- 2dup at + ." find: |" 'find get swap 1+ swap 2- at + ." ? replace: |" 'insert get ; + +\ *** Block No. 28, Hexblock 1c + +\ ks 20 dez 87 + Code match ( addr1 len1 string -- addr2 len2 ) + D W mov W ) D- mov $FF # D and 0= ?[ D pop Next ]? + W inc D dec C pop I A mov I pop A push + W ) A- mov W inc ?capital # call A- A+ mov D C sub + >= ?[ I inc Label done I dec + A pop I push A I mov C D add Next ]? + [[ byte lods ?capital # call A+ A- cmp 0= + ?[ D D or done 0= not ?] + I push W push C push A push D C mov + [[ byte lods ?capital # call A+ A- xchg + W ) A- mov W inc ?capital # call A+ A- cmp + 0= ?[[ C0= ?] A pop C pop + W pop I pop done ]] + ]? A pop C pop W pop I pop + ]? C0= ?] I inc done ]] end-code + +\ *** Block No. 29, Hexblock 1d + +\ search for string UH 11mai88 + +| : skip ( addr -- addr' ) 'find c@ + ; + +| : search ( buf len string -- offset flag ) + >r stash r@ match r> c@ < + IF drop 0= false exit THEN swap - true ; + +| : find? ( -- r# f ) 'cursor #remaining 'find search ; + +| : searchthru ( -- r# scr ) + find? IF skip cursor + scr @ exit THEN drop + capacity scr @ 1+ + ?DO I 2 3 at 6 .r I block b/blk 'find search + IF skip I endloop exit THEN stop? Abort" Break!" + LOOP true Abort" not found!" ; + +\ *** Block No. 30, Hexblock 1e + +\ replace strings UH 14mai88 +| : replace? ( -- f ) dy l/s + 3+ dx 3 - at + key dup #cr = IF line# redisplay true Abort" Break!" THEN + capital Ascii R = ; + +| : "mark ( -- ) r# push + 'find count dup negate c edit-at invers type normal ; + +| : (replace 'insert c@ 'find c@ - ?fit + r# push 'find c@ negate c + 'cursor #after 'find c@ delete + 'insert count 'cursor #after insert modified ; + +| : "replace get-buffers BEGIN searchthru + scr @ - ?dup IF ?stamp scr +! .all THEN r# ! imprint + "mark replace? IF (replace THEN line# redisplay REPEAT ; + +\ *** Block No. 31, Hexblock 1f + +\ Display Help-Screen, misc commands cas 11nov05 + +| : helpfile ( -- ) fromfile push editor.fb ; +| : .help ( --) + isfile push scr push helpfile scr off .screen ; +| : help ( -- ) .help key drop .screen ; + +| : screen# ( -- scr ) scr @ ; + +| Defer (fix-word + +| : fix-word ( -- ) isfile@ loadfile ! + scr @ blk ! cursor >in ! (fix-word ; + + + + +\ *** Block No. 32, Hexblock 20 + +\ Control-Characters IBM-PC Functionkeys UH 10Sep87 + +Forth definitions + +: Ctrl ( -- c ) + name 1+ c@ $1F and state @ IF [compile] Literal THEN ; +immediate + +\needs #del $7F Constant #del + +Editor definitions + +| : flipimode imode @ 0= imode ! .imode ; + +| : F ( # -- 16b ) $FFC6 swap - ; +| : shift ( n -- n' ) dup 0< + &24 - ; + +\ *** Block No. 33, Hexblock 21 + +\ Control-Characters IBM-PC Functionkeys UH 11dez88 + +Create keytable +-&72 , -&75 , -&80 , -&77 , + 3 F , 4 F , 7 F , 8 F , +Ctrl F , Ctrl S , 5 F , 6 F , + 1 F , Ctrl H , #del , -&83 , + Ctrl Y , Ctrl N , +-&82 , + #cr , #tab , #tab shift , + -&119 , -&117 , 2 F , Ctrl U , +Ctrl E , #esc , Ctrl L , 9 F shift , +-&81 , -&73 , 9 F , &10 F , +-&71 , -&79 , -&118 , -&132 , +#lf , +here keytable - 2/ Constant #keys + +\ *** Block No. 34, Hexblock 22 + +\ Try a screen Editor UH 11dez88 + +Create: actiontable +curup curleft curdown curright +line>buf char>buf buf>line buf>char +fix-word screen# copyline copychar +help backspace backspace delete-char +( insert-char ) delete-line insert-line +flipimode ( clear-line clear> ) + +tab -tab +top >""end "replace undo +update-exit flushed-exit showload >shadow +n b a mark + split join +new-screen ; +here actiontable - 2/ 1- #keys - abort( # of actions) + +\ *** Block No. 35, Hexblock 23 + +\ find keys ks 20 dez 87 + +| : findkey ( key -- adr/default ) + #keys 0 DO dup keytable [F] I 2* + @ = + IF drop [E] actiontable [F] I 2* + @ endloop exit THEN + LOOP drop ['] putchar ; + + + + + + + + + + + +\ *** Block No. 36, Hexblock 24 + +\ allocate buffers UH 01Nov86 + +c/l 2* | Constant cstack-size + +| : nextbuf ( adr -- adr' ) cstack-size + ; + +| : ?clearbuffer pad (pad @ = ?exit + pad dup (pad ! + nextbuf dup find-buffer ! 'find off + nextbuf dup insert-buffer ! 'insert off + nextbuf dup 0 chars 2! + nextbuf 0 lines 2! ; + + + + + +\ *** Block No. 37, Hexblock 25 + +\ enter and exit the editor, editor's loop UH 11mai88 + +| Variable jingle jingle on | : bell 07 charout jingle off ; + +| : clear-error ( -- ) + jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; + +| : fullquit ( -- ) BEGIN ?clearbuffer edit-at key dup char c! + findkey imprint execute ( .status ) clear-error REPEAT ; + +| : fullerror ( string -- ) jingle @ IF bell THEN count + dy l/s + 1+ over 2/ dx $20 + swap - at invers type normal + &80 col - spaces remember .all quit ; + +| : install ( -- ) + ['] fullquit Is 'quit ['] fullerror errorhandler ! ; + +\ *** Block No. 38, Hexblock 26 + +\ enter and exit the Editor UH 11mai88 + +Forth definitions + +: v ( -- ) + [E] 'start drop get-id install-screen + install ?clearbuffer + border .all .imode .status quit ; + + ' v Alias ed + +: l ( scr -- ) 1 arguments scr ! [E] top [F] v ; + + ' l Alias edit + + + +\ *** Block No. 39, Hexblock 27 + +\ savesystem enhanced view UH 24jun88 + +: savesystem [E] id off (pad off savesystem ; + +Editor definitions +| : >find ?clearbuffer >in push + name dup c@ 2+ >r bl over c! r> 'find place ; + +Forth definitions +: fix [ Dos ] >find ' @view >file + isfile ! scr ! [E] top curdown + find? IF skip 1- THEN c v ; + +' fix Is (fix-word + + + +\ *** Block No. 40, Hexblock 28 + + + + + + + + + + + + + + + + + + +\ *** Block No. 41, Hexblock 29 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/epson.prn b/8086/msdos/src/epson.prn similarity index 100% rename from 8086/msdos/epson.prn rename to 8086/msdos/src/epson.prn diff --git a/8086/msdos/extend.fb b/8086/msdos/src/extend.fb similarity index 100% rename from 8086/msdos/extend.fb rename to 8086/msdos/src/extend.fb diff --git a/8086/msdos/src/extend.fth b/8086/msdos/src/extend.fth new file mode 100644 index 0000000..998053e --- /dev/null +++ b/8086/msdos/src/extend.fth @@ -0,0 +1,209 @@ + +\ *** Block No. 0, Hexblock 0 + +\ ks 11 mai 88 +Dieses File enthält Definitionen, die zum Laden der weiteren +System- und Applikationsfiles benötigt werden. + +Unter anderem finden sich hier auch MS-DOS spezifische +Befehle wie zum Beispiel das Allokieren von Speicher- +platz ausserhalb des auf 64k begrenzten Forthsystems +und einige Routinen, die das Arbeiten mit dem Video- +Display erleichtern sowie einige Operatoren zur String- +manipulation. + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen for often used words ks cas 25sep16 + + Onlyforth \needs Assembler 2 loadfrom asm.fb + + ' save-buffers Alias sav + + ' name &12 + Constant 'name + + ' page Alias cls + + 1 8 +thru .( Systemerweiterung geladen) cr + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ Postkernel words ks 22 dez 87 + + : blank ( addr quan -- ) bl fill ; + + Code stash ( u1 u2 -- u1 u1 u2 ) + S W mov W ) push Next end-code +\ : stash ( u1 u2 -- u1 u1 u2 ) over swap ; + + : >expect ( addr len -- ) stash expect span @ over place ; + + : .field ( addr len quan -- ) + over - >r type r> 0 max spaces ; + + : tab ( n -- ) col - 0 max spaces ; + + + +\ *** Block No. 3, Hexblock 3 + +\ postkernel ks 08 mär 89 +\ hier sollte END-CODE eigentlich aehem, also z.B. -TRANSIENT + +\needs end-code : end-code toss also ; + + : u? ( addr -- ) @ u. ; + + : adr ' >body state @ 0=exit [compile] Literal ; immediate + + : Abort( ( f -- ) IF [compile] .( true abort" !" THEN + [compile] ( ; + + : arguments ( n -- ) + depth 1- > Error" zu wenige Parameter" ; + + + +\ *** Block No. 4, Hexblock 4 + +\ MS-DOS memory management + + Code lallocate ( pages -- seg ff / rest err# ) + R push D R mov $48 # A+ mov $21 int CS + ?[ A D xchg A pop R push A R xchg + ][ R pop A push 0 # D mov ]? Next end-code + + Code lfree ( seg -- err# ) + E: push D E: mov $49 # A+ mov $21 int CS + ?[ A D xchg ][ 0 # D mov ]? E: pop Next end-code + + + + + + + +\ *** Block No. 5, Hexblock 5 + +\ postkernel ks 03 aug 87 + + c/row c/col * 2* Constant c/dis \ characters per display + + Code video@ ( -- seg ) D push R D mov $F # A+ mov + $10 int R D xchg 0 # D- mov 7 # A- cmp + 0= ?[ $B0 # D+ mov ][ $B8 # D+ add ]? Next + end-code + + : savevideo ( -- seg / ff ) + [ c/dis b/seg /mod swap 0<> - ] Literal lallocate + IF drop false exit THEN video@ 0 2 pick 0 c/dis lmove ; + + : restorevideo ( seg -- ) ?dup 0=exit + dup 0 video@ 0 c/dis lmove lfree drop ; + + +\ *** Block No. 6, Hexblock 6 + +\ string operators append attach ks 21 jun 87 + +| : .stringoverflow true Abort" String zu lang" ; + + Code append ( char addr -- ) + D W mov D pop W ) A- mov 1 # A- add CS + ?[ ;c: .stringoverflow ; Assembler ]? + A- W ) mov 0 # A+ mov A W add + D- W ) mov D pop Next end-code + + Code attach ( addr len addr1 -- ) D W mov C pop + I D mov I pop W ) A- mov A- A+ mov C- A+ add CS + ?[ ;c: .stringoverflow ; Assembler ]? + A+ W ) mov A+ A+ xor A+ C+ mov A W add W inc + rep byte movs D I mov D pop Next end-code + + +\ *** Block No. 7, Hexblock 7 + +\\ string operators append attach detract ks 21 jun 87 + + : append ( char addr -- ) + under count + c! dup c@ 1+ swap c! ; + + : attach ( addr len addr.to -- ) + >r under r@ count + swap move r@ c@ + r> c! ; + + : detract ( addr -- char ) + dup c@ 1- dup 0> and over c! + count >r dup count -rot swap r> cmove ; + + + + + + +\ *** Block No. 8, Hexblock 8 + +\ ?" string operator ks 09 feb 88 + +\ : (?" ( 8b -- index ) "lit under count rot +\ scan IF swap - exit THEN 2drop false ; + +| Create months ," janfebmäraprmaijunjulaugsepoktnovdez" + + : >months ( n -- addr len ) 3 * 2- months + 3 ; + +| Code (?" ( 8b -- index ) + A D xchg I ) C- mov 0 # C+ mov C I add + I W mov I inc std 0<>rep byte scas cld + 0= ?[ C inc ]? C D mov Next + end-code + + : ?" compile (?" ," align ; immediate restrict + +\ *** Block No. 9, Hexblock 9 + +\ Conditional compilation ks 12 dez 88 +| Defer cond + + : .THEN ; immediate + + : .ELSE ( -- ) 0 + BEGIN name nullstring? IF drop exit THEN + find IF cond -1 case? ?exit ELSE drop THEN + REPEAT ; immediate + + : .IF ( f -- ) ?exit [compile] .ELSE ; immediate + +| : (cond ( n cfa -- n' ) + ['] .THEN case? IF 1- exit THEN + ['] .ELSE case? IF dup 0= + exit THEN + ['] .IF = 0=exit 1+ ; ' (cond is cond + +\ *** Block No. 10, Hexblock a + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/f83asm.fb b/8086/msdos/src/f83asm.fb similarity index 100% rename from 8086/msdos/f83asm.fb rename to 8086/msdos/src/f83asm.fb diff --git a/8086/msdos/src/f83asm.fth b/8086/msdos/src/f83asm.fth new file mode 100644 index 0000000..6827b54 --- /dev/null +++ b/8086/msdos/src/f83asm.fth @@ -0,0 +1,646 @@ + +\ *** Block No. 0, Hexblock 0 + +\ 8086 Assembler cas 10nov05 + +The 8086 Assembler was written by Mike Perry. +To create and assembler language definition, use the defining +word CODE. It must be terminated with either END-CODE or +its synonym C;. How the assembler operates is a very +interesting example of the power of CREATE DOES> Basically +the instructions are categorized and a defining word is +created for each category. When the nmemonic for the +instruction is interpreted, it compiles itself. + +Adapted for volksFORTH by Klaus Schleisiek + +No really tested, but + CODE TEST TOS PUSH 1 # TOS MOV NEXT END-CODE +works! + +\ *** Block No. 1, Hexblock 1 + +\ 8086 Assembler ks cas 10nov05 +Onlyforth +Vocabulary Assembler +: octal 8 Base ! ; + +decimal 1 14 +THRU clear + +Onlyforth + + : Code Create [ Assembler ] here dup 2- ! Assembler ; + +CR .( 8086 Assembler loaded ) +Onlyforth + + + + +\ *** Block No. 2, Hexblock 2 + +\ 8086 Assembler ks 19 mär 88 +: LABEL CREATE ASSEMBLER ; +\ 232 CONSTANT DOES-OP +\ 3 CONSTANT DOES-SIZE +\ : DOES? ( IP -- IP' F ) +\ DUP DOES-SIZE + SWAP C@ DOES-OP = ; +ASSEMBLER ALSO DEFINITIONS +: C; ( -- ) END-CODE ; +OCTAL +DEFER C, FORTH ' C, ASSEMBLER IS C, +DEFER , FORTH ' , ASSEMBLER IS , +DEFER HERE FORTH ' HERE ASSEMBLER IS HERE +DEFER ?>MARK +DEFER ?>RESOLVE +DEFER ? @ SWAP 7000 AND = 0<> ; +| 0 MD R8? | 1 MD R16? | 2 MD MEM? | 3 MD SEG? | 4 MD #? +| : REG? ( n -- f ) 7000 AND 2000 < 0<> ; +| : BIG? ( N -- F ) ABS -200 AND 0<> ; +| : RLOW ( n1 -- n2 ) 7 AND ; +| : RMID ( n1 -- n2 ) 70 AND ; +| VARIABLE SIZE SIZE ON +: BYTE ( -- ) SIZE OFF ; +| : OP, ( N OP -- ) OR C, ; +| : W, ( OP MR -- ) R16? 1 AND OP, ; +| : SIZE, ( OP -- OP' ) SIZE @ 1 AND OP, ; +| : ,/C, ( n f -- ) IF , ELSE C, THEN ; +| : RR, ( MR1 MR2 -- ) RMID SWAP RLOW OR 300 OP, ; +| VARIABLE LOGICAL +| : B/L? ( n -- f ) BIG? LOGICAL @ OR ; + +\ *** Block No. 5, Hexblock 5 + +\ Addressing ks 19 mär 88 +| : MEM, ( DISP MR RMID -- ) OVER #) = + IF RMID 6 OP, DROP , + ELSE RMID OVER RLOW OR -ROT [BP] = OVER 0= AND + IF SWAP 100 OP, C, ELSE SWAP OVER BIG? + IF 200 OP, , ELSE OVER 0= + IF C, DROP ELSE 100 OP, C, + THEN THEN THEN THEN ; +| : WMEM, ( DISP MEM REG OP -- ) OVER W, MEM, ; +| : R/M, ( MR REG -- ) + OVER REG? IF RR, ELSE MEM, THEN ; +| : WR/SM, ( R/M R OP -- ) 2 PICK DUP REG? + IF W, RR, ELSE DROP SIZE, MEM, THEN SIZE ON ; +| VARIABLE INTER +: FAR ( -- ) INTER ON ; +| : ?FAR ( n1 -- n2 ) INTER @ IF 10 OR THEN INTER OFF ; + +\ *** Block No. 6, Hexblock 6 + +\ Defining Words to Generate Op Codes ks 19 mär 88 +| : 1MI CREATE C, DOES> C@ C, ; +| : 2MI CREATE C, DOES> C@ C, 12 C, ; +| : 3MI CREATE C, DOES> C@ C, HERE - 1- + DUP -200 177 uWITHIN NOT ABORT" Branch out of Range" C, ; +| : 4MI CREATE C, DOES> C@ C, MEM, ; +| : 5MI CREATE C, DOES> C@ SIZE, SIZE ON ; +| : 6MI CREATE C, DOES> C@ SWAP W, ; +| : 7MI CREATE C, DOES> C@ 366 WR/SM, ; +| : 8MI CREATE C, DOES> C@ SWAP R16? 1 AND OR SWAP # = + IF C, C, ELSE 10 OR C, THEN ; +| : 9MI CREATE C, DOES> C@ OVER R16? + IF 100 OR SWAP RLOW OP, ELSE 376 WR/SM, THEN ; +| : 10MI CREATE C, DOES> C@ OVER CL = + IF NIP 322 ELSE 320 THEN WR/SM, ; + + +\ *** Block No. 7, Hexblock 7 + +\ Defining Words to Generate Op Codes ks 19 mär 88 +| : 11MI CREATE C, C, DOES> OVER #) = + IF NIP C@ INTER @ + IF 1 AND IF 352 ELSE 232 THEN C, SWAP , , INTER OFF + ELSE SWAP HERE - 2- SWAP 2DUP 1 AND SWAP BIG? NOT AND + IF 2 OP, C, ELSE C, 1- , THEN THEN + ELSE OVER S#) = IF NIP #) SWAP THEN + 377 C, 1+ C@ ?FAR R/M, THEN ; +| : 12MI CREATE C, C, C, DOES> OVER REG? + IF C@ SWAP RLOW OP, ELSE 1+ OVER SEG? + IF C@ RLOW SWAP RMID OP, + ELSE COUNT SWAP C@ C, MEM, + THEN THEN ; +| : 14MI CREATE C, DOES> C@ + DUP ?FAR C, 1 AND 0= IF , THEN ; + + +\ *** Block No. 8, Hexblock 8 + +\ Defining Words to Generate Op Codes ks 19 mär 88 +| : 13MI CREATE C, C, DOES> COUNT >R C@ LOGICAL ! DUP REG? + IF OVER REG? + IF R> OVER W, SWAP RR, ELSE OVER DUP MEM? SWAP #) = OR + IF R> 2 OR WMEM, ELSE ( # ) NIP DUP RLOW 0= ( ACC? ) + IF R> 4 OR OVER W, R16? ,/C, + ELSE OVER B/L? OVER R16? 2DUP AND + -ROT 1 AND SWAP NOT 2 AND OR 200 OP, + SWAP RLOW 300 OR R> OP, ,/C, + THEN THEN THEN + ELSE ( MEM ) ROT DUP REG? + IF R> WMEM, + ELSE ( # ) DROP 2 PICK B/L? DUP NOT 2 AND 200 OR SIZE, + -ROT R> MEM, SIZE @ AND ,/C, SIZE ON + THEN THEN ; + + +\ *** Block No. 9, Hexblock 9 + +\ Instructions ks 19 mär 88 +: TEST ( source dest -- ) DUP REG? + IF OVER REG? + IF 204 OVER W, SWAP RR, ELSE OVER DUP MEM? SWAP #) = OR + IF 204 WMEM, ELSE ( # ) NIP DUP RLOW 0= ( ACC? ) + IF 250 OVER W, + ELSE 366 OVER W, DUP RLOW 300 OP, + THEN R16? ,/C, THEN THEN + ELSE ( MEM ) ROT DUP REG? + IF 204 WMEM, + ELSE ( # ) DROP 366 SIZE, 0 MEM, SIZE @ ,/C, SIZE ON + THEN THEN ; + + + + + +\ *** Block No. 10, Hexblock a + +\ Instructions ks 19 mär 88 +HEX +: ESC ( source ext-opcode -- ) RLOW 0D8 OP, R/M, ; +: INT ( N -- ) 0CD C, C, ; +: SEG ( SEG -- ) RMID 26 OP, ; +: XCHG ( MR1 MR2 -- ) DUP REG? + IF DUP AX = + IF DROP RLOW 90 OP, ELSE OVER AX = + IF NIP RLOW 90 OP, ELSE 86 WR/SM, THEN THEN + ELSE ROT 86 WR/SM, THEN ; + +: CS: CS SEG ; +: DS: DS SEG ; +: ES: ES SEG ; +: SS: SS SEG ; + + +\ *** Block No. 11, Hexblock b + +\ Instructions ks 19 mär 88 +: MOV ( S D -- ) DUP SEG? + IF 8E C, R/M, ELSE DUP REG? + IF OVER #) = OVER RLOW 0= AND + IF A0 SWAP W, DROP , ELSE OVER SEG? + IF SWAP 8C C, RR, ELSE OVER # = + IF NIP DUP R16? SWAP RLOW OVER 8 AND OR B0 OP, ,/C, + ELSE 8A OVER W, R/M, THEN THEN THEN + ELSE ( MEM ) ROT DUP SEG? + IF 8C C, MEM, ELSE DUP # = + IF DROP C6 SIZE, 0 MEM, SIZE @ ,/C, + ELSE OVER #) = OVER RLOW 0= AND + IF A2 SWAP W, DROP , ELSE 88 OVER W, R/M, + THEN THEN THEN THEN THEN SIZE ON ; + + + +\ *** Block No. 12, Hexblock c + +\ Instructions 12Oct83map + 37 1MI AAA D5 2MI AAD D4 2MI AAM 3F 1MI AAS +0 10 13MI ADC 0 00 13MI ADD 2 20 13MI AND 10 E8 11MI CALL + 98 1MI CBW F8 1MI CLC FC 1MI CLD FA 1MI CLI + F5 1MI CMC 0 38 13MI CMP A6 5MI CMPS 99 1MI CWD + 27 1MI DAA 2F 1MI DAS 08 9MI DEC 30 7MI DIV + ( ESC ) F4 1MI HLT 38 7MI IDIV 28 7MI IMUL + E4 8MI IN 00 9MI INC ( INT ) 0CE 1MI INTO +0CF 1MI IRET 77 3MI JA 73 3MI JAE 72 3MI JB + 76 3MI JBE E3 3MI JCXZ 74 3MI JE 7F 3MI JG + 7D 3MI JGE 7C 3MI JL 7E 3MI JLE 20 E9 11MI JMP + 75 3MI JNE 71 3MI JNO 79 3MI JNS 70 3MI JO + 7A 3MI JPE 7B 3MI JPO 78 3MI JS 9F 1MI LAHF + C5 4MI LDS 8D 4MI LEA C4 4MI LES F0 1MI LOCK +0AC 6MI LODS E2 3MI LOOP E1 3MI LOOPE E0 3MI LOOPNE + + +\ *** Block No. 13, Hexblock d + +\ Instructions 12Apr84map + ( MOV ) 0A4 5MI MOVS 20 7MI MUL 18 7MI NEG + 90 1MI NOP 10 7MI NOT 2 08 13MI OR E6 8MI OUT + 8F 07 58 12MI POP 9D 1MI POPF + 0FF 36 50 12MI PUSH 9C 1MI PUSHF + 10 10MI RCL 18 10MI RCR + F2 1MI REP F2 1MI REPNZ F3 1MI REPZ + C3 14MI RET 00 10MI ROL 8 10MI ROR 9E 1MI SAHF + 38 10MI SAR 0 18 13MI SBB 0AE 5MI SCAS ( SEG ) + 20 10MI SHL 28 10MI SHR F9 1MI STC FD 1MI STD + FB 1MI STI 0AA 6MI STOS 0 28 13MI SUB ( TEST ) + 9B 1MI WAIT ( XCHG ) D7 1MI XLAT 2 30 13MI XOR + C2 14MI +RET + + + + +\ *** Block No. 14, Hexblock e + +\ Structured Conditionals ks 19 mär 88 +: A?>MARK ( -- f addr ) TRUE HERE 0 C, ; +: A?>RESOLVE ( f addr -- ) HERE OVER 1+ - SWAP C! true ?pairs ; +: A?MARK ASSEMBLER IS ?>MARK +' A?>RESOLVE ASSEMBLER IS ?>RESOLVE +' A? 79 CONSTANT 0< +78 CONSTANT 0>= 7D CONSTANT < 7C CONSTANT >= +7F CONSTANT <= 7E CONSTANT > 73 CONSTANT U< +72 CONSTANT U>= 77 CONSTANT U<= 76 CONSTANT U> +71 CONSTANT OV +DECIMAL + +\ *** Block No. 15, Hexblock f + +\ Structured Conditionals cas 10nov05 +HEX +: IF C, ?>MARK ; +: THEN ?>RESOLVE ; +: ELSE 0EB IF 2SWAP THEN ; +: BEGIN ? U +C; A synonym for END-CODE + +Deferring the definitions of the commas, marks, and resolves + allows the same assembler to serve for both the system and the + Meta-Compiler. + + + + + + + + +\ *** Block No. 18, Hexblock 12 + +\ 8086 Assembler Register Definitions 12Oct83map + +On the 8086, register names are cleverly defined constants. + +The value returned by registers and by modes such as #) contains +both mode and register information. The instructions use the +mode information to decide how many arguments exist, and what to +assemble. + Like many CPUs, the 8086 uses many 3 bit fields in its opcodes +This makes octal ( base 8 ) natural for describing the registers + + +We redefine the Registers that FORTH uses to implement its +virtual machine. + + + +\ *** Block No. 19, Hexblock 13 + +\ Addressing Modes 16Oct83map +MD defines words which test for various modes. +R8? R16? MEM? SEG? #? test for mode equal to 0 thru 4. +REG? tests for any register mode ( 8 or 16 bit). +BIG? tests offsets size. True if won't fit in one byte. +RLOW mask off all but low register field. +RMID mask off all but middle register field. +SIZE true for 16 bit, false for 8 bit. +BYTE set size to 8 bit. +OP, for efficiency. OR two numbers and assemble. +W, assemble opcode with W field set for size of register. +SIZE, assemble opcode with W field set for size of data. +,/C, assemble either 8 or 16 bits. +RR, assemble register to register instruction. +LOGICAL true while assembling logical instructions. +B/L? see 13MI + +\ *** Block No. 20, Hexblock 14 + +\ Addressing 16Oct83map +These words perform most of the addressing mode encoding. +MEM, handles memory reference modes. It takes a displacement, + a mode/register, and a register, and encodes and assembles + them. + + +WMEM, uses MEM, after packing the register size into the opcode +R/M, assembles either a register to register or a register to + or from memory mode. +WR/SM, assembles either a register mode with size field, or a + memory mode with size from SIZE. Default is 16 bit. Use BYTE + for 8 bit size. +INTER true if inter-segment jump, call, or return. +FAR sets INTER true. Usage: FAR JMP, FAR CALL, FAR RET. +?FAR sets far bit, clears flag. + +\ *** Block No. 21, Hexblock 15 + +\ Defining Words to Generate Op Codes 12Oct83map +1MI define one byte constant instructions. +2MI define ascii adjust instructions. +3MI define branch instructions, with one byte offset. +4MI define LDS, LEA, LES instructions. +5MI define string instructions. +6MI define more string instructions. +7MI define multiply and divide instructions. +8MI define input and output instructions. + +9MI define increment/decrement instructions. + +10MI define shift/rotate instructions. +*NOTE* To allow both 'ax shl' and 'ax cl shl', if the register +on top of the stack is cl, shift second register by cl. If not, +shift top ( only) register by one. + +\ *** Block No. 22, Hexblock 16 + +\ Defining Words to Generate Op Codes 09Apr84map +11MI define calls and jumps. + notice that the first byte stored is E9 for jmp and E8 for call + so C@ 1 AND is zero for call, 1 for jmp. + syntax for direct intersegment: address segment #) FAR JMP + + + +12MI define pushes and pops. + + + + +14MI defines returns. + RET FAR RET n +RET n FAR +RET + + +\ *** Block No. 23, Hexblock 17 + +\ Defining Words to Generate Op Codes 16Oct83map +13MI define arithmetic and logical instructions. + + + + + + + + + + + + + + + +\ *** Block No. 24, Hexblock 18 + +\ Instructions 16Oct83map +TEST bits in dest + + + + + + + + + + + + + + + +\ *** Block No. 25, Hexblock 19 + +\ Instructions 16Oct83map + +ESC +INT assemble interrupt instruction. +SEG assemble segment instruction. +XCHG assemble register swap instruction. + + + + + +CS: DS: ES: SS: assemble segment over-ride instructions. + + + + + +\ *** Block No. 26, Hexblock 1a + +\ Instructions 12Oct83map +MOV as usual, the move instruction is the most complicated. + It allows more addressing modes than any other, each of which + assembles something more or less unique. + + + + + + + + + + + + + +\ *** Block No. 27, Hexblock 1b + +\ Instructions 12Oct83map +Most instructions are defined on these two screens. Mnemonics in +parentheses are defined earlier or not at all. + + + + + + + + + + + + + + +\ *** Block No. 28, Hexblock 1c + +\ Instructions 12Oct83map +Most instructions are defined on these two screens. Mnemonics in +parentheses are defined earlier or not at all. + + + + + + + + + + + + + + +\ *** Block No. 29, Hexblock 1d + +\ Structured Conditionals 16Oct83map +A?>MARK assembler version of forward mark. +A?>RESOLVE assembler version of forward resolve. +A? IF ." $" u. exit THEN + dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ; + +: install \ install editor's keyboard + page ." Press keys requested (Spacebar to confirm)" + #keys 0 ?DO cr I 2* actiontable + @ >name .name + tab ." : " I 2* keytable + dup @ .key tab ." -> " + key dup bl = IF drop dup @ THEN dup .key swap ! + LOOP ; +--> + +\ *** Block No. 2, Hexblock 2 + +\ define action-names UH 11mai88 +: :a ( addr -- adr' ) dup @ Alias 2+ ; +actiontable +:a up :a left :a down :a right +:a push-line :a push-char :a pull-line :a pull-char +:a fix-word :a screen# :a copy-line :a copy-char +:a backspace :a backspace :a backspace :a delete-char +( :a insert-char ) :a delete-line :a insert-line +:a flipimode ( :a erase-line :a clear-to-right) +:a new-line :a +tab :a -tab +:a home :a to-end :a search :a undo +:a update-exit :a flushed-exit :a showload :a shadow-screen +:a next-Screen :a back-Screen :a alter-Screen :a mark-screen +drop + +warning off install empty + +\ *** Block No. 3, Hexblock 3 + + + + + + + + + + + + + + + + + + +\ *** Block No. 4, Hexblock 4 + + + + + + + + + + + + + + + + + + +\ *** Block No. 5, Hexblock 5 + + + + + + + + + + + + + + + + + + +\ *** Block No. 6, Hexblock 6 + + + + + + + + + + + + + + + + + + +\ *** Block No. 7, Hexblock 7 + + + + + + + + + + + + + + + + + + +\ *** Block No. 8, Hexblock 8 + + + + + + + + + + + + + + + + + + +\ *** Block No. 9, Hexblock 9 + + + + + + + + + + + + + + + + + + +\ *** Block No. 10, Hexblock a + + + + + + + + + + + + + + + + + + +\ *** Block No. 11, Hexblock b + + + + + + + + + + + + + + + + + + +\ *** Block No. 12, Hexblock c + + + + + + + + + + + + + + + + + + +\ *** Block No. 13, Hexblock d + + + + + + + + + + + + + + + + + + +\ *** Block No. 14, Hexblock e + + + + + + + + + + + + + + + + + + +\ *** Block No. 15, Hexblock f + + + + + + + + + + + + + + + + + + +\ *** Block No. 16, Hexblock 10 + + + + + + + + + + + + + + + + + + +\ *** Block No. 17, Hexblock 11 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/kernel.fb b/8086/msdos/src/kernel.fb similarity index 100% rename from 8086/msdos/kernel.fb rename to 8086/msdos/src/kernel.fb diff --git a/8086/msdos/src/kernel.fth b/8086/msdos/src/kernel.fth new file mode 100644 index 0000000..a29411d --- /dev/null +++ b/8086/msdos/src/kernel.fth @@ -0,0 +1,3040 @@ + +\ *** Block No. 0, Hexblock 0 + +\^@ #### volksFORTH #### cas 18jul20 +VolksForth has been developed by + + K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck + Ulli Hoffmann, Philip Zembrod, Carsten Strotmann +6502 version by B.Pennemann and K.Schleisiek +Port to C64 "ultraFORTH" by G. Rehfeld +Port to 68000 and Atari ST by D.Weineck and B.Pennemann +Port to 8080 and CP/M by U.Hoffmann jul 86 +Port to C16 "ultraFORTH" by C.Vogt +Port to 8088/86 and MS-DOS by K.Schleisiek dez 87 + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ MS-DOS volksForth Load Screen ks cas 18jul20 + Onlyforth \needs Transient include meta.fb + + 2 loadfrom META.fb + + new FORTH.COM Onlyforth Target definitions + + 4 &111 thru \ Standard 8088-System + + flush \ close FORTH.COM + +cr .( new kernel as "FORTH.COM" written) cr bell + + + + + +\ *** Block No. 2, Hexblock 2 + +\\ Die Nutzung der 8088/86 Register ks 27 oct 86 + +Im Assembler sind Forthgemaesse Namen fuer die Register gewaehlt +Dabei ist die Zuordnung zu den Intel Namen folgendermassen: + +A <=> AX A- <=> AL A+ <=> AH +C <=> CX C- <=> CL C+ <=> CH + Register A und C sind zur allgemeinen Benutzung frei + +D <=> DX D- <=> DL D+ <=> DH + das oberste Element des (Daten)-Stacks. + +R <=> BX R- <=> RL R+ <=> RH + der Return_stack_pointer + + + +\ *** Block No. 3, Hexblock 3 + +\\ Die Nutzung der 8088/86 Register ks 27 oct 86 + +U <=> BP User_area_pointer +S <=> SP Daten_stack_pointer +I <=> SI Instruction_pointer +W <=> DI Word_pointer, im allgemeinen zur Benutzung frei. + +D: <=> DS E: <=> ES S: <=> SS C: <=> CS + Alle Segmentregister werden beim booten auf den Wert des + Codesegments C: gesetzt und muessen, wenn sie "verstellt" + werden, wieder auf C: zurueckgesetzt werden. + + + + + + +\ *** Block No. 4, Hexblock 4 + +\ FORTH Preamble and ID ks 11 mär 89 +Assembler + +nop 5555 # jmp here 2- >label >cold +nop 5555 # jmp here 2- >label >restart + +Create origin here origin! here $100 0 fill +\ Hier beginnen die Kaltstartwerte der Benutzervariablen + + $E9 int end-code -4 , $FC allot +\ this is the multitasker initialization in the user area + +| Create logo ," volksFORTH-83 rev. 3.81.41" + + + + +\ *** Block No. 5, Hexblock 5 + +\ Next ks 27 oct 86 + + Variable next-link 0 next-link ! + + Host Forth Assembler also definitions + + : Next lods A W xchg W ) jmp + there tnext-link @ T , H tnext-link ! ; + +\ Next ist in-line code. Fuer den debugger werden daher alle +\ "nexts" in einer Liste mit dem Anker NEXT-LINK verbunden. + + : u' ( -- offset ) T ' 2+ c@ H ; + + Target + + +\ *** Block No. 6, Hexblock 6 + +\ recover ;c: noop ks 27 oct 86 + + Create recover Assembler + R dec R dec I R ) mov I pop Next + end-code + +Host Forth Assembler also definitions + + : ;c: 0 T recover # call ] end-code H ; + +Target + +| Code di cli Next end-code +| Code ei sti here Next end-code + + Code noop here 2- ! end-code + +\ *** Block No. 7, Hexblock 7 + +\ User variables ks 16 sep 88 + 8 uallot drop \ Platz fuer Multitasker + \ Felder: entry link spare SPsave + \ Laenge kompatibel zum 68000, 6502 und 8080 volksFORTH + User s0 + User r0 + User dp + User offset 0 offset ! + User base &10 base ! + User output + User input + User errorhandler \ pointer for Abort" -code + User aborted \ code address of latest error + User voc-link + User file-link cr .( Wieso ist UDP Uservariable? ) + User udp \ points to next free addr in User_area + +\ *** Block No. 8, Hexblock 8 + +\ manipulate system pointers ks 03 aug 87 + + Code sp@ ( -- addr ) D push S D mov Next end-code + + Code sp! ( addr -- ) D S mov D pop Next end-code + + + Code up@ ( -- addr ) D push U D mov Next end-code + + Code up! ( addr -- ) D U mov D pop Next end-code + + Code ds@ ( -- addr ) D push D: D mov Next end-code + + $10 Constant b/seg \ bytes per segment + + + +\ *** Block No. 9, Hexblock 9 + +\ manipulate returnstack ks 27 oct 86 + + Code rp@ ( -- addr ) D push R D mov Next end-code + + Code rp! ( addr -- ) D R mov D pop Next end-code + + + Code >r ( 16b -- ) R dec R dec D R ) mov D pop Next + end-code restrict + + Code r> ( -- 16b ) D push R ) D mov R inc R inc Next + end-code restrict + + + + + +\ *** Block No. 10, Hexblock a + +\ r@ rdrop exit unnest ?exit ks 27 oct 86 + Code r@ ( -- 16b ) D push R ) D mov Next end-code + + Code rdrop R inc R inc Next end-code restrict + + Code exit + Label >exit R ) I mov R inc R inc Next end-code + + Code unnest >exit here 2- ! end-code + + Code ?exit ( flag -- ) + D D or D pop >exit 0= ?] [[ Next end-code + + Code 0=exit ( flag -- ) + D D or D pop >exit 0= not ?] ]] end-code +\ : ?exit ( flag -- ) IF rdrop THEN ; + +\ *** Block No. 11, Hexblock b + +\ execute perform ks 27 oct 86 + + Code execute ( acf -- ) D W mov D pop W ) jmp end-code + + Code perform ( addr -- ) D W mov D pop W ) W mov W ) jmp + end-code + +\ : perform ( addr -- ) @ execute ; + + + + + + + + + +\ *** Block No. 12, Hexblock c + +\ c@ c! ctoggle ks 27 oct 86 + + Code c@ ( addr -- 8b ) + D W mov W ) D- mov 0 # D+ mov Next end-code + + Code c! ( 16b addr -- ) + D W mov A pop A- W ) mov D pop Next end-code + + Code ctoggle ( 8b addr -- ) + D W mov A pop A- W ) xor D pop Next end-code + +\ : ctoggle ( 8b addr -- ) under c@ xor swap c! ; + + Code flip ( 16b1 -- 16b2 ) D- D+ xchg Next end-code + + + +\ *** Block No. 13, Hexblock d + +\ @ ! 2@ 2! ks 27 oct 86 + + Code @ ( addr -- 16b ) D W mov W ) D mov Next end-code + + Code ! ( 16b addr -- ) D W mov W ) pop D pop Next + end-code + + : 2@ ( addr -- 32b ) dup 2+ @ swap @ ; + + : 2! ( 32b addr -- ) under ! 2+ ! ; + + + + + + + +\ *** Block No. 14, Hexblock e + +\ +! drop swap ks 27 oct 86 + + Code +! ( 16b addr -- ) + D W mov A pop A W ) add D pop Next end-code + +\ : +! ( n addr -- ) under @ + swap ! ; + + + Code drop ( 16b -- ) D pop Next end-code + + Code swap ( 16b1 16b2 -- 16b2 16b1 ) + A pop D push A D xchg Next end-code + + + + + +\ *** Block No. 15, Hexblock f + +\ dup ?dup ks 27 oct 86 + + Code dup ( 16b -- 16b 16b ) D push Next end-code + +\ : dup ( 16b -- 16b 16b ) sp@ @ ; + + Code ?dup ( 16b -- 16b 16b / false ) + D D or 0= not ?[ D push ]? Next end-code + +\ : ?dup ( 16b -- 16b 16b / false) dup 0=exit dup ; + + + + + + + +\ *** Block No. 16, Hexblock 10 + +\ over rot nip under ks 27 oct 86 + + Code over ( 16b1 16b2 -- 16b1 16b2 16b1 ) + A D xchg D pop D push A push Next end-code +\ : over >r dup r> swap ; + + Code rot ( 16b1 16b2 16b3 -- 16b2 16b3 16b1 ) + A D xchg C pop D pop C push A push Next end-code +\ : rot >r swap r> swap ; + + Code nip ( 16b1 16b2 -- 16b2 ) S inc S inc Next end-code +\ : nip swap drop ; + + Code under ( 16b1 16b2 -- 16b2 16b1 16b2 ) + A pop D push A push Next end-code +\ : under swap over ; + +\ *** Block No. 17, Hexblock 11 + +\ -rot pick ks 27 oct 86 + + Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) + A D xchg D pop C pop A push C push Next end-code + +\ : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; + + Code pick ( n -- 16b.n ) + D sal D W mov S W add W ) D mov Next end-code + +\ : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; + + + + + + +\ *** Block No. 18, Hexblock 12 + +\ roll -roll ks 27 oct 86 + + Code roll ( n -- ) + A I xchg D sal D C mov D I mov S I add + I ) D mov I W mov I dec W inc std + rep byte movs cld A I xchg S inc S inc Next + end-code +\ : roll ( n -- ) +\ dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; + + Code -roll ( n -- ) A I xchg D sal D C mov + S W mov D pop S I mov S dec S dec + rep byte movs D W ) mov D pop A I xchg Next + end-code +\ : -roll ( n -- ) >r dup sp@ dup 2+ +\ dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; + +\ *** Block No. 19, Hexblock 13 + +\ 2swap 2drop 2dup 2over ks 27 oct 86 + Code 2swap ( 32b1 32b2 -- 32b2 32b1 ) C pop A pop W pop + C push D push W push A D xchg Next end-code +\ : 2swap ( 32b1 32b2 -- 32b2 32b1 ) rot >r rot r> ; + + Code 2drop ( 32b -- ) S inc S inc D pop Next end-code +\ : 2drop ( 32b -- ) drop drop ; + + Code 2dup ( 32b -- 32b 32b ) + S W mov D push W ) push Next end-code +\ : 2dup ( 32b -- 32b 32b ) over over ; + + Code 2over ( 1 2 x x -- 1 2 x x 1 2 ) + D push S W mov 6 W D) push 4 W D) D mov Next + end-code +\ : 2over ( 1 2 x x -- 1 2 x x 1 2 ) 3 pick 3 pick ; + +\ *** Block No. 20, Hexblock 14 + +\ and or xor not ks 27 oct 86 + + Code not ( 16b1 -- 16b2 ) D com Next end-code + + Code and ( 16b1 16b2 -- 16b3 ) + A pop A D and Next end-code + + Code or ( 16b1 16b2 -- 16b3 ) + A pop A D or Next end-code +\ : or ( 16b1 16b2 -- 16b3 ) not swap not and not ; + + Code xor ( 16b1 16b2 -- 16b3 ) + A pop A D xor Next end-code + + + + +\ *** Block No. 21, Hexblock 15 + +\ + - negate ks 27 oct 86 + + Code + ( n1 n2 -- n3 ) A pop A D add Next end-code + + Code negate ( n1 -- n2 ) D neg Next end-code +\ : negate ( n1 -- n2 ) not 1+ ; + + Code - ( n1 n2 -- n3 ) + A pop D A sub A D xchg Next end-code +\ : - ( n1 n2 -- n3 ) negate + ; + + + + + + + +\ *** Block No. 22, Hexblock 16 + +\ dnegate d+ ks 27 oct 86 + + Code dnegate ( d1 -- -d1 ) D com A pop A neg + CS not ?[ D inc ]? A push Next end-code + + Code d+ ( d1 d2 -- d3 ) A pop C pop W pop + W A add A push C D adc Next end-code + + + + + + + + + + +\ *** Block No. 23, Hexblock 17 + +\ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- ks 27 oct 86 + + Code 1+ ( n1 -- n2 ) [[ D inc Next + Code 2+ ( n1 -- n2 ) [[ D inc swap ]] + Code 3+ ( n1 -- n2 ) [[ D inc swap ]] + Code 4+ ( n1 -- n2 ) [[ D inc swap ]] +| Code 6+ ( n1 -- n2 ) D inc D inc ]] end-code + + Code 1- ( n1 -- n2 ) [[ D dec Next + Code 2- ( n1 -- n2 ) [[ D dec swap ]] + Code 4- ( n1 -- n2 ) D dec D dec ]] end-code + + + + + + +\ *** Block No. 24, Hexblock 18 + +\ number Constants ks 30 jan 88 +-1 Constant true 0 Constant false + + 0 ( -- 0 ) Constant 0 + 1 ( -- 1 ) Constant 1 + 2 ( -- 2 ) Constant 2 + 3 ( -- 3 ) Constant 3 + 4 ( -- 4 ) Constant 4 + -1 ( -- -1 ) Constant -1 + + Code on ( addr -- ) -1 # A mov +[[ D W mov A W ) mov D pop Next + Code off ( addr -- ) 0 # A mov ]] end-code + +\ : on ( addr -- ) true swap ! ; +\ : off ( addr -- ) false swap ! ; + +\ *** Block No. 25, Hexblock 19 + +\ words for number literals ks 27 oct 86 + + Code lit ( -- 16b ) D push I ) D mov I inc +[[ I inc Next end-code restrict + + Code clit ( -- 8b ) + D push I ) D- mov 0 # D+ mov ]] end-code restrict + + : Literal ( 16b -- ) + dup $FF00 and IF compile lit , exit THEN + compile clit c, ; immediate restrict + + + + + + +\ *** Block No. 26, Hexblock 1a + +\ comparision code words ks 27 oct 86 + + Code 0= ( 16b -- flag ) + D D or 0 # D mov 0= ?[ D dec ]? Next end-code + + Code 0<> ( n -- flag ) + D D or 0 # D mov 0= not ?[ D dec ]? Next end-code +\ : 0<> ( n -- flag ) 0= not ; + + Code u< ( u1 u2 -- flag ) A pop +[[ D A sub 0 # D mov CS ?[ D dec ]? Next end-code + + Code u> ( u1 u2 -- flag ) A D xchg D pop ]] end-code +\ : u> ( u1 u2 -- flag ) swap u< ; + + + +\ *** Block No. 27, Hexblock 1b + +\ comparision words ks 13 sep 88 + Code < ( n1 n2 -- flag ) A pop +[[ [[ D A sub 0 # D mov < ?[ D dec ]? Next end-code + + Code > ( n1 n2 -- flag ) A D xchg D pop ]] end-code + + Code 0> ( n -- flag ) A A xor ]] end-code + +\ : < ( n1 n2 -- flag ) +\ 2dup xor 0< IF drop 0< exit THEN - 0< ; +\ : > ( n1 n2 -- flag ) swap < ; +\ : 0> ( n -- flag ) negate 0< ; + + Code 0< ( n1 n2 -- flag ) + D D or 0 # D mov 0< ?[ D dec ]? Next end-code +\ : 0< ( n1 -- flag ) 8000 and 0<> ; + +\ *** Block No. 28, Hexblock 1c + +\ comparision words ks 27 oct 86 + + Code = ( n1 n2 -- flag ) A pop A D cmp + 0 # D mov 0= ?[ D dec ]? Next end-code +\ : = ( n1 n2 -- flag ) - 0= ; + + Code uwithin ( u1 [low high[ -- flag ) A pop C pop + A C cmp CS ?[ [[ swap 0 # D mov Next ]? + D C cmp CS ?] -1 # D mov Next end-code +\ : uwithin ( u1 [low up[ -- f ) over - -rot - u> ; + + Code case? ( 16b1 16b2 -- 16b1 ff / tf ) A pop A D sub + 0= ?[ D dec ][ A push D D xor ]? Next end-code +\ : case? ( 16b1 16b2 -- 16b1 false / true ) +\ over = dup 0=exit nip ; + + +\ *** Block No. 29, Hexblock 1d + +\ double number comparisons ks 27 oct 86 + + Code d0= ( d - f) A pop A D or + 0= not ?[ 1 # D mov ]? D dec Next end-code +\ : d0= ( d -- flag ) or 0= ; + + : d= ( d1 d2 -- flag ) dnegate d+ d0= ; + +Code d< ( d1 d2 -- flag ) C pop A pop + D A sub A pop -1 # D mov < ?[ [[ swap Next ]? + 0= ?[ C A sub CS ?[ D dec ]? ]? D inc ]] end-code +\ : d< ( d1 d2 -- flag ) +\ rot 2dup - IF > nip nip exit THEN 2drop u< ; + + + + +\ *** Block No. 30, Hexblock 1e + +\ min max umax umin abs dabs extend ks 27 oct 86 + Code min ( n1 n2 -- n3 ) A pop A D sub < ?[ D A add ]? + [[ [[ [[ A D xchg Next end-code + Code max ( n1 n2 -- n3 ) + A pop A D sub dup < not ?] D A add ]] end-code + Code umin ( u1 u2 -- u3 ) + A pop A D sub dup CS ?] D A add ]] end-code + Code umax ( u1 u2 -- u3 ) + A pop A D sub dup CS not ?] D A add ]] end-code + + Code extend ( n -- d ) + A D xchg cwd A push Next end-code + + Code abs ( n -- u ) D D or 0< ?[ D neg ]? Next end-code + + : dabs ( d -- ud ) extend 0=exit dnegate ; + +\ *** Block No. 31, Hexblock 1f + +\\ min max umax umin extend 10Mar8 + +| : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; + +: min ( n1 n2 -- n3 ) 2dup > minimax ; +: max ( n1 n2 -- n3 ) 2dup < minimax ; +: umax ( u1 u2 -- u3 ) 2dup u< minimax ; +: umin ( u1 u2 -- u3 ) 2dup u> minimax ; +: extend ( n -- d ) dup 0< ; +: dabs ( d -- ud ) extend IF dnegate THEN ; +: abs ( n -- u) extend IF negate THEN ; + + + + + + +\ *** Block No. 32, Hexblock 20 + +\ (do (?do endloop bounds ks 30 jan 88 + + Code (do ( limit start -- ) A pop +[[ $80 # A+ xor R dec R dec I inc I inc + I R ) mov R dec R dec A R ) mov R dec R dec + A D sub D R ) mov D pop Next end-code restrict + + Code (?do ( limit start -- ) A pop A D cmp 0= ?] + I ) I add D pop Next end-code restrict + + Code endloop 6 # R add Next end-code restrict + + Code bounds ( start count -- limit start ) + A pop A D xchg D A add A push Next end-code +\ : bounds ( start count -- limit start ) over + swap ; + + +\ *** Block No. 33, Hexblock 21 + +\ (loop (+loop ks 27 oct 86 + + Code (loop R ) word inc +[[ OS not ?[ 4 R D) I mov ]? Next end-code restrict + + Code (+loop D R ) add D pop ]] end-code restrict + +\\ + +| : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; +\ dodo puts "index | limit | adr.of.DO" on return-stack + + : (do ( limit start -- ) over - dodo ; restrict + : (?do ( limit start -- ) over - ?dup IF dodo THEN + r> dup @ + >r drop ; restrict + + +\ *** Block No. 34, Hexblock 22 + +\ loop indices ks 27 oct 86 + + Code I ( -- n ) D push R ) D mov 2 R D) D add Next + end-code +\ : I ( -- n ) r> r> dup r@ + -rot >r >r ; + + Code J ( -- n ) D push 6 R D) D mov 8 R D) D add Next + end-code + + + + + + + + + +\ *** Block No. 35, Hexblock 23 + +\ branch ?branch ks 27 oct 86 + + Code branch +[[ I ) I add Next end-code restrict +\ : branch r> dup @ + >r ; + + Code ?branch D D or D pop 0= not ?] + I inc I inc Next end-code restrict + + + + + + + + + +\ *** Block No. 36, Hexblock 24 + +\ resolve loops and branches ks 02 okt 87 + + : >mark ( -- addr ) here 0 , ; + + : >resolve ( addr -- ) here over - swap ! ; + + : mark 1 ; immediate restrict + : THEN abs 1 ?pairs >resolve ; immediate restrict + : ELSE 1 ?pairs compile branch >mark + swap >resolve -1 ; immediate restrict + + : BEGIN mark -2 2swap ; immediate restrict + +| : (repeat 2 ?pairs resolve REPEAT ; + + : REPEAT compile branch (repeat ; immediate restrict + : UNTIL compile ?branch (repeat ; immediate restrict + +\ *** Block No. 38, Hexblock 26 + +\ Loops ks 27 oct 86 + + : DO compile (do >mark 3 ; immediate restrict + : ?DO compile (?do >mark 3 ; immediate restrict + : LOOP 3 ?pairs compile (loop + compile endloop >resolve ; immediate restrict + : +LOOP 3 ?pairs compile (+loop + compile endloop >resolve ; immediate restrict + + Code LEAVE 6 # R add -2 R D) I mov + I dec I dec I ) I add Next end-code restrict + +\ : LEAVE endloop r> 2- dup @ + >r ; restrict +\ Returnstack: | calladr | index | limit | adr of DO | + + + +\ *** Block No. 39, Hexblock 27 + +\ um* m* * ks 29 jul 87 + + Code um* ( u1 u2 -- ud3 ) + A D xchg C pop C mul A push Next end-code + + Code m* ( n1 n2 -- d3 ) + A D xchg C pop C imul A push Next end-code +\ : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN swap +\ dup 0< IF negate r> not >r THEN um* r> 0=exit dnegate ; + + : * ( n1 n2 - prod ) um* drop ; + + Code 2* ( u -- 2*u ) D shl Next end-code +\ : 2* ( u -- 2*u ) dup + ; + + + +\ *** Block No. 40, Hexblock 28 + +\ um/mod m/mod ks 27 oct 86 + + Code um/mod ( ud1 u2 -- urem uquot ) + D C mov D pop A pop C div A D xchg A push Next + end-code + + Code m/mod ( d1 n2 -- rem quot ) D C mov D pop +Label divide D+ A+ mov C+ A+ xor A pop 0< not + ?[ C idiv [[ swap A D xchg A push Next ]? + C idiv D D or dup 0= not ?] A dec C D add ]] + end-code + +\ : m/mod ( d n -- mod quot ) dup >r +\ abs over 0< IF under + swap THEN um/mod r@ 0< +\ IF negate over IF swap r@ + swap 1- THEN THEN rdrop ; + + +\ *** Block No. 41, Hexblock 29 + +\ /mod division trap 2/ ks 13 sep 88 + + Code /mod ( n1 n2 -- rem quot ) + D C mov A pop cwd A push divide ]] end-code +\ : /mod ( n1 n2 -- rem quot ) over 0< swap m/mod ; + + 0 >label >divINT + + Label divovl Assembler + 4 # S add popf 1 # D- mov ;c: Abort" / overflow" ; + + Code 2/ ( n1 -- n/2 ) D sar Next end-code +\ : 2/ ( n -- n/2 ) 2 / ; + + + + +\ *** Block No. 42, Hexblock 2a + +\ / mod */mod */ u/mod ud/mod ks 27 oct 86 + + : / ( n1 n2 -- quot ) /mod nip ; + + : mod ( n1 n2 -- rem ) /mod drop ; + + : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; + + : */ ( n1 n2 n3 -- quot ) */mod nip ; + + : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; + + : ud/mod ( ud1 u2 -- urem udquot ) + >r 0 r@ um/mod r> swap >r um/mod r> ; + + + +\ *** Block No. 43, Hexblock 2b + +\ cmove cmove> move ks 27 oct 86 + + Code cmove ( from to quan -- ) A I xchg D C mov + W pop I pop D pop rep byte movs A I xchg Next + end-code + + Code cmove> ( from to quan -- ) + A I xchg D C mov W pop I pop D pop +Label moveup C dec C W add C I add C inc + std rep byte movs A I xchg cld Next end-code + + Code move ( from to quan -- ) + A I xchg D C mov W pop I pop D pop +Label domove I W cmp moveup CS ?] + rep byte movs A I xchg Next end-code + + +\ *** Block No. 44, Hexblock 2c + +\ place count ks 27 oct 86 + +| Code (place ( addr len to - len to) A I xchg D W mov + C pop I pop C push W inc domove ]] end-code + + : place ( addr len to -) (place c! ; + + Code count ( addr -- addr+1 len ) D W mov + W ) D- mov 0 # D+ mov W inc W push Next end-code + +\ : move ( from to quan -- ) +\ >r 2dup u< IF r> cmove> exit THEN r> cmove ; +\ : place ( addr len to -- ) over >r rot over 1+ r> move c! ; +\ : count ( adr -- adr+1 len ) dup 1+ swap c@ ; + + + +\ *** Block No. 45, Hexblock 2d + +\ fill erase ks 27 oct 86 + + Code fill ( addr quan 8b -- ) + D A xchg C pop W pop D pop rep byte stos Next + end-code + +\ : fill ( addr quan 8b -- ) swap ?dup +\ IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; + + : erase ( addr quan --) 0 fill ; + + + + + + + +\ *** Block No. 46, Hexblock 2e + +\ here allot , c, pad compile ks 27 oct 86 + + Code here ( -- addr ) D push u' dp U D) D mov Next + end-code +\ : here ( -- addr ) dp @ ; + + Code allot ( n -- ) D u' dp U D) add D pop Next + end-code +\ : allot ( n -- ) dp +! ; + + : , ( 16b -- ) here ! 2 allot ; + : c, ( 8b -- ) here c! 1 allot ; + : pad ( -- addr ) here $42 + ; + : compile r> dup 2+ >r @ , ; restrict + + + +\ *** Block No. 47, Hexblock 2f + +\ input strings ks 23 dez 87 + + Variable #tib #tib off + Variable >tib here >tib ! $50 allot + Variable >in >in off + Variable blk blk off + Variable span span off + + : tib ( -- addr ) >tib @ ; + + : query tib $50 expect span @ #tib ! >in off ; + + + + + + +\ *** Block No. 48, Hexblock 30 + +\ skip scan /string ks 22 dez 87 + + Code skip ( addr len char -- addr1 len1 ) + A D xchg C pop C0= not + ?[ W pop 0=rep byte scas 0= not ?[ W dec C inc ]? + W push ]? C D mov Next end-code + + Code scan ( addr0 len0 char -- addr1 len1 ) + A D xchg C pop C0= not + ?[ W pop 0<>rep byte scas 0= ?[ W dec C inc ]? + W push ]? C D mov Next end-code + + Code /string ( addr0 len0 +n -- addr1 len1 ) + A pop C pop D A sub CS ?[ A D add A A xor ]? + C D add D push A D xchg Next end-code + + +\ *** Block No. 49, Hexblock 31 + +\\ scan skip /string ks 29 jul 87 + + : skip ( addr0 len0 char -- addr1 len1 ) >r + BEGIN dup + WHILE over c@ r@ = WHILE 1- swap 1+ swap + REPEAT rdrop ; + + : scan ( addr0 len0 char -- addr1 len1 ) >r + BEGIN dup + WHILE over c@ r@ - WHILE 1- swap 1+ swap + REPEAT rdrop ; + + : /string ( addr0 len0 +n -- addr1 len1 ) + over umin rot over + -rot - ; + + + +\ *** Block No. 50, Hexblock 32 + +\ capital ks 19 dez 87 + + Create (capital Assembler $61 # A- cmp CS not + ?[ $7B # A- cmp CS not + ?[ $84 # A- cmp 0= ?[ $8E # A- mov ret ]? \ ä + $94 # A- cmp 0= ?[ $99 # A- mov ret ]? \ ö + $81 # A- cmp 0= ?[ $9A # A- mov ]? ret \ ü + ]? $20 # A- xor + ]? ret end-code + + Code capital ( char -- char' ) + A D xchg (capital # call A D xchg Next + end-code + + + + +\ *** Block No. 51, Hexblock 33 + +\ upper ks 03 aug 87 + + Code upper ( addr len -- ) + D C mov W pop D pop C0= not + ?[ [[ W ) A- mov (capital # call + A- W ) mov W inc C0= ?] ]? Next + end-code + +\\ high level, ohne Umlaute + + : capital ( char -- char') + dup Ascii a [ Ascii z 1+ ] Literal + uwithin not ?exit [ Ascii a Ascii A - ] Literal - ; + + : upper ( addr len -- ) + bounds ?DO I c@ capital I c! LOOP ; + +\ *** Block No. 52, Hexblock 34 + +\ (word ks 28 mai 87 + +| Code (word ( char addr0 len0 -- addr1 ) D C mov W pop + A pop >in #) D mov D C sub >= not + ?[ C push D W add 0=rep byte scas W D mov 0= not + ?[ W dec D dec C inc + 0<>rep byte scas 0= ?[ W dec ]? + ]? A pop C A sub A >in #) add + W C mov D C sub 0= not + ?[ D I xchg u' dp U D) W mov C- W ) mov + W inc rep byte movs $20 # W ) byte mov + D I mov u' dp U D) D mov Next +swap ]? C >in #) add + ]? u' dp U D) W mov $2000 # W ) mov W D mov Next + end-code + + +\ *** Block No. 53, Hexblock 35 + +\\ (word ks 27 oct 86 + +| : (word ( char adr0 len0 -- addr ) + rot >r over swap >in @ /string r@ skip + over swap r> scan >r rot over swap - r> 0<> - >in ! + over - here dup >r place bl r@ count + c! r> ; + + + + + + + + + + + +\ *** Block No. 54, Hexblock 36 + +\ source word parse name ks 03 aug 87 + + Variable loadfile loadfile off + + : source ( -- addr len ) blk @ ?dup + IF loadfile @ (block b/blk exit THEN tib #tib @ exit ; + + : word ( char -- addr ) source (word ; + + : parse ( char -- addr len ) >r source >in @ /string + over swap r> scan >r over - dup r> 0<> - >in +! ; + + : name ( -- string ) bl word dup count upper exit ; + + + + +\ *** Block No. 55, Hexblock 37 + +\ state Ascii ," "lit (" " ks 16 sep 88 + Variable state state off + + : Ascii ( char -- n ) bl word 1+ c@ + state @ 0=exit [compile] Literal ; immediate + + : ," Ascii " parse here over 1+ allot place ; + + Code "lit ( -- addr ) D push R ) D mov D W mov + W ) A- mov 0 # A+ mov A inc A R ) add Next + end-code restrict +\ : "lit r> r> under count + even >r >r ; restrict + + : (" "lit ; restrict + + : " compile (" ," align ; immediate restrict + +\ *** Block No. 56, Hexblock 38 + +\ ." ( .( \ \\ hex decimal ks 12 dez 88 + + : (." "lit count type ; restrict + : ." compile (." ," align ; immediate restrict + + : ( Ascii ) parse 2drop ; immediate + : .( Ascii ) parse type ; immediate + + : \ >in @ negate c/l mod >in +! ; immediate + : \\ b/blk >in ! ; immediate + : have ( -- f ) name find nip 0<> ; immediate + : \needs have 0=exit [compile] \ ; + + : hex $10 base ! ; + : decimal &10 base ! ; + + +\ *** Block No. 57, Hexblock 39 + +\ number conversion: digit? accumulate convert ks 08 okt 87 + + : digit? ( char -- digit true/ false ) dup Ascii 9 > + IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and + THEN Ascii 0 - dup base @ u< dup ?exit nip ; + + : accumulate ( +d0 adr digit -- +d1 adr ) swap >r + swap base @ um* drop rot base @ um* d+ r> ; + + : convert ( +d1 addr0 -- +d2 addr2 ) + 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; + + + + + + +\ *** Block No. 58, Hexblock 3a + +\ number conversion ks 29 jun 87 +| : end? ( -- flag ) >in @ 0= ; + +| : char ( addr0 -- addr1 char ) count -1 >in +! ; + +| : previous ( addr0 -- addr0 char ) 1- count ; + +| : punctuation? ( char -- flag ) + Ascii , over = swap Ascii . = or ; +\ : punctuation? ( char -- f ) ?" .," ; + +| : fixbase? ( char -- char false / newbase true ) capital + Ascii $ case? IF $10 true exit THEN + Ascii H case? IF $10 true exit THEN + Ascii & case? IF &10 true exit THEN + Ascii % case? IF 2 true exit THEN false ; + +\ *** Block No. 59, Hexblock 3b + +\ number conversion: dpl ?num ?nonum ?dpl ks 27 oct 86 + + Variable dpl -1 dpl ! + +| : ?num ( flag -- exit if true ) 0=exit + rdrop drop r> IF dnegate THEN rot drop + dpl @ 1+ ?dup ?exit drop true ; + +| : ?nonum ( flag -- exit if true ) 0=exit + rdrop 2drop drop rdrop false ; + +| : ?dpl dpl @ -1 = ?exit 1 dpl +! ; + + + + + +\ *** Block No. 60, Hexblock 3c + +\ number conversion: number? number ks 27 oct 86 + + : number? ( string -- string false / n 0< / d 0> ) + base push >in push dup count >in ! dpl on + 0 >r ( +sign) 0.0 rot end? ?nonum char + Ascii - case? IF rdrop true >r end? ?nonum char THEN + fixbase? IF base ! end? ?nonum char THEN + BEGIN digit? 0= ?nonum + BEGIN accumulate ?dpl end? ?num char digit? + 0= UNTIL previous punctuation? 0= ?nonum + dpl off end? ?num char + REPEAT ; + + : number ( string -- d ) + number? ?dup 0= Abort" ?" 0> ?exit extend ; + + +\ *** Block No. 61, Hexblock 3d + +\ hide reveal immediate restrict ks 18 mär 88 + Variable last last off + + : last' ( -- cfa ) last @ name> ; + +| : last? ( -- false / nfa true) last @ ?dup ; + : hide last? 0=exit 2- @ current @ ! ; + : reveal last? 0=exit 2- current @ ! ; + + : Recursive reveal ; immediate restrict + +| : flag! ( 8b --) + last? IF under c@ or over c! THEN drop ; + + : immediate $40 flag! ; + : restrict $80 flag! ; + +\ *** Block No. 62, Hexblock 3e + +\ clearstack hallot heap heap? ks 27 oct 86 + + Code clearstack u' s0 U D) S mov D pop Next end-code + + : hallot ( quan -- ) + s0 @ over - swap sp@ 2+ dup rot - dup s0 ! + 2 pick over - di move clearstack ei s0 ! ; + + : heap ( -- addr ) s0 @ 6 + ; + : heap? ( addr -- flag ) heap up@ uwithin ; + +| : heapmove ( from -- from ) + dup here over - dup hallot + heap swap cmove heap over - last +! reveal ; + + + +\ *** Block No. 63, Hexblock 3f + +\ Does> ; ks 18 mär 88 + +| Create dodo Assembler + R dec R dec I R ) mov \ push IP + D push 2 W D) D lea \ load parameter address + W ) I mov 3 # I add Next end-code + + dodo Host tdodo ! Target \ target compiler needs to know + + : (;code r> last' ! ; + + : Does> compile (;code $E9 c, ( jmp instruction) + dodo here 2+ - , ; immediate restrict + + + + +\ *** Block No. 64, Hexblock 40 + +\ ?head | alignments ks 19 mär 88 + Variable ?head ?head off + + : | ?head @ ?exit ?head on ; + + : even ( addr -- addr1 ) ; immediate + : align ( -- ) ; immediate + : halign ( -- ) ; immediate +\ machen nichts beim 8088. 8086 koennte etwas schneller werden + + Variable warning warning on + +| : ?exists warning @ 0=exit + last @ current @ (find nip 0=exit + space last @ .name ." exists " ?cr ; + + +\ *** Block No. 65, Hexblock 41 + +\ Create Variable ks 19 mär 88 + + Defer makeview ' 0 Is makeview + + : Create align here makeview , current @ @ , + name c@ dup 1 $20 uwithin not Abort" invalid name" + here last ! 1+ allot align ?exists + ?head @ IF 1 ?head +! dup , \ Pointer to Code + halign heapmove $20 flag! dup dp ! + THEN drop reveal 0 , + ;Code ( -- addr ) D push 2 W D) D lea Next end-code + + : Variable Create 0 , ; + + + + +\ *** Block No. 66, Hexblock 42 + +\ nfa? ks 28 mai 87 + + Code nfa? ( thread cfa -- nfa / false ) + W pop R A mov $1F # C mov + [[ W ) W mov W W or 0= not + ?[[ 2 W D) R- mov C R and 3 R W DI) R lea + $20 # 2 W D) test 0= not ?[ R ) R mov ]? + D R cmp 0= ?] 2 W D) W lea + ]? W D mov A R mov Next end-code + +\\ + + : nfa? ( thread cfa -- nfa / false ) >r + BEGIN @ dup 0= IF rdrop exit THEN + dup 2+ name> r@ = UNTIL 2+ rdrop ; + + +\ *** Block No. 67, Hexblock 43 + +\ >name name> >body .name ks 13 aug 87 + + : >name ( acf -- anf / ff ) voc-link + BEGIN @ dup WHILE 2dup 4 - swap nfa? + ?dup IF -rot 2drop exit THEN REPEAT nip ; + + : (name> ( nfa -- cfa ) count $1F and + even ; + + : name> ( nfa -- cfa ) + dup (name> swap c@ $20 and 0=exit @ ; + + : >body ( cfa -- pfa ) 2+ ; + : body> ( pfa -- cfa ) 2- ; + + : .name ( nfa -- ) ?dup IF dup heap? IF ." | " THEN + count $1F and type ELSE ." ???" THEN space ; + +\ *** Block No. 68, Hexblock 44 + +\ : ; Constant Variable ks 29 oct 86 + + : Create: Create hide current @ context ! 0 ] ; + + : : Create: + ;Code R dec R dec I R ) mov 2 W D) I lea Next + end-code + + : ; 0 ?pairs compile unnest [compile] [ reveal ; + immediate restrict + + : Constant ( n -- ) Create , + ;Code ( -- n ) D push 2 W D) D mov Next end-code + + + + +\ *** Block No. 69, Hexblock 45 + +\ uallot User Alias Defer ks 02 okt 87 + : uallot ( quan -- offset ) even dup udp @ + + $FF u> Abort" Userarea full" udp @ swap udp +! ; + + : User Create 2 uallot c, + ;Code ( -- addr ) D push 2 W D) D- mov + 0 # D+ mov U D add Next end-code + + : Alias ( cfa -- ) + Create last @ dup c@ $20 and + IF -2 allot ELSE $20 flag! THEN (name> ! ; + +| : crash true Abort" crash" ; + + : Defer Create ['] crash , + ;Code 2 W D) W mov W ) jmp end-code + +\ *** Block No. 70, Hexblock 46 + +\ vp current context also toss ks 02 okt 87 + + Create vp $10 allot + Variable current + + : context ( -- adr ) vp dup @ + 2+ ; + +| : thru.vocstack ( -- from to ) vp 2+ context ; + +\ "Only Forth also Assembler" gives +\ vp: countword = 6 | Root | Forth | Assembler | + + : also vp @ &10 > Error" Vocabulary stack full" + context @ 2 vp +! context ! ; + + : toss vp @ 0=exit -2 vp +! ; + +\ *** Block No. 71, Hexblock 47 + +\ Vocabulary Forth Only Onlyforth definitions ks 19 jun 88 + : Vocabulary Create 0 , 0 , here voc-link @ , voc-link ! + Does> context ! ; +\ | Name | Code | Thread | Coldthread | Voc-link | + + Vocabulary Forth +Host h' Transient 8 + @ T h' Forth 8 + H ! +Target Forth also definitions + + Vocabulary Root + + : Only vp off Root also ; + + : Onlyforth Only Forth also definitions ; + + : definitions context @ current ! ; + +\ *** Block No. 72, Hexblock 48 + +\ order vocs words ks 19 jun 88 +| : init-vocabularys voc-link @ + BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; +| : .voc ( adr -- ) @ 2- >name .name ; + + : order vp 4+ context over umax + DO I .voc -2 +LOOP 2 spaces current .voc ; + + : vocs voc-link + BEGIN @ ?dup WHILE dup 6 - >name .name REPEAT ; + + : words ( -- ) [compile] Ascii capital >r context @ + BEGIN @ dup stop? 0= and + WHILE ?cr dup 2+ r@ bl = over 1+ c@ r@ = or + IF .name space ELSE drop THEN + REPEAT drop rdrop ; + +\ *** Block No. 73, Hexblock 49 + +\ (find found ks 09 jul 87 +| : found ( nfa -- cfa n ) dup c@ >r + (name> r@ $20 and IF @ THEN + -1 r@ $80 and IF 1- THEN + r> $40 and IF negate THEN ; + + Code (find ( string thread -- string ff / anf tf ) + D I xchg W pop D push W ) A- mov W inc + W D mov 0 # C+ mov $1F # A+ mov A+ A- and + [[ I ) I mov I I or 0= not + ?[[ 2 I D) C- mov A+ C- and A- C- cmp dup 0= ?] + I push D W mov 3 # I add + 0=rep byte cmps I pop 0= ?] + 3 # I add I W mov -1 # D mov + ][ D W mov 0 # D mov ]? W dec I pop W push Next + end-code + +\ *** Block No. 74, Hexblock 4a + +\\ -text (find ks 02 okt 87 + + : -text ( adr1 len adr2 -- 0< 1<2 / 0= 1=2 / 0> 1>2 ) + over bounds + DO drop count I c@ - dup IF LEAVE THEN LOOP nip ; + + : (find ( string thread -- str false / NFA +n ) + over c@ $1F and >r @ + BEGIN dup WHILE dup @ swap 2+ dup c@ $1F and r@ = + IF dup 1+ r@ 4 pick 1+ -text + 0= IF rdrop -rot drop exit + THEN THEN drop + REPEAT rdrop ; + + + + +\ *** Block No. 75, Hexblock 4b + +\ find ' [compile] ['] nullstring? ks 29 oct 86 + + : find ( string -- acf n / string false ) + context dup @ over 2- @ = IF 2- THEN + BEGIN under @ (find IF nip found exit THEN + swap 2- dup vp = UNTIL drop false ; + + : ' ( -- cfa ) name find ?exit Error" ?" ; + + : [compile] ' , ; immediate restrict + + : ['] ' [compile] Literal ; immediate restrict + + : nullstring? ( string -- string false / true ) + dup c@ 0= dup 0=exit nip ; + + +\ *** Block No. 76, Hexblock 4c + +\ interpreter ks 07 dez 87 + + Defer notfound + +| : interpreter ( string -- ) find ?dup + IF 1 and IF execute exit THEN + Error" compile only" + THEN number? ?exit notfound ; + +| : compiler ( string -- ) find ?dup + IF 0> IF execute exit THEN , exit THEN + number? ?dup IF 0> IF swap [compile] Literal THEN + [compile] Literal exit + THEN notfound ; + + + +\ *** Block No. 77, Hexblock 4d + +\ compiler [ ] ks 16 sep 88 + + : no.extensions ( string -- ) + state @ IF Abort" ?" THEN Error" ?" ; + + ' no.extensions Is notfound + + Defer parser ( string -- ) ' interpreter Is parser + + : interpret + BEGIN ?stack name nullstring? IF aborted off exit THEN + parser REPEAT ; + + : [ ['] interpreter Is parser state off ; immediate + + : ] ['] compiler Is parser state on ; + +\ *** Block No. 78, Hexblock 4e + +\ Is ks 07 dez 87 + + : (is r> dup 2+ >r @ ! ; + +| : def? ( cfa -- ) + @ [ ' notfound @ ] Literal - Abort" not deferred" ; + + : Is ( addr -- ) ' dup def? >body + state @ IF compile (is , exit THEN ! ; immediate + + + + + + + + +\ *** Block No. 79, Hexblock 4f + +\ ?stack ks 01 okt 87 + +| : stackfull ( -- ) depth $20 > Abort" tight stack" + reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN + true Abort" dictionary full" ; + + Code ?stack u' dp U D) A mov S A sub CS + ?[ $100 # A add CS ?[ ;c: stackfull ; Assembler ]? ]? + u' s0 U D) A mov A inc A inc S A sub + CS not ?[ Next ]? ;c: true Abort" stack empty" ; + +\ : ?stack sp@ here - $100 u< IF stackfull THEN +\ sp@ s0 @ u> Abort" stack empty" ; + + + + +\ *** Block No. 80, Hexblock 50 + +\ .status push load ks 29 oct 86 + +| Create: pull r> r> ! ; + : push ( addr -- ) + r> swap dup >r @ >r pull >r >r ; restrict + + Defer .status ' noop Is .status + + : (load ( blk offset -- ) isfile@ >r + loadfile @ >r fromfile @ >r blk @ >r >in @ >r + >in ! blk ! isfile@ loadfile ! .status interpret + r> >in ! r> blk ! r> fromfile ! r> loadfile ! + r> isfile ! ; + + : load ( blk -- ) ?dup 0=exit 0 (load ; + + +\ *** Block No. 81, Hexblock 51 + +\ +load thru +thru --> rdepth depth ks 26 jul 87 + + : +load ( offset -- ) blk @ + load ; + + : thru ( from to -- ) 1+ swap DO I load LOOP ; + + : +thru ( off0 off1 -- ) 1+ swap DO I +load LOOP ; + + : --> 1 blk +! >in off .status ; immediate + + : rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; + + : depth ( -- +n ) sp@ s0 @ swap - 2/ ; + + + + +\ *** Block No. 82, Hexblock 52 + +\ prompt quit ks 16 sep 88 + + : (prompt .status state @ IF cr ." ] " exit THEN + aborted @ 0= IF ." ok" THEN cr ; + + Defer prompt ' (prompt Is prompt + + : (quit BEGIN prompt query interpret REPEAT ; + + Defer 'quit ' (quit Is 'quit + + : quit r0 @ rp! [compile] [ blk off 'quit ; + +\ : classical cr .status state @ +\ IF ." C> " exit THEN ." I> " ; + + +\ *** Block No. 83, Hexblock 53 + +\ end-trace abort ks 26 jul 87 + + : standardi/o [ output ] Literal output 4 cmove ; + + Code end-trace next-link # W mov $AD # A- mov + $FF97 # C mov [[ W ) W mov W W or 0= not + ?[[ A- -4 W D) mov C -3 W D) mov + ]]? lods A W xchg W ) jmp end-code + + Defer 'abort ' noop Is 'abort + + : abort end-trace clearstack 'abort standardi/o quit ; + + + + + +\ *** Block No. 84, Hexblock 54 + +\ (error Abort" Error" ks 16 sep 88 + Variable scr 1 scr ! + Variable r# r# off + + : (error ( string -- ) rdrop r> aborted ! standardi/o + space here .name count type space ?cr + blk @ ?dup IF scr ! >in @ r# ! THEN quit ; + ' (error errorhandler ! + + : (abort" "lit swap IF >r clearstack r> + errorhandler perform exit THEN drop ; restrict + +| : (error" "lit swap IF errorhandler perform exit THEN + drop ; restrict + + + +\ *** Block No. 85, Hexblock 55 + +\ -trailing space spaces ks 16 sep 88 + + : Abort" compile (abort" ," align ; immediate restrict + : Error" compile (error" ," align ; immediate restrict + + $20 Constant bl + + : -trailing ( addr n1 -- addr n2) + dup 0 ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; + + : space bl emit ; + : spaces ( u -- ) 0 ?DO space LOOP ; + + + + + +\ *** Block No. 86, Hexblock 56 + +\ hold <# #> sign # #s ks 29 dez 87 + +| : hld ( -- addr) pad 2- ; + + : hold ( char -- ) -1 hld +! hld @ c! ; + + : <# hld hld ! ; + + : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; + + : sign ( n -- ) 0< not ?exit Ascii - hold ; + + : # ( +d1 -- +d2) + base @ ud/mod rot dup 9 > 7 and + Ascii 0 + hold ; + + : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; + +\ *** Block No. 87, Hexblock 57 + +\ print numbers .s ks 07 feb 89 + + : d.r ( d +n -- ) -rot under dabs <# #s rot sign #> + rot over max over - spaces type ; + : d. ( d -- ) 0 d.r space ; + + : .r ( n +n -- ) swap extend rot d.r ; + : . ( n -- ) extend d. ; + + : u.r ( u +n -- ) 0 swap d.r ; + : u. ( u -- ) 0 d. ; + + : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; + + + + +\ *** Block No. 88, Hexblock 58 + +\ list c/l l/s ks 19 mär 88 + + &64 Constant c/l \ Screen line length + &16 Constant l/s \ lines per screen + + : list ( scr -- ) dup capacity u< + IF scr ! ." Scr " scr @ . + ." Dr " drv . isfile@ .file + l/s 0 DO cr I 2 .r space scr @ block + I c/l * + c/l -trailing type + LOOP cr exit + THEN 9 ?diskerror ; + + + + + +\ *** Block No. 89, Hexblock 59 + +\ multitasker primitives ks 29 oct 86 + + Code pause D push I push R push + S 6 U D) mov 2 U D) U add 4 # U add U jmp + end-code + + : lock ( addr -- ) + dup @ up@ = IF drop exit THEN + BEGIN dup @ WHILE pause REPEAT up@ swap ! ; + + : unlock ( addr -- ) dup lock off ; + + Label wake Assembler U pop 2 # U sub A pop + popf 6 U D) S mov R pop I pop D pop Next + end-code + $E9 4 * >label >taskINT + +\ *** Block No. 90, Hexblock 5a + +\\ Struktur der Blockpuffer ks 04 jul 87 + + 0 : link zum naechsten Puffer + 2 : file 0 = direct access + -1 = leer, + sonst adresse eines file control blocks + 4 : blocknummer + 6 : statusflags Vorzeichenbit kennzeichnet update + 8 : Data ... 1 Kb ... + + + + + + + + +\ *** Block No. 91, Hexblock 5b + +\ buffer mechanism ks 04 okt 87 + + Variable isfile isfile off \ addr of file control block + Variable fromfile fromfile off \ fcb in kopieroperationen + + Variable prev prev off \ Listhead +| Variable buffers buffers off \ Semaphor + + $408 Constant b/buf \ physikalische Groesse + $400 Constant b/blk \ bytes/block + + Defer r/w \ physikalischer Diskzugriff + Variable error# error# off \ Nummer des letzten Fehlers + Defer ?diskerror \ Fehlerbehandlung + + + +\ *** Block No. 92, Hexblock 5c + +\ (core? ks 28 mai 87 + + Code (core? ( blk file -- dataaddr / blk file ) + A pop A push D D or 0= ?[ u' offset U D) A add ]? + prev #) W mov 2 W D) D cmp 0= + ?[ 4 W D) A cmp 0= + ?[ 8 W D) D lea A pop ' exit @ # jmp ]? ]? + [[ [[ W ) C mov C C or 0= ?[ Next ]? + C W xchg 4 W D) A cmp 0= ?] 2 W D) D cmp 0= ?] + W ) A mov prev #) D mov D W ) mov W prev #) mov + 8 W D) D lea C W mov A W ) mov A pop + ' exit @ # jmp + end-code + + + + +\ *** Block No. 93, Hexblock 5d + +\\ (core? ks 31 oct 86 + +| : this? ( blk file bufadr -- flag ) + dup 4+ @ swap 2+ @ d= ; + + .( (core?: offset is handled differently in code! ) + +| : (core? ( blk file -- dataaddr / blk file ) + BEGIN over offset @ + over prev @ this? + IF rdrop 2drop prev @ 8 + exit THEN + 2dup >r offset @ + >r prev @ + BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN + dup r> r> 2dup >r >r rot this? 0= + WHILE nip REPEAT + dup @ rot ! prev @ over ! prev ! rdrop rdrop + REPEAT ; + +\ *** Block No. 94, Hexblock 5e + +\ backup emptybuf readblk ks 23 jul 87 + +| : backup ( bufaddr -- ) dup 6+ @ 0< + IF 2+ dup @ 1+ \ buffer empty if file = -1 + IF BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w + WHILE 1 ?diskerror REPEAT + THEN 4+ dup @ $7FFF and over ! THEN + drop ; + + : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; + +| : readblk ( blk file addr -- blk file addr ) + dup emptybuf >r + BEGIN 2dup 0= offset @ and + + over r@ 8 + -rot 1 r/w + WHILE 2 ?diskerror REPEAT r> ; + +\ *** Block No. 95, Hexblock 5f + +\ take mark updates? full? core? ks 04 jul 87 + +| : take ( -- bufaddr) prev + BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL + buffers lock dup backup ; + +| : mark ( blk file bufaddr -- blk file ) 2+ >r + 2dup r@ ! over 0= offset @ and + r@ 2+ ! + r> 4+ off buffers unlock ; + +| : updates? ( -- bufaddr / flag) + prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; + + : core? ( blk file -- addr /false ) (core? 2drop false ; + + + +\ *** Block No. 96, Hexblock 60 + +\ block & buffer manipulation ks 01 okt 87 + + : (buffer ( blk file -- addr ) + BEGIN (core? take mark REPEAT ; + + : (block ( blk file -- addr ) + BEGIN (core? take readblk mark REPEAT ; + + Code isfile@ ( -- addr ) + D push isfile #) D mov Next end-code +\ : isfile@ ( -- addr ) isfile @ ; + + : buffer ( blk -- addr ) isfile@ (buffer ; + + : block ( blk -- addr ) isfile@ (block ; + + +\ *** Block No. 97, Hexblock 61 + +\ block & buffer manipulation ks 02 okt 87 + + : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; + + : save-buffers buffers lock + BEGIN updates? ?dup WHILE backup REPEAT buffers unlock ; + + : empty-buffers buffers lock prev + BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; + + : flush file-link + BEGIN @ ?dup WHILE dup fclose REPEAT + save-buffers empty-buffers ; + + + + +\ *** Block No. 98, Hexblock 62 + +\ Allocating buffers ks 31 oct 86 + $10000 Constant limit Variable first + + : allotbuffer ( -- ) + first @ r0 @ - b/buf 2+ u< ?exit + b/buf negate first +! first @ dup emptybuf + prev @ over ! prev ! ; + + : freebuffer ( -- ) first @ limit b/buf - u< + IF first @ backup prev + BEGIN dup @ first @ - WHILE @ REPEAT + first @ @ swap ! b/buf first +! THEN ; + + : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; + +| : init-buffers prev off limit first ! all-buffers ; + +\ *** Block No. 99, Hexblock 63 + +\ endpoints of forget uh 27 apr 88 + +| : |? ( nfa -- flag ) c@ $20 and ; + +| : forget? ( adr nfa -- flag ) \ code in heap or above adr ? + name> under 1+ u< swap heap? or ; + +| : endpoint ( addr sym thread -- addr sym' ) + BEGIN BEGIN @ 2 pick over u> IF drop exit THEN + dup heap? UNTIL dup >r 2+ dup |? + IF >r over r@ forget? IF r@ (name> >body umax THEN + rdrop THEN r> + REPEAT ; + +| : endpoints ( addr -- addr symb ) heap voc-link @ + BEGIN @ ?dup WHILE dup >r 4- endpoint r> REPEAT ; + +\ *** Block No. 100, Hexblock 64 + +\ remove, -words, -tasks ks 30 apr 88 + : remove ( dic sym thread -- dic sym ) + BEGIN dup @ ?dup \ unlink forg. words + WHILE dup heap? + IF 2 pick over u> ELSE 3 pick over 1+ u< THEN + IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; + +| : remove-words ( dic sym -- dic sym ) voc-link + BEGIN @ ?dup WHILE dup >r 4- remove r> REPEAT ; + +| : >up 2+ dup @ 2+ + ; + +| : remove-tasks ( dic -- ) up@ + BEGIN dup >up up@ - WHILE 2dup >up swap here uwithin + IF dup >up >up over - 2- 2- over 2+ ! ELSE >up THEN + REPEAT 2drop ; + +\ *** Block No. 101, Hexblock 65 + +\ remove-vocs trim ks 31 oct 86 + +| : remove-vocs ( dic symb -- dic symb ) + voc-link remove thru.vocstack + DO 2dup I @ -rot uwithin + IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP + 2dup current @ -rot uwithin 0=exit + [ ' Forth 2+ ] Literal current ! ; + + Defer custom-remove ' noop Is custom-remove + + : trim ( dic symb -- ) next-link remove + over remove-tasks remove-vocs remove-words remove-files + custom-remove heap swap - hallot dp ! last off ; + + + +\ *** Block No. 102, Hexblock 66 + +\ deleting words from dict. ks 02 okt 87 + + : clear here dup up@ trim dp ! ; + + : (forget ( adr -- ) + dup heap? Abort" is symbol" endpoints trim ; + + : forget ' dup [ dp ] Literal @ u< Abort" protected" + >name dup heap? IF name> ELSE 4- THEN (forget ; + + : empty [ dp ] Literal @ up@ trim + [ udp ] Literal @ udp ! ; + + + + + +\ *** Block No. 103, Hexblock 67 + +\ save bye stop? ?cr ks 1UH 26sep88 + + : save here up@ trim up@ origin $100 cmove + voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL ; + + $1B Constant #esc + +| : end? key #esc case? 0= + IF #cr case? 0= IF 3 ( Ctrl-C ) - ?exit THEN THEN + true rdrop ; + + : stop? ( -- flag ) key? IF end? end? THEN false ; + + : ?cr col c/l u> 0=exit cr ; + + + +\ *** Block No. 104, Hexblock 68 + +\ in/output structure ks 31 oct 86 + +| : Out: Create dup c, 2+ Does> c@ output @ + perform ; + + : Output: Create: Does> output ! ; +0 Out: emit Out: cr Out: type Out: del + Out: page Out: at Out: at? drop + + : row ( -- row ) at? drop ; + : col ( -- col ) at? nip ; + +| : In: Create dup c, 2+ Does> c@ input @ + perform ; + + : Input: Create: Does> input ! ; +0 In: key In: key? In: decode In: expect drop + + +\ *** Block No. 105, Hexblock 69 + +\ Alias only definitionen ks 31 oct 86 + + Root definitions + + : seal [ ' Root >body ] Literal off ; \ "erases" Root Vocab. + + ' Only Alias Only + ' Forth Alias Forth + ' words Alias words + ' also Alias also + ' definitions Alias definitions + + Forth definitions + + + + +\ *** Block No. 106, Hexblock 6a + +\ 'restart 'cold ks 01 sep 88 + + Defer 'restart ' noop Is 'restart + +| : (restart ['] (quit Is 'quit 'restart + [ errorhandler ] Literal @ errorhandler ! + ['] noop Is 'abort end-trace clearstack + standardi/o interpret quit ; + + Defer 'cold ' noop Is 'cold + +| : (cold origin up@ $100 cmove $80 count + $50 umin >r tib r@ move r> #tib ! >in off blk off + init-vocabularys init-buffers flush 'cold + Onlyforth page &24 spaces logo count type cr (restart ; + + +\ *** Block No. 107, Hexblock 6b + +\ (boot ks 11 mär 89 + + Label #segs ( -- R: seg ) Assembler + C: seg ' limit >body #) R mov R R or 0= not + ?[ 4 # C- mov R C* shr R inc ret ]? + $1000 # R mov ret + end-code + + Label (boot Assembler cli cld A A xor A D: mov + #segs # call C: D mov D R add R E: mov + $200 # C mov 0 # I mov I W mov rep movs + wake # >taskINT #) mov C: >taskINT 2+ #) mov + divovl # >divINT #) mov C: >divINT 2+ #) mov ret + end-code + + + +\ *** Block No. 108, Hexblock 6c + +\ restart ks 09 mär 89 + + Label warmboot here >restart 2+ - >restart ! Assembler + (boot # call + here ' (restart >body # I mov + Label bootsystem + C: A mov A E: mov A D: mov A S: mov + s0 #) U mov 6 # U add u' s0 U D) S mov + D pop u' r0 U D) R mov sti Next + end-code + + Code restart here 2- ! end-code + + + + + +\ *** Block No. 109, Hexblock 6d + +\ bye ks 11 mär 89 + + Variable return_code return_code off + +| Code (bye cli A A xor A E: mov #segs # call + C: D mov D R add R D: mov 0 # I mov I W mov + $200 # C mov rep movs sti \ restore interrupts + $4C # A+ mov C: seg return_code #) A- mov + $21 int warmboot # call + end-code + + : bye flush empty page (bye ; + + + + + +\ *** Block No. 110, Hexblock 6e + +\ cold ks 09 mär 89 + + here >cold 2+ - >cold ! Assembler + (boot # call C: A mov A D: mov A E: mov + #segs # call $41 # R add \ another k for the ints + $4A # A+ mov $21 int \ alloc memory + CS ?[ $10 # return_code #) byte mov ' (bye @ # jmp ]? + here s0 #) W mov 6 # W add origin # I mov $20 # C mov + rep movs ' (cold >body # I mov bootsystem # jmp + end-code + + Code cold here 2- ! end-code + + + + + +\ *** Block No. 111, Hexblock 6f + +\ System patchup ks 16 sep 88 + + 1 &35 +thru \ MS-DOS interface + + : forth-83 ; \ last word in Dictionary + + 0 ' limit >body ! $DFF6 s0 ! $E77C r0 ! + s0 @ s0 2- ! here dp ! + + Host tudp @ Target udp ! + Host tvoc-link @ Target voc-link ! + Host tnext-link @ Target next-link ! + Host tfile-link @ Target Forth file-link ! + Host T move-threads H + save-buffers cr .( unresolved: ) .unresolved + + +\ *** Block No. 112, Hexblock 70 + +\ lc@ lc! l@ l! special 8088 operators ks 27 oct 86 + + Code lc@ ( seg:addr -- 8b ) D: pop D W mov + W ) D- mov 0 # D+ mov C: A mov A D: mov Next + end-code + + Code lc! ( 8b seg:addr -- ) D: pop A pop D W mov + A- W ) mov C: A mov A D: mov D pop Next end-code + + Code l@ ( seg:addr -- 16b ) D: pop D W mov + W ) D mov C: A mov A D: mov Next end-code + + Code l! ( 16b seg:addr -- ) D: pop A pop D W mov + A W ) mov C: A mov A D: mov D pop Next end-code + + + +\ *** Block No. 113, Hexblock 71 + +\ ltype lmove special 8088 operators ks 11 dez 87 + + : ltype ( seg:addr len -- ) + 0 ?DO 2dup I + lc@ emit LOOP 2drop ; + + Code lmove ( from.seg:addr to.seg:addr quan -- ) + A I xchg D C mov W pop E: pop + I pop D: pop I W cmp CS + ?[ rep byte movs + ][ C dec C W add C I add C inc + std rep byte movs cld + ]? A I xchg C: A mov A E: mov + A D: mov D pop Next end-code + + + + +\ *** Block No. 114, Hexblock 72 + +\ BDOS keyboard input ks 16 sep 88 +\ es muss wirklich so kompliziert sein, da sonst kein ^C und ^P + +| Variable newkey newkey off + + Code (key@ ( -- 8b ) D push newkey #) D mov D+ D+ or + 0= ?[ $7 # A+ mov $21 int A- D- mov ]? + 0 # D+ mov D+ newkey 1+ #) mov Next + end-code + + Code (key? ( -- f ) D push newkey #) D mov D+ D+ or + 0= ?[ -1 # D- mov 6 # A+ mov $21 int 0= + ?[ 0 # D+ mov + ][ -1 # A+ mov A newkey #) mov -1 # D+ mov + ]? ]? D+ D- mov Next + end-code + +\ *** Block No. 115, Hexblock 73 + +\ empty-keys (key ks 16 sep 88 + + Code empty-keys $C00 # A mov $21 int + 0 # newkey 1+ #) byte mov Next end-code + + : (key ( -- 16b ) BEGIN pause (key? UNTIL + (key@ ?dup ?exit (key? IF (key@ negate exit THEN 0 ; + + + + + + + + + + +\ *** Block No. 116, Hexblock 74 + +\\ BIOS keyboard input ks 16 sep 88 + + Code (key@ ( -- 8b ) D push A+ A+ xor $16 int + A- D- xchg 0 # D+ mov Next end-code + + Code (key? ( -- f ) D push 1 # A+ mov D D xor + $16 int 0= not ?[ D dec ]? Next end-code + + Code empty-keys $C00 # A mov $21 int Next end-code + + : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; + +\ mit diesen Keytreibern sind die Funktionstasten nicht +\ mehr durch ANSI.SYS Sequenzen vorbelegt. + + + +\ *** Block No. 117, Hexblock 75 + +\ (decode expect ks 16 sep 88 + + 7 Constant #bel 8 Constant #bs + 9 Constant #tab $A Constant #lf + $D Constant #cr + + : (decode ( addr pos1 key -- addr pos2 ) + #bs case? IF dup 0=exit del 1- exit THEN + #cr case? IF dup span ! space exit THEN + >r 2dup + r@ swap c! r> emit 1+ ; + + : (expect ( addr len1 -- ) span ! 0 + BEGIN dup span @ u< WHILE key decode REPEAT 2drop ; + + Input: keyboard [ here input ! ] + (key (key? (decode (expect [ drop + +\ *** Block No. 118, Hexblock 76 + +\ MSDOS character output ks 29 jun 87 + + Code charout ( char -- ) $FF # D- cmp 0= ?[ D- dec ]? + 6 # A+ mov $21 int D pop ' pause # W mov W ) jmp + end-code + + &80 Constant c/row &25 Constant c/col + + : (emit ( char -- ) dup bl u< IF $80 or THEN charout ; + : (cr #cr charout #lf charout ; + : (del #bs charout bl charout #bs charout ; + : (at 2drop ; + : (at? 0 0 ; + : (page c/col 0 DO cr LOOP ; + + + +\ *** Block No. 119, Hexblock 77 + +\ MSDOS character output ks 7 may 85 + + : bell #bel charout ; + + : tipp ( addr len -- ) bounds ?DO I c@ emit LOOP ; + + Output: display [ here output ! ] + (emit (cr tipp (del (page (at (at? [ drop + + + + + + + + + +\ *** Block No. 120, Hexblock 78 + +\ MSDOS printer I/O Port access ks 09 aug 87 + + Code lst! ( 8b -- ) $5 # A+ mov $21 int D pop Next + end-code + + Code pc@ ( port -- 8b ) + D byte in A- D- mov D+ D+ xor Next + end-code + + Code pc! ( 8b port -- ) + A pop D byte out D pop Next + end-code + + + + + +\ *** Block No. 121, Hexblock 79 + +\ zero terminated strings ks 09 aug 87 + + : counted ( asciz -- addr len ) + dup -1 0 scan drop over - ; + + : >asciz ( string addr -- asciz ) 2dup >r - + IF count r@ place r@ THEN 0 r> count + c! 1+ ; + + + + : asciz ( -- asciz ) name here >asciz ; + + + + + + +\ *** Block No. 122, Hexblock 7a + +\ Disk capacities ks 08 aug 88 + Vocabulary Dos Dos also definitions + + 6 Constant #drives + + Create capacities $4B0 , $4B0 , $1B31 , $1B31 , $1B0F , 0 , + +| Code ?capacity ( +n -- cap ) D shl capacities # W mov + D W add W ) D mov Next end-code + + + + + + + + +\ *** Block No. 123, Hexblock 7b + +\ MS-dos disk handlers direct access ks 31 jul 87 + +| Code block@ ( addr blk drv -- ff ) + D- A- mov D pop C pop R push U push + I push C R mov 2 # C mov D shl $25 int + Label end-r/w I pop I pop U pop R pop 0 # D mov + CS ?[ D+ A+ mov A error# #) mov D dec ]? Next + end-code + +| Code block! ( addr blk drv -- ff ) D- A- mov D pop + C pop R push U push I push C R mov 2 # C mov + D shl $26 int end-r/w # jmp + end-code + + + + +\ *** Block No. 124, Hexblock 7c + +\ MS-dos disk handlers direct access ks cas 18jul20 + +| : ?drive ( +n -- +n ) dup #drives u< ?exit + Error" beyond drive capacity" ; + + : /drive ( blk1 -- blk2 drive ) 0 swap #drives 0 + DO dup I ?capacity under u< IF drop LEAVE THEN + - swap 1+ swap LOOP swap ; + + : blk/drv ( -- capacity ) drv ?capacity ; + + Forth definitions + + : >drive ( blk1 +n -- blk2 ) ?drive + 0 swap drv 2dup u> dup >r 0= IF swap THEN + ?DO I ?capacity + LOOP r> IF negate THEN - ; + +\ *** Block No. 125, Hexblock 7d + +\ MS-DOS file access ks 18 mär 88 + Dos definitions + +| Variable fcb fcb off \ last fcb accessed +| Variable prevfile \ previous active file + + &30 Constant fnamelen \ default length in FCB + + Create filename &62 allot \ max 60 + count + null + + Variable attribut 7 attribut ! \ read-only, hidden, system + + + + + + +\ *** Block No. 126, Hexblock 7e + +\ MS-DOS disk errors ks cas 18jul20 + +| : .error# ." error # " base push decimal error# @ . ; + +| : .ferrors error# @ &18 case? IF 2 THEN + 1 case? Abort" file exists" + 2 case? Abort" file not found" + 3 case? Abort" path not found" + 4 case? Abort" too many open files" + 5 case? Abort" no access" + 9 case? Abort" beyond end of file" + &15 case? Abort" illegal drive" + &16 case? Abort" current directory" + &17 case? Abort" wrong drive" + drop ." Disk" .error# abort ; + + +\ *** Block No. 127, Hexblock 7f + +\ MS-DOS disk errors ks cas 18jul20 + + : (diskerror ( *f -- ) ?dup 0=exit + fcb @ IF error# ! .ferrors exit THEN + input push output push standardi/o 1- + IF ." read" ELSE ." write" THEN + .error# ." retry? (y/n)" + key cr capital Ascii Y = not Abort" aborted" ; + + ' (diskerror Is ?diskerror + + + + + + + +\ *** Block No. 128, Hexblock 80 + +\ ~open ~creat ~close ks 04 aug 87 + + Code ~open ( asciz mode -- handle ff / err# ) + A D xchg $3D # A+ mov + Label >open D pop $21 int A D xchg + CS not ?[ D push 0 # D mov ]? Next + end-code + + Code ~creat ( asciz attribut -- handle ff / err# ) + D C mov $3C # A+ mov >open ]] end-code + + Code ~close ( handle -- ) D R xchg + $3E # A+ mov $21 int R D xchg D pop Next + end-code + + + +\ *** Block No. 129, Hexblock 81 + +\ ~first ~unlink ~select ~disk? ks 04 aug 87 + + Code ~first ( asciz attr -- err# ) + D C mov D pop $4E # A+ mov + [[ $21 int 0 # D mov CS ?[ A D xchg ]? Next + end-code + + Code ~unlink ( asciz -- err# ) $41 # A+ mov ]] end-code + + Code ~select ( n -- ) + $E # A+ mov $21 int D pop Next end-code + + Code ~disk? ( -- n ) D push $19 # A+ mov + $21 int A- D- mov 0 # D+ mov Next + end-code + + +\ *** Block No. 130, Hexblock 82 + +\ ~next ~dir ks 04 aug 87 + + Code ~next ( -- err# ) D push $4F # A+ mov + $21 int 0 # D mov CS ?[ A D xchg ]? Next + end-code + + Code ~dir ( addr drive -- err# ) I W mov + I pop $47 # A+ mov $21 int W I mov + 0 # D mov CS ?[ A D xchg ]? Next + end-code + + + + + + + +\ *** Block No. 131, Hexblock 83 + +\ MS-DOS file control Block cas 19jun20 + +| : Fcbytes ( n1 len -- n2 ) Create over c, + + Does> ( fcbaddr -- fcbfield ) c@ + ; + +\ first field for file-link +2 1 Fcbytes f.no \ must be first field + 2 Fcbytes f.handle + 2 Fcbytes f.date + 2 Fcbytes f.time + 4 Fcbytes f.size + fnamelen Fcbytes f.name Constant b/fcb + +b/fcb Host ' tb/fcb >body ! + Target Forth also Dos also definitions + + +\ *** Block No. 132, Hexblock 84 + +\ (.file fname fname! ks 10 okt 87 + + : fname! ( string fcb -- ) f.name >r count + dup fnamelen < not Abort" file name too long" r> place ; + +| : filebuffer? ( fcb -- fcb bufaddr / fcb ff ) + prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; + +| : flushfile ( fcb -- ) + BEGIN filebuffer? ?dup + WHILE dup backup emptybuf REPEAT drop ; + + : fclose ( fcb -- ) ?dup 0=exit + dup f.handle @ ?dup 0= IF drop exit THEN + over flushfile ~close f.handle off ; + + +\ *** Block No. 133, Hexblock 85 + +\ (.file fname fname! ks 18 mär 88 + +| : getsize ( -- d ) [ $80 &26 + ] Literal 2@ swap ; + + : (fsearch ( string -- asciz *f ) + filename >asciz dup attribut @ ~first ; + + Defer fsearch ( string -- asciz *f ) + + ' (fsearch Is fsearch + +\ graceful behaviour if file does not exist +| : ?notfound ( f* -- ) ?dup 0=exit last' @ [fcb] = + IF hide file-link @ @ file-link ! prevfile @ setfiles + last @ 4 - dp ! last off filename count here place + THEN ?diskerror ; + +\ *** Block No. 134, Hexblock 86 + +\ freset fseek ks 19 mär 88 + + : freset ( fcb -- ) ?dup 0=exit + dup f.handle @ ?dup IF ~close THEN dup >r + f.name fsearch ?notfound getsize r@ f.size 2! + [ $80 &22 + ] Literal @ r@ f.time ! + [ $80 &24 + ] Literal @ r@ f.date ! + 2 ~open ?diskerror r> f.handle ! ; + + + Code fseek ( dfaddr fcb -- ) + D W mov u' f.handle W D) W mov W W or 0= + ?[ ;c: dup freset fseek ; Assembler ]? R W xchg + C pop D pop $4200 # A mov $21 int W R mov + CS not ?[ D pop Next ]? A D xchg ;c: ?diskerror ; + + +\ *** Block No. 135, Hexblock 87 + +\ lfgets fgetc file@ ks 07 jul 88 + +\ Code ~read ( seg:addr quan handle -- #read ) D W mov +Assembler [[ W R xchg C pop D pop + D: pop $3F # A+ mov $21 int C: C mov C D: mov + W R mov A D xchg CS not ?[ Next ]? ;c: ?diskerror ; + + Code lfgets ( seg:addr quan fcb -- #read ) + D W mov u' f.handle W D) W mov ]] end-code + + true Constant eof + + : fgetc ( fcb -- 8b / eof ) + >r 0 sp@ ds@ swap 1 r> lfgets ?exit 0= ; + + : file@ ( dfaddr fcb -- 8b / eof ) dup >r fseek r> fgetc ; + +\ *** Block No. 136, Hexblock 88 + +\ lfputs fputc file! ks 24 jul 87 + +| Code ~write ( seg:addr quan handle -- ) D W mov +[[ W R xchg C pop D pop + D: pop $40 # A+ mov $21 int W R mov A D xchg + C: W mov W D: mov CS ?[ ;c: ?diskerror ; Assembler ]? + C D sub 0= ?[ D pop Next ]? ;c: Abort" Disk voll" ; + + Code lfputs ( seg:addr quan fcb -- ) + D W mov u' f.handle W D) W mov ]] end-code + + : fputc ( 8b fcb -- ) >r sp@ ds@ swap 1 r> lfputs drop ; + + : file! ( 8b dfaddr fcb -- ) dup >r fseek r> fputc ; + + + +\ *** Block No. 137, Hexblock 89 + +\ /block *block ks 02 okt 87 + + Code /block ( d -- rest blk ) A D xchg C pop + C D mov A shr D rcr A shr D rcr D+ D- mov + A- D+ xchg $3FF # C and C push Next + end-code +\ : /block ( d -- rest blk ) b/blk um/mod ; + + Code *block ( blk -- d ) A A xor D+ D- xchg D+ A+ xchg + A+ sal D rcl A+ sal D rcl A push Next + end-code +\ : *block ( blk -- d ) b/blk um* ; + + + + + +\ *** Block No. 138, Hexblock 8a + +\ fblock@ fblock! ks 19 mär 88 + Dos definitions + +| : ?beyond ( blk -- blk ) dup 0< 0=exit 9 ?diskerror ; + +| : fblock ( addr blk fcb -- seg:addr quan fcb ) + fcb ! ?beyond dup *block fcb @ fseek ds@ -rot + fcb @ f.size 2@ /block rot - ?beyond + IF drop b/blk THEN fcb @ ; + + : fblock@ ( addr blk fcb -- ) fblock lfgets drop ; + + : fblock! ( addr blk fcb -- ) fblock lfputs ; + + + + +\ *** Block No. 139, Hexblock 8b + +\ (r/w flush ks 18 mär 88 + Forth definitions + + : (r/w ( addr blk fcb r/wf -- *f ) over fcb ! over + IF IF fblock@ false exit THEN fblock! false exit + THEN >r drop /drive ?drive + r> IF block@ exit THEN block! ; + + ' (r/w Is r/w + +| : setfiles ( fcb -- ) isfile@ prevfile ! + dup isfile ! fromfile ! ; + + : direct 0 setfiles ; + + + +\ *** Block No. 140, Hexblock 8c + +\ File >file ks 23 mär 88 + + : File Create file-link @ here file-link ! , + here [ b/fcb 2 - ] Literal dup allot erase + file-link @ dup @ f.no c@ 1+ over f.no c! + last @ count $1F and rot f.name place + Does> setfiles ; + + File kernel.scr ' kernel.scr @ Constant [fcb] + + Dos definitions + + : .file ( fcb -- ) + ?dup IF body> >name .name exit THEN ." direct" ; + + + +\ *** Block No. 141, Hexblock 8d + +\ .file pushfile close open ks 12 mai 88 + Forth definitions + + : file? isfile@ .file ; + + : pushfile r> isfile push fromfile push >r ; restrict + + : close isfile@ fclose ; + + : open isfile@ freset ; + + : assign isfile@ dup fclose name swap fname! open ; + + + + + +\ *** Block No. 142, Hexblock 8e + +\ use from loadfrom include ks 18 mär 88 + + : use >in @ name find + 0= IF swap >in ! File last' THEN nip + dup @ [fcb] = over ['] direct = or + 0= Abort" not a file" execute open ; + + : from isfile push use ; + + : loadfrom ( n -- ) pushfile use load close ; + + : include 1 loadfrom ; + + + + + +\ *** Block No. 143, Hexblock 8f + +\ drive drv capacity drivenames ks 18 mär 88 + + : drive ( n -- ) isfile@ IF ~select exit THEN + ?drive offset off 0 ?DO I ?capacity offset +! LOOP ; + + : drv ( -- n ) + isfile@ IF ~disk? exit THEN offset @ /drive nip ; + + : capacity ( -- n ) isfile@ ?dup + IF dup f.handle @ 0= IF dup freset THEN + f.size 2@ /block swap 0<> - exit THEN blk/drv ; + +| : Drv: Create c, Does> c@ drive ; + + 0 Drv: A: 1 Drv: B: 2 Drv: C: 3 Drv: D: + 4 Drv: E: 5 Drv: F: 6 Drv: G: 7 Drv: H: + +\ *** Block No. 144, Hexblock 90 + +\ lfsave savefile savesystem ks 10 okt 87 + + : lfsave ( seg:addr quan string -- ) + filename >asciz 0 ~creat ?diskerror + dup >r ~write r> ~close ; + + : savefile ( addr len -- ) ds@ -rot + name nullstring? Abort" needs name" lfsave ; + + : savesystem save flush $100 here savefile ; + + + + + + + +\ *** Block No. 145, Hexblock 91 + +\ viewing ks 19 mär 88 + Dos definitions +| $400 Constant viewoffset + + : (makeview ( -- n ) + blk @ dup 0=exit loadfile @ ?dup 0=exit f.no c@ ?dup + IF viewoffset * + $8000 or exit THEN 0= ; + ' (makeview Is makeview + + : @view ( acf -- blk fno ) >name 4 - @ dup 0< + IF $7FFF and viewoffset u/mod exit THEN + ?dup 0= Error" eingetippt" 0 ; + + : >file ( fno -- fcb ) dup 0=exit file-link + BEGIN @ dup WHILE 2dup f.no c@ = UNTIL nip ; + + +\ *** Block No. 146, Hexblock 92 + +\ forget FCB's ks 23 okt 88 + Forth definitions +| : 'file ( -- scr ) r> scr push isfile push >r + [ Dos ] ' @view >file isfile ! ; + + : view 'file list ; + : help 'file capacity 2/ + list ; + +| : remove? ( dic symb addr -- dic symb addr f ) + 2 pick over 1+ u< ; + +| : remove-files ( dic symb -- dic symb ) file-link + BEGIN @ ?dup WHILE remove? IF dup fclose THEN REPEAT + file-link remove + isfile@ remove? nip IF file-link @ isfile ! THEN + fromfile @ remove? nip 0=exit isfile@ fromfile ! ; + +\ *** Block No. 147, Hexblock 93 + +\ BIOS keyboard input ks 16 sep 88 + + Code (key@ ( -- 8b ) D push A+ A+ xor $16 int + 0 # D+ mov A- D- mov A- A- or + 0= ?[ A+ D- mov D+ com ]? Next end-code + + : test BEGIN (key@ #esc case? ?exit + cr dup emit 5 .r key 5 .r REPEAT ; +\\ + Code (key? ( -- f ) D push 1 # A+ mov D D xor + $16 int 0= not ?[ D dec ]? Next end-code + + Code empty-keys $C00 # A mov $21 int Next end-code + + : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; + + +\ *** Block No. 148, Hexblock 94 + + + + + + + + + + + + + + + + + + +\ *** Block No. 149, Hexblock 95 + + + + + + + + + + + + + + + + + + +\ *** Block No. 150, Hexblock 96 + + + + + + + + + + + + + + + + + + +\ *** Block No. 151, Hexblock 97 + + + + + + + + + + + + + + + + + + +\ *** Block No. 152, Hexblock 98 + + + + + + + + + + + + + + + + + + +\ *** Block No. 153, Hexblock 99 + + + + + + + + + + + + + + + + + + +\ *** Block No. 154, Hexblock 9a + + + + + + + + + + + + + + + + + + +\ *** Block No. 155, Hexblock 9b + + + + + + + + + + + + + + + + + + +\ *** Block No. 156, Hexblock 9c + + + + + + + + + + + + + + + + + + +\ *** Block No. 157, Hexblock 9d + + + + + + + + + + + + + + + + + + +\ *** Block No. 158, Hexblock 9e + + + + + + + + + + + + + + + + + + +\ *** Block No. 159, Hexblock 9f + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/m130i.prn b/8086/msdos/src/m130i.prn similarity index 100% rename from 8086/msdos/m130i.prn rename to 8086/msdos/src/m130i.prn diff --git a/8086/msdos/meta.fb b/8086/msdos/src/meta.fb similarity index 100% rename from 8086/msdos/meta.fb rename to 8086/msdos/src/meta.fb diff --git a/8086/msdos/src/meta.fth b/8086/msdos/src/meta.fth new file mode 100644 index 0000000..8971ee4 --- /dev/null +++ b/8086/msdos/src/meta.fth @@ -0,0 +1,1007 @@ + +\ *** Block No. 0, Hexblock 0 + + + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ Target compiler loadscr ks cas 09jun20 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + : c+! ( 8b addr -- ) dup c@ rot + swap c! ; + + ' find $22 + @ Alias found + + : search ( string 'vocab -- acf n / string ff ) + dup @ [ ' Forth @ ] Literal - Abort" no vocabulary" + >body (find IF found exit THEN false ; + + 3 &27 thru Onlyforth savesystem meta.com + +cr .( Metacompiler saved as META.COM ) + + + +\ *** Block No. 2, Hexblock 2 + +\ Predefinitions loadscreen ks 30 apr 88 + + &28 load + +cr .( Predefinitions geladen ...) cr + + + + + + + + + + + + +\ *** Block No. 3, Hexblock 3 + +\ Target header pointers ks 29 jun 87 + + Variable tfile tfile off \ handle of target file + Variable tdp tdp off \ target dp + Variable displace displace off \ diplacement of code + Variable ?thead ?thead off \ for headerless code + Variable tlast tlast off \ last name in target + Variable glast' glast' off \ acf of latest ghost + Variable tdoes> tdoes> off \ code addr of last does + Variable tdodo tdodo off \ location of dodo + Variable >in: >in: off \ last :-def + Variable tvoc tvoc off \ + Variable tvoc-link tvoc-link off \ voc-link in target + Variable tnext-link tnext-link off \ link for tracer + + + +\ *** Block No. 4, Hexblock 4 + +\ Target header pointers ks 10 okt 87 + + : there ( -- taddr ) tdp @ ; + + : new pushfile makefile isfile@ tfile ! + tvoc-link off tnext-link off + $100 tdp ! $100 displace ! ; + + + + + + + + + + +\ *** Block No. 5, Hexblock 5 + +\ Ghost-creating ks 07 dez 87 + +0 | Constant 0 | Constant + +| Create gname $21 allot + +| : >heap ( from quan -- ) \ heap over - 1 and + \ align + dup hallot heap swap cmove ; + + : symbolic ( string -- cfa.ghost ) + count dup 1 $1F uwithin not Abort" invalid Gname" + gname place BL gname append align here >r makeview , + state @ IF context ELSE current THEN @ @ dup @ , + gname count under here place 1+ allot align + here r@ - , 0 , 0 , r@ here over - >heap + heap 2+ rot ! r> dp ! heap + ; + +\ *** Block No. 6, Hexblock 6 + +\ ghost words ks 07 dez 87 + + : gfind ( string -- cfa tf / string ff ) + >r 1 r@ c+! r@ find -1 r> c+! ; + + : ghost ( -- cfa ) name gfind ?exit symbolic ; + + : gdoes> ( cfa.ghost -- cfa.does ) + 4 + dup @ IF @ exit THEN + here , 0 , dup 4 >heap + dp ! heap swap ! heap ; + + + + + + +\ *** Block No. 7, Hexblock 7 + +\ ghost utilities ks 29 jun 87 + + : g' ( -- acf ) name gfind 0= Abort" ?T?" ; + + : '. g' dup @ case? + IF ." forw" ELSE - Abort" ??" ." res" THEN + 2+ dup @ 5 u.r 2+ @ ?dup + IF dup @ case? + IF ." fdef" ELSE - Abort" ??" ." rdef" THEN + 2+ @ 5 u.r THEN ; + + ' ' Alias h' + + + + + +\ *** Block No. 8, Hexblock 8 + +\ .unresolved ks 29 jun 87 + +| : forward? ( cfa -- cfa / exit&true ) + dup @ = 0=exit dup 2+ @ 0=exit drop true rdrop ; + +| : unresolved? ( addr -- f ) 2+ + dup count $1F and + 1- c@ bl = + IF name> forward? 4+ @ dup IF forward? THEN + THEN drop false ; + +| : unresolved-words ( thread -- ) + BEGIN @ ?dup WHILE dup unresolved? + IF dup 2+ .name ?cr THEN REPEAT ; + + : .unresolved voc-link @ + BEGIN dup 4 - unresolved-words @ ?dup 0= UNTIL ; + +\ *** Block No. 9, Hexblock 9 + +\ Extending Vocabularys for Target-Compilation ks 29 jun 87 + + Vocabulary Ttools + Vocabulary Defining + + : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; + + Vocabulary Transient tvoc off + + Root definitions + + : T Transient ; immediate + : H Forth ; immediate + : D Defining ; immediate + + Forth definitions + +\ *** Block No. 10, Hexblock a + +\ Image and byteorder ks 02 jul 87 + +| Code >byte ( 16b -- 8b- 8b+ ) A A xor + D- A- xchg D+ D- xchg A push Next end-code + +| Code byte> ( 8b- 8b+ -- 16b ) + A pop D- D+ mov A- D- xchg Next end-code + +| : >target ( addr1 -- daddr fcb ) displace @ - 0 tfile @ ; + + Transient definitions + + : c@ ( addr -- 8b ) [ Dos ] + >target file@ dup 0< Abort" nie abgespeichert" ; + + : c! ( 8b addr -- ) [ Dos ] >target file! ; + +\ *** Block No. 11, Hexblock b + +\ Transient primitives ks 09 jul 87 + : @ ( addr -- n ) H dup T c@ swap 1+ c@ byte> ; + : ! ( n addr -- ) H >r >byte r@ 1+ T c! r> c! H ; + + : cmove ( from.mem to.target quan -- ) [ Dos ] + >r >target fseek ds@ swap r> tfile @ lfputs ; +\ bounds ?DO dup c@ I T c! H 1+ LOOP drop ; + + : here ( -- taddr ) H tdp @ ; + : here! ( taddr -- ) H tdp ! ; + : allot ( n -- ) H tdp +! ; + : c, ( 8b -- ) T here c! 1 allot H ; + : , ( 16b -- ) T here ! 2 allot H ; + : align ( -- ) H ; immediate + : even ( addr1 -- addr2 ) H ; immediate + : halign H ; immediate + +\ *** Block No. 12, Hexblock c + +\ Transient primitives ks 29 jun 87 + + : count ( addr1 -- addr2 len ) H dup 1+ swap T c@ H ; + + : ," H here ," here over dp ! + over - T here swap dup allot cmove H ; + + : fill ( addr quan 8b -- ) H + -rot bounds ?DO dup I T c! H LOOP drop ; + : erase ( addr quan -- ) H 0 T fill H ; + : blank ( addr quan -- ) H bl T fill H ; + + : move-threads H tvoc @ tvoc-link @ + BEGIN over ?dup + WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT + Error" some undef. Target-Vocs left" drop ; + +\ *** Block No. 13, Hexblock d + +\ Resolving ks 29 jun 87 + Forth definitions + + : resolve ( cfa.ghost cfa.target -- ) over dup @ = + IF space dup >name .name ." exists " ?cr + 2+ ! drop exit THEN >r >r 2+ @ ?dup + IF BEGIN dup T @ H 2dup = Abort" resolve loop" + r@ rot T ! H ?dup 0= UNTIL + THEN r> r> over ! 2+ ! ; + + : resdoes> ( acf.ghost acf.target -- ) swap gdoes> + dup @ = IF 2+ ! exit THEN swap resolve ; + +here 2+ 0 ] Does> dup @ there rot ! T , H ; ' >body ! +here 2+ 0 ] Does> @ T , H ; ' >body ! + + +\ *** Block No. 14, Hexblock e + +\ compiling names into targ. ks 10 okt 87 + +| : tlatest ( -- addr ) current @ 6 + ; + + : (theader ?thead @ IF 1 ?thead +! exit THEN + >in @ bl word swap >in ! dup count upper + dup c@ 1 $20 uwithin not Abort" inval. Tname" + blk @ $8400 or T align , H + there tlatest @ T , H tlatest ! there tlast ! + there over c@ 1+ dup T allot cmove align H ; + + : theader tlast off + (theader ghost dup glast' ! there resolve ; + + + + +\ *** Block No. 15, Hexblock f + +\ prebuild defining words ks 29 jun 87 + +| : (prebuild >in @ Create >in ! + r> dup 2+ >r @ here 2- ! ; + +| : tpfa, there , ; + + : prebuild ( addr check# -- check# ) 0 ?pairs + dup IF compile (prebuild dup , THEN + compile theader ghost gdoes> , + IF compile tpfa, THEN 0 ; immediate + + : dummy 0 ; + + : DO> [compile] Does> here 3 - compile @ 0 ] ; + + +\ *** Block No. 16, Hexblock 10 + +\ Constructing defining words in Host kks 07 dez 87 + +| : defcomp ( string -- ) dup ['] Defining search ?dup + IF 0> IF nip execute exit THEN drop dup THEN + find ?dup IF 0< IF nip , exit THEN THEN + drop ['] Forth search ?dup + IF 0< IF , exit THEN execute exit THEN + number? ?dup 0= Abort" ?" + 0> IF swap [compile] Literal THEN [compile] Literal ; + +| : definter ( string -- ) dup ['] Defining search ?dup + IF 0< IF nip execute exit THEN THEN drop + find ?dup IF 1 and 0= Abort" compile only" execute exit + THEN number? 0= Error" ?" ; + + + +\ *** Block No. 17, Hexblock 11 + +\ Constructing defining words in Host ks 22 dez 87 + +| : (;tcode r> @ tlast @ T count + ! H ; + +Defining definitions + + : ] H ] ['] defcomp Is parser ; + + : [ H [compile] [ ['] definter Is parser ; immediate + + : ; H [compile] ; [compile] \\ ; immediate + + : Does> H compile (;tcode tdoes> @ , + [compile] ; -2 allot [compile] \\ ; immediate +D ' Does> Alias ;Code immediate H + + +\ *** Block No. 18, Hexblock 12 + +\ reinterpreting defining words ks 22 dez 87 + Forth definitions + + : ?reinterpret ( f -- ) 0=exit + state @ >r >in @ >r adr parser @ >r + >in: @ >in ! : D ] H interpret + r> Is parser r> >in ! r> state ! ; + + : undefined? ( -- f ) glast' @ 4+ @ 0= ; + +| : flag! ( 8b -- ) tlast @ ?dup 0= IF drop exit THEN + dup T c@ rot or swap c! H ; + +| : nfa? ( acf alf -- anf / acf ff ) + BEGIN dup WHILE 2dup 2+ T count $1F and + even H = + IF 2+ nip exit THEN T @ H REPEAT ; + +\ *** Block No. 19, Hexblock 13 + +\ the 8086 Assembler ks 29 jun 87 + +| Create relocate ] T c, , here ! c! H [ + +Transient definitions + + : Assembler H [ Assembler ] relocate >codes ! Assembler ; + + : >label ( 16b -- ) H >in @ name gfind rot >in ! + IF over resolve dup THEN drop Constant ; + + : Label T here >label Assembler H ; + + : Code H theader T here 2+ , Assembler H ; + + + +\ *** Block No. 20, Hexblock 14 + +( Transient primitives ks 17 dec 83 ) + +' exit Alias exit ' load Alias load +' / Alias / ' thru Alias thru +' swap Alias swap ' * Alias * +' dup Alias dup ' drop Alias drop +' /mod Alias /mod ' rot Alias rot +' -rot Alias -rot ' over Alias over +' 2* Alias 2* ' + Alias + +' - Alias - ' 1+ Alias 1+ +' 2+ Alias 2+ ' 1- Alias 1- +' 2- Alias 2- ' negate Alias negate +' 2swap Alias 2swap ' 2dup Alias 2dup + + + + +\ *** Block No. 21, Hexblock 15 + +\ Transient primitives kks 29 jun 87 + + ' also Alias also ' words Alias words +' definitions Alias definitions ' hex Alias hex +' decimal Alias decimal ' ( Alias ( immediate + ' \ Alias \ immediate ' \\ Alias \\ immediate + ' .( Alias .( immediate ' [ Alias [ immediate + ' cr Alias cr +' end-code Alias end-code ' Transient Alias Transient + ' +thru Alias +thru ' +load Alias +load + ' .s Alias .s + +Tools ' trace Alias trace immediate + + + + +\ *** Block No. 22, Hexblock 16 + +\ immediate words and branch primitives ks 29 jun 87 + + : >mark ( -- addr ) T here 0 , H ; + : >resolve ( addr -- ) T here over - swap ! H ; + : name ks 29 jun 87 + + : ' ( -- acf ) H g' dup @ - + IF Error" undefined" THEN 2+ @ ; + + : compile H ghost , ; immediate restrict + + : >name ( acf -- anf / ff ) H tvoc + BEGIN @ dup WHILE under 2- @ nfa? ?dup IF nip exit THEN + swap REPEAT nip ; + + + + + + + +\ *** Block No. 24, Hexblock 18 + +\ >name Alias ks 29 jun 87 + + : >body ( acf -- apf ) H 2+ ; + + : Alias ( n -- ) H tlast off + (theader ghost over resolve T , H $20 flag! ; + + : on ( addr -- ) H true swap T ! H ; + : off ( addr -- ) H false swap T ! H ; + + + + + + + + +\ *** Block No. 25, Hexblock 19 + +\ Target tools ks 9 sep 86 + Onlyforth + +| : .tfield ( taddr len quan -) >r under Pad swap + bounds ?DO dup T c@ I H c! 1+ LOOP drop + Pad over type r> swap - 0 max spaces ; + + ' view Alias hview + + Ttools also definitions + +| : ?: ( addr -- addr ) dup 4 u.r ." :" ; +| : @? ( addr -- addr ) dup T @ H 6 u.r ; +| : c? ( addr -- addr ) dup T c@ H 3 .r ; + + + +\ *** Block No. 26, Hexblock 1a + +\ Ttools for decompiling ks 9 sep 86 + + : s ( addr -- addr+ ) ?: space c? 4 spaces + T count 2dup + even -rot 18 .tfield ; + + : n ( addr -- addr+2 ) ?: @? 2 spaces dup T @ >name H + ?dup IF T count H ELSE 0 0 THEN + $1F and $18 .tfield 2+ ; + + : d ( addr n -- addr+n ) 2dup swap ?: 3 spaces + swap 0 DO c? 1+ LOOP 4 spaces -rot dup .tfield ; + + : l ( addr -- addr+2 ) ?: 6 spaces @? 2+ 14 spaces ; + + : c ( addr -- addr+1 ) 1 d 15 spaces ; + + +\ *** Block No. 27, Hexblock 1b + +\ Tools for decompiling ks 29 jun 87 + + : b ( addr -- addr+2 ) ?: @? dup T @ H + over + 6 u.r 2+ 14 spaces ; + + : dump ( addr n -- ) + bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; + + : view T ' >name H ?dup 0=exit 4 - T @ H ?dup 0=exit edit ; + + + + + + + + +\ *** Block No. 28, Hexblock 1c + +\ Predefinitions loadscreen ks 29 jun 87 + Onlyforth + + : clear H true Abort" There are ghosts" ; + + + 1 $B +thru + + + + + + + + + + +\ *** Block No. 29, Hexblock 1d + +\ Literal ['] ?" ." " ks 29 jun 87 + Transient definitions Forth + + : Literal ( n -- ) H dup $FF00 and + IF T compile lit , H exit THEN T compile clit c, H ; + immediate + + : Ascii H bl word 1+ c@ state @ 0=exit + T [compile] Literal H ; immediate + + : ['] T compile lit H ; immediate + : ." T compile (." ," align H ; immediate + : " T compile (" ," align H ; immediate + + + + +\ *** Block No. 30, Hexblock 1e + +\ Target compilation ] ks 07 dez 87 + Forth definitions + +| : tcompile ( string -- ) dup find ?dup + IF 0> IF nip execute exit THEN THEN + drop gfind IF execute exit THEN number? ?dup + IF 0> IF swap T [compile] Literal THEN + [compile] Literal H exit THEN + symbolic execute ; + + Transient definitions + + : ] H ] ['] tcompile Is parser ; + + + + +\ *** Block No. 31, Hexblock 1f + +\ Target conditionals ks 10 sep 86 + + : IF T compile ?branch >mark H 1 ; immediate restrict + : THEN abs 1 ?pairs T >resolve H ; immediate restrict + : ELSE 1 ?pairs T compile branch >mark + swap >resolve H -1 ; immediate restrict + + : BEGIN T mark H -2 2swap ; + immediate restrict + +| : (repeat 2 ?pairs T resolve H REPEAT ; + + : UNTIL T compile ?branch (repeat H ; immediate restrict + : REPEAT T compile branch (repeat H ; immediate restrict + +\ *** Block No. 32, Hexblock 20 + +\ Target conditionals Abort" etc. ks 09 feb 88 + + : DO T compile (do >mark H 3 ; immediate restrict + : ?DO T compile (?do >mark H 3 ; immediate restrict + : LOOP 3 ?pairs T compile (loop + compile endloop >resolve H ; immediate restrict + : +LOOP 3 ?pairs T compile (+loop + compile endloop >resolve H ; immediate restrict + + : Abort" T compile (abort" ," align H ; immediate restrict + : Error" T compile (error" ," align H ; immediate restrict + + + + + + +\ *** Block No. 33, Hexblock 21 + +\ Target does> ;code ks 29 jun 87 + +| : dodoes> T compile (;code + H glast' @ there resdoes> there tdoes> ! ; + + : Does> H undefined? T dodoes> + $E9 c, H tdodo @ there - 2- T , + H ?reinterpret ; immediate restrict + + : ;Code H 0 ?pairs undefined? T dodoes> H ?reinterpret + T [compile] [ Assembler H ; immediate restrict + + + + + + +\ *** Block No. 34, Hexblock 22 + +\ User ks 09 jul 87 + Forth definitions + + Variable torigin torigin off \ cold boot vector + Variable tudp tudp off \ user variable counter + : >user ( addr1 -- addr2 ) T c@ H torigin @ + ; + + Transient definitions Forth + + : origin! ( taddr -- ) H torigin ! tudp off ; + : uallot ( n -- offset ) H tudp @ swap tudp +! ; + + DO> >user ; + : User T prebuild User 2 uallot c, H ; + + + +\ *** Block No. 35, Hexblock 23 + +\ Variable Constant Create ks 01 okt 87 + + DO> ; + : Variable T prebuild Create 2 allot H ; + + DO> T @ H ; + : Constant T prebuild Constant , H ; + + DO> ; + : Create T prebuild Create H ; + + : Create: T Create ] H end-code 0 ; + + + + + +\ *** Block No. 36, Hexblock 24 + +\ Defer Is Vocabulary ks 29 jun 87 + + DO> ; + : Defer T prebuild Defer 2 allot ; + : Is T ' >body H state @ + IF T compile (is , H exit THEN T ! H ; immediate + + dummy + : Vocabulary H >in @ Vocabulary >in ! + T prebuild Vocabulary 0 , 0 , + H there tvoc-link @ T , H tvoc-link ! ; + + + + + + +\ *** Block No. 37, Hexblock 25 + +\ File ks 19 mär 88 + Forth definitions + + Variable tfile-link tfile-link off + Variable tfileno tfileno off + &45 Constant tb/fcb + + Transient definitions Forth + + dummy + : File T prebuild File here tb/fcb 0 fill + here H tfile-link @ T , H tfile-link ! + 1 tfileno +! tfileno @ T c, 0 , 0 , 0 , 0 , 0 , + here dup >r 1+ tb/fcb &13 - allot H tlast @ + T count dup r> c! + H bounds ?DO I T c@ over c! H 1+ LOOP drop ; + +\ *** Block No. 38, Hexblock 26 + +\ : ; compile Host [compile] ks 29 jun 87 + + dummy + : : H >in @ >in: ! T prebuild : ] H end-code 0 ; + + : ; 0 ?pairs T compile unnest + [compile] [ H ; immediate restrict + + : compile T compile compile H ; immediate restrict + + : Host H Onlyforth ; + + : Compiler H Onlyforth Transient also definitions ; + + : [compile] H ghost execute ; immediate restrict + + +\ *** Block No. 39, Hexblock 27 + +\ Target ks 29 jun 87 + + Onlyforth + + : Target H vp off Transient also definitions ; + + Transient definitions + + ghost c, drop + + + + + + + + +\ *** Block No. 40, Hexblock 28 + + + + + + + + + + + + + + + + + + +\ *** Block No. 41, Hexblock 29 + + + + + + + + + + + + + + + + + + +\ *** Block No. 42, Hexblock 2a + + + + + + + + + + + + + + + + + + +\ *** Block No. 43, Hexblock 2b + + + + + + + + + + + + + + + + + + +\ *** Block No. 44, Hexblock 2c + + + + + + + + + + + + + + + + + + +\ *** Block No. 45, Hexblock 2d + + + + + + + + + + + + + + + + + + +\ *** Block No. 46, Hexblock 2e + + + + + + + + + + + + + + + + + + +\ *** Block No. 47, Hexblock 2f + + + + + + + + + + + + + + + + + + +\ *** Block No. 48, Hexblock 30 + + + + + + + + + + + + + + + + + + +\ *** Block No. 49, Hexblock 31 + + + + + + + + + + + + + + + + + + +\ *** Block No. 50, Hexblock 32 + + + + + + + + + + + + + + + + + + +\ *** Block No. 51, Hexblock 33 + + + + + + + + + + + + + + + + + + +\ *** Block No. 52, Hexblock 34 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/minimal.sys b/8086/msdos/src/minimal.sys similarity index 100% rename from 8086/msdos/minimal.sys rename to 8086/msdos/src/minimal.sys diff --git a/8086/msdos/miniterm.fb b/8086/msdos/src/miniterm.fb similarity index 100% rename from 8086/msdos/miniterm.fb rename to 8086/msdos/src/miniterm.fb diff --git a/8086/msdos/src/miniterm.fth b/8086/msdos/src/miniterm.fth new file mode 100644 index 0000000..aa3eedf --- /dev/null +++ b/8086/msdos/src/miniterm.fth @@ -0,0 +1,380 @@ + +\ *** Block No. 0, Hexblock 0 + +\\ Terminalprogramm mit Blockinterface ( 08.03.91/KK ) + + Autor: Klaus Kohl, 30.01.89 aus FG-FORTH des RTX entnommen + + Beschreibung: + + Kleines Beispiel zur Implementation eines Fileinterfaces über + die serielle Schnittstelle (Achtung: immer 8 Datenbits) + + Die Schnittstellenbefehle stammen aus dem PC-volksFORTH 3.81 + von Klaus Schleisiek. Sie wurden weitgehend unverändert über- + nommen, sind aber auf 4KByte-Puffer erweitert. + File: SERIAL.SCR + + Umstellung des Ports durch Ausmaskierung der entsprechenden + Zeilen in Screen 2 (momentan COM1 aktiviert). + +\ *** Block No. 1, Hexblock 1 + +\ LOADSCREEN cas 28jun20 + +Onlyforth \ Suchreihenfolge: FORTH FORTH ONLY +\needs Assembler 2 loadfrom asm.fb \ Assembler nachladen + + FROM source.img ( File for SAVESYSTEM ) + + $20 >label I_ctrl \ 8259-Register + $21 >label I_mask \ 8259-Mask + + &02 &11 THRU ( SIO-Terminalroutines ) + &12 &17 THRU ( extended command words ) + &18 LOAD ( Terminalprogram ) + + + + +\ *** Block No. 2, Hexblock 2 + +\ Addresses and Constants cas 28jun20 + +| $C 4 * Constant SINT@ \ SIO-Interuptvector COM 1/3 +\ $B 4 * Constant SINT@ \ SIO-Interuptvector COM 2/4 +| $10 Constant I_level \ 8259-Interuptlevel COM 1/3 +\ $08 Constant I_level \ 8259-Interuptlevel COM 2/4 +( Port address) +| $3F8 >label Portadr \ Portaddress COM1: +\ $2F8 >label Portadr \ Portaddress COM2: +\ $3E8 >label Portadr \ Portaddress COM3: +\ $2E8 >label Portadr \ Portaddress COM4: +( Selection of Baud rate ) +\ &96 >label baud .( 1200 Baud ) +\ &48 >label baud .( 2400 Baud ) +| &12 >label baud .( 9600 Baud ) +\ &02 >label baud .( 57600 Baud ) + +\ *** Block No. 3, Hexblock 3 + +\ Queue and required commands cas 28jun20 + +( Dataqueue with 128 bytes and two pointer for IRQ service ) +( Queue+0: Number of saved characters ) +( Queue+1: offset to next char to be send ) + Create Queue 0 , 0 , $1000 allot + +\ send byte to port address ( b adr -- ) +\needs pc! Code pc! A pop D byte out D pop Next + +\ Read Byte from port address ( adr -- b ) +\needs pc@ Code pc@ D byte in A- D- mov D+ D+ xor Next + + + + + +\ *** Block No. 4, Hexblock 4 + +\ tx? = Request status for sending char cas 28jun20 + +( test if a char cn be send ) + Code tx? ( -- f ) \ f=-1, ready to send + D push \ TOS to datastack (TOS=Top Of Stack) + Portadr 5 + # D mov \ move status address into D reg + D in \ get port into register A + D D xor \ set D register to 0 + $1020 # A and \ mask % 0001 0000 0010 0000 + $1020 # A cmp \ tes if these bits are set + 0= ?[ D dec ]? \ char output permitted ? + Next \ compiling "Next" wurg macro + end-code + + + + +\ *** Block No. 5, Hexblock 5 + +\ (tx tx = transmit cas 28jun20 + +( unconditional send byte directly to 8250-Port ) + Code (tx ( char -- ) + D- A- xchg \ load char into AL-register + Portadr # D mov \ load port address in D-register + D byte out \ transmit AL + D pop \ load next stack value into D-register + Next \ compiling "Next" + end-code + +( wait until last char has been send ) + : tx ( char -- ) + BEGIN tx? UNTIL \ wait until SIO ready + (tx ; \ now write to port + + +\ *** Block No. 6, Hexblock 6 + +\ -DTR +DTR = Data Terminal Ready on/off cas 28jun20 +( DTR-Line to +12 V = logical zero ) + Code -DTR ( -- ) + D push \ save TOS + Portadr 4 + # D mov \ get Address of Port Controllregister + D byte in \ move content to AL register + $1C # A- and \ DTR and RTS to 0 = +12 V + D byte out \ write AL back into port register + D pop \ restore TOS + Next \ next FORTH words + end-code +( set DTR and RTS back to 1 = -12 V ) + Code +DTR ( -- ) + D push Portadr 4 + # D mov + D byte in 3 # A- or D byte out + D pop Next end-code + +\ *** Block No. 7, Hexblock 7 + +\ receive queue and interrupt service routine ( 21.02.89/KK ) + +| Label S_INT + D push I push A push + Queue # I mov C: seg I ) A mov + A D mov A inc $FFF # A and C: seg A I ) mov D I ADD + Portadr # D mov D byte in C: seg A- 4 I D) mov + $20 # A- mov I_ctrl #) byte out \ EOI for 8259 + A pop I pop D pop iret + end-code + + + + + + + +\ *** Block No. 8, Hexblock 8 + +\ rx? = request status for reading from Queue cas 28jun20 +| Code rx? ( -- f ) D push + Queue #) D mov Queue 2+ #) D XOR + Next end-code + +\\ Query if a char can be read from the queue + Code rx? ( -- f ) ( f<>0, if char ready ) + D push \ TOS to datastack + D D xor \ D-register to 0 + Queue #) D- mov \ get number if DL and + D- D- or \ test for 0 + 0= ?[ [[ D push \ if queue empty + Portadr 4 + # D mov \ activate S8 again + D byte in $B # A- or D byte out \ without changing + D pop \ D register +swap ]? Next end-code + +\ *** Block No. 9, Hexblock 9 + +\ (rx rx = receive char from queue cas 28jun20 + +( get char from queue, adjust pointer ) + Code (rx ( -- char ) + D push I push + Queue 2+ # I mov C: seg I ) A mov + A D mov A inc $FFF # A and C: seg A I ) mov D I ADD + C: seg 2 I D) A- mov 0 # A+ mov A D mov + I pop Next end-code + +( get char, wait for char available ) + : rx ( -- char ) + BEGIN rx? UNTIL (rx ; + + + + +\ *** Block No. 10, Hexblock a + +\ S_init = initialize serial interface cas 28jun20 +| Code S_init ( -- ) + D push D: push \ save TOS and DS register + A A xor A D: mov C: A mov \ 0 -> DS ; CS -> A + SINT@ # W mov S_INT # W ) mov \ set IRQ vector + A 2 W D) mov D: pop \ and restore DS register + Portadr 3 + # D mov + $80 # A- mov D byte out \ enable Baud-rate register + 2 # D sub baud # A mov A- A+ xchg D byte out \ set the + D dec A- A+ xchg D byte out \ BAUD rate + 3 # D add $A07 # A mov D out \ 8bit, noP, +RTS +OUT + 2 # D sub 1 # A- mov D byte out \ enable RX IRQ + I_mask #) byte in + I_level Forth not Assembler # A- and \ activate 8259 + I_mask #) byte out + D pop Next end-code + +\ *** Block No. 11, Hexblock b + +\ init -init = Initialization / Reset cas 28jun20 + +\needs init | : init ; + +( clear queue pointer and initialize port and interrupt ) + : init ( -- ) + init Queue off Queue 2+ off S_init ; + +( block IRQ, disable RTS and DTR ) + : -init ( -- ) + 0 [ Portadr 1+ ] Literal pc! \ disable 8259 IRQ + 0 [ Portadr 4 + ] Literal pc! \ -RTS/-rts/-out2 + I_mask pc@ I_level or I_mask pc! ; \ block 8259 + + + + +\ *** Block No. 12, Hexblock c + +\ rxto rxwto = receive char with timeout cas 28jun20 + +| &1000 Constant Timeout \ exit after 1000 iterations + +( get a char ) +| : rxto ( -- char 0 | f ) ( f=-1 signals error ) + Timeout \ number iterations + BEGIN rx? IF drop (rx 0 exit THEN \ char available? + 1- DUP 0= \ Timeout ? + UNTIL DROP -1 ; + +( get a word, Highbyte first ) +| : rxwto ( -- n 0 | f ) + rxto ?dup ?exit \ exit when Timeout in 1st byte + &256 * rxto \ move to highbyte, get lowbyte + if drop -1 else OR 0 then ; \ Timeout -> error flag + +\ *** Block No. 13, Hexblock d + +\ info. blk>sio sio>blk = Forth Block I/O cas 28jun20 +: info. ." Block: " dup . cr ; +: blk>sio ( b -- f ) ( Block to target machine ) + dup capacity u< + if cr ." HOST -> TA -" info. block 0 tx + &1024 0 DO dup c@ tx 1+ LOOP drop + else drop 9 tx + then 0 ; +: sio>blk ( b -- f ) ( Block from Target ) + dup capacity u< + if cr ." TA -> HOST -" info. flush block 0 tx + &1024 0 do rxto if drop &1234 leave + else over c! 1+ then loop &1234 = + if empty-buffers -1 else update flush 0 then + else drop 9 tx 0 then ; + + +\ *** Block No. 14, Hexblock e + +\ Extension for img>file cas 28jun20 + +VARIABLE TSEG TSEG OFF ( Segment-Address of Target-RAM ) + +: TINIT ( len -- ) + 0 B/SEG UM/MOD SWAP IF 1+ THEN ( number of blocks ) + LALLOCATE ABORT" No RAM" ( reserve ) + TSEG ! ; ( save address ) +: TFREE ( -- ) ( release memory ) + TSEG @ LFREE ABORT" RAM allocated" ; + +: TC! ( c addr -- ) ( write byte ) + TSEG @ SWAP LC! ; +: R >R TSEG @ SWAP DS@ R> R> LMOVE ; + + +\ *** Block No. 15, Hexblock f + +\ Terminal part for SAVESYSTEM cas 28jun20 + +: img>file ( len -- f ) ( save image file ) + DUP TINIT DUP 0 0 tx + ?DO rxto ABORT" Savesystem-Error" I TC! LOOP + PUSHFILE SOURCE.IMG + CAPACITY 1- 0 DO I BLOCK &1024 -1 FILL UPDATE LOOP + 0 $400 UM/MOD DUP 0 + ?DO I $400 * I BLOCK $400 sio exit then \ Transmit + 2 case? if rxwto ?dup ?exit sio>blk exit then \ Receive + 3 case? if rxwto ?dup ?exit img>file exit then \ ROM + 4 case? if rxwto ?dup ?exit drop page 0 exit then \ PAGE + 5 case? if rxto ?dup ?exit rxto ?dup if nip exit then + swap at 0 exit then \ AT + $1B case? if $1B tx 0 exit then \ ESCAPE + drop -1 ; \ error unknown command + + + + +\ *** Block No. 17, Hexblock 11 + +\ ?rx = char from terminal cas 28jun20 + +( receive and interpret char ) +| : ?rx ( -- ) + pause rx? 0=exit (rx \ return if no char wainting + dup $20 u< \ is control char? + if + $1B case? if tbu abort" Command-Error" exit THEN \ ESCAPE + #LF case? IF cr exit THEN \ CRLF + #CR case? IF Row 0 at exit THEN \ only CR + #BS case? IF del exit THEN \ Backspace + drop \ better ignore these + else + Col &78 u> if cr then \ next line? + emit \ directly emit char + then ; + +\ *** Block No. 18, Hexblock 12 + +\ T - Main Terminal command cas 28jun20 + +( send char if possible ) +| : ?tx ( c -- ) + BEGIN ?rx tx? UNTIL \ receive unil SIO is free + tx ; \ then transmit +( Terminal Interpreter Loop ) +| : (T ( -- ) + BEGIN BEGIN ?rx key? UNTIL \ receive until key pressed + key $1B case? IF -DTR exit THEN ?tx \ exit on ESC + REPEAT ; +( Main program, en-/disables interrupt ) + : T ( -- ) + CR ." TA-Terminal (Exit with ESC)" CR + INIT (T -INIT + CR ." VolksForth " ; + +\ *** Block No. 19, Hexblock 13 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/multi.vid b/8086/msdos/src/multi.vid similarity index 100% rename from 8086/msdos/multi.vid rename to 8086/msdos/src/multi.vid diff --git a/8086/msdos/nec8023.prn b/8086/msdos/src/nec8023.prn similarity index 100% rename from 8086/msdos/nec8023.prn rename to 8086/msdos/src/nec8023.prn diff --git a/8086/msdos/primed.fb b/8086/msdos/src/primed.fb similarity index 100% rename from 8086/msdos/primed.fb rename to 8086/msdos/src/primed.fb diff --git a/8086/msdos/src/primed.fth b/8086/msdos/src/primed.fth new file mode 100644 index 0000000..b800170 --- /dev/null +++ b/8086/msdos/src/primed.fth @@ -0,0 +1,133 @@ + +\ *** Block No. 0, Hexblock 0 + +\\ Simple Editor for Installation cas 10nov05 + +If the Full-Screen Editor cannot be used during installation +(incompatible display hardware), the screens must be altered +with this Simple Editor "PRIMED", which contains only one word +definition:: + +Usage: Select Screen nn with command "nn LIST", + and edit a screen with "ll NEW". It is only possible to + rewrite whole lines. ll is the first line where the editing + should start. The editing can be terminated by entering an + empty line (just RETURN). Each RETURN will store the editied + line and the whole screen will be reprinted. + + + + +\ *** Block No. 1, Hexblock 1 + +\ primitivst Editor PRIMED cas 10nov05 + Vocabulary Editor + +| : !line ( adr count line# -- ) + scr @ block swap c/l * + dup c/l bl fill + swap cmove update ; + +: new ( n -- ) + l/s 1+ swap + ?DO cr I . + pad c/l expect span @ 0= IF leave THEN + pad span @ I !line cr scr @ list LOOP ; + + ' scr | Alias scr' + + .( Simple Editor loaded ) cr + +\ *** Block No. 2, Hexblock 2 + +\ PRIMED Demo-Screen cas 10nov05 + + + +This text was created by: "2 LIST 4 NEW" and then entering +this text +The headerline (Line 0) was added later after leaving "NEW" +with an empty line (just RETURN) and a new editing command +"0 NEW". + Ulrich Hoffmann + + + + + + + +\ *** Block No. 3, Hexblock 3 + + + + + + + + + + + + + + + + + + +\ *** Block No. 4, Hexblock 4 + + + + + + + + + + + + + + + + + + +\ *** Block No. 5, Hexblock 5 + + + + + + + + + + + + + + + + + + +\ *** Block No. 6, Hexblock 6 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/see.fb b/8086/msdos/src/see.fb similarity index 100% rename from 8086/msdos/see.fb rename to 8086/msdos/src/see.fb diff --git a/8086/msdos/src/see.fth b/8086/msdos/src/see.fth new file mode 100644 index 0000000..1b03b68 --- /dev/null +++ b/8086/msdos/src/see.fth @@ -0,0 +1,2318 @@ + +\ *** Block No. 0, Hexblock 0 + +\ Extended-Decompiler for VolksForth cas 10nov05 + +This file contains the volksFORTH decompiler. The decompiler +will convert FORTH code back to Sourcecode. +Conditional words like IF THEN ELSE, BEGIN WHILE REPEAT UNTIL +and DO LOOP +LOOP are identified and converted. + +The Decompiler cannot re-create comments, so please use +comments in screens and view. + + +Because: There is always one more bug! +And to correct bug, nothing beats good commented sourcecode. + + +Usage: SEE + +\ *** Block No. 1, Hexblock 1 + +\ Extended-Decompiler for VolksForth LOAD-SCREEN ks 22 dez 87 +Onlyforth Tools also definitions + +| : internal 1 ?head ! ; +| : external ?head off ; + +1 &18 +thru + +\\ +Produces compilable Forth source from normal compiled Forth. + + These source blocks are based on the works of + + Henry Laxen, Mike Perry and Wil Baden + + volksFORTH version: U. Hoffmann + +\ *** Block No. 2, Hexblock 2 + +\ detecting does> ks 22 dez 87 + +internal + +' Forth @ 1+ dup @ + 2+ Constant (dodoes> + +: does? ( IP - f ) + dup c@ $E9 ( jmp ) = + swap 1+ dup @ + 2+ (dodoes> = and ; + + + + + + + + +\ *** Block No. 3, Hexblock 3 + +\ indentation. 04Jul86 +Variable #spaces #spaces off + +: +in ( -- ) 3 #spaces +! ; + +: -in ( -- ) -3 #spaces +! ; + +: ind-cr ( -- ) ( col #spaces @ = ?exit ) cr #spaces @ spaces ; + +: ?ind-cr ( -- ) col c/l u> IF ind-cr THEN ; + + + + + + + +\ *** Block No. 4, Hexblock 4 + +\ case defining words 01Jul86 + +: Case: ( -- ) + Create: Does> swap 2* + perform ; + +: Associative: ( n -- ) + Constant Does> ( n - index ) + dup @ -rot dup @ 0 + DO 2+ 2dup @ = + IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ; + + + + + + + +\ *** Block No. 5, Hexblock 5 + +\ branching 04Jul86 + +Variable #branches Variable #branch + +: branch-type ( n -- a ) 6 * pad + ; +: branch-from ( n -- a ) branch-type 2+ ; +: branch-to ( n -- a ) branch-type 4+ ; + +: branched ( adr type -- ) \ Make entry in branch-table. + #branches @ branch-type ! dup #branches @ branch-from ! + 2+ dup @ + #branches @ branch-to ! 1 #branches +! ; + +\\ branch-table: { type0|from0|to0 | type1|from1|to1 ... } + + + + +\ *** Block No. 6, Hexblock 6 + +\ branching 01Jul86 + +: branch-back ( adr type -- ) + \ : make entry in branch-table & reclassify branch-type.) + over swap branched + 2+ dup dup @ + swap 2+ ( loop-start,-end.) + 0 #branches @ 1- + ?DO + over I branch-from @ u> IF LEAVE THEN + dup I branch-to @ = IF ['] while I branch-type ! THEN + -1 +LOOP 2drop ; + + + + + + +\ *** Block No. 7, Hexblock 7 + +\ branching 01Jul86 +: forward? ( ip -- f ) 2+ @ 0> ; + +: ?branch+ ( ip -- ip' ) dup 4+ swap dup forward? + IF ['] if branched exit THEN ['] until branch-back ; + +: branch+ ( ip -- ip' ) dup 4+ swap dup forward? + IF ['] else branched exit THEN ['] repeat branch-back ; + +: (loop)+ ( ip -- ip' ) + dup dup @ ( loop,+loop ) branch-back -1 #branches +! 4+ ; + +: string+ ( ip -- ip' ) 2+ count + even ; + +: (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+ ; + + +\ *** Block No. 8, Hexblock 8 + +\ classify each word 25Aug86 +Forth + +&15 Associative: execution-class + ] clit lit ?branch branch + (do (." (abort" (;code + (" (?do (loop + (+loop unnest (is compile [ + +Case: execution-class+ + 3+ 4+ ?branch+ branch+ + 2+ string+ string+ (;code+ + string+ 2+ 4+ + 4+ 0= 4+ 4+ 2+ ; + +Tools + +\ *** Block No. 9, Hexblock 9 + +\ first pass ks 22 dez 87 + +: pass1 ( cfa -- ) #branches off >body + BEGIN dup @ execution-class execution-class+ + dup 0= stop? or + UNTIL drop ; + +: thru.branchtable ( -- limit start ) #branches @ 0 ; + + + + + + + + + +\ *** Block No. 10, Hexblock a + +\ identify branch destinations. ks 22 dez 87 +: ?.then ( ip -- ) thru.branchtable + ?DO I branch-to @ over = + IF I branch-from @ over u< + IF I branch-type @ dup ['] else = swap ['] if = or + IF -in ." THEN " ind-cr LEAVE THEN THEN THEN + LOOP ; + +: ?.begin ( ip -- ) thru.branchtable + ?DO I branch-to @ over = + IF I branch-from @ over u< not + IF I branch-type @ dup + ['] repeat = swap ['] until = or + IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN + LOOP ; +( put "BEGIN" and "THEN" where used.) + +\ *** Block No. 11, Hexblock b + +\ decompile each type of word 01Jul86 + +: .word ( ip -- ip' ) dup @ >name .name 2+ ; + +: .(word ( ip -- ip' ) dup @ >name + ?dup 0= IF ." ??? " ELSE + count $1f and swap 1+ swap 1- type space THEN 2+ ; +: .inline ( val16b -- ) + dup >name ?dup IF ." ['] " .name drop exit THEN . ; + +: .lit ( ip -- ip' ) 2+ dup @ .inline 2+ ?.then ; +: .clit ( ip -- ip' ) 2+ dup c@ . 1+ ?.then ; +: .string ( ip -- ip' ) + .(word count 2dup type Ascii " emit space + even ?.then ; + +: .unnest ( ip -- 0 ) ." ; " 0= ; + +\ *** Block No. 12, Hexblock c + +\ decompile each type of word 01Jul86 + +: .default ( ip -- ip' ) dup @ >name ?dup IF + c@ $40 and IF ." [COMPILE] " THEN THEN .word ?.then ; + +: .['] ( ip -- ip' ) .(word dup @ 2- >name .name 2+ ?.then ; + +: .compile ( ip -- ip' ) .word .word ?.then ; + + + + + + + + + +\ *** Block No. 13, Hexblock d + +\ decompiling conditionals 04Jul86 + +: .if ( ip nfa -- ip' ) ind-cr .name +in 4+ ?.then ; +: .repeat ( ip nfa -- ip' ) -in .name ind-cr 4+ ?.then ; +: .else ( ip nfa -- ip' ) -in ind-cr .name +in 4+ ; +: .do ( ip nfa -- ip' ) ind-cr .(word +in 2+ ?.then ; +: .loop ( ip nfa -- ip' ) -in .(word ind-cr 2+ ?.then ; + +5 Associative: branch-class + ' if , ' while , ' else , ' repeat , ' until , +Case: .branch-class + .if .else .else .repeat .repeat ; + +: .branch ( ip -- ip' ) + #branch @ branch-type @ 1 #branch +! + dup >name swap branch-class .branch-class ; + +\ *** Block No. 14, Hexblock e + +\ decompile Does> ;code 04Jul86 + +: .(;code ( IP - IP' f) + 2+ dup does? + IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ; + + + + + + + + + + + + +\ *** Block No. 15, Hexblock f + +\ classify word's output 01Jul86 + +Case: .execution-class + .clit .lit .branch .branch + .do .string .string .(;code + .string .do .loop + .loop .unnest .['] .compile + .default ; + + + + + + + + + +\ *** Block No. 16, Hexblock 10 + +\ decompile colon-definitions 04Jul86 + +: pass2 ( cfa -- ) #branch off >body + BEGIN ?.begin ?ind-cr dup @ execution-class .execution-class + dup 0= stop? or + UNTIL drop ; + +: .pfa ( cfa -- ) #spaces off +in dup pass1 pass2 ; + +: .immediate ( cfa - ) >name c@ dup + ?ind-cr 40 and IF ." IMMEDIATE " THEN + ?ind-cr 80 and IF ." RESTRICT" THEN ; + +: .: ( cfa - ) ." : " dup >name .name 3 spaces .pfa ; + + + +\ *** Block No. 17, Hexblock 11 + +\ display category of word 01Jul86 +external Defer (see internal + +: .does> ( cfa - ) ." DOES> " @ 1+ .pfa ; + +: .user-variable ( cfa - ) ." USER " dup >name dup .name + 3 spaces swap execute @ u. .name ." ! " ; + +: .defer ( cfa - ) + ." deferred " dup >name .name ." Is " >body @ (see ; + +: .other ( cfa - ) dup >name .name + dup @ over >body = IF drop ." is Code " exit THEN + dup @ does? IF .does> exit THEN + drop ." is unknown " ; + + +\ *** Block No. 18, Hexblock 12 + +\ decompiling variables and constants ks 22 dez 87 + +: .constant ( cfa - ) + dup >body @ u. ." CONSTANT " >name .name ; + +: .variable ( cfa - ) ." VARIABLE " + dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ; + +5 Associative: definition-class + ' quit @ , ' 0 @ , ' scr @ , ' base @ , + ' 'cold @ , + +Case: .definition-class + .: .constant .variable .user-variable + .defer .other ; + + +\ *** Block No. 19, Hexblock 13 + +\ Top level of Decompiler ks 20dez87 + +external + +: ((see ( cfa -) + #spaces off cr + dup dup @ + definition-class .definition-class .immediate ; + +' ((see Is (see + +Forth definitions + : see ' (see ; + + + + +\ *** Block No. 20, Hexblock 14 + + + + + + + + + + + + + + + + + + +\ *** Block No. 21, Hexblock 15 + + + + + + + + + + + + + + + + + + +\ *** Block No. 22, Hexblock 16 + + + + + + + + + + + + + + + + + + +\ *** Block No. 23, Hexblock 17 + + + + + + + + + + + + + + + + + + +\ *** Block No. 24, Hexblock 18 + + + + + + + + + + + + + + + + + + +\ *** Block No. 25, Hexblock 19 + + + + + + + + + + + + + + + + + + +\ *** Block No. 26, Hexblock 1a + + + + + + + + + + + + + + + + + + +\ *** Block No. 27, Hexblock 1b + + + + + + + + + + + + + + + + + + +\ *** Block No. 28, Hexblock 1c + + + + + + + + + + + + + + + + + + +\ *** Block No. 29, Hexblock 1d + + + + + + + + + + + + + + + + + + +\ *** Block No. 30, Hexblock 1e + + + + + + + + + + + + + + + + + + +\ *** Block No. 31, Hexblock 1f + + + + + + + + + + + + + + + + + + +\ *** Block No. 32, Hexblock 20 + + + + + + + + + + + + + + + + + + +\ *** Block No. 33, Hexblock 21 + + + + + + + + + + + + + + + + + + +\ *** Block No. 34, Hexblock 22 + + + + + + + + + + + + + + + + + + +\ *** Block No. 35, Hexblock 23 + + + + + + + + + + + + + + + + + + +\ *** Block No. 36, Hexblock 24 + + + + + + + + + + + + + + + + + + +\ *** Block No. 37, Hexblock 25 + + + + + + + + + + + + + + + + + + +\ *** Block No. 38, Hexblock 26 + + + + + + + + + + + + + + + + + + +\ *** Block No. 39, Hexblock 27 + + + + + + + + + + + + + + + + + + +\ *** Block No. 40, Hexblock 28 + + + + + + + + + + + + + + + + + + +\ *** Block No. 41, Hexblock 29 + + + + + + + + + + + + + + + + + + +\ *** Block No. 42, Hexblock 2a + + + + + + + + + + + + + + + + + + +\ *** Block No. 43, Hexblock 2b + + + + + + + + + + + + + + + + + + +\ *** Block No. 44, Hexblock 2c + + + + + + + + + + + + + + + + + + +\ *** Block No. 45, Hexblock 2d + + + + + + + + + + + + + + + + + + +\ *** Block No. 46, Hexblock 2e + + + + + + + + + + + + + + + + + + +\ *** Block No. 47, Hexblock 2f + + + + + + + + + + + + + + + + + + +\ *** Block No. 48, Hexblock 30 + + + + + + + + + + + + + + + + + + +\ *** Block No. 49, Hexblock 31 + + + + + + + + + + + + + + + + + + +\ *** Block No. 50, Hexblock 32 + + + + + + + + + + + + + + + + + + +\ *** Block No. 51, Hexblock 33 + + + + + + + + + + + + + + + + + + +\ *** Block No. 52, Hexblock 34 + + + + + + + + + + + + + + + + + + +\ *** Block No. 53, Hexblock 35 + + + + + + + + + + + + + + + + + + +\ *** Block No. 54, Hexblock 36 + + + + + + + + + + + + + + + + + + +\ *** Block No. 55, Hexblock 37 + + + + + + + + + + + + + + + + + + +\ *** Block No. 56, Hexblock 38 + + + + + + + + + + + + + + + + + + +\ *** Block No. 57, Hexblock 39 + + + + + + + + + + + + + + + + + + +\ *** Block No. 58, Hexblock 3a + + + + + + + + + + + + + + + + + + +\ *** Block No. 59, Hexblock 3b + + + + + + + + + + + + + + + + + + +\ *** Block No. 60, Hexblock 3c + + + + + + + + + + + + + + + + + + +\ *** Block No. 61, Hexblock 3d + + + + + + + + + + + + + + + + + + +\ *** Block No. 62, Hexblock 3e + + + + + + + + + + + + + + + + + + +\ *** Block No. 63, Hexblock 3f + + + + + + + + + + + + + + + + + + +\ *** Block No. 64, Hexblock 40 + + + + + + + + + + + + + + + + + + +\ *** Block No. 65, Hexblock 41 + + + + + + + + + + + + + + + + + + +\ *** Block No. 66, Hexblock 42 + + + + + + + + + + + + + + + + + + +\ *** Block No. 67, Hexblock 43 + + + + + + + + + + + + + + + + + + +\ *** Block No. 68, Hexblock 44 + + + + + + + + + + + + + + + + + + +\ *** Block No. 69, Hexblock 45 + + + + + + + + + + + + + + + + + + +\ *** Block No. 70, Hexblock 46 + + + + + + + + + + + + + + + + + + +\ *** Block No. 71, Hexblock 47 + + + + + + + + + + + + + + + + + + +\ *** Block No. 72, Hexblock 48 + + + + + + + + + + + + + + + + + + +\ *** Block No. 73, Hexblock 49 + + + + + + + + + + + + + + + + + + +\ *** Block No. 74, Hexblock 4a + + + + + + + + + + + + + + + + + + +\ *** Block No. 75, Hexblock 4b + + + + + + + + + + + + + + + + + + +\ *** Block No. 76, Hexblock 4c + + + + + + + + + + + + + + + + + + +\ *** Block No. 77, Hexblock 4d + + + + + + + + + + + + + + + + + + +\ *** Block No. 78, Hexblock 4e + + + + + + + + + + + + + + + + + + +\ *** Block No. 79, Hexblock 4f + + + + + + + + + + + + + + + + + + +\ *** Block No. 80, Hexblock 50 + + + + + + + + + + + + + + + + + + +\ *** Block No. 81, Hexblock 51 + + + + + + + + + + + + + + + + + + +\ *** Block No. 82, Hexblock 52 + + + + + + + + + + + + + + + + + + +\ *** Block No. 83, Hexblock 53 + + + + + + + + + + + + + + + + + + +\ *** Block No. 84, Hexblock 54 + + + + + + + + + + + + + + + + + + +\ *** Block No. 85, Hexblock 55 + + + + + + + + + + + + + + + + + + +\ *** Block No. 86, Hexblock 56 + + + + + + + + + + + + + + + + + + +\ *** Block No. 87, Hexblock 57 + + + + + + + + + + + + + + + + + + +\ *** Block No. 88, Hexblock 58 + + + + + + + + + + + + + + + + + + +\ *** Block No. 89, Hexblock 59 + + + + + + + + + + + + + + + + + + +\ *** Block No. 90, Hexblock 5a + + + + + + + + + + + + + + + + + + +\ *** Block No. 91, Hexblock 5b + + + + + + + + + + + + + + + + + + +\ *** Block No. 92, Hexblock 5c + + + + + + + + + + + + + + + + + + +\ *** Block No. 93, Hexblock 5d + + + + + + + + + + + + + + + + + + +\ *** Block No. 94, Hexblock 5e + + + + + + + + + + + + + + + + + + +\ *** Block No. 95, Hexblock 5f + + + + + + + + + + + + + + + + + + +\ *** Block No. 96, Hexblock 60 + + + + + + + + + + + + + + + + + + +\ *** Block No. 97, Hexblock 61 + + + + + + + + + + + + + + + + + + +\ *** Block No. 98, Hexblock 62 + + + + + + + + + + + + + + + + + + +\ *** Block No. 99, Hexblock 63 + + + + + + + + + + + + + + + + + + +\ *** Block No. 100, Hexblock 64 + + + + + + + + + + + + + + + + + + +\ *** Block No. 101, Hexblock 65 + + + + + + + + + + + + + + + + + + +\ *** Block No. 102, Hexblock 66 + + + + + + + + + + + + + + + + + + +\ *** Block No. 103, Hexblock 67 + + + + + + + + + + + + + + + + + + +\ *** Block No. 104, Hexblock 68 + + + + + + + + + + + + + + + + + + +\ *** Block No. 105, Hexblock 69 + + + + + + + + + + + + + + + + + + +\ *** Block No. 106, Hexblock 6a + + + + + + + + + + + + + + + + + + +\ *** Block No. 107, Hexblock 6b + + + + + + + + + + + + + + + + + + +\ *** Block No. 108, Hexblock 6c + + + + + + + + + + + + + + + + + + +\ *** Block No. 109, Hexblock 6d + + + + + + + + + + + + + + + + + + +\ *** Block No. 110, Hexblock 6e + + + + + + + + + + + + + + + + + + +\ *** Block No. 111, Hexblock 6f + + + + + + + + + + + + + + + + + + +\ *** Block No. 112, Hexblock 70 + + + + + + + + + + + + + + + + + + +\ *** Block No. 113, Hexblock 71 + + + + + + + + + + + + + + + + + + +\ *** Block No. 114, Hexblock 72 + + + + + + + + + + + + + + + + + + +\ *** Block No. 115, Hexblock 73 + + + + + + + + + + + + + + + + + + +\ *** Block No. 116, Hexblock 74 + + + + + + + + + + + + + + + + + + +\ *** Block No. 117, Hexblock 75 + + + + + + + + + + + + + + + + + + +\ *** Block No. 118, Hexblock 76 + + + + + + + + + + + + + + + + + + +\ *** Block No. 119, Hexblock 77 + + + + + + + + + + + + + + + + + + +\ *** Block No. 120, Hexblock 78 + + + + + + + + + + + + + + + + + + +\ *** Block No. 121, Hexblock 79 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/serial.fb b/8086/msdos/src/serial.fb similarity index 100% rename from 8086/msdos/serial.fb rename to 8086/msdos/src/serial.fb diff --git a/8086/msdos/src/serial.fth b/8086/msdos/src/serial.fth new file mode 100644 index 0000000..0eabc3b --- /dev/null +++ b/8086/msdos/src/serial.fth @@ -0,0 +1,418 @@ + +\ *** Block No. 0, Hexblock 0 + +\ Serial interface for IBM-PC using 8250 chip cas 11nov05 + + INCLUDE SERIAL.FB will load code for COM1, + 2 LOADFROM SERIAL.FB for COM2 + +Bytes recieved will be buffered in a 128 Byte deep Queue +by an interrupt Routine. + +The DTR Line will be used to signal that new bytes can be +recieved. +The Sender will recognize CTS, a full Handshake is implemented + +Xon/Xoff Protocoll using ^S/^Q is _not_ implemented. + +Sender: TX? ( -- f ) TX ( -- char ) +Empfänger: RX? ( -- f ) RX ( char -- ) + +\ *** Block No. 1, Hexblock 1 + +\ Driver for IBM-PC Serial card using 8250 cas 11nov05 + Onlyforth \needs Assembler 2 loadfrom asm.fb + +cr .( COM1: ) + +| $C 4 * Constant SINT@ \ absolute loc. of serial interrupt + + $3F8 >label Portadr + +| $10 Constant I_level \ 8259 priority + + 2 7 +thru + + + + + +\ *** Block No. 2, Hexblock 2 + +\ Driver for IBM-PC Serial card using 8250 cas 11nov05 + Onlyforth \needs Assembler 2 loadfrom asm.fb + +cr .( COM2: ) + +| $B 4 * Constant SINT@ \ absolute loc. of serial interrupt + + $2F8 >label Portadr + +| 8 Constant I_level \ 8259 priority + + 1 6 +thru + + + + + +\ *** Block No. 3, Hexblock 3 + +\ Driver for IBM-PC Serial card using 8250 ks 11 mai 88 +\ 3 .( 38.4 kbaud ) +\ &6 .( 19.2 kbaud ) + &12 .( 9.6 kbaud ) +\ &24 .( 4.8 kbaud ) +\ &96 .( 1200 baud ) + >label baud + + $20 >label I_ctrl $21 >label I_mask \ 8259 addresses + + Create Queue 0 , $80 allot +\ 0 1 2 130 byte address +\ | len | out |<-- 128 byte Queue -->| +\ len ::= number of characters queued +\ out ::= relativ address of next output character +\ (len+out)mod(128) ::= relative address of first empty byte + +\ *** Block No. 4, Hexblock 4 + +\ transmit to 8250 ks 11 dez 87 + + Code tx? ( -- f ) D push Portadr 5 + # D mov + D in D D xor $1020 # A and $1020 # A cmp + 0= ?[ D dec ]? Next end-code + + Code tx ( c -- ) D- A- xchg Portadr # D mov + D byte out D pop Next end-code + + Code -dtr D push Portadr 4 + # D mov + D byte in $1E # A- and D byte out D pop Next + end-code + + Code +dtr D push Portadr 4 + # D mov + D byte in 1 # A- or D byte out D pop Next + end-code + +\ *** Block No. 5, Hexblock 5 + +\ receive queue and interrupt service routine ks 11 dez 87 + + Label S_INT D push I push A push + Portadr # D mov D byte in A- D+ mov + Queue # I mov C: seg I ) A mov A- D- mov D- inc + C: seg D- I ) mov A+ A- add $7F # A and A I add + C: seg D+ 2 I D) mov $68 # D- cmp CS not + ?[ Portadr 4 + # D mov + D byte in $1E # A- and D byte out ]? \ -DTR + $20 # A- mov I_ctrl #) byte out \ EOI for 8259 + A pop I pop D pop iret + end-code + + + + + +\ *** Block No. 6, Hexblock 6 + +\ rx? rx ks 30 dez 87 + + Code rx? ( -- f ) D push D D xor + Queue #) D- mov D- D- or 0= + ?[ [[ D push Portadr 4 + # D mov \ +DTR + D byte in 9 # A- or D byte out D pop +swap ]? Next end-code + + Code rx ( -- 8b ) I W mov Queue # I mov + D push D D xor cli lods A- A- or 0= not + ?[ A+ C- mov A- dec A+ inc $7F # A+ and + A -2 I D) mov D- C+ mov C I add I ) D- mov + ]? sti W I mov $18 # A- cmp CS not ?] Next + end-code + + + +\ *** Block No. 7, Hexblock 7 + +\ Serial initialization ks 25 apr 86 + +| Code S_init D push D: push A A xor A D: mov C: A mov + SINT@ # W mov S_INT # W ) mov A 2 W D) mov D: pop + Portadr 3 + # D mov $80 # A- mov D byte out \ DLAB = 1 + 2 # D sub baud # A mov A- A+ xchg D byte out + D dec A- A+ xchg D byte out \ baudrate + 3 # D add $A07 # A mov D out \ 8bit, noP, +RTS +OUT + 2 # D sub 1 # A- mov D byte out \ +rxINT + I_mask #) byte in I_level Forth not Assembler # A- and + I_mask #) byte out D pop Next + end-code + + + + + +\ *** Block No. 8, Hexblock 8 + +\ init bye ks 11 dez 87 + \needs init : init ; + + : init init Queue off S_init ; init + + : bye 0 [ Portadr 1+ ] Literal pc! \ -rxINT + 0 [ Portadr 4 + ] Literal pc! \ -dtr/-rts/-out2 + I_mask pc@ I_level or I_mask pc! bye ; + + + + + + + + + +\ *** Block No. 9, Hexblock 9 + +\ dumb terminal via 8250 ks 11 dez 87 + + Variable Fkeys Fkeys on + +| : ?rx ( -- ) pause rx? 0=exit rx + Fkeys @ 0= IF emit ?cr exit THEN + #LF case? IF cr exit THEN + #CR case? IF Row 0 at exit THEN + #BS case? IF del exit THEN emit ; + +| : ?tx ( c -- ) BEGIN ?rx tx? UNTIL tx ; + + : dumb BEGIN BEGIN ?rx key? UNTIL key + $1B case? IF -dtr exit THEN ?tx REPEAT ; + + + +\ *** Block No. 10, Hexblock a + + + + + + + + + + + + + + + + + + +\ *** Block No. 11, Hexblock b + + + + + + + + + + + + + + + + + + +\ *** Block No. 12, Hexblock c + + + + + + + + + + + + + + + + + + +\ *** Block No. 13, Hexblock d + + + + + + + + + + + + + + + + + + +\ *** Block No. 14, Hexblock e + + + + + + + + + + + + + + + + + + +\ *** Block No. 15, Hexblock f + + + + + + + + + + + + + + + + + + +\ *** Block No. 16, Hexblock 10 + + + + + + + + + + + + + + + + + + +\ *** Block No. 17, Hexblock 11 + + + + + + + + + + + + + + + + + + +\ *** Block No. 18, Hexblock 12 + + + + + + + + + + + + + + + + + + +\ *** Block No. 19, Hexblock 13 + + + + + + + + + + + + + + + + + + +\ *** Block No. 20, Hexblock 14 + + + + + + + + + + + + + + + + + + +\ *** Block No. 21, Hexblock 15 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/stream.fb b/8086/msdos/src/stream.fb similarity index 100% rename from 8086/msdos/stream.fb rename to 8086/msdos/src/stream.fb diff --git a/8086/msdos/src/stream.fth b/8086/msdos/src/stream.fth new file mode 100644 index 0000000..9b5e660 --- /dev/null +++ b/8086/msdos/src/stream.fth @@ -0,0 +1,209 @@ + +\ *** Block No. 0, Hexblock 0 + +\ cas 11nov05 +The word STREAM>BLK convert a sequiential file with CR lineend +into a screenfile with 64 Chars per line. + +Example: +FORTH.TXT is a Forth-Sourceode in a sequiential file + +MAKEFILE FORTH.FB will create an empty screenfile +FROM FORTH.TXT will define the inputfile +STREAM>BLK will convert FORTH.TXT into FORTH.FB + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ ks 06 jul 88 + Onlyforth Dos also + +| : in ( -- fcb ) fromfile @ ; +| : out ( -- fcb ) isfile @ ; + +| : padd ( cnt -- ) dup IF c/l mod ?dup 0=exit THEN + c/l swap ?DO BL out fputc LOOP ; + +| : skipctrl ( -- char ) + BEGIN in fgetc dup #cr = ?exit + dup 0 BL uwithin 0=exit drop REPEAT ; + + 2 3 thru + + Onlyforth + +\ *** Block No. 2, Hexblock 2 + +\ ks 06 jul 88 + +| : lastline? ( -- f ) false 0 skipctrl + BEGIN -1 case? IF ?dup IF padd THEN 0= exit THEN + #cr case? 0= WHILE out fputc 1+ in fgetc REPEAT + padd ; + + : stream>blk open out freset + out f.size 2@ out fseek \ append to end of file + BEGIN lastline? stop? or UNTIL close out fclose ; + + + + + + + +\ *** Block No. 3, Hexblock 3 + +\ absolute blocks in file eintragen ks 11 aug 87 + +| : >stream ( blk -- ) + fromfile @ (block b/blk bounds + DO ds@ I C/L -trailing out lfputs + #cr out fputc #lf out fputc C/L +LOOP ; + + : blk>stream ( from.blk to.blk -- ) emptyfile + 1+ swap DO I >stream LOOP close ; + + + + + + + + +\ *** Block No. 4, Hexblock 4 + + + + + + + + + + + + + + + + + + +\ *** Block No. 5, Hexblock 5 + + + + + + + + + + + + + + + + + + +\ *** Block No. 6, Hexblock 6 + + + + + + + + + + + + + + + + + + +\ *** Block No. 7, Hexblock 7 + + + + + + + + + + + + + + + + + + +\ *** Block No. 8, Hexblock 8 + + + + + + + + + + + + + + + + + + +\ *** Block No. 9, Hexblock 9 + + + + + + + + + + + + + + + + + + +\ *** Block No. 10, Hexblock a + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/system.cfg b/8086/msdos/src/system.cfg similarity index 100% rename from 8086/msdos/system.cfg rename to 8086/msdos/src/system.cfg diff --git a/8086/msdos/tasker.fb b/8086/msdos/src/tasker.fb similarity index 100% rename from 8086/msdos/tasker.fb rename to 8086/msdos/src/tasker.fb diff --git a/8086/msdos/src/tasker.fth b/8086/msdos/src/tasker.fth new file mode 100644 index 0000000..1552944 --- /dev/null +++ b/8086/msdos/src/tasker.fth @@ -0,0 +1,95 @@ + +\ *** Block No. 0, Hexblock 0 + +\ ks 22 dez 87 +The multitasker is a simple yet powerful round robin scheme +with explicit task switching. This has the major advantage +that the system switches tasks only in known states. +Hence the difficulties in synchronizing tasks and locking +critical portions of code are greatly minimized or simply +do not exist at all. + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ Multitasker loadscreen ks 03 apr 88 + Onlyforth \needs Assembler 2 loadfrom asm.scr + + Code stop $E990 # U ) mov ' pause @ # jmp end-code + + : singletask [ ' noop @ ] Literal ['] pause ! ; + : multitask [ ' pause @ ] Literal ['] pause ! ; + + 1 3 +thru .( Multitasker geladen) cr + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ pass activate ks 1 jun 87 + + : pass ( n0 ... nr-1 Taddr r -- ) +BEGIN [ rot ] + swap $E9CD over ! \ awake Task + r> -rot \ Stack: IP r addr + 8 + >r \ s0 of Task + r@ 2+ @ swap \ Stack: IP r0 r + 2+ 2* \ bytes on Taskstack incl. r0 & IP + r@ @ over - \ new SP + dup r> 2- ! \ into Ssave + swap bounds ?DO I ! 2 +LOOP ; restrict + + : activate ( Taddr -- ) 0 \ [ ' pass >body ] Literal >r ; +[ -rot ] REPEAT ; restrict + + +\ *** Block No. 3, Hexblock 3 + +( Building a Task ks 8 may 84 ) + +| : taskerror ( string -- ) standardi/o singletask + ." Task error: " count type multitask stop ; + + : sleep ( addr -- ) $90 swap c! ; + + : wake ( addr -- ) $CD swap c! ; + + : rendezvous ( semaphoraddr -- ) + dup unlock pause lock ; + + + + + + +\ *** Block No. 4, Hexblock 4 + +\ Task ks 1 jun 87 + + : Task ( rlen slen -- ) clear + 0 Constant here 2- >r \ addr of task constant + here -rot \ here for Task dp + even allot even \ allot dictionary area + here r> ! \ set task constant addr + up@ here $100 cmove \ init user area + here $E990 , \ JMP opcode + up@ 2+ dup dup @ + here - , + 2dup - 2- swap ! \ link task + 0 , dup 2- dup , , \ ssave and s0 + 2dup + , \ here + rlen = r0 + rot , \ dp + under + dp ! 0 , \ allot rstack + ['] taskerror [ ' errorhandler >body c@ ] Literal rot + ! ; diff --git a/8086/msdos/timer.fb b/8086/msdos/src/timer.fb similarity index 100% rename from 8086/msdos/timer.fb rename to 8086/msdos/src/timer.fb diff --git a/8086/msdos/src/timer.fth b/8086/msdos/src/timer.fth new file mode 100644 index 0000000..aa37c45 --- /dev/null +++ b/8086/msdos/src/timer.fth @@ -0,0 +1,95 @@ + +\ *** Block No. 0, Hexblock 0 + +\ ks 22 dez 87 + +The timer utilizes the memory cell at $46C that is incremented +by an interrupt. A couple of words allow this timer to be +used for time delays. + +time-of-day and date are accessed via MS-DOS calls. + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ BIMomat BIOS Timer ks 03 apr 88 + Onlyforth \needs Assembler 2 loadfrom asm.scr + + $46C >label Counter + +\ 1193180 / 65536 = 18,206 Hz + + 1 2 +thru .( Timer geladen) cr + + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ BIMomat BIOS Timer ks 22 dez 87 + + Code ticks ( -- n ) D push D: C mov A A xor + A D: mov Counter #) D mov C D: mov Next end-code + + : timeout? ( ticks -- ticks f ) pause dup ticks - 0< ; + + : till ( n -- ) BEGIN timeout? UNTIL drop ; + + : time ( n -- time ) ticks + ; + + : wait ( n -- ) time till ; + + : seconds ( sec -- ticks ) &18206 &1000 */ ; + + : minutes ( min -- ticks ) &1092 * ; + +\ *** Block No. 3, Hexblock 3 + +\ MS-DOS time and date ks 22 dez 87 + + Code date@ ( -- dd mm yy ) + D push $2A # A+ mov $21 int A A xor D+ A- xchg + D push A push C D mov &1900 # D sub Next + end-code + + Code time@ ( -- ss mm hh ) + D push $2C # A+ mov $21 int D+ D- mov 0 # D+ mov + D push D+ D- mov C+ D- xchg C push Next + end-code + + + + + + +\ *** Block No. 4, Hexblock 4 + + + + + + + + + + + + + + + + + diff --git a/8086/msdos/tools.fb b/8086/msdos/src/tools.fb similarity index 100% rename from 8086/msdos/tools.fb rename to 8086/msdos/src/tools.fb diff --git a/8086/msdos/src/tools.fth b/8086/msdos/src/tools.fth new file mode 100644 index 0000000..668f89d --- /dev/null +++ b/8086/msdos/src/tools.fth @@ -0,0 +1,247 @@ + +\ *** Block No. 0, Hexblock 0 + +\ ks 22 dez 87 + +Some simple tools for debugging. +A state-of-the-art, interactive single step tracer +and a couple of tools for decompiling and dumping + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ Programming-Tools word set cas 19july2020 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + Vocabulary Tools Tools also definitions + + 1 11 +thru Onlyforth .( Tools loaded ) cr + + + + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ trace - next ks 11 jun 87 + +| Variable nest? nest? off + + Label tracenext 0 # nest? #) byte cmp 0= + ?[ $5555 # I cmp here 2- >label (ip >= + ?[ [[ swap lods A W xchg W ) jmp ]? + $5555 # I cmp here 2- >label ip) CS ?] + ][ 0 # nest? #) byte mov + ]? $5555 # W mov here 2- >label >tracing W ) jmp + end-code + +| (ip Constant + +| : (debug ( addr -- ) dup ! ; + +\ *** Block No. 3, Hexblock 3 + +\ install Tracer ks 11 jun 87 + + Label (do-trace next-link # W mov D push + $E9 # A- mov tracenext 1+ # C mov + [[ W ) W mov W W or 0= not + ?[[ A- -4 W D) mov C D mov W D sub + D -3 W D) mov ]]? D pop ret end-code + + Code do-trace (do-trace # call Next end-code + + ' end-trace Alias end-trace + +| Code (step (do-trace # call + R ) I mov R inc R inc lods A W xchg W ) jmp + +| Create: nextstep (step ; + +\ *** Block No. 4, Hexblock 4 + +\ tracer display ks 20 sep 88 + +| Variable nest# nest# off + +| Variable 'ip 'ip off + +| Create: -nest r> ip> ! r> r0 ! r> dup #tib ! + rp@ over tib swap cmove rp@ + rp! + r> Is parser r> adr 'quit ! r> >in ! + r> blk ! r> state ! r> output ! r> input ! ; + + +\ *** Block No. 5, Hexblock 5 + +\ tracer display ks 16 sep 88 + +| : tracing end-trace nest? @ + IF r> r ip> @ >r -nest >r >r + 1 nest# +! r@ 2- (debug nest? off THEN r@ 'ip ! + nextstep >r input @ >r output @ >r state @ >r + blk @ >r >in @ >r adr 'quit @ >r adr parser @ >r + tib #tib @ rp@ over - under rp! cmove #tib @ >r + r0 @ >r rp@ r0 ! standardi/o + cr nest# @ spaces 'ip @ dup 5 u.r @ dup 5 u.r + 2 spaces >name .name &30 nest# @ + tab .s + $20 allot ['] oneline Is 'quit quit ; + ' tracing >tracing ! + + + + +\ *** Block No. 6, Hexblock 6 + +\ test traceability ks 07 dez 87 + +| : traceable ( cfa -- cfa' ) recursive dup @ + [ ' : @ ] Literal case? ?exit + [ ' key @ ] Literal case? IF >body c@ Input @ + + @ traceable exit THEN + [ ' type @ ] Literal case? IF >body c@ Output @ + + @ traceable exit THEN + [ ' r/w @ ] Literal case? IF >body @ traceable exit THEN + c@ $E9 = IF @ 1+ exit THEN \ Does> word + >name .name ." can't be DEBUGged" quit ; + + + + + + +\ *** Block No. 7, Hexblock 7 + +\ user words for tracing ks 16 sep 88 +| : do_debug ( addr -- ) + traceable (debug nest? off nest# off do-trace ; + + : nest \ trace next high-level word executed + 'ip @ @ traceable drop nest? on ; + + : unnest \ ends tracing of actual word + off ; unnest \ clears trap range + + : endloop \ stop tracing loop + 'ip @ r do_debug r> execute end-trace unnest ; + +\ *** Block No. 8, Hexblock 8 + +\ tools for decompiling, interactive use ks 04 jul 87 + +| : ?: ( addr -- addr ) dup 5 u.r ." :" ; +| : @? ( addr -- addr ) dup @ 6 u.r ; +| : c? ( addr -- addr ) dup c@ 3 .r ; +| : end $28 tab ; + + : s ( addr1 -- addr2 ) + ?: 3 spaces c? 2 spaces count 2dup type + even end ; + : n ( addr1 -- addr2 ) + ?: @? 2 spaces dup @ >name .name 2+ end ; + : d ( addr1 n -- addr2 ) 2dup swap ?: 3 spaces + swap 0 DO c? 1+ LOOP 2 spaces -rot type end ; + : l ( addr1 -- addr2 ) ?: 6 spaces @? 2+ end ; + : c ( addr1 -- addr2 ) 1 d end ; + : b ( addr1 -- addr2 ) ?: @? dup @ over + 6 u.r 2+ end ; + +\ *** Block No. 9, Hexblock 9 + +\ often times ks 29 jun 87 + Onlyforth + + : often stop? ?exit >in off ; + +| Variable #times #times off + + : times ( n -- ) ?dup + IF #times @ 2+ u< stop? or + IF #times off exit THEN 1 #times +! + ELSE stop? ?exit + THEN >in off ; + + + + + +\ *** Block No. 10, Hexblock a + +\ dump ks 04 jul 87 + + : dump ( addr n -- ) base push hex + bounds ?DO cr I $10 [ Tools ] d [ Forth ] drop + stop? IF LEAVE THEN $10 +LOOP ; + +| : ld ( seg:addr -- ) + over 4 u.r ." :" dup 0 <# # # # # #> type + 3 spaces ds@ pad $10 lmove pad $10 bounds + DO I c@ 3 u.r LOOP 2 spaces pad $10 type ; + + : ldump ( seg:addr quan -- ) base push hex + 0 DO cr 2dup ld $10 + stop? IF LEAVE THEN + $10 +LOOP 2drop ; + + + +\ *** Block No. 11, Hexblock b + +\ N>R NR> cr + +: N>R ( i * n +n -- ) ( R: -- j * x +n ) +\ Transfer N items and count to the return stack. + DUP BEGIN DUP WHILE + ROT R> SWAP >R >R + 1- + REPEAT DROP R> SWAP >R >R ; + +: NR> ( -- i * x +n ) ( R: j * x +n -- ) +\ Pull N items and count off the return stack. + R> R> SWAP >R DUP + BEGIN DUP WHILE + R> R> SWAP >R -ROT + 1- + REPEAT DROP ; + +\ *** Block No. 12, Hexblock c + +\ ? +: ? ( a-addr -- ) +\ Display the value stored at a-addr. + @ . ; + + + + + + + + + + + + diff --git a/8086/msdos/volks4th.sys b/8086/msdos/src/volks4th.sys similarity index 100% rename from 8086/msdos/volks4th.sys rename to 8086/msdos/src/volks4th.sys From 1f698d6638b4962c093fde596f7eb8adcb8730ea Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 6 Feb 2022 11:19:10 +0100 Subject: [PATCH 05/17] Decouple stream include from isfile. This allows the free use of USE within a .fth stream source file. --- 8086/msdos/src/include.fb | 2 +- 8086/msdos/src/include.fth | 14 +++++++------- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/8086/msdos/src/include.fb b/8086/msdos/src/include.fb index 2a80fc0..622ad44 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 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 +\ 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 06feb22 variable incfile : freadline ( -- eof ) tib /tib bounds DO incfile @ 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 incfile @ 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 06feb22 : 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 incfile push isfile@ incfile ! 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 6b32681..81b7720 100644 --- a/8086/msdos/src/include.fth +++ b/8086/msdos/src/include.fth @@ -58,23 +58,23 @@ \ *** Block No. 3, Hexblock 3 -\ freadline probe-for-fb phz 06jan22 +\ freadline probe-for-fb phz 06feb22 + variable incfile : freadline ( -- eof ) tib /tib bounds DO - isfile@ fgetc dup eolf? under 0< IF I c! ELSE drop THEN + incfile @ 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 @ ; + BEGIN incfile @ fgetc eolf? 1+ UNTIL tibeof @ ; - : probe-for-fb ( -- flag ) +| : 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 \ save/restoretib phz 16jan22 @@ -96,7 +96,7 @@ \ *** Block No. 5, Hexblock 5 -\ interpret-via-tib include phz 16jan22 +\ interpret-via-tib include phz 06feb22 : interpret-via-tib BEGIN freadline >r .status >in off interpret @@ -105,6 +105,7 @@ : include ( -- ) pushfile use cr file? probe-for-fb isfile@ freset IF 1 load close exit THEN + incfile push isfile@ incfile ! savetib >r interpret-via-tib close r> restoretib ; : (stashquit stash[ stash> ! (quit ; @@ -112,7 +113,6 @@ ' stashrestore IS 'restart - \ *** Block No. 6, Hexblock 6 \ \ phz 16jan22 From 5e0dafaa161cb7c92d2217f4a9484f4497cc4a00 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 6 Feb 2022 23:11:22 +0100 Subject: [PATCH 06/17] Reopen stream include file if it was closed, e.g. by a FLUSH. --- 8086/msdos/src/include.fb | 2 +- 8086/msdos/src/include.fth | 39 ++++++++++++++++++++++++++++---------- 2 files changed, 30 insertions(+), 11 deletions(-) diff --git a/8086/msdos/src/include.fb b/8086/msdos/src/include.fb index 622ad44..cea4e15 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 06feb22 variable incfile : freadline ( -- eof ) tib /tib bounds DO incfile @ 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 incfile @ 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 06feb22 : 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 incfile push isfile@ incfile ! 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 06feb22 1 6 +thru \ fib /fib #fib eolf? phz 06feb22 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 ; \ incfile incpos inc-fgetc phz 06feb22 variable incfile variable incpos 2 allot : inc-fgetc ( -- c ) incfile @ f.handle @ 0= IF incpos 2@ incfile @ fseek THEN incfile @ fgetc incpos 2@ 1. d+ incpos 2! ; \ freadline probe-for-fb phz 06feb22 : freadline ( -- eof ) tib /tib bounds DO inc-fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr BEGIN inc-fgetc eolf? 1+ UNTIL tibeof @ ; | : probe-for-fb ( -- flag ) \ 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 06feb22 : 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 incfile push isfile@ incfile ! incpos push incpos off incpos 2+ dup push off 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 81b7720..0f5c3f4 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 16jan22 +\ load screen phz 06feb22 - 1 5 +thru + 1 6 +thru @@ -39,7 +39,7 @@ \ *** Block No. 2, Hexblock 2 -\ fib /fib #fib eolf? phz 06jan22 +\ fib /fib #fib eolf? phz 06feb22 context @ dos also context ! $50 constant /tib @@ -58,24 +58,43 @@ \ *** Block No. 3, Hexblock 3 -\ freadline probe-for-fb phz 06feb22 +\ incfile incpos inc-fgetc phz 06feb22 + variable incfile + variable incpos 2 allot + + : inc-fgetc ( -- c ) + incfile @ f.handle @ 0= IF + incpos 2@ incfile @ fseek THEN + incfile @ fgetc + incpos 2@ 1. d+ incpos 2! ; + + + + + + + +\ *** Block No. 4, Hexblock 4 + +\ freadline probe-for-fb phz 06feb22 : freadline ( -- eof ) tib /tib bounds DO - incfile @ fgetc dup eolf? under 0< IF I c! ELSE drop THEN + inc-fgetc dup eolf? under 0< IF I c! ELSE drop THEN 0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN LOOP /tib #tib ! ." warning: line exteeds max " /tib . cr ." extra chars ignored" cr - BEGIN incfile @ fgetc eolf? 1+ UNTIL tibeof @ ; + BEGIN inc-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 + +\ *** Block No. 5, Hexblock 5 \ save/restoretib phz 16jan22 @@ -94,7 +113,7 @@ r> #tib ! >in off ; -\ *** Block No. 5, Hexblock 5 +\ *** Block No. 6, Hexblock 6 \ interpret-via-tib include phz 06feb22 @@ -106,14 +125,14 @@ pushfile use cr file? probe-for-fb isfile@ freset IF 1 load close exit THEN incfile push isfile@ incfile ! + incpos push incpos off incpos 2+ dup push off savetib >r interpret-via-tib close r> restoretib ; : (stashquit stash[ stash> ! (quit ; : stashrestore ['] (stashquit IS 'quit ; ' stashrestore IS 'restart - -\ *** Block No. 6, Hexblock 6 +\ *** Block No. 7, Hexblock 7 \ \ phz 16jan22 From 64ed332b1237570d9eaa813f5c4eb8b88a1802a0 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Tue, 1 Mar 2022 14:02:46 +0100 Subject: [PATCH 07/17] First build of v4th.com with compile log file written and checked at the end of the Makefile recipe. Also introduces a prebuilt metacompiler metafile.com with integrated fth file include --- 8086/msdos/Makefile | 29 +++++++++++-- 8086/msdos/src/mk-meta.fth | 24 +++++++++++ 8086/msdos/src/mk-v4th.fth | 19 +++++++++ 8086/msdos/tests/log2file.fb | 2 +- 8086/msdos/tests/log2file.fth | 72 ++++++++++++++++++++++++-------- 8086/msdos/tests/logapp.fth | 78 +++++++++++++++++++++++++++++++++++ 8086/msdos/tests/preptest.fb | 1 + 8086/msdos/tests/preptest.fth | 38 +++++++++++++++++ 8 files changed, 241 insertions(+), 22 deletions(-) create mode 100644 8086/msdos/src/mk-meta.fth create mode 100644 8086/msdos/src/mk-v4th.fth create mode 100644 8086/msdos/tests/logapp.fth create mode 100644 8086/msdos/tests/preptest.fb create mode 100644 8086/msdos/tests/preptest.fth diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index 7dad4fe..8fc01cd 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -17,13 +17,29 @@ clean: *.log: emulator/run-in-dosbox.sh -# TODO: Make v4th.log contain something and check its contents -v4th.com v4th.log: volks4th.com src/kernel.fb tests/log2file.fb +metafile.com: v4thfile.com src/meta.fb src/mk-meta.fth tests/log2file.fb + rm -f METAFILE.COM OUTPUT.LOG + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ + v4thfile.com "include mk-meta.fth" + dos2unix -n OUTPUT.LOG metafile.log + grep -F 'Metacompiler saved as metafile.com' metafile.log + +v4th.com: metafile.com src/meta.fb src/mk-v4th.fth + rm -f v4th.com V4TH.COM OUTPUT.LOG + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ + metafile.com "include mk-v4th.fth" + dos2unix -n OUTPUT.LOG v4th.log + mv V4TH.COM v4th.com + grep -F 'new kernel written as v4th.com' v4th.log + +# o4th for old volks4th - the new v4th is built with precompiled +# metacompiler metafile.com and mk-v4th.fth which writes a compile log. +o4th.com o4th.log: volks4th.com src/kernel.fb rm -f FORTH.COM forth.com v4th.com FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ volks4th.com "include kernel.fb" - dos2unix -n OUTPUT.LOG v4th.log - mv FORTH.COM v4th.com + dos2unix -n OUTPUT.LOG o4th.log + mv FORTH.COM o4th.com v4thfile.com: volks4th.com src/include.fb src/v4thfile.fb \ emulator/run-in-dosbox.sh @@ -36,6 +52,11 @@ logtest.log: volks4th.com tests/log2file.fb tests/logtest.fb FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh volks4th.com "include logtest.fb" dos2unix -n OUTPUT.LOG $@ +logappendtest.log: v4thfile.com tests/logapp.fth + rm -f OUTPUT.LOG + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh v4thfile.com "include logapp.fth" + dos2unix -n OUTPUT.LOG $@ + prepsrcs = asm.fb extend.fb multi.vid dos.fb include.fb incltest.log: \ diff --git a/8086/msdos/src/mk-meta.fth b/8086/msdos/src/mk-meta.fth new file mode 100644 index 0000000..c052275 --- /dev/null +++ b/8086/msdos/src/mk-meta.fth @@ -0,0 +1,24 @@ + + include log2file.fth + logopen output.log + + Onlyforth \ \needs Assembler 2 loadfrom asm.fb + + : c+! ( 8b addr -- ) dup c@ rot + swap c! ; + + ' find $22 + @ Alias found + + : search ( string 'vocab -- acf n / string ff ) + dup @ [ ' Forth @ ] Literal - Abort" no vocabulary" + >body (find IF found exit THEN false ; + + use meta.fb + 3 &27 thru Onlyforth + + logclose + savesystem metafile.com + logreopen + + cr .( Metacompiler saved as metafile.com) cr + + logclose diff --git a/8086/msdos/src/mk-v4th.fth b/8086/msdos/src/mk-v4th.fth new file mode 100644 index 0000000..6c5c95f --- /dev/null +++ b/8086/msdos/src/mk-v4th.fth @@ -0,0 +1,19 @@ + + logopen output.log + + Onlyforth + + 2 loadfrom META.fb + use kernel.fb + + new v4th.com Onlyforth Target definitions + + 4 &111 thru \ Standard 8088-System + + logclose + flush \ close n4th.com + logreopen + + cr .( new kernel written as v4th.com) cr + + logclose diff --git a/8086/msdos/tests/log2file.fb b/8086/msdos/tests/log2file.fb index 50cdd7d..4223291 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 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 +\ logging to a text file phz 03jan22 \ load screen phz 25feb22 Code m+! ( 16b addr -- ) D W mov W inc W inc A pop A W ) add CS ?[ W dec W dec W ) inc ]? D pop Next end-code : (blk blk @ 0= IF ascii ) parse 2drop THEN ; (blk 1 2 +thru ( ) \ log-type log-emit log-cr phz 25feb22 context @ dos also context ! \ vocabulary log dos also log definitions file logfile variable logfcb variable logpos 0 , : log-type ( addr count -- ) dup logpos m+! 2dup (type ds@ -rot logfcb @ lfputs ; : log-emit ( char -- ) 1 logpos m+! dup (emit logfcb @ fputc ; : log-cr ( -- ) 2 logpos m+! (cr #cr logfcb @ fputc #lf logfcb @ fputc ; \ alsologtofile logopen logclose logreopen phz 25feb22 Output: alsologtofile log-emit log-cr log-type (del (page (at (at? ; : logopen ( -- ) isfile push logpos dup 2+ off off logfile make isfile@ dup freset logfcb ! alsologtofile ; : logclose ( -- ) display logfcb @ fclose ; : logreopen ( -- ) logfcb @ freset logpos 2@ logfcb @ fseek alsologtofile ; \ phz 25feb22 \ No newline at end of file diff --git a/8086/msdos/tests/log2file.fth b/8086/msdos/tests/log2file.fth index 8f246c7..dffcb3f 100644 --- a/8086/msdos/tests/log2file.fth +++ b/8086/msdos/tests/log2file.fth @@ -20,7 +20,13 @@ \ *** Block No. 1, Hexblock 1 -\ load screen phz 16jan22 +\ load screen phz 25feb22 + + Code m+! ( 16b addr -- ) + D W mov W inc W inc A pop A W ) add + CS ?[ W dec W dec W ) inc ]? + D pop Next end-code + : (blk blk @ 0= IF ascii ) parse 2drop THEN ; @@ -31,42 +37,74 @@ - - - - - - \ *** Block No. 2, Hexblock 2 -\ log-type log-emit log-cr alsologtofile phz 04jan22 +\ log-type log-emit log-cr phz 25feb22 context @ dos also context ! \ vocabulary log dos also log definitions file logfile variable logfcb + variable logpos 0 , - : log-type 2dup (type ds@ -rot logfcb @ lfputs ; + : log-type ( addr count -- ) dup logpos m+! + 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? ; + : log-emit ( char -- ) 1 logpos m+! + dup (emit logfcb @ fputc ; + : log-cr ( -- ) 2 logpos m+! + (cr #cr logfcb @ fputc #lf logfcb @ fputc ; \ *** Block No. 3, Hexblock 3 -\ logopen logclose phz 11jan22 +\ alsologtofile logopen logclose logreopen phz 25feb22 + +Output: alsologtofile + log-emit log-cr log-type (del (page (at (at? ; : logopen ( -- ) - isfile push + isfile push logpos dup 2+ off off logfile make isfile@ dup freset logfcb ! alsologtofile ; : logclose ( -- ) display logfcb @ fclose ; + : logreopen ( -- ) + logfcb @ freset logpos 2@ logfcb @ fseek + alsologtofile ; + + +\ *** Block No. 4, Hexblock 4 + +\ phz 25feb22 + + + + + + + + + + + + + + + + +\ *** Block No. 5, Hexblock 5 + + + + + + + + + + diff --git a/8086/msdos/tests/logapp.fth b/8086/msdos/tests/logapp.fth new file mode 100644 index 0000000..39cdc5b --- /dev/null +++ b/8086/msdos/tests/logapp.fth @@ -0,0 +1,78 @@ + + +\ Experimental code and test for text logs that can be closed +\ and reopened for appending. +\ Already integrated into log2file.fb/.fth +\ Yet to be done: A more permanent test for m+! +\ and an extension of logtest.fb/.fth to also cover the reopen feature. + + +\ Code +! ( 16b addr -- ) +\ D W mov A pop A W ) add D pop Next end-code + + Code m+! ( 16b addr -- ) + D W mov W inc W inc A pop A W ) add + CS ?[ W dec W dec W ) inc ]? + D pop Next end-code + + + + + +\ *** 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 + variable logpos 0 , + + : log-type + dup logpos m+! + 2dup (type ds@ -rot logfcb @ lfputs ; + + : log-emit + 1 logpos m+! + dup (emit logfcb @ fputc ; + + : log-cr + 2 logpos m+! + (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 11jan22 + + : logopen ( -- ) + isfile push logpos dup 2+ off off + logfile make isfile@ dup freset logfcb ! + alsologtofile ; + + : logclose ( -- ) display logfcb @ fclose ; + + : logreopen ( -- ) + logfcb @ freset logpos 2@ logfcb @ fseek + alsologtofile ; + + logopen output.log + .( logtest started) cr + logpos @ cr u. cr + .( logtest interrupted) cr + logclose + logreopen + create 2v 4 allot + hex + 12345. 2v 2! + 1 2v m+! + 2v 2@ d. cr + 1ffff. 2v 2! + 1 2v m+! + 2v 2@ d. cr + .( logtest done) cr + logclose diff --git a/8086/msdos/tests/preptest.fb b/8086/msdos/tests/preptest.fb new file mode 100644 index 0000000..dd70b90 --- /dev/null +++ b/8086/msdos/tests/preptest.fb @@ -0,0 +1 @@ +\ include file to bundle what test-*.fth need phz 30jan22\ on top of kernel.com \ loadscreen to prepare kernel.com for test-*.fth phz 31jan22 include multi.vid \ include asm.fb \ include extend.fb : arguments ( n -- ) depth 1- > Error" too few params" ; : blank ( addr count -- ) bl fill ; include dos.fb include include.fb include log2file.fb \ No newline at end of file diff --git a/8086/msdos/tests/preptest.fth b/8086/msdos/tests/preptest.fth new file mode 100644 index 0000000..7d0e4bc --- /dev/null +++ b/8086/msdos/tests/preptest.fth @@ -0,0 +1,38 @@ + +\ *** Block No. 0, Hexblock 0 + +\ include file to bundle what test-*.fth need phz 30jan22 +\ on top of kernel.com + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen to prepare kernel.com for test-*.fth phz 31jan22 + + include multi.vid +\ include asm.fb +\ include extend.fb + + : arguments ( n -- ) + depth 1- > Error" too few params" ; + : blank ( addr count -- ) bl fill ; + + include dos.fb + include include.fb + include log2file.fb + + + From 0ed53b9f5f2c51ea33d9f3b919dda6bf4aac8664 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Fri, 4 Mar 2022 23:25:37 +0100 Subject: [PATCH 08/17] Move kernel.fb screen 111 to mk-v4th.fth so no thru or +thru from kernel.fb is used anymore in building v4th.com --- 8086/msdos/src/mk-v4th.fth | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/8086/msdos/src/mk-v4th.fth b/8086/msdos/src/mk-v4th.fth index 6c5c95f..a1c5f6e 100644 --- a/8086/msdos/src/mk-v4th.fth +++ b/8086/msdos/src/mk-v4th.fth @@ -8,7 +8,23 @@ new v4th.com Onlyforth Target definitions - 4 &111 thru \ Standard 8088-System + 4 &110 thru \ Standard 8088-System + + &112 &146 thru \ MS-DOS interface + + : forth-83 ; \ last word in Dictionary + + 0 ' limit >body ! $DFF6 s0 ! $E77C r0 ! + s0 @ s0 2- ! here dp ! + + Host tudp @ Target udp ! + Host tvoc-link @ Target voc-link ! + Host tnext-link @ Target next-link ! + Host tfile-link @ Target Forth file-link ! + Host T move-threads H + save-buffers cr .( unresolved: ) .unresolved + + logclose flush \ close n4th.com From 1d293d7ccfaef3d466952a5ad2f7fe078888f417 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sat, 5 Mar 2022 23:08:31 +0100 Subject: [PATCH 09/17] Extracting the main parts from kernel.fth into .fth files for building a new v4th.com from. Also placing the info from the first few screens into a separate file. --- 8086/msdos/src/vf86core.fth | 2033 +++++++++++++++++++++++++++++++++++ 8086/msdos/src/vf86dos.fth | 665 ++++++++++++ 8086/msdos/src/vf86info.txt | 58 + 3 files changed, 2756 insertions(+) create mode 100644 8086/msdos/src/vf86core.fth create mode 100644 8086/msdos/src/vf86dos.fth create mode 100644 8086/msdos/src/vf86info.txt diff --git a/8086/msdos/src/vf86core.fth b/8086/msdos/src/vf86core.fth new file mode 100644 index 0000000..3912665 --- /dev/null +++ b/8086/msdos/src/vf86core.fth @@ -0,0 +1,2033 @@ +\ *** Block No. 4, Hexblock 4 + +\ FORTH Preamble and ID ks 11 mär 89 +Assembler + +nop 5555 # jmp here 2- >label >cold +nop 5555 # jmp here 2- >label >restart + +Create origin here origin! here $100 0 fill +\ Hier beginnen die Kaltstartwerte der Benutzervariablen + + $E9 int end-code -4 , $FC allot +\ this is the multitasker initialization in the user area + +| Create logo ," volksFORTH-83 rev. 3.81.41" + + + + +\ *** Block No. 5, Hexblock 5 + +\ Next ks 27 oct 86 + + Variable next-link 0 next-link ! + + Host Forth Assembler also definitions + + : Next lods A W xchg W ) jmp + there tnext-link @ T , H tnext-link ! ; + +\ Next ist in-line code. Fuer den debugger werden daher alle +\ "nexts" in einer Liste mit dem Anker NEXT-LINK verbunden. + + : u' ( -- offset ) T ' 2+ c@ H ; + + Target + + +\ *** Block No. 6, Hexblock 6 + +\ recover ;c: noop ks 27 oct 86 + + Create recover Assembler + R dec R dec I R ) mov I pop Next + end-code + +Host Forth Assembler also definitions + + : ;c: 0 T recover # call ] end-code H ; + +Target + +| Code di cli Next end-code +| Code ei sti here Next end-code + + Code noop here 2- ! end-code + +\ *** Block No. 7, Hexblock 7 + +\ User variables ks 16 sep 88 + 8 uallot drop \ Platz fuer Multitasker + \ Felder: entry link spare SPsave + \ Laenge kompatibel zum 68000, 6502 und 8080 volksFORTH + User s0 + User r0 + User dp + User offset 0 offset ! + User base &10 base ! + User output + User input + User errorhandler \ pointer for Abort" -code + User aborted \ code address of latest error + User voc-link + User file-link cr .( Wieso ist UDP Uservariable? ) + User udp \ points to next free addr in User_area + +\ *** Block No. 8, Hexblock 8 + +\ manipulate system pointers ks 03 aug 87 + + Code sp@ ( -- addr ) D push S D mov Next end-code + + Code sp! ( addr -- ) D S mov D pop Next end-code + + + Code up@ ( -- addr ) D push U D mov Next end-code + + Code up! ( addr -- ) D U mov D pop Next end-code + + Code ds@ ( -- addr ) D push D: D mov Next end-code + + $10 Constant b/seg \ bytes per segment + + + +\ *** Block No. 9, Hexblock 9 + +\ manipulate returnstack ks 27 oct 86 + + Code rp@ ( -- addr ) D push R D mov Next end-code + + Code rp! ( addr -- ) D R mov D pop Next end-code + + + Code >r ( 16b -- ) R dec R dec D R ) mov D pop Next + end-code restrict + + Code r> ( -- 16b ) D push R ) D mov R inc R inc Next + end-code restrict + + + + + +\ *** Block No. 10, Hexblock a + +\ r@ rdrop exit unnest ?exit ks 27 oct 86 + Code r@ ( -- 16b ) D push R ) D mov Next end-code + + Code rdrop R inc R inc Next end-code restrict + + Code exit + Label >exit R ) I mov R inc R inc Next end-code + + Code unnest >exit here 2- ! end-code + + Code ?exit ( flag -- ) + D D or D pop >exit 0= ?] [[ Next end-code + + Code 0=exit ( flag -- ) + D D or D pop >exit 0= not ?] ]] end-code +\ : ?exit ( flag -- ) IF rdrop THEN ; + +\ *** Block No. 11, Hexblock b + +\ execute perform ks 27 oct 86 + + Code execute ( acf -- ) D W mov D pop W ) jmp end-code + + Code perform ( addr -- ) D W mov D pop W ) W mov W ) jmp + end-code + +\ : perform ( addr -- ) @ execute ; + + + + + + + + + +\ *** Block No. 12, Hexblock c + +\ c@ c! ctoggle ks 27 oct 86 + + Code c@ ( addr -- 8b ) + D W mov W ) D- mov 0 # D+ mov Next end-code + + Code c! ( 16b addr -- ) + D W mov A pop A- W ) mov D pop Next end-code + + Code ctoggle ( 8b addr -- ) + D W mov A pop A- W ) xor D pop Next end-code + +\ : ctoggle ( 8b addr -- ) under c@ xor swap c! ; + + Code flip ( 16b1 -- 16b2 ) D- D+ xchg Next end-code + + + +\ *** Block No. 13, Hexblock d + +\ @ ! 2@ 2! ks 27 oct 86 + + Code @ ( addr -- 16b ) D W mov W ) D mov Next end-code + + Code ! ( 16b addr -- ) D W mov W ) pop D pop Next + end-code + + : 2@ ( addr -- 32b ) dup 2+ @ swap @ ; + + : 2! ( 32b addr -- ) under ! 2+ ! ; + + + + + + + +\ *** Block No. 14, Hexblock e + +\ +! drop swap ks 27 oct 86 + + Code +! ( 16b addr -- ) + D W mov A pop A W ) add D pop Next end-code + +\ : +! ( n addr -- ) under @ + swap ! ; + + + Code drop ( 16b -- ) D pop Next end-code + + Code swap ( 16b1 16b2 -- 16b2 16b1 ) + A pop D push A D xchg Next end-code + + + + + +\ *** Block No. 15, Hexblock f + +\ dup ?dup ks 27 oct 86 + + Code dup ( 16b -- 16b 16b ) D push Next end-code + +\ : dup ( 16b -- 16b 16b ) sp@ @ ; + + Code ?dup ( 16b -- 16b 16b / false ) + D D or 0= not ?[ D push ]? Next end-code + +\ : ?dup ( 16b -- 16b 16b / false) dup 0=exit dup ; + + + + + + + +\ *** Block No. 16, Hexblock 10 + +\ over rot nip under ks 27 oct 86 + + Code over ( 16b1 16b2 -- 16b1 16b2 16b1 ) + A D xchg D pop D push A push Next end-code +\ : over >r dup r> swap ; + + Code rot ( 16b1 16b2 16b3 -- 16b2 16b3 16b1 ) + A D xchg C pop D pop C push A push Next end-code +\ : rot >r swap r> swap ; + + Code nip ( 16b1 16b2 -- 16b2 ) S inc S inc Next end-code +\ : nip swap drop ; + + Code under ( 16b1 16b2 -- 16b2 16b1 16b2 ) + A pop D push A push Next end-code +\ : under swap over ; + +\ *** Block No. 17, Hexblock 11 + +\ -rot pick ks 27 oct 86 + + Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) + A D xchg D pop C pop A push C push Next end-code + +\ : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; + + Code pick ( n -- 16b.n ) + D sal D W mov S W add W ) D mov Next end-code + +\ : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; + + + + + + +\ *** Block No. 18, Hexblock 12 + +\ roll -roll ks 27 oct 86 + + Code roll ( n -- ) + A I xchg D sal D C mov D I mov S I add + I ) D mov I W mov I dec W inc std + rep byte movs cld A I xchg S inc S inc Next + end-code +\ : roll ( n -- ) +\ dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; + + Code -roll ( n -- ) A I xchg D sal D C mov + S W mov D pop S I mov S dec S dec + rep byte movs D W ) mov D pop A I xchg Next + end-code +\ : -roll ( n -- ) >r dup sp@ dup 2+ +\ dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; + +\ *** Block No. 19, Hexblock 13 + +\ 2swap 2drop 2dup 2over ks 27 oct 86 + Code 2swap ( 32b1 32b2 -- 32b2 32b1 ) C pop A pop W pop + C push D push W push A D xchg Next end-code +\ : 2swap ( 32b1 32b2 -- 32b2 32b1 ) rot >r rot r> ; + + Code 2drop ( 32b -- ) S inc S inc D pop Next end-code +\ : 2drop ( 32b -- ) drop drop ; + + Code 2dup ( 32b -- 32b 32b ) + S W mov D push W ) push Next end-code +\ : 2dup ( 32b -- 32b 32b ) over over ; + + Code 2over ( 1 2 x x -- 1 2 x x 1 2 ) + D push S W mov 6 W D) push 4 W D) D mov Next + end-code +\ : 2over ( 1 2 x x -- 1 2 x x 1 2 ) 3 pick 3 pick ; + +\ *** Block No. 20, Hexblock 14 + +\ and or xor not ks 27 oct 86 + + Code not ( 16b1 -- 16b2 ) D com Next end-code + + Code and ( 16b1 16b2 -- 16b3 ) + A pop A D and Next end-code + + Code or ( 16b1 16b2 -- 16b3 ) + A pop A D or Next end-code +\ : or ( 16b1 16b2 -- 16b3 ) not swap not and not ; + + Code xor ( 16b1 16b2 -- 16b3 ) + A pop A D xor Next end-code + + + + +\ *** Block No. 21, Hexblock 15 + +\ + - negate ks 27 oct 86 + + Code + ( n1 n2 -- n3 ) A pop A D add Next end-code + + Code negate ( n1 -- n2 ) D neg Next end-code +\ : negate ( n1 -- n2 ) not 1+ ; + + Code - ( n1 n2 -- n3 ) + A pop D A sub A D xchg Next end-code +\ : - ( n1 n2 -- n3 ) negate + ; + + + + + + + +\ *** Block No. 22, Hexblock 16 + +\ dnegate d+ ks 27 oct 86 + + Code dnegate ( d1 -- -d1 ) D com A pop A neg + CS not ?[ D inc ]? A push Next end-code + + Code d+ ( d1 d2 -- d3 ) A pop C pop W pop + W A add A push C D adc Next end-code + + + + + + + + + + +\ *** Block No. 23, Hexblock 17 + +\ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- ks 27 oct 86 + + Code 1+ ( n1 -- n2 ) [[ D inc Next + Code 2+ ( n1 -- n2 ) [[ D inc swap ]] + Code 3+ ( n1 -- n2 ) [[ D inc swap ]] + Code 4+ ( n1 -- n2 ) [[ D inc swap ]] +| Code 6+ ( n1 -- n2 ) D inc D inc ]] end-code + + Code 1- ( n1 -- n2 ) [[ D dec Next + Code 2- ( n1 -- n2 ) [[ D dec swap ]] + Code 4- ( n1 -- n2 ) D dec D dec ]] end-code + + + + + + +\ *** Block No. 24, Hexblock 18 + +\ number Constants ks 30 jan 88 +-1 Constant true 0 Constant false + + 0 ( -- 0 ) Constant 0 + 1 ( -- 1 ) Constant 1 + 2 ( -- 2 ) Constant 2 + 3 ( -- 3 ) Constant 3 + 4 ( -- 4 ) Constant 4 + -1 ( -- -1 ) Constant -1 + + Code on ( addr -- ) -1 # A mov +[[ D W mov A W ) mov D pop Next + Code off ( addr -- ) 0 # A mov ]] end-code + +\ : on ( addr -- ) true swap ! ; +\ : off ( addr -- ) false swap ! ; + +\ *** Block No. 25, Hexblock 19 + +\ words for number literals ks 27 oct 86 + + Code lit ( -- 16b ) D push I ) D mov I inc +[[ I inc Next end-code restrict + + Code clit ( -- 8b ) + D push I ) D- mov 0 # D+ mov ]] end-code restrict + + : Literal ( 16b -- ) + dup $FF00 and IF compile lit , exit THEN + compile clit c, ; immediate restrict + + + + + + +\ *** Block No. 26, Hexblock 1a + +\ comparision code words ks 27 oct 86 + + Code 0= ( 16b -- flag ) + D D or 0 # D mov 0= ?[ D dec ]? Next end-code + + Code 0<> ( n -- flag ) + D D or 0 # D mov 0= not ?[ D dec ]? Next end-code +\ : 0<> ( n -- flag ) 0= not ; + + Code u< ( u1 u2 -- flag ) A pop +[[ D A sub 0 # D mov CS ?[ D dec ]? Next end-code + + Code u> ( u1 u2 -- flag ) A D xchg D pop ]] end-code +\ : u> ( u1 u2 -- flag ) swap u< ; + + + +\ *** Block No. 27, Hexblock 1b + +\ comparision words ks 13 sep 88 + Code < ( n1 n2 -- flag ) A pop +[[ [[ D A sub 0 # D mov < ?[ D dec ]? Next end-code + + Code > ( n1 n2 -- flag ) A D xchg D pop ]] end-code + + Code 0> ( n -- flag ) A A xor ]] end-code + +\ : < ( n1 n2 -- flag ) +\ 2dup xor 0< IF drop 0< exit THEN - 0< ; +\ : > ( n1 n2 -- flag ) swap < ; +\ : 0> ( n -- flag ) negate 0< ; + + Code 0< ( n1 n2 -- flag ) + D D or 0 # D mov 0< ?[ D dec ]? Next end-code +\ : 0< ( n1 -- flag ) 8000 and 0<> ; + +\ *** Block No. 28, Hexblock 1c + +\ comparision words ks 27 oct 86 + + Code = ( n1 n2 -- flag ) A pop A D cmp + 0 # D mov 0= ?[ D dec ]? Next end-code +\ : = ( n1 n2 -- flag ) - 0= ; + + Code uwithin ( u1 [low high[ -- flag ) A pop C pop + A C cmp CS ?[ [[ swap 0 # D mov Next ]? + D C cmp CS ?] -1 # D mov Next end-code +\ : uwithin ( u1 [low up[ -- f ) over - -rot - u> ; + + Code case? ( 16b1 16b2 -- 16b1 ff / tf ) A pop A D sub + 0= ?[ D dec ][ A push D D xor ]? Next end-code +\ : case? ( 16b1 16b2 -- 16b1 false / true ) +\ over = dup 0=exit nip ; + + +\ *** Block No. 29, Hexblock 1d + +\ double number comparisons ks 27 oct 86 + + Code d0= ( d - f) A pop A D or + 0= not ?[ 1 # D mov ]? D dec Next end-code +\ : d0= ( d -- flag ) or 0= ; + + : d= ( d1 d2 -- flag ) dnegate d+ d0= ; + +Code d< ( d1 d2 -- flag ) C pop A pop + D A sub A pop -1 # D mov < ?[ [[ swap Next ]? + 0= ?[ C A sub CS ?[ D dec ]? ]? D inc ]] end-code +\ : d< ( d1 d2 -- flag ) +\ rot 2dup - IF > nip nip exit THEN 2drop u< ; + + + + +\ *** Block No. 30, Hexblock 1e + +\ min max umax umin abs dabs extend ks 27 oct 86 + Code min ( n1 n2 -- n3 ) A pop A D sub < ?[ D A add ]? + [[ [[ [[ A D xchg Next end-code + Code max ( n1 n2 -- n3 ) + A pop A D sub dup < not ?] D A add ]] end-code + Code umin ( u1 u2 -- u3 ) + A pop A D sub dup CS ?] D A add ]] end-code + Code umax ( u1 u2 -- u3 ) + A pop A D sub dup CS not ?] D A add ]] end-code + + Code extend ( n -- d ) + A D xchg cwd A push Next end-code + + Code abs ( n -- u ) D D or 0< ?[ D neg ]? Next end-code + + : dabs ( d -- ud ) extend 0=exit dnegate ; + +\ *** Block No. 31, Hexblock 1f + +\\ min max umax umin extend 10Mar8 + +| : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; + +: min ( n1 n2 -- n3 ) 2dup > minimax ; +: max ( n1 n2 -- n3 ) 2dup < minimax ; +: umax ( u1 u2 -- u3 ) 2dup u< minimax ; +: umin ( u1 u2 -- u3 ) 2dup u> minimax ; +: extend ( n -- d ) dup 0< ; +: dabs ( d -- ud ) extend IF dnegate THEN ; +: abs ( n -- u) extend IF negate THEN ; + + + + + + +\ *** Block No. 32, Hexblock 20 + +\ (do (?do endloop bounds ks 30 jan 88 + + Code (do ( limit start -- ) A pop +[[ $80 # A+ xor R dec R dec I inc I inc + I R ) mov R dec R dec A R ) mov R dec R dec + A D sub D R ) mov D pop Next end-code restrict + + Code (?do ( limit start -- ) A pop A D cmp 0= ?] + I ) I add D pop Next end-code restrict + + Code endloop 6 # R add Next end-code restrict + + Code bounds ( start count -- limit start ) + A pop A D xchg D A add A push Next end-code +\ : bounds ( start count -- limit start ) over + swap ; + + +\ *** Block No. 33, Hexblock 21 + +\ (loop (+loop ks 27 oct 86 + + Code (loop R ) word inc +[[ OS not ?[ 4 R D) I mov ]? Next end-code restrict + + Code (+loop D R ) add D pop ]] end-code restrict + +\\ + +| : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; +\ dodo puts "index | limit | adr.of.DO" on return-stack + + : (do ( limit start -- ) over - dodo ; restrict + : (?do ( limit start -- ) over - ?dup IF dodo THEN + r> dup @ + >r drop ; restrict + + +\ *** Block No. 34, Hexblock 22 + +\ loop indices ks 27 oct 86 + + Code I ( -- n ) D push R ) D mov 2 R D) D add Next + end-code +\ : I ( -- n ) r> r> dup r@ + -rot >r >r ; + + Code J ( -- n ) D push 6 R D) D mov 8 R D) D add Next + end-code + + + + + + + + + +\ *** Block No. 35, Hexblock 23 + +\ branch ?branch ks 27 oct 86 + + Code branch +[[ I ) I add Next end-code restrict +\ : branch r> dup @ + >r ; + + Code ?branch D D or D pop 0= not ?] + I inc I inc Next end-code restrict + + + + + + + + + +\ *** Block No. 36, Hexblock 24 + +\ resolve loops and branches ks 02 okt 87 + + : >mark ( -- addr ) here 0 , ; + + : >resolve ( addr -- ) here over - swap ! ; + + : mark 1 ; immediate restrict + : THEN abs 1 ?pairs >resolve ; immediate restrict + : ELSE 1 ?pairs compile branch >mark + swap >resolve -1 ; immediate restrict + + : BEGIN mark -2 2swap ; immediate restrict + +| : (repeat 2 ?pairs resolve REPEAT ; + + : REPEAT compile branch (repeat ; immediate restrict + : UNTIL compile ?branch (repeat ; immediate restrict + +\ *** Block No. 38, Hexblock 26 + +\ Loops ks 27 oct 86 + + : DO compile (do >mark 3 ; immediate restrict + : ?DO compile (?do >mark 3 ; immediate restrict + : LOOP 3 ?pairs compile (loop + compile endloop >resolve ; immediate restrict + : +LOOP 3 ?pairs compile (+loop + compile endloop >resolve ; immediate restrict + + Code LEAVE 6 # R add -2 R D) I mov + I dec I dec I ) I add Next end-code restrict + +\ : LEAVE endloop r> 2- dup @ + >r ; restrict +\ Returnstack: | calladr | index | limit | adr of DO | + + + +\ *** Block No. 39, Hexblock 27 + +\ um* m* * ks 29 jul 87 + + Code um* ( u1 u2 -- ud3 ) + A D xchg C pop C mul A push Next end-code + + Code m* ( n1 n2 -- d3 ) + A D xchg C pop C imul A push Next end-code +\ : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN swap +\ dup 0< IF negate r> not >r THEN um* r> 0=exit dnegate ; + + : * ( n1 n2 - prod ) um* drop ; + + Code 2* ( u -- 2*u ) D shl Next end-code +\ : 2* ( u -- 2*u ) dup + ; + + + +\ *** Block No. 40, Hexblock 28 + +\ um/mod m/mod ks 27 oct 86 + + Code um/mod ( ud1 u2 -- urem uquot ) + D C mov D pop A pop C div A D xchg A push Next + end-code + + Code m/mod ( d1 n2 -- rem quot ) D C mov D pop +Label divide D+ A+ mov C+ A+ xor A pop 0< not + ?[ C idiv [[ swap A D xchg A push Next ]? + C idiv D D or dup 0= not ?] A dec C D add ]] + end-code + +\ : m/mod ( d n -- mod quot ) dup >r +\ abs over 0< IF under + swap THEN um/mod r@ 0< +\ IF negate over IF swap r@ + swap 1- THEN THEN rdrop ; + + +\ *** Block No. 41, Hexblock 29 + +\ /mod division trap 2/ ks 13 sep 88 + + Code /mod ( n1 n2 -- rem quot ) + D C mov A pop cwd A push divide ]] end-code +\ : /mod ( n1 n2 -- rem quot ) over 0< swap m/mod ; + + 0 >label >divINT + + Label divovl Assembler + 4 # S add popf 1 # D- mov ;c: Abort" / overflow" ; + + Code 2/ ( n1 -- n/2 ) D sar Next end-code +\ : 2/ ( n -- n/2 ) 2 / ; + + + + +\ *** Block No. 42, Hexblock 2a + +\ / mod */mod */ u/mod ud/mod ks 27 oct 86 + + : / ( n1 n2 -- quot ) /mod nip ; + + : mod ( n1 n2 -- rem ) /mod drop ; + + : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; + + : */ ( n1 n2 n3 -- quot ) */mod nip ; + + : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; + + : ud/mod ( ud1 u2 -- urem udquot ) + >r 0 r@ um/mod r> swap >r um/mod r> ; + + + +\ *** Block No. 43, Hexblock 2b + +\ cmove cmove> move ks 27 oct 86 + + Code cmove ( from to quan -- ) A I xchg D C mov + W pop I pop D pop rep byte movs A I xchg Next + end-code + + Code cmove> ( from to quan -- ) + A I xchg D C mov W pop I pop D pop +Label moveup C dec C W add C I add C inc + std rep byte movs A I xchg cld Next end-code + + Code move ( from to quan -- ) + A I xchg D C mov W pop I pop D pop +Label domove I W cmp moveup CS ?] + rep byte movs A I xchg Next end-code + + +\ *** Block No. 44, Hexblock 2c + +\ place count ks 27 oct 86 + +| Code (place ( addr len to - len to) A I xchg D W mov + C pop I pop C push W inc domove ]] end-code + + : place ( addr len to -) (place c! ; + + Code count ( addr -- addr+1 len ) D W mov + W ) D- mov 0 # D+ mov W inc W push Next end-code + +\ : move ( from to quan -- ) +\ >r 2dup u< IF r> cmove> exit THEN r> cmove ; +\ : place ( addr len to -- ) over >r rot over 1+ r> move c! ; +\ : count ( adr -- adr+1 len ) dup 1+ swap c@ ; + + + +\ *** Block No. 45, Hexblock 2d + +\ fill erase ks 27 oct 86 + + Code fill ( addr quan 8b -- ) + D A xchg C pop W pop D pop rep byte stos Next + end-code + +\ : fill ( addr quan 8b -- ) swap ?dup +\ IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; + + : erase ( addr quan --) 0 fill ; + + + + + + + +\ *** Block No. 46, Hexblock 2e + +\ here allot , c, pad compile ks 27 oct 86 + + Code here ( -- addr ) D push u' dp U D) D mov Next + end-code +\ : here ( -- addr ) dp @ ; + + Code allot ( n -- ) D u' dp U D) add D pop Next + end-code +\ : allot ( n -- ) dp +! ; + + : , ( 16b -- ) here ! 2 allot ; + : c, ( 8b -- ) here c! 1 allot ; + : pad ( -- addr ) here $42 + ; + : compile r> dup 2+ >r @ , ; restrict + + + +\ *** Block No. 47, Hexblock 2f + +\ input strings ks 23 dez 87 + + Variable #tib #tib off + Variable >tib here >tib ! $50 allot + Variable >in >in off + Variable blk blk off + Variable span span off + + : tib ( -- addr ) >tib @ ; + + : query tib $50 expect span @ #tib ! >in off ; + + + + + + +\ *** Block No. 48, Hexblock 30 + +\ skip scan /string ks 22 dez 87 + + Code skip ( addr len char -- addr1 len1 ) + A D xchg C pop C0= not + ?[ W pop 0=rep byte scas 0= not ?[ W dec C inc ]? + W push ]? C D mov Next end-code + + Code scan ( addr0 len0 char -- addr1 len1 ) + A D xchg C pop C0= not + ?[ W pop 0<>rep byte scas 0= ?[ W dec C inc ]? + W push ]? C D mov Next end-code + + Code /string ( addr0 len0 +n -- addr1 len1 ) + A pop C pop D A sub CS ?[ A D add A A xor ]? + C D add D push A D xchg Next end-code + + +\ *** Block No. 49, Hexblock 31 + +\\ scan skip /string ks 29 jul 87 + + : skip ( addr0 len0 char -- addr1 len1 ) >r + BEGIN dup + WHILE over c@ r@ = WHILE 1- swap 1+ swap + REPEAT rdrop ; + + : scan ( addr0 len0 char -- addr1 len1 ) >r + BEGIN dup + WHILE over c@ r@ - WHILE 1- swap 1+ swap + REPEAT rdrop ; + + : /string ( addr0 len0 +n -- addr1 len1 ) + over umin rot over + -rot - ; + + + +\ *** Block No. 50, Hexblock 32 + +\ capital ks 19 dez 87 + + Create (capital Assembler $61 # A- cmp CS not + ?[ $7B # A- cmp CS not + ?[ $84 # A- cmp 0= ?[ $8E # A- mov ret ]? \ ä + $94 # A- cmp 0= ?[ $99 # A- mov ret ]? \ ö + $81 # A- cmp 0= ?[ $9A # A- mov ]? ret \ ü + ]? $20 # A- xor + ]? ret end-code + + Code capital ( char -- char' ) + A D xchg (capital # call A D xchg Next + end-code + + + + +\ *** Block No. 51, Hexblock 33 + +\ upper ks 03 aug 87 + + Code upper ( addr len -- ) + D C mov W pop D pop C0= not + ?[ [[ W ) A- mov (capital # call + A- W ) mov W inc C0= ?] ]? Next + end-code + +\\ high level, ohne Umlaute + + : capital ( char -- char') + dup Ascii a [ Ascii z 1+ ] Literal + uwithin not ?exit [ Ascii a Ascii A - ] Literal - ; + + : upper ( addr len -- ) + bounds ?DO I c@ capital I c! LOOP ; + +\ *** Block No. 52, Hexblock 34 + +\ (word ks 28 mai 87 + +| Code (word ( char addr0 len0 -- addr1 ) D C mov W pop + A pop >in #) D mov D C sub >= not + ?[ C push D W add 0=rep byte scas W D mov 0= not + ?[ W dec D dec C inc + 0<>rep byte scas 0= ?[ W dec ]? + ]? A pop C A sub A >in #) add + W C mov D C sub 0= not + ?[ D I xchg u' dp U D) W mov C- W ) mov + W inc rep byte movs $20 # W ) byte mov + D I mov u' dp U D) D mov Next +swap ]? C >in #) add + ]? u' dp U D) W mov $2000 # W ) mov W D mov Next + end-code + + +\ *** Block No. 53, Hexblock 35 + +\\ (word ks 27 oct 86 + +| : (word ( char adr0 len0 -- addr ) + rot >r over swap >in @ /string r@ skip + over swap r> scan >r rot over swap - r> 0<> - >in ! + over - here dup >r place bl r@ count + c! r> ; + + + + + + + + + + + +\ *** Block No. 54, Hexblock 36 + +\ source word parse name ks 03 aug 87 + + Variable loadfile loadfile off + + : source ( -- addr len ) blk @ ?dup + IF loadfile @ (block b/blk exit THEN tib #tib @ exit ; + + : word ( char -- addr ) source (word ; + + : parse ( char -- addr len ) >r source >in @ /string + over swap r> scan >r over - dup r> 0<> - >in +! ; + + : name ( -- string ) bl word dup count upper exit ; + + + + +\ *** Block No. 55, Hexblock 37 + +\ state Ascii ," "lit (" " ks 16 sep 88 + Variable state state off + + : Ascii ( char -- n ) bl word 1+ c@ + state @ 0=exit [compile] Literal ; immediate + + : ," Ascii " parse here over 1+ allot place ; + + Code "lit ( -- addr ) D push R ) D mov D W mov + W ) A- mov 0 # A+ mov A inc A R ) add Next + end-code restrict +\ : "lit r> r> under count + even >r >r ; restrict + + : (" "lit ; restrict + + : " compile (" ," align ; immediate restrict + +\ *** Block No. 56, Hexblock 38 + +\ ." ( .( \ \\ hex decimal ks 12 dez 88 + + : (." "lit count type ; restrict + : ." compile (." ," align ; immediate restrict + + : ( Ascii ) parse 2drop ; immediate + : .( Ascii ) parse type ; immediate + + : \ >in @ negate c/l mod >in +! ; immediate + : \\ b/blk >in ! ; immediate + : have ( -- f ) name find nip 0<> ; immediate + : \needs have 0=exit [compile] \ ; + + : hex $10 base ! ; + : decimal &10 base ! ; + + +\ *** Block No. 57, Hexblock 39 + +\ number conversion: digit? accumulate convert ks 08 okt 87 + + : digit? ( char -- digit true/ false ) dup Ascii 9 > + IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and + THEN Ascii 0 - dup base @ u< dup ?exit nip ; + + : accumulate ( +d0 adr digit -- +d1 adr ) swap >r + swap base @ um* drop rot base @ um* d+ r> ; + + : convert ( +d1 addr0 -- +d2 addr2 ) + 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; + + + + + + +\ *** Block No. 58, Hexblock 3a + +\ number conversion ks 29 jun 87 +| : end? ( -- flag ) >in @ 0= ; + +| : char ( addr0 -- addr1 char ) count -1 >in +! ; + +| : previous ( addr0 -- addr0 char ) 1- count ; + +| : punctuation? ( char -- flag ) + Ascii , over = swap Ascii . = or ; +\ : punctuation? ( char -- f ) ?" .," ; + +| : fixbase? ( char -- char false / newbase true ) capital + Ascii $ case? IF $10 true exit THEN + Ascii H case? IF $10 true exit THEN + Ascii & case? IF &10 true exit THEN + Ascii % case? IF 2 true exit THEN false ; + +\ *** Block No. 59, Hexblock 3b + +\ number conversion: dpl ?num ?nonum ?dpl ks 27 oct 86 + + Variable dpl -1 dpl ! + +| : ?num ( flag -- exit if true ) 0=exit + rdrop drop r> IF dnegate THEN rot drop + dpl @ 1+ ?dup ?exit drop true ; + +| : ?nonum ( flag -- exit if true ) 0=exit + rdrop 2drop drop rdrop false ; + +| : ?dpl dpl @ -1 = ?exit 1 dpl +! ; + + + + + +\ *** Block No. 60, Hexblock 3c + +\ number conversion: number? number ks 27 oct 86 + + : number? ( string -- string false / n 0< / d 0> ) + base push >in push dup count >in ! dpl on + 0 >r ( +sign) 0.0 rot end? ?nonum char + Ascii - case? IF rdrop true >r end? ?nonum char THEN + fixbase? IF base ! end? ?nonum char THEN + BEGIN digit? 0= ?nonum + BEGIN accumulate ?dpl end? ?num char digit? + 0= UNTIL previous punctuation? 0= ?nonum + dpl off end? ?num char + REPEAT ; + + : number ( string -- d ) + number? ?dup 0= Abort" ?" 0> ?exit extend ; + + +\ *** Block No. 61, Hexblock 3d + +\ hide reveal immediate restrict ks 18 mär 88 + Variable last last off + + : last' ( -- cfa ) last @ name> ; + +| : last? ( -- false / nfa true) last @ ?dup ; + : hide last? 0=exit 2- @ current @ ! ; + : reveal last? 0=exit 2- current @ ! ; + + : Recursive reveal ; immediate restrict + +| : flag! ( 8b --) + last? IF under c@ or over c! THEN drop ; + + : immediate $40 flag! ; + : restrict $80 flag! ; + +\ *** Block No. 62, Hexblock 3e + +\ clearstack hallot heap heap? ks 27 oct 86 + + Code clearstack u' s0 U D) S mov D pop Next end-code + + : hallot ( quan -- ) + s0 @ over - swap sp@ 2+ dup rot - dup s0 ! + 2 pick over - di move clearstack ei s0 ! ; + + : heap ( -- addr ) s0 @ 6 + ; + : heap? ( addr -- flag ) heap up@ uwithin ; + +| : heapmove ( from -- from ) + dup here over - dup hallot + heap swap cmove heap over - last +! reveal ; + + + +\ *** Block No. 63, Hexblock 3f + +\ Does> ; ks 18 mär 88 + +| Create dodo Assembler + R dec R dec I R ) mov \ push IP + D push 2 W D) D lea \ load parameter address + W ) I mov 3 # I add Next end-code + + dodo Host tdodo ! Target \ target compiler needs to know + + : (;code r> last' ! ; + + : Does> compile (;code $E9 c, ( jmp instruction) + dodo here 2+ - , ; immediate restrict + + + + +\ *** Block No. 64, Hexblock 40 + +\ ?head | alignments ks 19 mär 88 + Variable ?head ?head off + + : | ?head @ ?exit ?head on ; + + : even ( addr -- addr1 ) ; immediate + : align ( -- ) ; immediate + : halign ( -- ) ; immediate +\ machen nichts beim 8088. 8086 koennte etwas schneller werden + + Variable warning warning on + +| : ?exists warning @ 0=exit + last @ current @ (find nip 0=exit + space last @ .name ." exists " ?cr ; + + +\ *** Block No. 65, Hexblock 41 + +\ Create Variable ks 19 mär 88 + + Defer makeview ' 0 Is makeview + + : Create align here makeview , current @ @ , + name c@ dup 1 $20 uwithin not Abort" invalid name" + here last ! 1+ allot align ?exists + ?head @ IF 1 ?head +! dup , \ Pointer to Code + halign heapmove $20 flag! dup dp ! + THEN drop reveal 0 , + ;Code ( -- addr ) D push 2 W D) D lea Next end-code + + : Variable Create 0 , ; + + + + +\ *** Block No. 66, Hexblock 42 + +\ nfa? ks 28 mai 87 + + Code nfa? ( thread cfa -- nfa / false ) + W pop R A mov $1F # C mov + [[ W ) W mov W W or 0= not + ?[[ 2 W D) R- mov C R and 3 R W DI) R lea + $20 # 2 W D) test 0= not ?[ R ) R mov ]? + D R cmp 0= ?] 2 W D) W lea + ]? W D mov A R mov Next end-code + +\\ + + : nfa? ( thread cfa -- nfa / false ) >r + BEGIN @ dup 0= IF rdrop exit THEN + dup 2+ name> r@ = UNTIL 2+ rdrop ; + + +\ *** Block No. 67, Hexblock 43 + +\ >name name> >body .name ks 13 aug 87 + + : >name ( acf -- anf / ff ) voc-link + BEGIN @ dup WHILE 2dup 4 - swap nfa? + ?dup IF -rot 2drop exit THEN REPEAT nip ; + + : (name> ( nfa -- cfa ) count $1F and + even ; + + : name> ( nfa -- cfa ) + dup (name> swap c@ $20 and 0=exit @ ; + + : >body ( cfa -- pfa ) 2+ ; + : body> ( pfa -- cfa ) 2- ; + + : .name ( nfa -- ) ?dup IF dup heap? IF ." | " THEN + count $1F and type ELSE ." ???" THEN space ; + +\ *** Block No. 68, Hexblock 44 + +\ : ; Constant Variable ks 29 oct 86 + + : Create: Create hide current @ context ! 0 ] ; + + : : Create: + ;Code R dec R dec I R ) mov 2 W D) I lea Next + end-code + + : ; 0 ?pairs compile unnest [compile] [ reveal ; + immediate restrict + + : Constant ( n -- ) Create , + ;Code ( -- n ) D push 2 W D) D mov Next end-code + + + + +\ *** Block No. 69, Hexblock 45 + +\ uallot User Alias Defer ks 02 okt 87 + : uallot ( quan -- offset ) even dup udp @ + + $FF u> Abort" Userarea full" udp @ swap udp +! ; + + : User Create 2 uallot c, + ;Code ( -- addr ) D push 2 W D) D- mov + 0 # D+ mov U D add Next end-code + + : Alias ( cfa -- ) + Create last @ dup c@ $20 and + IF -2 allot ELSE $20 flag! THEN (name> ! ; + +| : crash true Abort" crash" ; + + : Defer Create ['] crash , + ;Code 2 W D) W mov W ) jmp end-code + +\ *** Block No. 70, Hexblock 46 + +\ vp current context also toss ks 02 okt 87 + + Create vp $10 allot + Variable current + + : context ( -- adr ) vp dup @ + 2+ ; + +| : thru.vocstack ( -- from to ) vp 2+ context ; + +\ "Only Forth also Assembler" gives +\ vp: countword = 6 | Root | Forth | Assembler | + + : also vp @ &10 > Error" Vocabulary stack full" + context @ 2 vp +! context ! ; + + : toss vp @ 0=exit -2 vp +! ; + +\ *** Block No. 71, Hexblock 47 + +\ Vocabulary Forth Only Onlyforth definitions ks 19 jun 88 + : Vocabulary Create 0 , 0 , here voc-link @ , voc-link ! + Does> context ! ; +\ | Name | Code | Thread | Coldthread | Voc-link | + + Vocabulary Forth +Host h' Transient 8 + @ T h' Forth 8 + H ! +Target Forth also definitions + + Vocabulary Root + + : Only vp off Root also ; + + : Onlyforth Only Forth also definitions ; + + : definitions context @ current ! ; + +\ *** Block No. 72, Hexblock 48 + +\ order vocs words ks 19 jun 88 +| : init-vocabularys voc-link @ + BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; +| : .voc ( adr -- ) @ 2- >name .name ; + + : order vp 4+ context over umax + DO I .voc -2 +LOOP 2 spaces current .voc ; + + : vocs voc-link + BEGIN @ ?dup WHILE dup 6 - >name .name REPEAT ; + + : words ( -- ) [compile] Ascii capital >r context @ + BEGIN @ dup stop? 0= and + WHILE ?cr dup 2+ r@ bl = over 1+ c@ r@ = or + IF .name space ELSE drop THEN + REPEAT drop rdrop ; + +\ *** Block No. 73, Hexblock 49 + +\ (find found ks 09 jul 87 +| : found ( nfa -- cfa n ) dup c@ >r + (name> r@ $20 and IF @ THEN + -1 r@ $80 and IF 1- THEN + r> $40 and IF negate THEN ; + + Code (find ( string thread -- string ff / anf tf ) + D I xchg W pop D push W ) A- mov W inc + W D mov 0 # C+ mov $1F # A+ mov A+ A- and + [[ I ) I mov I I or 0= not + ?[[ 2 I D) C- mov A+ C- and A- C- cmp dup 0= ?] + I push D W mov 3 # I add + 0=rep byte cmps I pop 0= ?] + 3 # I add I W mov -1 # D mov + ][ D W mov 0 # D mov ]? W dec I pop W push Next + end-code + +\ *** Block No. 74, Hexblock 4a + +\\ -text (find ks 02 okt 87 + + : -text ( adr1 len adr2 -- 0< 1<2 / 0= 1=2 / 0> 1>2 ) + over bounds + DO drop count I c@ - dup IF LEAVE THEN LOOP nip ; + + : (find ( string thread -- str false / NFA +n ) + over c@ $1F and >r @ + BEGIN dup WHILE dup @ swap 2+ dup c@ $1F and r@ = + IF dup 1+ r@ 4 pick 1+ -text + 0= IF rdrop -rot drop exit + THEN THEN drop + REPEAT rdrop ; + + + + +\ *** Block No. 75, Hexblock 4b + +\ find ' [compile] ['] nullstring? ks 29 oct 86 + + : find ( string -- acf n / string false ) + context dup @ over 2- @ = IF 2- THEN + BEGIN under @ (find IF nip found exit THEN + swap 2- dup vp = UNTIL drop false ; + + : ' ( -- cfa ) name find ?exit Error" ?" ; + + : [compile] ' , ; immediate restrict + + : ['] ' [compile] Literal ; immediate restrict + + : nullstring? ( string -- string false / true ) + dup c@ 0= dup 0=exit nip ; + + +\ *** Block No. 76, Hexblock 4c + +\ interpreter ks 07 dez 87 + + Defer notfound + +| : interpreter ( string -- ) find ?dup + IF 1 and IF execute exit THEN + Error" compile only" + THEN number? ?exit notfound ; + +| : compiler ( string -- ) find ?dup + IF 0> IF execute exit THEN , exit THEN + number? ?dup IF 0> IF swap [compile] Literal THEN + [compile] Literal exit + THEN notfound ; + + + +\ *** Block No. 77, Hexblock 4d + +\ compiler [ ] ks 16 sep 88 + + : no.extensions ( string -- ) + state @ IF Abort" ?" THEN Error" ?" ; + + ' no.extensions Is notfound + + Defer parser ( string -- ) ' interpreter Is parser + + : interpret + BEGIN ?stack name nullstring? IF aborted off exit THEN + parser REPEAT ; + + : [ ['] interpreter Is parser state off ; immediate + + : ] ['] compiler Is parser state on ; + +\ *** Block No. 78, Hexblock 4e + +\ Is ks 07 dez 87 + + : (is r> dup 2+ >r @ ! ; + +| : def? ( cfa -- ) + @ [ ' notfound @ ] Literal - Abort" not deferred" ; + + : Is ( addr -- ) ' dup def? >body + state @ IF compile (is , exit THEN ! ; immediate + + + + + + + + +\ *** Block No. 79, Hexblock 4f + +\ ?stack ks 01 okt 87 + +| : stackfull ( -- ) depth $20 > Abort" tight stack" + reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN + true Abort" dictionary full" ; + + Code ?stack u' dp U D) A mov S A sub CS + ?[ $100 # A add CS ?[ ;c: stackfull ; Assembler ]? ]? + u' s0 U D) A mov A inc A inc S A sub + CS not ?[ Next ]? ;c: true Abort" stack empty" ; + +\ : ?stack sp@ here - $100 u< IF stackfull THEN +\ sp@ s0 @ u> Abort" stack empty" ; + + + + +\ *** Block No. 80, Hexblock 50 + +\ .status push load ks 29 oct 86 + +| Create: pull r> r> ! ; + : push ( addr -- ) + r> swap dup >r @ >r pull >r >r ; restrict + + Defer .status ' noop Is .status + + : (load ( blk offset -- ) isfile@ >r + loadfile @ >r fromfile @ >r blk @ >r >in @ >r + >in ! blk ! isfile@ loadfile ! .status interpret + r> >in ! r> blk ! r> fromfile ! r> loadfile ! + r> isfile ! ; + + : load ( blk -- ) ?dup 0=exit 0 (load ; + + +\ *** Block No. 81, Hexblock 51 + +\ +load thru +thru --> rdepth depth ks 26 jul 87 + + : +load ( offset -- ) blk @ + load ; + + : thru ( from to -- ) 1+ swap DO I load LOOP ; + + : +thru ( off0 off1 -- ) 1+ swap DO I +load LOOP ; + + : --> 1 blk +! >in off .status ; immediate + + : rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; + + : depth ( -- +n ) sp@ s0 @ swap - 2/ ; + + + + +\ *** Block No. 82, Hexblock 52 + +\ prompt quit ks 16 sep 88 + + : (prompt .status state @ IF cr ." ] " exit THEN + aborted @ 0= IF ." ok" THEN cr ; + + Defer prompt ' (prompt Is prompt + + : (quit BEGIN prompt query interpret REPEAT ; + + Defer 'quit ' (quit Is 'quit + + : quit r0 @ rp! [compile] [ blk off 'quit ; + +\ : classical cr .status state @ +\ IF ." C> " exit THEN ." I> " ; + + +\ *** Block No. 83, Hexblock 53 + +\ end-trace abort ks 26 jul 87 + + : standardi/o [ output ] Literal output 4 cmove ; + + Code end-trace next-link # W mov $AD # A- mov + $FF97 # C mov [[ W ) W mov W W or 0= not + ?[[ A- -4 W D) mov C -3 W D) mov + ]]? lods A W xchg W ) jmp end-code + + Defer 'abort ' noop Is 'abort + + : abort end-trace clearstack 'abort standardi/o quit ; + + + + + +\ *** Block No. 84, Hexblock 54 + +\ (error Abort" Error" ks 16 sep 88 + Variable scr 1 scr ! + Variable r# r# off + + : (error ( string -- ) rdrop r> aborted ! standardi/o + space here .name count type space ?cr + blk @ ?dup IF scr ! >in @ r# ! THEN quit ; + ' (error errorhandler ! + + : (abort" "lit swap IF >r clearstack r> + errorhandler perform exit THEN drop ; restrict + +| : (error" "lit swap IF errorhandler perform exit THEN + drop ; restrict + + + +\ *** Block No. 85, Hexblock 55 + +\ -trailing space spaces ks 16 sep 88 + + : Abort" compile (abort" ," align ; immediate restrict + : Error" compile (error" ," align ; immediate restrict + + $20 Constant bl + + : -trailing ( addr n1 -- addr n2) + dup 0 ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; + + : space bl emit ; + : spaces ( u -- ) 0 ?DO space LOOP ; + + + + + +\ *** Block No. 86, Hexblock 56 + +\ hold <# #> sign # #s ks 29 dez 87 + +| : hld ( -- addr) pad 2- ; + + : hold ( char -- ) -1 hld +! hld @ c! ; + + : <# hld hld ! ; + + : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; + + : sign ( n -- ) 0< not ?exit Ascii - hold ; + + : # ( +d1 -- +d2) + base @ ud/mod rot dup 9 > 7 and + Ascii 0 + hold ; + + : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; + +\ *** Block No. 87, Hexblock 57 + +\ print numbers .s ks 07 feb 89 + + : d.r ( d +n -- ) -rot under dabs <# #s rot sign #> + rot over max over - spaces type ; + : d. ( d -- ) 0 d.r space ; + + : .r ( n +n -- ) swap extend rot d.r ; + : . ( n -- ) extend d. ; + + : u.r ( u +n -- ) 0 swap d.r ; + : u. ( u -- ) 0 d. ; + + : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; + + + + +\ *** Block No. 88, Hexblock 58 + +\ list c/l l/s ks 19 mär 88 + + &64 Constant c/l \ Screen line length + &16 Constant l/s \ lines per screen + + : list ( scr -- ) dup capacity u< + IF scr ! ." Scr " scr @ . + ." Dr " drv . isfile@ .file + l/s 0 DO cr I 2 .r space scr @ block + I c/l * + c/l -trailing type + LOOP cr exit + THEN 9 ?diskerror ; + + + + + +\ *** Block No. 89, Hexblock 59 + +\ multitasker primitives ks 29 oct 86 + + Code pause D push I push R push + S 6 U D) mov 2 U D) U add 4 # U add U jmp + end-code + + : lock ( addr -- ) + dup @ up@ = IF drop exit THEN + BEGIN dup @ WHILE pause REPEAT up@ swap ! ; + + : unlock ( addr -- ) dup lock off ; + + Label wake Assembler U pop 2 # U sub A pop + popf 6 U D) S mov R pop I pop D pop Next + end-code + $E9 4 * >label >taskINT + +\ *** Block No. 90, Hexblock 5a + +\\ Struktur der Blockpuffer ks 04 jul 87 + + 0 : link zum naechsten Puffer + 2 : file 0 = direct access + -1 = leer, + sonst adresse eines file control blocks + 4 : blocknummer + 6 : statusflags Vorzeichenbit kennzeichnet update + 8 : Data ... 1 Kb ... + + + + + + + + +\ *** Block No. 91, Hexblock 5b + +\ buffer mechanism ks 04 okt 87 + + Variable isfile isfile off \ addr of file control block + Variable fromfile fromfile off \ fcb in kopieroperationen + + Variable prev prev off \ Listhead +| Variable buffers buffers off \ Semaphor + + $408 Constant b/buf \ physikalische Groesse + $400 Constant b/blk \ bytes/block + + Defer r/w \ physikalischer Diskzugriff + Variable error# error# off \ Nummer des letzten Fehlers + Defer ?diskerror \ Fehlerbehandlung + + + +\ *** Block No. 92, Hexblock 5c + +\ (core? ks 28 mai 87 + + Code (core? ( blk file -- dataaddr / blk file ) + A pop A push D D or 0= ?[ u' offset U D) A add ]? + prev #) W mov 2 W D) D cmp 0= + ?[ 4 W D) A cmp 0= + ?[ 8 W D) D lea A pop ' exit @ # jmp ]? ]? + [[ [[ W ) C mov C C or 0= ?[ Next ]? + C W xchg 4 W D) A cmp 0= ?] 2 W D) D cmp 0= ?] + W ) A mov prev #) D mov D W ) mov W prev #) mov + 8 W D) D lea C W mov A W ) mov A pop + ' exit @ # jmp + end-code + + + + +\ *** Block No. 93, Hexblock 5d + +\\ (core? ks 31 oct 86 + +| : this? ( blk file bufadr -- flag ) + dup 4+ @ swap 2+ @ d= ; + + .( (core?: offset is handled differently in code! ) + +| : (core? ( blk file -- dataaddr / blk file ) + BEGIN over offset @ + over prev @ this? + IF rdrop 2drop prev @ 8 + exit THEN + 2dup >r offset @ + >r prev @ + BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN + dup r> r> 2dup >r >r rot this? 0= + WHILE nip REPEAT + dup @ rot ! prev @ over ! prev ! rdrop rdrop + REPEAT ; + +\ *** Block No. 94, Hexblock 5e + +\ backup emptybuf readblk ks 23 jul 87 + +| : backup ( bufaddr -- ) dup 6+ @ 0< + IF 2+ dup @ 1+ \ buffer empty if file = -1 + IF BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w + WHILE 1 ?diskerror REPEAT + THEN 4+ dup @ $7FFF and over ! THEN + drop ; + + : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; + +| : readblk ( blk file addr -- blk file addr ) + dup emptybuf >r + BEGIN 2dup 0= offset @ and + + over r@ 8 + -rot 1 r/w + WHILE 2 ?diskerror REPEAT r> ; + +\ *** Block No. 95, Hexblock 5f + +\ take mark updates? full? core? ks 04 jul 87 + +| : take ( -- bufaddr) prev + BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL + buffers lock dup backup ; + +| : mark ( blk file bufaddr -- blk file ) 2+ >r + 2dup r@ ! over 0= offset @ and + r@ 2+ ! + r> 4+ off buffers unlock ; + +| : updates? ( -- bufaddr / flag) + prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; + + : core? ( blk file -- addr /false ) (core? 2drop false ; + + + +\ *** Block No. 96, Hexblock 60 + +\ block & buffer manipulation ks 01 okt 87 + + : (buffer ( blk file -- addr ) + BEGIN (core? take mark REPEAT ; + + : (block ( blk file -- addr ) + BEGIN (core? take readblk mark REPEAT ; + + Code isfile@ ( -- addr ) + D push isfile #) D mov Next end-code +\ : isfile@ ( -- addr ) isfile @ ; + + : buffer ( blk -- addr ) isfile@ (buffer ; + + : block ( blk -- addr ) isfile@ (block ; + + +\ *** Block No. 97, Hexblock 61 + +\ block & buffer manipulation ks 02 okt 87 + + : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; + + : save-buffers buffers lock + BEGIN updates? ?dup WHILE backup REPEAT buffers unlock ; + + : empty-buffers buffers lock prev + BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; + + : flush file-link + BEGIN @ ?dup WHILE dup fclose REPEAT + save-buffers empty-buffers ; + + + + +\ *** Block No. 98, Hexblock 62 + +\ Allocating buffers ks 31 oct 86 + $10000 Constant limit Variable first + + : allotbuffer ( -- ) + first @ r0 @ - b/buf 2+ u< ?exit + b/buf negate first +! first @ dup emptybuf + prev @ over ! prev ! ; + + : freebuffer ( -- ) first @ limit b/buf - u< + IF first @ backup prev + BEGIN dup @ first @ - WHILE @ REPEAT + first @ @ swap ! b/buf first +! THEN ; + + : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; + +| : init-buffers prev off limit first ! all-buffers ; + +\ *** Block No. 99, Hexblock 63 + +\ endpoints of forget uh 27 apr 88 + +| : |? ( nfa -- flag ) c@ $20 and ; + +| : forget? ( adr nfa -- flag ) \ code in heap or above adr ? + name> under 1+ u< swap heap? or ; + +| : endpoint ( addr sym thread -- addr sym' ) + BEGIN BEGIN @ 2 pick over u> IF drop exit THEN + dup heap? UNTIL dup >r 2+ dup |? + IF >r over r@ forget? IF r@ (name> >body umax THEN + rdrop THEN r> + REPEAT ; + +| : endpoints ( addr -- addr symb ) heap voc-link @ + BEGIN @ ?dup WHILE dup >r 4- endpoint r> REPEAT ; + +\ *** Block No. 100, Hexblock 64 + +\ remove, -words, -tasks ks 30 apr 88 + : remove ( dic sym thread -- dic sym ) + BEGIN dup @ ?dup \ unlink forg. words + WHILE dup heap? + IF 2 pick over u> ELSE 3 pick over 1+ u< THEN + IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; + +| : remove-words ( dic sym -- dic sym ) voc-link + BEGIN @ ?dup WHILE dup >r 4- remove r> REPEAT ; + +| : >up 2+ dup @ 2+ + ; + +| : remove-tasks ( dic -- ) up@ + BEGIN dup >up up@ - WHILE 2dup >up swap here uwithin + IF dup >up >up over - 2- 2- over 2+ ! ELSE >up THEN + REPEAT 2drop ; + +\ *** Block No. 101, Hexblock 65 + +\ remove-vocs trim ks 31 oct 86 + +| : remove-vocs ( dic symb -- dic symb ) + voc-link remove thru.vocstack + DO 2dup I @ -rot uwithin + IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP + 2dup current @ -rot uwithin 0=exit + [ ' Forth 2+ ] Literal current ! ; + + Defer custom-remove ' noop Is custom-remove + + : trim ( dic symb -- ) next-link remove + over remove-tasks remove-vocs remove-words remove-files + custom-remove heap swap - hallot dp ! last off ; + + + +\ *** Block No. 102, Hexblock 66 + +\ deleting words from dict. ks 02 okt 87 + + : clear here dup up@ trim dp ! ; + + : (forget ( adr -- ) + dup heap? Abort" is symbol" endpoints trim ; + + : forget ' dup [ dp ] Literal @ u< Abort" protected" + >name dup heap? IF name> ELSE 4- THEN (forget ; + + : empty [ dp ] Literal @ up@ trim + [ udp ] Literal @ udp ! ; + + + + + +\ *** Block No. 103, Hexblock 67 + +\ save bye stop? ?cr ks 1UH 26sep88 + + : save here up@ trim up@ origin $100 cmove + voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL ; + + $1B Constant #esc + +| : end? key #esc case? 0= + IF #cr case? 0= IF 3 ( Ctrl-C ) - ?exit THEN THEN + true rdrop ; + + : stop? ( -- flag ) key? IF end? end? THEN false ; + + : ?cr col c/l u> 0=exit cr ; + + + +\ *** Block No. 104, Hexblock 68 + +\ in/output structure ks 31 oct 86 + +| : Out: Create dup c, 2+ Does> c@ output @ + perform ; + + : Output: Create: Does> output ! ; +0 Out: emit Out: cr Out: type Out: del + Out: page Out: at Out: at? drop + + : row ( -- row ) at? drop ; + : col ( -- col ) at? nip ; + +| : In: Create dup c, 2+ Does> c@ input @ + perform ; + + : Input: Create: Does> input ! ; +0 In: key In: key? In: decode In: expect drop + + +\ *** Block No. 105, Hexblock 69 + +\ Alias only definitionen ks 31 oct 86 + + Root definitions + + : seal [ ' Root >body ] Literal off ; \ "erases" Root Vocab. + + ' Only Alias Only + ' Forth Alias Forth + ' words Alias words + ' also Alias also + ' definitions Alias definitions + + Forth definitions + + + + +\ *** Block No. 106, Hexblock 6a + +\ 'restart 'cold ks 01 sep 88 + + Defer 'restart ' noop Is 'restart + +| : (restart ['] (quit Is 'quit 'restart + [ errorhandler ] Literal @ errorhandler ! + ['] noop Is 'abort end-trace clearstack + standardi/o interpret quit ; + + Defer 'cold ' noop Is 'cold + +| : (cold origin up@ $100 cmove $80 count + $50 umin >r tib r@ move r> #tib ! >in off blk off + init-vocabularys init-buffers flush 'cold + Onlyforth page &24 spaces logo count type cr (restart ; + + +\ *** Block No. 107, Hexblock 6b + +\ (boot ks 11 mär 89 + + Label #segs ( -- R: seg ) Assembler + C: seg ' limit >body #) R mov R R or 0= not + ?[ 4 # C- mov R C* shr R inc ret ]? + $1000 # R mov ret + end-code + + Label (boot Assembler cli cld A A xor A D: mov + #segs # call C: D mov D R add R E: mov + $200 # C mov 0 # I mov I W mov rep movs + wake # >taskINT #) mov C: >taskINT 2+ #) mov + divovl # >divINT #) mov C: >divINT 2+ #) mov ret + end-code + + + +\ *** Block No. 108, Hexblock 6c + +\ restart ks 09 mär 89 + + Label warmboot here >restart 2+ - >restart ! Assembler + (boot # call + here ' (restart >body # I mov + Label bootsystem + C: A mov A E: mov A D: mov A S: mov + s0 #) U mov 6 # U add u' s0 U D) S mov + D pop u' r0 U D) R mov sti Next + end-code + + Code restart here 2- ! end-code + + + + + +\ *** Block No. 109, Hexblock 6d + +\ bye ks 11 mär 89 + + Variable return_code return_code off + +| Code (bye cli A A xor A E: mov #segs # call + C: D mov D R add R D: mov 0 # I mov I W mov + $200 # C mov rep movs sti \ restore interrupts + $4C # A+ mov C: seg return_code #) A- mov + $21 int warmboot # call + end-code + + : bye flush empty page (bye ; + + + + + +\ *** Block No. 110, Hexblock 6e + +\ cold ks 09 mär 89 + + here >cold 2+ - >cold ! Assembler + (boot # call C: A mov A D: mov A E: mov + #segs # call $41 # R add \ another k for the ints + $4A # A+ mov $21 int \ alloc memory + CS ?[ $10 # return_code #) byte mov ' (bye @ # jmp ]? + here s0 #) W mov 6 # W add origin # I mov $20 # C mov + rep movs ' (cold >body # I mov bootsystem # jmp + end-code + + Code cold here 2- ! end-code + + + + + diff --git a/8086/msdos/src/vf86dos.fth b/8086/msdos/src/vf86dos.fth new file mode 100644 index 0000000..5801a6e --- /dev/null +++ b/8086/msdos/src/vf86dos.fth @@ -0,0 +1,665 @@ +\ *** Block No. 112, Hexblock 70 + +\ lc@ lc! l@ l! special 8088 operators ks 27 oct 86 + + Code lc@ ( seg:addr -- 8b ) D: pop D W mov + W ) D- mov 0 # D+ mov C: A mov A D: mov Next + end-code + + Code lc! ( 8b seg:addr -- ) D: pop A pop D W mov + A- W ) mov C: A mov A D: mov D pop Next end-code + + Code l@ ( seg:addr -- 16b ) D: pop D W mov + W ) D mov C: A mov A D: mov Next end-code + + Code l! ( 16b seg:addr -- ) D: pop A pop D W mov + A W ) mov C: A mov A D: mov D pop Next end-code + + + +\ *** Block No. 113, Hexblock 71 + +\ ltype lmove special 8088 operators ks 11 dez 87 + + : ltype ( seg:addr len -- ) + 0 ?DO 2dup I + lc@ emit LOOP 2drop ; + + Code lmove ( from.seg:addr to.seg:addr quan -- ) + A I xchg D C mov W pop E: pop + I pop D: pop I W cmp CS + ?[ rep byte movs + ][ C dec C W add C I add C inc + std rep byte movs cld + ]? A I xchg C: A mov A E: mov + A D: mov D pop Next end-code + + + + +\ *** Block No. 114, Hexblock 72 + +\ BDOS keyboard input ks 16 sep 88 +\ es muss wirklich so kompliziert sein, da sonst kein ^C und ^P + +| Variable newkey newkey off + + Code (key@ ( -- 8b ) D push newkey #) D mov D+ D+ or + 0= ?[ $7 # A+ mov $21 int A- D- mov ]? + 0 # D+ mov D+ newkey 1+ #) mov Next + end-code + + Code (key? ( -- f ) D push newkey #) D mov D+ D+ or + 0= ?[ -1 # D- mov 6 # A+ mov $21 int 0= + ?[ 0 # D+ mov + ][ -1 # A+ mov A newkey #) mov -1 # D+ mov + ]? ]? D+ D- mov Next + end-code + +\ *** Block No. 115, Hexblock 73 + +\ empty-keys (key ks 16 sep 88 + + Code empty-keys $C00 # A mov $21 int + 0 # newkey 1+ #) byte mov Next end-code + + : (key ( -- 16b ) BEGIN pause (key? UNTIL + (key@ ?dup ?exit (key? IF (key@ negate exit THEN 0 ; + + + + + + + + + + +\ *** Block No. 116, Hexblock 74 + +\\ BIOS keyboard input ks 16 sep 88 + + Code (key@ ( -- 8b ) D push A+ A+ xor $16 int + A- D- xchg 0 # D+ mov Next end-code + + Code (key? ( -- f ) D push 1 # A+ mov D D xor + $16 int 0= not ?[ D dec ]? Next end-code + + Code empty-keys $C00 # A mov $21 int Next end-code + + : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; + +\ mit diesen Keytreibern sind die Funktionstasten nicht +\ mehr durch ANSI.SYS Sequenzen vorbelegt. + + + +\ *** Block No. 117, Hexblock 75 + +\ (decode expect ks 16 sep 88 + + 7 Constant #bel 8 Constant #bs + 9 Constant #tab $A Constant #lf + $D Constant #cr + + : (decode ( addr pos1 key -- addr pos2 ) + #bs case? IF dup 0=exit del 1- exit THEN + #cr case? IF dup span ! space exit THEN + >r 2dup + r@ swap c! r> emit 1+ ; + + : (expect ( addr len1 -- ) span ! 0 + BEGIN dup span @ u< WHILE key decode REPEAT 2drop ; + + Input: keyboard [ here input ! ] + (key (key? (decode (expect [ drop + +\ *** Block No. 118, Hexblock 76 + +\ MSDOS character output ks 29 jun 87 + + Code charout ( char -- ) $FF # D- cmp 0= ?[ D- dec ]? + 6 # A+ mov $21 int D pop ' pause # W mov W ) jmp + end-code + + &80 Constant c/row &25 Constant c/col + + : (emit ( char -- ) dup bl u< IF $80 or THEN charout ; + : (cr #cr charout #lf charout ; + : (del #bs charout bl charout #bs charout ; + : (at 2drop ; + : (at? 0 0 ; + : (page c/col 0 DO cr LOOP ; + + + +\ *** Block No. 119, Hexblock 77 + +\ MSDOS character output ks 7 may 85 + + : bell #bel charout ; + + : tipp ( addr len -- ) bounds ?DO I c@ emit LOOP ; + + Output: display [ here output ! ] + (emit (cr tipp (del (page (at (at? [ drop + + + + + + + + + +\ *** Block No. 120, Hexblock 78 + +\ MSDOS printer I/O Port access ks 09 aug 87 + + Code lst! ( 8b -- ) $5 # A+ mov $21 int D pop Next + end-code + + Code pc@ ( port -- 8b ) + D byte in A- D- mov D+ D+ xor Next + end-code + + Code pc! ( 8b port -- ) + A pop D byte out D pop Next + end-code + + + + + +\ *** Block No. 121, Hexblock 79 + +\ zero terminated strings ks 09 aug 87 + + : counted ( asciz -- addr len ) + dup -1 0 scan drop over - ; + + : >asciz ( string addr -- asciz ) 2dup >r - + IF count r@ place r@ THEN 0 r> count + c! 1+ ; + + + + : asciz ( -- asciz ) name here >asciz ; + + + + + + +\ *** Block No. 122, Hexblock 7a + +\ Disk capacities ks 08 aug 88 + Vocabulary Dos Dos also definitions + + 6 Constant #drives + + Create capacities $4B0 , $4B0 , $1B31 , $1B31 , $1B0F , 0 , + +| Code ?capacity ( +n -- cap ) D shl capacities # W mov + D W add W ) D mov Next end-code + + + + + + + + +\ *** Block No. 123, Hexblock 7b + +\ MS-dos disk handlers direct access ks 31 jul 87 + +| Code block@ ( addr blk drv -- ff ) + D- A- mov D pop C pop R push U push + I push C R mov 2 # C mov D shl $25 int + Label end-r/w I pop I pop U pop R pop 0 # D mov + CS ?[ D+ A+ mov A error# #) mov D dec ]? Next + end-code + +| Code block! ( addr blk drv -- ff ) D- A- mov D pop + C pop R push U push I push C R mov 2 # C mov + D shl $26 int end-r/w # jmp + end-code + + + + +\ *** Block No. 124, Hexblock 7c + +\ MS-dos disk handlers direct access ks cas 18jul20 + +| : ?drive ( +n -- +n ) dup #drives u< ?exit + Error" beyond drive capacity" ; + + : /drive ( blk1 -- blk2 drive ) 0 swap #drives 0 + DO dup I ?capacity under u< IF drop LEAVE THEN + - swap 1+ swap LOOP swap ; + + : blk/drv ( -- capacity ) drv ?capacity ; + + Forth definitions + + : >drive ( blk1 +n -- blk2 ) ?drive + 0 swap drv 2dup u> dup >r 0= IF swap THEN + ?DO I ?capacity + LOOP r> IF negate THEN - ; + +\ *** Block No. 125, Hexblock 7d + +\ MS-DOS file access ks 18 mär 88 + Dos definitions + +| Variable fcb fcb off \ last fcb accessed +| Variable prevfile \ previous active file + + &30 Constant fnamelen \ default length in FCB + + Create filename &62 allot \ max 60 + count + null + + Variable attribut 7 attribut ! \ read-only, hidden, system + + + + + + +\ *** Block No. 126, Hexblock 7e + +\ MS-DOS disk errors ks cas 18jul20 + +| : .error# ." error # " base push decimal error# @ . ; + +| : .ferrors error# @ &18 case? IF 2 THEN + 1 case? Abort" file exists" + 2 case? Abort" file not found" + 3 case? Abort" path not found" + 4 case? Abort" too many open files" + 5 case? Abort" no access" + 9 case? Abort" beyond end of file" + &15 case? Abort" illegal drive" + &16 case? Abort" current directory" + &17 case? Abort" wrong drive" + drop ." Disk" .error# abort ; + + +\ *** Block No. 127, Hexblock 7f + +\ MS-DOS disk errors ks cas 18jul20 + + : (diskerror ( *f -- ) ?dup 0=exit + fcb @ IF error# ! .ferrors exit THEN + input push output push standardi/o 1- + IF ." read" ELSE ." write" THEN + .error# ." retry? (y/n)" + key cr capital Ascii Y = not Abort" aborted" ; + + ' (diskerror Is ?diskerror + + + + + + + +\ *** Block No. 128, Hexblock 80 + +\ ~open ~creat ~close ks 04 aug 87 + + Code ~open ( asciz mode -- handle ff / err# ) + A D xchg $3D # A+ mov + Label >open D pop $21 int A D xchg + CS not ?[ D push 0 # D mov ]? Next + end-code + + Code ~creat ( asciz attribut -- handle ff / err# ) + D C mov $3C # A+ mov >open ]] end-code + + Code ~close ( handle -- ) D R xchg + $3E # A+ mov $21 int R D xchg D pop Next + end-code + + + +\ *** Block No. 129, Hexblock 81 + +\ ~first ~unlink ~select ~disk? ks 04 aug 87 + + Code ~first ( asciz attr -- err# ) + D C mov D pop $4E # A+ mov + [[ $21 int 0 # D mov CS ?[ A D xchg ]? Next + end-code + + Code ~unlink ( asciz -- err# ) $41 # A+ mov ]] end-code + + Code ~select ( n -- ) + $E # A+ mov $21 int D pop Next end-code + + Code ~disk? ( -- n ) D push $19 # A+ mov + $21 int A- D- mov 0 # D+ mov Next + end-code + + +\ *** Block No. 130, Hexblock 82 + +\ ~next ~dir ks 04 aug 87 + + Code ~next ( -- err# ) D push $4F # A+ mov + $21 int 0 # D mov CS ?[ A D xchg ]? Next + end-code + + Code ~dir ( addr drive -- err# ) I W mov + I pop $47 # A+ mov $21 int W I mov + 0 # D mov CS ?[ A D xchg ]? Next + end-code + + + + + + + +\ *** Block No. 131, Hexblock 83 + +\ MS-DOS file control Block cas 19jun20 + +| : Fcbytes ( n1 len -- n2 ) Create over c, + + Does> ( fcbaddr -- fcbfield ) c@ + ; + +\ first field for file-link +2 1 Fcbytes f.no \ must be first field + 2 Fcbytes f.handle + 2 Fcbytes f.date + 2 Fcbytes f.time + 4 Fcbytes f.size + fnamelen Fcbytes f.name Constant b/fcb + +b/fcb Host ' tb/fcb >body ! + Target Forth also Dos also definitions + + +\ *** Block No. 132, Hexblock 84 + +\ (.file fname fname! ks 10 okt 87 + + : fname! ( string fcb -- ) f.name >r count + dup fnamelen < not Abort" file name too long" r> place ; + +| : filebuffer? ( fcb -- fcb bufaddr / fcb ff ) + prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; + +| : flushfile ( fcb -- ) + BEGIN filebuffer? ?dup + WHILE dup backup emptybuf REPEAT drop ; + + : fclose ( fcb -- ) ?dup 0=exit + dup f.handle @ ?dup 0= IF drop exit THEN + over flushfile ~close f.handle off ; + + +\ *** Block No. 133, Hexblock 85 + +\ (.file fname fname! ks 18 mär 88 + +| : getsize ( -- d ) [ $80 &26 + ] Literal 2@ swap ; + + : (fsearch ( string -- asciz *f ) + filename >asciz dup attribut @ ~first ; + + Defer fsearch ( string -- asciz *f ) + + ' (fsearch Is fsearch + +\ graceful behaviour if file does not exist +| : ?notfound ( f* -- ) ?dup 0=exit last' @ [fcb] = + IF hide file-link @ @ file-link ! prevfile @ setfiles + last @ 4 - dp ! last off filename count here place + THEN ?diskerror ; + +\ *** Block No. 134, Hexblock 86 + +\ freset fseek ks 19 mär 88 + + : freset ( fcb -- ) ?dup 0=exit + dup f.handle @ ?dup IF ~close THEN dup >r + f.name fsearch ?notfound getsize r@ f.size 2! + [ $80 &22 + ] Literal @ r@ f.time ! + [ $80 &24 + ] Literal @ r@ f.date ! + 2 ~open ?diskerror r> f.handle ! ; + + + Code fseek ( dfaddr fcb -- ) + D W mov u' f.handle W D) W mov W W or 0= + ?[ ;c: dup freset fseek ; Assembler ]? R W xchg + C pop D pop $4200 # A mov $21 int W R mov + CS not ?[ D pop Next ]? A D xchg ;c: ?diskerror ; + + +\ *** Block No. 135, Hexblock 87 + +\ lfgets fgetc file@ ks 07 jul 88 + +\ Code ~read ( seg:addr quan handle -- #read ) D W mov +Assembler [[ W R xchg C pop D pop + D: pop $3F # A+ mov $21 int C: C mov C D: mov + W R mov A D xchg CS not ?[ Next ]? ;c: ?diskerror ; + + Code lfgets ( seg:addr quan fcb -- #read ) + D W mov u' f.handle W D) W mov ]] end-code + + true Constant eof + + : fgetc ( fcb -- 8b / eof ) + >r 0 sp@ ds@ swap 1 r> lfgets ?exit 0= ; + + : file@ ( dfaddr fcb -- 8b / eof ) dup >r fseek r> fgetc ; + +\ *** Block No. 136, Hexblock 88 + +\ lfputs fputc file! ks 24 jul 87 + +| Code ~write ( seg:addr quan handle -- ) D W mov +[[ W R xchg C pop D pop + D: pop $40 # A+ mov $21 int W R mov A D xchg + C: W mov W D: mov CS ?[ ;c: ?diskerror ; Assembler ]? + C D sub 0= ?[ D pop Next ]? ;c: Abort" Disk voll" ; + + Code lfputs ( seg:addr quan fcb -- ) + D W mov u' f.handle W D) W mov ]] end-code + + : fputc ( 8b fcb -- ) >r sp@ ds@ swap 1 r> lfputs drop ; + + : file! ( 8b dfaddr fcb -- ) dup >r fseek r> fputc ; + + + +\ *** Block No. 137, Hexblock 89 + +\ /block *block ks 02 okt 87 + + Code /block ( d -- rest blk ) A D xchg C pop + C D mov A shr D rcr A shr D rcr D+ D- mov + A- D+ xchg $3FF # C and C push Next + end-code +\ : /block ( d -- rest blk ) b/blk um/mod ; + + Code *block ( blk -- d ) A A xor D+ D- xchg D+ A+ xchg + A+ sal D rcl A+ sal D rcl A push Next + end-code +\ : *block ( blk -- d ) b/blk um* ; + + + + + +\ *** Block No. 138, Hexblock 8a + +\ fblock@ fblock! ks 19 mär 88 + Dos definitions + +| : ?beyond ( blk -- blk ) dup 0< 0=exit 9 ?diskerror ; + +| : fblock ( addr blk fcb -- seg:addr quan fcb ) + fcb ! ?beyond dup *block fcb @ fseek ds@ -rot + fcb @ f.size 2@ /block rot - ?beyond + IF drop b/blk THEN fcb @ ; + + : fblock@ ( addr blk fcb -- ) fblock lfgets drop ; + + : fblock! ( addr blk fcb -- ) fblock lfputs ; + + + + +\ *** Block No. 139, Hexblock 8b + +\ (r/w flush ks 18 mär 88 + Forth definitions + + : (r/w ( addr blk fcb r/wf -- *f ) over fcb ! over + IF IF fblock@ false exit THEN fblock! false exit + THEN >r drop /drive ?drive + r> IF block@ exit THEN block! ; + + ' (r/w Is r/w + +| : setfiles ( fcb -- ) isfile@ prevfile ! + dup isfile ! fromfile ! ; + + : direct 0 setfiles ; + + + +\ *** Block No. 140, Hexblock 8c + +\ File >file ks 23 mär 88 + + : File Create file-link @ here file-link ! , + here [ b/fcb 2 - ] Literal dup allot erase + file-link @ dup @ f.no c@ 1+ over f.no c! + last @ count $1F and rot f.name place + Does> setfiles ; + + File kernel.scr ' kernel.scr @ Constant [fcb] + + Dos definitions + + : .file ( fcb -- ) + ?dup IF body> >name .name exit THEN ." direct" ; + + + +\ *** Block No. 141, Hexblock 8d + +\ .file pushfile close open ks 12 mai 88 + Forth definitions + + : file? isfile@ .file ; + + : pushfile r> isfile push fromfile push >r ; restrict + + : close isfile@ fclose ; + + : open isfile@ freset ; + + : assign isfile@ dup fclose name swap fname! open ; + + + + + +\ *** Block No. 142, Hexblock 8e + +\ use from loadfrom include ks 18 mär 88 + + : use >in @ name find + 0= IF swap >in ! File last' THEN nip + dup @ [fcb] = over ['] direct = or + 0= Abort" not a file" execute open ; + + : from isfile push use ; + + : loadfrom ( n -- ) pushfile use load close ; + + : include 1 loadfrom ; + + + + + +\ *** Block No. 143, Hexblock 8f + +\ drive drv capacity drivenames ks 18 mär 88 + + : drive ( n -- ) isfile@ IF ~select exit THEN + ?drive offset off 0 ?DO I ?capacity offset +! LOOP ; + + : drv ( -- n ) + isfile@ IF ~disk? exit THEN offset @ /drive nip ; + + : capacity ( -- n ) isfile@ ?dup + IF dup f.handle @ 0= IF dup freset THEN + f.size 2@ /block swap 0<> - exit THEN blk/drv ; + +| : Drv: Create c, Does> c@ drive ; + + 0 Drv: A: 1 Drv: B: 2 Drv: C: 3 Drv: D: + 4 Drv: E: 5 Drv: F: 6 Drv: G: 7 Drv: H: + +\ *** Block No. 144, Hexblock 90 + +\ lfsave savefile savesystem ks 10 okt 87 + + : lfsave ( seg:addr quan string -- ) + filename >asciz 0 ~creat ?diskerror + dup >r ~write r> ~close ; + + : savefile ( addr len -- ) ds@ -rot + name nullstring? Abort" needs name" lfsave ; + + : savesystem save flush $100 here savefile ; + + + + + + + +\ *** Block No. 145, Hexblock 91 + +\ viewing ks 19 mär 88 + Dos definitions +| $400 Constant viewoffset + + : (makeview ( -- n ) + blk @ dup 0=exit loadfile @ ?dup 0=exit f.no c@ ?dup + IF viewoffset * + $8000 or exit THEN 0= ; + ' (makeview Is makeview + + : @view ( acf -- blk fno ) >name 4 - @ dup 0< + IF $7FFF and viewoffset u/mod exit THEN + ?dup 0= Error" eingetippt" 0 ; + + : >file ( fno -- fcb ) dup 0=exit file-link + BEGIN @ dup WHILE 2dup f.no c@ = UNTIL nip ; + + +\ *** Block No. 146, Hexblock 92 + +\ forget FCB's ks 23 okt 88 + Forth definitions +| : 'file ( -- scr ) r> scr push isfile push >r + [ Dos ] ' @view >file isfile ! ; + + : view 'file list ; + : help 'file capacity 2/ + list ; + +| : remove? ( dic symb addr -- dic symb addr f ) + 2 pick over 1+ u< ; + +| : remove-files ( dic symb -- dic symb ) file-link + BEGIN @ ?dup WHILE remove? IF dup fclose THEN REPEAT + file-link remove + isfile@ remove? nip IF file-link @ isfile ! THEN + fromfile @ remove? nip 0=exit isfile@ fromfile ! ; + diff --git a/8086/msdos/src/vf86info.txt b/8086/msdos/src/vf86info.txt new file mode 100644 index 0000000..efb70e8 --- /dev/null +++ b/8086/msdos/src/vf86info.txt @@ -0,0 +1,58 @@ + +\ *** Block No. 0, Hexblock 0 + +\^@ #### volksFORTH #### cas 18jul20 +VolksForth has been developed by + + K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck + Ulli Hoffmann, Philip Zembrod, Carsten Strotmann +6502 version by B.Pennemann and K.Schleisiek +Port to C64 "ultraFORTH" by G. Rehfeld +Port to 68000 and Atari ST by D.Weineck and B.Pennemann +Port to 8080 and CP/M by U.Hoffmann jul 86 +Port to C16 "ultraFORTH" by C.Vogt +Port to 8088/86 and MS-DOS by K.Schleisiek dez 87 + + + + + + +\ *** Block No. 2, Hexblock 2 + +\\ Die Nutzung der 8088/86 Register ks 27 oct 86 + +Im Assembler sind Forthgemaesse Namen fuer die Register gewaehlt +Dabei ist die Zuordnung zu den Intel Namen folgendermassen: + +A <=> AX A- <=> AL A+ <=> AH +C <=> CX C- <=> CL C+ <=> CH + Register A und C sind zur allgemeinen Benutzung frei + +D <=> DX D- <=> DL D+ <=> DH + das oberste Element des (Daten)-Stacks. + +R <=> BX R- <=> RL R+ <=> RH + der Return_stack_pointer + + + +\ *** Block No. 3, Hexblock 3 + +\\ Die Nutzung der 8088/86 Register ks 27 oct 86 + +U <=> BP User_area_pointer +S <=> SP Daten_stack_pointer +I <=> SI Instruction_pointer +W <=> DI Word_pointer, im allgemeinen zur Benutzung frei. + +D: <=> DS E: <=> ES S: <=> SS C: <=> CS + Alle Segmentregister werden beim booten auf den Wert des + Codesegments C: gesetzt und muessen, wenn sie "verstellt" + werden, wieder auf C: zurueckgesetzt werden. + + + + + + From 6012afd9d827cf2de71e9801a32faf99120c68a4 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sat, 5 Mar 2022 23:14:05 +0100 Subject: [PATCH 10/17] Enable metacompiler to include fth files --- 8086/msdos/src/meta.fb | 2 +- 8086/msdos/src/meta.fth | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/8086/msdos/src/meta.fb b/8086/msdos/src/meta.fb index 18bf82f..0716ca9 100644 --- a/8086/msdos/src/meta.fb +++ b/8086/msdos/src/meta.fb @@ -1 +1 @@ - \ Target compiler loadscr ks cas 09jun20 Onlyforth \needs Assembler 2 loadfrom asm.fb : c+! ( 8b addr -- ) dup c@ rot + swap c! ; ' find $22 + @ Alias found : search ( string 'vocab -- acf n / string ff ) dup @ [ ' Forth @ ] Literal - Abort" no vocabulary" >body (find IF found exit THEN false ; 3 &27 thru Onlyforth savesystem meta.com cr .( Metacompiler saved as META.COM ) \ Predefinitions loadscreen ks 30 apr 88 &28 load cr .( Predefinitions geladen ...) cr \ Target header pointers ks 29 jun 87 Variable tfile tfile off \ handle of target file Variable tdp tdp off \ target dp Variable displace displace off \ diplacement of code Variable ?thead ?thead off \ for headerless code Variable tlast tlast off \ last name in target Variable glast' glast' off \ acf of latest ghost Variable tdoes> tdoes> off \ code addr of last does Variable tdodo tdodo off \ location of dodo Variable >in: >in: off \ last :-def Variable tvoc tvoc off \ Variable tvoc-link tvoc-link off \ voc-link in target Variable tnext-link tnext-link off \ link for tracer \ Target header pointers ks 10 okt 87 : there ( -- taddr ) tdp @ ; : new pushfile makefile isfile@ tfile ! tvoc-link off tnext-link off $100 tdp ! $100 displace ! ; \ Ghost-creating ks 07 dez 87 0 | Constant 0 | Constant | Create gname $21 allot | : >heap ( from quan -- ) \ heap over - 1 and + \ align dup hallot heap swap cmove ; : symbolic ( string -- cfa.ghost ) count dup 1 $1F uwithin not Abort" invalid Gname" gname place BL gname append align here >r makeview , state @ IF context ELSE current THEN @ @ dup @ , gname count under here place 1+ allot align here r@ - , 0 , 0 , r@ here over - >heap heap 2+ rot ! r> dp ! heap + ; \ ghost words ks 07 dez 87 : gfind ( string -- cfa tf / string ff ) >r 1 r@ c+! r@ find -1 r> c+! ; : ghost ( -- cfa ) name gfind ?exit symbolic ; : gdoes> ( cfa.ghost -- cfa.does ) 4 + dup @ IF @ exit THEN here , 0 , dup 4 >heap dp ! heap swap ! heap ; \ ghost utilities ks 29 jun 87 : g' ( -- acf ) name gfind 0= Abort" ?T?" ; : '. g' dup @ case? IF ." forw" ELSE - Abort" ??" ." res" THEN 2+ dup @ 5 u.r 2+ @ ?dup IF dup @ case? IF ." fdef" ELSE - Abort" ??" ." rdef" THEN 2+ @ 5 u.r THEN ; ' ' Alias h' \ .unresolved ks 29 jun 87 | : forward? ( cfa -- cfa / exit&true ) dup @ = 0=exit dup 2+ @ 0=exit drop true rdrop ; | : unresolved? ( addr -- f ) 2+ dup count $1F and + 1- c@ bl = IF name> forward? 4+ @ dup IF forward? THEN THEN drop false ; | : unresolved-words ( thread -- ) BEGIN @ ?dup WHILE dup unresolved? IF dup 2+ .name ?cr THEN REPEAT ; : .unresolved voc-link @ BEGIN dup 4 - unresolved-words @ ?dup 0= UNTIL ; \ Extending Vocabularys for Target-Compilation ks 29 jun 87 Vocabulary Ttools Vocabulary Defining : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; Vocabulary Transient tvoc off Root definitions : T Transient ; immediate : H Forth ; immediate : D Defining ; immediate Forth definitions \ Image and byteorder ks 02 jul 87 | Code >byte ( 16b -- 8b- 8b+ ) A A xor D- A- xchg D+ D- xchg A push Next end-code | Code byte> ( 8b- 8b+ -- 16b ) A pop D- D+ mov A- D- xchg Next end-code | : >target ( addr1 -- daddr fcb ) displace @ - 0 tfile @ ; Transient definitions : c@ ( addr -- 8b ) [ Dos ] >target file@ dup 0< Abort" nie abgespeichert" ; : c! ( 8b addr -- ) [ Dos ] >target file! ; \ Transient primitives ks 09 jul 87 : @ ( addr -- n ) H dup T c@ swap 1+ c@ byte> ; : ! ( n addr -- ) H >r >byte r@ 1+ T c! r> c! H ; : cmove ( from.mem to.target quan -- ) [ Dos ] >r >target fseek ds@ swap r> tfile @ lfputs ; \ bounds ?DO dup c@ I T c! H 1+ LOOP drop ; : here ( -- taddr ) H tdp @ ; : here! ( taddr -- ) H tdp ! ; : allot ( n -- ) H tdp +! ; : c, ( 8b -- ) T here c! 1 allot H ; : , ( 16b -- ) T here ! 2 allot H ; : align ( -- ) H ; immediate : even ( addr1 -- addr2 ) H ; immediate : halign H ; immediate \ Transient primitives ks 29 jun 87 : count ( addr1 -- addr2 len ) H dup 1+ swap T c@ H ; : ," H here ," here over dp ! over - T here swap dup allot cmove H ; : fill ( addr quan 8b -- ) H -rot bounds ?DO dup I T c! H LOOP drop ; : erase ( addr quan -- ) H 0 T fill H ; : blank ( addr quan -- ) H bl T fill H ; : move-threads H tvoc @ tvoc-link @ BEGIN over ?dup WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT Error" some undef. Target-Vocs left" drop ; \ Resolving ks 29 jun 87 Forth definitions : resolve ( cfa.ghost cfa.target -- ) over dup @ = IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN >r >r 2+ @ ?dup IF BEGIN dup T @ H 2dup = Abort" resolve loop" r@ rot T ! H ?dup 0= UNTIL THEN r> r> over ! 2+ ! ; : resdoes> ( acf.ghost acf.target -- ) swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; here 2+ 0 ] Does> dup @ there rot ! T , H ; ' >body ! here 2+ 0 ] Does> @ T , H ; ' >body ! \ compiling names into targ. ks 10 okt 87 | : tlatest ( -- addr ) current @ 6 + ; : (theader ?thead @ IF 1 ?thead +! exit THEN >in @ bl word swap >in ! dup count upper dup c@ 1 $20 uwithin not Abort" inval. Tname" blk @ $8400 or T align , H there tlatest @ T , H tlatest ! there tlast ! there over c@ 1+ dup T allot cmove align H ; : theader tlast off (theader ghost dup glast' ! there resolve ; \ prebuild defining words ks 29 jun 87 | : (prebuild >in @ Create >in ! r> dup 2+ >r @ here 2- ! ; | : tpfa, there , ; : prebuild ( addr check# -- check# ) 0 ?pairs dup IF compile (prebuild dup , THEN compile theader ghost gdoes> , IF compile tpfa, THEN 0 ; immediate : dummy 0 ; : DO> [compile] Does> here 3 - compile @ 0 ] ; \ Constructing defining words in Host kks 07 dez 87 | : defcomp ( string -- ) dup ['] Defining search ?dup IF 0> IF nip execute exit THEN drop dup THEN find ?dup IF 0< IF nip , exit THEN THEN drop ['] Forth search ?dup IF 0< IF , exit THEN execute exit THEN number? ?dup 0= Abort" ?" 0> IF swap [compile] Literal THEN [compile] Literal ; | : definter ( string -- ) dup ['] Defining search ?dup IF 0< IF nip execute exit THEN THEN drop find ?dup IF 1 and 0= Abort" compile only" execute exit THEN number? 0= Error" ?" ; \ Constructing defining words in Host ks 22 dez 87 | : (;tcode r> @ tlast @ T count + ! H ; Defining definitions : ] H ] ['] defcomp Is parser ; : [ H [compile] [ ['] definter Is parser ; immediate : ; H [compile] ; [compile] \\ ; immediate : Does> H compile (;tcode tdoes> @ , [compile] ; -2 allot [compile] \\ ; immediate D ' Does> Alias ;Code immediate H \ reinterpreting defining words ks 22 dez 87 Forth definitions : ?reinterpret ( f -- ) 0=exit state @ >r >in @ >r adr parser @ >r >in: @ >in ! : D ] H interpret r> Is parser r> >in ! r> state ! ; : undefined? ( -- f ) glast' @ 4+ @ 0= ; | : flag! ( 8b -- ) tlast @ ?dup 0= IF drop exit THEN dup T c@ rot or swap c! H ; | : nfa? ( acf alf -- anf / acf ff ) BEGIN dup WHILE 2dup 2+ T count $1F and + even H = IF 2+ nip exit THEN T @ H REPEAT ; \ the 8086 Assembler ks 29 jun 87 | Create relocate ] T c, , here ! c! H [ Transient definitions : Assembler H [ Assembler ] relocate >codes ! Assembler ; : >label ( 16b -- ) H >in @ name gfind rot >in ! IF over resolve dup THEN drop Constant ; : Label T here >label Assembler H ; : Code H theader T here 2+ , Assembler H ; ( Transient primitives ks 17 dec 83 ) ' exit Alias exit ' load Alias load ' / Alias / ' thru Alias thru ' swap Alias swap ' * Alias * ' dup Alias dup ' drop Alias drop ' /mod Alias /mod ' rot Alias rot ' -rot Alias -rot ' over Alias over ' 2* Alias 2* ' + Alias + ' - Alias - ' 1+ Alias 1+ ' 2+ Alias 2+ ' 1- Alias 1- ' 2- Alias 2- ' negate Alias negate ' 2swap Alias 2swap ' 2dup Alias 2dup \ Transient primitives kks 29 jun 87 ' also Alias also ' words Alias words ' definitions Alias definitions ' hex Alias hex ' decimal Alias decimal ' ( Alias ( immediate ' \ Alias \ immediate ' \\ Alias \\ immediate ' .( Alias .( immediate ' [ Alias [ immediate ' cr Alias cr ' end-code Alias end-code ' Transient Alias Transient ' +thru Alias +thru ' +load Alias +load ' .s Alias .s Tools ' trace Alias trace immediate \ immediate words and branch primitives ks 29 jun 87 : >mark ( -- addr ) T here 0 , H ; : >resolve ( addr -- ) T here over - swap ! H ; : name ks 29 jun 87 : ' ( -- acf ) H g' dup @ - IF Error" undefined" THEN 2+ @ ; : compile H ghost , ; immediate restrict : >name ( acf -- anf / ff ) H tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup IF nip exit THEN swap REPEAT nip ; \ >name Alias ks 29 jun 87 : >body ( acf -- apf ) H 2+ ; : Alias ( n -- ) H tlast off (theader ghost over resolve T , H $20 flag! ; : on ( addr -- ) H true swap T ! H ; : off ( addr -- ) H false swap T ! H ; \ Target tools ks 9 sep 86 Onlyforth | : .tfield ( taddr len quan -) >r under Pad swap bounds ?DO dup T c@ I H c! 1+ LOOP drop Pad over type r> swap - 0 max spaces ; ' view Alias hview Ttools also definitions | : ?: ( addr -- addr ) dup 4 u.r ." :" ; | : @? ( addr -- addr ) dup T @ H 6 u.r ; | : c? ( addr -- addr ) dup T c@ H 3 .r ; \ Ttools for decompiling ks 9 sep 86 : s ( addr -- addr+ ) ?: space c? 4 spaces T count 2dup + even -rot 18 .tfield ; : n ( addr -- addr+2 ) ?: @? 2 spaces dup T @ >name H ?dup IF T count H ELSE 0 0 THEN $1F and $18 .tfield 2+ ; : d ( addr n -- addr+n ) 2dup swap ?: 3 spaces swap 0 DO c? 1+ LOOP 4 spaces -rot dup .tfield ; : l ( addr -- addr+2 ) ?: 6 spaces @? 2+ 14 spaces ; : c ( addr -- addr+1 ) 1 d 15 spaces ; \ Tools for decompiling ks 29 jun 87 : b ( addr -- addr+2 ) ?: @? dup T @ H over + 6 u.r 2+ 14 spaces ; : dump ( addr n -- ) bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; : view T ' >name H ?dup 0=exit 4 - T @ H ?dup 0=exit edit ; \ Predefinitions loadscreen ks 29 jun 87 Onlyforth : clear H true Abort" There are ghosts" ; 1 $B +thru \ Literal ['] ?" ." " ks 29 jun 87 Transient definitions Forth : Literal ( n -- ) H dup $FF00 and IF T compile lit , H exit THEN T compile clit c, H ; immediate : Ascii H bl word 1+ c@ state @ 0=exit T [compile] Literal H ; immediate : ['] T compile lit H ; immediate : ." T compile (." ," align H ; immediate : " T compile (" ," align H ; immediate \ Target compilation ] ks 07 dez 87 Forth definitions | : tcompile ( string -- ) dup find ?dup IF 0> IF nip execute exit THEN THEN drop gfind IF execute exit THEN number? ?dup IF 0> IF swap T [compile] Literal THEN [compile] Literal H exit THEN symbolic execute ; Transient definitions : ] H ] ['] tcompile Is parser ; \ Target conditionals ks 10 sep 86 : IF T compile ?branch >mark H 1 ; immediate restrict : THEN abs 1 ?pairs T >resolve H ; immediate restrict : ELSE 1 ?pairs T compile branch >mark swap >resolve H -1 ; immediate restrict : BEGIN T mark H -2 2swap ; immediate restrict | : (repeat 2 ?pairs T resolve H REPEAT ; : UNTIL T compile ?branch (repeat H ; immediate restrict : REPEAT T compile branch (repeat H ; immediate restrict \ Target conditionals Abort" etc. ks 09 feb 88 : DO T compile (do >mark H 3 ; immediate restrict : ?DO T compile (?do >mark H 3 ; immediate restrict : LOOP 3 ?pairs T compile (loop compile endloop >resolve H ; immediate restrict : +LOOP 3 ?pairs T compile (+loop compile endloop >resolve H ; immediate restrict : Abort" T compile (abort" ," align H ; immediate restrict : Error" T compile (error" ," align H ; immediate restrict \ Target does> ;code ks 29 jun 87 | : dodoes> T compile (;code H glast' @ there resdoes> there tdoes> ! ; : Does> H undefined? T dodoes> $E9 c, H tdodo @ there - 2- T , H ?reinterpret ; immediate restrict : ;Code H 0 ?pairs undefined? T dodoes> H ?reinterpret T [compile] [ Assembler H ; immediate restrict \ User ks 09 jul 87 Forth definitions Variable torigin torigin off \ cold boot vector Variable tudp tudp off \ user variable counter : >user ( addr1 -- addr2 ) T c@ H torigin @ + ; Transient definitions Forth : origin! ( taddr -- ) H torigin ! tudp off ; : uallot ( n -- offset ) H tudp @ swap tudp +! ; DO> >user ; : User T prebuild User 2 uallot c, H ; \ Variable Constant Create ks 01 okt 87 DO> ; : Variable T prebuild Create 2 allot H ; DO> T @ H ; : Constant T prebuild Constant , H ; DO> ; : Create T prebuild Create H ; : Create: T Create ] H end-code 0 ; \ Defer Is Vocabulary ks 29 jun 87 DO> ; : Defer T prebuild Defer 2 allot ; : Is T ' >body H state @ IF T compile (is , H exit THEN T ! H ; immediate dummy : Vocabulary H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , H there tvoc-link @ T , H tvoc-link ! ; \ File ks 19 m„r 88 Forth definitions Variable tfile-link tfile-link off Variable tfileno tfileno off &45 Constant tb/fcb Transient definitions Forth dummy : File T prebuild File here tb/fcb 0 fill here H tfile-link @ T , H tfile-link ! 1 tfileno +! tfileno @ T c, 0 , 0 , 0 , 0 , 0 , here dup >r 1+ tb/fcb &13 - allot H tlast @ T count dup r> c! H bounds ?DO I T c@ over c! H 1+ LOOP drop ; \ : ; compile Host [compile] ks 29 jun 87 dummy : : H >in @ >in: ! T prebuild : ] H end-code 0 ; : ; 0 ?pairs T compile unnest [compile] [ H ; immediate restrict : compile T compile compile H ; immediate restrict : Host H Onlyforth ; : Compiler H Onlyforth Transient also definitions ; : [compile] H ghost execute ; immediate restrict \ Target ks 29 jun 87 Onlyforth : Target H vp off Transient also definitions ; Transient definitions ghost c, drop \ No newline at end of file + \ Target compiler loadscr ks cas 09jun20 Onlyforth \needs Assembler 2 loadfrom asm.fb : c+! ( 8b addr -- ) dup c@ rot + swap c! ; ' find $22 + @ Alias found : search ( string 'vocab -- acf n / string ff ) dup @ [ ' Forth @ ] Literal - Abort" no vocabulary" >body (find IF found exit THEN false ; 3 &27 thru Onlyforth savesystem meta.com cr .( Metacompiler saved as META.COM ) \ Predefinitions loadscreen ks 30 apr 88 &28 load cr .( Predefinitions geladen ...) cr \ Target header pointers ks 29 jun 87 Variable tfile tfile off \ handle of target file Variable tdp tdp off \ target dp Variable displace displace off \ diplacement of code Variable ?thead ?thead off \ for headerless code Variable tlast tlast off \ last name in target Variable glast' glast' off \ acf of latest ghost Variable tdoes> tdoes> off \ code addr of last does Variable tdodo tdodo off \ location of dodo Variable >in: >in: off \ last :-def Variable tvoc tvoc off \ Variable tvoc-link tvoc-link off \ voc-link in target Variable tnext-link tnext-link off \ link for tracer \ Target header pointers ks 10 okt 87 : there ( -- taddr ) tdp @ ; : new pushfile makefile isfile@ tfile ! tvoc-link off tnext-link off $100 tdp ! $100 displace ! ; \ Ghost-creating ks 07 dez 87 0 | Constant 0 | Constant | Create gname $21 allot | : >heap ( from quan -- ) \ heap over - 1 and + \ align dup hallot heap swap cmove ; : symbolic ( string -- cfa.ghost ) count dup 1 $1F uwithin not Abort" invalid Gname" gname place BL gname append align here >r makeview , state @ IF context ELSE current THEN @ @ dup @ , gname count under here place 1+ allot align here r@ - , 0 , 0 , r@ here over - >heap heap 2+ rot ! r> dp ! heap + ; \ ghost words ks 07 dez 87 : gfind ( string -- cfa tf / string ff ) >r 1 r@ c+! r@ find -1 r> c+! ; : ghost ( -- cfa ) name gfind ?exit symbolic ; : gdoes> ( cfa.ghost -- cfa.does ) 4 + dup @ IF @ exit THEN here , 0 , dup 4 >heap dp ! heap swap ! heap ; \ ghost utilities ks 29 jun 87 : g' ( -- acf ) name gfind 0= Abort" ?T?" ; : '. g' dup @ case? IF ." forw" ELSE - Abort" ??" ." res" THEN 2+ dup @ 5 u.r 2+ @ ?dup IF dup @ case? IF ." fdef" ELSE - Abort" ??" ." rdef" THEN 2+ @ 5 u.r THEN ; ' ' Alias h' \ .unresolved ks 29 jun 87 | : forward? ( cfa -- cfa / exit&true ) dup @ = 0=exit dup 2+ @ 0=exit drop true rdrop ; | : unresolved? ( addr -- f ) 2+ dup count $1F and + 1- c@ bl = IF name> forward? 4+ @ dup IF forward? THEN THEN drop false ; | : unresolved-words ( thread -- ) BEGIN @ ?dup WHILE dup unresolved? IF dup 2+ .name ?cr THEN REPEAT ; : .unresolved voc-link @ BEGIN dup 4 - unresolved-words @ ?dup 0= UNTIL ; \ Extending Vocabularys for Target-Compilation ks 29 jun 87 Vocabulary Ttools Vocabulary Defining : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; Vocabulary Transient tvoc off Root definitions : T Transient ; immediate : H Forth ; immediate : D Defining ; immediate Forth definitions \ Image and byteorder ks 02 jul 87 | Code >byte ( 16b -- 8b- 8b+ ) A A xor D- A- xchg D+ D- xchg A push Next end-code | Code byte> ( 8b- 8b+ -- 16b ) A pop D- D+ mov A- D- xchg Next end-code | : >target ( addr1 -- daddr fcb ) displace @ - 0 tfile @ ; Transient definitions : c@ ( addr -- 8b ) [ Dos ] >target file@ dup 0< Abort" nie abgespeichert" ; : c! ( 8b addr -- ) [ Dos ] >target file! ; \ Transient primitives ks 09 jul 87 : @ ( addr -- n ) H dup T c@ swap 1+ c@ byte> ; : ! ( n addr -- ) H >r >byte r@ 1+ T c! r> c! H ; : cmove ( from.mem to.target quan -- ) [ Dos ] >r >target fseek ds@ swap r> tfile @ lfputs ; \ bounds ?DO dup c@ I T c! H 1+ LOOP drop ; : here ( -- taddr ) H tdp @ ; : here! ( taddr -- ) H tdp ! ; : allot ( n -- ) H tdp +! ; : c, ( 8b -- ) T here c! 1 allot H ; : , ( 16b -- ) T here ! 2 allot H ; : align ( -- ) H ; immediate : even ( addr1 -- addr2 ) H ; immediate : halign H ; immediate \ Transient primitives ks 29 jun 87 : count ( addr1 -- addr2 len ) H dup 1+ swap T c@ H ; : ," H here ," here over dp ! over - T here swap dup allot cmove H ; : fill ( addr quan 8b -- ) H -rot bounds ?DO dup I T c! H LOOP drop ; : erase ( addr quan -- ) H 0 T fill H ; : blank ( addr quan -- ) H bl T fill H ; : move-threads H tvoc @ tvoc-link @ BEGIN over ?dup WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT Error" some undef. Target-Vocs left" drop ; \ Resolving ks 29 jun 87 Forth definitions : resolve ( cfa.ghost cfa.target -- ) over dup @ = IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN >r >r 2+ @ ?dup IF BEGIN dup T @ H 2dup = Abort" resolve loop" r@ rot T ! H ?dup 0= UNTIL THEN r> r> over ! 2+ ! ; : resdoes> ( acf.ghost acf.target -- ) swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; here 2+ 0 ] Does> dup @ there rot ! T , H ; ' >body ! here 2+ 0 ] Does> @ T , H ; ' >body ! \ compiling names into targ. ks 10 okt 87 | : tlatest ( -- addr ) current @ 6 + ; : (theader ?thead @ IF 1 ?thead +! exit THEN >in @ bl word swap >in ! dup count upper dup c@ 1 $20 uwithin not Abort" inval. Tname" blk @ $8400 or T align , H there tlatest @ T , H tlatest ! there tlast ! there over c@ 1+ dup T allot cmove align H ; : theader tlast off (theader ghost dup glast' ! there resolve ; \ prebuild defining words ks 29 jun 87 | : (prebuild >in @ Create >in ! r> dup 2+ >r @ here 2- ! ; | : tpfa, there , ; : prebuild ( addr check# -- check# ) 0 ?pairs dup IF compile (prebuild dup , THEN compile theader ghost gdoes> , IF compile tpfa, THEN 0 ; immediate : dummy 0 ; : DO> [compile] Does> here 3 - compile @ 0 ] ; \ Constructing defining words in Host kks 07 dez 87 | : defcomp ( string -- ) dup ['] Defining search ?dup IF 0> IF nip execute exit THEN drop dup THEN find ?dup IF 0< IF nip , exit THEN THEN drop ['] Forth search ?dup IF 0< IF , exit THEN execute exit THEN number? ?dup 0= Abort" ?" 0> IF swap [compile] Literal THEN [compile] Literal ; | : definter ( string -- ) dup ['] Defining search ?dup IF 0< IF nip execute exit THEN THEN drop find ?dup IF 1 and 0= Abort" compile only" execute exit THEN number? 0= Error" ?" ; \ Constructing defining words in Host ks 22 dez 87 | : (;tcode r> @ tlast @ T count + ! H ; Defining definitions : ] H ] ['] defcomp Is parser ; : [ H [compile] [ ['] definter Is parser ; immediate : ; H [compile] ; [compile] \\ ; immediate : Does> H compile (;tcode tdoes> @ , [compile] ; -2 allot [compile] \\ ; immediate D ' Does> Alias ;Code immediate H \ reinterpreting defining words ks 22 dez 87 Forth definitions : ?reinterpret ( f -- ) 0=exit state @ >r >in @ >r adr parser @ >r >in: @ >in ! : D ] H interpret r> Is parser r> >in ! r> state ! ; : undefined? ( -- f ) glast' @ 4+ @ 0= ; | : flag! ( 8b -- ) tlast @ ?dup 0= IF drop exit THEN dup T c@ rot or swap c! H ; | : nfa? ( acf alf -- anf / acf ff ) BEGIN dup WHILE 2dup 2+ T count $1F and + even H = IF 2+ nip exit THEN T @ H REPEAT ; \ the 8086 Assembler ks 29 jun 87 | Create relocate ] T c, , here ! c! H [ Transient definitions : Assembler H [ Assembler ] relocate >codes ! Assembler ; : >label ( 16b -- ) H >in @ name gfind rot >in ! IF over resolve dup THEN drop Constant ; : Label T here >label Assembler H ; : Code H theader T here 2+ , Assembler H ; \ Transient primitives ks 1phz 05m„r22 ' exit Alias exit ' load Alias load ' / Alias / ' thru Alias thru ' swap Alias swap ' * Alias * ' dup Alias dup ' drop Alias drop ' /mod Alias /mod ' rot Alias rot ' -rot Alias -rot ' over Alias over ' 2* Alias 2* ' + Alias + ' - Alias - ' 1+ Alias 1+ ' 2+ Alias 2+ ' 1- Alias 1- ' 2- Alias 2- ' negate Alias negate ' 2swap Alias 2swap ' 2dup Alias 2dup ' include Alias include \ Transient primitives kks 29 jun 87 ' also Alias also ' words Alias words ' definitions Alias definitions ' hex Alias hex ' decimal Alias decimal ' ( Alias ( immediate ' \ Alias \ immediate ' \\ Alias \\ immediate ' .( Alias .( immediate ' [ Alias [ immediate ' cr Alias cr ' end-code Alias end-code ' Transient Alias Transient ' +thru Alias +thru ' +load Alias +load ' .s Alias .s Tools ' trace Alias trace immediate \ immediate words and branch primitives ks 29 jun 87 : >mark ( -- addr ) T here 0 , H ; : >resolve ( addr -- ) T here over - swap ! H ; : name ks 29 jun 87 : ' ( -- acf ) H g' dup @ - IF Error" undefined" THEN 2+ @ ; : compile H ghost , ; immediate restrict : >name ( acf -- anf / ff ) H tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup IF nip exit THEN swap REPEAT nip ; \ >name Alias ks 29 jun 87 : >body ( acf -- apf ) H 2+ ; : Alias ( n -- ) H tlast off (theader ghost over resolve T , H $20 flag! ; : on ( addr -- ) H true swap T ! H ; : off ( addr -- ) H false swap T ! H ; \ Target tools ks 9 sep 86 Onlyforth | : .tfield ( taddr len quan -) >r under Pad swap bounds ?DO dup T c@ I H c! 1+ LOOP drop Pad over type r> swap - 0 max spaces ; ' view Alias hview Ttools also definitions | : ?: ( addr -- addr ) dup 4 u.r ." :" ; | : @? ( addr -- addr ) dup T @ H 6 u.r ; | : c? ( addr -- addr ) dup T c@ H 3 .r ; \ Ttools for decompiling ks 9 sep 86 : s ( addr -- addr+ ) ?: space c? 4 spaces T count 2dup + even -rot 18 .tfield ; : n ( addr -- addr+2 ) ?: @? 2 spaces dup T @ >name H ?dup IF T count H ELSE 0 0 THEN $1F and $18 .tfield 2+ ; : d ( addr n -- addr+n ) 2dup swap ?: 3 spaces swap 0 DO c? 1+ LOOP 4 spaces -rot dup .tfield ; : l ( addr -- addr+2 ) ?: 6 spaces @? 2+ 14 spaces ; : c ( addr -- addr+1 ) 1 d 15 spaces ; \ Tools for decompiling ks 29 jun 87 : b ( addr -- addr+2 ) ?: @? dup T @ H over + 6 u.r 2+ 14 spaces ; : dump ( addr n -- ) bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; : view T ' >name H ?dup 0=exit 4 - T @ H ?dup 0=exit edit ; \ Predefinitions loadscreen ks 29 jun 87 Onlyforth : clear H true Abort" There are ghosts" ; 1 $B +thru \ Literal ['] ?" ." " ks 29 jun 87 Transient definitions Forth : Literal ( n -- ) H dup $FF00 and IF T compile lit , H exit THEN T compile clit c, H ; immediate : Ascii H bl word 1+ c@ state @ 0=exit T [compile] Literal H ; immediate : ['] T compile lit H ; immediate : ." T compile (." ," align H ; immediate : " T compile (" ," align H ; immediate \ Target compilation ] ks 07 dez 87 Forth definitions | : tcompile ( string -- ) dup find ?dup IF 0> IF nip execute exit THEN THEN drop gfind IF execute exit THEN number? ?dup IF 0> IF swap T [compile] Literal THEN [compile] Literal H exit THEN symbolic execute ; Transient definitions : ] H ] ['] tcompile Is parser ; \ Target conditionals ks 10 sep 86 : IF T compile ?branch >mark H 1 ; immediate restrict : THEN abs 1 ?pairs T >resolve H ; immediate restrict : ELSE 1 ?pairs T compile branch >mark swap >resolve H -1 ; immediate restrict : BEGIN T mark H -2 2swap ; immediate restrict | : (repeat 2 ?pairs T resolve H REPEAT ; : UNTIL T compile ?branch (repeat H ; immediate restrict : REPEAT T compile branch (repeat H ; immediate restrict \ Target conditionals Abort" etc. ks 09 feb 88 : DO T compile (do >mark H 3 ; immediate restrict : ?DO T compile (?do >mark H 3 ; immediate restrict : LOOP 3 ?pairs T compile (loop compile endloop >resolve H ; immediate restrict : +LOOP 3 ?pairs T compile (+loop compile endloop >resolve H ; immediate restrict : Abort" T compile (abort" ," align H ; immediate restrict : Error" T compile (error" ," align H ; immediate restrict \ Target does> ;code ks 29 jun 87 | : dodoes> T compile (;code H glast' @ there resdoes> there tdoes> ! ; : Does> H undefined? T dodoes> $E9 c, H tdodo @ there - 2- T , H ?reinterpret ; immediate restrict : ;Code H 0 ?pairs undefined? T dodoes> H ?reinterpret T [compile] [ Assembler H ; immediate restrict \ User ks 09 jul 87 Forth definitions Variable torigin torigin off \ cold boot vector Variable tudp tudp off \ user variable counter : >user ( addr1 -- addr2 ) T c@ H torigin @ + ; Transient definitions Forth : origin! ( taddr -- ) H torigin ! tudp off ; : uallot ( n -- offset ) H tudp @ swap tudp +! ; DO> >user ; : User T prebuild User 2 uallot c, H ; \ Variable Constant Create ks 01 okt 87 DO> ; : Variable T prebuild Create 2 allot H ; DO> T @ H ; : Constant T prebuild Constant , H ; DO> ; : Create T prebuild Create H ; : Create: T Create ] H end-code 0 ; \ Defer Is Vocabulary ks 29 jun 87 DO> ; : Defer T prebuild Defer 2 allot ; : Is T ' >body H state @ IF T compile (is , H exit THEN T ! H ; immediate dummy : Vocabulary H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , H there tvoc-link @ T , H tvoc-link ! ; \ File ks 19 m„r 88 Forth definitions Variable tfile-link tfile-link off Variable tfileno tfileno off &45 Constant tb/fcb Transient definitions Forth dummy : File T prebuild File here tb/fcb 0 fill here H tfile-link @ T , H tfile-link ! 1 tfileno +! tfileno @ T c, 0 , 0 , 0 , 0 , 0 , here dup >r 1+ tb/fcb &13 - allot H tlast @ T count dup r> c! H bounds ?DO I T c@ over c! H 1+ LOOP drop ; \ : ; compile Host [compile] ks 29 jun 87 dummy : : H >in @ >in: ! T prebuild : ] H end-code 0 ; : ; 0 ?pairs T compile unnest [compile] [ H ; immediate restrict : compile T compile compile H ; immediate restrict : Host H Onlyforth ; : Compiler H Onlyforth Transient also definitions ; : [compile] H ghost execute ; immediate restrict \ Target ks 29 jun 87 Onlyforth : Target H vp off Transient also definitions ; Transient definitions ghost c, drop \ No newline at end of file diff --git a/8086/msdos/src/meta.fth b/8086/msdos/src/meta.fth index 8971ee4..305cf07 100644 --- a/8086/msdos/src/meta.fth +++ b/8086/msdos/src/meta.fth @@ -381,7 +381,7 @@ Transient definitions \ *** Block No. 20, Hexblock 14 -( Transient primitives ks 17 dec 83 ) +\ Transient primitives ks 1phz 05mär22 ' exit Alias exit ' load Alias load ' / Alias / ' thru Alias thru @@ -395,7 +395,7 @@ Transient definitions ' 2- Alias 2- ' negate Alias negate ' 2swap Alias 2swap ' 2dup Alias 2dup - +' include Alias include \ *** Block No. 21, Hexblock 15 From 4939662c55b93faec2ba4737ff162bb43a0e4e88 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sat, 5 Mar 2022 23:21:37 +0100 Subject: [PATCH 11/17] Build v4th.com from .fth sources instead of .fb sources. This needs two adaptions in the .fth sources: 1. Replace screen comments \\ with multiple line comments \ as fth files have no screens. 2. Move Create Does> constructs each into a single line because the metacompiler chokes on line breaks in Create Does> when including from an .fth fileb - unclear atm why. C64 metacompiler has the same issue - don't remember if I understood the reason when I encountered the issue there. --- 8086/msdos/src/mk-v4th.fth | 12 ++- 8086/msdos/src/vf86core.fth | 152 +++++++++++++++++------------------- 8086/msdos/src/vf86dos.fth | 20 ++--- 3 files changed, 93 insertions(+), 91 deletions(-) diff --git a/8086/msdos/src/mk-v4th.fth b/8086/msdos/src/mk-v4th.fth index a1c5f6e..b89a973 100644 --- a/8086/msdos/src/mk-v4th.fth +++ b/8086/msdos/src/mk-v4th.fth @@ -1,6 +1,12 @@ logopen output.log + \ : .blk|tib + \ blk @ ?dup IF ." Blk " u. ?cr exit THEN + \ incfile @ IF tib #tib @ cr type THEN ; + + \ ' .blk|tib Is .status + Onlyforth 2 loadfrom META.fb @@ -8,9 +14,11 @@ new v4th.com Onlyforth Target definitions - 4 &110 thru \ Standard 8088-System + \ 4 &110 thru \ Standard 8088-System + include vf86core.fth - &112 &146 thru \ MS-DOS interface + \ &112 &146 thru \ MS-DOS interface + include vf86dos.fth : forth-83 ; \ last word in Dictionary diff --git a/8086/msdos/src/vf86core.fth b/8086/msdos/src/vf86core.fth index 3912665..e614835 100644 --- a/8086/msdos/src/vf86core.fth +++ b/8086/msdos/src/vf86core.fth @@ -513,17 +513,17 @@ Code d< ( d1 d2 -- flag ) C pop A pop \ *** Block No. 31, Hexblock 1f -\\ min max umax umin extend 10Mar8 +\ min max umax umin extend 10Mar8 -| : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; +\ | : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; -: min ( n1 n2 -- n3 ) 2dup > minimax ; -: max ( n1 n2 -- n3 ) 2dup < minimax ; -: umax ( u1 u2 -- u3 ) 2dup u< minimax ; -: umin ( u1 u2 -- u3 ) 2dup u> minimax ; -: extend ( n -- d ) dup 0< ; -: dabs ( d -- ud ) extend IF dnegate THEN ; -: abs ( n -- u) extend IF negate THEN ; +\ : min ( n1 n2 -- n3 ) 2dup > minimax ; +\ : max ( n1 n2 -- n3 ) 2dup < minimax ; +\ : umax ( u1 u2 -- u3 ) 2dup u< minimax ; +\ : umin ( u1 u2 -- u3 ) 2dup u> minimax ; +\ : extend ( n -- d ) dup 0< ; +\ : dabs ( d -- ud ) extend IF dnegate THEN ; +\ : abs ( n -- u) extend IF negate THEN ; @@ -558,14 +558,14 @@ Code d< ( d1 d2 -- flag ) C pop A pop Code (+loop D R ) add D pop ]] end-code restrict -\\ +\ -| : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; +\ | : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; \ dodo puts "index | limit | adr.of.DO" on return-stack - : (do ( limit start -- ) over - dodo ; restrict - : (?do ( limit start -- ) over - ?dup IF dodo THEN - r> dup @ + >r drop ; restrict +\ : (do ( limit start -- ) over - dodo ; restrict +\ : (?do ( limit start -- ) over - ?dup IF dodo THEN +\ r> dup @ + >r drop ; restrict \ *** Block No. 34, Hexblock 22 @@ -855,20 +855,20 @@ Label domove I W cmp moveup CS ?] \ *** Block No. 49, Hexblock 31 -\\ scan skip /string ks 29 jul 87 +\ scan skip /string ks 29 jul 87 - : skip ( addr0 len0 char -- addr1 len1 ) >r - BEGIN dup - WHILE over c@ r@ = WHILE 1- swap 1+ swap - REPEAT rdrop ; +\ : skip ( addr0 len0 char -- addr1 len1 ) >r +\ BEGIN dup +\ WHILE over c@ r@ = WHILE 1- swap 1+ swap +\ REPEAT rdrop ; - : scan ( addr0 len0 char -- addr1 len1 ) >r - BEGIN dup - WHILE over c@ r@ - WHILE 1- swap 1+ swap - REPEAT rdrop ; +\ : scan ( addr0 len0 char -- addr1 len1 ) >r +\ BEGIN dup +\ WHILE over c@ r@ - WHILE 1- swap 1+ swap +\ REPEAT rdrop ; - : /string ( addr0 len0 +n -- addr1 len1 ) - over umin rot over + -rot - ; +\ : /string ( addr0 len0 +n -- addr1 len1 ) +\ over umin rot over + -rot - ; @@ -901,14 +901,14 @@ Label domove I W cmp moveup CS ?] A- W ) mov W inc C0= ?] ]? Next end-code -\\ high level, ohne Umlaute +\ high level, ohne Umlaute - : capital ( char -- char') - dup Ascii a [ Ascii z 1+ ] Literal - uwithin not ?exit [ Ascii a Ascii A - ] Literal - ; +\ : capital ( char -- char') +\ dup Ascii a [ Ascii z 1+ ] Literal +\ uwithin not ?exit [ Ascii a Ascii A - ] Literal - ; - : upper ( addr len -- ) - bounds ?DO I c@ capital I c! LOOP ; +\ : upper ( addr len -- ) +\ bounds ?DO I c@ capital I c! LOOP ; \ *** Block No. 52, Hexblock 34 @@ -931,12 +931,12 @@ swap ]? C >in #) add \ *** Block No. 53, Hexblock 35 -\\ (word ks 27 oct 86 +\ (word ks 27 oct 86 -| : (word ( char adr0 len0 -- addr ) - rot >r over swap >in @ /string r@ skip - over swap r> scan >r rot over swap - r> 0<> - >in ! - over - here dup >r place bl r@ count + c! r> ; +\ | : (word ( char adr0 len0 -- addr ) +\ rot >r over swap >in @ /string r@ skip +\ over swap r> scan >r rot over swap - r> 0<> - >in ! +\ over - here dup >r place bl r@ count + c! r> ; @@ -1188,11 +1188,10 @@ swap ]? C >in #) add D R cmp 0= ?] 2 W D) W lea ]? W D mov A R mov Next end-code -\\ - : nfa? ( thread cfa -- nfa / false ) >r - BEGIN @ dup 0= IF rdrop exit THEN - dup 2+ name> r@ = UNTIL 2+ rdrop ; +\ : nfa? ( thread cfa -- nfa / false ) >r +\ BEGIN @ dup 0= IF rdrop exit THEN +\ dup 2+ name> r@ = UNTIL 2+ rdrop ; \ *** Block No. 67, Hexblock 43 @@ -1274,8 +1273,8 @@ swap ]? C >in #) add \ *** Block No. 71, Hexblock 47 \ Vocabulary Forth Only Onlyforth definitions ks 19 jun 88 - : Vocabulary Create 0 , 0 , here voc-link @ , voc-link ! - Does> context ! ; + : Vocabulary + Create 0 , 0 , here voc-link @ , voc-link ! Does> context ! ; \ | Name | Code | Thread | Coldthread | Voc-link | Vocabulary Forth @@ -1330,19 +1329,19 @@ Target Forth also definitions \ *** Block No. 74, Hexblock 4a -\\ -text (find ks 02 okt 87 +\ -text (find ks 02 okt 87 - : -text ( adr1 len adr2 -- 0< 1<2 / 0= 1=2 / 0> 1>2 ) - over bounds - DO drop count I c@ - dup IF LEAVE THEN LOOP nip ; +\ : -text ( adr1 len adr2 -- 0< 1<2 / 0= 1=2 / 0> 1>2 ) +\ over bounds +\ DO drop count I c@ - dup IF LEAVE THEN LOOP nip ; - : (find ( string thread -- str false / NFA +n ) - over c@ $1F and >r @ - BEGIN dup WHILE dup @ swap 2+ dup c@ $1F and r@ = - IF dup 1+ r@ 4 pick 1+ -text - 0= IF rdrop -rot drop exit - THEN THEN drop - REPEAT rdrop ; +\ : (find ( string thread -- str false / NFA +n ) +\ over c@ $1F and >r @ +\ BEGIN dup WHILE dup @ swap 2+ dup c@ $1F and r@ = +\ IF dup 1+ r@ 4 pick 1+ -text +\ 0= IF rdrop -rot drop exit +\ THEN THEN drop +\ REPEAT rdrop ; @@ -1634,15 +1633,15 @@ Target Forth also definitions \ *** Block No. 90, Hexblock 5a -\\ Struktur der Blockpuffer ks 04 jul 87 +\ Struktur der Blockpuffer ks 04 jul 87 - 0 : link zum naechsten Puffer - 2 : file 0 = direct access - -1 = leer, - sonst adresse eines file control blocks - 4 : blocknummer - 6 : statusflags Vorzeichenbit kennzeichnet update - 8 : Data ... 1 Kb ... +\ 0 : link zum naechsten Puffer +\ 2 : file 0 = direct access +\ -1 = leer, +\ sonst adresse eines file control blocks +\ 4 : blocknummer +\ 6 : statusflags Vorzeichenbit kennzeichnet update +\ 8 : Data ... 1 Kb ... @@ -1691,22 +1690,22 @@ Target Forth also definitions \ *** Block No. 93, Hexblock 5d -\\ (core? ks 31 oct 86 +\ (core? ks 31 oct 86 -| : this? ( blk file bufadr -- flag ) - dup 4+ @ swap 2+ @ d= ; +\ | : this? ( blk file bufadr -- flag ) +\ dup 4+ @ swap 2+ @ d= ; - .( (core?: offset is handled differently in code! ) +\ .( (core?: offset is handled differently in code! ) -| : (core? ( blk file -- dataaddr / blk file ) - BEGIN over offset @ + over prev @ this? - IF rdrop 2drop prev @ 8 + exit THEN - 2dup >r offset @ + >r prev @ - BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN - dup r> r> 2dup >r >r rot this? 0= - WHILE nip REPEAT - dup @ rot ! prev @ over ! prev ! rdrop rdrop - REPEAT ; +\ | : (core? ( blk file -- dataaddr / blk file ) +\ BEGIN over offset @ + over prev @ this? +\ IF rdrop 2drop prev @ 8 + exit THEN +\ 2dup >r offset @ + >r prev @ +\ BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN +\ dup r> r> 2dup >r >r rot this? 0= +\ WHILE nip REPEAT +\ dup @ rot ! prev @ over ! prev ! rdrop rdrop +\ REPEAT ; \ *** Block No. 94, Hexblock 5e @@ -2026,8 +2025,3 @@ Target Forth also definitions end-code Code cold here 2- ! end-code - - - - - diff --git a/8086/msdos/src/vf86dos.fth b/8086/msdos/src/vf86dos.fth index 5801a6e..0f628b8 100644 --- a/8086/msdos/src/vf86dos.fth +++ b/8086/msdos/src/vf86dos.fth @@ -76,17 +76,17 @@ \ *** Block No. 116, Hexblock 74 -\\ BIOS keyboard input ks 16 sep 88 +\ BIOS keyboard input ks 16 sep 88 - Code (key@ ( -- 8b ) D push A+ A+ xor $16 int - A- D- xchg 0 # D+ mov Next end-code +\ Code (key@ ( -- 8b ) D push A+ A+ xor $16 int +\ A- D- xchg 0 # D+ mov Next end-code - Code (key? ( -- f ) D push 1 # A+ mov D D xor - $16 int 0= not ?[ D dec ]? Next end-code +\ Code (key? ( -- f ) D push 1 # A+ mov D D xor +\ $16 int 0= not ?[ D dec ]? Next end-code - Code empty-keys $C00 # A mov $21 int Next end-code +\ Code empty-keys $C00 # A mov $21 int Next end-code - : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; +\ : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ; \ mit diesen Keytreibern sind die Funktionstasten nicht \ mehr durch ANSI.SYS Sequenzen vorbelegt. @@ -363,8 +363,9 @@ \ MS-DOS file control Block cas 19jun20 -| : Fcbytes ( n1 len -- n2 ) Create over c, + - Does> ( fcbaddr -- fcbfield ) c@ + ; +\ | : Fcbytes ( n1 len -- n2 ) Create over c, + +\ Does> ( fcbaddr -- fcbfield ) c@ + ; +| : Fcbytes Create over c, + Does> c@ + ; \ first field for file-link 2 1 Fcbytes f.no \ must be first field @@ -662,4 +663,3 @@ Assembler [[ W R xchg C pop D pop file-link remove isfile@ remove? nip IF file-link @ isfile ! THEN fromfile @ remove? nip 0=exit isfile@ fromfile ! ; - From fcbb96d1b09c70459d69c42294b8e7fba61b007e Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 13 Mar 2022 21:53:11 +0100 Subject: [PATCH 12/17] Update main README.ORG Update details about the current version (3.8x, 3.9.x) of different platforms. --- README.ORG | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/README.ORG b/README.ORG index de07525..0f4cfc6 100644 --- a/README.ORG +++ b/README.ORG @@ -11,9 +11,13 @@ resources. Some modern Forth Systems were influenced by or were derived from VolksForth (GNU-Forth, bigForth). -The current Version of VolksForth is 3.81. Version 3.9.x will be -interim versions on the way to sync all VolksForth targets and move -towards compliance with the 2012 Forth standard. +On most platforms the current version of VolksForth is 3.8x. +Versions 3.9.x are interim versions towards compliance with the +2012 Forth standard, and at the same time towards a unification +(as far as feasible) of the sources of the different platforms. +Also included in 3.9.x versions is the transition from block files +to stream files as primary source format. +So far the 6502/C64 VolksForth (C64/Plus4/X16) is on a 3.9.x version. Version 3.8.x is based on the Forth 83 standard, Version 4.00 will be based on the current 2012 Standard (https://forth-standard.org). From 8a78db5cdc313958033138338b232cbd35d044e3 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 13 Mar 2022 22:05:48 +0100 Subject: [PATCH 13/17] Update README.ORG Adding pointer mention of make based automation --- README.ORG | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.ORG b/README.ORG index 0f4cfc6..1469113 100644 --- a/README.ORG +++ b/README.ORG @@ -16,7 +16,8 @@ Versions 3.9.x are interim versions towards compliance with the 2012 Forth standard, and at the same time towards a unification (as far as feasible) of the sources of the different platforms. Also included in 3.9.x versions is the transition from block files -to stream files as primary source format. +to stream files as primary source format, and an introduction of +make-based build and test automation. So far the 6502/C64 VolksForth (C64/Plus4/X16) is on a 3.9.x version. Version 3.8.x is based on the Forth 83 standard, Version 4.00 will be From f2a4edb1a12b64bec1a8fb955078daeb9af3ccec Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 13 Mar 2022 23:09:31 +0100 Subject: [PATCH 14/17] Update msdos/readme.org Add refactoring and transitional make target information. --- 8086/msdos/readme.org | 67 +++++++++++++++++++++++++++++++++++++++---- 1 file changed, 61 insertions(+), 6 deletions(-) diff --git a/8086/msdos/readme.org b/8086/msdos/readme.org index d14e788..7653759 100644 --- a/8086/msdos/readme.org +++ b/8086/msdos/readme.org @@ -1,15 +1,69 @@ #+TITLE: VolksForth MS-DOS README -#+AUTHOR: Carsten Strotmann -#+DATE: <2020-06-19 Fri> +#+AUTHOR: Carsten Strotmann, Philip Zembrod +#+DATE: <2022-03-13 Sun> -* How to meta-compile a new kernel +* Refactoring in progress + +MSDOS VolksForth is currently in transition towards make based +and stream file (.fth) based builds. + +* Documentation for make based builds + +The central Makefile is written for GNU make on Linux and uses +the DOS emulator dosbox to run VolksForth and Metacompiler +binaries for building new VolksForth binaries and for running +tests. The make rules also use several Linux tools, e.g. +bash, Python, grep or dos2unix. + +volks4th.com is the old checked-in full VolksForth binary +with editor etc, manually compiled from block sources as +described in the "Previous .fb-based manual build instructions". +It is intended to remain untouched throughout the transition +period until it can be safely replaced by new .fth-based +kernels with build-in .fth interface. + +** Binary make targets + +=make v4th.com= +builds the new minimal VolksForth kernel v4th.com from +.fth sources using metafile.com. + +=make metafile.com= +builds the metacompiler with included .fth file interface. +It is used to build v4th.com, so metafile.com will be built +as part of the make rule for v4th.com. Note: metafile.com +is mostly still built from meta.fb, i.e. from block sources. + +=make o4th.com= +builds a new minimal VolksForth kernel from kernel.fb, i.e. +from block sources. This is equivalent to the previous +"How to meta-compile a new kernel" instruction. + +=make v4thfile.com= +adds the .fth file interface to the old volks4th binary. + +** Test make targets + +=make test= +runs all current tests. + +=make test-min.result= +runs v4th.com through the initial minimal set of unit tests. + +=make test-volks4th-min.result= +runs the same initial minimal set of unit tests on v4thfile.com +which is the old volks4th.com binary with added .fth file interface. + +* Previous .fb-based manual build instructions + +** How to meta-compile a new kernel After making changes the the Forth kernel source in =kernel.fb=, restart =volksforth.com= to have a clean system and compile a new "minimal" kernel with =include kernel.fb=. This will create a new =FORTH.COM= executable. -* creating a minimal system with a simple editor +** creating a minimal system with a simple editor Execute =forth.com include minimal.sys= to generate the file =minimal.com= which contains a minimal VolksForth system with the @@ -19,11 +73,12 @@ This system can be used to edit the file =volksforth.sys= or other Forth source block files needed to create a full VolksForth system. -* creating a full VolksForth system from the minimal kernel +** creating a full VolksForth system from the minimal kernel Execute =forth.com include volks4th.sys= to create a new fully equipped VolksForth executable =volks4th.com=. -* creating a version of VolksForth that works with emu2 + +** creating a version of VolksForth that works with emu2 EMU2 is a nice PC Emulator that can run MS-DOS console applications as Linux/MacOS/Windows console applications. EMU2 can be found at From 32060bfcc3e02ae573bb0aa7b777b7ca35e40ee9 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Mon, 14 Mar 2022 00:25:57 +0100 Subject: [PATCH 15/17] 2 small Makefile fixes --- 8086/msdos/Makefile | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index 8fc01cd..7410bb6 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -24,7 +24,8 @@ metafile.com: v4thfile.com src/meta.fb src/mk-meta.fth tests/log2file.fb dos2unix -n OUTPUT.LOG metafile.log grep -F 'Metacompiler saved as metafile.com' metafile.log -v4th.com: metafile.com src/meta.fb src/mk-v4th.fth +v4th.com: metafile.com src/meta.fb src/mk-v4th.fth \ + src/vf86dos.fth rm -f v4th.com V4TH.COM OUTPUT.LOG FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ metafile.com "include mk-v4th.fth" @@ -35,7 +36,7 @@ v4th.com: metafile.com src/meta.fb src/mk-v4th.fth # o4th for old volks4th - the new v4th is built with precompiled # metacompiler metafile.com and mk-v4th.fth which writes a compile log. o4th.com o4th.log: volks4th.com src/kernel.fb - rm -f FORTH.COM forth.com v4th.com + rm -f FORTH.COM forth.com o4th.com FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ volks4th.com "include kernel.fb" dos2unix -n OUTPUT.LOG o4th.log From da96ca12173eae21b25293694d6f7b712f2b401e Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Mon, 14 Mar 2022 00:26:45 +0100 Subject: [PATCH 16/17] Checking in the current version of the new make-built binaries --- 8086/msdos/metafile.com | Bin 0 -> 37199 bytes 8086/msdos/o4th.com | Bin 0 -> 15867 bytes 8086/msdos/v4th.com | Bin 0 -> 15867 bytes 8086/msdos/v4thfile.com | Bin 32578 -> 32682 bytes 4 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 8086/msdos/metafile.com create mode 100644 8086/msdos/o4th.com create mode 100644 8086/msdos/v4th.com diff --git a/8086/msdos/metafile.com b/8086/msdos/metafile.com new file mode 100644 index 0000000000000000000000000000000000000000..c7a22687a48db045957c18282d622a965a260817 GIT binary patch literal 37199 zcmdqKiCC`N*96oagN4 zJm*)|>IRK@#QVTCE2uohYxv%Ez>#xez0HB9i}F`m zsmf(hI{&sIMwI)s0d|MeHUJnd%37AKq&|$0_xy{W!HG}{(^#0 z77G=9kJZVCSgohvOM(&PV?aJ*AM{u~F82?tiggjNUY4`fI4UI0H&F%t2w*=eRF;+5 zya4Oup&Xx2C@Gx&#PqI{R9Ps%ah#AbmEabFckb)GpqD3cqOHbesjRToaK4+<`xEuD zlM~%G5B5>%LIU}w_9q6)b)42xa6i5`MRYS%VHOuCcLEr<6~LMeyfUx{0o=%mmI_x< zk<<1( zvK|zM${Pi?%vJG%aN`6)o(5#Mz?#df?+7&s#|iWrK;44Y@UF-o?G+HooMVj+E3;d{EM z%}lvhEbRRzN?ssp$EU17`nxE3iKxv=*+}WlVqszLjVO5yN~ZldlhtV8kYXfl8W5=}ouqY@4VT{N@Auu@sBZSB#b`M~VnLC! zq&FC*_kuxAmDW0O{w0rZsNGI|O_mIDjwD+Et(82RhITW(7Y(vodLICr$LyqIXO@`$ zKMGd8j%f`sOBo>o*BVkSSwdpD82KJan=$oaNq^!khUwBM!*@zCvR`5|a`S$#!aG&? zZvg+Tq^-=|FJYa4-=V_)0QlR0=be(aPwzcHO#Z8+$-OXuvqHr=CJmFnlr(ui5z2*O z@(nbbrwbUrulKWIG8>@H$c+k6`mj{Rza|ZrLjyEZ(*kO8j^FKCLcnl2DL|~Oc2pEQ z%BBU>)aLxTBLMj{6;lFodOEJX)!$Da)xgXP;4Qen^4kMyQjT}A(|TF=cx5}!3y78H z2e8(RsSgEU^LDatX&7bbtC8_wfYv(IWXKSUMPEQH7b`ynKyG(HEe2hK+E)lv|KkB& ze9C*6fx_OaBjlF@*iuK?DQahhmR0xg!GIC+3Bb)YeFR^Ah27tKVT61ofU5+qpaZPq z6TnW4kbfeWxh95S?fU_HXM`N46L8<#%B&f>?YoqHe*qOH>R5B3*P_#(SgKVI&qUn_ zIY-A?0X7*-Iy09c#&SlvT(>sa>T1!|tonXcNr~OQaUyOnv7{vB_`n@jsx!*-baHaO z)wNxRN$&cD%~J0GWNg%}N6Sv|3@_={9#97S6u|$Z6AE1*g5HC=n(gd8Vh6?k4f1ljsg@)SLvS8Dc@ zm<&?LX)yzvdz4(Mm-0L|ugh6wBk*cITD0T7p{!;-pF4<7-?CoH{TXWXKn*+eLcZJV z@L+DE#gF3xyIMOs+q>p=cC|Omi{%pK-|P1~>?T8Nh*dvJe*rU}D1WFwSW#>%Ga1af z3*ugVr=Eak^apLA6D9+JT0>00w)36(5Q#Fc=?@j!zyzBNe*IOYj?lnE)x}_tOopq# zzbdNro2A?Rr9v#HLVu&DlYP5CC4f$L7HTu;|JhIV#Rnet*xWXA1$E4%F9;;yoWMhs zWfcw(1geZ+qvfu^{ZB5AJCb0R71+?ABsn@rGuC7X2+HDPxg$?}vSp|Ui+ z)Mc#-^7Txwx$)h0rDPGZN`iPLXEEh$x{!Ik=2yBK|5o$w3A*ubFa~|a>_@%djFB6I zII81uVAkw%_nugLkbCkq&80oxe;lVvH?}QlXm4z3yDyd-BX2_o()R~_bdx%;CTOhu zc916BWY`(>Jo-0Q{!0*xdgz<_J61jw#E+$#O@?kZHmHYf4I=23AnjNb>KiD;1oM?D z(rIkZ3I!!3Sg5oPmOL$-0nCvP{YdLX8^oeJG;E7_fo37 zHkfxi%@*v$-vn>Q$w`%8K+7Nk6@Ly^naQGRs`Sa=H2Ixi4qUzSZ1DEly6Jt-6Zmfc zpA6=46Vc{BEq)P3~6T+LFPFIC7L{k;0P@?bLZS;Dne*heQsE)Q96ah1B2Gt|Qp>)Fj7 z)nr!YauAsKQ3vMuJa`D%9GOI>%fXM|?Rb)jOq zx5DEnE7}xVQ=78CgJX}6-^YHWGSkaKGvx!`aY#7i|W3$whCx9S6#mat>o`Oz_n0v8dw9#8?ZpDnkCan&vlHq-rKQWycA z4CCEq4{hIW_WrP|K->_znz!>kY-4CQOLs~w($7iJ;?xn z`NP3iL#ghG@|R(}w*rhWt@}jz-(fbh*Wz%fcy;1ZP7{8NGjlCiaf@M;`B_E6T{_raCgPwxJ7XU`MpemMx>$73Y#eBhp$OSF?%>+&J2GK>DG|? z@Ui%wBsYhzO*SdHhl8)D5M*iiegd?HtQ+jW|e?bNwxeKj)?PQId_Q8Y_U|9Rywf+m?BV9yMjcw z%OeA+VzGxMg_x-zYQ>qiN4MQ>+4hM%w>Li#9 zyMRluYAJO!pAuk4pG+wMN0nRqGaTnpi*a2Cpu?dDMS-i9ihuDvdhlDP<|op(#9S5W z^8^~sk#`Sat!|vm{(kTn+%+}}+s~@!m<;g|K8v>vJ;v3E3o+^}{-DxP!f6z;_-ibc zHyH>cL`n%51NvzjN?SHp&L1k4RhAaoJeb#)wa$@OL!2X(or|Tk4ULgbgM3y?=r;2R ze{jg6p+|>QOKH@#VCEWo5Sc3QI%X-5p|w)KZ9}$6i-yWWRt!Bj#DPNeZPj1xKQ-i> zl4Bd1DXBRo{ola5St zr;j9)p)leY_gFLyj#3LTq^WXo1Xt{^Vxgx;n7QYmc_@iF#?juIDmO+59$S@-ww9WC zH*0mo2hgfjdb|$WxSJxV&gl^}s(1LM+)-gQzZnxtl{^s<;3zG%Sslu5s+I~~0`gS( zaD)Ut674k@==kVNIUNg_C!*Rg%Pnl4O3MjdLF9O`X;PB%o07(Mdr)(kwS8g#YOYj z!@47=)qMGd$U|0_&6`Jr9Qr{kw__|4Tq3!*aG>zNIoAuu+lme$mb$8%T0zW zk;k|(+?B`}oS6doYNQn_0G5|NxG1cJqiEnOEXs}vx$`+PN~|_}%5Yz)TYgd$5lLES zTD27*EM~4Vp1wbcUKuXprtawMFg^_OW|mD+QmMJbR^_l&$Hg3&YL*v72^J4HV+=59q-p*n~!xEQvStK~0<)snF|;CTV8esk-R`j+N-#@6~p4N^!UhE60nH;Tq#)f<=# z;+4o)zLw7j>A(~iUy8tbVO6p)nX1g*o2n6n&M z;1QJ188pZVHoP85y6uO$l$p$rw#uUn@8u9DNn#Y3p%Juqt@2cZ1aghjRfbb1V_h-* zK6Uyh8*H-IAXE;Vv0B~$Mz9Z;ME^+;m!QgyhW7gQhI(UTS4#_J*?|y?3A4%V2CmX; z^H7CX#rq8ws&rGOwwqxUopUQH-eUmM>M-LnlcQ)0)(*}dQ4EsKMnC`)K{v5KRz=h4 zF&Pd*kmTpK*LTdPMm{v~R-0XI#Vq|~psxE?X!{fGa!`!6%6&14V+_M2S4YSK;e7nk^0>zW4R*v)fgQ#`{qJi zs>HFXTbs7G6hb>Q1AotQuSZ^f=0~-%BKa>dykg_H7IS;c?JW#bB;StVJT6zowU}}1 z#;pq+RwRcG<6LDhU1*znXs?dS<#E=nncCw~fhg3>QO5^e4DEie>jO9(*4yL|V*xOd5!z zZh#>`d+k9EFT`m z6FUjCknqpIFH+xVo7|tWO(LCKD)Vp(NhfF6toW1wV)K@AXISDGNUHxNx-;H{t38W1 z>3jO=3Rg+_Qm&g_6@3O*G7c);{dA+#=PLDc7q}SQNa}}#o#2qa9>ynQj;t%eO4oTd z@kPE*UuX7?j6dkh(qHc!vB{~8|I3s=cYRmoy9x4t?b+E~7x3%54UJbXRPxZVxn?Vp z-us3UxobEiy)r9JHSM<5JWVhuA~@zb@f|=`3?~ZoJfAmQz=3)WcUf8t<^KbNATFdt z-alM}i<>yZG2FMf;|a#celTM|YMTY2Kb9_&64?-YU`CSiO`LIwoF1z$t8_Y58Ajm) zmvY;{=b05g&nf4}N>E+fNl_IS^F^%5@WF6eo>)+9nh=4h0;~URTp$Fy#Srj}ZLKX! zpBy@dTM$c=t0IRo5_+qmlERdD5n?n|sGV<-S|mX!Q7YHP29>!?in7kDZb0JWsWkB} z>ex!II$kL$A&}8jJz0D8cS35jW!b%-;OmYJG4~hMwn-S z&68SVXOCb;Xu?SXER|D7XfPpW>DL2Lx>L*K!Vzq;13T@mysHu%oLMO@M$uojwsjik zH8eJ~EBdQ4xn@Kml?aHf!&gQmOh{p;|iRE0fZ-kJq@;@Ve_P~^b9f3Tf=@2iO zzj_HI-)EN!3Q`WXE6T=qhF?ngit5p;WT|1%;?AYSqx7&nEOp8)-xwjgE4{@uT03rG zlJ2|N$s@a2Xj+hM8!4Jd)~fWz#r(6mkOQK&l`^_l&O9EjxOX3Xu zJdqKPf zDU&n-txAZ0qJD=E0LXBh?V8>$F2Qn|5>Z40k}m-5J~je=SxF2-l{$lXRhxxCVW8s0S~ zg@%qW>HpPFXork^62aqQDpz{s&yAdlM4j8sW{kLno}V|ya$dRDsHgkdYW7$i>A087 zQj+FRT268XQ?3vf01b3ng$KH)%(!<8wXeMR=41T|gCuRR-P&0CQ*R$JS6+EkoRFm0 zn&V=ArS-~XalG;c4SpOGSsgbtt`E&s$g|>DuLY)Z4O1a^#c4eW#G6*gtK)=Z#d>Wr zT*Kb_2DjDFxXySf12xhuj zCbEY;qiqJ6AyI*(amtaHyRb_6!??qP1zSTtjw1oRQs(0iE1gk9@^1%#G4a|$XQRQ$ zRLbe`0W>8JcmWg?E5OJJ=g+|DQXcla9JyYZtF9^o&? zACG?og3(pnoYAa9u zBxsVR<$RZLT3nzTg`>&93a|vjA*_@nMt?pbBdAX}pJ2zBY5A_CkTxNpI5C#1m2V_K zWd+uC;V4g)cVnZ#wrbZN;`-0m%Jri_tSm5+(6v1cdGD7t=Tt^Gz@^Q5m)m@!)sV&g~7kY5-jIJ|a6-!^j14Ee94Bs=KK zUBJ0f9B#U*i&4if(z%-q&>e=9n@=HYN(n ziBOK~3^_GXmv41=OB7gKjB&zDIVVv_wzxdD{My7CxBf&I%i4o|dACO8RBF2db8K9f z_)w)(b9vhtUy%NTF6DYTHfsI9Dd!u)x#Z)0k+()|jM#`mK=u85BVTj*o-;H@ey}wW zn4>&~#BoxrSoQI^^8Dgz#hHP`@?#+SqZ5f+yC4=Pn)K)T*DJVYsek1kp)VkjFqWGw zmnBLzP~2J!nnbBuK1NzE(tJ`wn$g|tGGUwaTO18K46AwK=A=I11Y}aR_Nz+mfA1&# z6wEE7)D;V7h?^wG3R3A<^;i0Dk6MGgXR#5e8LIXSuFTcodIu{%gG+*LFlzqxsMklS z^-(=UzV42itVwn9^+f3VF})xUiH!m=Z*%0AMvKW9ha$FACl-#LKUyXKbL9P_h2%nY zzfeYql64&w&5=)!7S%mcz$STok!MB`{a&3oN4_yy7_3Z_^q0|u8=Axq)S^i`4@kY7 zkR(*PtpmE2RX1^U`^7qu$WpyLAt}%cMPr&;3sDZt!S>O_vPsOdSd;HDD>Tk}xjZRI zS%v?^rRoS=mcBdq%aeG!Q{gj$!C?&I%$Z0ybCUc?vD`iK3rW1wQR=85+y6cC zag>0;5Te=fi}%Q9lJtt;IXJ)zNyj+43!}xr#5QrCG=>XIl*9{3u{`Ba>(m$8H8&Oh z;vV_yB%R%3v;Dk+lSzSzxXVF8Obiu!Hc{OUl%^{{!loc&Abr!le-@2U6VzE#GIi+g z@CoN;68)v^(}$I!&6O#g1ney5OQ!DujQ}Mdi+%?(%09^sDPPrUlCVh1sgvl=AT1#c zz@>iT%4nm%oNU!c<65Lm{T9+X<_x5l?&xS8UAZRxJ4&OTND`#fIS$1-bhEFEe@Ui% zlGWzPE0UqKBcqi{yl5%1fJRLPLqDo^!344Urjn*kk`S&=Ch?}vLx?&I`GbZrD62yd(I4YZ@Kja@<$yGd(Vta>X}UR<38Vs{ToSOQVX6Sz zAZL#WvQ&C2T%~F1=!wf|kkiJ(3&l}tG8CZt)%@?r^p06QW>4PKv839I7Na6b6;&8P zM!`QKO(LHS~L&r=TOE{ax z3WF#lCP0+XkX{|Ai`&~e8|HR4%qxjj*Wu?<02O^{EUz3kV(zFEHEov0BV|yy_$K-C zSdLCE^^7v7u|qWQR?#?vRk{6jk(TedU&!rEvOa}Nuz4+whGC4!uqM@!vN(Vk)^H{@ zLrqE81<~Rd?x08_bCX<{0?UhwG@_eRX`7a&l%^0VYmz%s*nA7F{;8?w6HZEIj+kB2 zW7P5%C^VtDxOinL_b2SkKA{ID ze=#L+zC1h?ereSvLwqXj+4*u(Dr<2;WgVYN`n><>qXm8J`B@()rV5IG=3o~SuJjCa z@t#z+#8z9LiXJXc<&exTPemWsrwXvPK+Rj8ik2Quh3|>mW~nGo6`J9s%Xt-Dxmhv{ zqaD>OznnUXbTP@pn&theiHb@_K>A2(qN42h9_i0gN0Gj1c}%l>J~icM`kC3o7Rb+} zN=c+8H+vu_w6CQ7al|-##6@FJnpsN0{y2l~nx$W9XOF0jBR+m;T<8emxEILUG(HK_ z0MY(eT9aXjW*Vz*80bDo+34nU-E2hY8Fo`JE;tBnBr1{6v0&J5lJ_Rzju;k{S}jGd zkB`t2gMTF@EDe+C8*wU0|MyPeRqn67mIH4yp$Bf>8ozJz$xHv}_xG@;HXnGC(Z0hl zzT17jdtcbizB|ev{4D#vz%b7Q`Gd90flJ5w-x-qT|MO;)*?in*iq)(=B#@ThH(RH; z;RYtP$Wzncv8xRFle9(hztZ%O{VP3Xbu{n96~<qRoAm7OQRkU1<;v_xxsM#qxtD)@do&X&R{-^r-zyx6>*C-z zC+_Y4tt-8|f72&~za+gwUY4#?xdqhieKY+HCh$nyVZoiQ_?tZogy+*aYS(0F9;D!pS)rmSK)BOghtX_AXG9-Idwx)=H_uC#0_}B)E-Sa>3O4~%QLs)T*cR(Xz#D& z-;d*pB%vf%j?9ODZF7LG%(@fLM*kQ{+#Ki=w2S!b7JAqjycV_C~ zv|+YDXKwRejCzH8g&Q|)+^~>gAZeK&oqPA;Om@JjTa)=(=BEAAYrU0KzR%v&G9R5g zk~n+ztQq70Dr~y&+lh&a>*PzBpZyYTbnmA$wg)na&4sn$o`$7ut@DiY+MAa&80Xe6 zuAkdXTD|46oGGL$ol_<72Qq2VjM(9f{x_NL@U&Nmv-~!Y%v+>8qs6r25?n5ajTa#| zqI4B_)7;-+?91hOn7o1NdQp{~e=K*Ia1t8gZkD(NjXGHBz~b zYKf<;fYvr+{oJ_?9RLInAbeoi8nAS2jS6nH6hb*c%`GhrP4zA6io&IVfMIjHpj>W+ znz^|h%wb#m(rPJ;GW7Sgx3xB@xLN$laL(G?v2bWsLtHGkQs%RC$#>*>lYvyJPmU*z zgpQezc$Q1g62RX$NB#-_hQ{pzD;@-EA_ueGJQGl$Lbb5 zFHLV9vnCZMA8r@5DT+~7tiPwN9SmzMw@Mx|fq%f|wv}z2uzl~;=||$Ww{xBWPvVa= zSIO%p2oES0%2y`%diLh_e!fcn9f6!KukFBu^{4jc9f@22SLHZAGhwy-2J#fK?+c($ z-&=Mhj?RZh@r62${J%{QAAlkS(K}4`UUTo4tL5(j@nUmXD#Ek(1`kk>t3Va9g$HOZ z^2cU-_8QbnjHt`7>^1VpZ2kd?1F|8@_476+A~PqOLqSh{w(s`ry+udjd^hg)p(2|Y z#?@eI`vfqx;a@HVLmSJjm20v&yQ$2zCR@8!ekfbAo76C#HQDT1c~`bzH<8S}CYxU? zKSy5`j#7MyYvn)Cm)9{JUjb|7L-a)lV@-C@TKTWpQ0Le!xYSY@Sw4$A%0jfq>FjP$ zu3G-J@&Ay>$R4ilSXkJNv?E)vL3%*qXwQ=vtSTgy!Ir5?r=*ZD84@Ov>_->ivxy|E zUsYr}S^gI7D9fYnpIUx*Hc69oG2;R8^>}F%GDF4WJEog zJr=0Z4~$REtmQ+qj&Yw)pv-L(#euxIm_LFZ)82H$)SH__0&^;}D1tNt$GBjKG|ynq zu9!lGU^2xI%3ue^9}bq_yhX~nb@EFS1<3P=vHH($($Riz0@0|`*>6nz<3xGl8TM$l z4l2?|!49+gvd@A9?4;ytNM02;Pbg08VRs`h#m1oyQpm0&g|`%KKOt-wEm0Q=_B{%ABppSu=z9J7u!_>%-Ttp zo>#MF?TQ?0xA$a?vuNvzEUKBd2Zy}W-CPuUjok2@`nVi$w!xPTk#50l2g zihu^>qrd>6R6>AY0iD#teu7R(lYKYU#tW!p+x^Eje*tUIc%|8tkGj;3{&v!(xDP;; zh*%gAAlDMhZIG{0mk@sDb)pUoxAzYlWbXGumx#`sSC3v z$8sCxj>!V_j?jocI(d7o@1u_{eRPWcZTe*0)zxSFStX(;b@E2pH(3~~;Jq_>{JwRc zth;dhA0M5de~P>D%af_z2uSV&Dp)u#jX%r%b#g8L$H_#;W=vYlp5Q5UH2Vi`$7FKs z`RinLU&bU7JeJ!e|KDWMt~7#~IydjCa!2-3a3ZVu9od@| zznlT5k4N~^AZ#Euzx%sdVHY#^JVT9Pby&XM2X zA6X0^l9%Q{O9J9f=yN6#F>VaYsB4dxuIjRzr#M#1yjelY5(v?q;~3;0~_h)T%zo z;YfXswLtGqE49bvsxGYxSk5_}^YO^1l#Hxg(NSh`R+5L-1u;K2mfIqi=JEslk0y!M zJ~Uh4dNY3u(=u6n$fe;o_=;87D8jGLWfcZW#ZCq`sfuI9lb&IVye(H6U=<GwQyEsULJt;Ht*cMw6q+W#;m;pDpE@m43aPt2IygXD+iv{&%jn5GljME;$`SGPKjAH#E%aP<*>QQwgtSs*doywcZLF zCO$l6ZxZPhq>%fNO=gL0a$!zD@}M`FYS$$Zj7-UNCD0+DsR?CXol2$|l!k00C?s&3 z{D-N00ePXB3?n-?$cBynb&d~GV9 zrw)J`R8JihT_#YYbPN4caq%Ks`2BI%G0L6}i2ZTuq&(G1yd_dEuyV+cznCdW8} zK`u>F2}_&&V4kF?hY-=@UQL-Z2cUz9zxXv7_64c)OoPe~qW>s$Z~nd@vWRQ^ zIr#xN*|t*n=XtKhj4T~lx;T^dBRoBilrs>J-pId*-Av@~ENr2y|G9j9nXAlW!`-3S zB)aoo%O_GwyZ(;q@P$v7a!1<*D4V0N0 zq{0g{R*Dzo{KE@0kp5YuMi*!xwQ)#g6lf|N4Lnj)3N#LqnX z;QTcO@u22N)EC4T){I4BL4nqsMhXYc-%+5oAQ^z<0|iXF<5+>}N` zAdA0m-*2#LQH;Ot^l8qWVYN+YR3@=}4; zi=-CGYp4iGRztSHbzX7Vf%2mCt;V&+yTIX2X? zOWblNeN{|>?<|RD0>@K`6SSl zqH>x&_?w$!BnR+n`BP|pi}}++A{tK@o)Asw$y1-EULu(uXmt0jIxEm> z)Io<|ZWcH*(qw<>VOQjLvs8nG8cZ-N)$;4}$+3&DsdlwDYRxP1d)T9x&VB0esevu# z!S0yRrNOS0o5^hR7WH{>rXrNSKVwmMgW{t=gQ=D#4UY9y%U!QC8apU{2sxOIL7(XE zptJ$$S1l{@?fhGo_4!I)jtbQBpgTWJ54b|%M!q^#lvW2TK+-=u0H-CpnJ;iE7Ojh! zE5+YhYz6wN6ORfRR;uAfexCA6wW<)+8}_pCgyQm4_>9G>pU<4b3??xLkdDKg5;BR@ zPytX+ZsvEHIf+s?kb)S3DO{y?vxlWyYXqZ~h*a!uv&_T>=#V~&Rmha6Sf2GBYnQo) zjkZq5Z!D+xR~NEotF_b0tkU~`up(}}(<(7~zs3fzrPCS;aG;I#78Z6|qmhmVybS0@ z;EV#i67XceGi(%K-f7JMJlDorO5L5-Nvi_=#WqCVK?n4WGQc!tfWw(rE!EO1)GHbv zsT-A1QP--a!-43Vnp6&?9@+mBZOudGUokIH`1Idh37QQWO0~3Ma7-ldEU`SMU`H@- zp(#OCB++Wn%+Vx=DSdDsMV1OA6pH`YLW&FcywK$Kt98e6f&K~`r@FPB7T>oKV7Q%i zQ|u-BP5`x0s@X8G2x< zxSgx96vH=3t%pps>g1;?2SME^>+=ud=<5MdP7?uxlxf?pVl6P^Eu3ZZjNyNBBB zE@Gi-C$6loh`z@bYaNhBP7i!eDaJY?n>2muuKEj=td@?bNB3v*7k8BA?>;59oxghpjR4tVOwQqXc5ax53>zfjEK@OrNoKO5@j9q>xB zBK<aqsYve*^~X9Wk`d{bLj7Zqh7 zR0$mp2V3l{D0h4x=KsmTVfkF;j-z3IX&MLl8}MUc{-M(lTeNuG;KCqrVRGZ=A-}ATX}n@oAXd|V^?RBl$Uaxe2+Fe<}w!Kj<_ipq>U zegoIxP34yPDWBX`DWBp-)Qf};Q?I&z5m}@bxpX6cmq^zV5dct2=$eV%^$FC#09{uJ zM!5f@X`BTfE_6yxPmATk{j*EhX{8DU4OIbcC0Z94>U)`R|EdzL1<4L1eIpEe%lO0j!FoYR`w< zJ0Pj1-p%-hkg9xYww@~m*{qtAq}du<#wU^9ywPwiOtUqqEWzUR2Bm7ZPAG$KoVg56 zoLTV{Pp{pYUk2|Mv$uFg8J_V`UibNEvUY2EnV2_d?yW6T!^l_jq+Qo;Z7LI>K(mpL zFS##uv)5Cg4->BjtcSy_cI(eiiw6vRfV!!|EEk_iA5)G*I16-`bL?>Y=y;^ zmh*1pGQ0KtGC}cdPBs~=xaD69Cvi(_jC(qqN_|llVD=PMmLhlwj(TmzT_Qyy4O!M@ zysx3Pxv9bEu5X7uptGSJqTtq_$^x9^KSx6LWS7@>YHu-I8-(pO-iLen8SVjl&D=6> zYl@3^lAm0iOW3@BuLD@@_FfhUN@#Ssi{D!5f;k$7l}5wUA^g_+TtXGXLtO=1U3mO! zZ^)6*^?!Yh$ra%V@JcVc>hK$6a_K;^2VDWA8B&nx2;7|LBI$$TSOjjf3)2IY$!T$= zYgBqH$8UYf6-Z7V@R%GZL6Q`CY7;6U&2p(OXf!Lq-p+O?dyE);3r;trxUHYN1T%u> z%dE+6Jl?g5=O{#C#A}=zYHWmhv;W!^%-+Or`ciuq z1-^MzDUg`?k4;~*|3cKfuTLpuLp<521@*0XuV9hfUcb0~QGN4*uGR&3$e^pKqhWE| z!p_#VCG#4VNn0ImF|X8BR#A*)x+!J^JtwYk_X+e$$bR?sO@Xg7?03G~_MiG*y49sI ztFI5-@0PYc>)xNQxUcVXlTUkGOksJz*3aSeL60Yp3MgP}AHLMrP)>_#+>2_T`2ayf z!OYk05ZEXY@C%8I;-1d*QyHe*VxpH;#&A+Ou{CDtrkj`^fgukFILwvP7x`~)gV!uU zrj(~ZAx{=^&4#S<0I+}+4inbo+bLH|`8(&a_-@93J&!xu%Q-V5M&C9VH9KA`7jVuH zQ$mrb_*bso@n$(s*$TfwVQ=&g!lI)1eDUDkaw2@%9e*j85bJ|yfAFG0c^b<^iP{}~ z<$N*~CCWq^qdIanTXt|Mx3`=$MtGdb!^C(rF&=GDq=jSZh}XsM)(yu zhh=y+;{`HugVpXZdpJ7+qv+@C&4cr{qsGH0lhe(8p1LZpZ;7$ecZD|lrkUJc z_DE>C=gr{Yy_zGTzM*ew7+Yy)#9r-@(A)c`ME)bAGXPOydjpPy_FmdJbb3zqpUb#h+Q7q-`tMl9`e!nr>ADqRo?@~jS)F{s36c= zNv%^Qvt}qe@-sKL3hYp66ED}gn0!-JHo+Zir3>+N~7a5 z@F3Q@!wOD{m*0`@<$wbV2~FN%%zCu3@xNZU*5O?MoQi5`@gVe1-T>us zI2d>pJ^Ud2uU?@L4_p>2mwm_}wAUM;P;kNysqmK$kkBqTBuNe0R z=sxJg#7+O%5-2M`3;wkys3MjVcW5dGTxO!Zs^WH+xJ>xklNEo`^R-8fM-g|-tPo&< z!2@%CYMdHg!6909)0J15O<4HbJ#T1)I}7w%uef7%h3cFW?acy*ftY8{QjYw6bpm+O{0+y!0D^S`oxspYOS`5(>=1Ky3 zD>sk(a7%u}d^v9M*~Ed=ETs$Yn_ppXh^KGY`WR|;rf37Ao^t<7^Oc1ps-X^f^1 zk{YD^orsFaci;?GP5@*aJC9PP|g zmHY9R!sciuY1QzsLuF6}MMuAa%l)vID2D1z8nEN5O4ZMAe>p{a*-b>rlB)#x^(bt` zs&e=re&BA0`kW~qfc`fc2AF1NZWRo~crK7EI28AG*Z8N|*;&O}E1-#91w|^}t)SVE z7PAM&S4+90(hrOe$wcC0z=835gAXWn9o00iT7RzhV?z1_3X=c{+PSrghY`#QE+Hl9 zaBxiGE_mM*g{p6V;IYRlvT}pBQMy1L)gwW$zpDB;F0!+}9X1c+JuPjBLMDrt67mOs z_@wU9blp;$n$emhQWi)InWy>$P0}Mgjph7k^dVZ*@p(yfHQW>fTyqfQNABhnNpVsl zces604@(-kQE)y#!_qS!WD5&tLZH9A-CvATa-)iTfk>yQ=8=Qqjj9W9w<%V_spce+ zyBWLl?^WO^-LQpS5NA~r;N5CLc`F1UYMWXkC+u!^c@>5F5Qn2ldJg*1~OCMP-_#quI6m4_r**X>{umUWb=x zG)a?SvE_CiuZHOCQRq*Ai)?w(%v-s3p8VP<)G(ul#`jc?N(K0x8F{>&+&O4V?1M26 zAx%-i&yzMd3OpjebA1hOR|76INv{p&L-L9uH(R=(_?`b-!<(v=dtG%|db#EisI8YE zib-RF<#QlKzgubs;8WDYEbQ#5!C{6;mqs@&hqxq|HDQjfmV)+_;b1p+Xp+drNcc4B zACQBHt`jw#@tUO5+2p(nerab7dI>W%$T69rRF9D>2&oRPy+4HvV{{n_J4}WP8-N1B- zJ9pPYC0l|Pp31oxrb+r&_A5#|pVTT(P^k61sQ89F7G1?rW}_h)CX6BWDKm5M&+DI3oTAX$GW;}# z()z1DhIBW?Gvt&)Apzt}NCAZV+}bHKDO_)+6f)Ya+Aafj3bi`78EoKye+=1IpO{E| z7I9zKSb=L4$njFW8LFqN9yh_@-FiSnQZuiDKRW}jA7Ya|?k6Tvxxc|)sXj*&u=AT* z-bD4A4Aga6)PSAAGvFIfph5O9a)!W7oKChFhFQg|XJ+DG3;rQ0eMXhHa^vWd8E;Po zPf!9smY&V0HlNtM-v?Ox@bUZHd(#1g!!WrG`>wsaig~jDe$bmw);#vsDrRpCoKHRl zFGKA9OSq;FgUFEsgNfWR?ff#KPP`Gk3BWqBbOsdJJ71p8+f@Yvq3#V{%;wBkj|heO za1KG>wqMVnJs5=H69B5oU(X;n8~x6AW^i^Q-G)c2piaLLTp!M+&&2~7k5=ssroSHd z{&MF?mDWFAb$G@kZ&WH2z&o$c;809qFvo_2MXY{H^(Gp48Or0vOAF{&;Li9NP-uFl z&g9?%VGP_^JrmlRGJL`t51)-QwWZdnGg&-l7Pzx(rq)6qbLnHvOs$7L+UaAy~^O;a@`%p-lRvX zG9?r>{}e|U z%@ZqUsRF@Z-ojCXdDU6=oQuhIOXY;LPrNZ}gV|Eys8S5br=b$x15w9h7#ioFwK6=gq8=Vkibv=a z?2_v#duDaa!fo?}G@JK2Z8k-rwUr#a379trE2Uf;y}ImU1^}pI$~lx(18u=vLD{y`@f3i{hl# zt*#@$({+#%aK+Oz9%gAoky*OL@*w)!r(XqCaFpToZ6(LbWx$(&efq;Xo-WRU-a60T zu}9+IF?QJF_IhYAXnyak(@oJPaCIkZzAokOo3(PCrS1_A@y#K!@R}H+8^fqBPMnZqLDI*#hcO@mV9*;uC z$KWrS(fFMScM{4YHE@TkmPQZ~g6hlONC0y;0%tI*o}#QMl8Tm@me*t;Ws6xVPbCFP zI76ygHI(ca_uxIGNO=*_b%QxH3gY(FoVXZO>CzpoLMTr3GOY*&pw{8uC$GGf;bC*@ zTa&=sHyEu5V=ZcGn5TB&!F$xHimcC+F3kZCwfl!T&?A$LjmAZFX7O!v=y4Nqcg);@ z2l8<&0eT!$OyCJ~MQkhed0Hw&dxqf7xp@2njgfj%m`jj(b9rU+5k&D3o7=-yaT#%W z$fe0pCJ~G)SZQ@`?nrvIc+`owSIVfClJ}HBxZJ&Dt_Ej*``nul{a%_&bAC8@nQ%P? z+&wCkb|0Fnfx2t^+-HB=ZVM0MSE8*ch(7R{%*toR@`%j!5SFHV~icy+;~nPTEN_!W7brz8img;J@Q| z%YdeHFX%(I#a}Fe=0Tun8yBYtD!jcF<8r_Hh`04ynAcw=Za-$K8PKt68 zW9n*XqrB6Q0%?@p^I*fBP*rx%Hw`?rQ7$Y&wWP0>0`Kz@%FPB+aN(JE0)xd@p`nf7 zmfTP^GR$=$y;0M}UT%N>0L|V>*l^DvCWr(^I+(PLY87Gk1UObFnE4*OCZ#;JYoOOL z2Ju%9U_HXmhloJ$teB90GJsP2p3#khIw99$W_HZ%ScHpUT^ybEn8YuG=*5$tlW6k4 zQvaC@^b`eEbv|LI^1Cihb+D(>1SkEhW(Hhcq1-z)5I2pFjkk@XjX;Yoa(EdT8`~<6w$#)#x2sGQyI?|5fTepP>GRNb2u} zL3ktf#_^y!D0D(If~ckee88nIgCxxEHatxtkuRs3V~>9xBKXMwbuLVXoF)}Mtclv9 zJ`x55#U^@+MJ0pxH&J|oI^rQsb>fl6UE=Fa>UT^crO2g@T>oe(h%5!o-z7$++W9Y2 z&L_}LCUa<-8j$uSY&4|LHW>!r1*zp#^lEAOmnmtfLGx*zq7dJTPnD1mb{MLxmeL{C zMa(alj~{$Q%vYyb--HJP=LgL%Mx(LZ6Z329s$f4^`+hLn4`uPDd7SS%h)Xa0{@g85 zeeL5rg+Ztj&t+r;*?C&~Z?H<6U60SFriL`N-O)XhTJk$wJfK66eX?-uPNTQuno0l2 zN$c@KS^z}@k=6(gKz1#jSFeQl3{Dg2KHi;AgoCh_dfRlZ4OsOkZQ zB?%ndq@z+vvowf=K@ezp72*ArG(Re-~8c*WVHuyL$qP7h- zt+uX~d5CMlgVFWImgZLF7z}O|dcTFB2rB4uZ%56{pGKnA!!DR#i2Fg!gznmGQv5M5UMFiB8*s z7>VA33bnPu3TIr}*41uwSdCMR@u@d4S?ZP?2-=NGwJm59Z;H>SzT%}&(psKs+sv79 z0w^`weYx%te#HVi|B72}XNA%SQs@2W8z`EEN0mt&*F1*HOHwCx*g~2Z>e;Y`-z5xb zQuSDO*K$VF4_s8L`Y6tZgmKN!mb~xo@Kh<|usA1Mo_G866Q&#f34_riE%Mb0GEE{J{uz zv-C(DMX#$YPSL`T6wIQ9bCT551+lJ%f(}#{>9=y}-3T02Ma@U_u?XCSN;7|47}fH5 z<2a=}Z5cIZTuYJy(KO{W6_u&!geDjAa|dwin_Mka$0yBHYBld_TF^L7fi$$JwP|qZ zmtlX{kfYZ6N%Q%}VNHjcR<;mz%fas;rmYE2CaILP@leyXreRG-@b4Y$tw(qjmtKa8 zYHj#cr?SC~_aQ1!jW=xWjLT{2gFn@CE$318JRWSKON%@Rb&MpgY#|fhb4rVYt>rXb z5OW*VQFSy$EuwK`F31xC?c*^5+2~7(ZolkHEpHFC5q{;wD`-f=_()tyQhMER(OKPfex<=#{w!$)8V9 z{WXXm7htj23_1td6cy8T{vD`$n@IN;;jawWH8!`-n*xGmT>gDq*kUzC`Z-)!P$T6d z9(Hj{{oIBr#^qllGnN~^XJi}vxhpKizQy$7!|HSW%s{l=pXL`$tMwh8?S|#|(uN;4 zf#bL@*j`ps<-5u%|NjDyFMi?D;vc3Q>>7>#`;3cK)#Ywq&kL7k|FG^Lm8hZ|>D)i@ zf6Fwx_XGNS?zp{opULojn;LFP1FbDP!){zmex?7w-ADh=CEFx&r67}u`e3=H$=39J z+f8)UWEgQT`2<{DOza}fHW@G8%B55t%r{xM+OOjJA(jUhGNb>hAtsTEQpHynGx`^F z0(XDP$8ka-VucsR5fec7tP*pj1WCu;ozeR-qvYZrmAWRimQT$f4leA@)jU`Of{8t< zUpp=M_ic(!9{k^?`G>vNQ`9Z@HHJ$=j>e^}VlBm6`TyHUG@IbLjbEc2eJyAlrcm># zi^txpZbVvf9dqvj^<>aS?Pxu8?-oo0$9!=w-G}N^>EMZQi)>RE3JUn4ZD@lnGgDHT z5m);fyc?sYsb+G;Xz3#1g`Te@2t8?ezLB&Z_kqPQ?it-|wN!XOGB1YFE40cB(dyff z978X!8uvWb&Luz>{QtCdEnrcdXZpa*nK>}PC;|=`6#;`vK%i~n$jeuwdP5pCe=LK z%)amWXJAZ&^c$oZ(rf-#{jd9hH!1zhpD4vhKlevV5z^=W ze*b`9^~X!HG)sz-e(e8+|5yJ1^uO#s;s2$7zu)DLl;$1zyira??J(;}mr{5bYm`i@ussmY z$+76k4>bj2*zv@1OM!9^mN9X@YCRyPw|UCa#sihev3Xhxot)y>qM0A99v z{|@%)o?S!wmz$azHt6qd&H_{%(^!&ytEhP_CRn~pel4w1I?6rzzKBZL}M5Y@#~hzKX~Z+jyId7=7t^PJNNHun9DM^9(lhx zrMT#W=39^Wo2k~gh$B-jJLl^@XlAm~lE!^#R7?7iIW0FiA6eLC!AIc z1aY?LaNi;X%S+;Hk>S3j2$moi6=$0j?ptk>bFvGo%HnLX;l8!FxLvz2vu4^Av9~Hx zp_#oA$48c@%WPvYRH_K9lkps}Gt&9)N7-DIb=ks}>wG`35o4S*2rgUr{8F9ouuaJf ziCLrb9kcPNs+eA-^PRHEnZe6@b-uGU-P-bdkyiE{o$n)?0>dc{>y({|v%z#t{tw!(JNcmvrlw{QTH_BTDwg zIpivVXH#OkfdauoIS%k1L0ejjYAD2T+Qr#aByT)k;(*|Oh-bix_{>X?aYBD1P;Hrm zr>xjr-#}^BfRl3HK8KtUgz0&=`W-vto^Cgkw3pcy9W|kK58VZRU z{8LT77IOwgcxyC1szl6q#yfV&aWH3=Bi~W!7}jDAJAQ?jQ;zo>mmC(zY6jnbwaD7g zfW+Y7QflxeISm*Z8TG7_zF&v86$EMx0UT(0s`4< zc0i{N}~pdyL&q|npQmb$=RWWSUl^gU6~^hu^yo$QZPVq(MY%vE^z;;z;^ zd0p(}hMZksCe|qGfi;cG@AQ$aR!z6OM2^<>vER&|5XjEWNo1=Yhnj3Cn7bG+6P_{p zXV8FVFD0Zmv+|fT%k+u=PUmAzA@%aEGzAHzq)6XwP8k@~1ie;l-Dw1HNpY@eC5R8L zZzR)W&I_$ve>SwTwHE?m#YVW!NZ%)|I86d)53GeLx==LYPT;-P3A~(dR(Fe5on(5i zm1@gi#eE?a_q7Hq&S*0dj90@^K4)Z|j~bV?VI}bOwt?|X!|9!BVT0{b#@DHrGSFpy zVi#3N(hu8A8{oyPS$5DN`Nu7oQ5V&;97AtZLX-Z%lJVRdZIMB@eU|;7wrEMJtvL+H zHz_$J<=aK2@KL=>zZi^R1lbB7UF|X;3^Wc7ity12mt0&~UV=fr!9|zLWKE2vx$-&4 z*a9OqO4{H`Lcihmn+$}y(Fa@v5#W;$`banWJr|4|3#%%%CF)R^ZuH+>fU7Ue3;=yR z;R2X9Omn!cijt1HzR)w~{yhFZo5$;oN*K6;))p1H-jjofv~H-9iN znrB-WmAfSG_N9N@JDKW;a=rD|TQ+h1$4#3Y^>z4hO{Tl#(Kq)R{yETATDv@YYrAM` zB^b^2%A-r$jkHSFh~s!b$bBsrfR*j+`-|JDU5IVoxrJc;O*k$17@w#einJuGLF*v|?m3GZR#?JOoq`v-9Yq?b9`}hb#t}8_EhYwQ_#f zFFq;eJF=acV=d4JnJ1yn%*i%S{S72n$%251eA>WfAKS{Trgs2Y31HK9L>&{6c^ zqxdqla{1g`Wo79B2EyI3=&%uF6r_umxnun_Es)=o)!Lc0u11j)#Gv=cZarI`Z8u~r`K%xw`^b+M?3@y5K-&M))~-Jd54Kis7&%+Mf&oO;@^2tyl5I^G2cREU== zu>if@WtcLQy~TyYB>Ar)beg!O%Yr?82+bjML-u81`_MK4XfaUAy~O|svRYRTxvSi z-EAn<$kasPhr10m8pW5mJcPVOl|_}}>iKRxSS^=}i&wk#HQ>P!7pJ=;c#(-|USqn{ zsqb}1*3dOds0d-CeX#=aiI4_?uxY-w8Hn$ld5>Bti%6d}O$Oya63Si>k?Wt)q8#$rwa z5_&X-{9uZiC$o3<2u~0iK3#w*6^~+e^i(HUp){vS35}wv6Q~O?sE!^P1C@Ib8j)Pk zo$R`xd-E1E%#}}~%No>}Ub%ElC5<9Jo}SRVP~X$T*sNYdX@G-`k{WM?J&G%&Vh%P> z5pqY5XpDAR)d`sX)S}+-Qh4F9HtMf+t7=v;x}!HdJqzEUmv!CQL(2{gWUtQJXwSmI zNI?%7WWrai!ciM^icOrAH9_!^R7#B0TP@WjNKuw2CvtKf$Y!!I$%?|dWR{kb8xhMg z5T_o2RfSRgx89UB=@GN}!Pqt(cLb)s_~{M)-LVi8pA5jTD}i1vWr-e6g9Tbl(ilhE*e2J-v8fW+`?C8G1m35EN4}& zT@mWOK0{5wrYieD_JN6(2=)0sMSvQwExnqwd0_LvYkd*w>wPz|Vf`VA9Y8Vv9{oHU zzuA8y)c5)#V2HAIT^WSht4YU)j}M>iK3VAVQt*CX>wD zeY5px`L@OlJR7t_hrJs7h4idq1}$6-O_BS09=C=# zt7zDXgUBu0w>9nAwsY$aoN_VSPIq`ArnQakHcZYYb;KQpLLdZkQ<2=@z8m*rQlD~% zAUxpKyN`h*|0>o}>vhsimGtLP3+d z-V;J07^QCU$QsrvpNcz=2Hbg+`dyF4u&S6B#d3slm~fn4!(-RV7SB6cCXa_GXxQqW z(d_7nIw+YAy2Z|jwfHr;v)Wc$?TyP zkY+LbjPZo~5L%}dX%?umKAm?O0LmdBr?I-)|6bot*)5|_|dArkD$_m z;+zH^SaUFbh|$rEEu=8Onj%HC!WflwAGBBtj@ooQ(;;`OAp;#GiUYeI@T~P#>z)g` zgYpTt7zgLUI{{O<9vZ!}5;k42k5rd|SqKm@+RPzZS3sCCfw>6$r~78pYxYN8-kPz8 z^Itw*6QYK^zte)i!~*iYwn?3>k5NzUQx<5;6sg!c@sfmi*om$oj&I1SD`3?)AAB~A z3czm>H{x}1BByYKwWD|3knb_}nETnHxqkvTGK9`&#N!aUF8H}))H(ge$+m~E{w(ZY zhNpT`%gZMb@NVD(#QtN7W{dW-d?mmk!o)vYZ&n}gUjv!=uJvW~u%%Nn=O*%Mz0^-5 z*#`4rR9w-UZRVuiVE#itk-p682mLZEnJVB&BCeD6>xwGDuk$8cl6f@IfX5N8(Co?u z%G-S(b+HG zr!6MqA_ho!mW?>yWZdk5f)xU(W`+cYp*2NI;Nwz3*tQy#+`Gc1Z z#Hx$-N3E(Zp4_FN8qIqfSQvPhQ)ZWMpc;PE1&PrE+_ebPQ1O{*3<@9tb@xCdm55lZ zH4mpJQH0BmAOYr+g@TQ8{yYdcof4VzBwr)3c8F!_^aRK^g^7^W_$)g1A$OMPJl2|z zXQq4dJ)Gtax@V}LdqUmaZy6-U7(L8qsEYVyx~$(Bw_YU9<`r6TI_aMH#2g_0G$*7~|A*Z%PiV znc~#N$dO@1AP+H_k0MZjn9OGoxZ8UxpkH8ft>9vvcYZGKt^$>8@}}kDwptOa_ohRK zL8L^fBVM(81N;Q>YM(bqTM(~~cyHz^h*zKRrh=Q=G9zC7xi=j+I;5mtjH~0`%?qB6 zjaSFKn;+;!h2!2W4?J)V5of(yvKBm#!290K_h-+ESO4ryDXhMf5wCvcT|gUX;t|AG z#H%;F3nv8ulRI8jhURMwaC4I5RSUv=|9_nuuci&9WUV`%8n0##ZPQFx+qWjD`9t!` z3aG`oCZ59woUKn#i-#0oas(EGYi?lx#G#g;)(**ci0nqlj|pn?ka9;zR!g9U-l1=h z8vpkIb3ZN~r6)Rdr}8d9{e22W=m?R08Oe1dvzNFg9XwHDop ziFLMqrh0XV6p%vTq=3ki-cRR6Xv-Z;G#=yv#eB-}8}Os4!Y(H(aT(@J#$^u&32?cV za&RSqp_%LG)d9|k2F!U}e#pl}!$ON%gc4IcwieYk45>q-ZVgWK95(qFoXLDVi|QT@ zr=_L}fr0PPqW*MPrx|IU3B*w3IVo>63-1n6$uzjB!V;EuP`g8_Ag%&WMXAo`QGcR( zd|>_>LNT^sUZ=DvEMdhIambBjkRmaY8r;I@IEnKlga&1#IVE+3I&P37Q})Bec2=njoi+ zi2G+lXCP3B7ThB|t5ZgBf1Z?t5i6>T;qxS^qa(r!c|X$3jGCp6kI)dAx5HZrF+>g& znx#&R1gwTb?S&)vkA&I_M+$r4S*q?p0J}13n2%MUfh!+^U{auuYJtQRio~8Q&57dA zTW>jn`(@YIo?FIT7U)d0pJny$)-MZ$bMlwoo-=enlBO4h{#*ZS=)d#!(0}mn{r1mw z5fx>b+OPtqoB>6VtXNf+9ZG+iiV>6&Jtp=lD5hBh#O6dqz|p2Cw7TJSq;-kA>n*`&I<^^@klye*PVQS<1l_%WMaNMFN`1vF2bH0$wteQmTr zeofPX!nbvzK$g?AAHGxqd4Q(vzPEKz0(qF`y-sJq(eSoTBakO(w#FK8yse87$n$^+ zHu!>oi4(|9nsa%iM!Z1w&`}P*-|MfndhBk8|7~5OKn7{SS_3O_*x%MA3*;MGoawbm zlYd*6B9IYU>2$drqkypjp&2HKb4U}(7={V>s>d<@@ZWI$chMqALy&O_6FxNyLHUeG zilBq9+6`2nAgCHZb_5ycG2sgmRRBPZ3}X*ecQXEs$B?QOK#LfzrXb*$)~bu4lw<|N z_a0k%nz&iP=kS9b z)!&Jra783Lip*naTlKxr-jL8wA;S_jigW|e_%HyQ)^XCp?g!v{R|~?Ko2;VxFpz~45b{1iK4cZfZvgU;-0vuWzGUg*YKtz! zbqIs3lN)6902~IO(W2YMon$+NlK|2Xj-yS+bPfhp$eq6hU^2&|083>^9;YGs92;n~ z`f9l*{}vpzjMI`TjaRPk-f&nl75cOht7Wk zh9Tb!Bz+&CA9AeEWvjcu9X=Jl%3PO)^CcHYPI9c@>vl8zV}Kb5k1#)kq`Cb9uHH#Ic+YU-w5QB99J$b^$5M;}PB;z8>k}!$B5N_w(^&JL9YR*pQpY4Lwu83g6s##2Rzf{^?$=RO^`sJ@d@M$ zUSaxyZ(=0C1pxem=RJ;T)&_@4xN;0xT?1f*SLCM%O{P84I%0%G5-$jLnXXv4a-`|X z=befgAChMPa-2ZhP1A*@&^+dS-fXF_|HKo^^SEz}HsmqZo` z^aRri`2IeLEEVVy(|Y{gB-GRlT}dLVp=bVo3DdD>EA)I6dglK@n2tTS19koz!u07w z!^z}Tfo<>y9j&@ZB$@nK;G9->09q84Oa=r+q5So^peSn9DFAj#P!zZ7X!!b8P)umm zG4OR+P?WUlSooquIv)s;l}e<&p0VPakx2OJdRf_jCnS>ukpYWbBECscLuYivEUt0G z`4|1+c&8KRnk(u^nMiB^4T=5@@%_}$Ssn3-?*qW$x4QAzSw$-H4sTbhsCKPYEY$LB zyS7oZY4vOhxm~0SD;^QmNB%@nJql_0ZZU;y6q&;E%0I~PZW;bGz@HWAVEG;q_6g{_ zWcV8Ze;eSH$HXnOhEAuFk3~iKnNgY*GR>fvO1>5ql|LcLnN)HGhOJa7C+r?Nno1ZY zU09x^l;+SY(_a$Dk{G3;B4625cIejBGL>UVj#3CVx*BR-p6SY_P}yI)lz>N3OjVW* zbY1#WB!Z1bpsZAKHt=6noysQDp&n-X5aXL5sq+G*o-9-{_QHw>m7u)c%%2pLwDdke z+^?kV6&78gP%DI$dR9+<3xM)|We67C1l(8f$o~mt4`+H0Bv3OnoJL+zGW9OcF&t+F z&B!{uPnkxJ0NmO%g7D=Rm_0*h(#QoR8w6Tj1+cD90d^#f{Dd%TQwqX5_W*2H8i`f$ z;O`wCd!cH}Ql*hH6>A5uMQ2f2*+N0j8psUQnq0eg zv8rj+53B0xoX+)=ziJe9Dx_J^&EwRcm2nH^dA( zRBQH13;r#D|Bs5V@q!Ty>{B&uVfIL~dR=8CZ>jFjMdB}15n%}vzFV>)2LW+d^+2u( zG5=I4l4cEklR+-16fRl~9+GLKQI2O+8RWW3F+CArjXcvRA}~swNn+Fw)cCC)TWz75 zDM6qSfZ6J`RWj76Mi+QmJ_M!eEHYKiRn}YmbrzkdJuVc2a%YjCTCDUt0$%q_2ZH;! zWWfpk22pKluKXrBwuxFS{{?CCD2GSYe3j4Y@`G%Xg-?u8J?&lHojvordpcVd=-F)Y z2lXD8)1qtF+SPN^XF&4Vb2s_o?Y6PB8?{k2iu;>ufuC)NQlj~M% zMMPdw@2_z{5Ny$HR1Zr$Vxsmp)$lyq=YzPpk1{--wu$c(O}? zn??PP2=dE_I^cKs9M%S$m_=P3g}~dQ_6I!;E-(nl3}NF)Pt+c}7Xgb@bJSO1Ie+4(m+E_feoi z;k$2mJn}})Q0I`dQB1IYygGVI=*me+jUrJwgo&o>$EPFgyabDn&LPRsit!emGP;D* zvpK{ZO&5>1Mjt+f3XvO~OQuHi!TN%FuYG28cwko3mG8GmJ*NSxE}D}tOAxc+O!4Wa zdsJ6`l<~JmU-=ONgOOV1@X&X8q&1pF9!~&e)8oFOBWw1tPrar%_xul^7*z#^j-@S~ zt&2PE*0XtJGfbdhPxRrdIDysC0do-BAFV_ zRu8`0qj@YmFmLXxk?m4s@Rw*4v1@n&s=VE?jzPCb*@z`~o_H2!b%+s*gd*diY z*^RDaqa0Rho&n(1(A*i*hR&JE8V%=jTWz3;Pir>8$uX0cU}P`?4S&(d!Q`|?WcrjQ zpX}1G5Y@X+YPN*t%^G8TTFnTa z5Hdr%*5h3dkxgTPZbuqy2xKViu4GwM-=@ zw>Z!REmPx$+zr1kYuSL$I*OoU7?^-X_ox;l;{u|M;bsIK{*XnN5Ys67UNkFX2HCYJ z0c|nZi$anf!v^YHK3B|^&^O||OFO!0ueC8O1wpymLQ)NAo7J;WMvv_1xrLq`Q%L5; z2nB%#zsoaiLrhc1w5N+@4o%q29F~LWWiiF%z8EprX7#xmtnRZ(<;|U`<@a_bl#?Fj z)lGZLABBG&-&@|-L%;gO-V(#!V)DBfVU+rdm@Vf%ibxUMlQ9#>U$)LfTv

FG-$&OgoW37h{B^ldeL)-z) za18REM81yY0u2!O;-n^#A7dTXfX(HS>E;Q&tRilZwX%z0lP3`&jy7jlbd6$0e=NGL zd7$e%;q*)**>NNTqPyBS@S<=8xt&zCLcpcZiJe5M;#TKEH)kAD{wnT0_-@xW$Bl>f zWYQM5Cf6ci4`?o%5YijB2LbKcm7^r#IBPDBn%5uO3I}O2c`~lXauXu=c{$GdD{w&| z2vInl`E|6s?8)TaxSC%9A|-nmbQQaP7H6*o`)|>mjs0Nki`)yauF2$F9RDki!(j)H zdNIz*?v*C?Qyf$4Xu@%0UZLgAabpC#!{(~T5VlcN$>1p@dkk-ff>A>i2DXjjlxw10 z9YZyW0&auUeur-q3$gVIJ;?4BLtGw<#(4@UAEUC`Y{B}V8@2#M1lH6k5utb4I{H;B z3@}K1_ZY$E^+0X}PIR7dK;sx=SBn%GV^RMQc^o{YEP&0hB#Z8VMk~rfu;?BKT7)%< z=047(bi$l0Cgn$x*FFlzIco{HYb8uLW}m>bjbiP8w8!0St7LpOwnb`Kz~&JcxQuKc z!`OXrG9wX)G1yB?38~GN_g;q2v z^T2*O;!$PGNmaby3D(y*{2njjM*&S6;H;jh~GEH1)Z>MR}V*yjX5P@9P!1XjIpTy z2C+*yc_f~fCt}e(6@MqUS^UJPs1jkW7L}f@AY&6)w>8j!2dILSC2-itvFK_N2H9=N zxH$Z}6P8p#Y7^L6mmM~GR)Up%0V)r5DT6HPRt0HI;Qfx74pc1}c?;E-@BviSg8qOD z6?a1d@|=}`tJ=l&vLEq%+$In#GI=sV>8h`H*jysd!>yv^;hN$q$)yCoR&sn6T_0$y9HeG39iYKmCF9Zu;v5#v zafq2iZ_rSQtu(@ruO<;ZsTD#q?Aj>u==>^4T_T52*h_!nbfy-v7(6X<0370y68(uz z&aLq$BFCBpJ%`Jbi-`UQgLHV}nga~l6IEgrX-?#G%WPhh;{fAJz)`EnONsmKUPqu3 z4ae(=jpBKmc59-j?SMmw9=4jim&jGY4D7g1)#Oy7V!1_kA#sq+V=pA8z?rEg!-;m- z0SI}q!6w08xTcM^Vw0R8ke{3BNkXI5?*V@$tNi37G?KW_xN9rGuvppd3~YazyfRK` zxu>nGyUXwhm^Ul2B#HIbI>$_xqtTeMx57#mCGj>tM8>cjQQMPLs6`$a7o3glWkcK< zp;0u{DqrLw)NgBF+Pt`JfuX(mt`<>S14~B}T%LsMu&Z^{8R0^ro(pk>+Aa`*VMhY& z7wk$2NE7pq*Ar2eD8}a#t>oS$ai-PpvesZsPm<&WrG{KeVm(f4)tKaY;k|FAQ{f7A zq&s=T96IypgCXXMgEmmzbU3~2SkLJPSJ2_l!cr;lVv>!hlDSIR$NU5v9|C_imRiQM z;Dnr9Y%=;ckvhV)@;qx%e;q;lXCt;`J{SAIwjIzkis|o2+F~PjCv&6V5VtDX32F|@ zd55=xT(H|iFjS4#4&g`#m=7D-k<4KexV#{>cO`Qcc`7*USSrM|CEC>jwK9%gZWtZt zvdIDyS{cVwRaJFo=vh1YC|QstkTaIemWOg9ASeu|N5&h5bX zc^w3;E-N@Ql7uQ4x+y)h7?_={X#-30wum5isyqT2_FBsagaxoaT~@}Z8iJDl<; zR`DktPCdMWj$}JYbP7Gwhezn&|8tVu6ah?>-{FxAp_5pl?e#zj7#5$O5`qfr2#=eE ztqx&!ik@|n87VAOsvxt=2T6lNy(V5XCd}-Z-+X(|;^xj?Lsxh6{5vHf%m#vCAwNaW z;f7$}o)osh8-PV(Un`62LbRTpM*f(hg37+N2AnEJtg>pOdW%}r%tH8ml6^h#{4>{N zX4A-DQ#k34<5CJmeG3;o)5wh!*6;N;AYj-Wl{$^Yq_SR*8`$Ni6pKlz%V7c2h%r@( zK&h`qmz&B1d~PaYN>kM!LYK$Y-~t`6=x_mb($pAA=(7-sV7O6B8rCyhcE54+9Ni{62&8SOR2cy=K$5L5X zIShwGpz6nh>VpYRmN;6}Loh-uIgrX>I0t#*`3)SjhA|b`&*gTOWr4#zF*3y&&uY$cnLO zfnMY)$MSHXUI1T~pMvj4HCUr!o z-#a@;YGY(vM+)?6Ptfg_a~LTO>}5AYoM)BdJU6M*i%`0DVxh{I@|E7A`(P|?j~*;G z3WTR-La2Yy7&X7+t|e`YTMQlTi+i7n&tn(qQMfX33?;&BWl}7dVl0AzrVMp*i^atv zFZHM=^YqakuSF`>1!M)pI39ar>>{tNo($@FDUI+OQ`+_Q0%oE%7bJM6aMI2^;^~9W}0D)M={~Cp&PxX+RG$z*t znszJSl?@J@S<#px)vww+x(y3jT3b4$`jv+?rPW{$r9Q;9r}Zbx6URF7+%#Oa+`q#B zdUg$rrMkQAj)mQ_so0Q!VNv|3xfiKz$*8EW3y+RR`=(vcHov>Aqa7^^8dg2)CE+x_ zN{)Zh!_FwvzOE>aQgjLDtl#ValOJ}9)zzkbol>!J*VuEWZ;+2#HcKscE$QyX7-fJN zU~p1CawU!Uf`M9GtrNU3X7~Nfl=OZEDlLF^qze|zwSoa-%00A?EJ){|M2STLMNU71 zsb4?yT^9bvgs`8%bOwK)WUs@IB4=^zNwz&bCT&214FJ_ib^vP}~6 z#&?1S9v7CU>)9FPqjV1HVmKVKAK^cdpx>mk4YmFtW)x0tkxB)&<&*TIU{|oqkI>~m zu|q#&6AiZfeDJwvgzJ!HVkMwmVp(F~!D#s!KoDWDLz^LPOcr)S4QU2(8^E(jm@Edv zLnlOgi1Cv<3_`BY59JY1z4ml@)78`k6S(X-2A=&68G((IJhq|Z&I=Gr`AMIFm-`q~ z!UjL-H*mQ#f-d0jt|2ETCe5P$R|LuS8@L>V8&eJf)t3fVCc?>WXA0An?N-0tRRDg;D&{EuOtYd}gIM0EgbH+igCA;7#m0AQ=vQBUYgP4>+9=( z8XCdiDnPP~e2#S2j2j&w9wR5Upn`9t5*v;2#t|5rV5yiBSxfd!Gh#NdI0{V3 zpljT%Is+9X1sO^di3?rbj{&DadB^k*An&693j|;L^1WbGroOm-Ex!t`!rEaSsqhEcH^i7}J0TfjRX;dXINs&_NS zWp3rpXB^7d3W?D$c+O<-%~+slB&C_O-GZwt&%|J}k=&L^V^1e%QElbQGZFObOa+iw zR4r1AWHLddzyhp{-;zlOB_1-tcHjUrk`EG&1s0K2?NL1}1qcvEWDW}$An4g9@;{l3 ztpGNxnrb3nWisx90KPS7B14(1+ZBKV6XO0-{vVzd{&Mg1T!1`96X{XohXCtRWq&W+Wl?^UQ&}~nLI0M~O3CBZ3f-Xy>+On|1 zF&%6wZg7a)n+5L@ZgyFnh3;q0n(yeQr^2oL?731Bn~^@7yp+Ye0?yHT+idc2mgofg zatm-Oiv>?N6VDv}%qEwz;2B0u(AlaJ+1Z56#+JJdZcm{Vm(BPKAYpS&olOkcymTU@ z<2sv|vsG1gSD;RU8B+`se?`i&`COaV@2Co8H~G{@dKkv330GdvDhtv*QDqLcM|dzO zHl5#mA{?#$pht2qgIQ~TM9gWC-WUWMN6(cL(fqDU^gnD)^@nnk* zu(%;uG^SD^E=61`pgeIP#khWE8NXS47LEoUhCU9XIdOzP0y(M7eOTiDMFi_paNUw6 z?^qm#(Ih^sz>9R5bu>sc~Cqs?|;}0jE$U^(wmwg+#GLFB=Op)`~aY!4J!;NxL1gFgFc zt!33!aNQe)c>7+DgcGXe3=Vc4v@i?aTv0R)N`;WKY&zloy}xMPPDWO|4xhS zkXi++SHN0Eex_fZ!#UkjoS}gT<0j2*laS`NoQ*kp_IC184(E2&yBhHB|8{Z+dccLD zl$za6PUNVi#Pj9?&*TiU=nIpDsO%15x0uI9WsAa@96g5^93AI^T60y3FK#E_=BS*0 zhvSzFKF^8D244;)#6n@W=dxvWz;AQ`A}9r324Wli{z(`Fhrr2Na&bbpmX9=7bMQB+ z&j{=kDp#@iIlxY`;aqHwRs`^KTkjr+qcT+V zS90y@WN?e9)PI6+6?Fo#m;U5r6}nuDdY3e)KM@ltS;jH25B<#R!e4U{kGa|cvLY9X zc6eze8!z075+K8&G*BOvr(l7!`>OPflf)!k7AD4~FG3P^0P+u9#?74V=0H_>HwTi> z<{&&uk}i^T)8X>ysl4e7%GCm{_NhE4RMKieRw*$0Q+ZG2p*wg1{zsE=66DTOPvv2{ zhV^qCsVc86Ws%ANeJS-IdxXQjDku(!sg(MpluV=NSjJ-s1hJT4i>Yz~+d@k7qHV!I zgSS3kUOh%REhK+Dyh3r+TXfaHzK{Du-cVj&-t(0ejjDXJy`%}Xn>jpwA| zBi6h^+;nF8c*G)R$#@|b66$G~gPhDYA$iaw$S)yB>r>|sT==sj&V^)`iFJS-c-cfPBu7oO&Hu8AUPw-x z*oKhL@v;dzUoFu#O|_83nHg(C)yt-+g=DN5-la8K zbQxyU*@Yy>%-Fn8vd%DLJ@4P(q#iut=uZ=Qc$kR0)%gMX68c?#uxnks57o6qDCxB+wY(UogeygD}Hs$8ywP zbn|~?KOVB}eVdBed-eK+-J3o?_xH%g0p{4Iy>C(UE{Y1@82SDC{C4Kutc{xInD=># zdM0|KhNkwO8;tB4lfUsVo1o98Lt%?vv1UJyRsQf?mGlfZDrYgN$cGoZ(xN}jzl;1U zUk$l`(C?Xta>uAB#c~zK+Elf=a&dko7 z@5e`*lP!AooG$`ne-3?1B5U?qcTPWO>=F*}iI$k5m%^1WnfLi!35vH2)X495)#aa` z8EGfg78b?WZdpR^w=iy7^=~Zc@`XNfLf8C5{u1&qqKyAzNpA{YUB@9t3idkr*Oi}E_(oe0N}>cQjhhwdK|O-nw+q3ZafKc;t?Ym#1Z~6%hyr_i{|pzgPuc*B^t?K+Muaez2h6I?31qE*F%!dQJgE7TyBYg zaL~BnP(QV<)K`GZsVnFt0hz3d{7g3Hwa8BXps|OAhjYTt$g|#p{>X+;k$!1G7g<)I zlA{IS9eAtYO)Bc3@c{2Dklvd;2Lvw`usE(o*Os-qz^=X;nO%TaZ}=@zvkOGHv^x%F zriXl3z-HDsAS)249`Zv0lUV~5})eB1o3x@h{5Xt&Mo)$)V@|?d2oIGE%n46G6u$}Lysu63q&XA=7x`R6 z#Rn*lgKx&S1?VVM)N1pSW(*o|A9~0=g(9r0#tYf`ugymaRu_~Pt}a|kwigPvTB{!n z;QNKEu10$38v`i5S?{)GfyBt$g`BMbj8?18M=d4Cumwuis?$O1Tp^c>))75TNd}II zb@5dn@%sz)>{4>MkjX_mY%bhiXn-GtB^0r+Y%qBO07^3U7vjH&$SY!U@p%)@bt$O< zGBBE`Rw(SH#8<@SqHTps+CogAL`b0I9QSV0T*SgY0MBa$$m?#hqKIv9`QQo-v$-fJ z$@H?aLLzcgkpSriynqRPWV%t9TC}yOu&Ax5wy3e_9`c7G7K)I@Lq$6|kN~R8`vv!q z_lp>xt@?D)w;K)>OYaH9!`d2CBHi)n z*Wus zsh=+1#i6cXWO*?PueY#vhMVaGC%Bx%P7ok(gx)hDHZ6Y|*1nu90O5_Y8v<5NZd>^> z{&T1h_cItJu#}UNclzn#5gu8|_viSA0BekLin@ZhCx}kG*m65Ot-3U71^I6PK#Gen zr24=4Zv}aCf@p1k7_KG=nSuae%*r?s%Ca4uhD-zAz!!{}n2iMi^z``ED8}I_XCc%* zBP>xuX|xrK*Yb7eumsUa5G?VwcJ#C_xGDpeG^r8rqr-4lb9=9$V@XT9 z0sD0|iX5Vp?Hz{Z`SV-40H8!b+~~Hoz}9uNO0J&eUdFG;UT_pr~es#;*F0(C>{;Bi7Z^(EwBIylu+*OZ0l}`FIgEE4SzV( z-Pv1Z$n7m?&s%MVlMl}>LMG`_S7^SyqZ0yFJ-dpGnaJJe^*KBbPu#MzV%9<9mQL0W zI*sS}lj2q6frRL}J8|u?os|cTYd@Bb^D`6s$eVzZ z(!Q^NeAZ6SK_i|Ih4dEc5a9ndQMeBZDe%`jROwFZ(ARzB2Y>`Xxoiz_r8_mF7GxMm z`BMHqlttC}QvXh!?8IL7UI=LQ>>AQk$~r9`@9I)|4SBFsbXw#;<5^wGtRat=@=gop z+^b8uHRJ_sHMr`bC9ENDU@PF71uf+ovL9P`FjkjFuOT0oLOI821E*%92ssHjM8RKs z953w$%N62YoA7rLFWKW{jfER_18U@AP>=yIaj5f{2FnGBWpI}%XQx<@u;?-;VeW?x z@VRVE)`z8>j*yEmjp%0-t(@ri#zZmehTCykTD zT==UetKSA?^t}_z#UU=HWRU%GA|f|W5=L>xlqV<2ynS%hTV93gYBJgKqJEAEiBGGKz2;xA)kl8vHJIE;?aI@BHF0qrEgApXA+ro zg88Ua1trqQARK0Pm!1R@@EiPm4L*m3O%rRg2bk^fjZAM$;$V`Fx;c{}99zMtBR%SK z=RXK>!sOYL_3YYfp;>QIHJ}k+bqbQoc9(8B_rV7^p|xLyW~J|}I%wSZ!KS0(ueQh+ zFl#2Cdr?M{z+~R-gbXq8mdtzT;99a{GUM<PTxZ^?=vjn1!GvJ}# zn4AZ<2rvNo2q?gAN`C?bH=vUTm``C+;*{`JdGKnS*p`iho4$hEpb65jro%n*M4z2} z&iDaXB{UWW_yak(Nm@sSaZ2##X8||xfaMOov5r`$a0rs7acdIOr(o{1jsyVW)wmeQe5>Q26lSbBB-N&xTJQ816e6VWhw4F;7`f!c+M165XyT z6LvrF=>umD{r&I}{E?m;zcK~+CP3ysT7regOA}7AA5RH!?@U2EHhc0C<_L#hAC>-- zeRK*w?D=?#td}X-2-mY4$p1_coYEj5sZ&$ln2b~3K$549LSgc!rc8%vhskXd*jy-) z!m}S>ip4$5eKF+Bn0f>P!pYL_es~#{GGV9~y&F%xTFkSbfqTRYuxFqTTpmDy2`{ve zVa-%{RtFECKq-$4E2iq%jpUK3_?j1DD3XKv22fwB4h7c$4^rmCQD>w$m{ZelJ@r6|QM7y1j#E#S{z8_B<> za;=s3xWwI9E(N%MN8oVHH=M>+Kn z`LUd?fiJ~FgsGry@I^mFqAO@Sd@&D^qzc*rUof_@f_B0e_Yg5v(9__He~3)1pljhv zc$idGfE|$QM`*Q=3p>Cl;sNKU3^4D3^?sPRDnulZw;T^4UbLgoTUr)$NpHLS6-c+Z zLWOjJP@us9f{!!p%)z>XsJ$D|crCG+)RZZ6Z@wmz?{zT+!>eQrSMU&^Xkw^8R^ZhP z^oHDqmrUSh@o_qpGE?{f?IIwk1ot zF`d~=E>&=q@&a%``P5<8WjqdwUg#gv6ED0Azt;#FBk8nKf30G2rF=`hg*;lp%Huax z-hh~L3+b+emxFFddzvcYHVP(;V9?&5i>KJavE)TPQHhF#I*;{O4O5k;$a$jjMOd(k fLMqvq46+D=yfjBPEFI+jN>M5g!Cy4vTfhGWSvz+F literal 0 HcmV?d00001 diff --git a/8086/msdos/v4th.com b/8086/msdos/v4th.com new file mode 100644 index 0000000000000000000000000000000000000000..e95f373ccf486f5a7c207682353d10a748c621e4 GIT binary patch literal 15867 zcmdsedtB62`u}IsK%J zbDr~@=RD^*&v|a=%me4@@*g<&ZXOrnILYgG&vVzENjz}w>L|xu{OsaqcbvIW!Erk7 zm1%!0+-l~yRYh{CiTnTkzcY!+w{)z$smtZ{*H`Dynr`ZBxy5RlZk;vFT0D&l=`;~_ z&Zhc&kGrnsOyZ&0T&P$p`<-_0LZ|;sVolA4nM#w%eIXq7P>&65wG^mwrRalAB z@wzdI3w@zg7JBU}^RF9|xzLCzPVF)fB0|2|IJ`J zl|bg%eE4KDf%17SGz|lMb3MTNfIxErauCS8lnt@!^1LH3x0Cm8I!air0Nu!o zRRsa(yjHA=3$5mPzi;kCAoD&U^a3GFAoJ6F_^3+eF@S!}udVRE%0tSDD(rc{{>ZQO zSNs(N6YX{y`W9gOc&&f#=L93j2Y?*m@9{hQUf(}?hIIz8AzpAcx$6}nJd**h065A^ z4Rv+S0Ki;mq99fhibc>LZtnS*h{XVG7No**g4+q+y=&++7n&u=&L*e5q2AdfgfBNk z1414__Bs8~quQGY6fP&=QbB83(Z;zSf$828hndHKLNY|1Vo_{kefyQ;ckrzy$;Y7qCf{`ow%jh?<3S( z0K84){oeX*;+A0Z0u>kr@V`X9&h2|nbT|m@H-Kyx#fCbE)4vPzs%S3(*e?qC82mR7 z4Eh!j>f3<6D+)fhz2>}l=w$dZf0YU6Q*@jV1;5wh;iX5=GY}r(zYR|eU#pw<{mAyK zkFcpO0`0OWf~v=38N<8U9RAkh8QH!ezWEWFBSnHTNMaF*!7BxumM-u&s-m!=!-)=( z*bS1yp>Aq3fJ-Ey2;#Uy3Sae)&LA2cfOY|uBk@gM{})ozbQSawK%Yn&%ePV! zuL8~k@DE9{iziBjXUrvV-9j$(If{UHZ6FQ{^M{ zbaYOUwGPXCxhc4mf7>_V5P>TJw#(XSmSu7kwHKn@ENhD_zmThjzQVzmwbL!D@%;@K zx<%F&TQ<=5X1S_r=n@xNi;?;NEzhTstr+<*M&|!Po=+pU13Ui}dH(#NVJ`HdEY$lO zoUO*uQ7-gnS#;Sv0kq(rLIbj zJU^nT^x%)IWkhhH>^ntjlisk5bf|^ zm7NhymV-U~{2|^qT~+55=)56xAfL9bN!odK_Bp_9OC#3b1Te?#(V(~D)}=+qABm9n3pCXG>eST9xjY;Hef znhA1W-rdvLvVw;FLBHGWvKreB4*g>NX;t#?>i5=HJL{}Qo9?vSr|;Gi z-f{h2C+vjPNT7Cu71%DZTW?UP^MZa~l@md*)woGNtkQ^y+}Bu*0Lf|`2L711CUwM5X#E(SHL{vV@6FFkU<-|2JO>WML{er_ZIuZ!H*P*?AUK_Frb z))Tqg;U&P0y2bj->dYG=_dp{E_P`IY$0PUB9$Jl;RpyWA+6~X?*t%Yf+^6pEc;AJe z^t~H-kH=|S==>%UDipr;T3sF6$OYJ~Gm(5l?Noi#mf)omsv3d;A2h#Yj!iIN&>3u?WNg;C*w=B7*EY*9zfLsw0d zsP?R)o{guAPBr~fcj-IUe|^-Y?+_S_RP%?(z_&&TMB_1FHa+SaI=pVL@We}+v%mlL z1GBEc)NxBoXY0z2TZw@O!9c<8s6&^Dfwh?B^(ak&)%dHZXI1|G8pVSSwHd!hqr|C1 z*=p?PQ=$g=_9!B9K1w?kgGR;%anWJ}LplcatXEMC(NcqBeB?3tIA4#^F0o(zmuO@} zi}qUh?z-ql!UIc}G>>doBZI$yB}cTRc2(Rs*5~HGfKdm63J=bZ4fHd#;*+j&r{6M{RX~*l3SYSyn(Os zAa|qhiv}U!vyF9VV|XxNH9l-$k+C60T+rb32d&2Vm`26-Y+gjnps=1KU?@`UMOusy zsB!z;F?f*lj*{z0Gqbv20oAq_W#PIvG_Qlcr#Caz# z(w_f4Mi&csQ#fJ7U>UfjWC4Hq!jAAq-HLa<4NPmiO_sMb(ug5EXc_39ynZBnXXJfR z^G3Gs7fs=jF};yuHPOJhGZIm^Df|(Uogd4E&c-MnugyUzCX@HFSSjFb@RJ%}g_Lg+ z9r{RaW$d7EYD#jJB*e$82UJqkyE9g3^!lMpx5p~6q)AW2iawj4)VH6%J$4v~_r>B))Y&s-2T{B^&mYSS7jZCurbfa*?tBW1VJeBsf^E~#+UtOT-DFek(@OQT_xfl#W|{B z|EYgOQefMt%)X*H^f6qcBGWdg?Kh-GrI1=LXa|K|N>I!dm~k$fptITS z4Yds(Yym_BYwA*w$h&ME`>K`)c;fxm39{W=hujEGbg8^Q+Bw0YM@%}ws{eNMQFuxw zfCsT8t8ss{L199$8XpBN!5WpkHKHZL1)i*yi1$>leFVoja~0fm1Q?FlD@#J7QvDz8 zDdTM&>(8RL!VSyRJgmCt?Gt#14<~bU6fuTyfiH&oIrIWoC~p;uMd!ppVX1r*R$VOa zRT(9mR;gILz|(lEkuVI3B_bF0(>al;Y~@6`uA#Qd>4#ij(0bB_4W2YrbFr1qiOI?_ zn9oK9Y;#-1y%TPp_}+v@C7)P}<}UDi(aC@pA*D!;_KLNg6CPA#AxjTT&h4#lQ zh$CTN?a-V?3{R#8=YGg5VT37%a z6cZEt2`=BAmx`Rx%)`EwAXb6{2ivEU37R{s#`6h-LauN=Az3v8!wC-T z0770`g^-B7aL*fS#U{ESkRO_9iE^XOUk881RDM<>8A;k_+O^d%EHybUC$Z2#G$<}O6Wc2U#nW=5 zVycdKRzj%X)_%*fm2E3b?aOX%Q4CdBI+@_IL|TVKZ{$wP=Mz%Ipjc?=f(T4I;;~=Y zm10Pf@{gAjNR}kV-$RVICn^hVez&cPV){_xc!F{vQK)m-Dkmf@4exm^jSH9SN4t|Y zF4kroxj)EXa%xRnw>F$sdbH=%{j0U%kHTsx@asfW3zEbN=3~Cc#s}fgCUdt*0-TUb zj7=i{rf`SFR!I`9`p-w1{j(=YIWz{_wm-U2Nqb{VTW(Df$G}1H?j#q~9Lsq_vOzAi zIsb*Js=N+_BOR*w*^wkt6I7m2+dGp)D`SPGoy-NrwgiV>=I)Bq-eDS>=%U36hVF{v zD=RCz(~0VPNiy4rIV6vp<7pojC7%!w0;j4fVbq`}+W2w;)wb{NQ6*W4QgWv8tx}34 zDUC`I3R6jUxlp-Lfw{)%s>7)ZVP7HsFcbf5BdUQ$sbTDl1w|tQ!4Wu#(T`zVq8hqd zI+t~}EHkzCtXxT5E+89F}i4+KK4K25mpbt2O6#5dOUpL95#aXBJ8% z6%39`k1PgdXQ@cQWY|sU$K6SEdaTC1NF>GOoy)pzAkN=4iVmlX&0fJzlI zyL?C*4)u!iwK;xa$MR*@_pDsj*=y?RUbg%uRS1iKFf8XMr--y6G`1&MsP_i2NE&Ms zXkFAzU4Km0p|WqQf>Wi4m8mwVw_+g8EX3a@gqIV}J#}TA*k6-H^^W60GRJ+1iykg? zEm`n;z4Zhb&WoIc+<%hbt@D6fesYnLIOz^`0p>{&1XRabjX9Gfz?V!S9!e(ZAwqYZ zyWR~Quo`IrH7e^?BRd{s{?~{vqs~m;fqc-H@HSTCARI$Y(ueRIsF_U?5%c>L$VSd*F1 z5-FSnnj!88;zi<()Z}){g9_E;^096-+4>p+J*CUE)e*r6Q>#kWi&W)p@OIu`a+Akm7h6O|i@P+6Gf3HI49_ zliO3c&_7cm+&Hm*pWlf?%cY%(txX}3eWfh|;cF>YRYSRukZN0mFi&YuS(3`7YT{T1 zn3t-7Ky1o?k3pGFtxDx{+|aZi^Ic|eaAp;AvRc1t@8~wIXlZTf9IIb7rB>01h?Jn% zp4y+p7^gb%l2lqY8{c7qo?U^l)OWZ2{Dy93DmKPbSTu3W+$-F+BvRCu<%g$|eKV|R zTi)H)(N30y3@hz!I8~}-@lRUV6=~Vq6)AF>F8QqOiybieVV5#@u4QkhT5Q}o`K;v& zqN8VKspaNX-Mti}4DbUyvq_gyL%xPUHLcbKFHG5eKR-LIpGTzylR495E9F`Z0dw*% zafP@dO+<;3iUgYMex6dle*UXW`kNBMexA}9`ul`%6@N6@D`QUx?P)Qo11f9)SSN%5 zjG(`%Z-76BZSm%8rRiwd(&hO3T=160-?zPCfvvPfY?tBIdU9g{fD; z`6&}24w>}iuN^kO!(9NsWK*&=f7S|$Cz^UCa|9~T`SpI(o{G$GR%u^+{u9xjS7ke3(Qza(DVemhp-~Gs{u2pl=MO2!o@KK!p zxw?-l($LmStFt+tRnC zGv)tNx;6t^*(wpvwscA;X!qVt7XoSkACFi%7vV* zki1hUimZJ^VrZ8^73^J0zfB6m3^TGkr?NR`Fc=!St<2jE3Pk zli-_KfubZs>#)-5$}(86d0mEMXU=an~ZruZFfPgR}V_2pDfk^*P25&FGhRwx>eU`y{3Ign{!BB?a zaR+c-Gtw zxSCs*31el)B?-Ch`G_;fO%;n0A`)_03fGoN6^{9^sceI9&&0cg@gZw7$^9%|_m#Hk ziEyj5Xo;G{rl)bC=Q1UC!1Y7D?fp!}1^elNHe9MzfF2j`7MqH9fma` zMRUrCbQn1)qdu%s|74WvQ@C!)WIGmz(2qT=ppuS5e}42@=34YU4Mm`7i0pB=%r%I5 z$B7?@lOPX9(_hPcIg`;NI%K|nTs6B*x|oG}Kg0|3kku-&;BChgIS1=d)0W1pswp>2 z88`pCr${+fOkb$OpmtqUJ;SjnGSiW{e6~NFa6FUj_ZnF6OH-tAVw&u~P9b5%WQ$`| zG})(ANJh5Q;B$=CTJF9K*S$$zDl@Y*BRevHLSsIoLY4zE*fNDeHidf{d-5%$LhD2t zlpUq+!oTAZIl|Uq^%|^Yg}J-hoq zh!MCj981lPXY19(b9{lPvj+w8g-LQ`R)@Sx$rU2A6!~;^iby>)JMltVb9pSj_%d7P z@;jYBCGc@}WEOlmOo)}EVNYiNA3!BIPPlJ_hWB5YD0YSVe$7w66DW~lGLFGM^z$#vf6bwO%GK~xD+fh8 zy0l`(i?*T|Xf#zc>Z6PWE7I=E>Nhb-NjMWG#iq|9iQ13+gO)L#vyD$wnL9oaJDY=e zlti^Ot8qRqkDkb#&y!rOaJ5h5x==~0hOCk?`xCiOuI03l}+!MK!u2KD* zW~$6>OTJNO!dOl}C>$1PtPaHiWfG@9p(fMhIc}4v1VX)(U@MbY0*mA}H_F}+sQ1?9 zv(>XGCx0qlp}1?U#dR+D3m53mC#UK9jL21 zJGxtzcekvlNn-o((=337?wBg7hmC?e8bwpvlscEgH*1}9#mxZsi!}XWvoyz!Fu?ZCHQXL~G+ELI%<>JiwUg6Ks%n_+g zmD&9knZ1M@t52QVfBw&7;@oKwoUjAWTj2SRShRNk^A@BYrz}E!(C2*K0zSUB@D8Wv zc?(`VU9kv0+dP1Atsv!TZ5W2P5OI0Dt-kVk3$DW_=iyyiqt%$6#~es@9&h)eWSyQz z^}K)M(GDI5e!}C-JV||@InH9n`GGMOug~LaoWTWo;P8$-0iTr%^1$QzJPEfgDDy7J z1D6lw;q8gfX|G?92Szzg2&lDkn_`^AH0p)COsd7?pjNXxFH0@SNccXGm!%dvzQy;E zyiBS$-GSGhr}8X6sn0Ay=Tmt~HdV=Oe&h+i)RKN2FfB(k@46yTq?#O6bo;nbtq`cJy0KML;;+4sE8#q7C!b^5N&AD{jE z=%xYw=;l4IaoU|67rr*~ySJt7{F|AZqMzp9mN@RIs7=vYZqM1l(VY|WH~nQZ#%w+q zwx(#-?USg=A6}wUpW#Mkqez*L7rW}BKg{Ps|H{`R_iymmEhV{ARFrJJj5&9mUB%}7 zM4b>5kNoaRpU3)}1nU9w*{yggCRzEaAkIu*_BT_b@{+76!dc%a=KdICi$~Y(vGvVA zVD6IlO9|GPq36OCVCHRUXT0V$6F2g^oi+LA7J|rJt3YCGx8lWqxhF7$~K zx#n-dt-~Yy_KUlS%xd&)aIDUM{Zou~gZa$@s*zn_sqv$zq z6+LtkSmF_*8pILl5$oq_1k0`){{2@vU4y(N4NntX%qk<_ zT3I+bxj@W;GS6LHfXKpIpu5;3^~nd!8xQt#_m%hxXgM_nr~@;!%FqvJ6J8qalMa}B z1U#IR`$m83E$AQJ_#xrn0{q(wbSzo`?Z9gVuX2$G%=;x@f%@L;X&^jXAke&4V_W9h z0*C(c=%NC;dZTZJTU4On((V|`hzf*^Dkri687J@C0zRV(S%HFYO(7m5*s5BM5okme z@);h)#Hb8}lJRZ#w;H4HJ*802Vdv9olwsn?u~ETGllLfQAfv}15iuul7b2mOK{?@Z zMDd#u=Y4Kjs`5|-D(qaN;seZM@XhqLfE=ZcTbuWI9t90-AAVV=U|m&SWaq!gJ6y1~ zpsa9hAs5F3-7)>+M~TTK;mnDvn`Wy@z)DQdjX7AtI-Fpk5UUt)@sD_ z$k5qBF^8-pd79#Mnv?3{cfTj?Dd2kO=g{*e#%mSOU^Gdsn6Q1*#2m7%xTGzl1WG{yHJ%VJni>^L_Yp4AtHJ(Ie7ksxv|+Eh@9BIyc6mS0EG^%m96Xfs`EI2$`%M&5|g3lW=^J*lpJ1%x+7ZV04Y;oV{ z?&m2=5IC2}cKXSp5s65#`*V6jKsCnk6xB0banZ$=$642kA0}|2{|x|AT!N`q=ihH- z{_k3$SEnnsdc<&54agK^gfVx;DJaW!beb|ubOT>7VMZ1e1jy6VSECX~r(8g&dsIw2GkONehgX@AC_iRMQUibvr#QNXp`3M)`hLbWBY3VyxAmGs$$K8F(kBmm{I*TZ3Mv$RCOK>xCm@UfHHw5!ppUxnYmZ|k{jgj?@ulg1SLl*G zj%h4z*iEF7E1@6*Fma^wlm@ec#BI3CWZ5YdB&^1anUwpH1AID*lJ#LVr$cOwdDQJ; z`V$nlmryoIN1o-SYsB)IZ_U_V!ip}9%47dTZcH+0oT=pCS5G#-9cA=A)ANdgVodR% z@aYWdd~l{b)@M$Bd?usq!&PrtDJ9H#+|BV+85k6zk1e+-gKX5Xl2>QGF*7vtIR9RW4kgk@5DxRZN>0E8{E9wb z!soEOc}8{C0KXmI#N@S^BA9g6ES`mMY&EYR?a`k-_fAlhXDynQBCNj>Y<`uif<}DS zDXS{mU9#ouJMR!f>pu%Nr}b4HFmHNi^O5jpTi6B6x>;wRRl5;0&5}GWWQc*+81110 zNbF|uPA}pV`r*RvSt51Y>3!TWIg?+7sN*y|)GM=caf?9Ay$1}~P4y>0xB;Ctz<&s) zl-c3SZ1TCp*p^L$n?J*C&~$ZL%b^~|=x=A8HNOL^M8?8|AIPaUNyEevets74fCiR3 z^a>ZU%@zryvhgDm^JlZ%sR6xU0V+rmCKeXYCf2%UOQ<`dBKpYeEy3`iLuU^ir9T@# zymxrbiBVqtMNi&r++EF5XHVaC?}zuEKKS=Thv|>{-1vprL^mFp`&bDUkC&#O z5Z<316yKOlc5KnCRs3O*zTPYOr||G>df4;+Y^ImVSp+9${%5xAQYV3=PR@R17GphW z&KMNTpPW5kW&676LJmr#c=iLLRNSN7mqO0;IfoGt&QkyG$IGzf=|e^2-6ZbCB1!lN z?vXCQp28Sh9-zQP7g{uR)f_yl!^0;iQ5lHW-`VeZnX{Jx7PaZ5;wS+{Ao6hvRS; zGydOCdd5LN{WtWlIpQK%l*O$^3=CQ4h*riNtH|w7qFa1PxGPR#Zig07T&nIl;zBB= z6XfTm_tBjp8%Z~Kp0uyhf0r?evtNSwWGL9cGuZG4fI0mv|L$6 zeAbqUWATqBoAy4YL=uLIev7MRy78eW4Nsz#qJ~j~zpRW`11N@_18gc4Cr@YZh8`?a z#zIBpIht&eIK^gUU72kqGsE;6SN*VilCW?(DOxCzp3Izk`be+PrttQLe4V7kp4< zIqU$dACc8QChvezqysL^9^l_nt+%^eAq2MNbO`C9orK=fvZ70U+vP7O5v(lN5ndn| zsCPo}ahASpsw*glThYy~C8|mza>ieiv3p%g!RRWP!WB9MB$^oRkL7eVgVD%sq%jlt zO1U_fUZGiyHA&Vlad$uhx){e?!s?3Lt|8(j!3yuKC5ExD`-;*)-FT>v70o3rK!!fB^0$_2_nUUh!i?I zTSVwpyC{YT4*o$rNO=PAi?zu>tjrKPO?at#0ww1RUFOffYy zkVt9qsuuugFA{g$DsY3v@l0cVlb``gybbsK`*XU&{Iiuxj~-%M%*)@@cpyG zd0cXgOCTxci4*$~vJ0doF%pldT52dBlG{9kWW#yasepBo#ZzPrTlUE)(0oh|rtSW0_=59tPNcV+e;dQT5`Orls{@ko}^`>Hu8waSmTr`uqME z$I`5ul*{FZ4c?iYoSn`wBgZADNknDTeUz~8ltOki!Mh>@D=4552*9};kU1k zru2~f!HCjb^gh_hwWR4jl#bpXl4H`Sd9$M$^dr%}ZCdR#0{h>ZR*^os1DadxQKkXe kEEbEKO)YM)&piu3L$5XIn=Jl6PqHaCGXOcD__$sD2e4%A9smFU delta 647 zcmZ4WpYhN?#tG8wAMSsHSIhk&}-uzElkb{wHvw#kVKZijG zcO3%*gUn=w>JlkVw;)$X7avbQS3OBl0r#3iTv=RJ42S4`@3O*cgC;k%^_b$?965K*NCt1r{=VY)oKj1{)qI zumSQdav*|0l4VP6En6(qt{b&1TW;0rLM*d;F5Us;zpP~sb_{b3@pRIYZ0A4E@&Sk? z*dtj#)t+bh#P+y$a!RdY42W}&*@y2Q^QT%_)>F)~EG%1o)N%#628Z|uLG(tlZe!+P z2T6kziwc00pJHz3e+V?uh(nfzb&GGEpr>DmYfu1Chi;gsqb}Iad6OU33fHr4sjFl6 z^mFzJbpeKLi}fArSK9g3Zncc+>=rKETnx|HugcG}W@BNh+r~VpZl3ii=BPT5nXBr! zG{Bw<4D}4rlWeQ~RQr(StO7{tK^+fR2I@#XNk@*ib#Zdffs$-ne%Cq1=t=$o`qhP7 zgyF;F{yM#Ev(Wk+3wXdCJ9h2bwSS0!JeFf&VUcqTN&XlR)UomWfC&9N1B@ Date: Mon, 14 Mar 2022 21:55:47 +0100 Subject: [PATCH 17/17] One more small Makefile fix --- 8086/msdos/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index 7410bb6..8e346d8 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -25,7 +25,7 @@ metafile.com: v4thfile.com src/meta.fb src/mk-meta.fth tests/log2file.fb grep -F 'Metacompiler saved as metafile.com' metafile.log v4th.com: metafile.com src/meta.fb src/mk-v4th.fth \ - src/vf86dos.fth + src/vf86core.fth src/vf86dos.fth rm -f v4th.com V4TH.COM OUTPUT.LOG FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ metafile.com "include mk-v4th.fth"