Draft: Blocks wordset

Makefile

@@ -19,7 +19,7 @@ SRC_DIR = forth
 SRC_NAMES = base debug v asm gfx gfxdemo rnd sin ls turtle fractals \
     sprite doloop sys labels mml mmldemo sid spritedemo \
     format require compat timer float viceutil turnkey \
-    wordlist io open dos see accept
+    wordlist io open dos see accept block
 SRCS = $(addprefix $(SRC_DIR)/,$(addsuffix .fs,$(SRC_NAMES)))
 
 TEST_SRC_NAMES = test testcore testcoreplus testcoreext tester testsee 1

asm/interpreter.asm

@@ -126,17 +126,15 @@ interpret_tib
     cmp TIB_SIZE + 1
     bne interpret_tib
 
-    ; 0 - keyboard, -1 evaluate, else file
-    lda SOURCE_ID_LSB
-    beq +
-    rts
-+   lda LATEST_LSB
+    lda LATEST_LSB
     sec
     sbc HERE_LSB
     lda LATEST_MSB
     sbc HERE_MSB
     beq .on_data_underflow
     lda STATE
+    ora SOURCE_ID_LSB
+    ora BLK_W
     bne +
     lda #'o'
     jsr PUTCHR

asm/io.asm

@@ -1,4 +1,5 @@
-; EMIT PAGE RVS CR TYPE KEY? KEY REFILL SOURCE SOURCE-ID >IN CHAR IOABORT
+; EMIT PAGE RVS CR TYPE KEY? KEY REFILL SOURCE SOURCE-ID >IN BLK CHAR IOABORT
+; BLOCK-XT LOAD
 
     +BACKLINK "emit", 4
 EMIT
@@ -60,12 +61,23 @@ CLOSE_INPUT_SOURCE
     lda	SOURCE_ID_LSB
     jsr	CLOSE
     jsr POP_INPUT_SOURCE
+    lda BLK_W
+    bne .restore_block
     ldx SOURCE_ID_LSB
-    beq +
+    beq .restore_keyboard
     jsr CHKIN
-    jmp ++
-+   jsr CLRCHN
-++  ldx W
+    jmp .ret
+.restore_keyboard
+    jsr CLRCHN
+.ret
+    ldx W
+    rts
+.restore_block
+    ldx W
+    jsr BLK
+    jsr FETCH
+    jsr BLOCK
+    inx ; assume block buffer address is unchanged
     rts
 
     +BACKLINK "refill", 6
@@ -211,6 +223,12 @@ TO_IN
 TO_IN_W
     !word 0
 
+    +BACKLINK "blk", 3
+BLK
+    +VALUE BLK_W
+BLK_W
+    !word 0
+
     +BACKLINK "char", 4
 CHAR ; ( name -- char )
     jsr PARSE_NAME
@@ -223,7 +241,7 @@ SAVE_INPUT_STACK
     ; Eight levels is overkill for INCLUDED, since opening more than four DOS
     ; channels gives a "no channel" error message on C64.
     ; It is anyway nice to keep some extra levels for EVALUATE and LOAD.
-    !fill 8*12
+    !fill 8*13
 SAVE_INPUT_STACK_DEPTH
     !byte 0
 
@@ -241,6 +259,8 @@ pop_input_stack
     rts
 
 PUSH_INPUT_SOURCE
+    lda BLK_W
+    jsr push_input_stack
     lda TO_IN_W
     jsr push_input_stack
     lda TO_IN_W+1
@@ -291,6 +311,8 @@ POP_INPUT_SOURCE
     sta TO_IN_W+1
     jsr pop_input_stack
     sta TO_IN_W
+    jsr pop_input_stack
+    sta BLK_W
     rts
 
 ; handle errors returned by open,
@@ -347,3 +369,29 @@ IOABORT ; ( ioresult -- )
 .cr_abort
     jsr CR
     jmp ABORT
+
+    +BACKLINK "block-xt", 8
+    +VALUE BLOCK + 1
+BLOCK
+    jmp PLACEHOLDER_ADDRESS
+
+    +BACKLINK "load", 4
+    jsr PUSH_INPUT_SOURCE
+    jsr DUP
+    jsr BLK
+    jsr STORE
+    jsr ZERO
+    jsr TO_IN
+    jsr STORE
+    jsr BLOCK
+    lda LSB,x
+    sta TIB_PTR
+    lda MSB,x
+    sta TIB_PTR + 1
+    inx
+    lda #0
+    sta TIB_SIZE
+    lda #4
+    sta TIB_SIZE + 1
+    jsr interpret_tib
+    jmp CLOSE_INPUT_SOURCE

forth/base.fs

@@ -183,7 +183,9 @@ hide dodoes
 .( require..) include require
 .( open..) include open
 .( accept..) include accept
-.( v..) include v
+\ .( v..) include v
+
+.( block..) include block
 
 decimal
 include turnkey
@@ -199,4 +201,4 @@ $20 + + - \ save-pack padding
 save-pack @0:durexforth
 .( ok!) cr
 
-0 $d7ff c! \ for vice -debugcart
+\ 0 $d7ff c! \ for vice -debugcart

forth/block.fs

