diff --git a/6502/C64/Makefile b/6502/C64/Makefile index 3b76b96..7f71ff8 100644 --- a/6502/C64/Makefile +++ b/6502/C64/Makefile @@ -162,31 +162,31 @@ emulator/sdcard.img: emulator/sdcard.sfdisk test-v4thblk-c64.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double block report-blk) - cat $? > $@ + cat $^ > $@ test-v4th-c64.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double report-noblk) - cat $? > $@ + cat $^ > $@ test-v4thblk-c16+.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double block report-blk) - cat $? > $@ + cat $^ > $@ test-v4th-c16+.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double report-noblk) - cat $? > $@ + cat $^ > $@ test-v4thblk-c16-.golden: $(patsubst %, tests/golden/%.golden, \ prelim core) - cat $? > $@ + cat $^ > $@ test-v4th-c16-.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double report-noblk) - cat $? > $@ + cat $^ > $@ test-v4th-x16.golden: $(patsubst %, tests/golden/%.golden, \ prelim core coreext double report-noblk) - cat $? > $@ + cat $^ > $@ # Rules for building Forth binaries on top of the plain vanilla # c64-volksforth83. diff --git a/8086/msdos/Makefile b/8086/msdos/Makefile index 8e346d8..2760555 100644 --- a/8086/msdos/Makefile +++ b/8086/msdos/Makefile @@ -6,7 +6,7 @@ fbfiles_uppercase = $(wildcard src/*.FB tests/*.FB) fthfiles_caseconverted = $(patsubst %.fb, %.fth, \ $(shell ../../tools/echo-tolower.py $(fbfiles_uppercase))) -test: incltest.result logtest.result test-min.result \ +test: incltest.result logtest.result test-std.result test-blk.result \ incltest-volks4th.result test-volks4th-min.result fth: $(fthfiles) $(fthfiles_caseconverted) @@ -24,14 +24,27 @@ 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 \ - src/vf86core.fth src/vf86dos.fth +v4th.com: metafile.com src/meta.fb src/v4th.fth src/vf86core.fth \ + src/vf86dos.fth src/vf86file.fth src/vf86end.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" + metafile.com "include v4th.fth" dos2unix -n OUTPUT.LOG v4th.log mv V4TH.COM v4th.com + grep -F 'unresolved:' v4th.log grep -F 'new kernel written as v4th.com' v4th.log + grep -i 'unresolved:.*[^ ]' v4th.log && exit 1 || true + +v4thblk.com: metafile.com src/meta.fb src/v4thblk.fth src/vf86core.fth \ + src/vf86dos.fth src/vf86file.fth src/vf86bufs.fth src/vf86end.fth + rm -f v4thblk.com V4THBLK.COM OUTPUT.LOG + FORTHPATH="f:\\;f:\\src;f:\\tests" ./emulator/run-in-dosbox.sh \ + metafile.com "include v4thblk.fth" + dos2unix -n OUTPUT.LOG v4thblk.log + mv V4THBLK.COM v4thblk.com + grep -F 'unresolved:' v4thblk.log + grep -F 'new kernel written as v4thblk.com' v4thblk.log + grep -i 'unresolved:.*[^ ]' v4thblk.log && exit 1 || true # o4th for old volks4th - the new v4th is built with precompiled # metacompiler metafile.com and mk-v4th.fth which writes a compile log. @@ -60,22 +73,90 @@ logappendtest.log: v4thfile.com tests/logapp.fth prepsrcs = asm.fb extend.fb multi.vid dos.fb include.fb +prepfths = asm.fb extend.fb multi.vid dos.fb include.fb 86asm.fth \ + t86asm.fth extend2.fth multivid.fth dos2.fth dos3.fth + incltest.log: \ - $(patsubst %, dosfiles/%, v4th.com $(prepsrcs) log2file.fb \ + $(patsubst %, dosfiles/%, v4thblk.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") + v4thblk.com "include incltest.fth") dos2unix -n dosfiles/OUTPUT.LOG $@ -test-min.log: \ - $(patsubst %, dosfiles/%, v4th.com $(prepsrcs)) \ +test-std.log: \ + $(patsubst %, dosfiles/%, v4th.com $(prepfths)) \ $(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") + "include logprep.fth include test-std.fth") dos2unix -n dosfiles/OUTPUT.LOG $@ +test-blk.log: \ + $(patsubst %, dosfiles/%, v4thblk.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4thblk.com \ + "include logprep.fth include test-blk.fth") + dos2unix -n dosfiles/OUTPUT.LOG $@ + +forthblkdos: v4thblk.dos v4thblk.forth + +forthdos: forthblkdos v4thfile.dos v4thfile.forth v4th0.dos v4th0.forth + +v4th0.dos: \ + $(patsubst %, dosfiles/%, v4th.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \ + "include logprep.fth include vocdos.fth") + dos2unix -n dosfiles/OUTPUT.LOG output.log + tr " " "\n" $@ + +v4th0.forth: \ + $(patsubst %, dosfiles/%, v4th.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4th.com \ + "include logprep.fth include vocforth.fth") + dos2unix -n dosfiles/OUTPUT.LOG output.log + tr " " "\n" $@ + +v4thblk.dos: \ + $(patsubst %, dosfiles/%, v4thblk.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4thblk.com \ + "include logprep.fth include vocdos.fth") + dos2unix -n dosfiles/OUTPUT.LOG output.log + tr " " "\n" $@ + +v4thblk.forth: \ + $(patsubst %, dosfiles/%, v4thblk.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4thblk.com \ + "include logprep.fth include vocforth.fth") + dos2unix -n dosfiles/OUTPUT.LOG output.log + tr " " "\n" $@ + +v4thfile.dos: \ + $(patsubst %, dosfiles/%, v4thfile.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4thfile.com \ + "include log2file.fth include vocdos.fth") + dos2unix -n dosfiles/OUTPUT.LOG output.log + tr " " "\n" $@ + +v4thfile.forth: \ + $(patsubst %, dosfiles/%, v4thfile.com $(prepfths)) \ + $(patsubst tests/%, dosfiles/%, $(wildcard tests/*.*)) + rm -f dosfiles/OUTPUT.LOG + (cd dosfiles && ../emulator/run-in-dosbox.sh v4thfile.com \ + "include log2file.fth include vocforth.fth") + dos2unix -n dosfiles/OUTPUT.LOG output.log + tr " " "\n" $@ incltest-volks4th.log: v4thfile.com tests/log2file.fb tests/incltest.fth rm -f OUTPUT.LOG @@ -95,15 +176,19 @@ run-editor: volks4th.com emulator/run-in-dosbox.sh test-min.golden: $(patsubst %, tests/golden/%.golden, prelim core) - cat $? > $@ + cat $^ > $@ test-std.golden: $(patsubst %, tests/golden/%.golden, \ - prelim core coreext double report-noblk) - cat $? > $@ + prelim core coreplus coreext doubltst report-noblk) + cat $^ > $@ + +test-blk.golden: $(patsubst %, tests/golden/%.golden, \ + prelim core coreplus coreext doubltst block report-blk) + cat $^ > $@ test-volks4th-min.golden: $(patsubst %, tests/golden/%.golden, \ volks4th-prelim core) - cat $? > $@ + cat $^ > $@ %.golden: tests/golden/%.golden diff --git a/8086/msdos/readme.org b/8086/msdos/readme.org index 7653759..80cfcdb 100644 --- a/8086/msdos/readme.org +++ b/8086/msdos/readme.org @@ -25,8 +25,16 @@ 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. +builds the new minimal VolksForth kernel v4th.com +from .fth sources using metafile.com. v4th.com does not have the block +words and the buffer mechanism anymore. The only way to load code from +files is via =include filename.fth=. + +=make v4thblk.com= +builds the new minimal VolksForth kernel v4thblk.com +from .fth sources using metafile.com. v4thblk.com contains the block +words and the buffer mechanism and can load and include both .fth +stream sources and .fb block sources. =make metafile.com= builds the metacompiler with included .fth file interface. @@ -47,8 +55,13 @@ adds the .fth file interface to the old volks4th binary. =make test= runs all current tests. -=make test-min.result= -runs v4th.com through the initial minimal set of unit tests. +=make test-std.result= +runs v4th.com through the standard set of unit tests, without the block +tests, of course + +=make test-blk.result= +runs v4thblk.com through full set of unit tests, including the block +tests. =make test-volks4th-min.result= runs the same initial minimal set of unit tests on v4thfile.com diff --git a/8086/msdos/src/86asm.fth b/8086/msdos/src/86asm.fth new file mode 100644 index 0000000..b30614a --- /dev/null +++ b/8086/msdos/src/86asm.fth @@ -0,0 +1,397 @@ + +\ *** 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. 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 ; + + + clear .( Assembler loaded ) cr diff --git a/8086/msdos/src/dos2.fth b/8086/msdos/src/dos2.fth new file mode 100644 index 0000000..4618be8 --- /dev/null +++ b/8086/msdos/src/dos2.fth @@ -0,0 +1,255 @@ + +\ *** Block No. 0, Hexblock 0 + +\ 28 jun 88 + +\ This file is a pure .fth-version of dos.fb. + +\ 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 + + + + +\ *** 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 ; + + + .( MS-DOS functions loaed ) cr + + Onlyforth diff --git a/8086/msdos/src/dos3.fth b/8086/msdos/src/dos3.fth new file mode 100644 index 0000000..ad3ae7b --- /dev/null +++ b/8086/msdos/src/dos3.fth @@ -0,0 +1,195 @@ + +\ *** Block No. 0, Hexblock 0 + +\ 28 jun 88 + +\ This file is an .fth-version of dos.fb without the block-related +\ words. + +\ 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 ; + + +\ *** Block No. 5, Hexblock 5 + +\ file eof? create dta-addressing ks 03 apr 88 + Dos also 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 ; + + + .( MS-DOS functions loaed ) cr + + Onlyforth diff --git a/8086/msdos/src/extend2.fth b/8086/msdos/src/extend2.fth new file mode 100644 index 0000000..0852488 --- /dev/null +++ b/8086/msdos/src/extend2.fth @@ -0,0 +1,182 @@ + +\ *** Block No. 0, Hexblock 0 + +\ ks 11 mai 88 + +\ This file is a pure .fth-version of extend.fb. +\ It contains definitions needed for several further system +\ and application files. + +\ Among others there are MSDOS specific commands such as allocating +\ memory outside the Forth core 64k memory segment, some routines +\ that make using the video display easier, and some string +\ manipulation words. + + +\ *** Block No. 1, Hexblock 1 + +\ loadscreen for often used words ks cas 25sep16 + + Onlyforth \needs Assembler include t86asm.fth + + ' save-buffers Alias sav + + ' name &12 + Constant 'name + + ' page Alias cls + +\ 1 8 +thru + +\ *** 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 + +.( Systemerweiterung geladen) cr diff --git a/8086/msdos/src/mk-v4th.fth b/8086/msdos/src/mk-v4th.fth deleted file mode 100644 index b89a973..0000000 --- a/8086/msdos/src/mk-v4th.fth +++ /dev/null @@ -1,43 +0,0 @@ - - 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 - use kernel.fb - - new v4th.com Onlyforth Target definitions - - \ 4 &110 thru \ Standard 8088-System - include vf86core.fth - - \ &112 &146 thru \ MS-DOS interface - include vf86dos.fth - - : 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 - logreopen - - cr .( new kernel written as v4th.com) cr - - logclose diff --git a/8086/msdos/src/multivid.fth b/8086/msdos/src/multivid.fth new file mode 100644 index 0000000..6915ccd --- /dev/null +++ b/8086/msdos/src/multivid.fth @@ -0,0 +1,192 @@ + +\ *** Block No. 0, Hexblock 0 + +\ This file is a pure .fth-version of multi.vid. + +\ 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. + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ Multitsking display interface loadscreen ks phz 31jan22 + Onlyforth \needs Assembler include t86asm.fth + + 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 + + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ 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 + + +\ *** Block No. 3, Hexblock 3 + +\ 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 ; + + +\ *** Block No. 4, Hexblock 4 + +\ 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 + +\ *** Block No. 5, Hexblock 5 + +\ 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 + + + + + +\ *** Block No. 6, Hexblock 6 + +\ 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 ; + +\ *** Block No. 7, Hexblock 7 + +\ 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 ; + +\ *** Block No. 8, Hexblock 8 + +\ 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 ; + + + +\ *** Block No. 9, Hexblock 9 + +\ 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 ; + +.( Multitasking display driver loaded ) cr diff --git a/8086/msdos/src/t86asm.fth b/8086/msdos/src/t86asm.fth new file mode 100644 index 0000000..f58411e --- /dev/null +++ b/8086/msdos/src/t86asm.fth @@ -0,0 +1,14 @@ + +\ *** Block No. 2, Hexblock 2 + +\ conditional Assembler compiler cas 10nov05 + here + + : maybe-include-tmp-asm ( 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 ! + include + dp ! ; + + maybe-include-tmp-asm 86asm.fth diff --git a/8086/msdos/src/v4th.fth b/8086/msdos/src/v4th.fth new file mode 100644 index 0000000..6f56c3c --- /dev/null +++ b/8086/msdos/src/v4th.fth @@ -0,0 +1,32 @@ + +\ with build log: +' noop alias \log +\ without build log: +\ ' \ alias \log + +\log 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 + + new v4th.com Onlyforth Target definitions + + include vf86core.fth + include vf86dos.fth + include vf86file.fth + include vf86end.fth + +\log logclose + flush +\log logreopen + + cr .( new kernel written as v4th.com) cr + +\log logclose diff --git a/8086/msdos/src/v4thblk.fth b/8086/msdos/src/v4thblk.fth new file mode 100644 index 0000000..e0aa7a1 --- /dev/null +++ b/8086/msdos/src/v4thblk.fth @@ -0,0 +1,33 @@ + +\ with build log: +' noop alias \log +\ without build log: +\ ' \ alias \log + +\log 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 + + new v4thblk.com Onlyforth Target definitions + + include vf86core.fth + include vf86dos.fth + include vf86file.fth + include vf86bufs.fth + include vf86end.fth + +\log logclose + flush +\log logreopen + + cr .( new kernel written as v4thblk.com) cr + +\log logclose diff --git a/8086/msdos/src/vf86bufs.fth b/8086/msdos/src/vf86bufs.fth new file mode 100644 index 0000000..878e9aa --- /dev/null +++ b/8086/msdos/src/vf86bufs.fth @@ -0,0 +1,348 @@ + +\ *** 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 ... + + + Forth definitions + + + + + + +\ *** Block No. 91, Hexblock 5b + +\ buffer mechanism ks 04 okt 87 + + Variable prev prev off \ Listhead of the buffers' list +| Variable buffers buffers off \ Semaphor + + $408 Constant b/buf \ physikalische Groesse + $400 Constant b/blk \ bytes/block + + Defer r/w \ physikalischer Diskzugriff + + +\ *** 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 ; + + : buffer ( blk -- addr ) isfile@ (buffer ; + + : block ( blk -- addr ) isfile@ (block ; + + : (blk-source ( -- addr len ) blk @ ?dup + IF loadfile @ (block b/blk exit THEN tib #tib @ ; + + ' (blk-source IS source + + +\ *** 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 ; + +' (save-buffers IS save-buffers + + : (empty-buffers buffers lock prev + BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; + +' (empty-buffers IS empty-buffers + + + Dos definitions + +\ *** 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 + + + Dos definitions + +| : filebuffer? ( fcb -- fcb bufaddr / fcb ff ) + prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; + +: (flush-file-buffers ( fcb -- ) + BEGIN filebuffer? ?dup + WHILE dup backup emptybuf REPEAT drop ; + +' (flush-file-buffers IS flush-file-buffers + + +\ *** Block No. 81, Hexblock 51 + + Forth definitions + +\ +load thru +thru --> rdepth depth ks 26 jul 87 + + : (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 ; + ' load IS include-load + + : +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 + + : loadfrom ( n -- ) pushfile use load close ; + + : \\ b/blk >in ! ; immediate + + : 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 ; + + : view 'file list ; + : help 'file capacity 2/ + list ; + + + + +\ *** Block No. 122, Hexblock 7a + +\ Disk capacities ks 08 aug 88 + Dos 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. 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. 98, Hexblock 62 + +\ Allocating buffers ks 31 oct 86 + + : 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 ; + +' (init-buffers IS init-buffers diff --git a/8086/msdos/src/vf86core.fth b/8086/msdos/src/vf86core.fth index e614835..2c4fa43 100644 --- a/8086/msdos/src/vf86core.fth +++ b/8086/msdos/src/vf86core.fth @@ -12,7 +12,7 @@ Create origin here origin! here $100 0 fill $E9 int end-code -4 , $FC allot \ this is the multitasker initialization in the user area -| Create logo ," volksFORTH-83 rev. 3.81.41" +| Create logo ," volksFORTH-83 rev. 3.9.1-MSDOS" @@ -819,8 +819,9 @@ Label domove I W cmp moveup CS ?] \ input strings ks 23 dez 87 + $84 Constant /tib Variable #tib #tib off - Variable >tib here >tib ! $50 allot + Variable >tib here >tib ! /tib allot Variable >in >in off Variable blk blk off Variable span span off @@ -954,8 +955,11 @@ swap ]? C >in #) add Variable loadfile loadfile off - : source ( -- addr len ) blk @ ?dup - IF loadfile @ (block b/blk exit THEN tib #tib @ exit ; + defer source + + : (source ( -- addr len ) tib #tib @ ; + + ' (source IS source : word ( char -- addr ) source (word ; @@ -996,8 +1000,9 @@ swap ]? C >in #) add : ( Ascii ) parse 2drop ; immediate : .( Ascii ) parse type ; immediate - : \ >in @ negate c/l mod >in +! ; immediate - : \\ b/blk >in ! ; immediate + : \ blk @ IF >in @ negate c/l mod >in +! + ELSE #tib @ >in ! THEN ; immediate + : have ( -- f ) name find nip 0<> ; immediate : \needs have 0=exit [compile] \ ; @@ -1451,26 +1456,6 @@ Target Forth also definitions 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/ ; @@ -1600,14 +1585,6 @@ Target Forth also definitions &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 ; - @@ -1631,176 +1608,9 @@ Target Forth also definitions 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 diff --git a/8086/msdos/src/vf86dos.fth b/8086/msdos/src/vf86dos.fth index 0f628b8..0bf9aa8 100644 --- a/8086/msdos/src/vf86dos.fth +++ b/8086/msdos/src/vf86dos.fth @@ -1,3 +1,24 @@ + + Forth definitions + + Defer save-buffers ' noop IS save-buffers + Defer init-buffers ' noop IS init-buffers + Defer empty-buffers ' noop IS empty-buffers + + Defer flush-file-buffers ( fcb -- ) + ' drop IS flush-file-buffers + + Variable isfile isfile off \ addr of file control block + Variable fromfile fromfile off \ fcb in kopieroperationen + + Code isfile@ ( -- addr ) + D push isfile #) D mov Next end-code +\ : isfile@ ( -- addr ) isfile @ ; + + Variable error# error# off \ Nummer des letzten Fehlers + Defer ?diskerror \ Fehlerbehandlung + + \ *** Block No. 112, Hexblock 70 \ lc@ lc! l@ l! special 8088 operators ks 27 oct 86 @@ -188,67 +209,10 @@ -\ *** 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 + Vocabulary Dos Dos also definitions | Variable fcb fcb off \ last fcb accessed | Variable prevfile \ previous active file @@ -386,16 +350,9 @@ b/fcb Host ' tb/fcb >body ! : 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 ; + over flush-file-buffers ~close f.handle off ; \ *** Block No. 133, Hexblock 85 @@ -473,62 +430,16 @@ Assembler [[ W R xchg C pop D pop : 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 ; + : flush file-link + BEGIN @ ?dup WHILE dup fclose REPEAT + save-buffers empty-buffers ; \ *** Block No. 140, Hexblock 8c @@ -580,33 +491,13 @@ Assembler [[ W R xchg C pop D pop : from isfile push use ; - : loadfrom ( n -- ) pushfile use load close ; - - : include 1 loadfrom ; +\ Old pure-block-file include: +\ : 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 @@ -652,9 +543,6 @@ Assembler [[ W R xchg C pop D pop | : '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< ; diff --git a/8086/msdos/src/vf86end.fth b/8086/msdos/src/vf86end.fth new file mode 100644 index 0000000..e249ea2 --- /dev/null +++ b/8086/msdos/src/vf86end.fth @@ -0,0 +1,12 @@ + + : 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 diff --git a/8086/msdos/src/vf86file.fth b/8086/msdos/src/vf86file.fth new file mode 100644 index 0000000..e7fa7a0 --- /dev/null +++ b/8086/msdos/src/vf86file.fth @@ -0,0 +1,93 @@ + + variable tibeof tibeof off + + : eolf? ( c -- f ) + \ f=-1: not yet eol; store c and continue + \ f=0: eol but not yet eof; return line and flag continue + \ f=1: eof: return line and flag eof + tibeof off + dup #lf = IF drop 0 exit THEN + -1 = IF tibeof on 1 ELSE -1 THEN ; + + + + +\ *** Block No. 3, Hexblock 3 + +\ 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 + 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 ; + + +\ *** Block No. 5, Hexblock 5 + +\ 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 ; + + +\ *** Block No. 6, Hexblock 6 + +\ interpret-via-tib include phz 06feb22 + + : interpret-via-tib + BEGIN freadline >r .status >in off interpret + r> UNTIL ; + + Defer include-load +| : block-not-implemented 1 abort" block file access not implemented" ; + ' block-not-implemented IS include-load + + : include ( -- ) + pushfile use cr file? + probe-for-fb isfile@ freset IF 1 include-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 diff --git a/8086/msdos/tests/block.fth b/8086/msdos/tests/block.fth index 7def227..cb1b450 100644 --- a/8086/msdos/tests/block.fth +++ b/8086/msdos/tests/block.fth @@ -27,6 +27,9 @@ \ - errorreport.fth has been loaded prior to this file \ - utilities.fth has been loaded prioir to this file \ ------------------------------------------------------------------------------ + +use empty.fb + TESTING Block word set DECIMAL diff --git a/8086/msdos/tests/double.fth b/8086/msdos/tests/doubltst.fth similarity index 100% rename from 8086/msdos/tests/double.fth rename to 8086/msdos/tests/doubltst.fth diff --git a/8086/msdos/tests/empty.fb b/8086/msdos/tests/empty.fb new file mode 100644 index 0000000..f5b7445 --- /dev/null +++ b/8086/msdos/tests/empty.fb @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/8086/msdos/tests/golden/block.golden b/8086/msdos/tests/golden/block.golden index 998ca33..d241942 100644 --- a/8086/msdos/tests/golden/block.golden +++ b/8086/msdos/tests/golden/block.golden @@ -1,5 +1,5 @@ - -blocktest.fth**=== NOT TESTED === *******Scr 21 Dr 1 + FLUSH exists +BLOCK.FTH **=== NOT TESTED === ******* Scr 21 Dr 5 EMPTY.FB 0 Should show a (mostly) blank screen 1 2 @@ -16,16 +16,7 @@ blocktest.fth**=== NOT TESTED === *******Scr 21 Dr 1 13 14 15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -Scr 20 Dr 1 + Scr 20 Dr 5 EMPTY.FB 0 List of the First test block 1 2 @@ -42,16 +33,7 @@ Scr 20 Dr 1 13 14 15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -Scr 29 Dr 1 + Scr 29 Dr 5 EMPTY.FB 0 List of the Last test block 1 2 @@ -68,16 +50,7 @@ Scr 29 Dr 1 13 14 15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -Scr 25 Dr 1 + Scr 25 Dr 5 EMPTY.FB 0 1 2 @@ -93,18 +66,9 @@ Scr 25 Dr 1 12 13 14 -15 -16 -17 -18 -19 -20 -21 -22 -23 -24 End of Screen -Scr 21 Dr 1 - 0 Should show another (mostly) blank scree +15 End of Screen + Scr 21 Dr 5 EMPTY.FB + 0 Should show another (mostly) blank screen 1 2 3 @@ -120,15 +84,6 @@ Scr 21 Dr 1 13 14 15 -16 -17 -18 -19 -20 -21 -22 -23 -24 -*** | exists Given Characters per Line: 41 +*** | exists Given Characters per Line: 64 * End of Block word tests diff --git a/8086/msdos/tests/golden/coreext.golden b/8086/msdos/tests/golden/coreext.golden index ddf90a8..4b81e2d 100644 --- a/8086/msdos/tests/golden/coreext.golden +++ b/8086/msdos/tests/golden/coreext.golden @@ -1,9 +1,9 @@ -utilities.fth ?DEFTEST1 exists +UTIL.FTH ?DEFTEST1 exists Test utilities loaded -errorreport.fth -coreexttest.fth************** +ERRORREP.FTH +COREEXT.FTH ************** Output from .( You should see -9876: -9876 diff --git a/8086/msdos/tests/golden/coreplus.golden b/8086/msdos/tests/golden/coreplus.golden index b6ea7aa..0c3fde5 100644 --- a/8086/msdos/tests/golden/coreplus.golden +++ b/8086/msdos/tests/golden/coreplus.golden @@ -1,5 +1,5 @@ -COREPLUS.FTH******** +COREPLUS.FTH ******** You should see 2345: 2345 ***** End of additional Core tests diff --git a/8086/msdos/tests/golden/double.golden b/8086/msdos/tests/golden/doubltst.golden similarity index 50% rename from 8086/msdos/tests/golden/double.golden rename to 8086/msdos/tests/golden/doubltst.golden index ad02caf..146428f 100644 --- a/8086/msdos/tests/golden/double.golden +++ b/8086/msdos/tests/golden/doubltst.golden @@ -1,3 +1,3 @@ -doubletest.fth***************** +DOUBLTST.FTH ***************** End of Double-Number word tests diff --git a/8086/msdos/tests/logprep.fth b/8086/msdos/tests/logprep.fth new file mode 100644 index 0000000..4e4e3d6 --- /dev/null +++ b/8086/msdos/tests/logprep.fth @@ -0,0 +1,14 @@ + + include extend2.fth +\needs drv : drv 2 ; \ showing C: if drv isn't defined + include multivid.fth + +\ : .blk|tib +\ blk @ ?dup IF ." Blk " u. ?cr exit THEN +\ incfile @ IF tib #tib @ cr type THEN ; + +\ ' .blk|tib Is .status + +\ include dos2.fth + include dos3.fth + include log2file.fth diff --git a/8086/msdos/tests/preptest.fb b/8086/msdos/tests/preptest.fb deleted file mode 100644 index dd70b90..0000000 --- a/8086/msdos/tests/preptest.fb +++ /dev/null @@ -1 +0,0 @@ -\ 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 deleted file mode 100644 index 7d0e4bc..0000000 --- a/8086/msdos/tests/preptest.fth +++ /dev/null @@ -1,38 +0,0 @@ - -\ *** 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 - - - diff --git a/8086/msdos/tests/test-blk.fth b/8086/msdos/tests/test-blk.fth index ed2799d..76840f0 100644 --- a/8086/msdos/tests/test-blk.fth +++ b/8086/msdos/tests/test-blk.fth @@ -1,25 +1,26 @@ include log2file.fth -logopen test.log +logopen output.log include ans-shim.fth : \vf [compile] \ ; immediate -include prelimtest.fth +include prelim.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 -1 drive include blocktest.fth +include coreext.fth +include doubltst.fth + +: flush logclose flush logreopen ; +include block.fth REPORT-ERRORS logclose -dos s0:notdone diff --git a/8086/msdos/tests/test-min.fth b/8086/msdos/tests/test-min.fth index b78ff86..68071f9 100644 --- a/8086/msdos/tests/test-min.fth +++ b/8086/msdos/tests/test-min.fth @@ -10,6 +10,5 @@ include tester.fth \ 1 verbose ! include core.fr -\ include coreplus.fth logclose diff --git a/8086/msdos/tests/test-std.fth b/8086/msdos/tests/test-std.fth index 97bb1fb..baaea50 100644 --- a/8086/msdos/tests/test-std.fth +++ b/8086/msdos/tests/test-std.fth @@ -1,11 +1,15 @@ +\ : .blk|tib +\ blk @ ?dup IF ." Blk " u. ?cr exit THEN +\ incfile @ IF tib #tib @ cr type THEN ; + include log2file.fth logopen output.log include ans-shim.fth : \vf [compile] \ ; immediate -include prelimtest.fth +include prelim.fth include tester.fth \ 1 verbose ! include core.fr @@ -15,7 +19,10 @@ include util.fth include errorrep.fth include coreext.fth -include double.fth + +\ ' .blk|tib Is .status + +include doubltst.fth REPORT-ERRORS diff --git a/8086/msdos/tests/vocdos.fth b/8086/msdos/tests/vocdos.fth new file mode 100644 index 0000000..a74e972 --- /dev/null +++ b/8086/msdos/tests/vocdos.fth @@ -0,0 +1,9 @@ + +logopen output.log + +clear + +forth also dos words +cr + +logclose diff --git a/8086/msdos/tests/vocforth.fth b/8086/msdos/tests/vocforth.fth new file mode 100644 index 0000000..8239fc2 --- /dev/null +++ b/8086/msdos/tests/vocforth.fth @@ -0,0 +1,9 @@ + +logopen output.log + +clear + +forth words +cr + +logclose diff --git a/8086/msdos/v4th.com b/8086/msdos/v4th.com index e95f373..6e4849f 100644 Binary files a/8086/msdos/v4th.com and b/8086/msdos/v4th.com differ diff --git a/8086/msdos/v4thblk.com b/8086/msdos/v4thblk.com new file mode 100644 index 0000000..eb95cb1 Binary files /dev/null and b/8086/msdos/v4thblk.com differ