mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-22 20:34:07 +00:00
First stream file include implementation, as yet with incomplete EOF detection.
This commit is contained in:
Philip Zembrod
parent
e3dcb08966
commit
7810835c7d
@ -22,10 +22,12 @@ msdos:
|
||||
%.fth: %.fb ../../tools/fb2fth.py
|
||||
../../tools/fb2fth.py $< $@
|
||||
|
||||
inctest.log: $(patsubst %, $(cpmfilesdir)/%, volks4th.com include.fb) \
|
||||
inctest.log: $(patsubst %, $(cpmfilesdir)/%, \
|
||||
volks4th.com include.fb inctest.fth) \
|
||||
| emu
|
||||
echo "volks4th" > $(runcpmdir)/input.script
|
||||
echo "include include.fb" >> $(runcpmdir)/input.script
|
||||
echo "xinclude inctest.fth" >> $(runcpmdir)/input.script
|
||||
echo "bye" >> $(runcpmdir)/input.script
|
||||
echo "exit" >> $(runcpmdir)/input.script
|
||||
./emulator/run-in-runcpm.sh volks4th
|
||||
|
||||
File diff suppressed because one or more lines are too long
@ -1,26 +1,31 @@
|
||||
|
||||
\ *** Block No. 0, Hexblock 0
|
||||
|
||||
\ include for stream sources for cp/m phz 02apr22
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ include for stream sources for cp/m phz 10apr23
|
||||
|
||||
\ loadscreen content while debugging read-seq esp. dos-error?
|
||||
|
||||
1 +load \ /tib tibeof eolf?
|
||||
create tib /tib 1+ allot variable #tib #tib off
|
||||
2 3 +thru
|
||||
: pushfile r> isfile push fromfile push >r ; restrict
|
||||
: iopen ( -- )
|
||||
pushfile use cr file?
|
||||
isfile@ incfile ! b/rec rec-offset c!
|
||||
incpos push incpos off incpos 2+ dup push off
|
||||
0 incfile @ record 1- c! ;
|
||||
: iread ( -- )
|
||||
freadline cr . cr tib #tib @ type cr ;
|
||||
|
||||
|
||||
\ *** Block No. 1, Hexblock 1
|
||||
|
||||
\ load screen phz 06feb22
|
||||
\ load screen phz 06mai23
|
||||
|
||||
onlyforth dos also forth definitions
|
||||
|
||||
: idos-error? ( n -- f ) 0<> ;
|
||||
: iread-seq ( dosfcb -- f ) $14 bdosa idos-error? ;
|
||||
|
||||
1 6 +thru
|
||||
|
||||
@ -32,19 +37,14 @@
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 2, Hexblock 2
|
||||
|
||||
\ fib /fib #fib eolf? phz 05apr22
|
||||
\ fib /fib #fib eolf? phz 06okt22
|
||||
|
||||
context @ dos also context !
|
||||
$50 constant /tib
|
||||
variable tibeof tibeof off
|
||||
\\
|
||||
|
||||
: eolf? ( c -- f )
|
||||
\ f=-1: not yet eol; store c and continue
|
||||
\ f=0: eol but not yet eof; return line and flag continue
|
||||
@ -58,46 +58,46 @@
|
||||
|
||||
\ *** Block No. 3, Hexblock 3
|
||||
|
||||
\ incfile incpos inc-fgetc phz 05apr22
|
||||
\ incfile incpos inc-fgetc phz 07mai23
|
||||
|
||||
variable incfile
|
||||
variable incpos 2 allot
|
||||
\\
|
||||
create rec-offset 1 allot $80 constant dmabuf
|
||||
|
||||
: inc-fgetc ( -- c )
|
||||
rec-offset c@ b/rec u< 0= IF dmabuf dma!
|
||||
incfile @ drive iread-seq IF ." eof" -1 exit THEN
|
||||
0 rec-offset c! THEN
|
||||
rec-offset c@ dup 1+ rec-offset c! dmabuf + 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 05apr22
|
||||
\ freadline probe-for-fb phz 06okt22
|
||||
|
||||
: freadline ( -- eof )
|
||||
( tib /tib bounds DO
|
||||
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 name has no .FTH extension
|
||||
isfile@ extension dup @ $5446 = swap 2+ c@ $48 = and not ;
|
||||
|
||||
isfile@ extension dup @ $dfdf and $5446 =
|
||||
swap 2+ c@ $df and $48 = and not ;
|
||||
|
||||
|
||||
\ *** Block No. 5, Hexblock 5
|
||||
|
||||
\ save/restoretib phz 05apr22
|
||||
\\
|
||||
\ save/restoretib phz 06okt22
|
||||
|
||||
$50 constant /stash
|
||||
create stash[ /stash allot here constant ]stash
|
||||
variable stash> stash[ stash> !
|
||||
@ -115,19 +115,19 @@
|
||||
|
||||
\ *** Block No. 6, Hexblock 6
|
||||
|
||||
\ interpret-via-tib include phz 05apr22
|
||||
|
||||
( : interpret-via-tib
|
||||
BEGIN freadline >r .status >in off interpret
|
||||
r> UNTIL ; )
|
||||
\ interpret-via-tib include phz 07mai23
|
||||
: xinterpret tib #tib @ type cr ;
|
||||
: interpret-via-tib
|
||||
BEGIN freadline >r .status >in off xinterpret
|
||||
r> UNTIL ;
|
||||
: pushfile r> isfile push fromfile push >r ; restrict
|
||||
: include ( -- )
|
||||
pushfile use cr file?
|
||||
: xinclude ( -- )
|
||||
pushfile use cr file? cr
|
||||
probe-for-fb IF 1 load exit THEN
|
||||
incfile push isfile@ incfile ! ; \\
|
||||
incfile push isfile@ incfile ! b/rec rec-offset c!
|
||||
incpos push incpos off incpos 2+ dup push off
|
||||
0 incfile @ record 1- c!
|
||||
savetib >r interpret-via-tib close r> restoretib ;
|
||||
|
||||
: (stashquit stash[ stash> ! (quit ;
|
||||
: stashrestore ['] (stashquit IS 'quit ;
|
||||
' stashrestore IS 'restart
|
||||
@ -150,3 +150,22 @@
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 8, Hexblock 8
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
4
8080/CPM/inctest.fth
Normal file
4
8080/CPM/inctest.fth
Normal file
@ -0,0 +1,4 @@
|
||||
0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcde
|
||||
@123456789ABCDEF0123456789abcdef0123456789abcdef0123456789abcde
|
||||
A123456789abcdef0123456789abcdef0123456789abcdef0123456789abcde
|
||||
B123456789ABCDEF0123456789abcdef0123456789abcdef0123456789abcde
|
||||
Loading…
Reference in New Issue
Block a user