Solo Forth development history in 2016-03.

Description of the page content

Solo Forth development history in 2016-03.

Tags:

2016-03-01

Simplified (cat), calling only the SCAN_CAT routine:

code (cat)  ( n -- )

  \ n = cat type: 2=compact; 4=detailed

  hl pop  bc push  exx
    \ Get the parameter in hl' and save the Forth IP

  patch hook

  ufia hl ldp#  ufia1 de ldp#  /ufia bc ldp#  ldir
    \ Copy Forth UFIA to G+DOS UFIA1.

  \ exx  l a ld  24B5 call  168E call \ XXX OLD
    \ 24B5 = CAT_RUN (input: cat type in the A register)
    \ 168E = BORD_REST (restore the border)

  exx  l a ld  09A5 call \ XXX NEW
    \ 09A5 = SCAN_CAT  (input: cat or search type in the A register)

  E7 out  bc pop  next ix ldp#  jpnext  end-code
    \ page +D out
    \ restore the Forth registers and exit

2016-03-02

Wrote standard delete-file, after the old -file:

  \ XXX OLD:

: ior>error  ( ior -- f n )
  dup 1 and negate swap   \ calculate f
  flip %11111111 and      \ upper 8 bits of ior
  1000 + negate  ;
  \ 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 0..31
  \     -1128..-1154: OS error number 0..26

: -file  ( ca len -- f n )  filename>ufia (-file) ior>error  ;
  \ Delete a disk file _ca len_. If error, _f_ is true and
  \ _n_ is the error code.

  \ XXX NEW:

: dosior>ior  ( ior1 -- ior2 )
  dup 1 and negate          \ error?
  swap flip %11111111 and   \ get upper 8 bits of ior
  1000 + negate and  ;
  \ Convert a DOS ior to a Forth ior.
  \ ior1 = 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
  \ ior2 = error number:
  \     0: no error
  \     -1000..-1031: G+DOS error number 0..31
  \     -1128..-1154: OS error number 0..26

: delete-file  ( ca len -- ior )
  filename>ufia (-file) dosior>ior  ;
  \ Delete a disk file _ca len_ and return I/O result code
  \ _ior_.

2016-03-05

Deleted old -file.

Renamed drive@ and drive! to get-drive and set-drive, which seems more logical.

Added assert and assert= to the library.

2016-03-07

First draft of a command line history. It will be part of the library:

( hp hp0 unused-history allot-history allocate-history )

  \ 2016-03-07: Start.

  \ Command line history is implemented as a list of counted
  \ string at the top of the memory bank which is used also to
  \ store the name fields. Name files are stored upwards from
  \ the bottom of the 16-KiB space; command line history grows
  \ downwards from the top.
  \
  \ The length of the counted strings is used as link field.
  \ The bottom of the list is the hights address of the bank,
  \ and it holds one byte, the length of the first string
  \ stored in the history, or zero when the history is empty.
  \
  \ There's a maximum space usable for the history. When
  \ there's no free space left, the oldest string is removed
  \ in a loop until the necessary space is freed.
  \ XXX TODO

variable hp
  \ Pointer to the most recent string in the history.

$FFFF constant hp0
  \ Pointer to the bottom of the history, which contains a copy
  \ of the length of the first string.

1024 constant /history
  \ Size of the history space, where all strings are hold.

: init-hp0  ( -- )  0 hp0 c!n  ;

: empty-history  ( -- )  init-hp0  hp0 hp !  ;  empty-history

: history-bounds  ( -- ca1 ca2 )  hp0 hp @  ;
  \ Return bottom of history _a1_ and address of the latest
  \ string _ca2:

: used-history  ( -- u )  history-bounds -  ;
  \ Used space _u_ in the history.

: unused-history  ( -- n )  /history @ used-history -  ;
  \ Unused space _n_ in the history.

: allot-history  ( +n -- )  negate hp +!  ;
  \ Reserve _+n_ bytes in the history.

: history-empty?  ( -- f )  history-bounds =  ;
  \ Is the history empty?

: allocate-history  ( +n -- ior )
  dup /history @ > if  drop #-274 exit  then
    \ command line history overflow?
  ." allocate-history" \ XXX INFORMER
  0  ; \ XXX TMP
  \ Allocate _+n_ bytes in the history.
  \ XXX TODO -- remove older strings if needed

-->

( >history history> )

need s=

: latest-history  ( -- ca len )
  names-bank  hp @ count  save-string  default-bank  ;
  \ Return the latest string in the command line history,
  \ copied in the circular string buffer, without affecting
  \ the contents of the command line history.

: history>  ( -- ca len )

  \ XXX OLD
  \ names-bank    hp @ count  2dup + hp !  save-string
  \ default-bank

  \ XXX NEW
  latest-history dup 1+ negate allot-history

  history-empty? if  init-hp0  then  ;

  \ Get a string from the command line history, and return it
  \ as _ca len_ in the circular string buffer.

: duplicated-history?  ( ca len -- f )  latest-history s=  ;
  \ Is string _ca len_ identical to the latest string in
  \ the command line history?

: >history  ( ca len -- )
  dup 0= if  2drop exit  then
    \ If string is empty, do nothing.
  history-empty? if  dup hp0 c!n  then
    \ If history is empty, init its bottom with the lenght
    \ of the string.
  2dup duplicated-history? if  2drop exit  then
  dup 1+ unused-history >
  if  dup 1+ allocate-history throw  then
    \ If there's no space left, allocate it.
  dup 1+ allot-history
  hp @ names-bank place default-bank  ;
  \ Save string _ca len_ into the command line history.

Started modifying accept in order to implement the command line history into it. Did some improvements and fixes during the process.

2016-03-13

Made accept a deferred word. Replaced its old default behaviour default-accept with a simple smaller version, adapted from eForth, with an additional filter for control characters, and renamed it to simple-accept:

; ----------------------------------------------
  _defer_header accept_,'ACCEPT',,simple_accept_

; doc{
;
; accept  ( ca1 len1 -- len2 )
;
; 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_.
;
; Origin: Forth-94 (CORE), Forth-2012 (CORE).
;
; In Solo Forth `accept` is a deferred word. Its default
; behaviour is `default-accept`, which provides only the basic
; editing options Alternative definitions are provided in the
; library.
;
; }doc

; ----------------------------------------------
  _colon_header simple_accept_,'SIMPLE-ACCEPT'

; Credits:
;
; Code adapted from eForth.

