mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-01 06:41:37 +00:00
Extract main part of buffer and block code from vf86core.fth
This commit is contained in:
Philip Zembrod
parent
483be768c1
commit
620cfae913
|
|
@ -25,7 +25,7 @@ metafile.com: v4thfile.com src/meta.fb src/mk-meta.fth tests/log2file.fb
|
|||
grep -F 'Metacompiler saved as metafile.com' metafile.log
|
||||
|
||||
v4th.com: metafile.com src/meta.fb src/mk-v4th.fth \
|
||||
src/vf86core.fth src/vf86dos.fth src/vf86file.fth
|
||||
src/vf86core.fth src/vf86dos.fth src/vf86file.fth src/vf86bufs.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"
|
||||
|
|
|
|||
171
8086/msdos/src/vf86bufs.fth
Normal file
171
8086/msdos/src/vf86bufs.fth
Normal file
|
|
@ -0,0 +1,171 @@
|
|||
|
||||
\ *** 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 ;
|
||||
|
|
@ -1633,176 +1633,9 @@ Target Forth also definitions
|
|||
end-code
|
||||
$E9 4 * >label >taskINT
|
||||
|
||||
\ *** Block No. 90, Hexblock 5a
|
||||
|
||||
\ Struktur der Blockpuffer ks 04 jul 87
|
||||
include vf86bufs.fth
|
||||
|
||||
\ 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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user