diff --git a/8080/CPM/Makefile b/8080/CPM/Makefile index 6380484..c56019a 100644 --- a/8080/CPM/Makefile +++ b/8080/CPM/Makefile @@ -73,7 +73,7 @@ test-std.log: \ $(patsubst tests/%, $(cpmfilesdir)/%, tests/ans-shim.fth) \ $(patsubst tests/%, $(cpmfilesdir)/%, tests/prelim.fth) \ $(patsubst tests/%, $(cpmfilesdir)/%, tests/tester.fth) \ - $(patsubst tests/%, $(cpmfilesdir)/%, tests/core.fth) \ + $(patsubst tests/%, $(cpmfilesdir)/%, tests/core.fr) \ | emu ./emulator/run-in-runcpm.sh \ "volks4th" \ @@ -84,15 +84,12 @@ test-std.log: \ ": \\vf [compile] \\ ; immediate" \ "include prelim.fth" \ "include tester.fth" \ - "include core.fth" \ + "include core.fr" \ "logclose" \ "bye" \ "exit" dos2unix -n $(runcpmdir)/logfile.txt $@ -tests/core.fth: tests/core.fr - cp -p $< $@ - emu: $(runcpmdir)/RunCPM %.golden: tests/golden/%.golden diff --git a/8080/CPM/src/include.fb b/8080/CPM/src/include.fb index 3a0b822..535233a 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 25aug23 variable incfile variable incpos 2 allot create rec-offset 1 allot $80 constant dmabuf : readrec ( fcb -- f ) 0 rec-offset c! dmabuf dma! drive iread-seq ; : inc-fgetc ( -- c ) rec-offset c@ b/rec u< 0= IF incfile @ 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 25aug23 : 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? 0 isfile@ record 1- c! isfile@ readrec IF close exit THEN probe-for-fb IF 1 load 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 \ \ 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 | $ff constant dmabuf-last : readrec ( fcb -- f ) 0 rec-offset c! dmabuf dma! drive iread-seq ; : inc-fgetc ( -- c ) rec-offset c@ b/rec u< 0= IF incfile @ readrec IF ctrl-z exit THEN THEN rec-offset c@ dup 1+ rec-offset c! dmabuf + c@ ; \ freadline probe-for-fb phz 25aug23 : 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 ) dmabuf BEGIN dup c@ #lf = IF drop 0 exit THEN 1+ dup dmabuf-last u> UNTIL drop 1 ; \ 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 25aug23 : 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? 0 isfile@ record 1- c! isfile@ readrec IF close exit THEN probe-for-fb IF 1 load 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 \ \ 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 0e6ffc7..cc11a20 100644 --- a/8080/CPM/src/include.fth +++ b/8080/CPM/src/include.fth @@ -62,7 +62,8 @@ variable incfile variable incpos 2 allot - create rec-offset 1 allot $80 constant dmabuf + create rec-offset 1 allot + $80 constant dmabuf | $ff constant dmabuf-last : readrec ( fcb -- f ) 0 rec-offset c! dmabuf dma! drive iread-seq ; @@ -74,10 +75,9 @@ - \ *** Block No. 4, Hexblock 4 -\ freadline probe-for-fb phz 06okt22 +\ freadline probe-for-fb phz 25aug23 : freadline ( -- eof ) tib /tib bounds DO @@ -89,9 +89,9 @@ 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 ; + dmabuf BEGIN dup c@ #lf = IF drop 0 exit THEN + 1+ dup dmabuf-last u> UNTIL drop 1 ; + \ *** Block No. 5, Hexblock 5 diff --git a/8080/CPM/tests/golden/test-std.golden b/8080/CPM/tests/golden/test-std.golden index 9d7cf68..e36d208 100644 --- a/8080/CPM/tests/golden/test-std.golden +++ b/8080/CPM/tests/golden/test-std.golden @@ -45,8 +45,8 @@ and no error messages ok include tester.fth TESTER.FTH ERROR exists ok -include core.fth -CORE.FTH +include core.fr +CORE.FR *********************YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS: !"#$%&'()*+,-./0123456789:;<=>?@ ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`