Merge pull request #54 from pzembrod/cpm-msdos-cleanup

Cpm msdos cleanup

6502/C64/Makefile

@@ -31,11 +31,12 @@ update: $(vf_blk_fth_files) $(vf_fth_files_petscii)
 
 
 clean:
-	rm -f cbmfiles/*.fr cbmfiles/*.fth cbmfiles/*.log
+	rm -f cbmfiles/*.fr cbmfiles/*.fth cbmfiles/*.log tmp/*
 	rm -rf tmp/* release
 	rm -f *.log *.result *.golden
 	rm -f cbmfiles/c??-testbase
 	rm -f disks/scratch.d64 emulator/sdcard.img
+	rm -f cbmfiles/tcbase16
 	rm -f tests/golden/mycore*.golden
 
 
@@ -138,6 +139,18 @@ cbmfiles/v4th-x16e:
 	emulator/build-vf.sh v4th-x16e
 
 
+# Proof-of-concept self-hosted C16 target compile
+
+cbmfiles/tcbase16: emulator/v4thblk-c16+.T64 emulator/build-tcbase.sh \
+    disks/tc38q.d64 disks/file-words.d64 cbmfiles/tc-base.fth
+	VICE=xplus4 TCVF=v4thblk-c16+ TCBASE=tcbase16 emulator/build-tcbase.sh
+
+cbmfiles/v4th-c16+self: emulator/tcbase16.T64
+	VICE=xplus4 TCBASE=tcbase16 emulator/build-vf.sh v4th-c16+
+	rm -f $@
+	cp cbmfiles/v4th-c16+ $@
+
+
 # Core test targets
 
 $(test_logs): $(test_files_petscii) $(wildcard emulator/run-in-*.sh)

6502/C64/emulator/build-tcbase.sh

@@ -4,14 +4,17 @@
 
 set -e
 
+test -n "${TCVF}" || TCVF="v4th-c64-4tc"
+test -n "${TCBASE}" || TCBASE="tcbase"
+
 emulatordir="$(dirname "${BASH_SOURCE[0]}")"
 basedir="$(realpath --relative-to="$PWD" "${emulatordir}/..")"
 
-rm -f "${basedir}/cbmfiles/tcbase"
+rm -f "${basedir}/cbmfiles/${TCBASE}"
 
 keybuf="3 drive 20 load\n3 drive 10 load\nsave\n\
 2 drive 4 load\ninclude tc-base.fth\n\
-savesystem tcbase\ndos s0:notdone"
+savesystem ${TCBASE}\ndos s0:notdone"
 
 DISK10=tc38q DISK11=file-words "${emulatordir}/run-in-vice.sh" \
-  "v4th-c64-4tc" "${keybuf}"
+  "${TCVF}" "${keybuf}"

6502/C64/emulator/build-vf.sh

@@ -7,6 +7,8 @@
 
 set -e
 
+test -n "${TCBASE}" || TCBASE="tcbase"
+
 emulatordir="$(dirname "${BASH_SOURCE[0]}")"
 basedir="$(realpath --relative-to="$PWD" "${emulatordir}/..")"
 
@@ -22,7 +24,7 @@ keybuf="include ${source}\nsave-target ${target}\ndos s0:notdone"
 test -n "${nosave}" && keybuf="include ${source}\n"
 
 DISK10=tc38q "${emulatordir}/run-in-vice.sh" \
-  "tcbase" "${keybuf}"
+  "${TCBASE}" "${keybuf}"
 
 petscii2ascii "${basedir}/cbmfiles/${logfile}" | \
   grep -F 'target compile complete' || \

8080/CPM/Makefile

@@ -0,0 +1,258 @@
+
+srcfbfiles = $(wildcard src/*.fb)
+srcfbtxtfiles = $(patsubst src/%.fb, src/%.fb.txt, $(srcfbfiles))
+testsfbfiles = $(wildcard tests/*.fb)
+testsfbtxtfiles = $(patsubst tests/%.fb, tests/%.fb.txt, $(testsfbfiles))
+fb_txt_files = $(srcfbtxtfiles) $(testsfbtxtfiles)
+
+whitch_runcpm = $(shell which RunCPM)
+runcpmdir = runcpm
+cpmfilesdir = cpmfiles
+
+bin: $(cpmfilesdir)/v4th.com
+
+fb.txt: $(fb_txt_files)
+
+clean:
+	rm -f *.log *.golden *.result
+	rm -rf $(runcpmdir)
+	rm -f msdos
+	rm -f $(cpmfilesdir)/empty.f*
+
+veryclean: clean
+	rm -rf $(cpmfilesdir)
+
+test: test-min.result test-std.result test-blk.result
+
+alltests: test-min.result test-std.result test-blk.result \
+    logtest.result inctest.result test-kernel.result
+
+run-editor: | msdos
+	FORTHPATH="f:\\src;f:\\tests;f:\\msdos" \
+	../../8086/msdos/emulator/run-in-dosbox.sh f:\\msdos\\volks4th.com
+
+msdos:
+	ln -s ../../8086/msdos msdos
+
+$(srcfbtxtfiles): src/%.fb.txt: src/%.fb ../../tools/fb2fth.py
+	../../tools/fb2fth.py $< $@
+
+$(testsfbtxtfiles): tests/%.fb.txt: tests/%.fb ../../tools/fb2fth.py
+	../../tools/fb2fth.py $< $@
+
+run-volks4th: \
+    $(patsubst %, $(cpmfilesdir)/%, volks4th.com) \
+    | emu
+	./emulator/run-in-runcpm.sh \
+	    "volks4th"
+
+logtest.log: \
+    $(patsubst %, $(cpmfilesdir)/%, kernel.com fileint.fb log2file.fb) \
+    | emu
+	./emulator/run-in-runcpm.sh \
+	    "kernel fileint.fb" \
+	    "1 load onlyforth" \
+	    "include log2file.fb" \
+	    "logopen" \
+	    ".( hello world) cr" \
+	    ".( 0123456789abcdef0123456789abcdef) cr" \
+	    ".( 1123456789abcdef0123456789abcdef) cr" \
+	    ".( 2123456789abcdef0123456789abcdef) cr" \
+	    ".( 3123456789abcdef0123456789abcdef) cr" \
+	    "logclose" \
+	    "bye" \
+	    "exit"
+	dos2unix -n $(runcpmdir)/logfile.txt $@
+
+inctest.log: \
+    $(patsubst %, $(cpmfilesdir)/%, kernel.com fileint.fb \
+    include.fb log2file.fb inctest.fs) \
+    | emu
+	./emulator/run-in-runcpm.sh \
+	    "kernel fileint.fb" \
+	    "1 load onlyforth" \
+	    "$50 constant /tib" \
+	    "include include.fb" \
+	    "include log2file.fb" \
+	    "logopen" \
+	    "include inctest.fs" \
+	    "logclose" \
+	    "bye" \
+	    "exit"
+	dos2unix -n $(runcpmdir)/logfile.txt $@
+
+$(cpmfilesdir)/tc-base.com: \
+$(patsubst %, $(cpmfilesdir)/%, v4th-4tc.com \
+    fileint.fb ass8080.fb include.fb log2file.fb xinout.fb savesys.fb) \
+    Makefile | emu
+	rm -f $(runcpmdir)/A/0/TC-BASE.COM $@
+	./emulator/run-in-runcpm.sh \
+	    "v4th-4tc fileint.fb" \
+	    "1 load" \
+	    "include log2file.fb" \
+	    "logopen" \
+	    "include ass8080.fb" \
+	    ".( include xinout.fb) cr" \
+	    "include savesys.fb" \
+	    "$50 constant /tib" \
+	    "include include.fb" \
+	    "cr   decimal   caps on" \
+	    "scr off  r# off     savesystem tc-base.com" \
+	    "logclose" \
+	    "bye" \
+	    "exit"
+	dos2unix -n $(runcpmdir)/logfile.txt $@.log
+	cp -f $(runcpmdir)/A/0/TC-BASE.COM $@
+
+$(cpmfilesdir)/tc-base2.com: \
+$(patsubst %, $(cpmfilesdir)/%, v4thblk.com sfileint.fs \
+    ass8080.fb include.fb log2file.fb xinout.fb savesys.fb) \
+    Makefile | emu
+	rm -f $(runcpmdir)/A/0/TC-BASE.COM $@
+	./emulator/run-in-runcpm.sh \
+	    "v4thblk sfileint.fs" \
+	    "include-isfile" \
+	    "include log2file.fb" \
+	    "logopen" \
+	    "include ass8080.fb" \
+	    ".( include xinout.fb) cr" \
+	    "include savesys.fb" \
+	    "cr   decimal   caps on" \
+	    "scr off  r# off     savesystem tc-base.com" \
+	    "logclose" \
+	    "bye" \
+	    "exit"
+	dos2unix -n $(runcpmdir)/logfile.txt $@.log
+	cp -f $(runcpmdir)/A/0/TC-BASE.COM $@
+
+$(cpmfilesdir)/v4th.com: \
+    $(patsubst %, $(cpmfilesdir)/%, tc-base.com \
+    target.fb v4th.fs vf-core.fs vf-file.fs \
+    vf-io.fs vf-sys.fs vf-end.fs vf-bdos.fs) \
+    Makefile | emu
+	rm -f $(runcpmdir)/A/0/V4TH.COM $(runcpmdir)/A/0/LOGFILE.TXT $@
+	./emulator/run-in-runcpm.sh \
+	    "tc-base" \
+	    "logopen" \
+	    "include target.fb" \
+	    "include v4th.fs" \
+	    "logclose" \
+	    "bye" \
+	    "exit"
+	dos2unix -n $(runcpmdir)/logfile.txt $@.log
+	cp -f $(runcpmdir)/A/0/V4TH.COM $@
+
+$(cpmfilesdir)/v4thblk.com: \
+    $(patsubst %, $(cpmfilesdir)/%, tc-base.com \
+    target.fb v4thblk.fs vf-core.fs vf-file.fs \
+    vf-io.fs vf-bufs.fs vf-sys.fs vf-end.fs vf-bdos.fs) \
+    Makefile | emu
+	rm -f $(runcpmdir)/A/0/V4THBLK.COM $(runcpmdir)/A/0/LOGFILE.TXT $@
+	./emulator/run-in-runcpm.sh \
+	    "tc-base" \
+	    "logopen" \
+	    "include target.fb" \
+	    "include v4thblk.fs" \
+	    "logclose" \
+	    "bye" \
+	    "exit"
+	dos2unix -n $(runcpmdir)/logfile.txt $@.log
+	cp -f $(runcpmdir)/A/0/V4THBLK.COM $@
+
+test-kernel.log: \
+    $(patsubst %, $(cpmfilesdir)/%, kernel.com fileint.fb \
+    include.fb log2file.fb core.fs) \
+    $(patsubst tests/%, $(cpmfilesdir)/%, $(wildcard tests/*.fs)) \
+    | emu
+	./emulator/run-in-runcpm.sh \
+	    "kernel fileint.fb" \
+	    "1 load onlyforth" \
+	    "$50 constant /tib" \
+	    "include include.fb" \
+	    "include test-krn.fs" \
+	    "bye" \
+	    "exit"
+	dos2unix -n $(runcpmdir)/logfile.txt $@
+
+test-min.log: \
+    $(patsubst %, $(cpmfilesdir)/%, v4th.com sfileint.fs \
+    logfile.fs \
+    ans-shim.fs prelim.fs tester.fs core.fs test-min.fs) \
+    | emu
+	./emulator/run-in-runcpm.sh \
+	    "v4th sfileint.fs" \
+	    "include-isfile" \
+	    "onlyforth" \
+	    "include test-min.fs" \
+	    "bye" \
+	    "exit"
+	dos2unix -n $(runcpmdir)/logfile.txt $@
+
+test-std.log: \
+    $(patsubst %, $(cpmfilesdir)/%, v4th.com sfileint.fs \
+    logfile.fs core.fs) \
+    $(patsubst tests/%, $(cpmfilesdir)/%, $(wildcard tests/*.fs)) \
+    | emu
+	./emulator/run-in-runcpm.sh \
+	    "v4th sfileint.fs" \
+	    "include-isfile" \
+	    "onlyforth" \
+	    "include test-std.fs" \
+	    "bye" \
+	    "exit"
+	dos2unix -n $(runcpmdir)/logfile.txt $@
+
+test-blk.log: \
+    $(patsubst %, $(cpmfilesdir)/%, v4thblk.com sfileint.fs \
+    sblkint.fs log2file.fb core.fs) \
+    $(patsubst tests/%, $(cpmfilesdir)/%, $(wildcard tests/*.fs) \
+    tests/empty.fb) | emu
+	./emulator/run-in-runcpm.sh \
+	    "v4thblk sfileint.fs" \
+	    "include-isfile" \
+	    "include sblkint.fs" \
+	    "onlyforth" \
+	    "include test-blk.fs" \
+	    "bye" \
+	    "exit"
+	dos2unix -n $(runcpmdir)/logfile.txt $@
+
+emu: $(runcpmdir)/RunCPM
+
+test-min.golden: $(patsubst %, tests/golden/%.golden, prelim core)
+	cat $^ > $@
+
+test-std.golden: $(patsubst %, tests/golden/%.golden, \
+    prelim core coreplus coreext doubltst report-noblk)
+	cat $^ > $@
+
+test-blk.golden: $(patsubst %, tests/golden/%.golden, \
+    prelim core coreplus coreext doubltst block report-blk)
+	cat $^ > $@
+
+test-kernel.golden: $(patsubst %, tests/golden/%.golden, \
+    prelim core coreplus coreext report-nodbl)
+	cat $^ > $@
+
+%.golden: tests/golden/%.golden
+	cp -p $< $@
+
+%.result: %.log %.golden tests/evaluate-test.sh
+	rm -f $@
+	tests/evaluate-test.sh $(basename $@)
+
+$(runcpmdir)/RunCPM: $(whitch_runcpm)
+	test -d $(runcpmdir) || mkdir -p $(runcpmdir)
+	cp $< $@
+
+$(cpmfilesdir)/%: src/%
+	test -d $(cpmfilesdir) || mkdir -p $(cpmfilesdir)
+	cp $< $@
+
+$(cpmfilesdir)/%: tests/%
+	test -d $(cpmfilesdir) || mkdir -p $(cpmfilesdir)
+	cp $< $@
+
+$(cpmfilesdir)/%: %
+	test -d $(cpmfilesdir) || mkdir -p $(cpmfilesdir)
+	cp $< $@

8080/CPM/cpmfiles/ans-shim.fs

@@ -0,0 +1,102 @@
+
+: cells  2* ;
+
+: s"  [compile] " compile count ; immediate restrict
+: c"  [compile] " ; immediate restrict
+
+: [char]  [compile] ascii ; immediate
+: char  [compile] ascii ;
+
+: invert  not ;
+
+: lshift  0 ?DO 2* LOOP ;
+
+: rshift  0 ?DO 2/ 32767 and LOOP ;
+
+\ : 2over  3 pick 3 pick ;
+
+: s>d  extend ;
+
+: fm/mod  m/mod ;
+
+: sm/rem  dup >r  2dup xor >r  m/mod
+    over IF r> 0< IF 1+ swap r> - swap ELSE rdrop THEN
+    ELSE rdrop rdrop THEN ;
+
+: postpone  ' dup >name c@ $40 and
+    IF , ELSE [compile] compile compile , THEN ; immediate
+
+\ : align ;
+: aligned ;
+: cell+  2+ ;
+: char+  1+ ;
+: chars ;
+
+\ : 2@  dup 2+ @ swap @ ;
+\ : 2!  under ! 2+ ! ;
+
+: recurse  last @ name> , ; immediate
+
+' endloop alias unloop
+
+: >number  ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
+ BEGIN  dup 0= IF exit THEN
+ >r  count digit? WHILE accumulate r> 1- REPEAT 1- r> ;
+
+: accept  expect span @ ;
+
+: tuck  under ;
+
+: :noname  here  ['] tuck @ ,  0 ] ;
+
+: <>  = not ;
+
+: 2>r  r> -rot swap >r >r >r ;
+: 2r>  r> r> r> swap rot >r ;
+: 2r@  r> r> r> 2dup >r >r swap rot >r ;
+
+: WITHIN ( test low high -- flag ) OVER - >R - R> U< ;
+
+: unused  sp@ here - ;
+: again  [compile] repeat ; immediate restrict
+
+: BUFFER:  CREATE ALLOT ;
+
+: compile,  , ;
+
+: defer!  >body ! ;
+: defer@  >body @ ;
+: action-of
+ STATE @ IF
+     POSTPONE ['] POSTPONE DEFER@
+   ELSE
+     ' DEFER@
+   THEN ; IMMEDIATE
+
+ : HOLDS ( addr u -- )
+   BEGIN DUP WHILE 1- 2DUP + C@ HOLD REPEAT 2DROP ;
+
+: 2Variable  ( --)   Create 4 allot ;
+             ( -- adr)
+
+: 2Constant  ( d --)   Create , ,
+  Does> ( -- d)   2@ ;
+
+: 2literal  swap [compile] literal [compile] literal ;
+immediate restrict
+
+: d-  dnegate d+ ;
+: d0<  0. d< ;
+: d2*  2dup d+ ;
+: d2/  dup 1 and -rot 2/ >r
+  1 rshift  swap IF $8000 or THEN r> ;
+
+: 2over  3 pick 3 pick ;
+: dmax  2over 2over d< IF 2swap THEN 2drop ;
+: dmin  2over 2over 2swap d< IF 2swap THEN 2drop ;
+
+: d>s  drop ;
+
+: m+  extend d+ ;
+
+: 2rot  5 roll 5 roll ;

8080/CPM/cpmfiles/inctest.fs

@@ -0,0 +1 @@
+ .( included from stream file: "1 2 + 4 * .": ) 1 2 + 4 * . cr

8080/CPM/cpmfiles/logfile.fs

@@ -0,0 +1,50 @@
+
+\ *** Block No. 2, Hexblock 2
+
+\ logfile                                            phz 20aug23
+
+  Dos also Forth definitions
+
+  $18 constant fcb\nam
+  create logfile  ," LOGFILE TXT"  fcb\nam allot  1 logfile c!
+  create logdma  b/rec allot
+  variable logoffset  0 logoffset !
+
+  : logflush  logdma dma!  logfile $15 bdos  $80 dma! ;
+
+  : logc!  ( c -- )
+    logoffset @ dup >r  logdma +  c!  r> 1+
+    dup logoffset !  b/rec =
+      IF logflush  0 logoffset ! THEN ;
+
+
+\ *** Block No. 3, Hexblock 3
+
+\ log-emit log-type log-cr alsologtofile            pphz 03sep23
+
+  : log-emit  ( char -- )
+      dup (emit  logc! ;
+
+  : log-type  ( addr count -- )
+      0 ?DO count log-emit LOOP drop ;
+
+  : log-cr  ( -- )
+      (cr  #cr logc!  #lf logc! ;
+
+Output: alsologtofile
+  log-emit log-cr log-type (del noop 2drop (at? ;
+
+
+\ *** Block No. 4, Hexblock 4
+
+\ logopen                                            phz 20aug23
+
+  : logopen  ( -- )
+      logfile filenamelen + 1+ fcb\nam erase
+      0 logoffset !
+      logfile killfile
+      logfile createfile
+      alsologtofile ;
+
+  : logclose  ( -- )
+      cr display  &26 logc!  logflush  logfile closefile ;

8080/CPM/cpmfiles/sblkint.fs

@@ -0,0 +1,86 @@
+
+Dos definitions
+
+: file-r/w  ( buffer block fcb f  -- f )
+    over 0= Abort" no Direct Disk IO supported! "
+    >r  dup  (open   2dup in-range r> (r/w ;
+
+\ backup was made visible in vf-blk.fth so no need to peek its address
+\ ' (save-buffers >body $0C + @ | Alias backup
+
+| : filebuffer?  ( fcb -- fcb bufaddr/flag )
+   prev  BEGIN @ dup WHILE  2dup 2+ @ = UNTIL ;
+
+| : (flushfile  ( fcb -- )  \ flush file buffers
+     BEGIN  filebuffer?  ?dup  WHILE
+            dup backup  emptybuf  REPEAT  drop ;
+
+' (flushfile is flushfile
+
+Forth definitions
+
+: list  ( n -- )   3 spaces  file? list ;
+
+\ *** Block No. 15, Hexblock f
+
+\ words for viewing                                   UH 10Oct87
+
+Forth definitions
+
+| $200 Constant viewoffset \ max. %512 kB files
+
+: (makeview  ( -- n )  \ calc. view filed for a name
+   blk @ dup  0= ?exit
+   loadfile @ ?dup IF fileno @ viewoffset * + THEN ;
+
+: (view      ( blk -- blk' ) \ select file and leave block
+   dup 0=exit
+   viewoffset u/mod  file-link
+   BEGIN @ dup WHILE 2dup fileno @ = UNTIL
+   !files drop ;        \ not found: direct access
+
+
+\ *** Block No. 17, Hexblock 11
+
+\ print a list of all buffers                         UH 20Oct86
+
+: .buffers
+   prev BEGIN  @ ?dup WHILE  stop? abort" stopped"
+           cr dup u. dup 2+ @ dup 1+
+           IF ."    Block: " over 4+ @ 5 .r
+              ."    File : " [ Dos ] .file
+              dup 6 + @ 0< IF ."     updated" THEN
+           ELSE ." Buffer empty" drop THEN  REPEAT ;
+
+
+
+
+
+
+
+
+: loadfrom     ( n -- )
+               isfile push  fromfile push  use load   close ;
+
+| : addblock  ( n -- )  \ add block n to file
+     dup buffer under   b/blk  bl fill
+     isfile@   rec/blk  over filesize +!  false file-r/w
+     IF close Abort" disk full!" THEN ;
+
+: more ( n -- )   open >fileend
+   capacity swap bounds  ?DO I addblock LOOP close
+   open close ;
+
+\ *** Block No. 22, Hexblock 16
+
+\ Status                                              UH 10OCt87
+
+
+: .blk ( -- )   blk @ ?dup 0=exit
+   dup 1 = IF cr file? THEN base push hex ."  Blk " . ?cr ;
+
+' .blk Is .status
+
+' (makeview     Is makeview
+' file-r/w      Is r/w
+

8080/CPM/cpmfiles/sfileint.fs

@@ -0,0 +1,334 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\ CP/M 2.2 File-Interface (3.80a)                     UH 05Oct87
+
+\ Dieses File enthaelt das File-Interface von volksFORTH zu CP/M.
+\ Damit ist Zugriff auf normale CP/M-Files moeglich.
+\ Wenn ein File mit USE benutzt wird, beziehen sich alle Worte,
+\ die mit dem Massenspeicher arbeiten, auf dieses File.
+
+\ Benutzung:
+\   USE <name>       \ benutze ein schon existierendes File
+\   FILE <name>      \ erzeuge ein Forthfile mit dem Namen <name>.
+\   MAKE <name>      \ Erzeuge ein File mit <name> und ordne
+\                   \ es dem aktuellen Forthfile zu.
+\   MAKEFILE <name>  \ Erzeuge ein File mit CP/M und FORTH-Namen
+\                      <name>.
+\   INCLUDE <name>   \ Lade File mit Forthnamen <name> ab Screen 1
+\   DOS RESET        \ zum Wechsel von Disketten. (Oh! CP/M)
+
+\ *** Block No. 1, Hexblock 1
+
+\ CP/M 2.2 File-Interface  load-Screen                UH 18Feb88
+OnlyForth
+
+\       2 load \ view numbers for this file
+\   3   4 thru \ DOS   File Functions
+\   5 $11 thru \ Forth File Functions
+\ $12 $16 thru \ User Interface
+
+\ File source.fb      \  Define already existing Files
+\ File fileint.fb     File startup.fbr
+
+\ ' (makeview     Is makeview
+\ ' remove-files  Is custom-remove
+\ ' file-r/w      Is r/w
+\ ' noop          Is drvinit
+ \      include startup.fb \ load Standard System
+
+\ *** Block No. 3, Hexblock 3
+
+\ File Control Blocks                                 UH 18Feb88
+Dos definitions also
+| : Fcbyte ( n len -- len' )  Create over c, + does> c@ + ;
+&11 Constant filenamelen
+0              2 | Fcbyte nextfile  immediate
+               1   Fcbyte drive    ' drive | Alias >dosfcb
+ filenamelen 3 -   Fcbyte filename
+               3   Fcbyte extension
+           &21 + \ ex, s1, s2, rc, d0, ... dn, cr
+               2   Fcbyte record    \  r0, r1
+              1+ \ r2
+               2   Fcbyte opened
+               2   Fcbyte fileno
+               2   Fcbyte filesize  \ in 128-Byte-Records
+               4   Fcbyte position
+Constant b/fcb
+
+\ *** Block No. 4, Hexblock 4
+
+\ dos primitives                                      UH 10Oct87
+
+' 2-  | Alias body>             ' 2- | Alias dosfcb>
+
+: drive!     ( drv    --      )     $0E bdos ;
+: search0    ( dosfcb -- dir  )     $11 bdosa ;
+: searchnext ( dosfcb -- dir  )     $12 bdosa ;
+: createfile ( dosfcb -- f    )     $16 bdosa dos-error? ;
+: size       ( dos    -- size ) dup $23 bdos dosfcb> record @ ;
+: drive@     (        -- drv  )   0 $19 bdosa ;
+: killfile   ( dosfcb --      )     $13 bdos ;
+
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ File sizes                                          UH 05Oct87
+
+: (capacity  ( fcb -- n )  \ filecapacity in blocks
+    filesize @  rec/blk  u/mod swap 0= ?exit 1+ ;
+
+: in-range ( block fcb -- )
+    (capacity u< not Abort" beyond capacity!" ;
+
+Forth definitions
+
+: capacity ( -- n )    isfile@  (capacity ;
+
+Dos definitions
+
+\ *** Block No. 6, Hexblock 6
+
+\ (open                                               UH 18Feb88
+
+: (open  ( fcb -- )
+    dup opened @ IF drop exit THEN   dup position  0. rot 2!
+    dup >dosfcb openfile  Abort" not found!"  dup opened on
+    dup >dosfcb size  swap filesize ! ;
+
+: (make  ( fcb -- )
+   dup >dosfcb killfile
+   dup >dosfcb createfile Abort" directory full!"
+   dup position 0. rot 2!
+   dup filesize off   opened on  offset off ;
+
+\ *** Block No. 7, Hexblock 7
+
+\ Print Filenames                                     UH 10Oct87
+
+: .file ( fcb -- ) 0 case? IF ." DIRECT"  exit THEN
+         fcb dosfcb> case? IF ." DEFAULT" exit THEN
+         body> >name .name ;
+
+: .drive   ( fcb -- ) drive c@ ?dup 0=exit
+     [ Ascii A 1- ] Literal + emit  Ascii : emit ;
+
+: .dosfile ( fcb -- )  dup filename  8 -trailing type
+    Ascii . emit           extension 3           type ;
+
+
+
+
+
+
+\ *** Block No. 8, Hexblock 8
+
+\ Print Filenames                                     UH 10Oct87
+
+: tab ( -- ) col &59 > IF cr exit THEN
+        &20  col &20 mod  -  0 max  spaces ;
+
+: .fcb  ( fcb -- )  dup fileno @  3 u.r tab
+     dup .file tab dup .drive dup .dosfile
+     tab dup opened @ IF ." opened" ELSE ." closed" THEN
+     3 spaces  base push  decimal   (capacity  3 u.r  ."  kB" ;
+
+
+
+
+
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+\ Filenames                                           UH 05Oct87
+
+: !name ( addr len fcb -- )
+     dup >r filename filenamelen bl fill
+     over 1+ c@  Ascii : =
+     IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r>
+     ELSE 0 THEN  r@ drive c! r> dup filename 2swap
+     filenamelen 1+ min bounds
+     ?DO  I c@ Ascii . =
+         IF drop dup  extension ELSE  I c@ over c! 1+ THEN
+     LOOP 2drop ;
+
+: !fcb  ( fcb -- )  dup opened off   name count rot !name ;
+
+
+
+
+\ *** Block No. 10, Hexblock a
+
+\ Print Directory                                     UH 18Nov87
+
+| Create dirbuf  b/rec allot    dirbuf b/rec erase
+| Create fcb0    b/fcb allot    fcb0   b/fcb erase
+
+| : wildchard?  ( f c -- f' )  Ascii * = IF drop Ascii ? THEN ;
+| : (expand ( addr len -- )  false -rot bounds
+     ?DO  I c@  wildchard? dup ?dup IF I c! THEN  LOOP drop ;
+| : expand ( fcb -- )  \ expand * to ???
+     dup filename 8 (expand   extension 3 (expand ;
+
+: (dir  ( addr len -- )
+    fcb0 !name fcb0 expand  dirbuf dma!  fcb0 >dosfcb search0
+    BEGIN dup dos-error? not
+    WHILE  $20 * dirbuf + dosfcb> tab .dosfile
+           fcb0 >dosfcb searchnext  stop? UNTIL  drop ;
+
+\ *** Block No. 11, Hexblock b
+
+\ File List                                           UH 10Oct87
+
+User file-link   file-link off
+
+| : #file ( -- n )   file-link @ dup IF fileno c@ THEN 1+ ;
+
+
+Forth definitions
+
+: forthfiles ( -- )
+   file-link @
+   BEGIN dup WHILE  cr  dup .fcb  @ stop? UNTIL drop ;
+
+Dos definitions
+
+
+
+\ *** Block No. 12, Hexblock c
+
+\ Close a file                                        UH 10Oct87
+
+Defer flushfile  ' noop is flushfile
+
+: (close  ( fcb -- )  \ close file in fcb
+   dup flushfile
+   dup opened  dup @ 0= IF 2drop exit THEN  off
+   >dosfcb closefile Abort" not found!" ;
+
+
+\ *** Block No. 13, Hexblock d
+
+\ Create fcbs                                         UH 10Oct87
+
+: !files ( fcb -- )  dup  isfile ! fromfile ! ;
+
+' r@ | Alias newfcb
+
+Forth definitions
+
+: File  ( -- )
+   Create here >r   b/fcb allot  newfcb b/fcb erase
+          last @ count $1F and  newfcb !name
+          #file   newfcb fileno !
+          file-link @  newfcb nextfile !   r> file-link !
+   Does> !files ;
+
+: direct     0 !files ;
+
+\ *** Block No. 14, Hexblock e
+
+\ flush buffers & misc.                  UH 10Oct87   UH 28Nov87
+Dos definitions
+
+: save-files  ( -- )  file-link BEGIN  @ ?dup  WHILE
+     dup opened @ IF dup >dosfcb closefile drop THEN  REPEAT ;
+
+' save-files Is save-dos-buffers
+
+\ : close-files  ( -- )  file-link
+\     BEGIN  @ ?dup  WHILE  dup (close  REPEAT ;
+
+Forth definitions
+
+: file?   isfile@ .file ;  \ print current file
+
+\ *** Block No. 16, Hexblock 10
+
+\ FORGETing files                                     UH 10Oct87
+
+| : remove?      ( dic symb addr -- dic symb addr f )
+     dup heap? IF  2dup u> exit THEN 2 pick over 1+ u< ;
+
+
+| : remove-files ( dic symb -- dic symb )  \ flush files !
+     isfile@      remove? nip  IF direct       THEN
+     fromfile @   remove? nip  IF fromfile off THEN
+     file-link
+     BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT
+     file-link remove ;
+
+
+
+
+
+\ *** Block No. 18, Hexblock 12
+
+\ File Interface User words                           UH 11Oct87
+
+| : same ( addr -- )  >in ! ;
+: open      isfile@ (open   offset off ;
+: close     isfile@ (close ;
+: assign    close   isfile@ !fcb  open ;
+: make      isfile@ dup !fcb   (make ;
+
+| : isfile?  ( addr -- addr f )    \ is adr a fcb?
+  file-link BEGIN  @ dup 0=exit 2dup body> = UNTIL drop true ;
+
+: use       >in @ name find \ create a fcb if not present
+            IF isfile? IF execute drop  exit THEN THEN drop
+            dup same File   same ' execute  open ;
+
+
+
+\ *** Block No. 19, Hexblock 13
+
+\ File Interface User words                           UH 25May88
+
+: makefile     >in @   File  dup  same ' execute  same make ;
+: emptyfile    isfile@ >dosfcb createfile ;
+
+: from         isfile push use ;
+
+: include ( -- )
+  increc-offset push  isfile push  fromfile push
+  use  cr file?
+  include-isfile
+  incfile @
+    IF increc @ incfile @ cr+ex!
+    incfile @ increadrec Abort" error re-reading after include"
+    THEN ;
+
+: eof ( -- f ) isfile@  dup filesize @ swap record @ = ;
+
+: files        " *.*" count (dir ;
+: files"       Ascii " word count 2dup upper (dir ;
+
+' files Alias dir     ' files" Alias dir"
+
+\ *** Block No. 20, Hexblock 14
+
+\ extend Files                                        UH 20Nov87
+
+| : >fileend   isfile@ >dosfcb size drop ;
+
+: Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ;
+0   Drive: a:   Drive: b:   Drive: c:   Drive: d:
+5 + Drive: j:  drop
+
+\ *** Block No. 21, Hexblock 15
+
+\ save memory-image as disk-file                      UH 29Nov86
+
+Forth definitions
+
+: savefile ( from count -- ) \ filename
+   isfile push  makefile bounds
+   ?DO I dma!  isfile@ >dosfcb write-seq  Abort" disk full!"
+       b/rec +LOOP  close ;
+
+' remove-files  Is custom-remove
+' noop          Is drvinit

8080/CPM/cpmfiles/test-blk.fs

@@ -0,0 +1,26 @@
+
+include log2file.fb  \ so that include with block file gets tested
+' noop Is .status
+logopen
+
+include ans-shim.fs
+: \vf  [compile] \ ; immediate
+
+include prelim.fs
+include tester.fs
+\ 1 verbose !
+include core.fs
+include coreplus.fs
+
+include util.fs
+include errorrep.fs
+
+include coreext.fs
+include doubltst.fs
+
+include block.fs
+
+REPORT-ERRORS
+
+logclose
+

8080/CPM/cpmfiles/test-krn.fs

@@ -0,0 +1,22 @@
+
+include log2file.fb
+logopen
+
+include ans-shim.fs
+: \vf  [compile] \ ; immediate
+
+include prelim.fs
+include tester.fs
+
+\ 1 verbose !
+include core.fs
+include coreplus.fs
+
+include util.fs
+include errorrep.fs
+
+include coreext.fs
+
+REPORT-ERRORS
+
+logclose

8080/CPM/cpmfiles/test-min.fs

@@ -0,0 +1,14 @@
+
+include logfile.fs
+logopen
+
+include ans-shim.fs
+: \vf  [compile] \ ; immediate
+
+include prelim.fs
+include tester.fs
+
+\ 1 verbose !
+include core.fs
+
+logclose

8080/CPM/cpmfiles/test-std.fs

@@ -0,0 +1,29 @@
+
+\ : .blk|tib
+\     blk @ ?dup IF  ."  Blk " u. ?cr  exit THEN
+\     incfile @ IF tib #tib @ cr type THEN ;
+
+include logfile.fs
+logopen
+
+include ans-shim.fs
+: \vf  [compile] \ ; immediate
+
+include prelim.fs
+include tester.fs
+\ 1 verbose !
+include core.fs
+include coreplus.fs
+
+include util.fs
+include errorrep.fs
+
+include coreext.fs
+
+\ ' .blk|tib Is .status
+
+include doubltst.fs
+
+REPORT-ERRORS
+
+logclose

8080/CPM/cpmfiles/v4th.fs

@@ -0,0 +1,24 @@
+
+Onlyforth
+
+: .pagestatus  ( n -- )
+  cr ." page " .
+  ." here "  here u.
+  ." there " there u.
+  ." displaced there " there displace @ + u.
+  ." heap "  heap u.  cr
+;
+
+    $8000 displace !
+Target definitions   $100 here!
+
+  include vf-core.fs
+  include vf-io.fs
+  include vf-sys.fs
+  include vf-bdos.fs
+  include vf-file.fs
+  include vf-end.fs
+
+cr .( unresolved: )  .unresolved   ( ' .blk is .status )
+
+save-target  V4TH.COM

8080/CPM/cpmfiles/v4thblk.fs

@@ -0,0 +1,26 @@
+
+Onlyforth
+
+: .pagestatus  ( n -- )
+  cr ." page " .
+  ." here "  here u.
+  ." there " there u.
+  ." displaced there " there displace @ + u.
+  ." heap "  heap u.  cr
+;
+
+    $8000 displace !
+
+Target definitions   $100 here!
+
+  include vf-core.fs
+  include vf-io.fs
+  include vf-sys.fs
+  include vf-bdos.fs
+  include vf-file.fs
+  include vf-bufs.fs
+  include vf-end.fs
+
+cr .( unresolved: )  .unresolved   ( ' .blk is .status )
+
+save-target  V4THBLK.COM

8080/CPM/cpmfiles/vf-bdos.fs

@@ -0,0 +1,137 @@
+\ *** Block No. 119, Hexblock 77
+
+\ CP/M-Interface                                         05Oct87
+Vocabulary Dos    Dos definitions  also
+Label >bios   pchl
+Code biosa ( arg fun -- res )
+   1 lhld   D pop   D dcx   D dad   D dad   D dad
+   D pop   IP push   D IP mvx   >bios call
+Label back
+   IP pop   0 H mvi   A L mov   Hpush jmp   end-code
+
+Code bdosa ( arg fun -- res )
+   H pop   D pop   IP push   L C mov   5 call  back jmp
+end-code
+
+: bios ( arg fun -- ) biosa drop ;
+: bdos ( arg fun -- ) bdosa drop ;
+
+
+\ *** Block No. 120, Hexblock 78
+
+\ Character-IO Constants  Character input                05Oct87
+
+Target Dos also
+
+$08 Constant #bs         $0D Constant #cr
+$0A Constant #lf         $1B Constant #esc
+$09 Constant #tab        $7F Constant #del
+$07 Constant #bel        $0C Constant #ff
+
+: con!   ( c -- )     4 bios ;
+: (key?  ( -- ? )   0 2 biosa 0= not ;
+: getkey ( -- c )   0 3 biosa ;
+
+: (key   ( -- c )   BEGIN  pause (key?  UNTIL getkey ;
+
+
+
+\ *** Block No. 121, Hexblock 79
+
+\ Character output                           07Oct87  UH 27Feb88
+
+| Code ?ctrl ( c -- c' )  H pop   L A mov
+    $20 cpi  cs ?[ $80 ori ]?   A L mov   Hpush jmp   end-code
+
+: (emit ( c -- )  ?ctrl  con!  pause ;
+
+: (cr     #cr con!  #lf con! ;
+: (del    #bs con!  bl  con!  #bs con! ;
+: (at? ( -- row col )  0 0 ;
+
+: tipp ( addr len -- )   0 ?DO count emit LOOP drop ;
+
+Output: display    [ here output ! ]
+   (emit (cr tipp (del noop 2drop (at? ;
+
+
+\ *** Block No. 122, Hexblock 7a
+
+\ Line input                                             04Oct87
+
+| : backspace ( addr pos1 -- addr pos2 ) dup 0=exit (del 1- ;
+
+: (decode ( addr pos1 key -- addr pos2 )
+     #bs  case? IF backspace         exit THEN
+     #del case? IF backspace         exit THEN
+     #cr  case? IF dup span !  space exit THEN
+     dup emit >r  2dup +  r> swap c!  1+ ;
+
+: (expect   ( addr len -- )  span ! 0
+    BEGIN  span @ over u>  WHILE  key decode  REPEAT  2drop ;
+
+Input:  keyboard    [ here input ! ]
+     (key  (key?  (decode  (expect ;
+
+
+\ *** Block No. 123, Hexblock 7b
+
+\ Default Disk Interface: Constants and Primitives       18Nov87
+
+ $80 Constant b/rec              b/blk b/rec / Constant rec/blk
+
+Dos definitions
+' 2- | Alias dosfcb>         ' 2+ | Alias >dosfcb
+
+: dos-error? ( n -- f )   0<> ;
+
+$5C Constant fcb
+: reset     (   --     )  0 &13 bdos ;
+: openfile  ( fcb -- f )    &15 bdosa dos-error? ;
+: closefile ( fcb -- f )    &16 bdosa dos-error? ;
+: read-seq  ( fcb -- f )    $14 bdosa dos-error? ;
+: write-seq ( fcb -- f )    $15 bdosa dos-error? ;
+: dma!      ( dma --   )    &26 bdos  ;
+: rec@      ( fcb -- f )    &33 bdosa ;
+: rec!      ( fcb -- f )    &34 bdosa ;
+
+\ *** Block No. 124, Hexblock 7c
+
+\ Default Disk Interface: open and close                 20Nov87
+
+Target Dos also     Defer drvinit
+
+Dos definitions
+
+| Variable  opened
+: default  ( -- )  opened off
+   fcb 1+ c@ bl = ?exit   $80 count here place   #tib off
+   fcb dup  dosfcb> dup  isfile ! fromfile !
+   openfile Abort" default file not found!"  opened on  ;
+' default Is drvinit
+
+Defer save-dos-buffers
+
+: close-default ( -- ) opened @ not ?exit
+    fcb closefile Abort" can't close default-file!" ;
+' close-default Is save-dos-buffers
+
+
+
+\ *** Block No. 126, Hexblock 7e
+
+\ Postlude                                               20Nov87
+
+Target Dos also
+
+Defer postlude
+
+| : (bye ( -- )   postlude 0 0 bdos ;
+
+| : #pages ( -- n ) here $100 -  $100 u/mod swap 0=exit 1+ ;
+
+: .size ( -- ) base push  decimal
+     cr ." Size: &" #pages u. ." Pages" ;
+
+' .size Is postlude
+

8080/CPM/cpmfiles/vf-bufs.fs

@@ -0,0 +1,242 @@
+\ *** Block No. 94, Hexblock 5e
+
+$5e .pagestatus
+
+\ buffer mechanism                             20Oct86   07Oct87
+
+Variable prev        0 prev !     \ Listhead
+| Variable buffers   0 buffers !  \ Semaphor
+$408 Constant b/buf               \ physikalische Groesse
+\ \\ Struktur eines Buffers:    0 : link
+\                               2 : file
+\                               4 : blocknummer
+\                               6 : statusflags
+\                               8 : Data ... 1 Kb ...
+\ Statusflag bits : 15   1 -> updated
+\ file :  -1 -> empty buffer,  0 -> no fcb, direct access
+\         else addr of fcb  ( system dependent )
+
+\ *** Block No. 95, Hexblock 5f
+
+\ search for blocks in memory                            30Jun86
+| Variable pred
+\ DE:blk  BC:file  HL:bufadr
+
+Label thisbuffer?   ( Zero = this buffer )
+   H push   H inx   H inx   M A mov   C cmp   0=
+   ?[ H inx   M A mov   B cmp   0= ?[ H inx   M A mov   E cmp
+      0= ?[ H inx   M A mov   D cmp ]? ]? ]?   H pop   ret
+
+Code (core?  ( blk file -- adr\blk file )
+   IP H mvx   Ipsave shld
+   user' offset D lxi   UP lhld   D dad
+   M E mov   H inx   M D mov
+   B pop   H pop   H push   B push   D dad   xchg
+   prev lhld
+   thisbuffer? call 0= ?[
+
+\ *** Block No. 96, Hexblock 60
+
+\ search for blocks in memory                            30Jun86
+
+Label blockfound
+   D pop   D pop   8 D lxi   D dad   H push   ' exit @ jmp ]?
+   [[ pred shld
+      M A mov   H inx   M H mov   A L mov
+      H ora 0= ?[ IPsave lhld   H IP mvx   Next ]?
+      thisbuffer? call   0= ?]
+      xchg   pred lhld   D ldax   A M mov
+      H inx  D inx   D ldax   A M mov   D dcx
+      prev lhld    xchg    E M mov  H inx  D M mov
+      H dcx   prev shld
+   blockfound jmp   end-code
+
+
+
+
+\ *** Block No. 97, Hexblock 61
+
+\ (core?                                                 29Jun86
+\ \\
+\
+\ | : this? ( blk file bufadr -- flag )
+\      dup 4+ @  swap 2+ @  d= ;
+\
+\ | : (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. 98, Hexblock 62
+
+\ (diskerr                                     29Jul86   07Oct87
+
+: (diskerr
+   ." error! r to retry "  key $FF and
+   capital Ascii R = not Abort" aborted" ;
+
+Defer diskerr
+' (diskerr Is diskerr
+
+Defer r/w
+
+
+
+
+
+
+
+\ *** Block No. 99, Hexblock 63
+
+\ backup emptybuf readblk                                20Oct86
+
+  : backup ( bufaddr -- )       dup 6+ @ 0<
+     IF 2+ dup @ 1+         \ buffer empty if file = -1
+       IF input push output push standardi/o
+         BEGIN  dup 6+ over 2+ @ 2 pick @ 0 r/w
+         WHILE ." write " diskerr
+         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
+     input push output push standardi/o >r
+     BEGIN  over offset @ + over r@ 8 + -rot 1 r/w
+     WHILE  ." read " diskerr  REPEAT r>  ;
+
+\ *** Block No. 100, Hexblock 64
+
+\ take mark updates? core?                     10Mar86   19Nov87
+
+| : take ( -- bufaddr)    prev
+     BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL
+     buffers lock   dup backup ;
+
+| : mark ( blk file bufaddr -- blk file )
+     2+ >r  2dup r@ !  offset @ + 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. 101, Hexblock 65
+
+\ block & buffer manipulation                  20Oct86   18Nov87
+
+: (buffer ( blk file -- addr )
+    BEGIN  (core? take mark  REPEAT ;
+
+: (block ( blk file -- addr )
+    BEGIN  (core? take readblk mark  REPEAT ;
+
+: buffer ( blk -- addr )   isfile@ (buffer ;
+
+: block  ( blk -- addr )   isfile@ (block ;
+
+: (blk-source   ( -- addr len)
+    blk @ ?dup IF loadfile @ (block  b/blk  exit THEN
+    tib #tib @ ;
+
+' (blk-source IS source
+
+\ : isfile@ ( -- addr )    isfile @ ;
+
+\ *** Block No. 102, Hexblock 66
+
+\ block & buffer manipulation                            05Oct87
+
+: update          $80 prev @ 6+ 1+ ( Byte-Order! )  c! ;
+
+: (save-buffers ( -- )   buffers lock
+   BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers
+   buffers unlock ;
+' (save-buffers IS save-buffers
+
+: empty-buffers ( -- )   buffers lock prev
+   BEGIN @ ?dup  WHILE dup emptybuf REPEAT  buffers unlock ;
+
+: flush           save-buffers empty-buffers ;
+
+
+
+\ *** Block No. 103, Hexblock 67
+
+\ Allocating buffers                                     10Oct87
+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  flush ;
+' (init-buffers IS init-buffers
+
+\ *** Block No. 125, Hexblock 7d
+
+$7d .pagestatus
+
+\ Default Disk Interface: read/write                     14Feb88
+
+Target Dos also
+
+| : rec# ( 'dosfcb -- 'rec# )  &33 + ;
+
+: (r/w  ( adr blk file r/wf -- flag )  >r
+    dup 0= Abort" no Direct Disk IO supported! " >dosfcb
+    swap rec/blk *  over rec#   0 over 2+ c!   !
+    r> rot  b/blk bounds
+    DO I dma!  2dup IF rec@ drop
+       ELSE rec! IF 2drop true endloop exit THEN THEN
+       over rec#   0 over 2+ c!  1 swap +!
+    b/rec +LOOP  2drop false ;
+
+' (r/w Is r/w
+
+: list ( blk -- )
+   scr ! ." Scr " scr @ u.
+   l/s 0 DO
+     cr I 2 .r space scr @ block I c/l * + c/l -trailing type
+   LOOP cr ;
+
+
+Variable loadfile
+
+: (load  ( blk offset -- )
+   isfile push  loadfile push  fromfile push  blk push >in push
+   >in !  blk !  isfile@ loadfile !  .status  interpret ;
+
+: load   ( blk --)     ?dup 0=exit  0 (load ;
+' load IS include-load
+
+
+\ *** Block No. 85, Hexblock 55
+
+$55 .pagestatus
+
+\ +load thru +thru --> rdepth depth                      20Oct86
+
+: +load    ( offset --)       blk @ + load ;
+
+: thru     ( from to --)      1+ swap DO I  load LOOP ;
+: +thru    ( off0 off1 --)    1+ swap DO I +load LOOP ;
+
+: -->        1 blk +! >in off .status ; immediate

8080/CPM/cpmfiles/vf-end.fs

@@ -0,0 +1,40 @@
+\ *** Block No. 116, Hexblock 74
+
+$74 .pagestatus
+
+\ Rest of Standard-System                      04Oct87   07Oct87
+
+\ 2 +load  \ Operating System
+
+Host    ' Transient 8 + @  Transient Forth Context @ 6 + !
+
+Target Forth also definitions
+
+Vocabulary Assembler  Assembler definitions
+Transient Assembler
+>Next Constant >Next
+hpush Constant hpush
+dpush Constant dpush
+
+Target Forth also definitions
+: forth-83 ;     \ last word in Dictionary
+
+\ *** Block No. 117, Hexblock 75
+
+$75 .pagestatus
+
+\ System patchup                                         04Oct87
+
+$EF00  r0 !
+$EB00  s0 !
+s0 @ 6 +  origin 2+ !  \ link Maintask to itself
+
+\ s0 und r0 werden beim Booten neu an die Speichergroesse
+\ angepasst. Ebenso der Multi-Tasker-Link auf die Maintask
+
+here dp !
+
+Host  Tudp @       Target  udp !
+Host  Tvoc-link @  Target  voc-link !
+Host move-threads
+

8080/CPM/cpmfiles/vf-file.fs

@@ -0,0 +1,78 @@
+
+$80 .pagestatus
+
+Target Dos also
+
+  : cr+ex@  ( fcb -- cr+256*ex )
+    dup &34 + c@  swap &14 + c@ $100 * + ;
+  : cr+ex!  ( cr+256*ex fcb -- )
+    >r $100 u/mod  r@ &14 + c!  r> &34 + c! ;
+
+| 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 ;
+
+  variable incfile
+  variable increc
+  variable increc-offset
+| $80 constant dmabuf
+| $ff constant dmabuf-last
+
+  : increadrec  ( fcb -- f )
+    dup cr+ex@ increc !
+    increc-offset off  dmabuf dma!  >dosfcb read-seq ;
+
+| : inc-fgetc  ( -- c )
+    increc-offset @ b/rec u< 0=
+      IF incfile @ increadrec IF ctrl-z exit THEN THEN
+    increc-offset @ dmabuf + c@  1 increc-offset +! ;
+
+| : 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 ;
+
+| $50 constant /stash
+| create stash[  /stash allot  here | constant ]stash
+| variable stash>   stash[ stash> !
+| : clear-tibstash  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
+  BEGIN freadline >r .status >in off  interpret  r> UNTIL ;
+
+  Defer include-load
+| : block-not-implemented 1 abort" block file access not implemented" ;
+  ' block-not-implemented IS include-load
+
+  : include-isfile ( -- )
+  increc push  0 isfile@ cr+ex!
+  isfile@ increadrec Abort" can't read start of file"
+  probe-for-fb IF 1 include-load exit THEN
+  incfile push  isfile@ incfile !
+  savetib >r  interpret-via-tib  r> restoretib
+  incfile @ 2+ closefile Abort" error closing file" ;

8080/CPM/cpmfiles/vf-io.fs

@@ -0,0 +1,186 @@
+\ *** Block No. 84, Hexblock 54
+
+$54 .pagestatus
+
+Target
+
+\ .status push load                                      20Oct86
+
+Defer .status   ' noop Is .status
+
+| Create: pull  r> r> ! ;
+
+: push   ( addr -- )   r> swap dup >r @ >r pull >r >r ;
+                       restrict
+
+: rdepth   ( -- +n)           r0 @ rp@ 2+   - 2/ ;
+: depth    ( -- +n)           sp@ s0 @ swap - 2/ ;
+
+
+
+
+
+
+\ *** Block No. 86, Hexblock 56
+
+\ quit (quit abort                                    UH 25Jan88
+
+: (prompt ( -- )
+    state @ IF cr ." ] " ELSE ."  ok" cr THEN .status ;
+
+Defer prompt    ' (prompt Is prompt
+
+: (quit      clear-tibstash  BEGIN prompt query interpret REPEAT ;
+
+Defer 'quit     ' (quit Is 'quit
+: quit   r0 @ rp!  level off  [compile] [ 'quit ;
+
+: standardi/o     [ output ] Literal output 4 cmove ;
+
+Defer 'abort   ' noop Is 'abort
+: abort      end-trace clearstack 'abort standardi/o quit ;
+
+\ *** Block No. 87, Hexblock 57
+
+\ (error Abort" Error"                         20Oct86   18Nov87
+
+Variable scr    1 scr !       Variable r#    0 r# !
+
+: (error ( string -- )     standardi/o space here .name
+    count type space ?cr
+    blk @ ?dup IF scr ! >in @ r# ! THEN quit ;
+' (error errorhandler !
+
+: (abort"     "lit swap IF >r clearstack r>
+              errorhandler perform exit THEN drop ; restrict
+
+| : (err"      "lit swap IF errorhandler perform exit THEN
+               drop ; restrict
+: Abort"       compile (abort" ,"  align  ; immediate restrict
+: Error"       compile (err"   ,"  align  ; immediate restrict
+
+\ *** Block No. 88, Hexblock 58
+
+\ -trailing                                    30Jun86   18Nov87
+
+Code -trailing   ( addr n1 -- addr n2 )
+   D pop   H pop   H push
+   D dad   xchg   D dcx
+Label -trail   H A mov   L ora    hpush jz
+   D ldax   BL cpi   hpush jnz
+   H dcx   D dcx   -trail jmp end-code
+
+\ \\
+\ : -trailing ( addr n1 -- addr n2)
+\     2dup bounds ?DO  2dup + 1- c@ bl - IF LEAVE THEN  1-  LOOP ;
+
+
+
+
+
+\ *** Block No. 89, Hexblock 59
+
+\ space spaces                                           30Jun86
+
+$20 Constant bl
+
+: space                      bl emit ;
+: spaces   ( u --)           0 ?DO space LOOP ;
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 90, Hexblock 5a
+
+\ hold <# #> sign # #s                                   17Oct86
+
+| : hld   ( -- addr)            pad 2- ;
+
+: hold    ( char -- )           -1 hld +! hld @ c! ;
+
+: <#                            hld hld ! ;
+
+: #>      ( 32b -- addr +n )    2drop hld @ hld over - ;
+
+: sign    ( n -- )              0< IF Ascii - hold THEN ;
+
+: #       ( +d1 -- +d2)         base @ ud/mod rot 9 over <
+   IF [ Ascii A Ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ;
+
+: #s      ( +d -- 0 0 )         BEGIN # 2dup d0= UNTIL ;
+
+\ *** Block No. 91, Hexblock 5b
+
+\ print numbers                                          24Dec83
+
+: d.r      -rot under dabs <# #s rot sign #>
+           rot over max over - spaces type ;
+
+: .r       swap extend rot d.r ;
+
+: u.r      0 swap d.r ;
+
+: d.       0 d.r space ;
+
+: .        extend d. ;
+
+: u.       0 d. ;
+
+
+
+\ *** Block No. 92, Hexblock 5c
+
+\ .s list c/l l/s                                        05Oct87
+
+: .s    sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ;
+
+$40 Constant c/l        \ Screen line length
+$10 Constant l/s        \ lines per screen
+
+
+
+
+
+
+\ *** Block No. 93, Hexblock 5d
+
+$5d .pagestatus
+
+\ multitasker primitives                                 20Nov87
+
+Code end-trace    \ patch Next to its original state
+   $0A A mvi   ( IP ldax )          >next sta
+   $6F03 H lxi ( IP inx   A L mov ) >next 1+ shld  Next end-code
+
+Code pause   >next here 2- !  end-code
+
+: lock ( addr -- )  dup @  up@  = IF  drop exit  THEN
+   BEGIN  dup  @ WHILE  pause  REPEAT  up@  swap  ! ;
+
+: unlock ( addr -- )   dup lock off ;
+
+Label wake   H pop   H dcx   UP shld
+   6 D lxi   D dad   M A mov   H inx   M H mov  A L mov   sphl
+   H pop   RP shld   IP pop   Next   end-code
+
+\ file related definitions moved here from vf-bufs.fth
+
+User isfile          0 isfile !   \ addr of file control block
+Variable fromfile    0 fromfile !
+
+Code isfile@ ( -- addr )  user' isfile  D lxi
+   UP lhld   D dad   fetch jmp   end-code
+
+$FF00 Constant limit
+
+Defer save-buffers  ' noop IS save-buffers
+Defer init-buffers  ' noop IS init-buffers
+
+$400 Constant b/blk

8080/CPM/cpmfiles/vf-sys.fs

@@ -0,0 +1,229 @@
+\ *** Block No. 104, Hexblock 68
+
+$68 .pagestatus
+
+Target
+
+\ endpoints of forget                                    01Jul86
+
+| : |? ( nfa -- flag )   c@ $20 and ;
+| : forget? ( adr nfa -- flag )   \ code in heap or above adr ?
+     name>  under  1+ u<  swap  heap?  or ;
+
+| : endpoints ( addr -- addr symb )
+     heap voc-link @ >r
+     BEGIN   r> @ ?dup      \ through all Vocabs
+     WHILE dup >r 4- >r    \ link on returnstack
+       BEGIN r> @ >r over 1- dup r@ u<      \ until link or
+                   swap r@ 2+ name> u< and  \ code under adr
+       WHILE r@ heap? [ 2dup ] UNTIL   \ search for name in heap
+       r@ 2+ |? IF over r@ 2+ forget?
+               IF r@ 2+ (name> 2+ umax THEN   \ then update symb
+       THEN REPEAT rdrop  REPEAT ;
+
+\ *** Block No. 105, Hexblock 69
+
+\ remove, -words, -tasks                                 20Oct86
+
+: remove ( dic sym thread - dic sym )
+     BEGIN dup @ ?dup      \ unlink forg. words
+     WHILE dup heap?
+       IF  2 pick over u>  ELSE  3 pick over 1+ u<  THEN
+       IF  @ over ! ( unlink word)  ELSE nip THEN  REPEAT drop ;
+
+| : remove-words ( dic sym -- dic sym )
+     voc-link BEGIN  @ ?dup
+              WHILE  dup >r  4- remove  r> REPEAT ;
+
+| : remove-tasks ( dic -- )       up@
+     BEGIN  2+  dup @  up@ -  WHILE  2dup @ swap here uwithin
+            IF dup @ 2+ @  over ! 2-
+            ELSE @ THEN REPEAT 2drop ;
+
+\ *** Block No. 106, Hexblock 6a
+
+\ remove-vocs trim                             20Oct86   07Oct87
+
+| : remove-vocs ( dic symb -- dic symb )
+     voc-link remove       thru.vocstack
+     DO 2dup I @ -rot uwithin
+       IF  [ ' Forth 2+ ]  Literal I !  THEN  -2 +LOOP
+     2dup  current @  -rot  uwithin
+     IF  [ ' Forth 2+ ] Literal current ! THEN ;
+
+Defer custom-remove     ' noop Is custom-remove
+
+| : trim ( dic symb -- )
+     over  remove-tasks remove-vocs remove-words
+     custom-remove  heap swap - hallot dp ! 0 last ! ;
+
+
+
+\ *** Block No. 107, Hexblock 6b
+
+\ deleting words from dict.                    01Jul86   18Nov87
+
+: clear        here  dup up@  trim  dp ! ;
+
+: (forget ( adr --)    dup heap? Abort" is symbol"
+                       endpoints  trim ;
+
+: forget   ' dup [ dp ] Literal @  u< Abort" protected"
+            >name  dup  heap?
+            IF name> ELSE 4- THEN (forget ;
+
+: empty   [ dp ] Literal @ up@ trim
+          [ udp ] Literal @ udp ! ;
+
+
+
+
+\ *** Block No. 108, Hexblock 6c
+
+\ save bye stop? ?cr                                     18Nov87
+
+: save    here  up@ trim
+   voc-link @ BEGIN  dup 4- @ over 2- ! @ ?dup  0= UNTIL
+   up@ origin $100 cmove ;
+
+: bye       save-buffers  (bye ;
+\ : bye       flush empty (bye ;
+
+| : end?    key #cr = IF true rdrop THEN ;
+
+: stop? ( -- flag )     key? IF end? end? THEN false ;
+
+: ?cr                   col c/l u> 0=exit cr ;
+
+
+
+
+\ *** Block No. 109, Hexblock 6d
+
+\ in/output structure                                    07Jun86
+
+| : Out:   Create dup c, 2+ Does> c@ output @ + perform ;
+
+: Output:  Create:  Does> output ! ;
+0   Out: emit   Out: cr   Out: type   Out: del
+    Out: page   Out: at   Out: at?    drop
+
+: row ( -- row)     at? drop ;
+: col ( -- col)     at? nip ;
+
+| : In:    Create dup c, 2+ Does> c@ input @ + perform ;
+
+: Input:   Create:  Does> input ! ;
+0   In: key   In: key?   In: decode   In: expect  drop
+
+
+\ *** Block No. 110, Hexblock 6e
+
+\ Alias  only definitionen                               18Nov87
+
+Root definitions Forth
+
+: seal  [ ' Root >body ] Literal off ; \ "erase" Root Vocab.
+
+' Only        Alias Only
+' Forth       Alias Forth
+' words       Alias words
+' also        Alias also
+' definitions Alias definitions
+
+Host Target
+
+
+
+
+\ *** Block No. 111, Hexblock 6f
+
+\ 'restart 'cold                               22Oct86   10Oct87
+
+Defer 'restart  ' noop Is 'restart
+
+| : (restart   ['] (quit Is 'quit drvinit 'restart
+     [ errorhandler ] Literal @ errorhandler !
+     ['] noop Is 'abort clearstack
+     standardi/o interpret quit ;
+
+Defer 'cold    ' noop Is 'cold
+
+| : (cold      origin up@ $100 cmove  $80 count
+     $50 umin >r tib r@ move r> #tib ! >in off  blk off
+     init-vocabularys init-buffers  'cold
+     Onlyforth page &24 spaces  logo count type cr (restart  ;
+
+
+\ *** Block No. 112, Hexblock 70
+
+\ cold bootsystem                                        20Oct86
+
+Code cold   here >cold !
+   s0 lhld   6 D lxi   D dad   origin D lxi   $3F C mvi
+   [[ D ldax   A M mov  H inx   D inx   C dcr   0= ?]
+   ' (cold >body IP lxi
+Label bootsystem
+   s0 lhld   6 D lxi   D dad   UP shld
+   user' s0  D lxi   D dad
+   M E mov   H inx   M D mov   xchg   sphl
+   user' r0 D lxi    UP lhld    D dad
+   M E mov   H inx   M D mov    xchg   RP shld
+   $C3 ( jmp ) A mvi  $30 sta   wake H lxi  $31 shld ( Tasker )
+   Next
+end-code
+
+
+\ *** Block No. 113, Hexblock 71
+
+\ restart boot                                           20Oct86
+
+Code restart      here >restart !
+   ' (restart >body IP lxi   bootsystem jmp   end-code
+
+Label boot     here >boot !    \ find link to Main:
+   s0 lhld   6 D lxi   D dad   H B mvx    origin D lxi
+   [[ [[ xchg   H inx   H inx   M E mov   H inx   M D mov
+         D A mov   B cmp 0= ?]   E A mov   C cmp 0= ?]   H B mvx
+   6 lhld   0 L mvi   ' limit >body shld
+  -$1100 D lxi   D dad   r0 shld   \ set initial RP
+   -$400 D lxi   D dad   s0 shld   \ set initial SP
+       6 D lxi   D dad   xchg   B H mvx
+       D M mov   H dcx   E M mov   \ set link to Maintask
+  >cold 2- jmp
+end-code
+
+\ *** Block No. 114, Hexblock 72
+
+$72 .pagestatus
+
+\ "search                                                05Mar88
+
+Label notfound      H pop   H pop
+   IPsave lhld   H IP mvx   False H lxi   hpush jmp
+
+Code "search ( text tlen buf blen -- addr tf / ff )
+   IP H mvx  IPsave shld   D pop    H pop    xthl
+   H A mov   L ora  notfound jz
+   E A mov  L sub  A C mov   D A mov  H sbb  A B mov notfound jc
+   B inx   D pop   xthl   M A mov  xthl  H push   xchg
+Label scanfirst
+   A E mov  ?capital call  E D mov
+   [[  M E mov   H inx   B A mov  C ora   notfound jz   B dcx
+       ?capital call  E A mov  D cmp  0=  ?]
+   B D mvx   B pop   xchg   xthl   xchg   H push  B push  D push
+
+
+\ *** Block No. 115, Hexblock 73
+
+\ "search  part 2                                        27Nov87
+
+Label match
+   B dcx   B A mov  C ora  0<> ?[
+   D inx   D ldax   D push   A E mov  ?capital call   E D mov
+   M E mov  H inx  ?capital call  E A mov   D cmp   D pop
+   match jz   H pop   B pop   D pop
+   M A mov   xthl   B push   H B mvx  xchg  scanfirst jmp ]?
+   D pop   D pop   H pop   D pop  H dcx  H push
+   IPsave lhld  H IP mvx  True H lxi  hpush jmp
+end-code

8080/CPM/emulator/run-in-runcpm.sh

@@ -0,0 +1,42 @@
+#!/bin/bash
+
+set -e
+
+emulatordir="$(realpath --relative-to="$PWD" "$(dirname "${BASH_SOURCE[0]}")")"
+basedir="$(realpath --relative-to="$PWD" "${emulatordir}/..")"
+cpmfilesdir="${basedir}/cpmfiles"
+runcpmdir="${basedir}/runcpm"
+runcpm_a0="${runcpmdir}/A/0"
+toolsdir="${basedir}/../../tools"
+
+logfile="${runcpmdir}/runcpm.log"
+scriptfile="${runcpmdir}/input.script"
+rm -f "${logfile}"
+rm -f "${scriptfile}"
+for line in "$@"; do
+  echo "${line}" >> "${scriptfile}"
+done
+
+test -d "${runcpm_a0}" || mkdir -p "${runcpm_a0}"
+
+for pathname in ${cpmfilesdir}/*
+do
+  # echo $pathname
+  filename="$(realpath --relative-to="${cpmfilesdir}" "${pathname}")"
+  # echo $filename
+  uppercase_filename="$("${toolsdir}/echo-toupper.py" "${filename}")"
+  # echo $uppercase_filename
+  cp "${pathname}" "${runcpm_a0}/${uppercase_filename}"
+done
+
+if [[ -f "${scriptfile}" ]]; then
+  "${runcpmdir}/RunCPM" -i "${scriptfile}" -o "${logfile}"
+#  "${runcpmdir}/RunCPM" -s <"${scriptfile}" | tee "${logfile}"
+else
+  "${runcpmdir}/RunCPM" -o "${logfile}"
+#  "${runcpmdir}/RunCPM" -s | tee "${logfile}"
+fi
+
+cp "${logfile}" runcpm.log
+"${toolsdir}/trunc-ctrl-z.py" "${runcpmdir}/A/0/LOGFILE.TXT" \
+    "${runcpmdir}/logfile.txt"

8080/CPM/src/ass8080.fb.txt

@@ -0,0 +1,342 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\ VolksForth 8080 Assembler                           UH 09Mar86
+
+Ideen lieferten:
+                    John Cassady
+                    Mike Perry
+                    Klaus Schleisiek
+                    Bernd Pennemann
+                    Dietrich Weineck
+
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ VolksForth 8080 Assembler Load Screen               UH 03Jun86
+Onlyforth Assembler also definitions hex
+
+  1 6 +THRU  cr .( VolksForth 8080-Assembler geladen. ) cr
+
+OnlyForth
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+   \ Vektorisierte Erzeugung                          UH 03Jun86
+Variable >codes
+
+| Create nrc  ]  c, , c@ here allot ! c! [
+
+: nonrelocate ( -- )   nrc >codes ! ;   nonrelocate
+
+| : >exec ( n -- n+2 )
+      Create dup c, 2+ does> c@ >codes @ + perform ;
+
+0    | >exec >c,     | >exec >,  | >exec >c@  | >exec >here
+     | >exec >allot  | >exec >!  | >exec >c!
+drop
+
+
+
+
+\ *** Block No. 3, Hexblock 3
+
+   \ Register und Definierende Worte                  UH 09Mar86
+
+7 Constant A
+0 Constant B   1 Constant C      2 Constant D   3 Constant E
+0 Constant I   1 Constant I'     2 Constant W   3 Constant W'
+0 Constant IP  1 Constant IP'    4 Constant H   5 Constant L
+6 Constant M   6 Constant PSW    6 Constant SP  6 Constant S
+
+| : 1MI Create >c, does> C@ >c, ;
+| : 2MI Create >c, does> C@ + >c, ;
+| : 3MI Create >c, does> C@ swap 8 * + >c, ;
+| : 4MI Create >c, does> C@ >c, >c, ;
+| : 5MI Create >c, does> C@ >c, >, ;
+
+
+
+
+\ *** Block No. 4, Hexblock 4
+
+   \ Mnemonics                                        UH 09Mar86
+00 1MI nop   76 1MI hlt  F3 1MI di   FB 1MI ei    07 1MI rlc
+0F 1MI rrc   17 1MI ral  1F 1MI rar  E9 1MI pchl  EB 1MI xchg
+C9 1MI ret   C0 1MI rnz  C8 1MI rz   D0 1MI rnc   D8 1MI rc
+2F 1MI cma   37 1MI stc  3F 1MI cmc  F9 1MI sphl  E3 1MI xthl
+E0 1MI rpo   E8 1MI rpe  F8 1MI rm   27 1MI daa
+80 2MI add   88 2MI adc  90 2MI sub  98 2MI sbb   A0 2MI ana
+A8 2MI xra   B0 2MI ora  B8 2MI cmp  02 3MI stax  04 3MI inr
+03 3MI inx   09 3MI dad  0B 3MI dcx  C1 3MI pop   C5 3MI push
+C7 3MI rst   05 3MI dcr  0A 3MI ldax D3 4MI out   DB 4MI in
+C6 4MI adi   CE 4MI aci  D6 4MI sui  DE 4MI sbi   E6 4MI ani
+EE 4MI xri   F6 4MI ori  FE 4MI cpi  22 5MI shld  CD 5MI call
+2A 5MI lhld  32 5MI sta  3A 5MI lda  C3 5MI jmp
+C2 5MI jnz   CA 5MI jz   D2 5MI jnc  DA 5MI jc    E2 5MI jpo
+EA 5MI jpe   F2 5MI jp   FA 5MI jm
+
+
+\ *** Block No. 5, Hexblock 5
+
+   \ Spezial Mnemonics und Spruenge                   UH 09Mar86
+DA Constant C0=  D2 Constant C0<>  D2 Constant CS
+C2 Constant 0=   CA Constant 0<>   E2 Constant PE
+F2 Constant 0<   FA Constant 0>=  : not   8 [ FORTH ] xor   ;
+
+: mov   8 * 40 + + >c, ;
+: mvi   8 * 6 + >c, >c, ;     : lxi   8 * 1+ >c, >, ;
+
+: [[  ( -- addr )  >here ;                              \ BEGIN
+: ?]  ( addr opcode -- )  >c,  >, ;                     \ UNTIL
+: ?[  ( opcode -- addr )  >c,   >here   0 >, ;          \ IF
+: ?[[ ( addr -- addr' addr )   ?[ swap ;                \ WHILE
+: ]?  ( addr -- )   >here swap >! ;                     \ THEN
+: ][  ( addr -- addr' )   >here  1+  0 jmp  swap ]? ;   \ ELSE
+: ]]  ( addr -- )   jmp ;                               \ AGAIN
+: ]]? ( addr addr' -- )   jmp  ]? ;                     \ REPEAT
+
+\ *** Block No. 6, Hexblock 6
+
+   \ Macros                                           UH 14May86
+: end-code    context 2- @   context ! ;
+
+: ;c:   0 recover call   end-code ] ;
+
+: Next   >next jmp ;
+
+: rpush ( reg -- )  RP lhld  H dcx  DUP M mov ( high )
+   H dcx   1+ M mov ( low )   RP shld  ;
+
+: rpop  ( reg -- )  RP lhld   M over 1+ mov ( low )  H inx
+   M swap mov ( high )  H inx   RP shld ;
+\  rpush und rpop gehen nicht mit HL
+
+: mvx ( src dest -- )
+   2dup  mov ( high )  1+ swap 1+ swap mov  ( low ) ;
+
+\ *** Block No. 7, Hexblock 7
+
+   \ Definierende Worte                               UH 06Aug86
+Forth definitions
+: Code ( -- )   Create here dup 2- ! Assembler ;
+
+: ;Code ( -- )  0 ?pairs
+   compile [ ' does>  >body 2+ @ , ]
+   reveal  [compile] [  Assembler ; immediate
+
+: >label ( adr -- )
+   here | Create  swap , 4 hallot   >here 4 - heap 4 cmove
+   heap last @  (name> !  dp !
+   does> ( -- adr )  @   State @ IF  [compile] Literal THEN ;
+
+: Label  [ Assembler ]  >here >label Assembler ;
+
+
+
+\ *** Block No. 8, Hexblock 8
+
+                                                      UH 14May86
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+% VolksForth 8080 Assembler  Shadow-Screens           UH 09Mar86
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 10, Hexblock a
+
+% VolksForth 8080 Assembler                           UH 03Jun86
+
+Der 8080 Assembler wurde von John Cassady, in den Forth
+Dimensions veroeffentlicht und von Mike Perry im F83
+implementiert. Er unterstuetzt den gesamten 8080 Befehlsvorrat
+und auch Befehle zur strukturierten Assemblerprogrammierung.
+Um ein Wort in Assembler zu definieren wird das definierende
+Wort Code benutzt, es kann, muss aber nicht mit end-code beendet
+werden. Wie der Assembler arbeitet ist ein interessantes
+Beispiel fuer die Maechtigkeit von Create does>.
+Am Anfang werden die Befehle in Klassen eingeteilt und fuer
+jede Klasse ein definierndes Wort definiert. Wenn der Mnemonic
+des Befehls spaeter interpretiert wird, kompiliert er den
+entsprechenden Opcode.
+
+
+
+\ *** Block No. 11, Hexblock b
+
+   % Vektorisierte Erzeugung                          UH 09Mar86
+Zeigt Auf die Tabelle mit den aktuellen Erzeugungs-Operatoren.
+
+Tabelle mit Erzeugungs-Operatoren fuer In-Line Assembler
+
+Schaltet Assembler in den In-Line Modus.
+
+Definierendes Wort fuer Erzeugungs-Operator-Namen.
+
+
+Die Erzeugungs-Operator-Namen, sie fuehren den entsprechenden
+aktuellen Erzeugungsoperator aus.
+
+Mit diesen Erweiterungen kann der Assembler auch fuer den
+Target-Compiler benutzt werden.
+
+
+\ *** Block No. 12, Hexblock c
+
+   % Register und Definierende Worte                  UH 09Mar86
+
+Die 8080 Register werden definiert. Es sind einfach Konstanten
+die Information fuer die Mnemonics hinterlassen.
+Einige Register der Forth-Maschine:
+    IP ist BC, W ist DE
+
+
+Definierende Worte fuer die Mnemonics.
+Fast alle 8080 Befehle fallen in diese 5 Klassen.
+
+
+
+
+
+
+
+\ *** Block No. 13, Hexblock d
+
+   % Mnemonics                                        UH 09Mar86
+Die 8080 Mnemonics werden definiert.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 14, Hexblock e
+
+   % Spezial Mnemonics und Spruenge                   UH 09Mar86
+Vergleiche des 8080
+
+not folgt einem Vergleich, wenn er invertiert werden soll.
+
+die Mnemonics, die sich nicht in die Klassen MI1 bis MI5
+einteilen lassen.
+
+Die strukturierten Assembler-Anweisungen.
+Die 'Fleischerhaken' werden benutzt, damit keine Verwechselungen
+zu den strukturierten Anweisungen in Forth entstehen.
+Es findet keine Absicherung der Kontrollstrukturen statt, sodass
+sie auch beliebig missbraucht, werden koennen.
+Das ist manchmal aus Geschwindigkeitsgruenden leider notwendig.
+
+
+
+\ *** Block No. 15, Hexblock f
+
+   % Macros                                           UH 17May86
+end-code beendet eine Code-Definition
+
+;c:   Erlaubt das Einbinden von High-Level Forth in Code-Worten.
+
+Next  Assembliert einen Sprung zum Adress-Interpretierer.
+
+rpush Das angegebene Register wird auf den Return-Stack gelegt.
+
+
+rpop  Das angegebene Register wird vom Return-Stack genommen.
+
+rpush und rpop benutzen das HL Register.
+
+mvx  Ein 16-Bit-Move wie 'mov' fuer 8-Bit Register
+     Bewegt Registerpaare HL BC DE
+
+\ *** Block No. 16, Hexblock 10
+
+   % Definierende Worte                               UH 17May86
+Code leitet eine Code-Definition ein.
+
+;code ist das Low-Level-Aequivalent von does>
+
+
+>label erzeugt ein Label auf dem Heap, mit dem angegebenen Wert
+
+
+
+
+Label erzeugt ein Label auf dem Heap, mit dem Wert von here
+
+
+
+
+
+\ *** Block No. 17, Hexblock 11
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

8080/CPM/src/asstran.fb.txt

@@ -0,0 +1,38 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Transinient Assembler                                 11Nov86
+
+Dieses File enthaelt Befehle, die den Assembler vollstaendig in
+den Heap laden, so dass er schliesslich mit clear wieder
+vergessen werden kann.
+
+Dadurch ist es nicht notwendig in einer Anwendung den ganzen
+Assembler im Speicher lassen zu muessen, nur weil einige
+primitive Worte in Assembler geschrieben sind.
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ Internal Assembler                                  UH 22Oct86
+
+Onlyforth
+
+here
+    $C00 hallot    heap dp !     include ass8080.scr
+dp !
+
+
+
+
+
+
+
+
+

8080/CPM/src/copy.fb.txt

@@ -0,0 +1,38 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\ Copy und Convey                                        19Nov87
+
+Dieses File enthaelt Definitionen, die urspruenglich im Kern
+enthalten waren. Sie sind jetzt ausgelagert worden, um den Kern
+klein zu halten.
+
+copy      kopiert einen Screen
+
+convey    kopiert einen Bereich von Screens
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ moving blocks                                20Oct86   19Nov87
+| : full? ( -- flag )  prev  BEGIN @ dup @ 0= UNTIL  6 + @ 0< ;
+| : fromblock ( blk -- adr )   fromfile @ (block ;
+| : (copy ( from to -- )
+     dup isfile@  core? IF  prev @ emptybuf  THEN
+                  full? IF  save-buffers  THEN
+     offset @ +   isfile@ rot  fromblock 6 - 2!  update ;
+| : blkmove ( from to quan --) save-buffers >r
+     over r@ + over u> >r 2dup u< r> and
+     IF    r@ r@ d+ r> 0 ?DO  -1 -2 d+ 2dup (copy  LOOP
+     ELSE  r> 0 ?DO 2dup (copy 1 1 d+ LOOP THEN
+     save-buffers 2drop ;
+
+: copy ( from to --)         1 blkmove ;
+: convey ( [blk1 blk2] [to.blk --)
+   swap 1+ 2 pick - dup  0> not Abort" Nein !" blkmove ;

8080/CPM/src/disass.fb.txt

@@ -0,0 +1,342 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Z80-Disassembler                                      08Nov86
+
+Dieses File enthaelt einen Z80-Disassembler, der assemblierten
+Code in Standard Zilog-Z80 Mnemonics umsetzt.
+
+Benutzung:
+
+     TOOLS ALSO   \ Schalte Disassembler-Vokabular an
+
+       addr DIS   \ Disassembliere ab Adresse addr
+
+ xxxx displace !  \ Beruecksichte bei allen Adressen einen
+                  \ Versatz von xxxx.
+                  \ Wird gebraucht, wenn ein Assemblerstueck
+                  \ nicht an dem Platz disassembliert wird,
+                  \ an dem es ablaeuft.
+
+\ *** Block No. 1, Hexblock 1
+
+\ Z80-Disassembler Load Screen                           08Nov86
+
+Onlyforth Tools also definitions hex
+
+' Forth | Alias F: immediate
+' Tools | Alias T: immediate
+
+  1 $10 +THRU  cr .( Disassembler geladen. ) cr
+
+OnlyForth
+
+
+\\ Fragen Anregungen & Kritik an:
+                    U. Hoffmann
+                    Harmsstrasse 71
+                    2300 Kiel 1
+
+\ *** Block No. 2, Hexblock 2
+
+   \ Speicherzugriff und Ausgabe                         07Jul86
+internal
+\needs Case:  : Case: Create: Does> swap 2* + perform ;
+
+Variable index      Variable address    Variable offset
+Variable oldoutput
+external  Variable displace  displace off   internal
+
+' pad Alias str1  ( -- addr )
+: str2  ( -- addr )  str1  $40 + ;
+
+: byte ( -- b )  address @ displace @ +  c@ ;
+: word ( -- w )  address @ displace @ +   @ ;
+
+: .byte ( byte -- )   0 <# # #s #> type ;
+: .word ( addr -- )   0 <# # # # #s #> type ;
+
+\ *** Block No. 3, Hexblock 3
+
+   \ neue Bytes lesen    Byte-Fraktionen                 07Jul86
+
+: next-byte   output push  oldoutput @ output !
+   byte .byte space   1 address +! ;
+
+: next-word   next-byte next-byte ;
+
+: f    ( -- b )  byte $40 / ;
+: g    ( -- b )  byte 8 / 7 and ;
+: h    ( -- b )  byte 7 and ;
+: j    ( -- b )  g 2/ ;
+: k    ( -- b )  g 1 and ;
+
+\\  76543210
+    ffggghhh
+      jjk
+
+\ *** Block No. 4, Hexblock 4
+
+   \ Select"                                             08Nov86
+
+: scan/ ( limit start -- limit start' ) over swap
+    DO I c@ Ascii / = IF I F: ENDLOOP T: exit THEN LOOP dup ;
+
+: select ( n addr len -- addr' len' )
+   bounds rot
+   0 ?DO scan/ 1+ 2dup < IF 2drop " -" count ENDLOOP exit THEN
+     LOOP under scan/ nip over - ;
+
+: (select" ( n -- ) "lit count select type ;
+
+: select" ( -- )  compile (select" ," ; immediate
+
+: append ( c str -- )
+   under count + c!  dup c@ 1+ swap c! ;
+
+\ *** Block No. 5, Hexblock 5
+
+   \ StringOutput                                        07Jul86
+
+Variable $
+
+: $emit ( c -- )  $ @  append  pause ;
+
+: $type ( adr len -- )  0 ?DO count $emit LOOP drop ;
+
+: $cr ( -- )   $ @ off ;
+
+: $at? ( -- row col )  0   $ @ c@ ;
+
+Output: $output
+  $emit $cr $type noop $cr 2drop $at? ;
+
+
+
+\ *** Block No. 6, Hexblock 6
+
+   \ Register                                            07Jul86
+
+: reg ( n -- )  dup 5 = IF index @ negate index ! THEN
+   select" B/C/D/E/H/L/$/A" ;
+
+: double-reg ( n -- ) select" BC/DE/%/SP" ;
+
+: double-reg2 ( n -- ) select" BC/DE/%/AF" ;
+
+: num ( n -- ) select" 0/1/2/3/4/5/6/7" ;
+
+: cond ( n -- ) select" nz/z/nc/c/po/pe/p/m" ;
+
+: arith ( n -- )
+   select" add A,/adc A,/sub /sbc A,/and /xor /or /cp " ;
+
+
+\ *** Block No. 7, Hexblock 7
+
+   \ no-prefix  Einteilung der Befehle in Klassen        07Jul86
+
+: 00xxx000
+   g dup 3 > IF ." jr " 4- cond  ." ,?" exit THEN
+     select" nop/ex AF,AF'/djnz ?/jr ?" ;
+
+: 00xxx001
+   k IF ." add %," j double-reg exit THEN
+   ." ld " j double-reg ." ,&" ;
+
+: 00xxx010  ." ld " g
+   select" (BC),A/A,(BC)/(DE),A/A,(DE)/(&),%/%,(&)/(&),A/A,(&)"
+;
+
+: 00xxx011   k IF ." dec " ELSE ." inc " THEN  j double-reg ;
+
+
+\ *** Block No. 8, Hexblock 8
+
+      \ no-prefix                                        07Jul86
+
+: 00xxx100  ." inc "  g reg ;
+
+: 00xxx101  ." dec "  g reg ;
+
+: 00xxx110  ." ld "  g reg ." ,#" ;
+
+: 00xxx111  g select" rlca/rrca/rla/rra/daa/cpl/scf/ccf" ;
+
+: 01xxxxxx  ." ld "  g reg ." ," h reg ;
+
+: 10xxxxxx  g arith   h reg ;
+
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+      \ no-prefix                                        07Jul86
+
+: 11xxx000  ." ret " g cond ;
+
+: 11xxx001  k IF  j select" ret/exx/jp (%)/ld sp,%" exit THEN
+            ." pop " j double-reg2 ;
+
+: 11xxx010 ." JP " g  cond ." ,&" ;
+
+: 11xxx011  g
+ select" jp &/-/out (#),A/in a,(#)/ex (SP),%/ex DE,HL/di/ei" ;
+
+: 11xxx100 ." call " g cond ;
+: 11xxx101 k IF ." call &" exit THEN ." push " j double-reg2 ;
+: 11xxx110  g arith  ." #" ;
+: 11xxx111  ." rst " g select" 00/08/10/18/20/28/30/38" ;
+
+\ *** Block No. 10, Hexblock a
+
+      \ no-prefix                                        07Jul86
+
+Case: 00xxxhhh
+  00xxx000 00xxx001 00xxx010 00xxx011
+  00xxx100 00xxx101 00xxx110 00xxx111 ;
+
+Case: 11xxxhhh
+  11xxx000 11xxx001 11xxx010 11xxx011
+  11xxx100 11xxx101 11xxx110 11xxx111 ;
+
+: 00xxxxxx h 00xxxhhh ;
+: 11xxxxxx h 11xxxhhh ;
+
+Case: ffxxxxxx
+  00xxxxxx 01xxxxxx 10xxxxxx 11xxxxxx ;
+
+
+\ *** Block No. 11, Hexblock b
+
+      \ no-prefix                                        07Jul86
+
+: get-offset   index @ 0> IF byte offset ! next-byte THEN ;
+
+: no-prefix  f ffxxxxxx  next-byte  get-offset ;
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 12, Hexblock c
+
+   \ CB-Prefix                                           07Jul86
+
+: CB-00xxxxxx
+   g select" rlc /rrc /rl /rr /sla /sra /-/srl "  h reg ;
+
+: CB-01xxxxxx  ." bit "  g num  ." ,"   h reg ;
+
+: CB-10xxxxxx  ." res "  g num  ." ,"   h reg ;
+
+: CB-11xxxxxx  ." set "  g num  ." ,"   h reg ;
+
+case: singlebit
+  CB-00xxxxxx   CB-01xxxxxx  CB-10xxxxxx  CB-11xxxxxx ;
+
+: CB-prefix  get-offset  f singlebit  next-byte ;
+
+
+\ *** Block No. 13, Hexblock d
+
+   \ ED-Prefix                                           30Sep86
+: ED-01xxx000  ." in (C),"  g reg ;
+: ED-01xxx001  ." out (C)," g reg ;
+: ED-01xxx010  k IF ." adc " ELSE ." sbc " THEN
+               ." HL," j double-reg ;
+: ED-01xxx011  ." ld "  k IF  j double-reg ." ,(&)" exit THEN
+               ." (&),"  j double-reg ;
+: ED-01xxx100  ." neg" ;
+: ED-01xxx101  k IF ." reti" exit THEN ." retn" ;
+: ED-01xxx110  g select" im 0/-/im 1/im 2" ;
+: ED-01xxx111  g select" ld I,A/ld R,A/ld A,I/ld A,R/rrd/rld" ;
+: ED-10xxxxxx  h select" ld/cp/in/ot" g 4- select" i/d/ir/dr" ;
+Case: ED-01xxxhhh
+  ED-01xxx000  ED-01xxx001  ED-01xxx010  ED-01xxx011
+  ED-01xxx100  ED-01xxx101  ED-01xxx110  ED-01xxx111 ;
+: ED-01xxxxxx  h ED-01xxxhhh ;
+
+\ *** Block No. 14, Hexblock e
+
+      \ ED-Prefix                                        07Jul86
+
+Case: extended
+  noop  ED-01xxxxxx  ED-10xxxxxx noop ;
+
+: ED-prefix  get-offset  f extended  next-byte ;
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 15, Hexblock f
+
+   \ Disassassemblieren eines einzelnen Befehls          30Sep86
+
+: index-register ( n -- )   index ! next-byte ;
+
+: get-instruction ( -- )
+   index off  str1 $ !  cr
+   byte $DD = IF 1 index-register ELSE
+   byte $FD = IF 2 index-register THEN THEN
+   byte $76 case? IF next-byte ." halt"  exit THEN
+        $CB case? IF next-byte CB-prefix exit THEN
+        $ED case? IF next-byte ED-prefix exit THEN
+   drop no-prefix ;
+
+
+
+
+
+\ *** Block No. 16, Hexblock 10
+
+   \ Adressierungsarten ausgeben               07Jul86   27Nov87
+: .index-register ( -- )  index @ abs select" HL/IX/IY" ;
+
+: offset-sign ( o -- o' ) dup $7F > IF $100 -  THEN ;
+: +- ( s -- ) 0< IF Ascii - ELSE Ascii + THEN hold ;
+
+: .offset ( -- )   offset @  offset-sign
+    extend under dabs <# # #s rot +- #> type ;
+: .index-register-offset
+   index @ abs dup select" (HL)/(IX/(IY" IF .offset ." )" THEN ;
+
+: .inline-byte ( -- )    byte .byte next-byte ;
+: .inline-word ( -- )    word .word next-word ;
+
+: .displace ( -- )
+    byte offset-sign address @ + 1+  .word next-byte ;
+
+\ *** Block No. 17, Hexblock 11
+
+   \ Hauptebene: dis                                     07Jul86
+: .char ( c -- )
+   Ascii % case? IF .index-register exit THEN
+   Ascii $ case? IF .index-register-offset exit THEN
+   Ascii # case? IF .inline-byte exit THEN
+   Ascii & case? IF .inline-word exit THEN
+   Ascii ? case? IF .displace exit THEN  emit ;
+
+: instruction ( -- )  cr  address @ .word  2 spaces
+   output @  oldoutput !  $output  get-instruction
+   str2 $ ! cr str1 count 0 ?DO count .char LOOP drop
+   oldoutput @ output ! $20 col - 0 max spaces str2 count type ;
+
+external
+: dis ( addr -- )  address !
+   BEGIN  instruction stop? UNTIL ;

8080/CPM/src/double.fb.txt

@@ -0,0 +1,57 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Double words                                          11Nov86
+
+Dieses File enthaelt Worte fuer 32-Bit Objekte.
+
+Im Kern bereits enthalten sind:
+
+   2@ 2! 2dup 2drop 2swap dnegate d+
+
+Hier werden definiert:
+
+   2Variable 2Constant 2over d*
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ 2over  2@  2! 2Variable 2Constant                   UH 30Oct86
+
+: 2Variable   Variable  2 allot ;
+: 2Constant   Create , ,  does>  2@ ;
+
+Code 2over   ( 32b1 32b2  -- 32b1 32b2 32b1 )  7 H lxi
+   SP dad    M D mov   H dcx   M E mov  D push
+   H dcx     M D mov   H dcx   M E mov  D push Next   end-code
+--> \\
+Code 2@   ( addr -- 32b )   H pop   H push
+   H inx  H inx   M E mov   H inx   M D mov   H pop   D push
+   M E mov   H inx   M D mov  D push    Next   end-code
+
+Code 2!   ( 32b addr -- )   H pop
+   D pop    E M mov   H inx   D M mov   H inx
+   D pop    E M mov   H inx   D M mov   Next   end-code
+
+\ *** Block No. 2, Hexblock 2
+
+\ d* d-                                                  29Jun86
+
+: d*   ( d1 d2 -- d1*d2 )
+    rot  2over  rot  um*  2swap um* d+ 2swap um* d+ ;
+
+: d-  ( d1 d2 -- d1-d2 ) dnegate d+ ;
+
+
+
+
+
+
+
+
+
+

8080/CPM/src/editor.fb.txt

@@ -0,0 +1,608 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\ Full-Screen Editor                                  UH 02Nov86
+
+Dieses File enthaelt den Full-Screen Editor fuer die CP/M -
+volksFORTH-Version.
+
+Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion
+sowie Unterstuetzung des Shadow-Screen-Konzepts, der view-
+Funktion und des sichtbaren Laden von Screens (showload).
+
+Durch die integrierte Tastaturtabelle (keytable) laesst sich die
+Kommandobelegung der Tasten auf einfache Art und Weise aendern.
+
+Anregungen, Kritik und Verbesserungsvorschlaege bitte an:
+                       U. Hoffmann
+                       Harmsstrasse 71
+                       2300 Kiel
+
+\ *** Block No. 1, Hexblock 1
+
+\ Load Screen for the Editor             UH 03Nov86   UH 27Nov87
+
+Onlyforth    cr
+
+ 1 $1E  +thru
+
+Onlyforth
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+\ String primitves                                       27Nov87
+
+: delete   ( buffer size count -- )
+   over umin dup >r -  2dup  over r@ +  -rot cmove
+   +  r> bl fill ;
+
+: insert   ( string length buffer size -- )
+   rot over umin dup >r -
+   over dup r@ +  rot cmove>   r> cmove  ;
+
+: replace   ( string length buffer size -- )  rot umin cmove ;
+
+
+
+
+
+
+\ *** Block No. 3, Hexblock 3
+
+\ usefull definitions and Editor vocabulary           UH 27Nov87
+
+: blank ( addr len -- )   bl fill ;
+
+: ?enough ( n --)  depth 1- > abort" Not enough Parameters" ;
+
+: ?abort( ( f -- )
+    IF [compile] .(  true abort" !" THEN  [compile] ( ;
+
+Vocabulary Editor
+
+' Forth  | Alias F: immediate
+' Editor | Alias E: immediate
+
+Editor also definitions
+
+
+\ *** Block No. 4, Hexblock 4
+
+\ move cursor with position-checking                     23Nov86
+
+| : c  ( n --)   \ checks the cursor position
+      r# @ +  dup 0 b/blk uwithin not
+       Abort" There is a border!"  r# ! ;
+
+\\
+
+: c  ( n --)   \ goes thru the screens
+   r# @ +  dup b/blk 1- >  IF  1 scr +!  THEN
+   dup 0< IF  -1 scr +!  THEN  b/blk mod  r# ! ;
+
+: c  ( n --)   \ moves cyclic thru the screen
+   r# @ +  b/blk mod  r# ! ;
+
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ calculate addresses                                 UH 31Oct86
+
+| Code *line ( l -- adr )
+    H pop   H dad   H dad   H dad
+    H dad   H dad   H dad   Hpush jmp   end-code
+
+| Code /line ( n -- c l )
+   H pop   L A mov   $3F ani  A E mov  0 D mvi
+   L A mov   ral   A L mov   H A mov   ral   A H mov
+   L A mov   ral   A L mov   H A mov   ral   A H mov
+   L A mov   ral   3 ani     H L mov   A H mov
+   dpush jmp   end-code
+
+\\
+| : *line      ( l -- adr )  c/l * ;
+| : /line      ( n -- c l )  c/l /mod ;
+
+\ *** Block No. 6, Hexblock 6
+
+\ calculate addresses                                 UH 01Nov86
+
+| : top        ( --     )  r# off ;
+| : cursor     ( -- n   )  r# @ ;
+| : 'start     ( -- adr )  scr @ block ;
+| : 'end       ( -- adr )  'start  b/blk + ;
+| : 'cursor    ( -- adr )  'start  cursor  + ;
+| : position   ( -- c l )  cursor  /line ;
+| : line#      ( -- l   )  position nip ;
+| : col#       ( -- c   )  position drop ;
+| : 'line      ( -- adr )  'start  line#  *line + ;
+| : 'line-end  ( -- adr )  'line c/l + 1- ;
+| : #after     ( -- n   )  c/l col# - ;
+| : #remaining ( -- n   )  b/blk cursor - ;
+| : #end       ( -- n   )  b/blk line# *line - ;
+
+
+\ *** Block No. 7, Hexblock 7
+
+\ move cursor directed                                UH 01Nov86
+
+| : curup      c/l negate c ;
+| : curdown    c/l c ;
+| : curleft    -1 c ;
+| : curright   1 c ;
+
+| : +tab  \ 1/4 line forth
+      cursor  $10 / 1+ $10 * cursor - c ;
+
+| : -tab  \ 1/8 line back
+      cursor  8 mod  negate  dup 0=  8 * +  c ;
+
+| : >""end   'start b/blk -trailing nip  b/blk 1- min  r# ! ;
+| : <cr>   #after c ;
+
+
+\ *** Block No. 8, Hexblock 8
+
+\ show border                                         UH 27Nov87
+&15 | Constant dx       1 | Constant dy
+
+| : horizontal ( row -- row' )
+     dup dx 1- at   c/l 2+  0 DO Ascii - emit LOOP 1+ ;
+
+| : vertical ( row -- row' )
+     l/s 0 DO dup dx 1-    at Ascii | emit
+              row dx c/l + at Ascii | emit    1+   LOOP ;
+
+| : border  dy 1- horizontal vertical horizontal drop ;
+
+| : edit-at ( -- )   position swap dy dx d+ at ;
+
+Forth definitions
+: updated?  ( -- f)   scr @ block  2- @  0< ;
+
+\ *** Block No. 9, Hexblock 9
+
+\ display screen                         UH 02Nov86   UH 27Nouho
+Editor definitions  | Variable isfile'        | Variable imode
+
+| : .updated ( -- )  7 0 at
+      updated? IF 4 spaces ELSE ." not " THEN ." updated" ;
+
+| : redisplay   ( line# -- )
+     dup dy +  dx at   *line 'start +  c/l type ;
+
+| : .file ( 'file -- ) [ Dos ] .file  &14 col - 0 max spaces ;
+| : .title   1 0 at isfile@ .file    3 0 at isfile' @ .file
+      5 0 at ." Scr# " scr @ 4 .r  .updated  &10 0 at
+      imode @ IF ." insert   " exit THEN ." overwrite" ;
+
+| : .screen  l/s 0 DO I redisplay LOOP ;
+| : .all   .title .screen ;
+
+\ *** Block No. 10, Hexblock a
+
+\ check errors                                        UH 02Nov86
+
+| : ?bottom  ( -- )  'end  c/l -  c/l -trailing nip
+                      Abort" You would lose a line" ;
+
+| : ?fit ( n -- )  'line c/l -trailing  nip + c/l >
+     IF line# redisplay
+        true Abort" You would lose a char" THEN ;
+
+| : ?end    1 ?fit ;
+
+
+
+
+
+
+
+\ *** Block No. 11, Hexblock b
+
+\ programmer's id                                     UH 02Nov86
+
+$12 | Constant id-len
+Create id   id-len allot   id id-len erase
+
+| : stamp  ( -- )
+     id 1+ count  'start c/l + over - swap  cmove ;
+
+| : ?stamp   ( -- )   updated? IF stamp THEN  ;
+
+| : get-id   ( -- )
+   id c@ ?exit  id on
+   cr ." Enter your ID : "  at?  $10 0 DO Ascii . emit LOOP  at
+   id id-len 2 /string expect  rvsoff  span @ id 1+ c! ;
+
+
+
+\ *** Block No. 12, Hexblock c
+
+\ update screen-display                               UH 02Dec86
+
+| : emptybuf    prev @  2+ dup on  4+ off ;
+
+| : undo  emptybuf  .all ;
+
+| : modified   updated? ?exit  update .updated ;
+
+| : linemodified   modified  line# redisplay ;
+
+| : screenmodified    modified
+     l/s line# ?DO I redisplay LOOP ;
+
+| : .modified ( -- )  dy l/s + 4+ 0 at  scr @ .
+      updated? not IF  ." un"  THEN  ." modified"  ?stamp ;
+
+
+\ *** Block No. 13, Hexblock d
+
+\ leave editor                           UH 02Dec86   UH 23Feb88
+| Variable (pad   (pad off
+| : memtop  ( -- adr)   sp@ $100 - ;
+
+| Create char  1 allot
+
+( | Variable imode ) imode off
+| : setimode   imode on  .title ;
+| : clrimode   imode off .title ;
+| : flipimode ( -- )  imode @ 0= imode !  .title ;
+
+| : done ( -- )
+     ['] (quit is 'quit  ['] (error errorhandler !  quit ;
+
+| : update-exit  ( -- )  .modified  done ;
+| : flushed-exit ( -- )  .modified  save-buffers  done ;
+
+\ *** Block No. 14, Hexblock e
+
+\ handle lines                                        UH 01Nov86
+
+| : (clear-line   'line c/l blank ;
+| : clear-line   (clear-line linemodified ;
+
+| : clear>   'cursor #after blank  linemodified ;
+
+| : delete-line   'line #end c/l  delete screenmodified ;
+
+| : backline   curup delete-line ;
+
+| : (insert-line
+      ?bottom  'line c/l over #end insert (clear-line ;
+
+| : insert-line   (insert-line  screenmodified ;
+
+
+\ *** Block No. 15, Hexblock f
+
+\ handle characters                                   UH 01Nov86
+
+| : delete-char   'cursor #after 1 delete  linemodified ;
+
+| : backspace   curleft  delete-char ;
+
+| : (insert-char   ?end  'cursor 1 over #after insert ;
+
+
+| : insert-char   (insert-char  bl 'cursor c! linemodified ;
+
+| : putchar  ( --)  char c@
+    imode @ IF (insert-char THEN
+    'cursor c!  linemodified  curright ;
+
+
+
+\ *** Block No. 16, Hexblock 10
+
+\ stack lines                                         UH 31Oct86
+
+| Create lines 4 allot    \  { 2+pointer | 2base }
+| : 'lines  ( -- adr)   lines 2@ + ;
+
+| : @line   'lines  memtop u> Abort" line buffer full"
+   'line 'lines c/l cmove  c/l lines +! ;
+
+| : copyline   @line curdown ;
+| : line>buf   @line delete-line ;
+
+| : !line   c/l negate lines +!  'lines 'line c/l cmove ;
+
+| : buf>line   lines @ 0= Abort" line buffer empty"
+     ?bottom    (insert-line  !line   screenmodified ;
+
+
+\ *** Block No. 17, Hexblock 11
+
+\ stack characters                                    UH 01Nov86
+
+| Create chars 4 allot    \  { 2+pointer | 2base }
+| : 'chars  ( -- adr)   chars 2@ + ;
+
+| : @char   'chars 1-  lines 2+ @  u> Abort" char buffer full"
+     'cursor c@ 'chars c!  1 chars +! ;
+
+| : copychar   @char curright ;
+| : char>buf   @char delete-char ;
+
+| : !char   -1 chars +!  'chars c@  'cursor c! ;
+
+| : buf>char   chars @ 0= Abort" char buffer empty"
+     ?end  (insert-char  !char  linemodified ;
+
+
+\ *** Block No. 18, Hexblock 12
+
+\ switch screens                         UH 03Nov86   UH 27Nov87
+
+| Variable r#'             r#'  off
+| Variable scr'            scr' off
+( | Variable isfile' )     isfile@  isfile' !
+
+| : associate \ switch to alternate screen
+     isfile' @ isfile@   isfile' ! isfile !
+     scr' @ scr @ scr' ! scr !   r#' @ r# @ r#' ! r# ! ;
+
+| : mark   isfile@ isfile' !  scr @ scr' !  r# @ r#' ! .title ;
+| : n   ?stamp  1 scr +! .all ;
+| : b   ?stamp -1 scr +! .all ;
+| : a   ?stamp associate .all ;
+
+
+
+\ *** Block No. 19, Hexblock 13
+
+\ shadow screens                                      UH 03Nov86
+
+Variable shadow   shadow off
+
+| : (shadow   isfile@ IF capacity 2/ exit THEN  shadow @ ;
+
+| : >shadow  ?stamp   \ switch to shadow screen
+      (shadow dup  scr @  u> not IF negate THEN scr +! .all ;
+
+
+
+
+
+
+
+
+
+\ *** Block No. 20, Hexblock 14
+
+\ load and show screens                               UH 06Mar88
+
+' name >body &10 + | Constant 'name
+
+| : showoff  ['] exit 'name ! curoff rvsoff  ;
+
+| : show ( -- )  blk @ 0= IF showoff exit THEN
+     >in @ 1- r# !  curoff edit-at curon
+     stop? IF showoff true Abort" Break! " THEN
+     blk @  scr @ -
+     IF  blk @  scr ! rvsoff curoff .all rvson curon THEN ;
+
+| : showload  ( -- )    ?stamp save-buffers
+     ['] show 'name !  curon rvson
+     ['] .status >body push  ['] noop is .status
+     scr @  scr push  scr off  r# push  r# @  (load  showoff ;
+
+\ *** Block No. 21, Hexblock 15
+
+\ find strings                                        UH 01Nov86
+
+| Variable insert-buffer
+| Variable find-buffer
+| : 'insert ( -- addr )  insert-buffer @ ;
+| : 'find   ( -- addr )  find-buffer @ ;
+
+| : .buf ( addr -- )   count type ." |"  &80 col - spaces  ;
+
+| : get ( addr -- )  >r at?  r@ .buf
+    2dup at  r@ 1+ c/l expect  span @ ?dup IF r@ c! THEN
+    at r> .buf ;
+
+| : get-buffers    dy l/s + 2+  dx 1-  2dup  at
+       ." find:    |"  'find   get     swap 1+ swap 2- at
+     ." ? replace: |"  'insert get ;
+
+\ *** Block No. 22, Hexblock 16
+
+\ search for string                      UH 02Nov86   UH 27Nov87
+
+| : skip ( addr -- addr' )  'find c@ + ;
+
+| : find?  ( -- addr T | F )
+     'find count 'cursor #remaining "search ;
+
+| : "find ( -- r# scr )
+    find?  IF skip 'start -  scr @ exit THEN  ?stamp
+    capacity   scr @ 1+
+    ?DO 'find count
+         I   dup 5 5 at 4 .r   block  b/blk "search
+       IF skip I block -  I endloop exit THEN
+       stop? Abort" Break! "
+    LOOP  true Abort" not found!" ;
+
+
+\ *** Block No. 23, Hexblock 17
+
+\ replace strings                        UH 03Nov86   UH 27Nov87
+| : replace? ( -- f )  dy l/s + 3+ dx 3 - at
+      key dup #cr = IF line# redisplay true Abort" Break!" THEN
+      capital Ascii R = ;
+
+| : "mark ( -- )   r# push
+     'find count dup negate c  edit-at  rvson type rvsoff ;
+
+| : (replace  'insert c@  'find c@ - ?fit
+      'find c@ negate c   'cursor #after  'find c@ delete
+      'insert count   'cursor #after  insert
+      'insert c@ c   modified ;
+
+| : "replace   get-buffers
+      BEGIN  "find  dup scr @ - swap scr ! IF .all THEN  r# !
+        "mark replace? IF (replace THEN line# redisplay REPEAT ;
+
+\ *** Block No. 24, Hexblock 18
+
+\ Control-Characters  'normal' CP/M                uho 08May2005
+
+Forth definitions
+
+: Ctrl ( -- c )
+   name 1+ c@  $1F and   state @ IF [compile] Literal THEN ;
+immediate
+
+$7F Constant #del
+
+Editor definitions
+
+\ | : flipimode    imode @ 0= imode ! ;
+
+
+
+
+\ *** Block No. 25, Hexblock 19
+
+\ Try a Screen-Editor 'normal' CP/M                   UH 29Nov86
+
+Create keytable
+Ctrl E c,       Ctrl S c,       Ctrl X c,       Ctrl D c,
+Ctrl I c,       Ctrl J c,       Ctrl O c,       Ctrl K c,
+                                Ctrl P c,       Ctrl L c,
+Ctrl H c,       Ctrl H c,         #del c,       Ctrl G c,
+Ctrl T c,                       Ctrl Y c,       Ctrl N c,
+Ctrl V c,                                       Ctrl Z c,
+   #cr c,       Ctrl F c,       Ctrl A c,
+                                Ctrl \ c,       Ctrl U c,
+Ctrl Q c,         #esc c,                       Ctrl W c,
+Ctrl C c,       Ctrl R c,       Ctrl ] c,       Ctrl B c,
+
+
+here keytable -  Constant #keys
+
+\ *** Block No. 26, Hexblock 1a
+
+\ Try a screen Editor                                 UH 29Nov86
+
+Create: actiontable
+curup           curleft         curdown         curright
+line>buf        char>buf        buf>line        buf>char
+                                copyline        copychar
+backspace       backspace       backspace       delete-char
+insert-char                     delete-line     insert-line
+flipimode                      ( clear-line )   clear>
+<cr>            +tab            -tab
+( top             >""end  )     "replace        undo
+update-exit     flushed-exit  ( showload )      >shadow
+n               b               a               mark ;
+
+
+here actiontable -  2/ 1-   #keys -  ?abort( # of actions)
+
+\ *** Block No. 27, Hexblock 1b
+
+\ find keys                                           UH 01Nov86
+
+| Code findkey ( key -- addr/default )
+     H pop   L A mov   keytable H lxi   #keys $100 * D lxi
+     [[ M cmp 0=
+        ?[ actiontable H lxi  0 D mvi   D dad   D dad
+           M E mov   H inx   M D mov   D push   next ]?
+        H inx   E inr   D dcr   0= ?]
+     ' putchar H lxi   hpush jmp
+  end-code
+
+\\
+| : findkey  ( key -- adr/default )
+  #keys 0 DO  dup  keytable F: I + c@ =
+     IF drop   E: actiontable  F: I 2* + @ endloop exit THEN
+  LOOP drop ['] putchar ;
+
+\ *** Block No. 28, Hexblock 1c
+
+\ allocate buffers                                    UH 01Nov86
+
+c/l 2* | Constant cstack-size
+
+| : nextbuf ( adr -- adr' )   cstack-size + ;
+
+| : ?clearbuffer   pad (pad @ = ?exit
+      pad     dup (pad !
+      nextbuf dup find-buffer   !   'find off
+      nextbuf dup insert-buffer !   'insert off
+      nextbuf dup 0 chars 2!
+      nextbuf     0 lines 2! ;
+
+
+
+
+
+\ *** Block No. 29, Hexblock 1d
+
+\ enter and exit the editor, editor's loop            UH 02Nov86
+| Variable jingle  jingle on    | : bell  07 con! jingle off ;
+
+| : clear-error
+     jingle @ ?exit  dy l/s + 1+ dx  at c/l spaces jingle on ;
+
+| : fullquit    BEGIN  ?clearbuffer edit-at  key dup char c!
+      findkey execute  clear-error REPEAT ;
+
+| : fullerror  ( string --) jingle @ IF bell THEN
+      dy l/s + 1+ dx $16 + at  rvson count type rvsoff
+      &80 col - spaces  scr @ capacity 1- min 0 max scr !
+      .title quit ;
+
+| : install   ( -- )
+     ['] fullquit Is 'quit  ['] fullerror errorhandler !  ;
+
+\ *** Block No. 30, Hexblock 1e
+
+\ enter and exit the Editor                           UH 02Nov86
+
+Forth definitions
+
+: v   ( -- )   E: 'start drop  get-id  install  ?clearbuffer
+               page curoff  border .all  quit ;
+
+: l   ( scr -- )   1 ?enough scr !  E: top  F: v ;
+
+
+
+
+
+
+
+
+
+\ *** Block No. 31, Hexblock 1f
+
+\ savesystem                                       uho 09May2uho
+
+: savesystem    \ save image
+    E: id off  (pad off   savesystem ;
+
+| : >find  ?clearbuffer  >in push
+      bl word count  'find 1+ place
+      bl   'find 1+   dup >r   count   dup >r   + c!
+      r> 2+ 'find c!   bl r> c! ;
+| : %view  ( -- )  >find ' >name 4- @  (view
+   ?dup 0= Abort" hand made"  scr !
+   E: top curdown find? 0=
+   IF ." From Scr # " scr @ u. true Abort" wrong file" THEN
+   skip 'start - 1- r# ! ;
+: view ( -- ) %view scr @ list ;
+: fix ( -- ) %view v ;

8080/CPM/src/fileint.fb.txt

@@ -0,0 +1,608 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\ CP/M 2.2 File-Interface (3.80a)                     UH 05Oct87
+
+Dieses File enthaelt das File-Interface von volksFORTH zu CP/M.
+Damit ist Zugriff auf normale CP/M-Files moeglich.
+Wenn ein File mit USE benutzt wird, beziehen sich alle Worte,
+die mit dem Massenspeicher arbeiten, auf dieses File.
+
+Benutzung:
+  USE <name>       \ benutze ein schon existierendes File
+  FILE <name>      \ erzeuge ein Forthfile mit dem Namen <name>.
+  MAKE <name>      \ Erzeuge ein File mit <name> und ordne
+                   \ es dem aktuellen Forthfile zu.
+  MAKEFILE <name>  \ Erzeuge ein File mit CP/M und FORTH-Namen
+                     <name>.
+  INCLUDE <name>   \ Lade File mit Forthnamen <name> ab Screen 1
+  DOS RESET        \ zum Wechsel von Disketten. (Oh! CP/M)
+
+\ *** Block No. 1, Hexblock 1
+
+\ CP/M 2.2 File-Interface  load-Screen                UH 18Feb88
+OnlyForth
+
+      2 load \ view numbers for this file
+  3   4 thru \ DOS   File Functions
+  5 $11 thru \ Forth File Functions
+$12 $16 thru \ User Interface
+
+File source.fb      \  Define already existing Files
+File fileint.fb     File startup.fbr
+
+' (makeview     Is makeview
+' remove-files  Is custom-remove
+' file-r/w      Is r/w
+' noop          Is drvinit
+ \      include startup.fb \ load Standard System
+
+\ *** Block No. 2, Hexblock 2
+
+\ Build correct view-numbers for this file           UUH 19Nov87
+
+| : fileintview ( -- )  $400 blk @ + ;
+
+' fileintview Is makeview
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 3, Hexblock 3
+
+\ File Control Blocks                                 UH 18Feb88
+Dos definitions also
+| : Fcbyte ( n len -- len' )  Create over c, + does> c@ + ;
+&11 Constant filenamelen
+0              2 | Fcbyte nextfile  immediate
+               1   Fcbyte drive    ' drive | Alias >dosfcb
+ filenamelen 3 -   Fcbyte filename
+               3   Fcbyte extension
+           &21 + \ ex, s1, s2, rc, d0, ... dn, cr
+               2   Fcbyte record    \  r0, r1
+              1+ \ r2
+               2   Fcbyte opened
+               2   Fcbyte fileno
+               2   Fcbyte filesize  \ in 128-Byte-Records
+               4   Fcbyte position
+Constant b/fcb
+
+\ *** Block No. 4, Hexblock 4
+
+\ dos primitives                                      UH 10Oct87
+
+' 2-  | Alias body>             ' 2- | Alias dosfcb>
+
+: drive!     ( drv    --      )     $0E bdos ;
+: search0    ( dosfcb -- dir  )     $11 bdosa ;
+: searchnext ( dosfcb -- dir  )     $12 bdosa ;
+: read-seq   ( dosfcb -- f    )     $14 bdosa dos-error? ;
+: write-seq  ( dosfcb -- f    )     $15 bdosa dos-error? ;
+: createfile ( dosfcb -- f    )     $16 bdosa dos-error? ;
+: size       ( dos    -- size ) dup $23 bdos dosfcb> record @ ;
+: drive@     (        -- drv  )   0 $19 bdosa ;
+: killfile   ( dosfcb --      )     $13 bdos ;
+
+
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ File sizes                                          UH 05Oct87
+
+: (capacity  ( fcb -- n )  \ filecapacity in blocks
+    filesize @  rec/blk  u/mod swap 0= ?exit 1+ ;
+
+: in-range ( block fcb -- )
+    (capacity u< not Abort" beyond capacity!" ;
+
+Forth definitions
+
+: capacity ( -- n )    isfile@  (capacity ;
+
+Dos definitions
+
+
+
+
+\ *** Block No. 6, Hexblock 6
+
+\ (open                                               UH 18Feb88
+
+: (open  ( fcb -- )
+    dup opened @ IF drop exit THEN   dup position  0. rot 2!
+    dup >dosfcb openfile  Abort" not found!"  dup opened on
+    dup >dosfcb size  swap filesize ! ;
+
+: (make  ( fcb -- )
+   dup >dosfcb killfile
+   dup >dosfcb createfile Abort" directory full!"
+   dup position 0. rot 2!
+   dup filesize off   opened on  offset off ;
+
+: file-r/w  ( buffer block fcb f  -- f )
+    over 0= Abort" no Direct Disk IO supported! "
+    >r  dup  (open   2dup in-range r> (r/w ;
+
+\ *** Block No. 7, Hexblock 7
+
+\ Print Filenames                                     UH 10Oct87
+
+: .file ( fcb -- ) 0 case? IF ." DIRECT"  exit THEN
+         fcb dosfcb> case? IF ." DEFAULT" exit THEN
+         body> >name .name ;
+
+: .drive   ( fcb -- ) drive c@ ?dup 0=exit
+     [ Ascii A 1- ] Literal + emit  Ascii : emit ;
+
+: .dosfile ( fcb -- )  dup filename  8 -trailing type
+    Ascii . emit           extension 3           type ;
+
+
+
+
+
+
+\ *** Block No. 8, Hexblock 8
+
+\ Print Filenames                                     UH 10Oct87
+
+: tab ( -- ) col &59 > IF cr exit THEN
+        &20  col &20 mod  -  0 max  spaces ;
+
+: .fcb  ( fcb -- )  dup fileno @  3 u.r tab
+     dup .file tab dup .drive dup .dosfile
+     tab dup opened @ IF ." opened" ELSE ." closed" THEN
+     3 spaces  base push  decimal   (capacity  3 u.r  ."  kB" ;
+
+
+
+
+
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+\ Filenames                                           UH 05Oct87
+
+: !name ( addr len fcb -- )
+     dup >r filename filenamelen bl fill
+     over 1+ c@  Ascii : =
+     IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r>
+     ELSE 0 THEN  r@ drive c! r> dup filename 2swap
+     filenamelen 1+ min bounds
+     ?DO  I c@ Ascii . =
+         IF drop dup  extension ELSE  I c@ over c! 1+ THEN
+     LOOP 2drop ;
+
+: !fcb  ( fcb -- )  dup opened off   name count rot !name ;
+
+
+
+
+\ *** Block No. 10, Hexblock a
+
+\ Print Directory                                     UH 18Nov87
+
+| Create dirbuf  b/rec allot    dirbuf b/rec erase
+| Create fcb0    b/fcb allot    fcb0   b/fcb erase
+
+| : wildchard?  ( f c -- f' )  Ascii * = IF drop Ascii ? THEN ;
+| : (expand ( addr len -- )  false -rot bounds
+     ?DO  I c@  wildchard? dup ?dup IF I c! THEN  LOOP drop ;
+| : expand ( fcb -- )  \ expand * to ???
+     dup filename 8 (expand   extension 3 (expand ;
+
+: (dir  ( addr len -- )
+    fcb0 !name fcb0 expand  dirbuf dma!  fcb0 >dosfcb search0
+    BEGIN dup dos-error? not
+    WHILE  $20 * dirbuf + dosfcb> tab .dosfile
+           fcb0 >dosfcb searchnext  stop? UNTIL  drop ;
+
+\ *** Block No. 11, Hexblock b
+
+\ File List                                           UH 10Oct87
+
+User file-link   file-link off
+
+| : #file ( -- n )   file-link @ dup IF fileno c@ THEN 1+ ;
+
+
+Forth definitions
+
+: forthfiles ( -- )
+   file-link @
+   BEGIN dup WHILE  cr  dup .fcb  @ stop? UNTIL drop ;
+
+Dos definitions
+
+
+
+\ *** Block No. 12, Hexblock c
+
+\ Close a file                                        UH 10Oct87
+
+' save-buffers >body $0C + @ | Alias backup
+
+| : filebuffer?  ( fcb -- fcb bufaddr/flag )
+   prev  BEGIN @ dup WHILE  2dup 2+ @ = UNTIL ;
+
+| : flushfile  ( fcb -- )  \ flush file buffers
+     BEGIN  filebuffer?  ?dup  WHILE
+            dup backup  emptybuf  REPEAT  drop ;
+
+: (close  ( fcb -- )  \ close file in fcb
+   dup flushfile
+   dup opened  dup @ 0= IF 2drop exit THEN  off
+   >dosfcb closefile Abort" not found!" ;
+
+
+\ *** Block No. 13, Hexblock d
+
+\ Create fcbs                                         UH 10Oct87
+
+: !files ( fcb -- )  dup  isfile ! fromfile ! ;
+
+' r@ | Alias newfcb
+
+Forth definitions
+
+: File  ( -- )
+   Create here >r   b/fcb allot  newfcb b/fcb erase
+          last @ count $1F and  newfcb !name
+          #file   newfcb fileno !
+          file-link @  newfcb nextfile !   r> file-link !
+   Does> !files ;
+
+: direct     0 !files ;
+
+\ *** Block No. 14, Hexblock e
+
+\ flush buffers & misc.                  UH 10Oct87   UH 28Nov87
+Dos definitions
+
+: save-files  ( -- )  file-link BEGIN  @ ?dup  WHILE
+     dup opened @ IF dup >dosfcb closefile drop THEN  REPEAT ;
+
+' save-files Is save-dos-buffers
+
+\ : close-files  ( -- )  file-link
+\     BEGIN  @ ?dup  WHILE  dup (close  REPEAT ;
+
+Forth definitions
+
+: file?   isfile@ .file ;  \ print current file
+
+: list  ( n -- )   3 spaces  file? list ;
+
+\ *** Block No. 15, Hexblock f
+
+\ words for viewing                                   UH 10Oct87
+
+Forth definitions
+
+| $200 Constant viewoffset \ max. %512 kB files
+
+: (makeview  ( -- n )  \ calc. view filed for a name
+   blk @ dup  0= ?exit
+   loadfile @ ?dup IF fileno @ viewoffset * + THEN ;
+
+: (view      ( blk -- blk' ) \ select file and leave block
+   dup 0=exit
+   viewoffset u/mod  file-link
+   BEGIN @ dup WHILE 2dup fileno @ = UNTIL
+   !files drop ;        \ not found: direct access
+
+
+\ *** Block No. 16, Hexblock 10
+
+\ FORGETing files                                     UH 10Oct87
+
+| : remove?      ( dic symb addr -- dic symb addr f )
+     dup heap? IF  2dup u> exit THEN 2 pick over 1+ u< ;
+
+
+| : remove-files ( dic symb -- dic symb )  \ flush files !
+     isfile@      remove? nip  IF direct       THEN
+     fromfile @   remove? nip  IF fromfile off THEN
+     file-link
+     BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT
+     file-link remove ;
+
+
+
+
+
+\ *** Block No. 17, Hexblock 11
+
+\ print a list of all buffers                         UH 20Oct86
+
+: .buffers
+   prev BEGIN  @ ?dup WHILE  stop? abort" stopped"
+           cr dup u. dup 2+ @ dup 1+
+           IF ."    Block: " over 4+ @ 5 .r
+              ."    File : " [ Dos ] .file
+              dup 6 + @ 0< IF ."     updated" THEN
+           ELSE ." Buffer empty" drop THEN  REPEAT ;
+
+
+
+
+
+
+
+
+\ *** Block No. 18, Hexblock 12
+
+\ File Interface User words                           UH 11Oct87
+
+| : same ( addr -- )  >in ! ;
+: open      isfile@ (open   offset off ;
+: close     isfile@ (close ;
+: assign    close   isfile@ !fcb  open ;
+: make      isfile@ dup !fcb   (make ;
+
+| : isfile?  ( addr -- addr f )    \ is adr a fcb?
+  file-link BEGIN  @ dup 0=exit 2dup body> = UNTIL drop true ;
+
+: use       >in @ name find \ create a fcb if not present
+            IF isfile? IF execute drop  exit THEN THEN drop
+            dup same File   same ' execute  open ;
+
+
+
+\ *** Block No. 19, Hexblock 13
+
+\ File Interface User words                           UH 25May88
+
+: makefile     >in @   File  dup  same ' execute  same make ;
+: emptyfile    isfile@ >dosfcb createfile ;
+
+: from         isfile push use ;
+: loadfrom     ( n -- )
+               isfile push  fromfile push  use load   close ;
+: include      1 loadfrom ;
+
+: eof ( -- f ) isfile@  dup filesize @ swap record @ = ;
+
+: files        " *.*" count (dir ;
+: files"       Ascii " word count 2dup upper (dir ;
+
+' files Alias dir     ' files" Alias dir"
+
+\ *** Block No. 20, Hexblock 14
+
+\ extend Files                                        UH 20Nov87
+
+| : >fileend   isfile@ >dosfcb size drop ;
+
+| : addblock  ( n -- )  \ add block n to file
+     dup buffer under   b/blk  bl fill
+     isfile@   rec/blk  over filesize +!  false file-r/w
+     IF close Abort" disk full!" THEN ;
+
+: more ( n -- )   open >fileend
+   capacity swap bounds  ?DO I addblock LOOP close
+   open close ;
+
+: Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ;
+0   Drive: a:   Drive: b:   Drive: c:   Drive: d:
+5 + Drive: j:  drop
+
+\ *** Block No. 21, Hexblock 15
+
+\ save memory-image as disk-file                      UH 29Nov86
+
+Forth definitions
+
+: savefile ( from count -- ) \ filename
+   isfile push  makefile bounds
+   ?DO I dma!  isfile@ >dosfcb write-seq  Abort" disk full!"
+       b/rec +LOOP  close ;
+
+
+
+
+
+
+
+
+
+\ *** Block No. 22, Hexblock 16
+
+\ Status                                              UH 10OCt87
+
+
+: .blk ( -- )   blk @ ?dup 0=exit
+   dup 1 = IF cr file? THEN base push hex ."  Blk " . ?cr ;
+
+' .blk Is .status
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 23, Hexblock 17
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 24, Hexblock 18
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 25, Hexblock 19
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 26, Hexblock 1a
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 27, Hexblock 1b
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 28, Hexblock 1c
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 29, Hexblock 1d
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 30, Hexblock 1e
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 31, Hexblock 1f
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

8080/CPM/src/hashcash.fb.txt

@@ -0,0 +1,95 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\ HashCash Suchalgorithmus                            UH 11Nov86
+
+Ein Algorithmus, der die Dictionarysuche beschleunigt:
+Zuerst wird uebr das gesucht Wort gehasht und in in einer
+Tabelle nachgesehen. Schlaegt der Versuch fehl, wird ganz normal
+gesucht. Suchzeit geht auf ca. 70-80% gegenueber normalem Suchen
+herunter.
+
+Hinzu kommen die Worte:
+cash, hash-thread, erase-cash, 'cash, und found?
+
+Im Kernal neudefiniert oder gepatched werden muessen:
+(find, hide, reveal, forget-words
+
+(find und (forget benutzen jejweils die alten Worte. Sie muessen
+umbenannt oder in die neuen Worte eingebettet werden.
+
+\ *** Block No. 1, Hexblock 1
+
+\ Hash Cash fuer volksFORTH                           UH 11Nov86
+
+Create cash $200 allot
+
+' Forth >body Constant hash-thread
+: erase-cash ( -- ) cash $200 erase ;  erase-cash
+
+1 3 +thru
+
+patch (find
+( patch forget-words )  ' forget-words \ forget-words
+   dup  ' clear   >body   6 + ! \ liegt auf einer ungluecklichen
+   dup  ' (forget >body $12 + ! \ Adresse, sodass das automa-
+   dup  ' empty   >body   8 + ! \ tische Patchen nicht klappt.
+        ' save    >body    4+ !
+patch hide   patch reveal    forget (patch  save
+
+\ *** Block No. 2, Hexblock 2
+
+\ 'cash found? hfind                                  UH 23Oct86
+
+: 'cash ( nfa -- 'cash )
+    count $1F and  under bounds
+    ?DO  I c@ +  LOOP   $FF and   2*  cash + ;
+
+: found? ( str nfa -- f )
+   count rot count rot over = IF swap -text 0= exit THEN
+   drop 2drop false ;
+
+: (find ( str thread -- str false | nfa true )
+   dup hash-thread -  IF (find exit THEN
+   drop dup 'cash @  2dup found?   IF nip true exit THEN
+   drop   hash-thread (find   dup 0= ?exit   over dup 'cash ! ;
+
+
+
+\ *** Block No. 3, Hexblock 3
+
+\ Kernal changes                                      UH 23Oct86
+
+' hide >body @  | Alias last?
+
+: hide   last? IF  0   over 'cash !  2- @ current @ !  THEN ;
+
+: reveal last? IF  dup  dup 'cash !  2-   current @ !  THEN ;
+
+' clear >body 6 + @ | Alias forget-words
+
+| : forget-words  erase-cash forget-words ;
+
+: .cash   cash $200 bounds DO  I @ ?dup IF .name THEN  2 +LOOP ;
+
+
+
+
+\ *** Block No. 4, Hexblock 4
+
+\ patching                                            UH 23Oct86
+
+: (patch ( new old -- )
+    ['] cash 0 DO
+      i @ over = IF cr I u.  over I ! THEN  LOOP 2drop ;
+
+: patch \ name
+   >in @ '  swap >in !   dup >name 2-  context push  context ! '
+   (patch ;
+
+
+
+
+
+
+

8080/CPM/src/include.fb.txt

@@ -0,0 +1,171 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\ include for stream sources for cp/m                phz 30aug23
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ load screen                                        phz 02sep23
+
+  onlyforth dos also forth definitions
+
+  : idos-error?  ( n -- f )  0<> ;
+  : iread-seq  ( dosfcb -- f )  $14 bdosa  idos-error? ;
+  : cr+ex@  ( fcb -- cr+256*ex )
+    dup &34 + c@  swap &14 + c@ $100 * + ;
+  : cr+ex!  ( cr+256*ex fcb -- )
+    >r $100 u/mod  r@ &14 + c!  r> &34 + c! ;
+
+  1 7 +thru
+
+
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+\ fib /fib #fib eolf?                                phz 09okt24
+
+  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 ;
+
+
+
+\ *** Block No. 3, Hexblock 3
+
+\ incfile incpos inc-fgetc                           phz 02sep23
+
+  variable incfile
+  variable increc
+  variable rec-offset
+  $80 constant dmabuf    | $ff constant dmabuf-last
+
+  : readrec  ( fcb -- f )
+    dup cr+ex@ increc !
+    rec-offset off  dmabuf dma!  drive iread-seq ;
+
+  : inc-fgetc  ( -- c )
+    rec-offset @ b/rec u< 0=
+      IF incfile @ readrec IF ctrl-z exit THEN THEN
+    rec-offset @ dmabuf + c@  1 rec-offset +! ;
+
+
+\ *** Block No. 4, Hexblock 4
+
+\ 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 ;
+
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ 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 ;
+
+
+\ *** Block No. 6, Hexblock 6
+
+\ interpret-via-tib inner-include                    phz 02sep23
+
+  : interpret-via-tib
+  BEGIN freadline >r .status >in off  interpret  r> UNTIL ;
+
+  : include-inner ( -- )
+  increc push  0 isfile@ cr+ex!
+  isfile@ readrec Abort" can't read start of file"
+  probe-for-fb IF 1 load exit THEN
+  incfile push  isfile@ incfile !
+  savetib >r  interpret-via-tib close  r> restoretib ;
+
+
+
+
+
+
+\ *** Block No. 7, Hexblock 7
+
+\ include                                            phz 02sep23
+
+  : include ( -- )
+  rec-offset push  isfile push  fromfile push
+  use  cr file?
+  include-inner
+  incfile @
+    IF increc @ incfile @ cr+ex!
+    incfile @ readrec Abort" error re-reading after include"
+    THEN ;
+
+
+
+
+
+
+
+\ *** Block No. 8, Hexblock 8
+
+\ \                                                  phz 02sep23
+
+  : (stashquit  stash[ stash> !  incfile off  increc off
+    (quit ;
+  : stashrestore  ['] (stashquit IS 'quit ;
+  ' stashrestore IS 'restart
+
+  : \  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 ;
+
+
+

8080/CPM/src/install.fb.txt

@@ -0,0 +1,95 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Install Editor
+
+Dieses File enthaelt einen Installer fuer den Editor.
+
+Es werden nacheinander die Tasten erfragt, die einen bestimmten
+Befehl ausloesen sollen.
+
+Damit ist es moeglich, die Tastatur an die individuellen
+Beduerfnisse anzupassen.
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ install Editor                                      UH 17Nov86
+
+Onlyforth Editor also  save   warning on
+
+: tab      &20 col &20 mod - spaces ;
+: .key ( c -- )
+    dup $7E > IF ." $" u. exit THEN
+    dup bl  < IF ." ^" [ Ascii A 1- ] Literal +  THEN emit ;
+
+: install   \ install editor's keyboard
+   page ." Entsprechende Tasten druecken. (Blank uebernimmt.)"
+   #keys 0 ?DO  cr I 2* actiontable + @ >name .name
+     tab ." : " I keytable + dup c@ .key   tab ." -> "
+     key dup bl = IF drop dup c@ THEN  dup .key  swap c!
+   LOOP ;
+-->
+
+\ *** Block No. 2, Hexblock 2
+
+\ define action-names                                 UH 29Nov86
+: :a ( addr -- adr' )  dup @ Alias  2+ ;
+actiontable
+:a up          :a left         :a down        :a right
+:a push-line   :a push-char    :a pull-line   :a pull-char
+                               :a copy-line   :a copy-char
+:a backspace   :a backspace    :a backspace   :a delete-char
+:a insert-char                 :a delete-line :a insert-line
+:a flipimode                 ( :a erase-line) :a clear-to-right
+:a new-line    :a +tab         :a -tab
+( :a home        :a to-end )   :a search      :a undo
+:a update-exit :a flushed-exit ( :a showload ):a shadow-screen
+:a next-Screen :a back-Screen  :a alter-Screen :a mark-screen
+drop
+
+warning off  install  empty
+
+\ *** Block No. 3, Hexblock 3
+
+                                                      UH 17Nov86
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 4, Hexblock 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

8080/CPM/src/port8080.fb.txt

@@ -0,0 +1,38 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\ 8080-Portzugriff                                    UH 11Nov86
+
+Dieses File enthaelt Definitionen um die 8080-Ports ueber 8-Bit
+Adressen anzusprechen.
+
+Der Code ist leider selbstmodifizierend, da beim 8080 die
+Portadresse im Code ausdruecklich angegeben werden muss.
+
+Sollte dies unerwuenscht sein und ein Z80-Komputer vorliegen,
+kann auch das File portz80.scr benutzt werden, indem die
+Z80-IO-Befehle (16Bit-Adressen) benutzt werden.
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ 8080-Portzugriff pc@, pc!                              15Jul86
+
+' 0 | Alias patch
+
+Code pc@ ( addr -- c )
+   H pop   L A mov   here 4 + sta   patch in
+   0 H mvi   A L mov   Hpush jmp   end-code
+
+Code pc! ( c addr -- )
+   H pop   L A Mov   here 6 + sta   H pop   L A mov   patch out
+   Next end-code
+
+
+
+
+

8080/CPM/src/portz80.fb.txt

@@ -0,0 +1,57 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\ Z80-Portzugriff                                     UH 05Nov86
+
+Dieses File enthaelt Definitionen um die Z80-Ports ueber 16-Bit
+Adressen anzusprechen.
+
+Einige Komputer, so die der Schneider Serie dekodieren ihre
+Ports etwas unkonventionell, sodass sie unbedingt ueber 16-Bit
+Adressen angesprochen werden muessen.
+Im allgemeinen sollte es ausreichen 8-Bit Adressen zu benutzen.
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ Z80-Portaccess Extending 8080-Assembler             UH 05Nov86
+
+Assembler definitions
+
+| : Z80-io ( base -- )  \ define special Z80-io instruction
+     Create c,
+     Does> ( reg -- )  $ED c, c@ swap 8 * + c, ;
+
+$40 Z80-io (c)in
+$41 Z80-io (c)out
+
+Forth definitions
+
+-->
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+\ store and fetch values  with 16-bit port-adresses   UH 05Nov86
+
+Code pc@ ( 16b -- 8b ) \ fetch 8-bit value from 16-bit port-addr
+   H pop   IP push   H B mvx   L (c)in   0 H mvi
+   IP pop  hpush jmp
+end-code
+
+Code pc! ( 8b 16b -- ) \ store 8-bit value to 16-bit port-addr
+   H pop   D pop   IP push   H B mvx   E (c)out
+   IP pop   Next
+end-code
+
+
+
+
+

8080/CPM/src/primed.fb.txt

@@ -0,0 +1,57 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Primitivst Editor zur Installation                 UH 17Nov86
+
+Da zur Installationszeit der Full-Screen Editor noch nicht
+funtionsfaehig ist, muessen die zu aendernden Screens auf eine
+andere Weise ge{nder werden: mit dem primitivst Editor PRIMED,
+der nur ein Benutzer wort enthaelt:
+
+Benutzung: Mit "nn LIST" Screen nn zum editieren Anwaehlen,
+  dann mit "ll NEW" den Screen aendern. Es koennen immer nur
+  ganze Zeilen neu geschrieben werden. ll gibt an, ab welcher
+  Zeilennummer neue Zeilen eingeben werden sollen. Die Eingabe
+  einer leeren Zeile (nur RETURN) bewirkt den Abruch von NEW.
+  Nach jeder Eingabe von RETURN wird die eingegebene Zeile in
+  den Screen uebernommen, und der ganze Screen zur Kontrolle
+  nocheinmal ausgegeben.
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ primitivst Editor PRIMED                            UH 17Nov86
+
+| : !line ( adr count line# -- )
+      scr @ block  swap c/l * +  dup c/l bl fill
+      swap cmove update ;
+
+: new ( n -- )
+   l/s 1+ swap
+   ?DO cr  I .
+      pad c/l expect   span @ 0= IF leave THEN
+      pad  span @  I !line   cr  scr @ list  LOOP ;
+
+
+
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+\ PRIMED Demo-Screen
+
+
+
+Dieser Text entstand durch: "2 LIST  4 NEW" mit anschliessender
+Eingabe dieses Textes
+Die Kopfzeile (Zeile 0) wurde spaeter durch Verlassen von new
+durch Eingabe einer leeren Zeile (nur RETURN) und Neustart mit
+"0 NEW" erzeugt.
+                  Ulrich Hoffmann
+
+
+
+
+
+

8080/CPM/src/printer.fb.txt

@@ -0,0 +1,304 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Printer Interface                                     08Nov86
+
+Dieses File enthaelt das Printer Interface zwischen volksFORTH
+und dem Drucker.
+
+Damit ist es moeglich Source-Texte auf bequeme Art und Weise
+in uebersichtlicher Form auszudrucken (6 auf eine Seite).
+
+In Verbindung mit dem Multitasker ist es moeglich, auch Texte im
+Hintergrund drucken zu lassen und trotztdem weiterzuarbeiten.
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ Printer Interface Epson RX80                           18Aug86
+\ angepasst auf M 130i                                 07dec85we
+
+Onlyforth
+
+Variable shadow         capacity 2/ shadow !   \ s. Editor
+
+Vocabulary Printer   Printer definitions also
+| Variable printsem   printsem off
+
+     01 +load  04 0C +thru        \ M 130i - Printer
+\ 01 03 +thru  06 0C +thru        \ Fujitsu - Printer
+
+Onlyforth
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+\ Printer  p! and controls                            UH 02Nov87
+
+| : ready? ( -- f ) [ Dos ]  0 &15 biosa 0= not ;
+
+: p!  ( n --)   BEGIN  pause
+   stop? IF printsem unlock true abort" stopped! " THEN
+   ready?  UNTIL  [ Dos ]  5 bios ;
+
+| : ctrl:  ( 8b --)   Create c,   Does>  ( --)   c@ p! ;
+
+07   ctrl: BEL       7F | ctrl: DEL        0D | ctrl: RET
+1B | ctrl: ESC       0A   ctrl: LF         0C   ctrl: FF
+0F | ctrl: (+17cpi   12 | ctrl: (-17cpi
+
+
+
+
+\ *** Block No. 3, Hexblock 3
+
+\ Printer Escapes                                        24dec85
+
+| : esc:  ( 8b --)   Create c,   does>  ( --)   ESC c@ p! ;
+
+Ascii 0   esc: 1/8"       Ascii 1   esc: 1/10"
+Ascii 2   esc: 1/6"       Ascii T   esc: suoff
+Ascii N   esc: +jump      Ascii O   esc: -jump
+Ascii G   esc: +dark      Ascii H   esc: -dark
+\ Ascii 4   esc: +cursive   Ascii 5   esc: -cursive
+
+
+| : ESC2  ( 8b0 8b1 --)   ESC p! p! ;
+
+| : on:  ( 8b --)  Create c,  does>  ( --)  ESC c@ p!  1 p! ;
+| : off: ( 8b --)  Create c,  does>  ( --)  ESC c@ p!  0 p! ;
+
+
+\ *** Block No. 4, Hexblock 4
+
+\ Printer Escapes                                        29jan86
+
+Ascii W   on:  +wide    Ascii W   off: -wide
+Ascii -   on:  +under   Ascii -   off: -under
+Ascii S   on:  sub      Ascii S   off: super
+Ascii P   on:  (10cpi   Ascii P   off: (12cpi
+
+: 10cpi     (-17cpi  (10cpi  ;
+: 12cpi     (-17cpi  (12cpi  ;
+: 17cpi     (10cpi   (+17cpi ;
+
+: lines  ( #.of.lines --)   Ascii C ESC2 ;
+: "long  ( inches --)   0 lines p! ;
+: american   0 Ascii R ESC2 ;
+: german   2 Ascii R ESC2 ;
+: normal   12cpi  american  suoff 1/6" 0C "long RET ;
+
+\ *** Block No. 5, Hexblock 5
+
+\ Printer Escapes                                        16Jul86
+
+| : esc:  ( 8b --)   Create c,   does>  ( --)   ESC c@ p! ;
+
+Ascii 0   esc: 1/8"       Ascii 1   esc: 1/10"
+Ascii 2   esc: 1/6"       Ascii T   esc: suoff
+Ascii N   esc: +jump      Ascii O   esc: -jump
+Ascii G   esc: +dark      Ascii H   esc: -dark
+Ascii 4   esc: +cursive   Ascii 5   esc: -cursive
+Ascii M   esc: 12cpi      Ascii P | esc: (-12cpi
+
+: 10cpi   (-12cpi (-17cpi ;
+: 17cpi   (-12cpi (+17cpi ;
+
+' 10cpi   Alias pica      ' 12cpi   Alias elite
+
+
+\ *** Block No. 6, Hexblock 6
+
+\ Printer Escapes                                        16Jul86
+
+| : ESC2  ( 8b0 8b1 --)   ESC p! p! ;
+
+| : on:  ( 8b --)  Create c,  does>  ( --)  ESC c@ p!  1 p! ;
+| : off: ( 8b --)  Create c,  does>  ( --)  ESC c@ p!  0 p! ;
+
+Ascii W   on:  +wide    Ascii W   off: -wide
+Ascii -   on:  +under   Ascii -   off: -under
+Ascii S   on:  sub      Ascii S   off: super
+Ascii p   on:  +prop    Ascii p   off: -prop
+: lines  ( #.of.lines --)   Ascii C ESC2 ;
+: "long  ( inches --)   0 lines p! ;
+: american   0 Ascii R ESC2 ;
+: german     2 Ascii R ESC2 ;
+: normal   12cpi  american  suoff 1/6" 0C "long RET ;
+
+\ *** Block No. 7, Hexblock 7
+
+\ Printer Output                                         04Jul86
+
+: prinit ;  \ initializing Printer
+
+| Variable pcol   pcol off      | Variable prow   prow off
+| : pemit  ( 8b --)   p!  1 pcol +! ;
+| : pcr  ( --)   RET LF  1 prow +!  pcol off ;
+| : pdel  ( --)   DEL  pcol @ 1- 0 max pcol ! ;
+| : ppage  ( --)   FF  prow off  pcol off ;
+| : pat  ( row col --)   over  prow @ <  IF  ppage  THEN
+   swap  prow @ -  0 ?DO  pcr  LOOP
+   dup  pcol @ <  IF  RET  pcol off  THEN  pcol @ - spaces ;
+| : pat?  ( -- row col)   prow @  pcol @ ;
+| : ptype  ( adr len --)
+ dup pcol +!  bounds ?DO  I c@ p!  LOOP ;
+
+
+\ *** Block No. 8, Hexblock 8
+
+\ Printer output                                         28Jun86
+
+| Output: >printer   pemit pcr ptype pdel ppage pat pat? ;
+
+Forth definitions
+
+: print   >printer  normal ;
+
+: printable?  ( char -- f)   bl  Ascii ~  uwithin ;
+
+
+
+
+
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+\ Variables and Setup                                    23Oct86
+
+Printer definitions
+
+$00 | Constant logo   | Variable pageno
+| Create scr#s   $0E allot  \ enough room for 6 screens
+
+| : header  ( -- )
+ 12cpi  4 spaces   ." Page No " +dark pageno @ 2 .r
+ $0D spaces  ."  volksFORTH83 der FORTH-Gesellschaft eV "
+ 5 spaces  file?  -dark 1 pageno +! 17cpi ;
+
+
+
+
+
+
+\ *** Block No. 10, Hexblock a
+
+\ Print 2 screens across on a page                       03dec85
+
+| : text?  ( scr# -- f)   block  dup c@  printable?
+  IF  b/blk -trailing  nip  0=  THEN  0=  ;
+
+| : pr  ( scr# --)    dup  capacity 1- u>  IF  drop logo  THEN
+ 1 scr#s +!  scr#s dup @ 2* + ! ;
+
+| : 2pr  ( scr#1 scr#2 line# --)  cr  dup 2 .r space  c/l * >r
+ pad $101 bl fill  swap block  r@ +  pad c/l cmove
+ block r> + pad c/l + 1+ c/l cmove  pad $101 -trailing type ;
+
+| : 2scr  ( scr#1 scr#2 --)    cr cr  $1E spaces
+ +wide +dark over 4 .r  $1C spaces  dup 4 .r  -wide -dark
+ cr  l/s 0 DO  2dup  I 2pr  LOOP  2drop ;
+
+
+\ *** Block No. 11, Hexblock b
+
+\ Printer 6 screens on a page                            03dec85
+
+| : pr-start  ( --)   scr#s off  1 pageno ! ;
+
+| : pagepr  ( --)   header  scr#s off  scr#s 2+
+ 3 0 DO  dup @  over 6 + @  2scr  2+  LOOP  drop  page ;
+
+| : shadowpr  ( --)   header  scr#s off  scr#s 2+
+ 3 0 DO  dup @  over 2+ @  2scr  4 +  LOOP  drop  page ;
+
+| : pr-flush  ( -- f)   scr#s @  dup   \ any screens left over?
+ IF  BEGIN  scr#s @ 5 <  WHILE  -1 pr  REPEAT  logo pr  THEN
+ 0<> ;
+
+
+
+
+\ *** Block No. 12, Hexblock c
+
+\ Printer 6 screens on a page                            23Nov86
+Forth definitions
+
+: pthru  ( first last --)
+ printsem lock  output push  print  pr-start  1+ swap
+ ?DO  I text?  IF  I pr  THEN  scr#s @ 6 = IF  pagepr  THEN
+ LOOP  pr-flush IF  pagepr  THEN  printsem unlock ;
+
+: document  ( first last --)
+   isfile@ IF capacity 2/ shadow ! THEN
+   printsem lock  output push  print  pr-start  1+ swap
+   ?DO  I text?  IF  I pr  I shadow @ + pr  THEN
+        scr#s @ 6 = IF  shadowpr  THEN  LOOP
+   pr-flush  IF  shadowpr  THEN  printsem unlock ;
+
+: listing  ( --)  0  capacity 2/ 1- document ;
+
+\ *** Block No. 13, Hexblock d
+
+\ Printerspool                                           03Nov86
+
+\needs Task \\
+
+| Input: noinput    0  false  drop  2drop  ;
+
+
+$100 $200  noinput Task spooler
+
+keyboard
+
+: spool   ( from to -- )
+   isfile@  spooler 3 pass  isfile !  pthru  stop ;
+
+
+
+
+\ *** Block No. 14, Hexblock e
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 15, Hexblock f
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

8080/CPM/src/relocate.fb.txt

@@ -0,0 +1,57 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Relocate System                                       11Nov86
+
+Dieses File enthaelt das Utility-Wort BUFFERS.
+Mit ihm ist es moeglich die Zahl der Disk-Buffers festzulegen,
+die volksFORTH benutzt. Voreingestellt sind 4 Buffer.
+
+Benutzung:            nn BUFFERS
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ Relocate a system                                      16Jul86
+
+| : relocate-tasks ( mainup -- )  up@ dup
+     BEGIN 2+ under @  2dup - WHILE rot drop REPEAT  2drop ! ;
+
+| : relocate   ( stacklen rstacklen -- )
+     2dup +  b/buf +  2+  limit origin -
+         u> abort" kills all buffers"
+     over  pad $100 +  origin -   u< abort" cuts the dictionary"
+     dup  udp @ $40 +
+         u< abort" a ticket to the moon with no return ..."
+     flush  empty  over +  origin +
+     origin $0A + !                \ r0
+     origin +  dup  relocate-tasks \ multitasking link
+     6 -  origin 8 + !             \ s0
+     cold ;                                       -->
+
+\ *** Block No. 2, Hexblock 2
+
+\ bytes.more  buffers                                    29Jun86
+
+| : bytes.more   ( n+-  -- )
+   up@  origin -  +  r0 @ up@ -  relocate ;
+
+: buffers      ( +n   -- )
+   b/buf *  4+  limit  r0 @ -  swap  -  bytes.more ;
+
+
+
+
+
+
+
+
+

8080/CPM/src/savesys.fb

@@ -0,0 +1 @@
+\\ savesystem                                            11Nov86                                                                Dieses File enthaelt das Utility-Wort SAVESYSTEM.                                                                               Mit ihm kann man das gesamte System als File auf Disk schreiben.                                                                Achtung:                                                           Es wird SAVE ausgefuehrt, daher ist nach SAVESYSTEM             der Heap geloescht!                                                                                                          Benutzung:     SAVESYSTEM <filename>                                                                                                                                                                                                                                                                                                                                                            \ savsystem                                              05Nov86                                                                : savesystem \ filename                                            save  $100 here over -  savefile ;                                                                                                                                                           \\ Einfaches savesystem                                  18Aug86                                                                | : message ( -- )                                                 base push decimal                                               cr ." ready for SAVE " here 1-  $100  / u.                      ." VOLKS4TH.COM" cr ;                                                                                                        : savesystem ( -- )    save message bye ;                                                                                                                                                       

8080/CPM/src/savesys.fb.txt

@@ -0,0 +1,38 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ savesystem                                            11Nov86
+
+Dieses File enthaelt das Utility-Wort SAVESYSTEM.
+
+Mit ihm kann man das gesamte System als File auf Disk schreiben.
+
+Achtung:
+   Es wird SAVE ausgefuehrt, daher ist nach SAVESYSTEM
+   der Heap geloescht!
+
+Benutzung:     SAVESYSTEM <filename>
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ savsystem                                              05Nov86
+
+: savesystem \ filename
+   save  $100 here over -  savefile ;
+
+
+\\ Einfaches savesystem                                  18Aug86
+
+| : message ( -- )
+   base push decimal
+   cr ." ready for SAVE " here 1-  $100  / u.
+   ." VOLKS4TH.COM" cr ;
+
+: savesystem ( -- )    save message bye ;
+
+

8080/CPM/src/sblkint.fs

@@ -0,0 +1,86 @@
+
+Dos definitions
+
+: file-r/w  ( buffer block fcb f  -- f )
+    over 0= Abort" no Direct Disk IO supported! "
+    >r  dup  (open   2dup in-range r> (r/w ;
+
+\ backup was made visible in vf-blk.fth so no need to peek its address
+\ ' (save-buffers >body $0C + @ | Alias backup
+
+| : filebuffer?  ( fcb -- fcb bufaddr/flag )
+   prev  BEGIN @ dup WHILE  2dup 2+ @ = UNTIL ;
+
+| : (flushfile  ( fcb -- )  \ flush file buffers
+     BEGIN  filebuffer?  ?dup  WHILE
+            dup backup  emptybuf  REPEAT  drop ;
+
+' (flushfile is flushfile
+
+Forth definitions
+
+: list  ( n -- )   3 spaces  file? list ;
+
+\ *** Block No. 15, Hexblock f
+
+\ words for viewing                                   UH 10Oct87
+
+Forth definitions
+
+| $200 Constant viewoffset \ max. %512 kB files
+
+: (makeview  ( -- n )  \ calc. view filed for a name
+   blk @ dup  0= ?exit
+   loadfile @ ?dup IF fileno @ viewoffset * + THEN ;
+
+: (view      ( blk -- blk' ) \ select file and leave block
+   dup 0=exit
+   viewoffset u/mod  file-link
+   BEGIN @ dup WHILE 2dup fileno @ = UNTIL
+   !files drop ;        \ not found: direct access
+
+
+\ *** Block No. 17, Hexblock 11
+
+\ print a list of all buffers                         UH 20Oct86
+
+: .buffers
+   prev BEGIN  @ ?dup WHILE  stop? abort" stopped"
+           cr dup u. dup 2+ @ dup 1+
+           IF ."    Block: " over 4+ @ 5 .r
+              ."    File : " [ Dos ] .file
+              dup 6 + @ 0< IF ."     updated" THEN
+           ELSE ." Buffer empty" drop THEN  REPEAT ;
+
+
+
+
+
+
+
+
+: loadfrom     ( n -- )
+               isfile push  fromfile push  use load   close ;
+
+| : addblock  ( n -- )  \ add block n to file
+     dup buffer under   b/blk  bl fill
+     isfile@   rec/blk  over filesize +!  false file-r/w
+     IF close Abort" disk full!" THEN ;
+
+: more ( n -- )   open >fileend
+   capacity swap bounds  ?DO I addblock LOOP close
+   open close ;
+
+\ *** Block No. 22, Hexblock 16
+
+\ Status                                              UH 10OCt87
+
+
+: .blk ( -- )   blk @ ?dup 0=exit
+   dup 1 = IF cr file? THEN base push hex ."  Blk " . ?cr ;
+
+' .blk Is .status
+
+' (makeview     Is makeview
+' file-r/w      Is r/w
+

8080/CPM/src/see.fb.txt

@@ -0,0 +1,456 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\ Extended-Decompiler for VolksForth LOAD-SCREEN      UH 07Nov86
+
+Dieses File enthaelt einen Decompiler, der bereits kompilierte
+Worte wieder in Sourcetextform bringt.
+Strukturierte Worte wie IF THEN ELSE, BEGIN WHILE REPEAT UNTIL
+und DO LOOP +LOOP werden in einem an AI-grenzenden Vorgang
+erkannt und umgeformt.
+Ein Decompiler kann aber keine (Stack-) Kommentare wieder
+herzaubern, die Benutzung der Screens und dann view, wird
+daher staerkstens empfohlen.
+
+Denn:        Es ist immernoch ein Fehler drin!
+Und um den zu korrigieren, ist der Sourcetext dem Objektkode
+doch vorzuziehen.
+
+              Benutzung:       see <name>
+
+\ *** Block No. 1, Hexblock 1
+
+\ Extended-Decompiler for VolksForth LOAD-SCREEN         07Nov86
+
+Onlyforth Tools also definitions
+
+1 13 +thru
+
+\\
+Produces compilable Forth source from normal compiled Forth.
+
+         These source blocks are based on the works of
+
+            Henry Laxen, Mike Perry and Wil Baden
+
+               volksFORTH version: U. Hoffmann
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+\ detacting does>                                        01Jul86
+
+internal
+
+' does> 4+ @   Alias (;code
+' Forth @ 1+ @  Constant (dodoes>
+
+: does?    ( IP -  f )
+   dup c@  $CD ( call ) =  swap
+   1+ @  (dodoes>  = and ;
+
+
+
+
+
+
+
+\ *** Block No. 3, Hexblock 3
+
+\ indentation.                                           04Jul86
+Variable #spaces   #spaces off
+
+: +in  ( -- ) 3 #spaces +! ;
+
+: -in  ( -- ) -3 #spaces +! ;
+
+: ind-cr ( -- ) ( col #spaces @ = ?exit ) cr  #spaces @ spaces ;
+
+: ?ind-cr ( -- ) col c/l u> IF ind-cr THEN  ;
+
+
+
+
+
+
+
+\ *** Block No. 4, Hexblock 4
+
+\ case defining words                                    01Jul86
+
+: Case:  ( -- )
+   Create:  Does>   swap 2* +  perform ;
+
+: Associative: ( n -- )
+   Constant   Does>      ( n - index )
+   dup @ -rot  dup @ 0
+   DO  2+  2dup @ =
+       IF  2drop drop  I  0 0  LEAVE  THEN   LOOP 2drop ;
+
+
+
+
+
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ branching                                              04Jul86
+
+Variable #branches    Variable #branch
+
+: branch-type ( n -- a ) 6 * pad + ;
+: branch-from ( n -- a ) branch-type 2+ ;
+: branch-to   ( n -- a ) branch-type 4+ ;
+
+: branched ( adr type -- ) \ Make entry in branch-table.
+     #branches @ branch-type !   dup #branches @ branch-from !
+     2+ dup @ +  #branches @ branch-to !   1 #branches +! ;
+
+\\ branch-table: { type0|from0|to0 | type1|from1|to1 ... }
+
+
+
+
+\ *** Block No. 6, Hexblock 6
+
+\ branching                                              01Jul86
+
+: branch-back ( adr type --  )
+   \  : make entry in branch-table & reclassify branch-type.)
+   over swap branched
+   2+ dup dup @ + swap 2+ ( loop-start,-end.)
+   0  #branches @ 1-
+   ?DO
+      over I branch-from @  u> IF LEAVE THEN
+      dup  I branch-to @ = IF ['] while  I branch-type !  THEN
+   -1 +LOOP 2drop ;
+
+
+
+
+
+
+\ *** Block No. 7, Hexblock 7
+
+\ branching                                              01Jul86
+: forward? ( ip -- f )   2+ @ 0> ;
+
+: ?branch+ ( ip -- ip' ) dup 4+ swap dup forward?
+   IF ['] if branched exit THEN   ['] until branch-back ;
+
+: branch+ ( ip -- ip' ) dup 4+ swap dup forward?
+   IF ['] else branched exit THEN ['] repeat branch-back ;
+
+: (loop)+ ( ip -- ip' )
+   dup  dup @ ( loop,+loop )  branch-back -1 #branches +! 4+ ;
+
+: string+ ( ip -- ip' ) 2+ count + even ;
+
+: (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+  ;
+
+
+\ *** Block No. 8, Hexblock 8
+
+\ classify each word                                     25Aug86
+Forth
+
+&15 Associative: execution-class
+ ] clit         lit             ?branch         branch
+   (do          (."             (abort"         (;code
+   ("           (?do            (loop
+   (+loop       unnest          (is             compile   [
+
+Case:  execution-class+
+   3+           4+              ?branch+        branch+
+   2+           string+         string+         (;code+
+   string+      2+              4+
+   4+           0=              4+              4+         2+  ;
+
+Tools
+
+\ *** Block No. 9, Hexblock 9
+
+\ first pass                                             01Jul86
+
+: pass1 ( cfa -- ) #branches off >body
+   BEGIN dup @ execution-class execution-class+
+      dup 0= stop? or
+   UNTIL drop ;
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 10, Hexblock a
+
+\ identify branch destinations.                          04Jul86
+: thru.branchtable ( -- limit start ) #branches @ 0 ;
+: ?.then ( ip -- ) thru.branchtable
+   ?DO I branch-to @ over =
+      IF I branch-from @ over u<
+        IF I branch-type @ dup ['] else = swap ['] if = or
+          IF -in ." THEN " ind-cr LEAVE THEN THEN THEN
+   LOOP ;
+: ?.begin ( ip -- ) thru.branchtable
+   ?DO I branch-to @ over =
+      IF I branch-from @ over u< not
+        IF I branch-type @ dup
+           ['] repeat = swap ['] until = or
+           IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN
+   LOOP ;
+( put "BEGIN" and "THEN" where used.)
+
+\ *** Block No. 11, Hexblock b
+
+\ decompile each type of word                            01Jul86
+
+: .word   ( ip -- ip' ) dup @ >name .name 2+  ;
+
+: .(word  ( ip -- ip' )     dup @  >name
+      ?dup 0= IF ." ??? " ELSE
+      count $1f and swap 1+ swap 1-  type space THEN 2+ ;
+: .inline ( val16b -- )
+     dup >name ?dup IF ." ['] " .name drop exit THEN . ;
+
+: .lit    ( ip -- ip' )     2+ dup @ .inline  2+  ?.then ;
+: .clit   ( ip -- ip' )     2+ dup c@ . 1+ ?.then ;
+: .string ( ip -- ip' )
+     .(word count 2dup type Ascii " emit space + even ?.then ;
+
+: .unnest  ( ip -- 0 )      ." ; " 0=  ;
+
+\ *** Block No. 12, Hexblock c
+
+\ decompile each type of word                            01Jul86
+
+: .default ( ip -- ip' ) dup @ >name ?dup IF
+    c@ $40 and IF ." [COMPILE] " THEN THEN   .word ?.then ;
+
+: .['] ( ip -- ip' )  .(word dup @ 2- >name .name  2+  ?.then ;
+
+: .compile ( ip -- ip' ) .word  .word  ?.then ;
+
+
+
+
+
+
+
+
+
+\ *** Block No. 13, Hexblock d
+
+\ decompiling conditionals                               04Jul86
+
+: .if     ( ip nfa -- ip' )  ind-cr .name +in 4+ ?.then ;
+: .repeat ( ip nfa -- ip' )  -in .name ind-cr 4+ ?.then ;
+: .else   ( ip nfa -- ip' )  -in ind-cr .name +in 4+ ;
+: .do     ( ip nfa -- ip' )  ind-cr .(word +in 2+ ?.then ;
+: .loop   ( ip nfa -- ip' )  -in .(word ind-cr 2+ ?.then ;
+
+5 Associative: branch-class
+ ' if ,   ' while ,  ' else ,  ' repeat ,  ' until ,
+Case: .branch-class
+   .if    .else      .else     .repeat     .repeat      ;
+
+: .branch ( ip -- ip' )
+    #branch @   branch-type @   1 #branch +!
+    dup >name   swap branch-class .branch-class ;
+
+\ *** Block No. 14, Hexblock e
+
+\ decompile Does> ;code                                  04Jul86
+
+: .(;code  ( IP - IP' f)
+   2+ dup does?
+   IF  ind-cr ." DOES> " 3+  ELSE  ." ;CODE "  0=  THEN ;
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 15, Hexblock f
+
+\ classify word's output                                 01Jul86
+
+Case: .execution-class
+   .clit        .lit            .branch         .branch
+   .do          .string         .string         .(;code
+   .string      .do             .loop
+   .loop        .unnest         .[']            .compile
+   .default ;
+
+
+
+
+
+
+
+
+
+\ *** Block No. 16, Hexblock 10
+
+\ decompile colon-definitions                            04Jul86
+
+: pass2 ( cfa -- ) #branch off >body
+   BEGIN ?.begin ?ind-cr  dup @ execution-class .execution-class
+         dup 0= stop? or
+   UNTIL drop ;
+
+: .pfa ( cfa -- ) #spaces off  +in  dup pass1   pass2 ;
+
+: .immediate  ( cfa - )    >name c@ dup
+    ?ind-cr  40 and IF  ." IMMEDIATE "  THEN
+    ?ind-cr  80 and IF  ." RESTRICT"    THEN ;
+
+: .:  ( cfa - )  ." : " dup >name .name 3 spaces  .pfa ;
+
+
+
+\ *** Block No. 17, Hexblock 11
+
+\ display category of word                               01Jul86
+external   Defer (see   internal
+
+: .does>  ( cfa - )     ." DOES> "  @  1+ .pfa ;
+
+: .user-variable  ( cfa - ) ." USER " dup >name dup .name
+    3 spaces swap execute @ u. .name ." ! " ;
+
+: .defer   ( cfa - )
+ ." deferred "  dup >name .name  ." Is "  >body @  (see  ;
+
+: .other   ( cfa - )  dup >name .name
+    dup @ over >body =   IF drop ."  is Code " exit THEN
+    dup @ does? IF .does> exit THEN
+    drop ." is unknown " ;
+
+
+\ *** Block No. 18, Hexblock 12
+
+\ decompiling variables and constants                    01Jul86
+
+: .constant   ( cfa - )
+    dup  >body @ u.  ." CONSTANT "  >name .name ;
+
+: .variable   ( cfa - ) ." VARIABLE "
+    dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ;
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 19, Hexblock 13
+
+\ classify a word                                     UH 25Jan88
+
+5 Associative: definition-class
+  ' quit @ ,    ' 0 @ ,         ' scr @ ,       ' base @ ,
+  ' 'cold @ ,
+
+Case: .definition-class
+  .:            .constant       .variable       .user-variable
+  .defer        .other  ;
+
+
+
+
+
+
+
+
+\ *** Block No. 20, Hexblock 14
+
+\ Top level of Decompiler                                04Jul86
+
+external
+
+: ((see    ( cfa -)
+    #spaces off cr
+    dup dup @
+    definition-class .definition-class   .immediate  ;
+
+' ((see Is (see
+
+Forth definitions
+: see   ' (see ;
+
+
+
+
+\ *** Block No. 21, Hexblock 15
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 22, Hexblock 16
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 23, Hexblock 17
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

8080/CPM/src/sfileint.fs

@@ -0,0 +1,334 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\ CP/M 2.2 File-Interface (3.80a)                     UH 05Oct87
+
+\ Dieses File enthaelt das File-Interface von volksFORTH zu CP/M.
+\ Damit ist Zugriff auf normale CP/M-Files moeglich.
+\ Wenn ein File mit USE benutzt wird, beziehen sich alle Worte,
+\ die mit dem Massenspeicher arbeiten, auf dieses File.
+
+\ Benutzung:
+\   USE <name>       \ benutze ein schon existierendes File
+\   FILE <name>      \ erzeuge ein Forthfile mit dem Namen <name>.
+\   MAKE <name>      \ Erzeuge ein File mit <name> und ordne
+\                   \ es dem aktuellen Forthfile zu.
+\   MAKEFILE <name>  \ Erzeuge ein File mit CP/M und FORTH-Namen
+\                      <name>.
+\   INCLUDE <name>   \ Lade File mit Forthnamen <name> ab Screen 1
+\   DOS RESET        \ zum Wechsel von Disketten. (Oh! CP/M)
+
+\ *** Block No. 1, Hexblock 1
+
+\ CP/M 2.2 File-Interface  load-Screen                UH 18Feb88
+OnlyForth
+
+\       2 load \ view numbers for this file
+\   3   4 thru \ DOS   File Functions
+\   5 $11 thru \ Forth File Functions
+\ $12 $16 thru \ User Interface
+
+\ File source.fb      \  Define already existing Files
+\ File fileint.fb     File startup.fbr
+
+\ ' (makeview     Is makeview
+\ ' remove-files  Is custom-remove
+\ ' file-r/w      Is r/w
+\ ' noop          Is drvinit
+ \      include startup.fb \ load Standard System
+
+\ *** Block No. 3, Hexblock 3
+
+\ File Control Blocks                                 UH 18Feb88
+Dos definitions also
+| : Fcbyte ( n len -- len' )  Create over c, + does> c@ + ;
+&11 Constant filenamelen
+0              2 | Fcbyte nextfile  immediate
+               1   Fcbyte drive    ' drive | Alias >dosfcb
+ filenamelen 3 -   Fcbyte filename
+               3   Fcbyte extension
+           &21 + \ ex, s1, s2, rc, d0, ... dn, cr
+               2   Fcbyte record    \  r0, r1
+              1+ \ r2
+               2   Fcbyte opened
+               2   Fcbyte fileno
+               2   Fcbyte filesize  \ in 128-Byte-Records
+               4   Fcbyte position
+Constant b/fcb
+
+\ *** Block No. 4, Hexblock 4
+
+\ dos primitives                                      UH 10Oct87
+
+' 2-  | Alias body>             ' 2- | Alias dosfcb>
+
+: drive!     ( drv    --      )     $0E bdos ;
+: search0    ( dosfcb -- dir  )     $11 bdosa ;
+: searchnext ( dosfcb -- dir  )     $12 bdosa ;
+: createfile ( dosfcb -- f    )     $16 bdosa dos-error? ;
+: size       ( dos    -- size ) dup $23 bdos dosfcb> record @ ;
+: drive@     (        -- drv  )   0 $19 bdosa ;
+: killfile   ( dosfcb --      )     $13 bdos ;
+
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ File sizes                                          UH 05Oct87
+
+: (capacity  ( fcb -- n )  \ filecapacity in blocks
+    filesize @  rec/blk  u/mod swap 0= ?exit 1+ ;
+
+: in-range ( block fcb -- )
+    (capacity u< not Abort" beyond capacity!" ;
+
+Forth definitions
+
+: capacity ( -- n )    isfile@  (capacity ;
+
+Dos definitions
+
+\ *** Block No. 6, Hexblock 6
+
+\ (open                                               UH 18Feb88
+
+: (open  ( fcb -- )
+    dup opened @ IF drop exit THEN   dup position  0. rot 2!
+    dup >dosfcb openfile  Abort" not found!"  dup opened on
+    dup >dosfcb size  swap filesize ! ;
+
+: (make  ( fcb -- )
+   dup >dosfcb killfile
+   dup >dosfcb createfile Abort" directory full!"
+   dup position 0. rot 2!
+   dup filesize off   opened on  offset off ;
+
+\ *** Block No. 7, Hexblock 7
+
+\ Print Filenames                                     UH 10Oct87
+
+: .file ( fcb -- ) 0 case? IF ." DIRECT"  exit THEN
+         fcb dosfcb> case? IF ." DEFAULT" exit THEN
+         body> >name .name ;
+
+: .drive   ( fcb -- ) drive c@ ?dup 0=exit
+     [ Ascii A 1- ] Literal + emit  Ascii : emit ;
+
+: .dosfile ( fcb -- )  dup filename  8 -trailing type
+    Ascii . emit           extension 3           type ;
+
+
+
+
+
+
+\ *** Block No. 8, Hexblock 8
+
+\ Print Filenames                                     UH 10Oct87
+
+: tab ( -- ) col &59 > IF cr exit THEN
+        &20  col &20 mod  -  0 max  spaces ;
+
+: .fcb  ( fcb -- )  dup fileno @  3 u.r tab
+     dup .file tab dup .drive dup .dosfile
+     tab dup opened @ IF ." opened" ELSE ." closed" THEN
+     3 spaces  base push  decimal   (capacity  3 u.r  ."  kB" ;
+
+
+
+
+
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+\ Filenames                                           UH 05Oct87
+
+: !name ( addr len fcb -- )
+     dup >r filename filenamelen bl fill
+     over 1+ c@  Ascii : =
+     IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r>
+     ELSE 0 THEN  r@ drive c! r> dup filename 2swap
+     filenamelen 1+ min bounds
+     ?DO  I c@ Ascii . =
+         IF drop dup  extension ELSE  I c@ over c! 1+ THEN
+     LOOP 2drop ;
+
+: !fcb  ( fcb -- )  dup opened off   name count rot !name ;
+
+
+
+
+\ *** Block No. 10, Hexblock a
+
+\ Print Directory                                     UH 18Nov87
+
+| Create dirbuf  b/rec allot    dirbuf b/rec erase
+| Create fcb0    b/fcb allot    fcb0   b/fcb erase
+
+| : wildchard?  ( f c -- f' )  Ascii * = IF drop Ascii ? THEN ;
+| : (expand ( addr len -- )  false -rot bounds
+     ?DO  I c@  wildchard? dup ?dup IF I c! THEN  LOOP drop ;
+| : expand ( fcb -- )  \ expand * to ???
+     dup filename 8 (expand   extension 3 (expand ;
+
+: (dir  ( addr len -- )
+    fcb0 !name fcb0 expand  dirbuf dma!  fcb0 >dosfcb search0
+    BEGIN dup dos-error? not
+    WHILE  $20 * dirbuf + dosfcb> tab .dosfile
+           fcb0 >dosfcb searchnext  stop? UNTIL  drop ;
+
+\ *** Block No. 11, Hexblock b
+
+\ File List                                           UH 10Oct87
+
+User file-link   file-link off
+
+| : #file ( -- n )   file-link @ dup IF fileno c@ THEN 1+ ;
+
+
+Forth definitions
+
+: forthfiles ( -- )
+   file-link @
+   BEGIN dup WHILE  cr  dup .fcb  @ stop? UNTIL drop ;
+
+Dos definitions
+
+
+
+\ *** Block No. 12, Hexblock c
+
+\ Close a file                                        UH 10Oct87
+
+Defer flushfile  ' noop is flushfile
+
+: (close  ( fcb -- )  \ close file in fcb
+   dup flushfile
+   dup opened  dup @ 0= IF 2drop exit THEN  off
+   >dosfcb closefile Abort" not found!" ;
+
+
+\ *** Block No. 13, Hexblock d
+
+\ Create fcbs                                         UH 10Oct87
+
+: !files ( fcb -- )  dup  isfile ! fromfile ! ;
+
+' r@ | Alias newfcb
+
+Forth definitions
+
+: File  ( -- )
+   Create here >r   b/fcb allot  newfcb b/fcb erase
+          last @ count $1F and  newfcb !name
+          #file   newfcb fileno !
+          file-link @  newfcb nextfile !   r> file-link !
+   Does> !files ;
+
+: direct     0 !files ;
+
+\ *** Block No. 14, Hexblock e
+
+\ flush buffers & misc.                  UH 10Oct87   UH 28Nov87
+Dos definitions
+
+: save-files  ( -- )  file-link BEGIN  @ ?dup  WHILE
+     dup opened @ IF dup >dosfcb closefile drop THEN  REPEAT ;
+
+' save-files Is save-dos-buffers
+
+\ : close-files  ( -- )  file-link
+\     BEGIN  @ ?dup  WHILE  dup (close  REPEAT ;
+
+Forth definitions
+
+: file?   isfile@ .file ;  \ print current file
+
+\ *** Block No. 16, Hexblock 10
+
+\ FORGETing files                                     UH 10Oct87
+
+| : remove?      ( dic symb addr -- dic symb addr f )
+     dup heap? IF  2dup u> exit THEN 2 pick over 1+ u< ;
+
+
+| : remove-files ( dic symb -- dic symb )  \ flush files !
+     isfile@      remove? nip  IF direct       THEN
+     fromfile @   remove? nip  IF fromfile off THEN
+     file-link
+     BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT
+     file-link remove ;
+
+
+
+
+
+\ *** Block No. 18, Hexblock 12
+
+\ File Interface User words                           UH 11Oct87
+
+| : same ( addr -- )  >in ! ;
+: open      isfile@ (open   offset off ;
+: close     isfile@ (close ;
+: assign    close   isfile@ !fcb  open ;
+: make      isfile@ dup !fcb   (make ;
+
+| : isfile?  ( addr -- addr f )    \ is adr a fcb?
+  file-link BEGIN  @ dup 0=exit 2dup body> = UNTIL drop true ;
+
+: use       >in @ name find \ create a fcb if not present
+            IF isfile? IF execute drop  exit THEN THEN drop
+            dup same File   same ' execute  open ;
+
+
+
+\ *** Block No. 19, Hexblock 13
+
+\ File Interface User words                           UH 25May88
+
+: makefile     >in @   File  dup  same ' execute  same make ;
+: emptyfile    isfile@ >dosfcb createfile ;
+
+: from         isfile push use ;
+
+: include ( -- )
+  increc-offset push  isfile push  fromfile push
+  use  cr file?
+  include-isfile
+  incfile @
+    IF increc @ incfile @ cr+ex!
+    incfile @ increadrec Abort" error re-reading after include"
+    THEN ;
+
+: eof ( -- f ) isfile@  dup filesize @ swap record @ = ;
+
+: files        " *.*" count (dir ;
+: files"       Ascii " word count 2dup upper (dir ;
+
+' files Alias dir     ' files" Alias dir"
+
+\ *** Block No. 20, Hexblock 14
+
+\ extend Files                                        UH 20Nov87
+
+| : >fileend   isfile@ >dosfcb size drop ;
+
+: Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ;
+0   Drive: a:   Drive: b:   Drive: c:   Drive: d:
+5 + Drive: j:  drop
+
+\ *** Block No. 21, Hexblock 15
+
+\ save memory-image as disk-file                      UH 29Nov86
+
+Forth definitions
+
+: savefile ( from count -- ) \ filename
+   isfile push  makefile bounds
+   ?DO I dma!  isfile@ >dosfcb write-seq  Abort" disk full!"
+       b/rec +LOOP  close ;
+
+' remove-files  Is custom-remove
+' noop          Is drvinit

8080/CPM/src/simpfile.fb.txt

@@ -0,0 +1,76 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Simple Files                                          11Nov86
+
+Wenn volksFORTH im Direktzugriff Disketten bearbeitet, ist es
+trotzdem wuenschenswert eine Art File-Struktur zu besitzen.
+Dieses File enthaelt eine einfache Implementation eines
+Filesystems. Der/die Programmierer/in muss selbst die Direktory
+auf dem laufenden halten: in ihr sind die Start-Bloecke des
+entsprechenden Diskettenteils gespeichert.
+Sogar eine Hierarchie von Direktories laesst sich so relisieren.
+
+Vorgestellt wurde dieses FileSystem von Georg Rehfeld und auch
+von ihm fuer volksFORTH implementiert (ultraFORTH auf dem C64).
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ simple files                                           12feb86
+
+\needs search   .( search missing) \\
+
+| Variable (dir    : dir  (dir @ ;   : root  0 (dir ! ;  root
+
+| : read"  ( -- n)
+ Ascii " word  count  dup >r  dir block  b/blk  search
+ 0= abort" not found"  r> +  >in push  >in !
+ bl  dir block  b/blk  (word number drop ;
+
+: load"   read" dir + load ;    : dir"   read" (dir +! ;
+: list"   read" dir + list ;
+
+\ 1 +load       \ Only if file" is needed
+
+
+\ *** Block No. 2, Hexblock 2
+
+\ simple files                                           01feb86
+
+| : snap   ( n0 -- n1)   $20 /  3 max  $20 * ;
+: file"  ( n --)
+ Ascii " word  count  2dup  dir block b/blk  search
+ IF    + nip
+ ELSE  drop  dir block  b/blk -trailing nip  snap $20 +
+       dup b/blk 1- > abort" directory full"
+       2dup + >r  dir block + swap  cmove  r>
+ THEN  snap $18 +  >r
+ dir - extend under dabs <# # # # #
+ base @ $0A = IF  Ascii &  ELSE Ascii $  THEN hold
+ rot 0< IF  Ascii -  ELSE  bl  THEN hold #>
+ r> dir block +  swap cmove update ;
+
+
+
+\ *** Block No. 3, Hexblock 3
+
+\ dir load"                                              11feb86
+
+\needs search   .( search missing) \\
+
+0 Constant dir
+
+: load"   ( -- )
+ Ascii " word count  dup >r  dir block b/blk search
+     0= abort" not found"   r> +
+ >in @  blk @  rot >in !  dir blk !
+ bl word number drop -rot  blk !  >in !  load ;
+
+
+
+
+

8080/CPM/src/startup.fb.txt

@@ -0,0 +1,57 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Startup: Load Standard System                      UH 11Nov86
+
+Dieses File enthaelt Befehle, die aus dem File KERNEL.COM
+ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM
+als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann.
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ System LOAD-Screen fuer CP/M VolksForth             UH 27Nov87
+include ass8080.fb
+include xinout.fb            \ extended I/O
+\ include terminal.fb  save    \ Terminal
+include copy.fb           cr .( copy and convey loaded)   cr
+include savesys.fb        cr .( Savesystem loaded)        cr
+include editor.fb         cr .( Editor loaded)            cr
+include tools.fb          cr .( Tools loaded)             cr
+\ include see.fb            cr .( Decompiler loaded)        cr
+\ include tasker.fb         cr .( Multitasker loaded)       cr
+\ include printer.fb        cr .( Printer Interface loaded) cr
+include relocate.fb       cr .( Relocating loaded)        cr
+
+.( May the volksFORTH be with you ...) cr   decimal   caps on
+scr off  r# off     savesystem volks4th.com
+
+
+\ *** Block No. 2, Hexblock 2
+
+                                          UH 22Oct86
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

8080/CPM/src/target.fb.txt

@@ -0,0 +1,646 @@
+
+\ *** Block No. 0, Hexblock 0
+
+ \                                                       05Jul86
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ Target compiler loadscr                             UH 07Jun86
+\ Idea and first Implementation by ks/bp
+\ Implemented on 6502  by ks/bp
+\ ultraFORTH83-Version by bp/we
+\ Atari 520 ST - Version by we
+\ CP/M 2.2 Version by UH
+
+Onlyforth hex     Assembler nonrelocate
+Vocabulary Ttools
+Vocabulary Defining
+ 1 10 +thru   \ Target compiler
+11 13 +thru   \ Target Tools
+14 16 +thru   \ Redefinitions
+save  17 20 +thru  \ Predefinitions
+
+Onlyforth
+
+\ *** Block No. 2, Hexblock 2
+
+\ Target header pointers                              UH 26Mar88
+
+Create   lastname $20 allot
+Variable tdp                  : there  tdp @ ;
+Variable displace
+Variable image
+Variable ?thead               ?thead off
+Variable tlast                tlast  off
+Variable glast'               glast' off
+Variable tdoes>
+Variable >in:
+Variable tvoc                 tvoc off
+Variable tvoc-link            tvoc-link off
+0 | Constant <forw>
+0 | Constant <res>
+| : Is> ( cfa -- )  [compile] Does> here 3 - swap >body ! 0 ] ;
+
+\ *** Block No. 3, Hexblock 3
+
+\ Image and byteorder                                 UH 26Mar88
+
+Code c+! ( 8b addr -- )
+   H pop   D pop   E A mov   M add   A M mov   Next   end-code
+
+Code /block  ( addr -- +n blk )
+   H pop    L E mov    H A mov    3 ani    A D mov
+   H A mov   $FC ani    rrc rrc  A L mov   0 H mvi   dpush jmp
+end-code
+
+: >image    ( addr1 - addr2 )
+   displace @ ( -  /block   image @ +  block ) + ;
+
+: >heap  ( from quan - )  dup hallot heap swap cmove ;
+\\ : c+!   ( 8b addr -- )        dup c@ rot + swap c! ;
+   : /block ( addr -- +n blk )  b/blk /mod ;
+
+\ *** Block No. 4, Hexblock 4
+
+\ Ghost-creating                                      UH 26Mar88
+
+| : (make.ghost  ( str -- cfa.ghost )  dp push
+     count  dup 1 $1F uwithin not Abort" invalid Ghostname"
+     here 2+ place
+     here state @          \ address of link field
+     IF  context @  ELSE current  THEN  @  under @ ,  \ link
+     1 here c+!  here c@  allot  bl c,  \ name
+     here over - swap  \ offset to codefield
+     <forw> , 0 , 0 ,           \ code and parameter field
+     here over - >heap          \ move to heap
+     heap rot !                 \ link
+     heap  +  ;                 \ codefield address
+
+| : Make.Ghost ( -- cfa.ghost )  name (make.ghost ;
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ ghost words                                         UH 28Apr88
+
+: gfind  ( string - cfa tf / string ff )
+   >r bl r@ count + c!  1 r@ c+!  r@ find  -1 r> c+! ;
+
+: (ghost   ( string -- cfa )  gfind  ?exit  (make.ghost ;
+
+: ghost ( -- cfa )  name (ghost ;
+
+: gdoes>  ( cfa.ghost - cfa.does )  dp push
+    4+ dup @    IF  @ exit  THEN   \ defined
+    here <forw> , 0 ,  4 >heap     \ forward-chain
+    heap dup rot ! ;               \ forward-link
+
+
+
+
+\ *** Block No. 6, Hexblock 6
+
+\ ghost utilities                                    2UH 26Mar88
+
+: g' ( -- cfa.ghost )  name gfind 0= abort" ?" ;
+
+| : .ghost-type ( cfa.ghost -- ) @
+      <forw> case? IF ." forward" exit THEN
+      <res> - Abort" type unknown" ." resolved " ;
+
+| : .does-type ( cfa.does -- )  @
+      <forw> case? IF ." forward-define" exit THEN
+      <res> - Abort" does-type unknown"  ." resolved-define" ;
+
+: '. ( -- ) g'         dup .ghost-type  dup 2+ @ 5 u.r
+     4+ @ ?dup 0=exit  dup  .does-type      2+ @ 5 u.r  ;
+
+' ' Alias h'
+
+\ *** Block No. 7, Hexblock 7
+
+\ .unresolved                                         UH 26Mar88
+
+| : forward? ( cfa -- f )  dup @  <forw> =  swap 2+ @ and ;
+| : ghost?   ( nfa -- f )  count $1F and + 1- c@ bl = ;
+
+| : unresolved? ( addr - f ) 2+
+    dup     ghost? not IF drop false exit THEN
+    name> dup forward? IF drop true  exit THEN
+    4+ @      forward? ;
+
+| : unresolved-words  ( thread -- )  BEGIN @ ?dup WHILE
+     dup unresolved?  IF dup 2+ .name ?cr  THEN REPEAT ;
+
+: .unresolved ( -- ) voc-link @
+    BEGIN dup 4- unresolved-words  @ ?dup 0= UNTIL ;
+
+
+\ *** Block No. 8, Hexblock 8
+
+\ Extending Vocabularys for Target-Compilation       2UH 26Mar88
+
+: Vocabulary       Vocabulary 0 , here tvoc @ , tvoc ! ;
+
+Vocabulary Transient    tvoc off
+
+Root definitions
+
+: T Transient ;   immediate
+: H Forth     ;   immediate
+
+OnlyForth
+
+
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+\ Transient primitives                                UH 26Mar88
+
+Code byte>   ( 8bl 8bh -- 16b )
+   D pop  H pop  E H mov  hpush jmp end-code
+Code >byte   ( 16b -- 8bh 8bl )
+   H pop  H E mov  0 H mvi  H D mov  dpush jmp end-code
+
+Transient definitions
+: c@ ( addr -- 8b )  H >image  c@ ;
+: c! ( 8b addr -- )  H >image  c!  ( update ) ;
+: @  ( addr -- n  )  dup T c@ H  swap 1+  T c@ H  byte> ;
+: !  ( n addr --  )  >r  >byte r@  T c! H  r> 1+  T c! H ;
+: cmove ( from.mem to.target quan -)
+     bounds ?DO  dup  H c@   I  T c! H  1+ LOOP drop ;
+: on  ( addr -- )  true  swap T ! H ;
+: off ( addr -- )  false swap T ! H ;
+
+\ *** Block No. 10, Hexblock a
+
+\ Transient primitives                                UH 26Mar88
+
+: here  ( -- taddr )   there ;
+: allot ( n -- )  Tdp +! ;
+: c, ( c -- )  T here c! 1 allot H ;
+: ,  ( n -- )  T here  ! 2 allot H ;
+
+: ," ( -- )  Ascii " parse
+     dup T c,  under  here swap cmove  allot H ;
+
+: fill ( addr len c -- )
+   -rot bounds ?DO dup I  T c! H  LOOP drop ;
+
+: erase ( addr len -- )  0  T fill H ;
+: blank ( addr len -- )  bl T fill H ;
+: here! ( addr -- )  H tdp ! ;
+
+\ *** Block No. 11, Hexblock b
+
+\ Resolving                                           UH 26Mar88
+
+Forth definitions
+
+: resolve ( cfa.ghost cfa.target -- )
+   2dup  swap >body   dup @ >r   !   over @ <res> =
+   IF drop >name space .name ." exists" ?cr rdrop exit THEN
+   r> swap >r  <res> rot !  ?dup 0= IF rdrop exit THEN
+   BEGIN dup T @ H 2dup = abort" resolve loop"
+         r@ rot T ! H  ?dup 0= UNTIL rdrop ;
+
+: resdoes> ( cfa.ghost cfa.target -- )
+    swap gdoes> dup @ <res> = IF 2+ ! exit THEN swap resolve ;
+
+' <forw> Is> ( -- )  dup @ there rot ! T , H ; \ forward link
+' <res>  Is> ( -- )  @ T , H ;  \ compile target.cfa
+
+\ *** Block No. 12, Hexblock c
+
+\ move-threads                                        UH 26Mar88
+
+: move-threads           Tvoc @ Tvoc-link @
+  BEGIN  over ?dup
+  WHILE  2- @ over 2- T ! @ H swap @ swap  REPEAT
+  error" some undef. Target-Vocs left" drop ;
+
+| : tlatest ( - addr)       Current @  6  + ;
+
+
+: save-target \ filename
+    $100 dup >image  there rot -  savefile ;
+
+
+
+
+
+\ *** Block No. 13, Hexblock d
+
+\ compiling names into targ.                          UH 26Mar88
+
+| : viewfield ( -- n ) H blk @  $200 + ; \ in File #1
+
+: (theader  ( -- ) ?thead @ IF  1 ?thead +! exit THEN
+   >in push
+   name dup c@  1 $20 uwithin  not abort" invalid Targetname"
+   viewfield T ,
+   H there  tlatest @ T , H  tlatest !   \ link
+   there dup tlast !
+   over c@ 1+   dup T allot   cmove H ;
+
+: Theader ( -- )  tlast off
+    (theader Ghost dup glast' !  there resolve ;
+
+
+
+\ *** Block No. 14, Hexblock e
+
+\ prebuild defining words                          bp2UH 26Mar88
+
+| : executable? ( adr - adr f )       dup ;
+| : tpfa,                             there , ;
+
+| : (prebuild ( cfa.adr -- )  >in push  Create  here 2- ! ;
+
+: prebuild ( adr 0.from.: - 0 )  0 ?pairs
+    executable? dup >r
+    IF  [compile] Literal compile (prebuild  ELSE  drop  THEN
+    compile Theader  Ghost gdoes> ,
+    r> IF  compile tpfa,  THEN  0 ;    immediate restrict
+
+
+
+
+
+\ *** Block No. 15, Hexblock f
+
+\ code portion of def.words                        bp2UH 26Mar88
+
+: dummy      0 ;
+
+: DO> ( - adr.of.jmp.dodoes> 0 )
+    [compile] Does>  here 3 -  compile @  0 ] ;
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 16, Hexblock 10
+
+\ The Target-Assembler                                UH 26Mar88
+
+
+Forth definitions
+| Create relocate  ]  T c, , c@ here allot ! c! H  [
+
+Transient definitions
+
+: Assembler      H [ Assembler ] relocate >codes ! Assembler ;
+: >label ( 16b -)   H >in @ name gfind rot >in !
+                    IF over resolve dup THEN drop Constant ;
+: Label          H there T >label Assembler H ;
+: Code           H Theader there 2+ T , Assembler H ;
+
+
+
+
+\ *** Block No. 17, Hexblock 11
+
+\ immed. restr. ' \ compile                        bp2UH 26Mar88
+
+: ?pairs   ( n1 n2 -- )    H - abort" unstructured" ;
+: >mark    ( - addr)       H there T 0 , H ;
+: >resolve ( addr -)       H there over - swap T ! H ;
+: <mark    ( - addr)       H there ;
+: <resolve ( addr -)       H there - T , H ;
+: immediate  H Tlast @ ?dup 0=exit  dup T c@ $40 or swap c! H ;
+: restrict   H Tlast @ ?dup 0=exit  dup T c@ $80 or swap c! H ;
+: ' ( <name> - cfa)        H g' dup @ <res> - abort" ?" 2+ @ ;
+: |                        H ?thead @ ?exit ?thead on ;
+: compile                  H Ghost , ; immediate restrict
+
+
+
+
+
+\ *** Block No. 18, Hexblock 12
+
+\ Target tools                                        UH 26Mar88
+Onlyforth Ttools also definitions
+
+| : ttype ( adr n -)   bounds ?DO I T c@ H  dup
+   bl > IF  emit  ELSE  drop ascii . emit  THEN  LOOP ;
+
+: .name ( nfa -)       ?dup IF dup 1+ swap T c@ H $1F and ttype
+                            ELSE ." ??? " THEN space ?cr ;
+
+| : nfa? ( cfa lfa - nfa / cfa ff)
+  BEGIN  dup  WHILE  2dup 2+ dup T c@ H $1F and + 1+ =
+     IF  2+ nip exit  THEN   T @ H REPEAT ;
+
+: >name ( cfa - nfa / ff)
+   Tvoc BEGIN  @ dup  WHILE  under 2- @ nfa? ?dup
+     IF nip exit THEN   swap REPEAT  nip ;
+
+\ *** Block No. 19, Hexblock 13
+
+\ Ttools for decompiling                           ks29jun85we
+
+| : ?:        dup 4 u.r ." :" ;
+| : @?        dup T @ H 6 u.r ;
+| : c?        dup T c@ H 3 .r ;
+
+: s ( adr - adr+)         ?: space c? 3 spaces
+ dup 1+ over T c@ H ttype dup T c@ H + 1+ ;
+
+: n ( adr - adr+2)        ?: @? 2 spaces
+ dup T @ H [ Ttools ] >name .name H 2+ ;
+
+: d ( adr n - adr+n)      2dup swap ?: swap 0 DO  c? 1+  LOOP
+                          2 spaces -rot ttype ;
+
+
+
+\ *** Block No. 20, Hexblock 14
+
+\ Tools for decompiling                            bp204dec85we
+
+: l ( adr - adr+2)        ?: 5 spaces @? 2+ ;
+
+: c ( adr - adr+1)        1 d ;
+
+: b ( adr - adr+1)        ?: @? dup T @ H over + 5 u.r  2+ ;
+
+: dump ( adr n -)         bounds ?DO cr I 10 d drop stop?
+                            IF LEAVE THEN 10 +LOOP ;
+
+: view                    T ' H [ Ttools ] >name ?dup
+                            IF  4 - T @ H list  THEN ;
+
+
+
+
+\ *** Block No. 21, Hexblock 15
+
+\ reinterpretation def.-words                         UH 26Mar88
+
+Onlyforth
+
+: redefinition ( -- )  tdoes> @ 0=exit
+   >in push [ ' parser >body ] Literal push
+   state push   context push
+   >in: @ >in ! name [ ' Transient 2+ ] Literal (find nip ?exit
+   cr ." Redefinition: " here .name
+   >in: @ >in ! : Defining interpret  tdoes> off ;
+
+
+
+
+
+
+
+\ *** Block No. 22, Hexblock 16
+
+\ Create..does> structure                                27Apr86
+
+| : (;tcode      Tlast @ dup T c@ + 1+ ! H rdrop ;
+
+| : changecfa    compile lit tdoes> @ , compile (;tcode ;
+
+Defining definitions
+
+: ;code          0 ?pairs changecfa reveal rdrop rdrop ;
+                                     immediate restrict
+
+Defining ' ;code Alias does>         immediate restrict
+
+: ;              [compile] ; rdrop rdrop ; immediate restrict
+
+
+
+\ *** Block No. 23, Hexblock 17
+
+\ redefinition conditionals                        bp27jun85we
+
+' DO     Alias DO        immediate restrict
+' ?DO    Alias ?DO       immediate restrict
+' LOOP   Alias LOOP      immediate restrict
+' IF     Alias IF        immediate restrict
+' THEN   Alias THEN      immediate restrict
+' ELSE   Alias ELSE      immediate restrict
+' BEGIN  Alias BEGIN     immediate restrict
+' UNTIL  Alias UNTIL     immediate restrict
+' WHILE  Alias WHILE     immediate restrict
+' REPEAT Alias REPEAT    immediate restrict
+
+
+
+
+
+\ *** Block No. 24, Hexblock 18
+
+\ clear Liter. Ascii ['] ."                           UH 26Mar88
+
+Onlyforth Transient definitions
+
+: clear  True abort" There are ghosts" ;
+: Literal ( n -) H dup $FF00 and IF T compile lit , H exit THEN
+                   T compile clit c, H ; immediate
+: Ascii  H bl word 1+ c@
+          state @ 0=exit T [compile] Literal H ; immediate
+: [']   T ' [compile] Literal H ; immediate restrict
+: "     T compile (" ," H ;       immediate restrict
+: ."    T compile (." ," H ;      immediate restrict
+
+: even   H ; immediate   \ machen nichts beim 8080
+: align  H ; immediate
+: halign H ; immediate
+
+\ *** Block No. 25, Hexblock 19
+
+\ Target compilation  ]  [                         bp0UH 26Mar88
+
+Forth definitions
+
+: tcompile ( str -- )  count lastname place
+   lastname find ?dup
+   IF 0> IF  execute exit  THEN  drop lastname THEN
+   gfind IF  execute exit  THEN
+   number? ?dup
+   IF 0> IF  swap T [compile] Literal  THEN
+                    [compile] Literal H exit THEN
+   (ghost execute ;
+
+Transient definitions
+: ]           H State on ['] tcompile is parser ;
+
+
+\ *** Block No. 26, Hexblock 1a
+
+\ Target conditionals                              bp27jun85we
+
+: IF           T compile ?branch >mark H 1 ; immediate restrict
+: THEN         abs 1 T ?pairs >resolve H ;   immediate restrict
+: ELSE         T 1 ?pairs compile branch >mark swap >resolve
+               H -1 ;                        immediate restrict
+: BEGIN        T <mark H 2 ;                 immediate restrict
+: WHILE        T 2 ?pairs 2 compile ?branch >mark -2 H 2swap ;
+                                             immediate restrict
+| : (repeat    T 2 ?pairs <resolve H BEGIN dup -2 =
+                    WHILE drop T >resolve H REPEAT ;
+: UNTIL        T compile ?branch (repeat H ; immediate restrict
+: REPEAT       T compile branch (repeat H ;  immediate restrict
+
+
+
+
+\ *** Block No. 27, Hexblock 1b
+
+\ Target conditionals                              bp27jun85we
+
+: DO             T compile (do >mark H 3 ;  immediate restrict
+: ?DO            T compile (?do >mark H 3 ; immediate restrict
+: LOOP           T 3 ?pairs compile (loop compile endloop
+                 >resolve H ;               immediate restrict
+: +LOOP          T 3 ?pairs compile (+loop compile endloop
+                 >resolve H ;               immediate restrict
+
+
+
+
+
+
+
+
+
+\ *** Block No. 28, Hexblock 1c
+
+\ predefinitions                                   bp27jun85we
+
+: abort"                T compile (abort" ," H ; immediate
+: error"                T compile (err" ," H ;   immediate
+
+Forth definitions
+
+Variable torigin
+Variable tudp           0 tudp !
+
+: >user                 T c@ H torigin @ + ;
+
+
+
+
+
+
+\ *** Block No. 29, Hexblock 1d
+
+\ Datatypes                                        bp2UH 07Nov87
+
+Transient definitions
+: origin!            H torigin ! ;
+: user' ( - 8b)      T ' 2 + c@ H ;
+: uallot ( n -)      H tudp @ swap tudp +! ;
+
+                     DO> >user ;
+: User               prebuild User 2 T uallot c, ;
+
+                     DO> ;
+: Create             prebuild (create ;
+
+                     DO> T @ H ;
+: Constant           prebuild Constant T , ;
+: Variable           Create 2 T allot ;
+
+\ *** Block No. 30, Hexblock 1e
+
+\ Datatypes                                           UH 07Nov87
+
+dummy
+: Vocabulary
+ H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 ,
+ here H tvoc-link @ T , H tvoc-link ! ;
+
+
+                dummy
+: (create       prebuild (create ;
+
+
+
+
+
+
+
+\ *** Block No. 31, Hexblock 1f
+
+\ target defining words                                  27Apr86
+
+              Do> ;
+: Defer       prebuild Defer 2 T allot ;
+: Is          T ' H >body State @ IF T compile (is , H
+                                  ELSE T ! H THEN ; immediate
+| : dodoes>   T compile (;code H Glast' @
+              there resdoes> there tdoes> ! ;
+
+: ;code       0 T ?pairs dodoes> Assembler H [compile] [
+              redefinition ; immediate restrict
+: does>       T dodoes> $CD c,
+              compile (dodoes> H ;      immediate restrict
+
+
+
+
+\ *** Block No. 32, Hexblock 20
+
+\ :  Alias  ;                                        bUH 07Jun86
+
+dummy
+: :      H tdoes> off >in @ >in: ! T prebuild :
+         H current @ context ! T ] H 0 ;
+
+: Create:  Create  H current @ context ! T ] H 0 ;
+
+: Alias ( n -- )       H Tlast off (theader Ghost over resolve
+                       tlast @ T c@ H 20 or tlast @ T c! , H ;
+
+: ;      T 0 ?pairs compile unnest [compile] [ H redefinition ;
+                                            immediate restrict
+
+
+
+
+\ *** Block No. 33, Hexblock 21
+
+\ predefinitions                                      UH 26Mar88
+
+: compile             T compile compile H ; immediate restrict
+: Host                H Onlyforth Ttools also ;
+: Compiler            T Host H Transient also definitions ;
+: [compile]           H ghost execute ; immediate restrict
+\  : Onlypatch           H there 3 - 0 tdoes> ! 0 ;
+
+Onlyforth
+: Target              Onlyforth Transient also definitions ;
+
+Transient definitions
+Ghost c, drop
+
+
+

8080/CPM/src/tasker.fb.txt

@@ -0,0 +1,133 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Multitasker                                           11Nov86
+
+Dieses File enthaelt den Multitasker des volksFORTHs.
+Er ist ein Round-Robin-Multitasker, d.h. jede Task behaelt
+die Kontrolle ueber den Prozessor solange, bis sie sie
+ausdruecklich abgibt.
+Hintergrundtasks im volksFORTH koennen durch Semaphore geordnet
+auf den Massenspeicher und auf den Drucker zugreifen.
+
+In Verbindung mit dem Printer-Interface ist es moeglich
+Files im Hintergrund auszudrucken. (SPOOL)
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ Multitasker Loadscreen                       27Jun86   20Nov87
+
+Onlyforth
+
+\needs multitask   1 +load
+
+02 05 +thru    \ Tasker
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+\ stop singletask multitask                   28Aug86    20Nov87
+
+Code stop   UP lhld   0 ( nop )  M mvi
+Label taskpause
+   IP push   RP lhld   H push   UP lhld   6 D lxi   D dad   xchg
+   H L mov   SP dad   xchg   E M mov   H inx   D M mov
+   UP lhld   H inx   pchl
+end-code
+
+: singletask  [ ' pause @ ] Literal  ['] pause ! ;
+
+: multitask   [ taskpause ] Literal  ['] pause ! ;
+
+
+
+
+
+\ *** Block No. 3, Hexblock 3
+
+\ pass activate                                          28Aug86
+
+: pass   ( n0 ... nr-1 Taddr r -- )
+ BEGIN  [ rot ( Trick !! ) ]
+  swap $F7 over c!        \ awake Task  ( rst 6 )
+  r> -rot                 \ Stack:  IP r addr
+  8 + >r                  \ s0 of Task
+  r@ 2+ @ swap            \ Stack:  IP r0 r
+  2+ 2*                   \ bytes on Taskstack incl. r0 & IP
+  r@ @ over -             \ new SP
+  dup r> 2- !             \ into Ssave
+  swap bounds  ?DO  I !  2 +LOOP  ;  restrict
+
+: activate   ( Taddr -- )
+ 0 [ -rot  ( Trick !! ) ]  REPEAT ; restrict
+
+
+\ *** Block No. 4, Hexblock 4
+
+\ sleep wake taskerror                         28Aug86   20Nov87
+
+: sleep   ( Taddr -- )    $00 ( nop   ) swap c! ;
+: wake    ( Taddr -- )    $F7 ( rst 6 ) swap c! ;
+
+| : taskerror   ( string -- )
+      standardi/o  singletask  ." Task error : " count type
+      multitask stop ;
+
+
+
+
+
+
+
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ Task                                                   20Nov87
+
+: Task   ( rlen slen -- )
+   0 Constant   here 2- >r    \ addr of task constant
+   here  -rot                 \ here for Task dp
+   even allot even            \ allot dictionary area
+   here  r@ !                 \ set task constant addr
+   up@ here $100 cmove        \ init user area
+   here dup    $C300 ,        \ nop-jmp opcode to sleep task
+   up@ 2+ dup @ ,  !          \ link task
+   r> ,                       \ spare used for pointer to header
+   dup  6 -   dup , ,         \ ssave and s0
+   2dup + ,                   \ here + rlen = r0
+   rot ,                      \ dp
+   under  +  dp ! 0 ,         \ allot rstack
+   ['] taskerror  [ ' errorhandler >body c@ ] Literal rot + ! ;
+
+\ *** Block No. 6, Hexblock 6
+
+\ rendezvous 's tasks                          27Jun86   20Nov87
+
+: rendezvous   ( semaphoraddr -- ) dup unlock  pause  lock ;
+
+| : statesmart       state @ IF  [compile] Literal  THEN ;
+
+: 's   ( Taddr -- adr.of.tasks.userarea )
+         ' >body c@ +  statesmart ;  immediate
+
+: tasks   ( -- )  ." Main " cr up@ dup 2+ @
+    BEGIN  2dup -  WHILE  dup  4+ @  body> >name .name
+       dup c@ 0= ( nop ) IF  ." sleeping"  THEN  cr
+       2+  @  REPEAT  2drop ;
+
+
+

8080/CPM/src/terminal.fb.txt

@@ -0,0 +1,38 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Terminal-Anpassung                                 UH 08OCt87
+
+In diesem File wird volksFORTH an das benutzte Terminal
+angepasst. Ueber folgende Faehigkeiten muss das Terminal
+verfuegen, damit alle Moeglichkeiten von volksFORTH ausgenutzt
+werden koennen:
+
+curon,   curoff   \ Ein- bzw. Ausschalten des Cursors
+rvson,   rvsoff   \ Ein- bzw. Ausschalten der Inversedarstellung
+dark              \ Loeschen des Bildschirms
+locate            \ Positionieren des Cursors auf eine
+                  \ bestimmte Position auf dem Bildschirm
+
+In der Version 3.80a nicht mehr in der Terminal-Anpassung:
+
+curleft, currite  \ Cursor nach links bzw. rechts bewegen
+
+\ *** Block No. 1, Hexblock 1
+
+\ Anpassung fuer ANSI-Terminal                     uho 09May2005
+| : ccon!! ( addr len -- )  bounds ?DO I C@ con! LOOP ;
+| : con!! ( addr -- ) count ccon!! ;
+| : ## ( n -- ) base push decimal 0 <# #S #> ccon!! ;
+| : csi ( -- ) #esc con!  Ascii [ con! ;
+| : ANSIcuron ( -- )  csi " ?25h" con!! ;
+| : ANSIcuroff ( -- ) csi " ?25l" con!! ;
+| : ANSIrvson ( -- )   csi " 7m" con!! ;
+| : ANSIrvsoff ( -- )  csi " 0m" con!! ;
+| : ANSIdark ( -- ) csi " 2J" con!!  csi " ;H" con!! ;
+| : ANSIlocate ( row col -- )
+     csi  swap 1+ ##  ascii ; con! 1+ ## ascii H con! ;
+
+Terminal: ANSI
+noop noop           ANSIrvson ANSIrvsoff ANSIdark ANSIlocate ;
+ANSI page rvson .(  ANSI Terminal installiert. ) rvsoff cr cr

8080/CPM/src/times.fb.txt

@@ -0,0 +1,38 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Times Often: interactive loops                        11Nov86
+
+Dieses File enthaelt die Definitionen der beiden Utility-Worte
+TIMES, OFTEN, die interaktiv benutzt werden koennen, was
+normalerweise mit BEGIN WHILE ... nicht moeglich ist.
+
+Benutzung:  nur interaktiv!
+
+a b ... nn times \ Wiederhole die Befehlsfolge "a b ..." nn mal,
+                 \ oder bis eine Taste gedrueckt wird, oder
+                 \ bis ein Fehler auftritt,
+
+a b ... often     \ Wiederhole die Befehlsfolge "a b ..."
+                  \ so oft, bis eine Taste gedrueckt wird, oder
+                  \ bis ein Fehler auftritt.
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ Times, Often                                           02feb86
+
+also Forth definitions
+
+: often    stop? ?exit  >in off ;
+
+| Variable #times   #times off
+
+: times   ( n --)
+ ?dup IF  #times @ 2+  u<  stop? or
+          IF  #times off  exit  THEN  1 #times +!
+ ELSE  stop? ?exit  THEN  >in off ;
+
+toss definitions
+
+

8080/CPM/src/tools.fb.txt

@@ -0,0 +1,342 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Tools                                                 11Nov86
+Dieses File enthaelt die wichtigsten Werkzeuge zur Programm-
+entwicklung:    - den einfachen Decompiler
+                - der DUMP-Befehl
+                - den Tracer
+
+Der einfache Decompiler wird benutzt, um neue Defining-Words
+zu ueberpruefen. Der automatische Decompiler kann ja dafuer
+nicht benutzt werden, da ihm diese Strukturen unbekannt sind.
+(Benutzung: addr und dann, je nach Art: S N D L C oder B)
+
+DUMP wird zum Ausgeben von Hexdumps benutzt. (from count DUMP)
+
+Der Tracer erlaubt Einzelschrittausfuehrung von Worten.
+Er ist unentbehrliches Hilfsmittel bei der Fehlersuche.
+(Benutzung:  DEBUG <name>  und  END-TRACE)
+
+\ *** Block No. 1, Hexblock 1
+
+\  Programming-Tools word set / tracer            cas 19july2020
+
+Onlyforth    Vocabulary Tools  Tools also definitions
+
+01 05 +thru   &15 &16 +thru
+   06 +load     \ Tracer
+
+Onlyforth
+
+: internal \ start headerless definitions
+   1 ?head ! ;
+
+: external \ end headerless definitions
+   ?head off ;
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+\ Tools for decompiling                                  22feb86
+
+| : ?:     dup 4 u.r ." :" ;
+| : @?     dup @ 6 u.r ;
+| : c?     dup c@ 3 .r ;
+
+: s   ( adr - adr+ )
+ ?: space  c? 3 spaces  dup 1+ over c@ type  dup c@ + 1+ even ;
+
+: n   ( adr - adr+2 )  ?: @? 2 spaces  dup @ >name .name 2+ ;
+: d   ( adr n - adr+n)
+ 2dup swap ?:  swap  0 DO c? 1+ LOOP  2 spaces  -rot type ;
+
+
+
+
+
+\ *** Block No. 3, Hexblock 3
+
+\ Tools for decompiling                                  22feb86
+
+: l   ( adr - adr+2 )    ?: 5 spaces @? 2+ ;
+: c   ( adr - adr+1)     1 d ;
+: b   ( adr - adr+1)     ?: @? dup @ over + 5 u.r 2+ ;
+
+
+
+\\
+: dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE
+THEN 10 +LOOP ;
+
+
+
+
+
+
+\ *** Block No. 4, Hexblock 4
+
+\ General Dump Utility - Output                       UH 07Jun86
+
+| : .2   ( n -- )   0  <#   # #   #>   type  space ;
+| : .6   ( d -- )   <#  # # # # # #  #>  type ;
+| : d.2   ( addr len -- )   bounds ?DO  I C@  .2  LOOP ;
+| : emit.   ( char -- )
+   $7F and  dup bl $7E uwithin not IF drop Ascii . THEN  emit ;
+| : dln   ( addr --- )
+   cr  dup 6 u.r  2 spaces  8 2dup d.2  space
+   over + 8 d.2  space   $10 bounds ?DO  I C@ EMIT.  LOOP  ;
+| : ?.n    ( n1 n2 -- n1 )
+   2dup = IF  ." \/"  drop  ELSE  2 .r  THEN   space ;
+| : ?.a    ( n1 n2 -- n1 )
+   2dup = IF  ." V"  drop   ELSE  1 .r  THEN ;
+
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ .head                                               UH 03Jun86
+
+
+| : .head   ( addr len -- addr' len' )
+   swap  dup -$10 and  swap  $0F and  cr 8 spaces
+   8 0 DO  I ?.n  LOOP  space  $10 8 DO  I ?.n  LOOP
+   space  $10 0 DO  I ?.a  LOOP  rot + ;
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 6, Hexblock 6
+
+\ Dump and Fill Memory Utility                        UH 25Aug86
+
+Forth definitions
+
+: dump   ( addr len -- )
+ base push  hex    .head
+ bounds ?DO  I dln  stop? IF  LEAVE  THEN  $10 +LOOP ;
+
+Tools definitions
+
+: du   ( addr -- addr+$40 )     dup $40 dump  $40 + ;
+
+: dl   ( line# -- )             c/l * scr @ block + c/l  dump ;
+
+Forth definitions
+
+
+\ *** Block No. 7, Hexblock 7
+
+\ Trace Loadscreen                                       29Jun86
+
+Onlyforth       \needs Tools    Vocabulary Tools
+Tools also definitions
+
+1 8 +thru
+
+Onlyforth
+
+\ clear
+
+\  don't forget END-TRACE after using DEBUG
+
+
+
+
+
+\ *** Block No. 8, Hexblock 8
+
+\ Variables do-trace                                  UH 04Nov86
+
+| Variable Wsave        \ Variable for saving W
+| Variable <ip          \ start of trace trap range
+| Variable ip>          \ end of trace trap range
+| Variable 'ip          \ holds IP  (preincrement!)
+| Variable nest?        \ True if NEST shall be performed
+| Variable newnext      \ Address of new Next for tracing
+| Variable #spaces      \ for indenting nested trace
+| Variable tracing      \ true if trace mode active
+
+
+
+
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+\ install Tracer                                      UH 18Nov87
+
+Tools definitions
+
+| Code do-trace   \ patch Next to new definition
+   $C3 A mvi ( jmp )  >next sta
+   newnext lhld       >next 1+ shld  Next
+end-code
+
+
+
+
+
+
+
+
+
+\ *** Block No. 10, Hexblock a
+
+\ throw status on Return-Stack                           29Jun86
+
+| Create: npull
+   rp@ count  2dup + even rp!  r> swap cmove ;
+
+: npush  ( addr len --)   r> -rot  over >r
+   rp@ over 1+ -  even dup rp!  place  npull >r  >r ;
+
+| : oneline   .status space query interpret  -&82 allot
+              rdrop ( delete quit from tracenext ) ;
+
+
+
+
+
+
+
+\ *** Block No. 11, Hexblock b
+
+\ reenter tracer                                         04Nov86
+
+| Code (step
+   true H lxi   tracing shld   IP rpop   Wsave lhld   H W mvx
+Label fnext
+   xchg
+   M E mov   H inx   M D mov   xchg   pchl
+end-code
+
+| Create: nextstep   (step ;
+
+| : (debug  ( addr --)   \ start tracing at addr
+      dup  <ip !
+      BEGIN  1+ dup @   ['] unnest =  UNTIL  2+ ip> ! ;
+
+
+
+\ *** Block No. 12, Hexblock c
+
+\ check trace conditions                                 04Nov86
+
+Label tracenext   tracenext newnext !
+   IP ldax  IP inx   A L mov   IP ldax   IP inx   A H mov
+   xchg   tracing lhld   H A mov   L ora   fnext jz
+   nest? 1+ lda   A ana
+   0= ?[
+         <IP lhld  H inx
+         IP A mov  H cmp   fnext jc
+           0= ?[ IP' A mov  L cmp   fnext jc ]?
+         IP> lhld
+         H A mov   IP cmp   fnext jc
+           0= ?[ L A mov   IP' cmp   fnext jc ]?
+      ][ A xra nest? 1+ sta  ]? \ low byte still set
+                            \ one trace condition satisfied
+   W H mvx   Wsave shld   false H lxi   tracing shld
+
+\ *** Block No. 13, Hexblock d
+
+\ tracer display                                      UH 25Jan88
+
+;c: nest? @
+    IF  nest? off  r>  ip> push  <ip push  dup 2- (debug
+         #spaces push  1 #spaces +!  >r   THEN
+    r@ nextstep >r  input push  output push  standardi/o
+    cr #spaces @ spaces
+    dup 'ip !  2-  dup 5 u.r  @ dup 6 u.r  2 spaces
+    >name .name  $1C col -  0 max spaces  .s
+    state push  blk push  >in push  ['] 'quit >body push
+    [ ' parser >body ] Literal push
+    span push  #tib push  tib #tib @ npush  r0 push
+    rp@ r0 !  &82 allot  ['] oneline Is 'quit  quit ;
+
+
+
+
+\ *** Block No. 14, Hexblock e
+
+\ DEBUG with errorchecking                               28Nov86
+
+| : traceable  ( cfa -- cfa' )
+ recursive  dup @
+ ['] : @    case? ?exit
+ ['] key @  case? IF  >body c@ Input @ +  @  traceable exit THEN
+ ['] type @ case? IF  >body c@ Output @ + @  traceable exit THEN
+ ['] r/w  @ case? IF  >body                  traceable exit THEN
+ dup 1+ @ [ ' Forth @ 1+ @ ] Literal =      IF nip 1+  exit THEN
+ drop >name .name ." can't be DEBUGged" quit ;
+
+also Forth definitions
+
+: debug  ( -- )   \ reads a word
+   '  traceable  (debug   Tools
+   nest? off  #spaces off  tracing on  do-trace ;
+
+\ *** Block No. 15, Hexblock f
+
+\ misc. words for tracing                                28Nov86
+Tools definitions
+
+: nest                  \ trace next high-level word executed
+   'ip @ 2- @ traceable drop  nest? on ;
+
+: unnest                \ ends tracing of actual word
+   <ip on  ip> off ;    \ clears trap range
+
+: endloop               \ stop tracing loop
+   'ip @ <ip ! ;        \ use when at end of loop
+
+Forth definitions
+
+: trace' ( -- )   \ reads a word
+   context push   debug   <ip perform  end-trace ;
+
+\ *** Block No. 16, Hexblock 10
+
+\ N>R  NR> cr
+
+: N>R  ( i * n +n -- ) ( R: -- j * x +n )
+\ Transfer N items and count to the return stack.
+  DUP BEGIN DUP WHILE
+    ROT R> SWAP >R >R
+    1-
+  REPEAT DROP  R> SWAP >R >R  ;
+
+: NR>  ( -- i * x +n ) ( R: j * x +n -- )
+\ Pull N items and count off the return stack.
+  R> R> SWAP >R DUP
+  BEGIN  DUP  WHILE
+     R> R> SWAP >R -ROT
+     1-
+ REPEAT  DROP  ;
+
+\ *** Block No. 17, Hexblock 11
+
+\  ?
+
+: ?  ( a-addr -- )
+\ Display the value stored at a-addr.
+  @ . ;
+
+
+
+
+
+
+
+
+
+
+

8080/CPM/src/v4th.fs

@@ -0,0 +1,24 @@
+
+Onlyforth
+
+: .pagestatus  ( n -- )
+  cr ." page " .
+  ." here "  here u.
+  ." there " there u.
+  ." displaced there " there displace @ + u.
+  ." heap "  heap u.  cr
+;
+
+    $8000 displace !
+Target definitions   $100 here!
+
+  include vf-core.fs
+  include vf-io.fs
+  include vf-sys.fs
+  include vf-bdos.fs
+  include vf-file.fs
+  include vf-end.fs
+
+cr .( unresolved: )  .unresolved   ( ' .blk is .status )
+
+save-target  V4TH.COM