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.