@@ -0,0 +1,160 @@
+require io
+
+marker ---block---
+
+header block
+header buffer
+header create-blocks
+header empty-buffers
+header flush
+header list
+header save-buffers
+header update
+
+latest \ hide words
+
+( 11 block buffers at $a000-$cbff.
+  this may be excessive, let's
+  shrink it once v is replaced with
+  a block-based editor. )
+
+\ buf block id's
+create bbi   0 , 0 , 0 , 0 , 0 , 0 c,
+create dirty 0 , 0 , 0 , 0 , 0 , 0 c,
+create curr-buf 0 c,
+
+variable map 0 map !
+: path s" blocks" ;
+
+: get## ( -- n )
+chrin '0' - #10 * chrin '0' - + ;
+
+variable t variable s
+
+: b-a ( -- ) \ allocate sector
+decimal <# s @ 0 #s bl hold 2drop
+t @ 0 #s bl hold '0' hold bl hold
+'a' hold '-' hold 'b' hold #>
+$f $f open ioabort $f chkin ioabort
+get## case #65 of \ no block
+#10 0 do chrin drop loop
+get## t ! chrin drop get## s !
+clrchn $f close recurse endof
+#66 of \ illegal track/sector
+s @ 0= abort" full"
+0 s ! 1 t +! clrchn $f close recurse
+endof endcase clrchn $f close ;
+
+\ Usage: "20 create-blocks" allocates
+\ 20 Forth blocks = 80 sectors and
+\ writes a map file named "blocks".
+define create-blocks ( n -- )
+path here loadb abort" exist"
+1 t ! 0 s ! here map !
+4 * 0 do b-a t @ c, s @ c, 1 s +!
+loop map @ here path saveb ;
+
+: load-map map @ if exit then
+here path here loadb dup 0=
+abort" no blocks" to here map ! ;
+
+: >addr ( buf -- addr )
+$400 * $a000 + ;
+
+: write-sector ( t s src -- ) decimal
+s" #" 5 5 open ioabort
+s" b-p 5 0" $f $f open ioabort
+5 chkout ioabort
+dup $100 + swap do i c@ emit loop
+$f chkout ioabort
+<# $d hold 0 #s 2drop bl hold 0 #s
+bl hold '0' hold bl hold '5' hold
+bl hold '2' hold 'u' hold #> type
+clrchn $f close 5 close ;
+
+: save-buf ( buf -- )
+dup dirty + c@ 0= if drop exit then
+load-map 0 over dirty + c!
+dup bbi + c@ 1- 8 * map @ +
+swap >addr dup $400 + swap do
+dup @ split i write-sector
+2+ $100 +loop drop ;
+
+: >buf ( blk -- buf ) #11 mod ;
+
+: read-sector ( dst t s -- ) decimal
+s" #" 5 5 open ioabort <# 0 #s bl hold
+2drop 0 #s bl hold '0' hold bl hold
+'5' hold bl hold '1' hold 'u' hold #>
+$f $f open ioabort 5 chkin ioabort
+dup $100 + swap do chrin i c! loop
+$f close 5 close clrchn ;
+
+: load-blk ( blk -- )
+load-map dup 1- 8 * map @ + swap >buf
+>addr dup $400 + swap do i over @
+split read-sector 2+ $100 +loop drop ;
+
+: set-blk ( blk -- addr )
+dup >buf curr-buf c!
+dup dup >buf bbi + c! >buf >addr ;
+
+: unassign ( blk -- blk )
+dup >buf dup save-buf bbi + 0 swap c! ;
+
+: loaded? ( blk -- blk flag )
+dup dup >buf bbi + c@ = ;
+
+define block ( blk -- addr )
+loaded? 0= if unassign dup load-blk
+then set-blk ;
+
+' block block-xt !
+
+define buffer ( blk -- addr )
+loaded? 0= if unassign then set-blk ;
+
+define list ( blk -- )
+block dup $400 + swap do
+i c@ emit loop ;
+
+define empty-buffers ( -- )
+bbi #11 erase dirty #11 erase ;
+
+define update ( -- )
+1 dirty curr-buf c@ + c! ;
+
+define save-buffers ( -- )
+11 0 do i save-buf loop ;
+
+define flush save-buffers empty-buffers ;
+
+to latest \ end hiding words
+
+: \ blk @ if >in @ dup #40 mod - #40 +
+>in ! else postpone \ then ; immediate
+
+: refill blk @ ?dup if
+1+ block if 1 blk +! -1 else 0 then
+else refill then ;
+
+: evaluate blk @ >r 0 blk !
+evaluate r> blk ! ;
+
+( --- testing
+
+: test-load
+4 create-blocks 0
+s" 1 2 load 7" 1 block swap move update
+s" 2 3 load 6" 2 block swap move update
+s" 3 4 load 5" 3 block swap move update
+s" 4" 4 block swap move update
+1 load
+7 <> abort" 7"
+6 <> abort" 6"
+5 <> abort" 5"
+4 <> abort" 4"
+3 <> abort" 3"
+2 <> abort" 2"
+1 <> abort" 1"
+0 <> abort" 0" ; )

manual/memmap.adoc

@@ -10,7 +10,7 @@ $35b - $3d9 :: `pad` Scratch pad memory, Cassette Buffer, untouched by DurexFort
 $3da - $3fb :: `#>` buffer.
 $801 - here :: Forth Kernel followed by code and data space.
 latest - $9fff :: Dictionary. Grows downwards as needed.
-$a000 - $cbff :: Editor text buffer.
+$a000 - $cbff :: Editor text buffer / Block buffers.
 $cc00 - $cfff :: Hi-res graphics colors.
 $d000 - $dfff :: I/O area.
 $e000 - $ffff :: Kernal / hi-res graphics bitmap.