Solo Forth development history in 2016-01..2016-02
Description of the page content
Solo Forth development history from 2016-01 to 2016-02.
Tags:
2016-01-01
Fix: id. was not renamed to .name in the library.
Rewrote ?dup in Z80. It's much faster and saves 3 bytes:
; XXX OLD
; _colon_header question_dup_,'?DUP'
; dw dup_
; dw zero_branch_,question_dup.end
; dw dup_
; question_dup.end:
; dw exit_
; XXX NEW
_code_header question_dup_,'?DUP'
pop hl
ld a,h
or l
jp z,push_hl
push hl
jp push_hl
Benchmarked both versions of ?dup:
( ?dup-bench )
\ 2016-01-01
need bench{ variable times 40000 times !
: iterations ( -- n1 n2 ) times @ 0 ;
: forth-0-?dup-bench ( -- )
bench{ iterations do 0 ?dup drop loop }bench. ;
: z80-0-?dup-bench ( -- )
bench{ iterations do 0 ?dup80 drop loop }bench. ;
: forth-1-?dup-bench ( -- )
bench{ iterations do 1 ?dup 2drop loop }bench. ;
: z80-1-?dup-bench ( -- )
bench{ iterations do 1 ?dup80 2drop loop }bench. ;
: ?dup-bench ( -- )
cr ." Forth version:" cr ." 0 ?dup :" forth-0-?dup-bench cr
." 1 ?dup :" forth-1-?dup-bench cr
." Z80 version:" cr ." 0 ?dup :" z80-0-?dup-bench cr
." 1 ?dup :" z80-1-?dup-bench cr ;
\ Code Frames for 40000 iterations
\ ----- ---------------------------
\ Forth Z80
\ ----- ----
\ `0 ?dup` 532 288
\ `1 ?dup` 585 312
Fixed a recently introduced bug in previous.
2016-01-02
Renamed some words of the xstack module.
2016-02-16
New benchmark for constants and literals.
First plans for dividing the library into several files.
2016-02-17
Added a simple defition for string constants:
: sconstant ( ca len "name" -- )
here >r s, r> count 2constant ;
Fixed 2constant: its alternative code for DTC was missing.
Added a new word to the benchmark tools:
: benched ( xt n -- )
bench{ 0 do dup execute loop }bench. drop ;
Version 0.1.0-rc3+20160217.
Replaced break-key? with nuf? in words, words-like, index, index-like and index-ilike.
Version 0.1.0-rc4+20160217.
Improved the benchmarking tool.
2016-02-18
New debugging tool, inspired by Gforth's ~~:
( ~~ )
\ 2016-02-18: First version.
variable ~~? ~~? on \ active?
variable ~~x ~~x off \ x coordinate
variable ~~y ~~y off \ y coordinate
variable ~~key ~~key off \ quit key, or zero if no pause
: ((~~)) ( nt blk -- )
~~x @ ~~y @ at-xy ." Block " . .name .s
~~key @ ?dup 0= ?exit key = if quit then ;
\ Execute the debugging code: show the block and the name
\ of the word `~~` was compiled into. If `~~key` is
\ zero, exit; else wait for a key and quit if it equals
\ the contents of `~~key`.
: (~~) ( nt blk -- ) ~~? @ if ((~~)) else 2drop then ;
\ Execute the debugging code, if active.
: ~~ ( -- )
latest postpone literal blk @ postpone literal
postpone (~~) ; immediate compile-only
\ Compile debugging code.
\ This word was inspired by Gforth's `~~`.
Version 0.1.0-rc5+20160218.
Second version, improved with line number and more factored:
variable ~~? ~~? on \ active?
variable ~~x ~~x off \ x coordinate
variable ~~y ~~y off \ y coordinate
variable ~~key ~~key off \ quit key, or zero if no pause
: ~~show ( nt line block -- )
~~x @ ~~y @ at-xy ." Block " . ." Line " . .name .s ;
\ Show the debugging info.
: ~~control ( -- )
~~key @ ?dup 0= ?exit key = if quit then ;
\ If `~~key` is non-zero, wait for a key and quit if it
\ equals the contents of `~~key`.
: (~~) ( nt line block -- )
~~? @ if ~~show ~~control else 2drop drop then ;
\ Execute the debugging code, if debugging is active.
: ~~ ( -- )
latest postpone literal
>in @ c/l / postpone literal
blk @ postpone literal
postpone (~~) ; immediate compile-only
\ Compile debugging code.
\ This word was inspired by Gforth's `~~`.
2016-02-20
Renamed all words related to physical keys using the "kk" prefix, and did other name changes as well. Fixed the selection of kk, and kk@ depending on /kk: the flag used by conditional compilation was inversed. Renamed and documented the keyboard ports table and created the kk-chars table, and constants to be used as indexes.
Fixed (mode32-xy), which returned the coordinates in inverse order.
Fixed :noname: the DTC alternative code was not implemented.
2016-02-22
Added interpretation semantics to s\":
: s\" ( Interpretation: "text<quote>" -- ca len )
( Compilation: "text<quote>" -- )
( Run-time: -- ca len )
parse-escaped-string compiling? if postpone sliteral then
; immediate
Wrote .\":
: .\" ( Compilation: "text<quote>" -- )
( Run-time: -- ca len )
compile (.") parse-escaped-string s,
; immediate compile-only
2016-02-23
Another implementation of play:
( play )
\ Faster version of the previous `play`, using `c@+`,
\ which requires the assembler.
need !p need c@+
need sound-register-port need sound-write-port
: play ( a -- )
\ a = address of a table with 14 bytes
14 0 do
i sound-register-port !p c@+ sound-write-port !p
loop drop ;
2016-02-25
New 128 sound effects in the library: bomber whip metalic rain lightning1 lighting2.
2016-02-26
Started adapting the DRAW-LINE plot routine to use the whole screen.
Fixed and improved sound:. The old version was:
: sound: ( b0 ... b13 name -- )
create here 1- 14 allot here -1 do i c! -1 +loop ;
The new version:
14 constant /sound
: sound, ( b0 ... b13 -- )
here /sound allot here 1- do i c! -1 +loop ;
: sound: ( b0 ... b13 "name" -- ) create sound, ;
addp cannot be used with the index registers, because the hl register is implicit. Thus I added two specific instructions to the assembler:
: addix ( rp -- ) ix-op c, addp ;
: addiy ( rp -- ) iy-op c, addp ;
Added two more words to manipulate the data stack:
( ndrop )
need z80-asm
code ndrop ( x1..xn n -- )
hl pop hl addp exde \ DE = n cells
\ pop hl
\ add hl,hl
\ ex de,hl
0 hl ldp# sp addp \ HL = stack pointer
\ ld hl,0
\ add hl,sp
de addp ldsp \ update SP
\ add hl,de
\ ld sp,hl
jpnext
end-code
\ doc{
\
\ ndrop ( x1..xn n -- )
\
\ Drop _n_ cell items from the stack.
\
\ }doc
( 2ndrop )
need z80-asm
code 2ndrop ( dx1..dxn n -- )
hl pop hl addp hl addp exde \ DE = n cells
\ pop hl
\ add hl,hl
\ add hl,hl
\ ex de,hl
0 hl ldp# sp addp \ HL = stack pointer
\ ld hl,0
\ add hl,sp
de addp ldsp \ update SP
\ add hl,de
\ ld sp,hl
jpnext
end-code
\ doc{
\
\ ndrop ( dx1..dxn n -- )
\
\ Drop _n_ double cell items from the stack.
\
\ }doc
Added three graphic words for clearing and coloring screen blocks:
( clear-block )
\ Credits:
\
\ Code extracted and adapted from a routine written by Pablo
\ Ariza, published on Microhobby Especial, issue 7 (1987-12),
\ page 50: <http://microhobby.org/mhes7.htm>.
need z80-asm
code clear-block ( column row width height -- )
\ doc{
\
\ clear-block ( column row width height -- )
\
\ Clear a screen block at the given character coordinates and
\ of the given size in characters. Only the bitmap is
\ cleared. The color attributes remain unchanged.
\
\ }doc
exx 0 ix ldp# sp addix
\ exx ; save the Forth IP
\ ld ix,0
\ add ix,sp ; ix = address of TOS
\
\ ; ix+6 = column
\ ; ix+4 = row
\ ; ix+2 = width
\ ; ix+0 = height
#4 ix a ftx a d ld rrca rrca rrca #224 and# #6 ix orx
\ ld a,(ix+4) ; row
\ ld d,a
\ rrca
\ rrca
\ rrca
\ and 224
\ or (ix+6) ; column
a e ld d a ld #24 and# #64 or# a d ld
\ ld e,a
\ ld a,d ; column
\ and 24
\ or 64
\ ld d,a
#2 ix c ftx #0 ix a ftx a add a add a add a b ld
\ ld c,(ix+2) ; width
\ ld a,(ix+0) ; height
\ add a,a
\ add a,a
\ add a,a
\ ld b,a ; width*8
begin
\ delete_bitmap:
de push de hl ldp de incp 0 m ld# bc push c dec
\ push de ; save the address of the block scan
\ ld l,e
\ ld h,d ; HL = origin, start of the scan
\ inc de ; DE = destination
\ ld (hl),0 ; delete the first byte
\ push bc ; save the counts
\ dec c ; is width greater than 1?
nz if 0 b ld# ldir then
\ jr z,label1
\ ld b,0 ; BC = width
\ ldir ; erase the rest of the scan
\ label1:
bc pop de pop d inc d a ld 7 and#
\ pop bc ; restore counts
\ pop de ; restore address of scan
\ inc d
\ ld a,d
\ and 7
z if #32 a ld# e add a e ld
nc if d a ld 8 sub# a d ld then
then
\ jr nz,inc_char
\ ld a,32
\ add a,e
\ ld e,a
\ jr c,inc_char
\ ld a,d
\ sub 8
\ ld d,a
\ inc_char:
step 0 hl ldp# sp addp #4 cells de ldp# de addp ldsp
\ djnz delete_bitmap
\ ; Drop the parameters:
\ ld hl,0
\ add hl,sp
\ ld de,5*cells
\ add hl,de
\ ld sp,hl
exx next ix ldp# jpnext end-code
\ exx ; restore the Forth IP
\ ld ix,next ; restore IX
\ jp next
( color-block )
\ Credits:
\
\ Code extracted and adapted from a routine written by Pablo
\ Ariza, published on Microhobby Especial, issue 7 (1987-12),
\ page 50: <http://microhobby.org/mhes7.htm>.
need z80-asm
code color-block ( column row width height color -- )
\ doc{
\
\ color-block ( column row width height color -- )
\
\ Color a screen block at the given character coordinates and
\ of the given size in characters. Only the color attributes
\ are changed; the bitmap remains unchanged.
\
\ }doc
exx 0 ix ldp# sp addix
\ exx ; save the Forth IP
\ ld ix,0
\ add ix,sp ; ix = address of TOS
\
\ ; ix+8 = column
\ ; ix+6 = row
\ ; ix+4 = width
\ ; ix+2 = height
\ ; ix+0 = color
#6 ix a ftx #22 d ld# a add a add a add a add
\ ld a,(ix+6) ; row
\ ld d,22
\ add a
\ add a
\ add a
\ add a ; row*8
d rl a add d rl #8 ix orx a e ld
\ rl d
\ add a
\ rl d
\ or (ix+8) ; column
\ ld e,a
#2 ix b ftx #4 ix c ftx
\ ld b,(ix+2) ; height
\ ld c,(ix+4) ; width
begin
\ delete_attributes:
de push de hl ldp de incp bc push #0 b ld#
\ push de
\ ld h,d
\ ld l,e
\ inc de
\ push bc
\ ld b,0
0 ix a ftx a m ld c dec
\ ld a,(ix+0) ; color
\ ld (hl),a
\ dec c
nz if ldir then
\ jr z,no_more_attributes
\ ldir
\ no_more_attributes:
bc pop hl pop #32 de ldp# de addp exde
\ pop bc
\ pop hl
\ ld de,32
\ add hl,de
\ ex de,hl
step
\ djnz delete_attributes
\ Drop the parameters:
0 hl ldp# sp addp #5 cells de ldp# de addp ldsp
\ ld hl,0
\ add hl,sp
\ ld de,5*cells
\ add hl,de
\ ld sp,hl
exx next ix ldp# jpnext end-code
\ exx ; restore the Forth IP
\ ld ix,next ; restore IX
\ jp next
( wipe-block )
\ Credits:
\
\ Code adapted from a routine written by Pablo Ariza,
\ published on Microhobby Especial, issue 7 (1987-12), page
\ 50: <http://microhobby.org/mhes7.htm>.
need z80-asm
code wipe-block ( column row width height color -- )
\ doc{
\
\ wipe-block ( column row width height color -- )
\
\ Wipe a screen block at the given character coordinates and
\ of the given size in characters. The bitmap is erased and
\ the color attributes are changed with the given color.
\
\ This word is written in assembler and it combines the
\ functions of `clear-block` and `color-block`. It may be
\ defined also this way (with slower but much smaller code):
\ ----
\ : wipe-block ( column row width height color -- )
\ >r 2over 2over clear-block r> color-block ;
\ ----
\ }doc
exx 0 ix ldp# sp addix
\ exx ; save the Forth IP
\ ld ix,0
\ add ix,sp ; ix = address of TOS
\
\ ; ix+8 = column
\ ; ix+6 = row
\ ; ix+4 = width
\ ; ix+2 = height
\ ; ix+0 = color
#6 ix a ftx a d ld rrca rrca rrca #224 and# #8 ix orx
\ ld a,(ix+6) ; row
\ ld d,a
\ rrca
\ rrca
\ rrca
\ and 224
\ or (ix+8) ; column
a e ld d a ld #24 and# #64 or# a d ld
\ ld e,a
\ ld a,d ; column
\ and 24
\ or 64
\ ld d,a ; DE = top left address of the block
#4 ix c ftx #2 ix a ftx a add a add a add a b ld
\ ld c,(ix+4) ; width
\ ld a,(ix+2) ; height
\ add a,a
\ add a,a
\ add a,a
\ ld b,a ; width*8
begin
\ delete_bitmap:
de push de hl ldp de incp 0 m ld# bc push c dec
\ push de ; save the address of the block scan
\ ld l,e
\ ld h,d ; HL = origin, start of the scan
\ inc de ; DE = destination
\ ld (hl),0 ; delete the first byte
\ push bc ; save the counts
\ dec c ; is width greater than 1?
nz if 0 b ld# ldir then
\ jr z,label1
\ ld b,0 ; BC = width
\ ldir ; erase the rest of the scan
\ label1:
bc pop de pop d inc d a ld 7 and#
\ pop bc ; restore counts
\ pop de ; restore address of scan
\ inc d
\ ld a,d
\ and 7
z if #32 a ld# e add a e ld
nc if d a ld 8 sub# a d ld then
then
\ jr nz,inc_char
\ ld a,32
\ add a,e
\ ld e,a
\ jr c,inc_char
\ ld a,d
\ sub 8
\ ld d,a
\ inc_char:
step -->
\ djnz delete_bitmap
( wipe-block )
#6 ix a ftx #22 d ld# a add a add a add a add
\ ld a,(ix+6) ; row
\ ld d,22
\ add a
\ add a
\ add a
\ add a ; row*8
d rl a add d rl #8 ix orx a e ld #2 ix b ftx
\ rl d
\ add a
\ rl d
\ or (ix+8) ; column
\ ld e,a
\ ld b,(ix+2) ; height
begin
\ delete_attributes:
de push de hl ldp de incp bc push #0 b ld#
\ push de
\ ld h,d
\ ld l,e
\ inc de
\ push bc
\ ld b,0
0 ix a ftx a m ld c dec
\ ld a,(ix+0) ; color
\ ld (hl),a
\ dec c
nz if ldir then
\ jr z,no_more_attributes
\ ldir
\ no_more_attributes:
bc pop hl pop #32 de ldp# de addp exde
\ pop bc
\ pop hl
\ ld de,32
\ add hl,de
\ ex de,hl
step
\ djnz delete_attributes
\ Drop the parameters:
0 hl ldp# sp addp #5 cells de ldp# de addp ldsp
\ ld hl,0
\ add hl,sp
\ ld de,5*cells
\ add hl,de
\ ld sp,hl
exx next ix ldp#
\ exx ; restore the Forth IP
\ ld ix,next ; restore IX
jpnext end-code
2016-02-27
The DTC version of alias has a bug: the alias of an unitialized deferred word will execute the default error even after its initialization:
: deferred? ( xt -- wf ) c@ $C3 = ;
\ Is _xt_ a deferred word?
\ The code of a deferred word starts with a Z80 jump ($C3)
\ to the word it's associated to.
: alias ( xt "name" -- )
dup deferred? if 1+ @ then defer latest name> defer! ;
\ doc{
\
\ alias ( xt "name" -- )
\
\ Create an alias _name_ that will execute _xt_.
\
\ If _xt_ is a deferred word, the alias will point to the
\ word it's associated to.
\
\ }doc
The solution is making it simpler:
: alias ( xt "name" -- ) defer latest name> defer! ;
\ doc{
\
\ alias ( xt "name" -- )
\
\ Create an alias _name_ that will execute _xt_.
\
\ }doc
But eventually an actual alias will be implemented, which will the return the same xt.
Fixed macro, which was written when : was immediate.