mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-25 10:30:57 +00:00
Fork vf-bufs1.fth from vf-bufs.fth for experiment v4th3.fth and fix test3.golden
This commit is contained in:
Philip Zembrod
parent
9d0789f958
commit
9227d0a855
@ -139,7 +139,7 @@ $(cpmfilesdir)/v4thblk.com: \
|
|||||||
$(cpmfilesdir)/v4th3.com: \
|
$(cpmfilesdir)/v4th3.com: \
|
||||||
$(patsubst %, $(cpmfilesdir)/%, tc-base.com \
|
$(patsubst %, $(cpmfilesdir)/%, tc-base.com \
|
||||||
target.fb v4th3.fth vf-core.fth vf-io.fth \
|
target.fb v4th3.fth vf-core.fth vf-io.fth \
|
||||||
vf-bufs.fth vf-sys.fth vf-file1.fth vf-end.fth vf-bdos.fth) \
|
vf-bufs1.fth vf-sys.fth vf-file1.fth vf-end.fth vf-bdos.fth) \
|
||||||
Makefile | emu
|
Makefile | emu
|
||||||
rm -f $(runcpmdir)/A/0/V4TH.COM $(runcpmdir)/A/0/LOGFILE.TXT $@
|
rm -f $(runcpmdir)/A/0/V4TH.COM $(runcpmdir)/A/0/LOGFILE.TXT $@
|
||||||
./emulator/run-in-runcpm.sh \
|
./emulator/run-in-runcpm.sh \
|
||||||
@ -238,7 +238,7 @@ test-blk.golden: $(patsubst %, tests/golden/%.golden, \
|
|||||||
cat $^ > $@
|
cat $^ > $@
|
||||||
|
|
||||||
test3.golden: $(patsubst %, tests/golden/%.golden, \
|
test3.golden: $(patsubst %, tests/golden/%.golden, \
|
||||||
prelim core coreplus coreext doubltst block report-blk)
|
prelim core coreplus coreext doubltst report-noblk)
|
||||||
cat $^ > $@
|
cat $^ > $@
|
||||||
|
|
||||||
test-kernel.golden: $(patsubst %, tests/golden/%.golden, prelim core)
|
test-kernel.golden: $(patsubst %, tests/golden/%.golden, prelim core)
|
||||||
|
|||||||
@ -17,7 +17,7 @@ Target definitions $100 here!
|
|||||||
\ .( order2 ) order
|
\ .( order2 ) order
|
||||||
include vf-io.fth
|
include vf-io.fth
|
||||||
\ .( order3 ) order
|
\ .( order3 ) order
|
||||||
include vf-bufs.fth
|
include vf-bufs1.fth
|
||||||
\ .( order4 ) order
|
\ .( order4 ) order
|
||||||
include vf-sys.fth
|
include vf-sys.fth
|
||||||
\ .( order5 ) order
|
\ .( order5 ) order
|
||||||
|
|||||||
214
8080/CPM/src/vf-bufs1.fth
Normal file
214
8080/CPM/src/vf-bufs1.fth
Normal file
@ -0,0 +1,214 @@
|
|||||||
|
\ *** Block No. 94, Hexblock 5e
|
||||||
|
|
||||||
|
\ buffer mechanism 20Oct86 07Oct87
|
||||||
|
|
||||||
|
Variable prev 0 prev ! \ Listhead
|
||||||
|
| Variable buffers 0 buffers ! \ Semaphor
|
||||||
|
$408 Constant b/buf \ physikalische Groesse
|
||||||
|
\ \\ Struktur eines Buffers: 0 : link
|
||||||
|
\ 2 : file
|
||||||
|
\ 4 : blocknummer
|
||||||
|
\ 6 : statusflags
|
||||||
|
\ 8 : Data ... 1 Kb ...
|
||||||
|
\ Statusflag bits : 15 1 -> updated
|
||||||
|
\ file : -1 -> empty buffer, 0 -> no fcb, direct access
|
||||||
|
\ else addr of fcb ( system dependent )
|
||||||
|
|
||||||
|
\ *** Block No. 95, Hexblock 5f
|
||||||
|
|
||||||
|
\ search for blocks in memory 30Jun86
|
||||||
|
| Variable pred
|
||||||
|
\ DE:blk BC:file HL:bufadr
|
||||||
|
|
||||||
|
Label thisbuffer? ( Zero = this buffer )
|
||||||
|
H push H inx H inx M A mov C cmp 0=
|
||||||
|
?[ H inx M A mov B cmp 0= ?[ H inx M A mov E cmp
|
||||||
|
0= ?[ H inx M A mov D cmp ]? ]? ]? H pop ret
|
||||||
|
|
||||||
|
Code (core? ( blk file -- adr\blk file )
|
||||||
|
IP H mvx Ipsave shld
|
||||||
|
user' offset D lxi UP lhld D dad
|
||||||
|
M E mov H inx M D mov
|
||||||
|
B pop H pop H push B push D dad xchg
|
||||||
|
prev lhld
|
||||||
|
thisbuffer? call 0= ?[
|
||||||
|
|
||||||
|
\ *** Block No. 96, Hexblock 60
|
||||||
|
|
||||||
|
\ search for blocks in memory 30Jun86
|
||||||
|
|
||||||
|
Label blockfound
|
||||||
|
D pop D pop 8 D lxi D dad H push ' exit @ jmp ]?
|
||||||
|
[[ pred shld
|
||||||
|
M A mov H inx M H mov A L mov
|
||||||
|
H ora 0= ?[ IPsave lhld H IP mvx Next ]?
|
||||||
|
thisbuffer? call 0= ?]
|
||||||
|
xchg pred lhld D ldax A M mov
|
||||||
|
H inx D inx D ldax A M mov D dcx
|
||||||
|
prev lhld xchg E M mov H inx D M mov
|
||||||
|
H dcx prev shld
|
||||||
|
blockfound jmp end-code
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 97, Hexblock 61
|
||||||
|
|
||||||
|
\ (core? 29Jun86
|
||||||
|
\ \\
|
||||||
|
\
|
||||||
|
\ | : this? ( blk file bufadr -- flag )
|
||||||
|
\ dup 4+ @ swap 2+ @ d= ;
|
||||||
|
\
|
||||||
|
\ | : (core? ( blk file -- dataaddr / blk file )
|
||||||
|
\ BEGIN over offset @ + over prev @ this?
|
||||||
|
\ IF rdrop 2drop prev @ 8 + exit THEN
|
||||||
|
\ 2dup >r offset @ + >r prev @
|
||||||
|
\ BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN
|
||||||
|
\ dup r> r> 2dup >r >r rot this? 0=
|
||||||
|
\ WHILE nip REPEAT
|
||||||
|
\ dup @ rot ! prev @ over ! prev ! rdrop rdrop
|
||||||
|
\ REPEAT ;
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 98, Hexblock 62
|
||||||
|
|
||||||
|
\ (diskerr 29Jul86 07Oct87
|
||||||
|
|
||||||
|
: (diskerr
|
||||||
|
." error! r to retry " key $FF and
|
||||||
|
capital Ascii R = not Abort" aborted" ;
|
||||||
|
|
||||||
|
Defer diskerr
|
||||||
|
' (diskerr Is diskerr
|
||||||
|
|
||||||
|
Defer r/w
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 99, Hexblock 63
|
||||||
|
|
||||||
|
\ backup emptybuf readblk 20Oct86
|
||||||
|
|
||||||
|
: backup ( bufaddr -- ) dup 6+ @ 0<
|
||||||
|
IF 2+ dup @ 1+ \ buffer empty if file = -1
|
||||||
|
IF input push output push standardi/o
|
||||||
|
BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w
|
||||||
|
WHILE ." write " diskerr
|
||||||
|
REPEAT THEN 4+ dup @ $7FFF and over ! THEN drop ;
|
||||||
|
|
||||||
|
: emptybuf ( bufaddr -- ) 2+ dup on 4+ off ;
|
||||||
|
|
||||||
|
| : readblk ( blk file addr -- blk file addr )
|
||||||
|
dup emptybuf
|
||||||
|
input push output push standardi/o >r
|
||||||
|
BEGIN over offset @ + over r@ 8 + -rot 1 r/w
|
||||||
|
WHILE ." read " diskerr REPEAT r> ;
|
||||||
|
|
||||||
|
\ *** Block No. 100, Hexblock 64
|
||||||
|
|
||||||
|
\ take mark updates? core? 10Mar86 19Nov87
|
||||||
|
|
||||||
|
| : take ( -- bufaddr) prev
|
||||||
|
BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL
|
||||||
|
buffers lock dup backup ;
|
||||||
|
|
||||||
|
| : mark ( blk file bufaddr -- blk file )
|
||||||
|
2+ >r 2dup r@ ! offset @ + r@ 2+ ! r> 4+ off
|
||||||
|
buffers unlock ;
|
||||||
|
|
||||||
|
| : updates? ( -- bufaddr / flag)
|
||||||
|
prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ;
|
||||||
|
|
||||||
|
: core? ( blk file -- addr /false ) (core? 2drop false ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 101, Hexblock 65
|
||||||
|
|
||||||
|
\ block & buffer manipulation 20Oct86 18Nov87
|
||||||
|
|
||||||
|
: (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
|
||||||
|
|
||||||
|
\ : isfile@ ( -- addr ) isfile @ ;
|
||||||
|
|
||||||
|
\ *** Block No. 102, Hexblock 66
|
||||||
|
|
||||||
|
\ block & buffer manipulation 05Oct87
|
||||||
|
|
||||||
|
: update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ;
|
||||||
|
|
||||||
|
: (save-buffers ( -- ) buffers lock
|
||||||
|
BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers
|
||||||
|
buffers unlock ;
|
||||||
|
' (save-buffers IS save-buffers
|
||||||
|
|
||||||
|
: empty-buffers ( -- ) buffers lock prev
|
||||||
|
BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ;
|
||||||
|
|
||||||
|
: flush save-buffers empty-buffers ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
\ *** Block No. 103, Hexblock 67
|
||||||
|
|
||||||
|
\ Allocating buffers 10Oct87
|
||||||
|
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 flush ;
|
||||||
|
' (init-buffers IS init-buffers
|
||||||
|
|
||||||
|
\ *** Block No. 125, Hexblock 7d
|
||||||
|
|
||||||
|
\ Default Disk Interface: read/write 14Feb88
|
||||||
|
|
||||||
|
Target Dos also
|
||||||
|
|
||||||
|
| : rec# ( 'dosfcb -- 'rec# ) &33 + ;
|
||||||
|
|
||||||
|
: (r/w ( adr blk file r/wf -- flag ) >r
|
||||||
|
dup 0= Abort" no Direct Disk IO supported! " >dosfcb
|
||||||
|
swap rec/blk * over rec# 0 over 2+ c! !
|
||||||
|
r> rot b/blk bounds
|
||||||
|
DO I dma! 2dup IF rec@ drop
|
||||||
|
ELSE rec! IF 2drop true endloop exit THEN THEN
|
||||||
|
over rec# 0 over 2+ c! 1 swap +!
|
||||||
|
b/rec +LOOP 2drop false ;
|
||||||
|
|
||||||
|
' (r/w Is r/w
|
||||||
|
|
||||||
|
: list ( blk -- )
|
||||||
|
scr ! ." Scr " scr @ u.
|
||||||
|
l/s 0 DO
|
||||||
|
cr I 2 .r space scr @ block I c/l * + c/l -trailing type
|
||||||
|
LOOP cr ;
|
||||||
Loading…
Reference in New Issue
Block a user