From 164f12be49308c157a56a3bafdff3362cb90bdd2 Mon Sep 17 00:00:00 2001 From: Philip Zembrod Date: Sun, 7 May 2023 12:54:14 +0200 Subject: [PATCH] Use the real interpret in include, and overwrite the original include --- 8080/CPM/Makefile | 2 +- 8080/CPM/include.fb | 2 +- 8080/CPM/include.fth | 12 ++++++------ 8080/CPM/inctest.fth | 6 +----- 4 files changed, 9 insertions(+), 13 deletions(-) diff --git a/8080/CPM/Makefile b/8080/CPM/Makefile index bc2ccea..6336085 100644 --- a/8080/CPM/Makefile +++ b/8080/CPM/Makefile @@ -27,7 +27,7 @@ inctest.log: $(patsubst %, $(cpmfilesdir)/%, \ | emu echo "volks4th" > $(runcpmdir)/input.script echo "include include.fb" >> $(runcpmdir)/input.script - echo "xinclude inctest.fth" >> $(runcpmdir)/input.script + echo "include inctest.fth" >> $(runcpmdir)/input.script echo "bye" >> $(runcpmdir)/input.script echo "exit" >> $(runcpmdir)/input.script ./emulator/run-in-runcpm.sh volks4th diff --git a/8080/CPM/include.fb b/8080/CPM/include.fb index 3740eb1..7cb59be 100644 --- a/8080/CPM/include.fb +++ b/8080/CPM/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 : 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 : xinclude ( -- ) pushfile use cr file? cr 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 05apr22\\ : \ 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 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 05apr22\\ : \ 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/include.fth b/8080/CPM/include.fth index 6da3932..ba5fc3d 100644 --- a/8080/CPM/include.fth +++ b/8080/CPM/include.fth @@ -69,7 +69,7 @@ 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 @@ -116,13 +116,13 @@ \ *** Block No. 6, Hexblock 6 \ interpret-via-tib include phz 07mai23 - : xinterpret tib #tib @ type cr ; + : interpret-via-tib - BEGIN freadline >r .status >in off xinterpret - r> UNTIL ; + BEGIN freadline >r .status >in off interpret r> UNTIL ; + : pushfile r> isfile push fromfile push >r ; restrict - : xinclude ( -- ) - pushfile use cr file? cr + : 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 diff --git a/8080/CPM/inctest.fth b/8080/CPM/inctest.fth index 6133107..4d2d608 100644 --- a/8080/CPM/inctest.fth +++ b/8080/CPM/inctest.fth @@ -1,5 +1 @@ -0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcde -@123456789ABCDEF0123456789abcdef0123456789abcdef0123456789abcde -A123456789abcdef0123456789abcdef0123456789abcdef0123456789abcde -B123456789ABCDEF0123456789abcdef0123456789abcdef0123456789abcde -abc + .( included from stream file: "1 2 + 4 * .": ) 1 2 + 4 * . cr