Solo Forth development history in 2015-09

Description of the page content

Solo Forth development history in 2015-09.

Tags:

2015-09-01

Modified the assembler: Included a 1- in >relresolve, so the parameter can be here; removed just-here. Simpler.

Added a word to scroll the screen one pixel up. This word may be useful to improve the FZX driver.

( scroll-1px-up )

  \ [Code adapted from a routine written by Iván Sansa,
  \ published in Microhobby, issue 122 (1987-03), page 7:
  \ http://microhobby.org/numero122.htm
  \ http://microhobby.speccy.cz/mhf/122/MH122_07.jpg]

require z80-asm

create (scroll-1px-up)  ( -- a )

  \ Scroll the whole screen one pixel up.
  \ This is the Z80 routine that can be called from code words.

  asm

  4000 hl ldp#  BF b ld#

  begin
    bc push  hl de ldp  h inc  h a ld  F8 and#  h cp
    z if    8 b ld#  b sub  rra  rra  rra  a h ld  0020 bc ldp#
            bc addp  h a ld  rla  rla  rla  a h ld
    then    hl push  0020 bc ldp#  ldir  hl pop  bc pop
  step

  end-asm

code scroll-1px-up  ( -- )

  \ Scroll the whole screen one pixel up.

  bc push  \ Forth IP
  ' (scroll-1px-up) cfa>pfa call
  bc pop  jpnext  end-code

Finished the alternative definition of pixel-add, that does not jump to the ROM routine. It's faster but bigger. The previous version is the default one.

( pixel-add )

create pixel-add  ( -- a )

  \ This Z80 routine is an alternative entry point to the
  \ "pixel-add" ROM routine (0x22AA), to let the range of the y
  \ coordinate to be 0..191 instead of 0..175.

  \ a = address of the routine

  \ Input registers:
  \   c = x cordinate (0..255)
  \   b = y coordinate (0..191)
  \ Output registers:
  \   hl = address of the pixel byte in the screen bitmap
  \   a = position of the pixel in the byte address (0..7),
  \       note: position 0=bit 7, position 7=bit 0.

  asm
  3E c, BF c,   \ ld a,191 ; max Y coordinate
  90 00 + c,    \ sub b
  C3 c, 22B0 ,  \ jp 0x22B0 ; and return
  end-asm

( pixel-add )

require z80-asm

create pixel-add  ( -- a )

  \ This Z80 routine is a modified copy of the "pixel-add" ROM
  \ routine (0x22AA), to let the range of the y coordinate to
  \ be 0..191 instead of 0..175. Calling this code is a bit
  \ faster than calling the version that uses the ROM, because
  \ the necessary jump is saved and a useless `and a` has been
  \ removed.

  \ a = address of the routine

  \ Input registers:
  \   c = x cordinate (0..255)
  \   b = y coordinate (0..191)
  \ Output registers:
  \   hl = address of the pixel byte in the screen bitmap
  \   a = position of the pixel in the byte address (0..7),
  \       note: position 0=bit 7, position 7=bit 0.

  asm

  BF a ld#  b sub
    \ b= adjusted Y coordinate (0..191)

  a b ld  rra  scf  rra  a and  rra
    \ the line number from top of screen to B
    \                     0xxxxxxx
    \ set carry flag
    \                     10xxxxxx
    \ clear carry flag
    \                     010xxxxx

  b xor  F8 and#  b xor  a h ld
    \
    \ keep the top 5 bits 11111000
    \                     010xxbbb
    \ transfer high byte to H

  c a ld
    \ the x value 0..255

  rlca rlca rlca  b xor  C7 and#
    \ the y value
    \ apply mask             11000111

  b xor  rlca  rlca
    \ restore unmasked bits  xxyyyxxx
    \ rotate to              xyyyxxxx
    \ required position      yyyxxxxx

  a l ld
    \ low byte to L

  c a ld  07 and#
    \ form the pixel position in A

  ret

  end-asm

Moved defer! and defer@ from the library to the kernel. defer! is needed to implement the word that restores the default printing mode, that must be in the kernel. Anyway, since also defer had to be moved to the kernel, it seems logical to be able to manipulate the deferred words without library code. defers and action-of are kept in the library.

Removed the old code, already deactivated with conditional compilation, related to the experimental implementation of a 255-character font in paged memory. This could be an optional printing mode in the library.

Converted at-xy and home to deferred words. This was needed in order to make it possible to change the printing mode. cls needed a little modification, because it is written in Z80 and calls home at the end.

2015-09-02

Finished accept, after ANS Forth. This will eventually replace query and expect, that will be moved to the library.

  _colon_header accept_,'ACCEPT'

; doc{
;
; accept  ( ca1 len1 -- len2 )  \ ANS Forth
;
; Receive a string of at most _len1_ characters.  No characters
; are received or transferred if _len1_ is zero.  Display
; graphic characters as they are received.
;
; Input terminates when an implementation-defined line
; terminator is received. When input terminates, nothing is
; appended to the string or displayed on the screen.
;
; _len2_ is the length of the string stored at _ca1_.
;
; }doc

  dw span_,off_
  dw question_dup_
  dw zero_branch_,accept.end

  dw to_r_ ; ( ca1 ) ( R: len1 )

accept.begin: ; ( ca )
  dw xkey_ ; ( ca c )

  dw dup_ ; ( ca c c )
  _literal delete_char
  dw equals_ ; delete key?
  dw zero_branch_,accept.maybe_carriage_return
  ; Delete key ( ca c )
  dw drop_
  dw span_,fetch_
  dw zero_branch_,accept.begin ; nothing to delete
  ; Do delete the last char
  dw one_minus_ ; update the current address
  _literal -1
  dw span_,plus_store_ ; update `span`
  _literal backspace_char
  dw branch_,accept.emit

accept.maybe_carriage_return: ; ( ca c )
  dw dup_
  _literal carriage_return_char
  dw equals_ ; carriage return?
  dw zero_branch_,accept.ordinary_key
  ; Carriage return ( ca c )
  dw drop_,r_drop_
  dw branch_,accept.end

accept.ordinary_key: ; ( ca c )
  dw span_,fetch_,r_fetch_,less_than_
  dw zero_branch_,accept.begin ; the string is full
  _literal 1
  dw span_,plus_store_ ; update `span`
  dw two_dup_,swap_,c_store_
  dw swap_,one_plus_,swap_

accept.emit: ; ( ca c )
  dw emit_
  dw branch_,accept.begin

accept.end: ( ca )
  dw drop_
  dw span_,fetch_
  dw semicolon_s_

Added cursor-char to the kernel, in order to make it easy to change the cursor used by xkey.

Modified query to use accept. This is a temporary change, until query is removed.

  _colon_header query_,'QUERY'

  dw tib_,dup_
  dw number_tib_,fetch_
  dw two_dup_,blank_ ; clean the input buffer
if 1 ; accept instead of expect
  dw accept_,space_
else
  dw expect_,span_,fetch_
endif
  dw plus_,stream_end_
  dw to_in_,off_
  dw semicolon_s_

Changed all push ix and pop ix to next ix ldp#, it's much faster with the same length.

2015-09-03

Finished the word xy-emit-udg, that prints a user defined graphic at high resolution coordinates. It's based on code written by Simon N. Goodwin.

( xy-emit-udg )

require (xy-emit)  require z80-asm

code xy-emit-udg  ( x y b -- )

  \ Display the used graphic character _b_ (0..255) at graphic
  \ coordinates _x y_. The system variable "UDG" is supossed to
  \ hold the address of a graphic charset (the address of the
  \ char 0 bitmap).
  \
  \ The UDG character will be printed with overwritting
  \ (equivalent to `1 overwritte`).

  hl pop  l a ld
  de pop  hl pop  bc push  e b ld  l c ld
  5C7B de ftp  \ system variable UDG
  (xy-emit) call
  bc pop  next ix ldp#  jpnext
  end-code

\ (xy-emit) \

require z80-asm  require (pixel-addr)

  \ [Code Adapted from "SMOOTH MOVE",
  \ written by Simon N.  Goodwin,
  \ published in Todospectrum, issue 2 (1984-10), page
  \ 16.  http://microhobby.speccy.cz/zxsf/revistas-ts.htm]

create (xy-emit)  ( -- )

  \ Print a 8x8 bits char at high resolution coordinates.

  \ Input:
  \   DE = address of the first char (0) bitmap in a charset
  \   A = char code (0..255)
  \   B = y coordinate
  \   C = x coordinate
  \ Modifies:
  \   AF BC HL IX DE

  asm

  0 h ld#  a l ld  hl addp  hl addp  hl addp  de addp
  hl push  ix pop  bc hl ldp  hl push  8 c ld#

  begin

    hl pop  h dec  hl push  h inc
      \ next line

    bc push  hl bc ldp  (pixel-addr) call  bc pop
      \ convert the coords H (x) and L (y) to an address in HL
      \ and a bit in A

    a b ld  a xor  b or  0 ix a ftx
    nz if   exde  0 h ld#  a l ld  8 a ld#  b sub  a b ld
            begin  hl addp  step  exde
            m a ld  d xor  a m ld
            hl incp  e a ld  then

    m xor  a m ld  ix incp  c dec
      \ next char scan, one screen line less

  z until  hl pop  ret  end-asm

2015-09-04

A bit faster set-pixel, reset-pixel and toggle-pixel.

Finished and tested the words that get attributes or attribute addresses.

( attr )

require z80-asm require (attr-addr)

code attr ( col line -- b )

  \ Return the color attribute of the given cursor coordinates.

  de pop  hl pop  l d ld
    \ d = col
    \ e = line
  (attr-addr) call
    \ hl = attribute address
  m l ld  0 h ld#
    \ hl = attribute
  pushhl jp

  end-code

( attr-addr )

require z80-asm require (attr-addr)

code attr-addr ( col line -- a )

  \ Return the color attribute address of the given cursor
  \ coordinates.

  de pop  hl pop  l d ld
    \ d = col
    \ e = line
  (attr-addr) call
    \ hl = attribute address
  pushhl jp

  end-code

\ (attr-addr) \

require z80-asm

create (attr-addr)  ( -- a )

  \ Address of a Z80 routine that calculates the color
  \ attribute address of a cursor position.  This is a modified
  \ version of the ROM routine at 0x2583.

  \ Input:
  \   d = column (0..31)
  \   e = line (0..23)
  \ Output:
  \   hl = address of the attribute in the screen

  asm

  e a ld  \ line to a 0x00..0x17 (max 00010111)
  rrca rrca rrca  \ rotate bits left
  a e ld  \ store in d as an intermediate value
  E0 and#  \ pick up bits 11100000 (was 00011100)
  d xor  \ combine with column 0x00..0x1F
  a l ld  \ low byte now correct
  e a ld  \ bring back intermediate result from d
  03 and#  58 xor#
    \ mask to give correct third of screen
    \ combine with base address
  a h ld  \ high byte correct
  ret

  end-asm

Removed the old version of pixel? that returned 1 as true flag. Removed the conditional compilation in the kernel for true=1 instead of true=-1. No way back to true=1.

Moved unresolved from the FZX module to the assembler. It is an useful solution to resolve unstructured branches or references in assembly code. Nevertheless, using the circular string buffer as storage is not safe. It's a temporary solution until the heap is implemented.

6 cells allocate-string
  \ Temporary space to store unresolved addresses during
  \ compilation. `pad` can not be used because it's transient
  \ and changes during the compilation. The circular string
  \ buffer is used.
  \
  \ XXX TODO -- use the heap instead, when implemented

: unresolved  ( n -- a )  cells [ dup ] literal +  ;  drop
  \ Return the address of the _n_ unresolved address.  Note:
  \ The address returned by `allocate-string` is directly
  \ compiled into `unresolved`. This saves a definition.  `dup`
  \ and `drop` are used to pass the compiler security that
  \ checks the stack is balanced at the end of the definition.

2015-09-05

Finished ocr (formerly called emitted). It can be configurated to use the main charset (32..127) or, by default, the user defined graphics (128..255 in Solo Forth). A slower alternative definition that recognizes also inverse mode characters is under development.

( ocr )

  \ [Adapted from anonymous code published in Todospectrum,
  \ issue 19 (1986-03), page 65.
  \ http://microhobby.speccy.cz/zxsf/revistas-ts.htm]

require z80-asm require ocr-chars

code ocr  ( col line -- n )

  \ Recognize the char printed at the given cursor
  \ coordinates, using the charset whose first printable char
  \ is pointed by the variable `ocr-charset`. The variable
  \ `ocr-chars` holds the number of chars in the charset,
  \ and `ocr-first` holds the code of the first char in the
  \ charset.  If succesful, return the char number _n_
  \ according to the said variables.  If no char is recognized,
  \ return 0. Inverse characters are not recognized.

  de pop  hl pop  bc push
    \ get row, get col, save the Forth IP
  l b ld  e c ld  ocr-charset hl ftp
    \ b=colum, c=row, hl=udg

  c a ld  rrca  rrca  rrca  E0 and#  b xor  a e ld
  c a ld  18 and#  40 xor#  a d ld
    \ de = screen address
  0 de stp here 2- 0 unresolved !
    \ modify the code to get the screen address later

  ocr-chars fta  a b ld
    \ number of chars in the charset
  begin
    \ b=remaining chars
    \ hl = address of scan 0 of the current char
    bc push  hl push
    0 de ldp#  \ restore the screen address
    here 2- 0 unresolved @ !
      \ compilation: resolve the address of the screen address
    \ de = screen address

-->

( ocr )

    08 b ld# \ scans
    begin
      de ftap  m xor  \ scan match?
      here jrnz >relmark 1 unresolved !
        \ if not, goto next_char
      d inc  hl incp  \ update the pointers
    step  \ next scan

    \ all eight scans match: udg found

    bc pop  bc pop
      \ discard the saved pointer
      \ b = chars left
    ocr-chars fta  b sub  a b ld
    ocr-first fta  b add  a b ld
      \ b = char number
    here jr >relmark 2 unresolved !
      \ go to end

    \ next_char:
    1 unresolved @ here >relresolve
    hl pop  0008 de ldp#  de addp  bc pop
  step
  \ b = 0 (no char matches)

  \ end:
  2 unresolved @ here >relresolve  0 h ld#  b l ld
  bc pop  pushhl jp  end-code

( ocr-charset ocr-first ocr-chars ocr-ascii ocr-udg )

variable ocr-charset

  \ doc{
  \
  \ ocr-charset  ( -- a )
  \
  \ Variable that holds the address of the first printable char
  \ in the charset used by `ocr`. By default it contains
  \ 0x3D00, the address of the space char in the ROM charset.
  \
  \ }doc

variable ocr-first

  \ doc{
  \
  \ ocr-first  ( -- a )
  \
  \ Variable that holds the code of the first printable char in the
  \ charset used by `ocr`. By default it contais 0x80, the
  \ first UDG.
  \
  \ }doc

variable ocr-chars

  \ doc{
  \
  \ ocr-charset  ( -- a )
  \
  \ Variable that holds the number of printable chars in the
  \ charset used by `ocr`. By default it contais 0x5F, the
  \ number of printable ASCII chars in the ROM charset.
  \
  \ }doc

: ocr-ascii  ( -- )
  \ Set `ocr` to work with the ASCII charset pointed by the
  \ system variable CHARS.
  23606 @ 256 + ocr-charset !
  32 ocr-first !
  95 ocr-chars !  ;

: ocr-udg  ( n -- )
  \ Set `ocr` to work with the first _n_ chars of the UDG
  \ charset pointed by the system variable UDG.
  23675 @ ocr-charset !
  128 ocr-first !
  ocr-chars !  ;

19 ocr-udg  \ default


Fixed ahead and modified else to use it.

New version of (emit), the default behaviour of emit: Now chars 128..255 are user defined graphics. This was an old objective. Eventually, the code will be included as an independent routine, not as a Forth word; and the output channel of the operating system will be pointed to it, so rst 0x10 can be used for graphics.

  _code_header paren_emit_,'(EMIT)'

; doc{
;
; (emit)  ( b -- )
;
; Send the character _b_ to the current channel.
;
; }doc

  pop hl
  push bc

  ld (iy+sys_scr_ct_offset),0xFF ; no scroll message

  ld a,l
  cp 128 ; control or ASCII character?
  jp nc,paren_emit.print_udg ; is not, jump

  ; use the ROM routine to print a control or ASCII character
  rst 0x10
  pop bc
  _jp_next

paren_emit.print_udg:
  ; hl = UDG code (128..255)
  sub 128
  ld l,a ; hl = UDG index code (0..127)
  ld de,(sys_udg)
  add hl,hl
  add hl,hl
  add hl,hl
  add hl,de
  ex de,hl ; de = char address in the font
  ld bc,(sys_s_posn) ; cursor position
  ld hl,(sys_df_cc) ; current screen address
  call rom_pr_all
  ld (sys_s_posn),bc
  ld (sys_df_cc),hl
  pop bc
  _jp_next


First tries with alternative 42 cpl printing routines.

2015-09-06

Added printing, a flag set by printer, reset by display and checked by page. This way page can do the right thing.

Changed the order of parameters in the assembler commands for bit manipulation. Example of the old syntax: 5 b set, 2 FF IX bit; new syntax: b 5 set, FF IX 2 bit. Now the position of the displacement is the same in all instructions with index registers, what is easier to remember, and the bit number is right before the instruction, what is clearer.

Renamed overwrite to overprint.

Renamed ocr-udg to udg-ocr and ocr-ascii to ascii-ocr; they look clearer now, because they set the mode of ocr.

2015-09-07

Converted 0, 1 and 2 to byte constants.

After trying several routines to print 36, 42, 51 and 64 characters per line, the only one that supports all control characters and works fine is Print-42, by Ricardo Serral Wigge, published in 1986 in Microhobby. Two temporary words have been added to turn the 42 cpl mode on and off, but the code of the new printing routine still has to be loaded from disk. It's being disassembled in order to integrate it into the Forth library.

( mode32 mode42 )

[defined] sys-chans ?\ 23631 constant sys-chans
[defined] sys-chars ?\ 23606 constant sys-chars


: (mode)  ( a1 a2 -- )
  \ Set the system font to _a2_ and associate the output
  \ routine at _a1_ to the system channels "K", "S" and "P".
  \ a1 = character output routine
  \ a2 = address of char 0x00 in a font
  sys-chars !
  sys-chans @ 2dup ! 2dup 5 + ! 15 + !  ;


: mode32  ( -- )  2548 15360 (mode) ;
  \ Set the default printing mode, 32 cpl and the ROM font.

: mode42  ( -- )  63900 [ 64600 256 - ] literal (mode) ;
  \ Set the 42 cpl printing mode.

  \ [Author of the 42 cpl printing code: Ricardo Serral Wigge.
  \ Published in Microhobby, issue 66 (1986-02), page 24:
  \ http://microhobby.org/numero066.htm
  \ http://microhobby.speccy.cz/mhf/066/MH066_24.jpg]

Added unnest, a code synonym of rdrop.

Finished don't, a simple temporary alternative to ?do.

2015-09-08

Started adapting the 4x8 font driver written by Andrew Owen: removed the channels stuff, that will be done in Forth, and added the delete control code.

Fixed a silly bug in ?exhausted, a typo in the code.

Modified key and xkey to share a common routine that waits for a key press.

Added value to the library. Three alternative versions with non-parsing to are included too.

( value )

  \ `value` with parsing and state-smart `to`

  \ This implementation conforms to ANS Forth.
  \ ANS Forth explicitly requires that `to` must parse.

  \ Adapted from Afera.
  \ http://programandala.net/en.program.afera.html

: value  ( n "name"  -- )  constant  ;

: to  ( Interpretation: n "name" -- )
      ( Compilation: "name" -- )
  ' cfa>pfa comp? if    postpone literal postpone !
                  else  !  then  ; immediate

2015-09-09

Added <file-as-is (temporary name) to load a code file from disk, using the start and length stored in its header.

( <file-as-is )

require z80-asm  require ufia  require --hook-codes--
require >ufia  require ior>error

code (<file-as-is)  ( -- ior )

  \ Load a file from disk, using the data hold in UFIA, the
  \ file header and the parameters specified by the high level
  \ command.

  bc push  \ save the Forth IP

  ufia ix ldp#  hgfile hook \ get the file
  nc if \ no error?  -- load the file header:

    hd00 de ldp#  9 b ld# \ destination and count
    begin  lbyte hook  de stap  de incp  step
      \ Load the file header.

    hd0d de ftp  hd0b bc ftp  hldbk hook
      \ Use the address and length from the header.
      \ Then load the file data.

  then  bc pop  next ix ldp#  af push
        \ restore the Forth registers and save the ior
  jpnext  end-code

: <file-as-is  ( ca len -- f n )
  \ Load a file from disk.
  \ ca len  = filename
  \ f       = error?
  \ n       = error
  0 0 2swap >ufia (<file-as-is) ior>error  ;

<file-as-is was needed in order to load the alternative screen mode drivers from the disk, though the current method to activate and switch the screen modes is provisional.

( mode32 )

[defined] sys-chans ?\ 23631 constant sys-chans
[defined] sys-chars ?\ 23606 constant sys-chars

: channels!  ( a -- )
  \ Associate the output
  \ routine at _a_ to the system channels "K", "S" and "P".
  sys-chans @ 2dup ! 2dup 5 + ! 15 + !  ;

: set-mode  ( a1 a2 -- )
  \ Set the system font to _a1_ and associate the output
  \ routine at _a2_ to the system channels "K", "S" and "P".
  sys-chars !  channels!  ;

: mode32  ( -- )  2548 15360 set-mode ;
  \ Set the default printing mode, 32 cpl and the ROM font.

( mode42 )

require mode32  require <file-as-is

drive@ 1 drive!
s" print-42" <file-as-is ?error
s" ea5aky.f42" <file-as-is ?error
drive!
  \ Load the driver and the font.

: mode42  ( -- )  63900 [ 64600 256 - ] literal set-mode ;
  \ Set the 42 cpl printing mode.

  \ Credits:
  \ Author of the 42 cpl printing routine: Ricardo Serral Wigge.
  \ Published in Microhobby, issue 66 (1986-02), page 24:
  \ http://microhobby.org/numero066.htm
  \ http://microhobby.speccy.cz/mhf/066/MH066_24.jpg
  \ Adapted to Solo Forth by Marcos Cruz.

( mode64 )

require mode32  require <file-as-is

drive@ 1 drive!
s" 4x8fd.tap" <file-as-is ?error
drive!
  \ Load the driver and the font.

: mode64  ( -- )  60000 channels! ;
  \ Set the 64 cpl printing mode.

  \ Credits:
  \ Author of the 4x8 font driver: Andrew Owen.
  \ Published in the World of Spectrum forum:
  \ http://www.worldofspectrum.org/forums/discussion/14526/redirect/p1
  \ Modified and adapted to Solo Forth by Marcos Cruz.

2015-09-10

Added from to make it possible for require start searching from the first screen of a library section, therefore avoiding possible name clashes.

( require ) \ scr 2

  \ This screen must be at a fixed location.

: reload  ( -- )  scr @ load  ;

: contains  ( ca1 len1 ca2 len2 -- f )  search nip nip  ;
  \ Does the string ca1 len1 contains the string ca2 len2?

variable default-first-locatable
variable first-locatable
  8 dup default-first-locatable !  first-locatable !
variable last-locatable  scr/disk last-locatable !

: located  ( ca len -- screen | false )
  last-locatable @ 1+  first-locatable @
  default-first-locatable @  first-locatable !
  do
    0 i (line) 2over contains if  2drop i unloop exit  then
    \ break-key? ?exhaust
  loop  2drop false  ;

: locate  ( "name" -- screen | false )
  parse-name save-string located  ;

-->

( require ) \ scr 3

: ?located  ( screen | false -- )  dup 0= 29 ?error ;

: from  ( "name" -- )  locate ?located first-locatable !  ;
  \ Locate the given _name_ and set its screen the first one
  \ `require` will search from.

: do-required  ( ca len -- )  located ?located load  ;

: do-require  ( "name" -- )
  parse-name save-string do-required  ;

: required  ( ca len -- )

  \ XXX FIXME usually the final check fails because the saved
  \ string has been overwritten. the only solution is to store
  \ the string apart, in an ad hoc zone.

  \ XXX OLD
  \ 2dup undefined?
  \   if  2dup do-required  then
  \ 2dup undefined? warnings @ and
  \   if  type 28 warning exit  then  2drop  ;

  \ XXX TMP
  2dup undefined?  if  do-required  else  2drop  then  ;

: require  ( "name" -- )
  parse-name save-string required  ;

In order to use from, a unique identifier name must be added to the first line of the first screen of library sections. Example from the double numbers section:

( du.r u.r du. )  \ ==doublenumbers==

Finished n>r and nr>, after Forth 2012.

( n>r )

require z80-asm

code n>r  ( x1..xn n -- ) ( R: -- x1..xn n )

  exx

  bc pop  0000 bc stp  here 2- 0 unresolved !
  rp hl ftp
  begin  bc tstp  nz while
    de pop  hl decp  d m ld  hl decp  e m ld  bc decp
  repeat
  0000 de ldp# here 2- 0 unresolved @ !
  hl decp  d m ld  hl decp  e m ld

  rp hl stp  exx  jpnext

  end-code

require nr>

( nr> )

require z80-asm

code nr>  ( -- x1..xn n ) ( R: x1..xn n -- )

  exx
  rp hl ftp
  m c ld  hl incp  m b ld  hl incp
  0000 bc stp  here 2- 0 unresolved !
  begin  bc tstp  nz while
    m e ld  hl incp  m d ld  hl incp  de push  bc decp
  repeat
  rp hl stp  exx
  0000 hl ldp# here 2- 0 unresolved @ !
  pushhl jp
  end-code

require n>r

Improved the method to resolve absolute and relative references in assembler, but more changes will be necessary to make it simpler.

Finished the needed changes in the 4x8 font driver written by Andrew Owen: order of parameters; left control char; scroll. Extracted the font; now it's compiled in the dictionary space. The driver is ready to be converted to the Forth Z80 assembler and included in the library.

2015-09-11

Adapted the line editor of ZX Spectrum Specforth (Specforth Editor V1.1, by Chris A. Thornton, 1983). Beside the usual changes to remove or adapt the fig-Forth specific issues, text had to be rewritten, with an interesting factor, provisionally called command, that will be moved outside the editor

  \ XXX OLD
  \ : text  ( c "text<c>" -- )
  \  here c/l 1+ blank word pad c/l 1+ cmove ;
  \ Parse a text string delimited by character _c_ and store it
  \ into `pad`, blank-filling the remainder of `pad` to `c/l`
  \ characters.

  \ XXX NEW
: command  ( "text<eol>" -- ca len )
  source span @ min c/l min  >in @ span @ min /string
  dup >in +! save-string  ;
  \ Get the text string until the end of line.
  \ Note: this is possibly useful factor of the editor's
  \ `text`.
: text  ( "text<eol>" -- )
  pad c/l 1+ blank  command  pad place  ;
  \ Get the text string until end of line and store it
  \ into `pad` as a counted string, blank-filling the remainder
  \ of `pad` to `c/l` characters.

Beside, the documented problem of `c` has been fixed (typing `c` with no text copied a null into the text at the cursor position), with a simple check and a factor:

: (c)  ( ca len -- )
  #lag rot over min >r r@ r# +! r@ - >r
  dup here r@ cmove here #lead + r> cmove r> cmove 0 m
  update  ;
  \ Copy the string _ca len_ to the cursor line at the cursor
  \ position.

: c  ( "text<eol>" -- )
  text pad count dup if  (c)  else  2drop  then  ;
  \ Copy in "text" to the cursor line at the cursor position.

Though Solo Forth is not intended to edit the sources in the system, it's useful to have a classic Forth editor in the library, to do quick changes and tests during the development. Beside, it works great with the mode64 screen mode.

2015-09-12

Fixed words-like: the order of the compared strings was wrong!

( words-like )

  \ Credits:
  \ Code adapted from pForth.

require break-key?

[defined] contains
  ?\ : contains  ( ca1 len1 ca2 len2 -- f )  search nip nip  ;
     \ Does the string _ca1 len1_ contains the string _ca2
     \ len2?_

[defined] tab
  ?\  : tab  ( -- )  6 emit  ;

: words-like  ( "name" -- )
  \ Print all words (from the `context` vocabulary) containing a substring.
  parse-name 2dup uppers trail  ( ca len nfa )
  begin  dup 0<> break-key? 0= and  while
    dup >r
    nfa>string 2over contains if  r@ id. tab  then
    r> nfa>lfa @n
  repeat drop 2drop  ;

Added c#, a shortcut for char and [char], inspired by pForth's d#, h# and b#, still being adapted.

( c# )

: c#  ( "name" -- c )
  parse-name drop c@ postpone literal  ; immediate
  \ Parse a name and return the code of the its first
  \ character.
  \ Note: This word depends on the fig-Forth's `literal`.
  \ XXX TODO change when `literal` is updated.

Wrote two assembler macros to call any Forth word from code words.

( execute-hl call-cfa )

  \ Assembler macros to call any Forth word from code words.

  \ Credits:
  \
  \ Code inspired by Spectrum Forth-83, where similar code is
  \ embedded in `KEY` and `PAUSE` to call a cfa hold in a
  \ variable. The code has been converted from DTC to ITC and
  \ factored to two assembler macros in order to make it
  \ reusable.

macro execute-hl  ( -- )
  \ Compile an `execute` with the cfa hold in HL.
  here 6 + bc ldp# \ point IP to phony_compiled_word
  next2 jp  \ execute the cfa in HL
  \ phony_compiled_word:
  here cell+ ,  \ point to the phony cfa following
  here cell+ ,  \ phony cfa, point to the code following
  endm

macro call-cfa  ( cfa -- )
  \ Compile a call to _cfa_.
  \ This is the low-level equivalent of `execute`.
  hl ldp#  execute-hl
  endm

Finished adapting pause from Spectrum Forth-83: it waits a number of ticks. A vectored call is done during the wait. Though the goal is to use a user variable to hold the cfa, instead of a deferred word.

( pause )

  \ Credits:
  \ Code adapted from Spectrum Forth-83.

require z80-asm  require call-cfa

defer (wait)  ' noop ' (wait) defer!

code pause ( u --- )
  \ u = number of ticks
  de pop  bc push
  begin
    de push
    ' (wait) call-cfa
    de pop  halt  de decp  de tstp  \ finished?
  z until
  bc pop  jpnext
  end-code

Improved key, xkey and key?: now they use the 5th bit of the system variable FLAGS to check if a new key is available, and reset it, instead of LASTK.

Moved and old version of key? to the library, that still may be useful, and renamed it to key??.

( key?? )

  \ An alternative to `key?` that works also when the system
  \ interrupts are off. Variant with relative jumps.

require z80-asm

code key??  ( -- f )

  bc push
  028E call  \ ROM KEY_SCAN
  here jrnz  >relmark 0 unresolved ! \ to return_false
  031E call  \ ROM KEY_TEST
  here jrnc  >relmark 1 unresolved ! \ to return_false

  \ return_true:
  bc pop  ' true cfa>pfa jp

  \ return_false:
  0 unresolved @ >relresolve
  1 unresolved @ >relresolve
  bc pop  ' false cfa>pfa jp

  end-code

( key?? )

  \ An alternative to `key?` that works also when the system
  \ interrupts are off. Faster variant with absolute jumps.

require z80-asm

code key??  ( -- f )

  bc push
  028E call  \ ROM KEY_SCAN
  0000 jpnz  |mark 0 unresolved ! \ to return_false
  031E call  \ ROM KEY_TEST
  0000 jpnc  |mark 1 unresolved ! \ to return_false

  \ return_true:
  bc pop  ' true cfa>pfa jp

  \ return_false:
  0 unresolved @ >resolve
  1 unresolved @ >resolve
  bc pop  ' false cfa>pfa jp

  end-code

Wrote index-like and index-ilike, with a nice factor from index: .index. The insensitive case version index-ilike is not a good solution: Eventually, the kernel search and compare will be configurable to use case sensitive or case insensitive modes, after DZX-Forth.

( index .index )

require break-key?

: .index  ( n -- )  cr dup 3 .r space 0 swap .line  ;
  \ Print the first line of the screen _n_.

: index  ( n1 n2 -- )

  \ doc{
  \
  \ index  ( n1 n2 -- )
  \
  \ Print the first line of each screen over the range from
  \ _n1_ to _n2_.
  \
  \ }doc

  1+ swap do
    cr i 3 .r space 0 i .line
    break-key? if  exhaust  then
  loop  ;

( index-like )

require break-key?  require .index

[defined] contains
  ?\ : contains  ( ca1 len1 ca2 len2 -- f )  search nip nip  ;
     \ Does the string _ca1 len1_ contains the string _ca2
     \ len2?_

: index-like  ( n1 n2 "name" -- )

  \ doc{
  \
  \ index-like  ( n1 n2 "name" -- )
  \
  \ Print the first line of each screen over the range from
  \ _n1_ to _n2_, as long as the string "name" is included in
  \ the line. The string comparison is case-sensitive.
  \
  \ }doc

  parse-name 2swap
  1+ swap do
    0 i (line) 2over contains if  i .index  then
    break-key? if  exhaust  then
  loop  2drop  ;

( index-ilike )

require break-key?  require .index

[defined] contains
  ?\ : contains  ( ca1 len1 ca2 len2 -- f )  search nip nip  ;
     \ Does the string _ca1 len1_ contains the string _ca2
     \ len2?_

: index-ilike  ( n1 n2 "name" -- )

  \ doc{
  \
  \ index-ilike  ( n1 n2 "name" -- )
  \
  \ Print the first line of each screen over the range from
  \ _n1_ to _n2_, as long as the string "name" is included in
  \ the line. The string comparison is case-insensitive.
  \
  \ }doc

  parse-name save-string 2dup uppers
  2swap 1+ swap do
    save-string  0 i (line) save-string 2dup uppers
    2over contains if  i .index  then
    break-key? if  exhaust  then
  loop  2drop  ;

  \ Note: The parsed string is re-saved to the circular string
  \ buffer in every iteration in order to prevent it from being
  \ overwritten by the strings of the index lines, because the
  \ circular string buffer is small.

Removed unless from the kernel:

; ----------------------------------------------
  _colon_header unless_,'UNLESS',immediate

  ; Equivalent to `0= if`, but faster.

  dw compile_,question_branch_
  dw branch_,if.do
  dw semicolon_s_

And rewrote it in the library:

( unless )

  \ Equivalent to `0= if`, but faster.

: unless  ( f -- )  postpone ?branch >mark 2  ; immediate

  \ XXX TODO Alternative for when compiler security is removed:
  \ : unless  ( f -- )  postpone ?branch >mark  ; immediate

Added up (name after fig-Forth) (the user area pointer), up0 (its default value) and /user (the length of the user variables) to the kernel, because they will be needed by the multitasking words, currently being adapted from Spectrum Forth-83.

2015-09-13

Renamed the original assembler instruction ldhl to fthl, an oversight. Converted, in the library, all occurences of hl ftp to fthl, and hl stp to sthl; the new forms compile shorter Z80 opcodes.

Renamed require to need, required to needed, and so the variants with the "re" prefix. The reason is require and required are standard words (in Forth 94 and Forth 2012), and should not be used for different purposes.

Renamed the kernel code word $! to place and removed the library high-level word place; they did the same: stored a string into a memory address as a counted string.

Added s+, converted from Afera:

( s+ )

  \ Credits:
  \ Code adapted from Afera.

[defined] lengths
?\ : lengths   2over nip over  ;
   ( ca1 len1 ca2 len2 -- ca1 len1 ca2 len2 len1 len2 )

: s+  ( ca1 len1 ca2 len2 -- ca3 len3 )

  \ Append the string _ca2 len2_ to the end of string _ca1
  \ len1_ returning the string _ca3 len3_ in the circular
  \ string buffer.

  lengths + >r           ( ca1 len2 ca2 len2 ) ( r: len3 )
  r@ allocate-string >r  ( r: len3 ca3 )
  2 pick r@ +            ( ca1 len1 ca2 len2 len1+ca3 )
  smove                  ( ca1 len1 )  \ 2nd string to buffer
  r@ smove               \  1st string to buffer
  r> r>  ;

Fixed 2constant: the value was not stored!

Implemented search-wordlist, needed to implement s\".

: search-wordlist ( ca len wid -- 0 | xt 1 | xt -1 )
  >r 2dup uppers save-counted-string r>
  @ (find) dup ?exit  nip  ;

Implemented Forth-2012's s\". Some new words were needed.

( parse-char )

: parse-char  ( "c"  -- c )  stream c@ 0 parsed  ;
  \ Parse the next char in the input stream and return its
  \ code.
  \
  \ Note: `0 parsed` increments `>in` because `parsed` adds 1
  \ to its parameter (to include the delimiter).

( s\" )  \ ==strings==

only forth definitions
need wid-of  need parse-char
vocabulary escaped-voc
wid-of escaped-voc constant escaped-wordlist
also escaped-voc definitions

  \ The `escaped-voc` contains the words whose names are
  \ characters that must be escaped after a backslash. Their
  \ execution returns the new character(s) on the stack (the
  \ first one at the top) and the count.
  \
  \ Most of the escaped chars are translated to one char, so
  \ they are defined as double constants.

7 1 2constant a  8 1 2constant b  27 1 2constant e
  \ \a = backspace
  \ \b = alert
  \ \e = escape
12 1 2constant f  10 1 2constant l  13 1 2constant n
  \ \f = form feed
  \ \l = line feed
  \ \n = new line (implementation dependent)
char " 1 2constant q  13 1 2constant r  9 1 2constant t
  \ \q = double quote
  \ \r = carriage return
  \ \t = horizontal tab
11 1 2constant v  0 1 2constant z
  \ \v = vertical tab
  \ \z = null character
char " 1 2constant "  char \ 1 2constant \
  \ \" = double quote
  \ \\ = backslash

: m  ( -- c1 c2 2 )  10 13 2  ;
  \ \m = carriage return and line feed

: (x)  ( "c" -- n )  parse-char upper 16 digit 0= 14 ?error  ;
  \ Parse an hex digit and convert it to a number.

: x  ( "cc" -- c 1 )  (x) 16 * (x) + 1  ;
  \ \x = hex character code
  \ Parse the 8-bit hex number of a character code.

-->

( s\" )

only forth definitions

need char>string   need search-wordlist
need chars>string  need s+

: unescape-char  ( c -- c1..cn n )
  dup char>string escaped-wordlist search-wordlist
  if  nip execute  else  [char] \ 2  then  ;
  \ Translate a escaped char to a number of chars and their
  \ count.
  \ c1..cn = chars to make the string with
  \          (_c1_ is the last one)
  \ n = number of chars

: (s\")  ( "text<quote>"  -- ca len )
  pad 0  \ empty string to start with
  begin  parse-char dup [char] " <>  while  \ not finished?
    dup [char] \ =  \ possibly escaped char?
    if    drop parse-char unescape-char
    else  1  then  chars>string s+
  repeat  drop  ;
  \ Parse a text string delimited by a double quote, using the
  \ translation rules described by Forth 2012's `s\"`, and
  \ returning the string _ca len_ in the circular string
  \ buffer.

: s\"  ( "text<quote>"  - ca len )  \ Forth 2012
  (s\")  comp? if  postpone sliteral  then  ; immediate

( char>string chars>string )

: char>string  ( c -- ca len )  1 allocate-string tuck c! 1  ;
  \ Convert the char _c_ to a string _ca len_ in the circular
  \ string buffer.

: chars>string  ( c1..cn n -- ca len )
  dup if
    dup allocate-string swap 2dup 2>r  ( c1..cn ca n )
    bounds do  i c!  loop  2r>
  else  pad swap  then  ;
  \ Convert _n_ chars to a string _ca len_ in the circular
  \ string buffer.
  \ c1..cn = chars to make the string with
  \          (_c1_ is the last one)
  \ n = number of chars

Moved /string to the kernel, and rewrote it in assembler. It will be needed in order to improve the parsing primitives after Forth-83 and ANS Forth.

  _code_header slash_string_,'/STRING'

; doc{
;
; /string  ( ca1 len1 n -- ca2 len2 )  \ Forth 2012
;
; ----
; : /string  ( ca1 len1 n -- ca2 len2 )  rot over + -rot -  ;

; \ Alternative definition:
; : /string  ( ca1 len1 n -- ca2 len2 )  \ dup >r - swap r> + swap  ;
; ----
;
; }doc

  pop de                  ; n
  pop hl                  ; len1
  and a                   ; cy=0
  sbc hl,de               ; hl=len2
  ex (sp),hl              ; (sp)=len2 hl=ca1
  add hl,de               ; hl=ca2
  ex (sp),hl              ; (sp)=ca2 hl=len2
  jp push_hl

Removed expect from the kernel. It will modified and added to the library. The kernel byte-coded version uses low-level branches that can not be reproduced with control structures, so the word will be rewritten from scratch.

2015-09-15

Moved continued to the library.

Added assert( to the library, copied from Gforth.

Added invert to the kernel, adapted from Z88 CamelForth.

2015-09-16

Added words to manage the "jiffy call", a configurable routine G+DOS can call after processing a system interrupt.

( jiffy! jiffy@ -jiffy )

  \ Credits:
  \ Idea inspired by an article by Paul King, published in
  \ Format, vol. 2 no. 3 (1988-10).
  \ XXX TODO link to the WoS archive ftp, when available

need !dosvar  need @dosvar

: jiffy!  ( a -- )  16 !dosvar  ;
  \ Set the Z80 routine to be called by G+DOS after the OS
  \ interrupts routine, every 50th of a second.

: jiffy@  ( -- a )  16 @dosvar  ;
  \ Get the current Z80 routine that is called by G+DOS after
  \ the OS interrupts routine, every 50th of a second.

: -jiffy  ( -- )  8335 jiffy!  ;
  \ Deactivate the jiffy call, setting its default value
  \ (a noop routine in the RAM of the +D interface).

Done a lot of work on the new improved parsing method, that does not need a null word added at the end of the input buffers. Wrote new versions of scan, skip, query, stream, parse, parse-name, word, error, interpret, quit and defined. Added some new words. The parsing method can be selected with a conditional compilation flag in the kernel.

2015-09-17

Added >number and number?, because fig-Forth number and (number) can not work with the new parsing method. Renamed digit to digit?.

Improved d+. The current code was from Abersoft Forth:

  _code_header d_plus_,'D+'

; doc{
;
; d+  ( d1|ud1 d2|ud2 -- d3|ud3 )
;
; Add _d2|ud2_ to _d1|ud1_, giving the sum _d3|ud3_.
;
; }doc

  ; [Code from Abersoft Forth.]

                ;  t  B
                ;  -- --
  ld hl,0x0006  ;  10 03
  add hl,sp     ;  11 01
  ld e,(hl)     ;  07 01
  ld (hl),c     ;  07 01
  inc hl        ;  06 01
  ld d,(hl)     ;  07 01
  ld (hl),b     ;  07 01
  pop bc        ;  10 01
  pop hl        ;  10 01
  add hl,de     ;  11 01
  ex de,hl      ;  04 01
  pop hl        ;  10 01
  adc hl,bc     ;  15 01
  pop bc        ;  10 01
  jp push_hlde  ;  10 03
                ;  11    ; push de
                ;  11    ; push hl
                ; --- --
                ; 157 19 TOTALS

The new code is adapted from Z88 CamelForth. It's faster and smaller, even with the additional pop and push (Z88 CamelForth keeps TOS in the BC register).

  ; [Code adapted from Z88 CamelForth.]

                        ;  t  B
                        ;  -- --
  pop de                ;  10 01 ; DE=d2hi
  exx                   ;  04 01
  pop de                ;  10 01 ; DE'=d2lo
  exx                   ;  04 01
  pop hl                ;  10 01 ; HL=d1hi,DE=d2hi
  exx                   ;  04 01
  pop hl                ;  10 01 ; HL'=d1lo
  add hl,de             ;  11 01
  push hl               ;  11 01 ; 2OS=d1lo+d2lo
  exx                   ;  04 01
  adc hl,de             ;  15 02 ; HL=d1hi+d2hi+cy
  push hl               ;  11 01
  _jp_next              ;  08 02
                        ;  -- --
                        ; 112 15 TOTALS

Added d- to the library, also adapted from Z88 CamelForth:

( d- )

need z80-asm

  \ Credits:
  \ Code adapted from Z88 CamelForth.

code d-  ( d1|ud1 d2|ud2 -- d3|ud3 )

  de pop          \ DE=d2hi
  exx
  de pop          \ DE'=d2lo
  exx
  hl pop          \ HL=d1hi,DE=d2hi
  exx
  hl pop          \ HL'=d1lo
  de subp
  hl push         \ 2OS=d1lo-d2lo
  exx
  de sbcp         \ HL=d1hi-d2hi-cy
  pushhl jp
  end-code

2015-09-18

Wrote find-name to substitute the old standard word find. This change makes it possible to forget counted strings (word will be substituted by parse-name).

; ----------------------------------------------
  _colon_header find_name_,'FIND-NAME'

; doc{

; find-name  ( ca len -- ca len 0 | cfa 1 | cfa -1 )
;
; Find the definition identified by the string _ca len_ in the
; current search order. If the definition is not found after
; searching all the vocabularies in the search order, return _ca
; len_ (converted to uppercase) and zero.  If the definition is
; found, return its _cfa_.  If the definition is immediate, also
; return one (1); otherwise also return minus-one (-1).
;
; The search is case-insensitive.

; ----
; : find-name  ( ca len -- ca len 0 | cfa 1 | cfa -1 )
;   2dup uppers
;   #vocs 0 do
;     context i cells + @  ?dup
;     if  @ >r 2dup r> (find-name) ?dup
;         if  2swap 2drop unloop exit  then  drop
;     then
;   loop  false  ;
; ----

; }doc

  dw two_dup_,uppers_
  dw hash_vocs_,zero_,paren_do_
find_name.do:
  ; ( ca len )
  dw context_,i_,cells_,plus_,fetch_
  dw question_dup_ ; a vocabulary in the search order?
  dw zero_branch_,find_name.loop ; if not, next
  ; ( ca len wid )
  ; valid vocabulary in the search order
  dw fetch_,to_r_,two_dup_,from_r_ ; ( ca len ca len nfa )
  dw paren_find_name_,question_dup_ ; word found in the vocabulary?
  dw zero_branch_,find_name.not_found
  dw two_swap_,two_drop_
  dw unloop_,exit_
find_name.not_found:
  dw drop_
find_name.loop:
  dw paren_loop_,find_name.do
  dw false_
  dw semicolon_s_

Wrote the required (find-name):

; ----------------------------------------------
  _code_header paren_find_name_,'(FIND-NAME)'

; doc{
;
; (find-name)  ( ca len nfa -- x 0 | cfa 1 | cfa -1 )
;
; Find the definition named in the string at _ca len_, starting
; at _nfa_. If the definition is not found, return an undefined
; cell _x_ and zero.  If the definition is found, return its
; _cfa_.  If the definition is immediate, also return one (1);
; otherwise also return minus-one (-1).
;
; The search is case-sensitive.
;
; }doc

  ld (paren_find_name.ip_backup),bc ; save the Forth IP

  ld e,names_bank
  call bank.e ; page the memory bank in

  pop de ; nfa
  pop bc ; C=len, B is supposed to be 0
  ld a,c
  ld (paren_find_name.string_length),a
  pop hl ; ca
  ld (paren_find_name.string_address),hl

  ; XXX FIXME the string searched for must be in the string
  ; buffer, below 0xC000! This is not a problem now, during the
  ; development, because the dictionary is small.

paren_find_name.begin:
  ; Compare the string with a new word.
  ; de = nfa
  ld (paren_find_name.nfa_backup),de ; save the nfa for later
paren_find_name.string_address: equ $+1
  ld hl,0x0000 ; string address
  ld a,(de) ; length byte of the name field
  ld (paren_find_name.length_byte_backup),a ; save it for later
  and max_word_length_mask  ; length
paren_find_name.string_length: equ $+1
  ld c,0x00 ; length of the string
  cp c ; same length?
  jr nz,paren_find_name.not_a_match ; lengths differ

  ; Lengths match, compare the characters.
paren_find_name.compare_next_char:
  inc de
  ld a,(de)
  cpi
  jr nz,paren_find_name.not_a_match ; mismatch
  jp pe, paren_find_name.compare_next_char ; count not exhausted

  ; The string matches.
  ld hl,(paren_find_name.nfa_backup)
  dec hl
  dec hl ; lfa
  dec hl ; high part of the pointer to cfa
  ld d,(hl)
  dec hl ; low part of the pointer to cfa
  ld e,(hl) ; de = cfa

  ld hl,1 ; 1=immediate word
paren_find_name.length_byte_backup: equ $+1
  ld a,0 ; name field length byte
  and precedence_mask ; immediate word?
  jp nz,paren_find_name.end
  ; non-immediate word
  dec hl
  dec hl ; -1 = non-immediate word
  jr paren_find_name.end

paren_find_name.not_a_match:
  ; Not a match, try the next word.
paren_find_name.nfa_backup: equ $+1
  ld hl,0x0000 ; nfa
  dec hl ; high address of lfa
  ld d,(hl) ; high part of the next nfa
  dec hl ; low address of lfa
  ld e,(hl) ; low part of the next nfa
  ld a,d
  or e ; end of dictionary? (next nfa=0)
  jp nz,paren_find_name.begin ; if not, continue

  ; End of dictionary, no match found.
  ld hl,0x0000

paren_find_name.end:
  ; If match found:
  ;   de = cfa
  ;   hl = -1 | 1
  ; If no match found:
  ;   de = ?
  ;   hl = 0
  exx
  ld e,default_bank
  call bank.e ; page the default memory bank in
  exx
paren_find_name.ip_backup: equ $+1
  ld bc,0x0000 ; restore the Forth IP
  jp push_hlde

And finally updated the library definition of search-wordlist:

 : search-wordlist  ( ca len wid -- 0 | cfa 1 | cfa -1 )
    >r 2dup uppers r>
   @ (find-name) dup ?exit nip  ;

Improved some definitions of the circular string buffer, to make them more versatile. Some addresses of the buffer had been included as literals in the byte-coded definitions, because no word returned them. Documented all words of the circular string buffer.

2015-09-20

Finished fixing some bugs caused by the changes of the parsing system.

2015-09-21

Wrote number-base and modified >number to use it. This way number prefixes "$", "%" and "#" are recognized.

; ----------------------------------------------
  _colon_header number_base_,'NUMBER-BASE'

; doc{
;
; number-base  ( ca len -- ca' len' n )
;
; If the first char of string _ca len_ is a radix prefix, return
; its value _n_ and the updated string _ca' len'_ (which does
; not include the radix prefix).  Otherwise return _ca len_
; untouched and the current value of `base`.

; ----
; : number-base  ( ca len -- ca' len' n )
;   over c@ [char] $ = if  1 /string 16  exit  then
;   over c@ [char] % = if  1 /string  2  exit  then
;   over c@ [char] # = if  1 /string 10  exit  then
;   base @  ;
; ----

; }doc

number_base.try_hex:
  dw over_,c_fetch_
  _literal '$'
  dw equals_,zero_branch_,number_base.try_binary
  _literal 1
  dw slash_string_
  _literal 16
  dw exit_
number_base.try_binary:
  dw over_,c_fetch_
  _literal '%'
  dw equals_,zero_branch_,number_base.try_decimal
  _literal 1
  dw slash_string_
  _literal 2
  dw exit_
number_base.try_decimal:
  dw over_,c_fetch_
  _literal '#'
  dw equals_,zero_branch_,number_base.current
  _literal 1
  dw slash_string_
  _literal 10
  dw exit_
number_base.current:
  dw base_,fetch_
  dw semicolon_s_

2015-09-22

Tried alternative code for um*, from hForth and Z88 CamelForth, but the current code from DZX-Forth is faster, what was a surprise because the original code from DX-Forth is not Z80-specific, and consists of several routines that call each other. hForth and Z88 CamelForth use relative jumps in their code, but absolute jumps don't make it faster than the current code.

This is the version adapted from hForth, with absolute jumps:

  _code_header u_m_star_,'UM*'

; doc{
;
; um*  ( u1 u2 -- ud )
;
; Multiply _u1_ by _u2_, giving the unsigned double-cell product
; _ud_.  All values and arithmetic are unsigned.
;
; Standard: Forth 94
;
; }doc

  ; XXX -- adapted from hForth

  exx
  pop bc          ; BC = u2
  pop de          ; DE = u1
  ld  hl,0x0000
  ld  a,0x10
u_m_star.1:
  add  hl,hl
  ex  de,hl
  adc  hl,hl
  ex  de,hl
  jp  nc,u_m_star.3
u_m_star.2:
  add  hl,bc
  jp  nc,u_m_star.3
u_m_star.5:
  inc  de
u_m_star.3:
  dec  a
  jp  nz,u_m_star.1
u_m_star.4:
  push hl
  push de
  exx
  _jp_next

This is the version adapted from Z88 CamelForth, with absolute jumps:

  _code_header u_m_star_,'UM*'

; doc{
;
; um*  ( u1 u2 -- ud )
;
; Multiply _u1_ by _u2_, giving the unsigned double-cell product
; _ud_.  All values and arithmetic are unsigned.
;
; Standard: Forth 94
;
; }doc

  ; XXX -- adapted from Z88 CamelForth

  exx
  pop bc      ; u2 in BC
  pop de      ; u1 in DE
  ld hl,0     ; result will be in HLDE
  ld a,17     ; loop counter
  or a        ; clear cy
u_m_star.do:
  rr h
  rr l
  rr d
  rr e
  jp nc,u_m_star.noadd
  add hl,bc
u_m_star.noadd:
  dec a
  jp nz,u_m_star.do
  push de     ; lo result
  push hl     ; hi result
  exx
  _jp_next

And the benchmarks:

( um*-bench )

2 load  need frames@  need frames0

: um*-bench  ( times -- )
  frames0  0 do  i i um* 2drop  loop  frames@ d.  ;

  \ Times Frames (1 frame = 50th of second)
  \ ----- -----------------------------------
  \       DZX   hForth R hForth A Z88 R Z88 A
  \       ----- -------- -------- ----- -----
  \ 00100     3        3        3     3     3
  \ 01000    29       32       31    32    31
  \ 10000   297      328      319   323   316
  \ 20000   598      659      643   647   633
  \ 32000   961     1060     1037  1037  1016

  \            Bytes free Code from
  \            ---------- ---------
  \ DZX      = 33783      DZX-Forth
  \ hForth R = 33787      hForth, with relative jumps
  \ hForth A = 33784      hForth, with absolute jumps
  \ Z88 R    = 33786      Z88 CamelForth, with relative jumps
  \ Z88 A    = 33784      Z88 CamelForth, with absolute jumps

Renamed fig-Forth's +- and d+- to ?negate and ?dnegate, better names, already used by other Forth systems.

Tested and benchmarked the Abersoft Forth implementation of fig-Forth's m/ and the Z88 CamelForth implementation of Forth-94's sm/rem. Confirmed m/ does a symmetric division, and so both words are equivalent. The code of m/ is much faster, therefore it's renamed to sm/rem. m/ is converted to a deferred word in order to use fm/mod when needed.

( /-test )

  \ 2015-09-22: This test shows that Abersoft Forth's `m/` does
  \ a symmetric division, and so it's equivalent to Forth-94's
  \ `sm/rem`.

  \ From the Forth-94 documentation:

     \ Table 3.4 - Symmetric Division Example

     \ Dividend        Divisor Remainder       Quotient
     \ --------        ------- ---------       --------
     \ 10                 7       3                1
     \ -10                7      -3               -1
     \ 10                -7       3               -1
     \ -10               -7      -3                1

[defined] (/)  ?\ defer (/)

: ((/-test))  ( dividend divisor -- )
  >r s>d r> (/) swap . . space  ;

: (/-test)  ( -- )
  cr  10  7 ((/-test)) -10  7 ((/-test))
      10 -7 ((/-test)) -10 -7 ((/-test))  ;

: /-test  ( -- )
  dup ['] m/     ['] (/) defer! (/-test)
      ['] sm/rem ['] (/) defer! (/-test)  ;

( /-bench )

  \ 2015-09-22: This bench compares the execution speed of
  \ Abersoft Forth's `m/` and Z88 CamelForth's `sm/rem`. Both
  \ words are equivalent.  Abersoft Forth's `m/` is much
  \ faster.

need frames@  need frames0  need rnd

: drnd  ( -- d )  rnd rnd  ;

[defined] (/)  ?\ defer (/)

: (/-bench)  ( n -- )
  frames0  1+ 1 do  drnd i (/) 2drop  loop  frames@ cr d.  ;

: /-bench  ( n -- )
  dup ['] m/ ['] (/) defer! (/-bench)
      ['] sm/rem ['] (/) defer! (/-bench)  ;

  \ Times Frames (1 frame = 50th of second)
  \ ----- -----------------------------------
  \       m/    sm/rem
  \       ----- ------
  \ 00010     3      4
  \ 00100    33     44
  \ 01000   326    442

  \ m/     = word from Abersoft Forth
  \ sm/rem = word from Z88 Camel Forth

Fixed a silly bug recently introduced in asm and end-asm.

Wrote a new implementation of defer that calls the deferred words more than 200% faster. The implementation used so far is the classic one, with create and does>:

; ----------------------------------------------
  _colon_header defer_,'DEFER'

; doc{
;
; defer  ( "name" -- )
;
; Create a deferred word.
;
; Standard: Forth-2012.
;
; ----
; : defer  ( "name" -- )
;   create  ['] (defer) ,
;   does>  ( pfa ) @ execute  ;
; ----
;
; }doc

  dw create_
  _literal paren_defer_
  dw compile_comma_
  dw paren_semicolon_code_
do_defer:
  call do_does
  dw fetch_,execute_
  dw semicolon_s_

; ----------------------------------------------
  _colon_header defer_fetch_,'DEFER@'

; doc{
;
; defer@  ( cfa1 -- cfa2 )
;
; Return the word _cfa2_ currently associated to the deferred
; word _cfa1_.
;
; Standard: Forth-2012.
;
; }doc

  dw cfa_to_pfa_,fetch_
  dw semicolon_s_

; ----------------------------------------------
  _colon_header defer_store_,'DEFER!'

; doc{
;
; defer!  ( cfa1 cfa2 -- )
;
; Change the deferred word _cfa2_ to execute _cfa1_.
;
; Standard: Forth-2012.
;
; }doc

  dw cfa_to_pfa_,store_
  dw semicolon_s_

The new implementation of defer creates a code word with a direct jump to the inner interpreter. This is not only much faster, but does not create an additional nesting level, which may be a problem in some cases. defer! and defer@ need a little change.

; ----------------------------------------------
  _colon_header defer_,'DEFER' ; XXX TMP

; doc{
;
; defer  ( "name" -- )
;
; Create a deferred word.
;
; Standard: Forth-2012.
;
; }doc

  dw header_
  _literal 0x21 ; Z80 opcode for `ld hl,NN`
  dw c_comma_
  _literal paren_defer_ ; default cfa to execute
  dw comma_
  _literal 0xC3 ; Z80 opcode for `jp NN`
  dw c_comma_
  _literal next2 ; address to jump to
  dw comma_
  dw semicolon_s_

; ----------------------------------------------
  _colon_header defer_fetch_,'DEFER@'

; doc{
;
; defer@  ( cfa1 -- cfa2 )
;
; Return the word _cfa2_ currently associated to the deferred
; word _cfa1_.
;
; Standard: Forth-2012.
;
; }doc

  dw cfa_to_pfa_,one_plus_,fetch_
  dw semicolon_s_

; ----------------------------------------------
  _colon_header defer_store_,'DEFER!'

; doc{
;
; defer!  ( cfa1 cfa2 -- )
;
; Change the deferred word _cfa2_ to execute _cfa1_.
;
; Standard: Forth-2012.
;
; }doc

  dw cfa_to_pfa_,one_plus_,store_
  dw semicolon_s_

Adapted the deferred words in the kernel (cr, emit, at-xy and home). Conditional compilation will used for a while, just in case. Example:

if old_defer

  _does_header emit_,'EMIT',,do_defer

  dw paren_emit_

else

  _code_header emit_,'EMIT'

  ld hl,paren_emit_
  jp next2

endif

Added xy to get the current cursor position. This word is deferred because it depends on the screen mode.

; ----------------------------------------------
  _colon_header paren_mode32_xy_,'(MODE32-XY)'

; doc{
;
; (mode32-xy)  ( -- col row )

; Return the current column and row, in mode 32.

; ----
; : (mode32-xy)  ( -- row col )
;   24 23689 c@ -
;   33 23688 c@ - dup 32 = if  drop 1+ 0  then  ;
; ----

; }doc

  ; Credits:
  ; Code from the Spectrum Forth-83 manual.

  _literal 24
  _literal sys_s_posy
  dw c_fetch_,minus_
  _literal 33
  _literal sys_s_posx
  dw c_fetch_,minus_
  dw dup_
  _literal 32 ; XXX TODO -- chars per line in the current mode
  dw equals_
  dw zero_branch_,paren_mode32_xy.end
  dw drop_,one_plus_
  _literal 0
paren_mode32_xy.end:
  dw semicolon_s_

; ----------------------------------------------
if old_defer
  _does_header at_xy_,'XY',,do_defer

; doc{
;
; xy ( -- col row )
;
; Return the current column and row of the text cursor.
;
; }doc

  dw paren_mode32_xy_

else

  _code_header xy_,'XY'

  ld hl,paren_mode32_xy_
  jp next2

endif

Tidied the user data space to move the free space to the end.

removed the fld user variable, not used. It's defined but not used in fig-Forth; it's defined also in Forth-79 and Forth-83.

Added a new user variable, udp, to hold an offset to the free space in the user data space. This way an improved version of user will be possible, without requiring an offset as parameter.

Renamed the fig-Forth user variable out (called #out by the F83 Forth system) to #emit.

2015-09-23

Started implementing the Forth-2012 floating point word set, using the ROM calculator. Its stack can be used as the Forth floating point stack. So far the coding has been easy, because most o the words require only one or two calculator instructions. But it seems the ROM calculator uses the BASIC error routines after an error condition, what crashes the system. Not sure yet. If so, some ROM routines would have to be replicated and modified.

Fixed the problem of bye crashing when the screen mode is changed by mode42 or mode64. Now bye restores mode32. The previous mode is restored by warm and cold.

Converted boot to a deferred word. Formerly it was a constant that returned an address inside a definition to be patched with a cfa...

2015-09-24

Converted the error codes to the Forth-2012 standard. This change required a new version of error>line, with the new word error>ordinal:

; ----------------------------------------------
  _colon_header error_to_ordinal_,'ERROR>ORDINAL'

; : error>ordinal  ( -n1 -- +n2 )
;   \ Convert an error code to its ordinal position in the
;   \ library.
;   \ -n1 =  -90..-1        \ Forth-2012 error codes
;   \        -285..-256     \ Solo Forth error codes
;   \        -1024..-1000   \ G+DOS error codes
;   \ +n2 =  1..146
;   abs
;   dup 256 < ?exit
;   dup 1000 < if  [ 255 091 - ] literal - exit  then
;   [ 1000 286 - 255 091 - + ] literal -   ;

  dw abs_,dup_
  _literal 256
  dw less_than_,question_exit_
  dw dup_
  _literal 1000
  dw less_than_,zero_branch_,error_to_ordinal.g_plus_dos
  _literal 255-91
  dw minus_,exit_
error_to_ordinal.g_plus_dos:
  _literal (1000-286)+(255-91)
  dw minus_
  dw semicolon_s_

; ----------------------------------------------
  _colon_header error_to_line_,'ERROR>LINE'

; doc{
;
; error>line  ( n1 -- n2 )
;
; Convert an error number to its correspondent line offset. This
; is used in order to skip the first line of screens and use
; them as screen headers as usual.
;
; : error>line  ( n1 -- n2 )
;   error>ordinal dup 1+ 1 do  i 16 mod 0= abs +  loop  ;
;
; }doc

  dw error_to_ordinal_
  dw dup_,one_plus_,one_,paren_do_
error_to_number.do
  dw i_
  _literal 16
  dw mod_,zero_equals_,abs_,plus_
  dw paren_loop_,error_to_number.do
  dw semicolon_s_

The old error codes were based on fig-Forth, with some system specific codes and all G+DOS codes added:

  \ }}} =======================================================

The new error codes are those of the Forth-2012 standard, with two additional ranges for Solo Forth codes and G+DOS codes:

  \ }}} =======================================================

Rewrote ?negate and ?dnegate in assembler. They are faster and each of them saves two bytes.

; ----------------------------------------------
  _code_header question_negate_,'?NEGATE'

; doc{
;
; ?negate  ( n1 f -- n1|n2 )
;
; If _f_ is not zero, negate _n1_, giving its arithmetic inverse
; _n2_.
;
; ----
; : ?negate  ( n1 f -- n1|n2 )
;   if  negate  then  ;
; ----
; }doc

  ; XXX OLD
  ; _colon_header question_negate_,'?NEGATE'
  ; dw zero_less_than_
  ; dw zero_branch_,question_negate.end
  ; dw negate_
; question_negate.end:
  ; dw semicolon_s_

  pop hl
  ld a,h
  or l
  jp nz,negate_pfa
  _jp_next

; ----------------------------------------------
  _code_header question_d_negate_,'?DNEGATE'

; doc{
;
; ?dnegate  ( d1 f -- d1|d2 )
;
; If _f_ is not zero, negate _d1_, giving its arithmetic inverse
; _d2_.
;
; ----
; : ?dnegate  ( d1 f -- d1|d2 )
;   if  dnegate  then  ;
; ----
; }doc

  ; XXX OLD
  ;_colon_header question_d_negate_,'?DNEGATE'
  ; dw zero_less_than_
  ; dw zero_branch_,question_d_negate.end
  ; dw d_negate_
; question_d_negate.end:
  ; dw semicolon_s_

  pop hl
  ld a,h
  or l
  jp nz,dnegate_pfa
  _jp_next

2015-09-25

Fixed silly bug recently introduced: The fig-Forth +- and d+- changed the sign of a number when the TOS is negative; that's different from the behaviour of their new versions ?negate and ?negate, that change the sign when TOS is not zero! Restored the original behaviour, because some words need it.

Documented many words.

Benchmarked three implementations of fill: the original one from Abersoft Forth, a modified variant and the one from Z88 CamelForth. The later uses the Z80 instruction ldir and is almost 200% faster.

Reorganized and renamed most of the files. Moved the GNU binutils versions to /_old/gnu_binutils. Updated Makefile and the Vim session accordingly. Formerly most of the files used the same base name, "solo_forth". Now they are called "kernel", "library", "loader" or "boot":

Fixed error>ordinal: the range -256..-286 returned a number incremented by one.

Renamed (line) (name from fig-Forth) to line>string.

Documented more words of the kernel.

Added more alternative implementations for single-cell and double-cell values and benchmarked all of them. The benchmarks are the following:

( to-value-bench )

need frames@  need frames0

0 value v1

: to-value-bench  ( n -- )
  frames0  0
  do  0 to v1   loop
  frames@ cr d.  ;

( to-2value-bench )

need frames@  need frames0

0. 2value v2

: to-2value-bench  ( n -- )
  frames0  0
  do  0. to v2   loop
  frames@ cr d.  ;

( 2to-2value-bench )

need frames@  need frames0

0. 2value v2

: 2to-2value-bench  ( n -- )
  frames0  0
  do  0. 2to v2   loop
  frames@ cr d.  ;

The benchmarked versions:

( value 2value to )

  \ Standard: Forth-2012.

: value  ( n "name"  -- )  create  0 c, ,  does> 1+ @  ;
: 2value  ( n "name"  -- )  create  1 c, , ,  does> 1+ 2@  ;

: !value  ( n|d pfa -- )  dup c@ if  1+ 2! exit  then  1+ !  ;

: to  ( Interpretation: n "name" -- )
      ( Compilation: "name" -- )
  ' cfa>pfa
  comp? if  postpone literal  postpone !value  exit  then
  !value  ; immediate

( value to )

  \ Standard: Forth-94.

  \ Credits:
  \ Code adapted from Afera.

: value  ( n "name"  -- )  constant  ;

: to  ( Interpretation: n "name" -- )
      ( Compilation: "name" -- )
  ' cfa>pfa comp? if    postpone literal postpone !
                  else  !  then  ; immediate

( 2value 2to )

  \ Implementation of `2value` (from Forth-2012) but with
  \ the non-standard word `2to`

: 2value  ( d "name"  -- )  2constant  ;

: 2to  ( Interpretation: d "name" -- )
       ( Compilation: "name" -- )
  ' cfa>pfa comp? if    postpone literal postpone 2!
                  else  2!  then  ; immediate

( value )

  \ Non-standard implementation of `value` with non-parsing
  \ `to` -- version with flag.

  \ Credits:
  \ Code from lina.

variable to-message
: from  ( -- )  to-message off  ;  from
: to    ( -- )  to-message on  ;
: value  ( n "name" -- )
  create ,  does>  to-message @ if  !  else  @  then  from  ;

( value )

  \ Non-standard implementation of `value` with non-parsing
  \ `to` -- version with `perform`

  \ Credits:
  \ Code inspired by lina.

variable (value)
: from  ( -- )  ['] @ (value) !  ;  from
: to    ( -- )  ['] ! (value) !  ;
: value  ( n "name" -- )
  create ,  does>   (value) perform  from  ;

( value )

  \ Non-standard implementation of `value` with non-parsing
  \ `to` -- version with `defer`

  \ Credits:
  \ Code inspired by lina.

defer (value)
: from  ( -- )  ['] @ ['] (value) defer!  ;  from
: to    ( -- )  ['] ! ['] (value) defer!  ;
: value  ( n "name" -- )
  create ,  does>  (value) from  ;

The benchmarks (for compiled to or 2to):

( to-value-bench )

need frames@  need frames0

0 value v1

: to-value-bench  ( n -- )
  frames0  0
  do  0 to v1   loop
  frames@ cr d.  ;

( to-2value-bench )

need frames@  need frames0

0. 2value v2

: to-2value-bench  ( n -- )
  frames0  0
  do  0. to v2   loop
  frames@ cr d.  ;

( 2to-2value-bench )

need frames@  need frames0

0. 2value v2

: 2to-2value-bench  ( n -- )
  frames0  0
  do  0. 2to v2   loop
  frames@ cr d.  ;

Results:

Time benchmark: storing into a value 32,000 times
Implementation for single-cell values Frames (1 frame= 50th of second)
Forth-94 to 0339
Forth-2012 to with single-cell value 0744
Non-parsing to with flag 1208
Non-parsing to with perform 1208
Non-parsing to with defer 1719
Implementation for double-cell values Frames (1 frame= 50th of second)
Non-standard 2to 0425
Forth-2012 to with double-cell value 0968

2015-09-26

Renamed comp? to compiling? and made it return a well-formed flag; renamed ?comp to ?compiling and ?exec to ?executing. Documented all of them.

Wrote a second, better implementation of Forth-2012 to:

( value 2value to )

  \ Standard: Forth-2012.

: value  ( n "name"  -- )  create  0 c, ,  does> 1+ @  ;
: 2value  ( n "name"  -- )  create  1 c, , ,  does> 1+ 2@  ;

: to  ( Interpretation: n "name" -- )
      ( Compilation: "name" -- )
  ' cfa>pfa dup 1+ swap c@
  compiling? if  swap postpone literal
                 if  postpone 2!  else  postpone !  then  exit
             then
  if  2!  else  !  then
  ; immediate

Now the code compiled by to is exactly the same than the Forth-94 version, and so the benchmarks. Wrote simplified and a bit faster versions of the non-parsing implementations of to, without from. Example:

( value to )

  \ Alternative non-standard implementation of `value` with
  \ non-parsing `to` -- version with flag.

  \ Note: this version of is 3.6 times slower than the Forth-94
  \ and Forth-2012 implementations (for compiled `to`).

  \ Credits:
  \ Code modified from lina.

variable to-message  to-message off
: to    ( -- )  to-message on  ;
: value  ( n "name" -- )
  create ,
  does>  to-message @ if  !  else  @  then  to-message off  ;

All benchmark results so far:

Time benchmark: storing into a value 32,000 times
Implementation for single-cell values Frames (1 frame= 50th of second)
Forth-94 to 0339
Forth-2012 to (2nd version) 0339
Non-parsing to with perform (without from) 0670
Non-parsing to with defer (without from) 0670
Forth-2012 to (1st version) 0744
Non-parsing to with flag (without from) 1051
Non-parsing to with flag (with from) 1208
Non-parsing to with perform (with from) 1208
Non-parsing to with defer (with from) 1719
Implementation for double-cell values Frames (1 frame= 50th of second)
Non-standard 2to 0425
Forth-2012 to (2nd version) 0425
Forth-2012 to (1st version) 0968

Then benchmarked the fetching from single-cell and double-cell values, with the following code:

( value-bench )

need frames@  need frames0

0 value v1

: value-bench  ( n -- )
  frames0  0 do  v1 drop  loop  frames@ cr d.  ;

( 2value-bench )

need frames@  need frames0

0. 2value v2

: 2value-bench  ( n -- )
  frames0  0 do  v2 2drop  loop  frames@ cr d.  ;

Time benchmark: fetching from a value 32,000 times
Implementation for single-cell values Frames (1 frame= 50th of second)
Forth-94 value 0256
Forth-2012 to (2nd version) 0480
Forth-2012 to (1st version) 0670
Non-parsing to with perform (without from) 0670
Non-parsing to with flag (without from) 0719
Non-parsing to with defer (with from) 0842
Non-parsing to with perform (with from) 0851
Non-parsing to with flag (with from) 0874
Non-parsing to with defer (without from) 0899
Implementation for double-cell values Frames (1 frame= 50th of second)
Non-standard 2to 0283
Forth-2012 to (2nd version) 0500
Forth-2012 to (1st version) 0500

Finally, noted the dictionary space required by each implementation. Note that in Solo Forth the names are stored apart.

Dictionary space needed to implement values
Implementation for single-cell values Bytes
Forth-94 to 032
Non-parsing to with perform (without from) 041
Non-parsing to with flag (without from) 045
Non-parsing to with perform (with from) 047
Non-parsing to with defer (without from) 047
Non-parsing to with flag (with from) 051
Non-parsing to with defer (with from) 053
Forth-2012 to (1st version), without 2value 067
Forth-2012 to (2nd version), without 2value 077
Implementation for double-cell values Bytes
Non-standard 2to 032
Forth-2012 to (1st version), without value 069
Forth-2012 to (2nd version), without value 079
Implementation for single-cell and double-cell values Bytes
Forth 94 to with non-standard 2to 064
Forth-2012 to (1st version) 090
Forth-2012 to (2nd version) 100

The conclusion is easy: Forth-94 to and the non-standard 2to are the winners in all aspects. The second version of the Forth-2012 implementation will be kept as an alternative, in case the smart to is needed for compatibility. Finally, also a non-parsing version of to will be kept, because it may be useful for special cases. The version implemented with perform and without from is the best of all non-parsing versions in every aspect.

Improved header to issue an error when the name is empty.

2015-09-27

Fixed a calculation error in error>ordinal.

Modified ior>error to suite the new error codes:

: ior>error  ( ior -- f n )

  \ Convert a DOS ior to a Forth error number.

  \ ior = the AF register returned by a DOS command:
  \     bit 0     = set: error
  \     bits 8-14 = error code
  \     bit 15    = set: OS error; unset: DOS error
  \ f = error?
  \ n = error number: 1000..1031: G+DOS error number
  \                   1128..1154: OS error number
  dup 1 and negate swap   \ calculate f
  flip %11111111 and      \ upper 8 bits of ior
  1000 + negate  ;

Modified header, now it's smarter and faster: it uses parse-name instead of defined (which executes find-name). This way, the name is searched for only when warnings is on, and only the current vocabulary is searched (with search-wordlist), not the current search order. Did some benchmarking, loading many screens directly by their number: Given the time needed by the old method is always 1.0, the time needed by the new method is 0.86 when warnings is on, and 0.82 when warnings is off.

; ----------------------------------------------
  _colon_header header_,'HEADER'

; header  ( "name" -- )

if 0 ; XXX OLD

  dw defined_ ; ( x 0 | cfa 1 | cfa -1 )
  dw abs_,star_,question_dup_ ; ( 0 | cfa cfa )
  dw zero_branch_,header.continue

  ; The word is not unique.
  ; Note: `warnings` is already checked by `warning`,
  ; but it has to be done here too, in order to show the
  ; offending word or not before executing `warning`.
  dw warnings_,fetch_
  dw zero_branch_,header.no_warning
  dw cfa_to_nfa_,id_dot_
  _literal error.not_unique
  dw warning_
  dw zero_ ; for the `drop`, faster and smaller than a branch
header.no_warning:
  dw drop_

header.continue:

  dw parsed_name_,two_fetch_
  dw two_dup_,uppers_ ; XXX TMP

  ; XXX FIXME -- the problem is `parsed-name` is updated by
  ; `parse-name`, thus before `find` converted the word to uppercase.
  ; The solution is to write an alternative to `find`:
  ;     `find-name ( ca len -- 0 | cfa 1 | cfa -1 )`

  dw dup_,zero_equals_
  _question_error error.zero_length_name

  ; XXX TODO error if name is too long? (see lina)
  dw width_,fetch_,min_
  dw tuck_ ; ( len ca len )
  _names_bank
  dw here_,comma_np_ ; store a pointer to the cfa
  dw latest_,comma_np_ ; link field
  ; Now `np` contains the address of the nfa.
  dw np_fetch_
  dw place_ ; store the name
  dw np_fetch_,current_,fetch_,store_ ; update contents of `latest` in the current vocabulary
  dw smudge_ ; set the smudge bit and page the default bank
  dw one_plus_,np_,plus_store_ ; update the names pointer with the length+1
  dw here_,two_plus_,comma_ ; compile the pfa into code field
  dw semicolon_s_

else

; XXX NEW -- smarter and faster

  ; XXX Note: This version checks wether the word is unique only when
  ; `warnings` is on, and by searching only `current`.

  dw parse_name_  ; ( ca len )
  dw dup_,zero_equals_
  _question_error error.zero_length_name

  dw warnings_,fetch_
  dw zero_branch_,header.continue

  ; `warnings` is on
  dw two_dup_,current_,fetch_,search_wordlist_
  dw zero_branch_,header.continue
  ; the word is not unique in `current`
  ; ( ca len cfa )
  dw cfa_to_nfa_,id_dot_
  _literal error.not_unique
  dw message_ ; XXX TMP -- `warning`?

header.continue:

  ; ( ca len )

  dw two_dup_,uppers_ ; XXX FIXME -- do this modifies the buffer?

  ; XXX TODO error if name is too long? (see lina)
  dw width_,fetch_,min_
  dw tuck_ ; ( len ca len )
  _names_bank
  dw here_,comma_np_ ; store a pointer to the cfa
  dw latest_,comma_np_ ; link field
  ; Now `np` contains the address of the nfa.
  dw np_fetch_
  dw place_ ; store the name
  dw np_fetch_,current_,fetch_,store_ ; update contents of `latest` in the current vocabulary
  dw smudge_ ; set the smudge bit and page the default bank
  dw one_plus_,np_,plus_store_ ; update the names pointer with the length+1
  dw here_,two_plus_,comma_ ; compile the pfa into code field
  dw semicolon_s_

endif

Fixed the restoration of the previous screen mode in warm.