; doc{
;
; simple-accept  ( ca1 len1 -- len2 )
;
; Default behaviour of the deferred word `accept`:
;
; 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 the Return key is pressed.  When input
; terminates, nothing is appended to the string or displayed on
; the screen.
;
; The only control key accepted is Delete.
;
; _len2_ is the length of the string stored at _ca1_.
;
; ----
; : simple-accept  ( ca len -- len' )
;   over + over  ( bot eot cur )
;   begin  xkey dup 13 <> \ not carriage return?
;   while
;     dup 12 =  \ delete?
;     if    drop  >r over r@ < dup  \ any chars?
;           if  8 dup emit  bl emit  emit  then  r> +
;     else  \ printable
;           >r  2dup <>  \ more?
;           r@ [ bl 1- ] literal > and  \ and printable?
;           if  r@ over c!  char+  r@ emit  then  r> drop
;     then
;   repeat  ( bot eot cur c )  drop nip swap -  ;
; ----
;
; }doc

  dw over_,plus_,over_
simple_accept.begin                                    ; begin
  dw xkey_,dup_
  _literal carriage_return_char
  dw not_equals_
  dw zero_branch_,simple_accept.end                    ; while
  dw dup_
  _literal delete_char
  dw equals_                                           ; delete?
  dw zero_branch_,simple_accept.printable              ; if
  dw drop_,to_r_,over_,r_fetch_,less_than_,dup_        ; any chars?
  dw zero_branch_,simple_accept.delete_end             ; if
  _literal backspace_char
  dw dup_,emit_,b_l_,emit_,emit_
simple_accept.delete_end                               ; then
  dw from_r_,plus_
  dw branch_,simple_accept.repeat
simple_accept.printable                                ; else
  ; printable
  dw to_r_,two_dup_,not_equals_                        ; more?
  dw r_fetch_
  _literal space_char-1
  dw greater_than_,and_                                ; and printable?
  dw zero_branch_,simple_accept.printable_end          ; if
  dw r_fetch_,over_,c_store_,char_plus_,r_fetch_,emit_
simple_accept.printable_end                            ; then
  dw from_r_,drop_
simple_accept.repeat
  dw branch_,simple_accept.begin                       ; repeat
simple_accept.end
  ; ( bot eot cur c )
  dw drop_,nip_,swap_,minus_
  dw exit_

; ----------------------------------------------
  _colon_header default_accept_,'DEFAULT-ACCEPT'

; doc{
;
; default-accept  ( ca1 len1 -- len2 )
;
; Default behaviour of the deferred word `accept`:
;
; 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 the Return key is pressed.  When input
; terminates, nothing is appended to the string or displayed on
; the screen.
;
; The only control key accepted is Delete.
;
; _len2_ is the length of the string stored at _ca1_.
;
; }doc

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

  dw to_r_ ; ( ca1 ) ( R: len1 )
default_accept.begin: ; ( ca )
  dw xkey_ ; ( ca c )

  dw dup_ ; ( ca c c )
  _literal delete_char
  dw equals_ ; delete key?
  dw zero_branch_,default_accept.maybe_carriage_return

  ; Delete key ( ca c )
  dw drop_
  dw span_,fetch_
  dw zero_branch_,default_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_,default_accept.emit

default_accept.maybe_carriage_return: ; ( ca c )
  dw dup_
  _literal carriage_return_char
  dw equals_ ; carriage return?
  dw question_branch_,default_accept.carriage_return

default_accept.ordinary_key: ; ( ca c )
  dw dup_,b_l_,less_than_ ; is it a control key?
  dw question_branch_,default_accept.discard ; if so, discard the char

default_accept.printable_key ; ( ca c )
  ; Printable key
  dw span_,fetch_,r_fetch_,less_than_ ; enough free space left?
  dw zero_branch_,default_accept.discard ; if not, discard the char

  dw two_dup_,swap_,c_store_ ; add the char to the string
  dw swap_,one_plus_,swap_ ; increase the address
  _literal 1
  dw span_,plus_store_ ; increase `span`

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

default_accept.discard: ; ( ca c )
  ; Discard the typed char
  dw drop_
  dw branch_,default_accept.begin

default_accept.carriage_return: ; ( ca c )
  dw drop_,r_drop_

default_accept.end: ; ( ca )
  dw drop_
  dw accept_buffer_,fetch_,span_,fetch_,to_history_
  dw span_,fetch_
  dw exit_

2016-03-14

Fixed cliteral.

Wrote c", with a new implementation of csilteral:

( csliteral c" )

: csliteral  ( Compilation: ca len -- )
             ( Run-time: -- ca )
  2>r postpone ahead here 2r> s, >r postpone then
  r> postpone literal  ; immediate compile-only
  \ doc{
  \
  \ csliteral  ( Compilation: "text<quote>" -- ) ( Run-time: -- ca )
  \
  \ Compile a string _ca len_ which at run-time will
  \ be returned as a counted string.
  \
  \ }doc
  \
  \ Credits:
  \ Code from Gforth's `CLiteral`.

: c"  ( Compilation: "text<quote>" -- )
      ( Run-time: -- ca )
  [char] " parse postpone csliteral  ; immediate compile-only

  \ doc{
  \
  \ c"  ( Compilation: "text<quote>" -- ) ( Run-time: -- ca )
  \
  \ Parse a string delimited by double quotes and
  \ compile it into the current definition.
  \ At run-time the string will be returned as a
  \ counted string _ca_.
  \
  \ Origin: Forth-94 (CORE EXT), Forth-2012 (CORE EXT).
  \
  \ }doc


Wrote basic tools to control the caps lock:

( capslock )

need os-flags2
need c!toggle-bits  need c@test-bits
need c!reset-bits   need c!reset-bits

%1000 os-flags2 2constant capslock
  \ Bit and system variable that control the capslock.

: toggle-capslock  ( -- )    capslock c!toggle-bits  ;
: set-capslock     ( -- )    capslock c!set-bits  ;
: unset-capslock   ( -- )    capslock c!reset-bits  ;
: capslock?        ( -- f )  capslock c@test-bits 0<>  ;

Removed the old ITC code, which was deactivated by default with conditional compilation.

Old ITC code in header macros:

_code_header: macro _base_label,_name,_flags

  _header _base_label,_name,_flags
if 0 ; itc
  dw _base_label##pfa ; code field
endif
  _base_label##pfa:   ; parameter field address
  _base_label##code:  ; address of the actual code

  endm

_defer_header: macro _base_label,_name,_flags,_xt

  _code_header _base_label,_name,_flags
if 0 ; itc
  ld hl,_xt
  jp next2
else ; DTC
  jp _xt
endif

  endm

_code_alias_header: macro _base_label,_name,_flags,_xt

  _header _base_label,_name,_flags
if 0 ; itc
  dw _xt##pfa ; code field
else ; DTC
  jp _xt
endif

  endm

_colon_header: macro _base_label,_name,_flags

  _header _base_label,_name,_flags
if 0 ; itc
  dw do_colon ; code field
else
  call do_colon ; code field
endif
  _base_label##pfa: ; parameter field address

  endm

_user_variable_header: macro _base_label,_name,_flags

  _header _base_label,_name,_flags
if 0 ; itc
  dw do_user ; code field
else
  call do_user ; code field
endif
  _base_label##pfa: ; parameter field address

  endm

_does_header: macro _base_label,_name,_flags,_runtime_routine

  _header _base_label,_name,_flags

if 0 ; itc
  dw _runtime_routine ; code field
else
  call _runtime_routine ; code field ; XXX TODO confirm this
endif
  _base_label##pfa: ; parameter field address

  endm

_constant_header: macro _base_label,_name,_flags

  _header _base_label,_name,_flags
if 0 ; itc
  dw do_constant ; code field
else
  call do_constant ; code field
endif
  _base_label##pfa: ; parameter field address

  endm

_two_constant_header: macro _base_label,_name,_flags

  _header _base_label,_name,_flags
if 0 ; itc
  dw do_two_constant ; code field
else
  call do_two_constant ; code field
endif
  _base_label##pfa: ; parameter field address

  endm

_c_constant_header: macro _base_label,_name,_flags

  _header _base_label,_name,_flags
if 0 ; itc
  dw do_c_constant ; code field
else
  call do_c_constant ; code field
endif
  _base_label##pfa: ; parameter field address

  endm

_variable_header: macro _base_label,_name,_flags

  _header _base_label,_name,_flags
if 0 ; itc
  dw do_create ; code field
else
  call do_create ; code field
endif
  _base_label##pfa: ; parameter field address

  endm

_two_variable_header: macro _base_label,_name,_flags

  _variable_header _base_label,_name,_flags

  endm

Old ITC code in the inner interpreter:

; ==============================================================
; :Inner interpreter

push_hlde:
  push de

push_hl:
  push hl

if 0 ; itc

next:
  ; Execute the word whose xt is in the address pointed by the bc register.
  ; Forth: W  <-- (IP)
  ; Z80:   hl <-- (bc)
  ld a,(bc)
  ld l,a
  inc bc ; inc IP
  ld a,(bc)
  ld h,a
  inc bc ; inc IP
  ; bc = address of the next xt
  ; hl = xt

next2:
  ; Execute the word whose xt is in the hl register.
  ; Forth: PC <-- (W)
  ; Z80:   pc <-- (hl)
  ld e,(hl)
  inc hl
  ld d,(hl)
  ex de,hl
  ; hl = (xt) = address of the code
  ; de = xt+1 = pfa-1

next2_end: ; XXX TMP label for debugging
  jp (hl)

else ; DTC

next:
  ; Execute the word whose xt is in the address pointed by the bc register.
  ; Forth: W  <-- (IP)
  ; Z80:   hl <-- (bc)
  ld a,(bc)
  ld l,a
  inc bc ; inc IP
  ld a,(bc)
  ld h,a
  inc bc ; inc IP
  ; bc = address of the next xt
  ; hl = xt

next2:
  ; Execute the word whose xt is in the hl register.
  ; Forth: PC <-- (W)
  ; Z80:   pc <-- (hl)
next2_end: ; XXX TMP label for debugging
  jp (hl)

endif

Old ICT code in some words:

; ----------------------------------------------
  _code_header execute_,'EXECUTE'

; doc{
;
; execute  ( xt  -- )
;
; }doc

  pop hl
if 0 ; itc
  jp next2
else ; DTC
  jp (hl)
endif

; ----------------------------------------------
  _colon_header colon_,':'

  dw store_csp_
  dw header_
if 0 ; itc
else ; DTC
  dw lit_,do_colon
  dw code_field_comma_
endif
  dw right_bracket_
  dw paren_semicolon_code_
do_colon:
  ld hl,(return_stack_pointer)
  dec hl
  ld (hl),b
  dec hl
  ld (hl),c
  ld (return_stack_pointer),hl ; save the updated IP

if 0 ; itc
                     ; T  B
                     ; -- --
  inc de ; de=pfa    ; 06 01
  ld c,e             ; 04 01
  ld b,d ; bc=pfa    ; 04 01

else ; DTC
                     ; T  B
                     ; -- --
  pop bc ; bc=pfa    ; 10 01

endif

do_colon.end: ; XXX TMP for debugging
  _jp_next

; ----------------------------------------------
  _colon_header colon_no_name_,':NONAME',immediate

; doc{
;
; :noname  ( -- xt )
;
; Origin: Forth-94 (CORE EXT), Forth-2012 (CORE EXT).
;
; ----
; }doc


  ; Credits:
  ; Code from the Afera library.

  ; XXX TODO move to the library?
  ; first `do_colon` must be defined as a constant

  dw here_ ; xt
  dw store_csp_
  dw lit_,do_colon
if 0 ; itc
  dw comma_ ; create the code field
else ; DTC
  dw code_field_comma_
endif
  dw noname_question_,on_
  dw right_bracket_
  dw exit_

; ----------------------------------------------
if 0 ; itc
else ; DTC
  _colon_header code_field_comma_,'CODE-FIELD,'

; doc{
;
; code-field,  ( a -- )
;
; Compile a code field for a high-level word, to execute the
; actual Z80 code at _a_.

; ----
; : code-field,  ( a -- )
;   $CD c,  \ Z80 opcode for "call"
;   ,  ;
; ----
;
; }doc

  _literal 0xCD ; Z80 opcode for "call"
  dw c_comma_ ; compile it
  dw comma_  ; compile _a_
  dw exit_

endif

; ----------------------------------------------
  _header noop_,'NOOP'

; doc{
;
; noop  ( -- )
;
; }doc

if 0 ; itc
  dw next ; code field
else ; DTC
  _jp_next ; code field
endif

; ----------------------------------------------
  _colon_header c_constant_,'CCONSTANT'

  dw create_,c_comma_
  dw paren_semicolon_code_
do_c_constant:
if 0 ; itc
                     ; T  B
                     ; -- --
  inc de    ; de=pfa ; 06 01
  ex de,hl  ; hl=pfa ; 04 01
else
                     ; T  B
                     ; -- --
  pop hl             ; 10 01
endif
  jp c_fetch.hl

; ----------------------------------------------
  _colon_header constant_,'CONSTANT'

  dw create_,comma_
  dw paren_semicolon_code_
do_constant:
if 0 ; itc
                     ; T  B
                     ; -- --
  inc de    ; de=pfa ; 06 01
  ex de,hl  ; hl=pfa ; 04 01
else
                     ; T  B
                     ; -- --
  pop hl             ; 10 01
  ; _z80_border_wait 4 ; XXX INFORMER
  ; _z80_border 0 ; XXX INFORMER
endif
  jp fetch.hl

; ----------------------------------------------
  _colon_header user_,'USER'

; doc{
;
; user  ( "name" -- )
;
; Create a user variable _name_ in the first available offset
; within the user area.  Execution of _name_ leaves its absolute
; user area storage address.
;
; }doc

  ; XXX UNDER DEVELOPMENT
  ; XXX TODO

  dw c_constant_
  dw paren_semicolon_code_
do_user:
if 0 ; itc
  inc de      ; de=pfa
  ex de,hl
else ; DTC
  pop hl
endif
  ld e,(hl)
  ld d,0x00   ; de = index of the user variable
  ld hl,(user_variables_pointer)
  add hl,de   ; hl= address of the user variable
  jp push_hl

; ----------------------------------------------
if 0 ; itc
  _code_alias_header from_body_,'BODY>',,two_minus_
else ; DTC
  _code_header from_body_,'BODY>'
  pop hl
  dec hl
  dec hl
  dec hl
  jp push_hl
endif

; ----------------------------------------------
if 0 ; itc
  _code_alias_header to_body_,'>BODY',,two_plus_
else ; DTC
  _code_header to_body_,'>BODY'
  pop hl
  inc hl
  inc hl
  inc hl
  jp push_hl
endif

; ----------------------------------------------
if 0 ; ITC
  _code_alias_header to_code_,'>CODE',,two_plus_
else ; DTC
  _code_alias_header to_code_,'>CODE',immediate,noop_
endif

; doc{
;
; >code  ( xt -- a )
;
; Convert _xt_ of a primitive word to the actual address where
; the Z80 code is.
;
; This word is an abstraction: On ITC Solo Forth, `>code` is
; equivalent to `>body`; on DTC, it does nothing.
;
; }doc

; ----------------------------------------------
  _colon_header paren_semicolon_code_,'(;CODE)'

; doc{
;
; (;code)  ( -- )
;
; The run-time procedure compiled by `;code`. Rewrite the code
; field of the most recently defined word to point to the
; following machine code sequence.
;
; }doc

if 0 ; itc

; ----
; : (;code)  ( -- )
;   r>        \ Pop the address of the next instruction off the return stack,
;             \ which is the starting address of the run-time code routine.
;   latest    \ Get the name token of the word under construction.
;   name> !   \ Find its execution token and store the address of
;             \ the code routine to be executed at run-time into it.
;   ;
; ----

  dw from_r_,latest_,from_name_,store_
  dw exit_

else ; DTC

; ----
; : (;code)  ( -- )
;   r> latest name> 1+ !  ;
; ----

  dw from_r_,latest_,from_name_,one_plus_,store_
  dw exit_

endif

; ----------------------------------------------
  _colon_header does_,'DOES>',immediate+compile_only

if 0 ; itc

  dw compile_,paren_semicolon_code_
  _literal 0xCD ; Z80 opcode for "call"
  dw c_comma_ ; compile it
  dw lit_,do_does,comma_ ; compile the routine address
  dw exit_

do_does:
  ; Save the IP on the return stack.
  ld hl,(return_stack_pointer)
  dec hl
  ld (hl),b
  dec hl
  ld (hl),c
  ld (return_stack_pointer),hl
  ; Pop the address of the run-time routine
  ; (put there bye `call do_does`) in IP.
  pop bc ; new Forth IP
  ; Push the pfa.
  inc de  ; de=pfa
  push de
  ; Execute the run-time routine.
  _jp_next

else ; DTC

do_does equ do_colon

  dw compile_,paren_semicolon_code_
  _literal 0xCD ; Z80 opcode for "call"
  dw c_comma_ ; compile it
  dw lit_,do_does,comma_ ; compile the routine address
  dw exit_

;do_does:
  ; XXX UNDER DEVELOPMENT
  ; XXX FIXME
;  pop de
;  push de
;  push de
;  jp do_colon

endif

; ----------------------------------------------
  _colon_header header_comma_,'HEADER,'

; doc{
;
; header,  ( ca len -- )
;
; Create a dictionary header with the name _ca len_.
;
; }doc

  ; XXX TODO -- complete the description, depending on ITC and
  ; DTC

  dw dup_,zero_equals_
  _question_throw error.zero_length_name

  dw warnings_,fetch_
  dw zero_branch_,header_comma.continue

  ; `warnings` is on
  dw two_dup_,get_current_,search_wordlist_
  dw zero_branch_,header_comma.continue
  ; the word is not unique in `current`
  ; ( ca len xt )
  dw to_name_,dot_name_
  _literal error.not_unique
  dw dot_throw_ ; XXX TMP -- `warning`?

header_comma.continue:

  ; ( ca len )

  dw width_,fetch_,min_
  dw tuck_ ; ( len ca len )
  dw names_bank_
  dw here_,comma_np_ ; store a pointer to the xt
  dw latest_,comma_np_ ; link field
  ; Now `np` contains the address of the nt.
  dw np_fetch_
  dw dup_,to_r_
  dw place_ ; store the name
  dw from_r_,count_,uppers_

  dw np_fetch_,get_current_,store_ ; update contents of `latest` in the current vocabulary
  dw hide_
  dw one_plus_,np_,plus_store_ ; update the names pointer with the length+1

if 0 ; itc
  dw here_,cell_plus_,comma_ ; compile the pfa into code field
else ; DTC
  ; no code field is created
endif

  dw exit_

; ----------------------------------------------
  _colon_header create_,'CREATE'

  ; XXX TODO factor `header reveal` to `visible-header`? it's
  ; used also by `defer`.

  dw header_
if 0 ; itc
else ; DTC
  dw lit_,do_create
  dw code_field_comma_
endif
  dw reveal_
  dw paren_semicolon_code_
do_create:
if 0 ; itc
  inc de  ; de=pfa
  push de
else ; DTC
  ; DTC does not require any code, because `call do_create` already
  ; left the pfa on the stack.
endif
  _jp_next

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

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

  dw header_,reveal_
if 0 ; itc
  _literal 0x21 ; Z80 opcode for `ld hl,NN`
  dw c_comma_
  _literal paren_defer_ ; default xt to execute
  dw comma_
  _literal 0xC3 ; Z80 opcode for `jp NN`
  dw c_comma_
  _literal next2 ; address to jump to
  dw comma_
else ; DTC
  _literal 0xC3 ; Z80 opcode for `jp NN`
  dw c_comma_
  _literal paren_defer_ ; default xt to execute
  dw comma_
endif

  dw exit_


if 0 ; itc

; ----------------------------------------------
  _colon_header to_defer_,'>DEFER'

; doc{
;
; >defer  ( xt1 -- a )
;
; Return the address _a_ that holds the xt currently associated
; to the deferred word _xt1_.
;
; }doc


  dw to_body_,one_plus_
  dw exit_

else ; DTC

; ----------------------------------------------
  _code_alias_header to_defer_,'>DEFER',,one_plus_

; doc{
;
; >defer  ( xt1 -- a )
;
; Return the address _a_ that holds the xt currently associated
; to the deferred word _xt1_.
;
; }doc

endif

; ----------------------------------------------
  _colon_header two_constant_,'2CONSTANT'

  dw create_,two_comma_
  dw paren_semicolon_code_
do_two_constant:
if 0 ; itc
  inc de    ; de=pfa
  ex de,hl  ; hl=pfa
else
  pop hl
endif
  jp two_fetch.hl


The word >code was an abstraction required to make some code words from the library work on both ITC and DTC. Now it can be removed.

Also some words from the library can be removed. For example, the ITC implementation of alias, which was quite complex:

( alias )

  \ XXX NEW -- DTC

: alias  ( xt "name" -- )  defer latest name> defer!  ;

  \ doc{
  \
  \ alias  ( xt "name" -- )
  \
  \ Create an alias _name_ that will execute _xt_.
  \
  \ }doc

( code? code-alias? defer-alias code-alias alias )

  \ XXX OLD -- ITC

: code?  ( xt -- wf )  dup >body swap @ =  ;
  \ Is _xt_ a word created by `code`?

: code-alias?  ( xt -- wf )  @ dup body> @ =  ;
  \ Is _xt_ a word created by `code-alias` or `code`?

: defer-alias  ( xt "name" -- )
  defer latest name> defer!  ;
  \ Create a deferred word _name_ that executes _xt_.

: code-alias  ( xt "name" -- )
  @ header reveal latest name> !  ;
  \ Create a code word that executes the code pointed by _xt_.

: alias  ( xt "name" -- )
  dup code-alias? if  code-alias exit  then  defer-alias  ;

  \ doc{
  \
  \ alias  ( xt "name" -- )
  \
  \ Create an alias _name_ that will execute _xt_.  If _xt_
  \ is a primitive word, the address hold in _name_'s own xt
  \ will be the same than the address hold in _xt_. Otherwise
  \ _name_ will be a deferred word executing _xt_.
  \
  \ }doc

Converted execute-hl back to DTC:

( execute-hl call-xt )

  \ 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 an xt hold in a
  \ variable.  The code was factored to two assembler macros in
  \ order to make it reusable.

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

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

2016-03-15

Tested the previous implementation of csliteral, which is system-dependent but more versatile, and thus used by default:

( cslit csliteral c" )

  \ This is the default definition of `csliteral`, based on a
  \ system-dependent `cslit`, which makes it possible to decode
  \ `c"`.

  \ XXX REMARK -- 43 bytes used

: cslit  ( -- ca )  r@ dup c@ 1+ r> + >r  ;
  \ doc{
  \
  \ cslit  ( -- ca )
  \
  \ Return a string that is compiled after the calling word, and
  \ adjust the instruction pointer to step over the inline string.
  \
  \ }doc

: csliteral  ( ca len -- )
  compile cslit s,  ; immediate compile-only
  \ doc{
  \
  \ csliteral  ( Compilation: "text<quote>" -- ) ( Run-time: -- ca )
  \
  \ Compile a string _ca len_ which at run-time will
  \ be returned as a counted string.
  \
  \ }doc

: c"  ( Compilation: "text<quote>" -- )
      ( Run-time: -- ca )
  [char] " parse postpone csliteral  ; immediate compile-only
  \ doc{
  \
  \ c"  ( Compilation: "text<quote>" -- ) ( Run-time: -- ca )
  \
  \ Parse a string delimited by double quotes and
  \ compile it into the current definition.
  \ At run-time the string will be returned as a
  \ counted string _ca_.
  \
  \ Origin: Forth-94 (CORE EXT), Forth-2012 (CORE EXT).
  \
  \ }doc

( csliteral c" )

  \ This is an alternative system-independent definition of
  \ `csliteral`.

  \ XXX REMARK -- 43 bytes used

: csliteral  ( Compilation: ca len -- )
             ( Run-time: -- ca )
  2>r postpone ahead here 2r> s, >r postpone then
  r> postpone literal  ; immediate compile-only
  \ Credits:
  \ Code from Gforth's `CLiteral`.

: c"  ( Compilation: "text<quote>" -- )
      ( Run-time: -- ca )
  [char] " parse postpone csliteral  ; immediate compile-only


Replaced the Abersoft and Gforth definition of ud/mod with code adapted from Z88 CamelForth, which is a bit faster and a bit smaller, but which needs -rot to be moved from the library:

; ----------------------------------------------
  _colon_header u_d_slash_mod_,'UD/MOD'

if 0 ; XXX OLD

; doc{
;
; ud/mod ( ud1 u2 -- urem udquot )
;
; ----
; : ud/mod ( ud1 u2 -- urem udquot )
;   >r 0 r@ um/mod r> swap
;   >r um/mod r>  ;
; ----

; Origin: fig-Forth (`m/mod`), Gforth.
;
; }doc

  ; Credits:
  ;
  ; Code from fig-Forth (where this word is called `m/mod`)
  ; and Gforth.

  dw to_r_
  _literal 0
  dw r_fetch_
  dw u_m_slash_mod_
  dw from_r_
  dw swap_
  dw to_r_
  dw u_m_slash_mod_
  dw from_r_
  dw exit_

else ; XXX NEW

  _colon_header u_d_slash_mod_,'UD/MOD'

; doc{
;
; ud/mod ( ud1 u2 -- urem udquot )
;
; ----
; : ud/mod  ( ud1 u1 -- urem udquot )
;   >r 0 r@ um/mod -rot r> um/mod rot ;
; ----

  ; Credits:
  ; Code modified from Z88 CamelForth.

  dw to_r_
  _literal 0
  dw r_fetch_
  dw u_m_slash_mod_
  dw minus_rot_
  dw from_r_
  dw u_m_slash_mod_
  dw rot_
  dw exit_

; ----------------------------------------------
  _code_header minus_rot_,'-ROT'

  pop hl
  pop de
  ex (sp),hl
  ex de,hl
  jp push_hlde

endif

Fixed number?: wrong numbers left a double cell under the TOS false flag. This error was not detected before because the interpreter forced and error, which clears the stacks.

Improved number?: now any number of decimal points is accepted, not only one (also Gforth works this way).

2016-03-16

Fixed number?: base was not restored on exit caused by a wrong number, so bad numbers with base prefixes, like "$" and "%", left base with the value set by the prefix.

Improved number?: now also colon, slash, comma, plus and hyphen are allowed as punctuation.

Added number to the library, and a new error code for it:

: number  ( ca len -- n | d )  number? 0= #-275 ?throw  ;

Made .\" independent from s\", by a commond dependency on parse-escaped-string.

Replaced Z80 jumps to the push_hl entry point of the inner interpreter with a push hl and the usual jp (ix) (jump to next). This saves 2 T states and needs no additional bytes. Benchmarks are 1% faster.

Added jppushhl to the assembler word list in the kernel.

Made number? to reject initial or duplicated points:

; ----------------------------------------------
  _defer_header number_point_question_,'NUMBER-POINT?',,standard_number_point_question_

; doc{
;
; number-point?  ( c -- f )
;
; Is character _c_ a valid point in a number?  This is a
; deferred word used in `number?`. Its default behaviour is
; `standard-number-point?`, which only allows the period.
;
; The library provides alternatives which accept more points.
;
; }doc

; ----------------------------------------------
  _colon_header standard_number_point_question_,'STANDARD-NUMBER-POINT?'

; doc{
;
; standard-number-point?  ( c -- f )
;
; Is character _c_ a valid point in a number?  The only allowed
; point is period.
;
; This is the default behaviour of the deferred word
; `number-point?`, which is used in `number?`.
;
; The library provides alternatives which accept more points.

; ----
; : number-point?  ( c -- f )
;   [char] . =  ;
; ----
;
; }doc

; ----------------------------------------------
  _colon_header number_question_,'NUMBER?'

  ; XXX TODO make it a deferred word

; doc{
;
; number?   ( ca len -- 0 | n 1 | d 2 )
;
; Convert a string _ca len_ to a number. Return 0 if the
; conversion is not possible. If the result is a single number,
; return _n_ and 1. If the result is a double number, return _d_
; and 2.
;
; This word accepts valid point anywhere on the number and
; updates `dpl` with the position of the last one. If no
; point is found, `dpl` contains -1.
;
; Chars between single quotes are recognized, after Forth-2012.

; ----
; : number?   ( ca len -- 0 | n 1 | d 2 )
;
;   dup 0= if  2drop 0 exit  then  \ reject empty strings
;
;   2dup char? if  nip nip 1 exit  then  \ char format
;
;   over c@ number-point?  \ first char is a point?
;   if  2drop 0 exit  then  \ is so, reject the string
;
;   base @ >r  number-base base !  ( R: radix )
;   skip-sign? >r                  ( R: radix sign )
;   0 0 2swap  dpl on
;
;   begin  ( d ca len )  >number dup  while
;
;     over c@ number-point? 0=   \ invalid point?
;     if  2drop 2drop rdrop r> base ! 0 exit  then
;
;     dup dpl @ =   \ previous char was a point?
;     if  2drop 2drop rdrop r> base ! 0 exit  then
;
;     dup 1- dpl !  \ update the position of the last point
;     1 /string     \ skip the point
;
;   repeat
;
;   2drop                     \ discard the empty string
;   dpl @ 0<                  \ single-cell number?
;   if    d>s r> ?negate  1   \ single-cell number
;   else  r> ?dnegate  2      \ double-cell number
;   then  r> base !  ;        \ restore the radix
; ----

; }doc

  dw dup_,zero_equals_ ; empty string?
  dw zero_branch_,number_question.try_char
  ; reject an empty string
number_question.reject:
  dw two_drop_,false_
  dw exit_

number_question.try_char:
  dw two_dup_,char_question_ ; a char?
  dw zero_branch_,number_question.try_initial_point
  ; return the char code
  dw nip_,nip_
  _literal 1
  dw exit_

number_question.try_initial_point:
  dw over_,c_fetch_ ; first char...
  dw number_point_question_ ; ...is point?
  dw question_branch_,number_question.reject ; is so, reject the string

  dw base_,fetch_,to_r_
  dw number_base_,base_,store_

  dw skip_sign_question_,to_r_
  dw two_lit_,0,0 ; initial value
  dw two_swap_,dpl_,on_

number_question.begin:
  dw to_number_
  dw dup_ ; are there non-recognized chars?
  dw zero_branch_,number_question.done ; while

  ; The conversion was not completed, so it may be because of a
  ; point that indicates it's a double number.

  dw over_,c_fetch_ ; get the non-digit character
  dw number_point_question_ ; is it valid point?
  dw question_branch_,number_question.point

number_question.invalid_character:
  dw two_drop_,two_drop_,r_drop_,false_
  dw branch_,number_question.end

number_question.point:
  dw dup_,dpl_,fetch_,equals_ ; was the previous character a point?
  dw question_branch_,number_question.invalid_character ; if so, invalid

number_question.valid_point:
  dw dup_,one_minus_,dpl_,store_ ; update the position of the last point
  _literal 1
  dw slash_string_ ; skip the point

  dw branch_,number_question.begin ; repeat

number_question.done:
  dw two_drop_ ; discard the empty string
  dw dpl_,fetch_,zero_less_than_ ; single-cell number?
  dw zero_branch_,number_question.double

  ; single-cell number
  dw d_to_s_,from_r_,question_negate_
  _literal 1
  dw branch_,number_question.end

number_question.double:
  ; double-cell number
  dw from_r_,question_d_negate_
  _literal 2

number_question.end:
  dw from_r_,base_,store_  ; restore `base`

  dw exit_

Added two alternatives to number-point? to the library:

( standard-number-point? extended-number-point? )

need [if]

[needed] classic-number-point? [if]

: classic-number-point?  ( c -- f )
  dup [char] : = swap [char] , - 4 u< or  ;
  \ doc{
  \
  \ standard-number-point?  ( c -- f )
  \
  \ Is character _c_ a classic number point?  Allowed
  \ points are: comma, hyphen, period, slash and
  \ colon.
  \
  \ This word is an alternative behaviour for the deferred word
  \ `number-point?`, which is used in `number?`.
  \
  \ }doc

[then]

[needed] extended-number-point? [if]

: extended-number-point?  ( c -- f )
  dup [char] : = swap [char] + - 5 u< or  ;
  \ doc{
  \
  \ extended-number-point?  ( c -- f )
  \
  \ Is character _c_ an extended number point?  Allowed
  \ points are: plus sign, comma, hyphen, period, slash and
  \ colon, after _Forth Programmer's Handbook_.
  \
  \ This word is an alternative behaviour for the deferred word
  \ `number-point?`, which is used in `number?`.
  \
  \ }doc
  \
  \ Credits:
  \
  \ Code by Wil Baden, from Forth Dimensions (volume 20, number
  \ 3 page 26, 1998-10).

[then]

2016-03-19

Added there to set dp and updated the library accordingly.

Made compile, an alias of ,,

Since DTC makes aliases of colon words possible, the following words are converted to alias: compile,, begin, <mark, <resolve and then.

Removed next2. Updated pause and execute-hl accordingly.

Updated some development benchmarks.

Moved the stack notation description to its own file.

Reorganized the source, binary and temporary files into directories.

Added bank-start:

; ----------------------------------------------
  _constant_header bank_start_,'BANK-START'

; doc{
;
; bank-start  ( -- a )
;
; A constant: Memory address where banks are paged in.
;
; }doc

bank_start equ 0xC000

  dw bank_start

Added save-here and restore-here:

( save-here restore-here )

variable here-backup
: save-here  ( -- )  here here-backup !  ;
: restore-here  ( -- )  here-backup there  ;

Renamed the "names bank" to "system bank", because it will be used also for the command line history, and maybe more things. Renamed all related words and kernel labels accordingly.

Added the code-bank tool:

( code-bank )

need save-here  need call

variable cp  bank-start cp !  \ code pointer

: code-here   ( -- a )  cp @  ;
: code-there  ( a -- )  cp !  ;
: code-allot  ( n -- )  cp +!  ;

variable code-bank#  3 code-bank# !
  \ Memory bank used as code bank.

: code-bank  ( -- )  code-bank# @ bank  ;
  \ Page the code bank in.

: code-bank{  ( -- )  save-here code-here there code-bank  ;
  \ Start compiling code into the code bank.

: }code-bank  ( -- )  default-bank restore-here  ;
  \ End compiling code into the code bank.

: ?bank  ( -- )  bank-start here u< #-276 ?throw  ;
  \ Issue error -276 if the dictionary has reached
  \ the zone of memory banks. This check is required after
  \ compiling code which must manipulate memory banks.

: code-bank-routine  ( i*x a "name" -- j*x )
  create ?bank ,
  does>  ( -- )  ( pfa ) @ code-bank call default-bank  ;
  \ Create a word "name" which will call the machine code
  \ routine at _a_, in the code bank.

Restored list, wich was removed by mistake in version 0.3.0-rc.0+20160316.

Converted >wid and wid> to aliases.

2016-03-20

Added +under, a variant of the current under+:

( under+ )  \ ==operators==

code under+  ( n1|u1 x n2|u2 -- n3|u3 x )
  D9 c,           \ exx
  D1 c,           \ pop de
  C1 c,           \ pop bc
  E1 c,           \ pop hl
  19 c,           \ add hl,de
  E5 c,           \ push hl
  C5 c,           \ push bc
  D9 c,           \ exx
  jpnext  end-code

  \ doc{
  \
  \ under+  ( n1|u1 x n2|u2 -- n3|u3 x )
  \
  \ Add _n2|u2_ to _n1|u2_, giving the sum _n3|u3_.
  \
  \ Origin: Comus.
  \
  \ ----
  \ : under+  ( n1|u1 x n2|u2 -- n3|u3 x )
  \   rot + swap  ;
  \ ----
  \
  \ }doc

( +under )

code +under  ( n1|u1 n2|u2 x -- n3|u3 x )
  D9 c,           \ exx
  C1 c,           \ pop bc
  D1 c,           \ pop de
  E1 c,           \ pop hl
  19 c,           \ add hl,de
  E5 c,           \ push hl
  C5 c,           \ push bc
  D9 c,           \ exx
  jpnext  end-code

  \ doc{
  \
  \ +under  ( n1|u1 n2|u2 x -- n3|u3 x )
  \
  \ Add _n2|u2_ to _n1|u2_, giving the sum _n3|u3_.
  \
  \ Origin: Comus.
  \
  \ ----
  \ : +under  ( n1|u1 n2|u2 x -- n3|u3 x )
  \   >r + r>  ;
  \ ----
  \
  \ }doc

  \ XXX TODO -- variant after PFE's `(under+)`:
  \ : +under  ( n1 n2 -- n1+n2 n2 )  tuck + swap  ;

Replaced get-order with the version of eForth:

( get-order order@ )

  \ Credits: Code from eForth.

: order@  ( a -- u*wid u )
  dup @ dup if    >r cell+  recurse  r> swap 1+ exit
            then  nip  ;
  \ XXX TODO use the actual number of vocs in context,
  \ not a trailing zero

: get-order  ( -- u*wid u )  context order@ ;

2016-03-21

There is a problem: the default bank is restored. Added set-default-bank and get-default-bank and default-bank#.

Removed parens from names of the printing mode vectors.

Commented out the contrast ink calculation done in border.

2016-03-22

Removed the game _Nuclear Invaders_, which temporarily had been included in the library.

Splitted the library into 65 files. This makes it possible to include only the modules needed by the user application. The Makefile has been updated accordingly.

2016-03-23

Splitted the library files even more: strings, tools, value, data structures, control structures...

Added for-i for the for step loop and renamed di to dfor-i for the dfor dstep loop.

Renamed the words of Wil Baden's case structure, to avoid standard names:

( thiscase )

  \ An alternative `case` structure that makes any
  \ calculation easier.

  \ 2015-11-14: First version.
  \ 2016-03-24: Renamed to avoid standard names `case`, `of`
  \ and `endof`.

  \ Credits:
  \
  \ Adapted and modified from code written by Wil Baden,
  \ published on Forth Dimensions (volume 8, number 5, page 29,
  \ 1987-01).

need alias

' dup alias thiscase  ( n -- n n )
' drop alias othercase  ( n -- )

: ifcase  ( n f -- )
  postpone if  postpone drop  ; immediate compile-only

: exitcase  ( n f -- )
  postpone exit  postpone then  ; immediate compile-only

  \ Usage example

  \ ----
  \ : say0 ." nul"  ;
  \ : say1 ." unu"  ;
  \ : say2 ." du"  ;
  \ : say-other ." alia"  ;

  \ : test  ( n -- )
  \   thiscase 0 = ifcase  say0  exitcase
  \   thiscase 1 = ifcase  say1  exitcase
  \   thiscase 2 = ifcase  say2  exitcase
  \            othercase say-other  ;
  \ ----

Fixed -suffix.

2016-03-24

Removed old fig-Forth loop indexes from the library.

Splitted the memory, benchmarking and locals library files.

Modified the license. Updated and completed all of the source file headers.

Added ?repeat.

2016-03-25

Splitted the numbers and printing library files. Renamed some library files to reduce the number of sections. Now there are 144 library files.

Extracted the code related to modules from the compilation library file. There are four implementations of modules. Renamed some words in order to prevent name clashes, or for clarity, and documented all of them.

Modified and factored wid>name: now it returns a name token, after >name and similar words, not its address:

: (wid>name)  ( wid -- a )  [ 2 cells ] literal +  ;

  \ doc{
  \
  \ (wid>name)  ( wid -- a )
  \
  \ Return the address _a_ which holds the _nt_ of _wid_ (or
  \ zero if the word list has no associated name).
  \
  \ }doc

: wid>name  ( wid -- nt|0 )  (wid>name) @  ;

  \ doc{
  \
  \ wid>name  ( wid -- nt|0 )
  \
  \ Return the _nt_ of _wid_ (or zero if the word list has no
  \ associated name).
  \
  \ }doc

Simplified the storage and printing of the version number, by making release candidates start from 1 instead of 0.

2016-03-31

Added a new random number generator and updated the benchmarks:

( cgm-random )

  \ Random Number Generator by C. G. Montgomery

  \ 2015-12-13: found here:
  \ http://web.archive.org/web/20060707001752/http://www.tinyboot.com/index.html
  \
  \ 2016-03-31: adapted to Solo Forth.

need rng-benchmark

2variable rloc  $111 rloc !  \ seed with nonzero

: cgm-rnd  ( -- u )
  rloc 2@ $61BF um* rot 0 d+ over rloc 2!  ;
  \ good values for 16-bit systems: 61BF 62DC 6594 6363 5E9B 65E8

: cgm-random  ( n -- 0..n-1 )  cgm-rnd um* nip  ;

: cgm-rng-benchmark  ( -- )
  s" C. G. Montgomery $61BF" ['] cgm-random rng-benchmark  ;

' rng-benchmark2 ' rng-benchmark defer!

cgm-rng-benchmark

' rng-benchmark1 ' rng-benchmark defer!

cgm-rng-benchmark

In the following benchmarks, a "cycle" is a loop of 49152 iterations. In every iteration, a random pixel is plot on the screen. The "Cycles" column shows how many cycles were done before the number of pixels didn't change anymore. Benchmarks that require more than one cycle have an additional entry with the data of their first cycle.

Results of the 16-bit versions of random:

Code Pixels Time per cycle in frames (and seconds) Cycles
C. G. Montgomery $5E9B 49151 (099%) 06917 (138 s) 11
C. G. Montgomery $5E9B 30985 (063%) 06917 (138 s) first only
C. G. Montgomery $61BF 49152 (100%) 06916 (138 s) 11
C. G. Montgomery $61BF 31024 (063%) 06916 (138 s) first only
C. G. Montgomery $62DC 49152 (100%) 06917 (138 s) 12
C. G. Montgomery $62DC 30964 (063%) 06916 (138 s) first only
C. G. Montgomery $6363 49152 (100%) 06917 (138 s) 11
C. G. Montgomery $6363 30917 (062%) 06917 (138 s) first only
C. G. Montgomery $6594 49151 (099%) 06917 (138 s) 10
C. G. Montgomery $6594 31009 (063%) 06916 (138 s) first only
C. G. Montgomery $65E8 49152 (100%) 06917 (138 s) 12
C. G. Montgomery $65E8 31006 (063%) 06917 (138 s) first only
DX-Forth 49152 (100%) 17733 (354 s) 12
DX-Forth 31076 (063%) 17734 (354 s) first only
Gforth 31189 (063%) 09746 (194 s) 1
J. E. Rickenbacker 08149 (016%) 18458 (369 s) 1
J.M. Lazo 12637 (025%) 03349 (066 s) 1
Jupiter ACE manual 05937 (012%) 07652 (153 s) 1
Leo Brodie 20818 (042%) 09150 (183 s) 1
lina 23945 (048%) 09179 (183 s) 1
Milos Bazelides 28465 (057%) 03316 (066 s) 1
Spectrum Forth-83 05194 (010%) 08741 (174 s) 1
Tetris for terminals 02038 (004%) 14200 (284 s) 1
vForth 27448 (055%) 14806 (296 s) 10
vForth 20804 (042%) 14806 (296 s) first only
Z88 CamelForth 05496 (011%) 15683 (313 s) 1
Z80 Heaven 32599 (066%) 03371 (067 s) 1

Results of the 8-bit versions of rnd:

Code Pixels Time per cycle in frames (and seconds) Cycles
Joe Wingbermuehle 49145 (099%) 01076 (021 s) 29
Joe Wingbermuehle 25234 (051%) 01075 (021 s) first only
Milos Bazelides 1 00096 (000%) 01047 (020 s) 1
Milos Bazelides 2 00096 (000%) 01048 (021 s) 1
Z80 Heaven 00096 (000%) 01055 (021 s) 1