Compare commits
23 Commits
1a3bc28e53
...
e412229459
| Author | SHA1 | Date |
|---|---|---|
Carsten Strotmann
|
e412229459 | |
Philip Zembrod
|
e3bf763d3b | |
Philip Zembrod
|
f8c3d7c16e | |
|
Philip Zembrod
|
6e4f9fa1bf | |
|
Philip Zembrod
|
1a814700b9 | |
|
Philip Zembrod
|
a6976accb7 | |
|
Philip Zembrod
|
67f6188fe3 | |
|
Philip Zembrod
|
22079fe734 | |
|
Philip Zembrod
|
3e42ca8b2a | |
|
Philip Zembrod
|
82cd5ba3da | |
|
Philip Zembrod
|
b24511437e | |
|
Philip Zembrod
|
48544073a1 | |
|
Philip Zembrod
|
f3376268f8 | |
|
Philip Zembrod
|
c9a62fc7ff | |
|
Philip Zembrod
|
91c74f0830 | |
|
Philip Zembrod
|
155eceadcf | |
|
Philip Zembrod
|
620cfae913 | |
|
Philip Zembrod
|
483be768c1 | |
|
Philip Zembrod
|
432048b844 | |
|
Philip Zembrod
|
41cecebbfa | |
|
Philip Zembrod
|
54c3d25af5 | |
|
Philip Zembrod
|
9c2a761894 | |
|
Philip Zembrod
|
a7ef2d0e64 |
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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" <output.log | sort >$@
|
||||
|
||||
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" <output.log | sort >$@
|
||||
|
||||
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" <output.log | sort >$@
|
||||
|
||||
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" <output.log | sort >$@
|
||||
|
||||
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" <output.log | sort >$@
|
||||
|
||||
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" <output.log | sort >$@
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ( <name> -- 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
|
||||
|
||||
|
|
|
|||
|
|
@ -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< ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
COREPLUS.FTH********
|
||||
COREPLUS.FTH ********
|
||||
You should see 2345: 2345
|
||||
*****
|
||||
End of additional Core tests
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
|
||||
doubletest.fth*****************
|
||||
DOUBLTST.FTH *****************
|
||||
End of Double-Number word tests
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -10,6 +10,5 @@ include tester.fth
|
|||
|
||||
\ 1 verbose !
|
||||
include core.fr
|
||||
\ include coreplus.fth
|
||||
|
||||
logclose
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
|
||||
logopen output.log
|
||||
|
||||
clear
|
||||
|
||||
forth also dos words
|
||||
cr
|
||||
|
||||
logclose
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
|
||||
logopen output.log
|
||||
|
||||
clear
|
||||
|
||||
forth words
|
||||
cr
|
||||
|
||||
logclose
|
||||
Binary file not shown.
Binary file not shown.
Loading…
Reference in New Issue