From b762d6ecb08147d2ebce5083da59677f4e790e3f Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Fri, 25 Aug 2023 23:11:09 +0200 Subject: [PATCH] Extract inc-readrec from inc-fgetc --- 8080/CPM/src/include.fb | 2 +- 8080/CPM/src/include.fth | 20 ++++++++++---------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/8080/CPM/src/include.fb b/8080/CPM/src/include.fb index 798e55d..153db1a 100644 --- a/8080/CPM/src/include.fb +++ b/8080/CPM/src/include.fb @@ -1 +1 @@ -\ 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 ; \ 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 \ fib /fib #fib eolf? phz 07mai23 context @ dos also context ! $50 constant /tib variable tibeof tibeof off $1a constant ctrl-z : 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 ctrl-z = IF tibeof on 1 ELSE -1 THEN ; \ 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 ctrl-z 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! ; \ freadline probe-for-fb phz 06okt22 : 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 name has no .FTH extension isfile@ extension dup @ $dfdf and $5446 = swap 2+ c@ $df and $48 = and not ; \ save/restoretib phz 06okt22 $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 ; \ interpret-via-tib include phz 07mai23 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : pushfile r> isfile push fromfile push >r ; restrict : include ( -- ) pushfile use cr file? probe-for-fb IF 1 load exit THEN 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 \ \ phz 25aug23 : \ blk @ IF >in @ negate c/l mod >in +! ELSE #tib @ >in ! THEN ; immediate \ : \needs have 0=exit \ blk @ IF >in @ negate c/l mod >in +! \ ELSE #tib @ >in ! THEN ; \ No newline at end of file +\ 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 ; \ 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 \ fib /fib #fib eolf? phz 07mai23 context @ dos also context ! $50 constant /tib variable tibeof tibeof off $1a constant ctrl-z : 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 ctrl-z = IF tibeof on 1 ELSE -1 THEN ; \ incfile incpos inc-fgetc phz 25aug23 variable incfile variable incpos 2 allot create rec-offset 1 allot $80 constant dmabuf : inc-readrec ( -- f ) 0 rec-offset c! dmabuf dma! incfile @ drive iread-seq ; : inc-fgetc ( -- c ) rec-offset c@ b/rec u< 0= IF inc-readrec IF ctrl-z exit THEN THEN rec-offset c@ dup 1+ rec-offset c! dmabuf + c@ ; \ freadline probe-for-fb phz 06okt22 : 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 name has no .FTH extension isfile@ extension dup @ $dfdf and $5446 = swap 2+ c@ $df and $48 = and not ; \ save/restoretib phz 06okt22 $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 ; \ interpret-via-tib include phz 07mai23 : interpret-via-tib BEGIN freadline >r .status >in off interpret r> UNTIL ; : pushfile r> isfile push fromfile push >r ; restrict : include ( -- ) pushfile use cr file? probe-for-fb IF 1 load exit THEN 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 \ \ phz 25aug23 : \ blk @ IF >in @ negate c/l mod >in +! ELSE #tib @ >in ! THEN ; immediate \ : \needs have 0=exit \ blk @ IF >in @ negate c/l mod >in +! \ ELSE #tib @ >in ! THEN ; \ No newline at end of file diff --git a/8080/CPM/src/include.fth b/8080/CPM/src/include.fth index 22d0bf9..379f197 100644 --- a/8080/CPM/src/include.fth +++ b/8080/CPM/src/include.fth @@ -58,22 +58,22 @@ \ *** Block No. 3, Hexblock 3 -\ incfile incpos inc-fgetc phz 07mai23 +\ incfile incpos inc-fgetc phz 25aug23 variable incfile variable incpos 2 allot create rec-offset 1 allot $80 constant dmabuf + : inc-readrec ( -- f ) + 0 rec-offset c! dmabuf dma! + incfile @ drive iread-seq ; + : inc-fgetc ( -- c ) - rec-offset c@ b/rec u< 0= IF dmabuf dma! - incfile @ drive iread-seq IF ctrl-z 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! ; + rec-offset c@ b/rec u< 0= + IF inc-readrec IF ctrl-z exit THEN THEN + rec-offset c@ dup 1+ rec-offset c! dmabuf + c@ ; + + \ *** Block No. 4, Hexblock 4