Solo Forth development history in 2015-10

Description of the page content

Solo Forth development history in 2015-10.

Tags:

2015-10-03

Added Leo Brodie's doer to the library.

( doer )

  \ Credits:
  \ Code adapted from PFE.
  \ Original code by Leo Brodie, 1983,
  \ published in _Thinking Forth_, Appendix A. Public domain.

: doer-noop ;

: doer  ( "name" -- )
  \ Define a word whose behaviour is vectorable.
  create  ['] doer-noop cfa>pfa ,
  does>  ( pfa ) @ >r ;

: (make)
  \ Stuff the address of further code into the parameter field
  \ of a doer word.
  r> dup cell+ dup cell+
    ( a1 a2 a2 )
    \ a1 = address of an optional continuation after `;and`,
    \      or zero
    \ a2 = address of the doer word
    \ a3 = address of the code to associate the doer word with
  swap @ cfa>pfa !
    \ Get the pfa of the doer word and store the code address
    \ into it.
  @ ?dup if  >r  then ;
    \ Manage the optional continuation after `;and`.

variable >;and
  \ Hold the address of optional continuation pointer.

: make
  \ Used interpretively:
  \   make doer-name forth-code ;
  \ Or inside a definition:
  \   : definition  make doer-name forth-code  ;
  compiling? if     postpone (make)  here >;and ! 0 ,
             else   here ' cfa>pfa ! ]  then  ; immediate

: ;and  ( -- )  postpone exit  here >;and @ !  ; immediate
  \ Allow continuation of the "making" definition.

: undo  ( "name" -- )  ['] doer-noop cfa>pfa  ' cfa>pfa ! ;
  \ Make the doer word "name" safe to execute.

2015-10-05

First working version of the Forth-94 Memory-Allocation Word Set, adapted from code written by Gordon Charlton in 1994. The unique error code has been changed to the specific codes of Forth-2012.

Fixed needed. The trailing and leading spaces of the string, sometimes used to prevent name clashes, had to be removed before undefined?:

: needed  ( ca len -- )
  2dup save-string -trailing -leading undefined?
    \ a copy of the string is used because `undefined?`
    \ converts it to uppercase
  if  reneeded  else  2drop  then  ;

The fix of needed required -leading to be defined in the kernel.

  _colon_header minus_leading_,'-LEADING'

; doc{
;
; -leading  ( ca1 len1 -- ca2 len2 )
;
; Adjust the start and length of a string to suppress the
; leading blanks.
;
; }doc

  dw b_l_,skip_
  dw semicolon_s_

Added chars to the kernel.

Started adapting Tetris for terminals, written on 1994-05-05 by Dirk Uwe Zoller in ANS Forth. It will be included in the library as the second sample game. A version of Siderator was included some time ago.

2015-10-06

Substituted bl skip in parse-name with -leading.

Removed all the code related to the old parsing method with a trailing null word. That code was already commented out.

Moved word from the kernel to the library. It's not needed anymore with the new parsing method, but it could be useful for backward compatibility.

; ----------------------------------------------
  _colon_header word_,'WORD'

; doc{
;
; word  ( c "<c...>text<c>" -- ca )
;
; c = delimiter char
;
; Skip leading _c_ delimiters from the input stream.  Parse the
; next text characters from the input stream, until a delimiter
; _c_ is found, storing the packed character string beginning at
; _ca_, as a counted string (the character count in the first
; byte), and with one blank at the end (not included in the count).
;
; Standard: Forth-94.
;
; }doc

  ; Credits:
  ; after Z88 CamelForth

;   dup  source >in @ /string   ( c c a n )
;   dup >r   rot skip           ( c a' n' )
;   over >r  rot scan           ( a" n" )
;   dup if char- then           \ skip trailing delimiter
;   r> r> rot -   >in +!        \ update >in offset
;   tuck -                      ( a' n )
;   here place                  ( )
;   here                        ( a )
;   bl over count + c! ;        \ append trailing blank

  dw dup_,stream_       ; ( c c ca len )
  dw dup_,to_r_         ; ( c c ca len ) ( R: len )
  dw rot_,skip_         ; ( c ca1 len1 ) ( R: len )
  dw over_,to_r_       ; ( c ca1 len1 ) ( R: len ca1 )
  dw rot_,scan_         ; ( ca2 len2 ) ( R: len ca1 )
  dw dup_
  dw zero_branch_,word.skip
  dw char_minus_
word.skip:
  dw from_r_,from_r_    ; ( ca2 len2 ca1 len )
  dw rot_,minus_        ; ( ca2 ca1 len3 )
  dw to_in_,plus_store_  ; ( ca2 ca1 )
  dw tuck_,minus_       ; ( ca1 len4 )
  dw here_,place_
  dw here_
  dw b_l_,over_,count_,plus_,c_store_ ; append trailing blank
  dw semicolon_s_

( word )

  \ Credits:
  \ Code from Z88 CamelForth.

: word  ( c "<c...>text<c>" -- ca )
  dup  stream                 ( c c ca len )
  dup >r   rot skip           ( c ca' len' )
  over >r  rot scan           ( ca" len" )
  dup if  char-  then         \ skip trailing delimiter
  r> r> rot -   >in +!        \ update `>in`
  tuck -                      ( ca' len )
  here place  here            ( ca )
  bl over count + c!  ;       \ append trailing blank

  \  doc{
  \
  \  word  ( c "<c...>text<c>" -- ca )
  \
  \  c = delimiter char
  \
  \  Skip leading _c_ delimiters from the input stream.  Parse
  \  the next text characters from the input stream, until a
  \  delimiter _c_ is found, storing the packed character
  \  string beginning at _ca_, as a counted string (the
  \  character count in the first byte), and with one blank at
  \  the end.  byte), and with one blank at the end (not
  \  included in the count).
  \
  \  Standard: Forth-94.
  \
  \  }doc

Removed from the library all words that create numerical prefixes using the fig-Forth's width trick. They don't work anymore with the current kernel, and most of them are unnecessary because the latest versions of >number and number? already recognize them.

( c>hex )

  \ Credits:
  \ Code adapted from lina.

hex

: c>hex  ( c -- n )  upper 30 - dup 9 > 7 * +  ;
  \ Convert a character to its hexadecimal value.

decimal

( '. ) \ character prefix

  \ Credits:
  \ Code adapted from lina.

hex  width @ 1 width !

: '.  ( -- n )
  \ leave ascii character; example: 'a leaves 0x41
  here 2+ c@ postpone literal  ; immediate

width ! decimal

( $.. $.... ) \ hex prefixes

  \ Credits:
  \ Code adapted from lina.

need c>hex

hex width @  1 width !

: $..  ( -- n )
  \ leave hex number; example: $0a leaves 0x0A
  here 2+ c@ c>hex 10 * here 3 + c@ c>hex +
  postpone literal  ; immediate

: $....  ( -- n )
  \ leave 16-bit hex number; example: $0aff leaves 0x0AFF
  0 here 6 + here 2+ do 10 * i c@ c>hex + loop
  postpone literal  ; immediate

width ! decimal

( 0x.. 0x.... )  \ hex prefixes

  \ Credits:
  \ Code adapted from lina.

need c>hex

hex  width @ 2 width !

: 0x..  ( -- n )
  \ Leave hex number; example: 0x0A.
  here 3 + c@ c>hex 10 * here 4 + c@ c>hex +
  postpone literal  ; immediate

: 0x....  ( -- n )
  \ Leave hex number; example: 0x0AFF.
  0 here 7 + here 3 + do 10 * i c@ c>hex + loop
  postpone literal  ; immediate

width ! decimal

( #... #..... ) \ hex prefixes

  \ Credits:
  \ Code adapted from lina.

need c>hex

width @  1 width !

: #...  ( -- n )
  \ leave decimal number
  here 2+ c@ c>hex 10 * here 3 + c@ c>hex +
  postpone literal  ; immediate

: #.....  ( -- n )
  \ leave 16-bit decimal number
  0 here 6 + here 2 + do 10 * i c@ c>hex + loop
  postpone literal  ; immediate

width !

Adapted begin-stringtable from the stt module of Forth Foundation Library.

( begin-stringtable end-stringtable )

  \ Credits:
  \ Code adapted from Forth Foundation Library (stt module).

: begin-stringtable  ( "name" -- stringtable-sys )
  \ Start a named stringtable definition.
  create  here ( a1 ) cell allot here  ( a1 a2 )
    \ stringtable-sys:
    \   a1 = pointer (address of address) to the strings index
    \   a2 = address of the compiled strings
  does> ( n -- ca len )
    \ Return the nth string.
    ( n pfa )  @ swap cells + @ count  ;

: end-stringtable  ( stringtable-sys -- )
  \ End the stringtable definition.
  \ stringtable-sys:
  \   a1 = pointer (address of address) to the strings index
  \   a2 = address of the compiled strings
  ( a1 a2 )
  here rot !   \ set the index
  here swap  ( a3 a2 )
  begin  2dup <>  while
    dup ,   \ store the start of the string in the index
    count chars +  \ move to the next string
  repeat  2drop  ;

  \ Usage example:
  \
  \ begin-stringtable esperanto-number
  \   s" nulo" s,  s" unu" s,  s" du" s,  s" tri" s,
  \ end-stringtable
  \ 0 esperanto-number type
  \ 3 esperanto-number type

The original code provides a specific word to compile the strings of the table, +". In Solo Forth it could be defined simply: : +" ( "tex<quote>" -- ) [char] " parse s, ;. But it's more versatile to use s" and s, directly.

2015-10-07

Finished the improved port of tt (Tetris for Terminals), with configurable key sets.

Fixed error: error-pos was not updated when blk contained zero, what sometimes caused where to show the old value.

Finished the documentation of sm/rem and fm/mod.

Adapted the following words from Galope and included them in the library: less-of, greater-of, between-of, within-of, default-of and or-of.

Wrote cvalue and cto in the library, after the alternative non-standard version of 2value and 2to.

Started the port of Towers of Hanoi bundled with kForth.

2015-10-08

Moved the fig-Forth user variable r# to the library; it's used only by the editor.

2015-10-09

Started the implementation of the Forth-94 and Forth-2012 exception and exception extension word sets: abort, abort", catch and throw.

Fixed decode: slit was missing from the special cases.

Wrote an alternative definition of ." without interpretation semantics; this saves four bytes.

Benchmarked the current version of number-base and three alternatives:

( number-base-bench )

: number-base-1  ( ca len -- ca' len' n )
  \ This is the current version defined in the kernel.
  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 @  ;

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

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

-->

( number-base-bench )

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

need frames@  need frames0  defer (number-base)

: (number-base-bench)  ( n cfa -- )
  ['] (number-base) defer!
  frames0  0 do  s" 000" (number-base) drop 2drop  loop
  frames@ d. cr  ;

: number-base-bench  ( n -- )
  dup ['] number-base-1 (number-base-bench)
  dup ['] number-base-2 (number-base-bench)
  dup ['] number-base-3 (number-base-bench)
      ['] number-base-4 (number-base-bench) ;

  \ Times Frames (1 frame = 50th of second)
  \ ----- -----------------------------------
  \          1    2    3    4
  \       ---- ---- ---- ----
  \ 01000   73   75   74   69
  \ 10000  732  744  736  686
  \ 32000 2343 2382 2367 2194

number-base-4 is a bit faster and does not need more space, so it substitutes the current version.

2015-10-10

Fixed error>line, the word that converts an ordinal error number to its line offset. I knew the code was buggy from the start. Finally I've coded a right algorithm:

  \ XXX OLD -- buggy

: error>line  ( n1 -- n2 )
  error>ordinal dup 1+ 1 do  i 16 mod 0= abs +  loop  ;

  \ XXX NEW -- fixed

: error>line  ( n1 -- n2 )
  error>ordinal dup >r
  begin
    dup dup 16 / - r@ <>  while  1+
  repeat  rdrop  ;

error>line and error>ordinal may be moved to the library, because they are needed only when message prints complete messages, what is useful mainly for debugging. Most programs don't need this feature.

2015-10-11

Modified parsed: it doesn't add 1 to the count anymore; now it does just >in +!.

2015-10-13

Factored (smudge) from smudge, in order to choose any name field, as required by the port of privatize from pForth.

Fixed (find-name): the smudge bit was not included in the check, thus words with the smudge bit set were found!

( nfa<nfa )

: nfa<nfa  ( nfa1 -- nfa2 )  nfa>lfa @n  ;
  \ Get the previous _nfa2_ from _nfa1_.

( privatize )

  \ Credits:
  \ Code adapted from pForth.

  \ ____
  \
  \ @(#) private.fth 98/01/26 1.2
  \ PRIVATIZE
  \
  \ Privatize words that are only needed within the file
  \ and do not need to be exported.

  \ Usage:
  \    PRIVATE{
  \    \ Everything between PRIVATE{ and }PRIVATE
  \    \ will become private.
  \    : FOO ;
  \    : MOO ;
  \    }PRIVATE
  \    : GOO   foo moo ;  \ can use foo and moo
  \    PRIVATIZE          \ smudge foo and moo
  \    ' foo              \ will fail

  \ Copyright 1996 Phil Burk
  \
  \ 19970701 PLB Use unsigned compares for machines with
  \ "negative" addresses.
  \ ____

need abort"  need nfa<nfa

variable private-start  variable private-stop

: private{  ( -- )
  latest private-start !  private-stop off  ;

: }private  ( -- )
  private-stop @ abort" Extra }private"
  latest private-stop !  ;

: privatize  ( -- )
  \ Hide all words between `private{` and `}private`.
  private-start @ 0= abort" Missing private{"
  private-stop dup @ 0= abort" Missing }private"
  begin   dup private-start @ u>
  while   dup (smudge) nfa<nfa
  repeat  drop  private-start off  private-stop off  ;

Added behead, clearer than (smudge) and definitive:

: behead  ( nfa -- )  0 swap c!n  ;
  \ Store zero at _nfa_, thus making the definition impossible
  \ to find.

Tested the three versions of abort". The one from DZX-Forth uses less memory, because ," has already been included in the kernel, as a factor of .".

( abort" )

  \ Version adapted from DZX-Forth:
  \ XXX code: 38 bytes
  \ XXX word with 4-char abort message: 11 bytes.

[defined] abort-message ?\ 2variable abort-message
  \ XXX TMP

: (abort")  ( n -- )
  r> count rot if  abort-message 2! -2 throw  then + >r  ;

: abort"  ( compilation: "ccc<quote>" -- )
  postpone (abort") ,"  ; immediate

( abort" )

  \ Version adapted from hForth:

[defined] abort-message ?\ 2variable abort-message
  \ XXX TMP
  \ XXX code: 38 bytes
  \ XXX word with 4-char abort message: 25 bytes.

: (abort")  ( ca len -- )  abort-message 2! -2 throw  ;

: abort"  ( x "text<quote>" -- )
  postpone s"
  postpone rot   ( ca len x )
  postpone if    postpone (abort")
  postpone else  postpone 2drop  postpone then
  ;  immediate

( abort" )

  \  Version adapted from Gforth:

  \ XXX code: 62 bytes with `csliteral`; 34 bytes per se.
  \ XXX word with 4-char abort message: 17 bytes.

need csliteral

\ variable abort-message

: (abort")  ( ca len -- )  abort-message ! -2 throw  ;

: abort"  ( n "text<quote>" -- )
  postpone if
  [char] " parse postpone csliteral postpone (abort")
  postpone  then  ; immediate

2015-10-14

Removed the conditional compilation for the exception word set. Beside adding catch and throw it affected ?error, error and abort (abort" didn't existed, it has been recently included in the library, defined with throw). Code before removing the conditional compilation:

; ----------------------------------------------
  _colon_header question_error_,'?ERROR'

; doc{
;
; ?error  ( wf n -- )
;
; Issue error _n_ if the boolean flag _wf_ is `true`.
;
; }doc

if 1 ; exception_wordset

  dw and_,throw_
  dw semicolon_s_

else

  ; XXX OLD -- fig-Forth

  dw swap_
  dw zero_branch_,question_error.no_error
  dw error_
  dw semicolon_s_

question_error.no_error:
  dw drop_
  dw semicolon_s_

endif

; ----------------------------------------------
  _colon_header error_,'ERROR'

if 1 ; exception_wordset

; doc{
;
; error  ( n -- )
;
; Save the error number into `error-number`, and the current
; block and line into `error-pos`, to be used by `where`.  Issue
; error _n_ and restart the system.

; ----
; : error  ( n -- )
;   dup error-number !
;   >in @ blk @ error-pos 2!
;   dup -1 = if  (abort)  then
;   dup -2 = if  abort-message 2@ type (abort)  then
;   parsed-name 2@ type ." ? " message  (abort)  ;
; ----

; }doc

  dw dup_,error_number_,store_ ; save the error number
  dw to_in_,fetch_,blk_,fetch_,error_pos_,two_store_

  dw dup_
  _literal -1
  dw equals_
  dw question_branch_,paren_abort_pfa
  ; No return from `(abort)`.

  dw dup_
  _literal -2
  dw equals_
  dw zero_branch_,error.message
  dw space_,abort_message_,two_fetch_,type_,paren_abort_
  ; No return from `(abort)`.

error.message:
  dw parsed_name_,two_fetch_,type_ ; last parsed word
  dw paren_dot_quote_
  _string '? '
  dw message_,paren_abort_
  ; No return from `(abort)`.

  ; XXX FIXME -- the end of `error` will not be recognized by
  ; `decode`.

  _two_variable_header abort_message_,"ABORT-MESSAGE"

  dw 0,0

else

; doc{
;
; error  ( n -- )
;
; Issue error message _n_ and restart the system.  Save the
; error number into `error-number`, and the current block and
; line into `error-pos`, to be used by `where`.
;
; This word is a modified version of fig-Forth's `error`.

; ----
; : error  ( n -- )
;   dup error-number !
;   >in @ blk @ error-pos 2!
;   parsed-name 2@ type ." ? " message
;   sp0 @ sp!  quit  ;
; ----

; }doc


  dw dup_,error_number_,store_ ; save the error number
  dw to_in_,fetch_,blk_,fetch_,error_pos_,two_store_

  ; XXX OLD
;  dw warnings_,fetch_,zero_less_than_ ; custom error routine?
;  dw question_branch_,paren_abort_pfa ; if so, branch to it

error.message:
  dw parsed_name_,two_fetch_,type_ ; last parsed word
  dw paren_dot_quote_
  _string '? '
  dw message_
  dw sp0_,fetch_,sp_store_
  dw quit_

endif

; ----------------------------------------------
if 1 ; exception_wordset
  _colon_header catch_,'CATCH'

; doc{

; catch  ( cfa -- 0 | err# )

; Push an exception frame on the exception stack and then
; execute _cfa_ (as with `execute`) in such a way that control
; can be transferred to a point just after `catch` if `throw` is
; executed during the execution of _cfa_.
;
; If the execution of _cfa_ completes normally (i.e., the
; exception frame pushed by this `catch` is not popped by an
; execution of `throw`) pop the exception frame and return zero
; on top of the data stack, above whatever stack items would
; have been returned by the execution of _cfa_. Otherwise, the
; remainder of the execution semantics are given by `throw`.
;
; Standard: Forth-94 (EXCEPTION), Forth-2012 (EXCEPTION).
;
;----
; : catch  ( xt -- exception# | 0 )
;   sp@ >r          ( cfa ) \ save data stack pointer
;   catcher @ >r    ( cfa ) \ save previous catcher
;   rp@ catcher !   ( cfa ) \ set current catcher
;   execute         ( )     \ `execute` returns if no `throw`
;   r> catcher !    ( )     \ restore previous catcher
;   r> drop         ( )     \ discard saved stack pointer
;   0  ;            ( 0 )   \ normal completion, no error
;----
; }doc

  ; Credits:
  ; Code from DZX-Forth and MPE Forth for TiniARM.

  dw sp_fetch_,to_r_ ; save data stack pointer
  dw catcher_,fetch_,to_r_ ; save previous catcher
  dw rp_fetch_,catcher_,store_ ; set current catcher
  dw execute_ ; `execute` returns if no `throw`
  dw from_r_,catcher_,store_  ; restore error frame
  dw from_r_,drop_ ; discard saved stack pointer
  _literal 0  ; normal completion, no error
  dw semicolon_s_

endif

; ----------------------------------------------
if 1 ; exception_wordset
  _colon_header throw_,'THROW'

  ; XXX UNDER DEVELOPMENT

if 0

  ; Version from eForth:

; throw  ( err# -- err# )
; reset system to current local error frame an update error flag.

  dw catcher_,fetch_,rp_store_        ; restore return stack
  dw from_r_,catcher_,store_          ; restore exception frame
  dw from_r_,swap_,to_r_,sp_store_    ; restore data stack
  dw drop_,from_r_
  dw semicolon_s_

endif

if 0

  ; Version from hForth and MPE Forth for TiniARM.
  ; Comments from MPE Forth for TiniARM.

  ; : throw  ( ??? exception# -- ??? exception# )
  ;   ?dup if           ( exc# )
  ;     catcher @ rp!   ( exc# )      \ restore previous return stack
  ;     r> catcher !    ( exc# )      \ restore previous catcher
  ;     r> swap >r      ( saved-sp ) ( R: exc# )
  ;     sp! drop r>     ( exc# )      \ restore stack
  ;     \ Return to the caller of `catch` because return stack is
  ;     \ restored to the state that existed when `catch` began
  ;     \ execution.
  ;   then  ;

  dw question_dup_,zero_branch_,throw.end
  dw catcher_,fetch_,rp_store_          ; restore previous return stack
  dw from_r_,catcher_,store_            ; restore previous exception frame
  dw from_r_,swap_,to_r_
  dw sp_store_,drop_,from_r_            ; restore data stack

  ; Return to the caller of `catch` because return stack is
  ; restored to the state that existed when `catch` began
  ; execution.

throw.end:
  dw semicolon_s_

endif

if 1

  ; Version from DZX-Forth:

  ; XXX TODO -- Comments from MPE Forth for TiniARM.

; throw  ( n -- )
; ?dup if
;   catcher @ ?dup 0= if  error  then
;   rp! r> catcher ! r> swap >r sp! drop r>
; then  ;

  dw question_dup_
  dw zero_branch_,throw.end
  dw catcher_,fetch_
  dw question_dup_,zero_equals_
  dw zero_branch_,throw.catcher
  dw error_
  ; No return from `error`.

throw.catcher:
  dw rp_store_
  dw from_r_,catcher_,store_
  dw from_r_,swap_,to_r_
  dw sp_store_
  dw drop_,from_r_
throw.end:
  dw semicolon_s_

endif

endif

; ----------------------------------------------

if 1 ; exception_wordset

  _colon_header paren_abort_,'(ABORT)'

  dw sp0_,fetch_,sp_store_
  dw boot_
  dw quit_

  _colon_header abort_,'ABORT'

  _literal -1
  dw throw_
  dw semicolon_s_

else

  _colon_header paren_abort_,'(ABORT)'

  dw abort_
  dw semicolon_s_

  _colon_header abort_,'ABORT'

  dw sp0_,fetch_,sp_store_
  dw boot_
  dw quit_

endif


Substituted ?error with the clearer and more versatile ?throw:

; ----------------------------------------------
  _colon_header question_throw_,'?THROW'

; doc{
;
; ?throw  ( f n -- )
;
; Perform a `throw` of value _n_ if the boolean flag _f_ is
; non-zero.

; ----
; : ?throw  ( f n -- )
;   swap if  throw  else  drop  then  ;
; ----
; }doc

  dw swap_
  dw question_branch_,throw_pfa
  dw drop_
  dw semicolon_s_

Renamed sign? to skip-sign?, after MPE Forth for TiniARM's skip-sign.

Benchmarked the three considered versions of number?.

( number?-bench )

need frames@  need frames0

: empty-stack  ( -- )  sp0 @ sp!  ;

defer num?

: number?-bench  ( n -- )
  frames0  0 do
    s" " num?  s" 12345" num?   s" 12345." num?
    s" -12345" num?  s" -12345." num?  empty-stack
  loop  frames@ cr d.  ;

: benchs  ( -- )
  100 number?-bench 1000 number?-bench 10000 number?-bench  ;

                                    \ Version of `number?`
    ' number? ' num? defer! benchs  \ pForth
  ' c.number? ' num? defer! benchs  \ CamelForth
' dzx-number? ' num? defer! benchs  \ DZX-Forth

  \ Note: The CamelForth code is for single numbers only.
  \       The DZX-Forth code is a bit obfuscated.

  \ Times Frames (1 frame = 50th of second)
  \ ----- -----------------------------------
  \       pForth CamelForth DZX-Forth
  \       ------ ---------- ---------
  \ 00100    256        257       259
  \ 01000   2559       2565      2594
  \ 10000  25591      25652     25933

Speed differences are unimportant in this case, but since the version from DZX-Forth is less legible and the version from CamelForth is limited, the version from pForth is chosen.


  \ Version adapted from pForth:

: number?   ( ca len -- 0 | n 1 | d 2 )
  dup 0= if  2drop 0 exit  then
  base @ >r number-base base !
  skip-sign? >r
  dpl on  0 0 2swap >number dup
  if
    1 = swap c@ [char] . =  and
    if    r@ ?dnegate  dpl off  2
    else  2drop 0  then
  else
    2drop d>s r@ ?negate  1
  then  rdrop  r> base !  ;

  \ Version adapted from DZX-Forth:

: number?  ( ca len -- d tf | ff )
  dup 0= if  2drop false exit  then
  base @ >r  number-base base !
  skip-sign? >r
  0 0 2swap ?dup if
    >number dpl on
    dup if  1- over c@ [char] . - or dpl off  then
    while then
    r> 2drop 2drop false
  else
    drop r> ?dnegate true
  then  r> base !  ;

  \ Version adapted from CamelForh (single numbers only):

: number?  ( ca len -- n tf | ff )

  base @ >r  number-base base !
  0 0 2swap
  skip-sign? >r  >number nip
  if    2drop rdrop false
  else  r> if negate then  true
  then  r> base !  ;

But double numbers are recognized only when the decimal point is at the end, and dpl is just a flag. This behaviour follows the Forth-94 and Forth-2012 standards, but an improved version is desirable, after fig-Forth: capable of recognizing the decimal point anywhere in the string, and using dpl to hold the number of digits after the decimal point.

( number? )

  \ XXX UNDER DEVELOPMENT
  \ Improved alternative to `number?`.

: solo-number?   ( ca len -- 0 | n 1 | d 2 )
  dup 0= if  2drop 0 exit  then
  base @ >r number-base base !
  skip-sign? >r
  0 0 2swap  dpl on
  begin
    >number dup
  while
    over c@ [char] . <>  \ not a decimal point?
    dpl @ 0< 0=  or  \ or not the first decimal point?
    if  2drop 2rdrop 0 exit  then
    dup 1- dpl !  1 /string
  repeat  2drop  dpl @ 0<
  if    d>s r> ?negate  1
  else  r> ?dnegate  2  then  r> base !  ;

Updated benchmarks:

  \ Times Frames (1 frame = 50th of second)
  \ ----- -----------------------------------
  \       pForth CamelForth DZX-Forth Solo Forth
  \       ------ ---------- --------- ----------
  \ 00100    256        257       259        266
  \ 01000   2559       2565      2594       2658
  \ 10000  25591      25652     25933      26581

A modified benchmark with strings whose conversion fail:

( number?-bench )

need frames@  need frames0

: empty-stack  ( -- )  sp0 @ sp!  ;

defer num?

: number?-bench  ( n -- )
  frames0  0 do
    s" " num?  s" 123x45." num?   s" 12345.999x" num?
    s" -12345.x" num?  s" -12345.999x" num?
    s" -12345.000.000" num?
    empty-stack
  loop  frames@ cr d.  ;

: benchs  ( -- )
  100 number?-bench 1000 number?-bench 10000 number?-bench  ;

' solo-number? ' num? defer! benchs

  \ Times Frames (1 frame = 50th of second)
  \ ----- -----------------------------------
  \ 00100   416
  \ 01000  4165
  \ 10000 41649

The improved version is slower and occupies 26 bytes more, but the differences are unimportant and the new features are useful. I keep it as default. Both versions can be chosen with conditional compilation in the kernel. Eventually number? may be deferred and one of the definitions moved to the library.

Added some new words and tools to the library, adapted from Galope: xstack, hunt, column, row, at-x, at-y, random-range, prefix?, -prefix, suffix?, -suffix, d>str, ud>str, times-execute, chop.

2015-10-15

Finished porting the IsForth's control structure case:.

( options[ )

  \ Credits:
  \ `options[` is a port of IsForth's `case:`.

variable (default-option)
  \ default option cfa

variable #options
  \ number of compiled options

: default-option ( "name" -- )  ' (default-option) !  ;
  \ Set the default option.
  \ It can go anywhere inside a the options statement.

: (options)  ( i*x x -- j*x )

  \ Note: in the original IsForth code this word (called
  \ `docase`) is written in x86 assembler. I rewrote it from
  \ scratch, without investigating the assembler code.

  \ x = option to search for

  false swap  ( false x ) \ default flag returned by the loop
  r> dup cell+ dup cell+  ( false x a1 a2 a3 )
  \ a1 = address of the exit point
  \ a2 = address of the default option cfa
  \ a3 = address of the number of options
  rot @ >r    ( false x a2 a3 ) \ set the exit point
  swap >r     ( false x a3 ) ( R: a2 ) \ save a2
  dup cell- swap @  ( false x a4 n )
  \ a4 = address of the first compiled option minus two cells
  \ n = number of compiled options

-->

( options[ )

  0 do
    [ 2 cells ] literal + 2dup @ =  ( false x a5 f )  \ match?
    \ a5 = address of the current compiled option
    if
        nip nip cell+ perform
        exhaust true 0 0  then
  loop  ( f x1 x2 )  2drop
  if    rdrop       \ discard the default option
  else  r> perform  \ execute the default option
  then  ;   -->

( options[ )

: options[        ( -- a1 a2 a3 )

  \ a1 = address of exit point
  \ a2 = address of default option cfa
  \ a3 = address of number of options

  (default-option) off        \ assume no default option
  #options off                \ number of options is 0 so far
  compile (options)           \ compile run time handler
  >mark >mark >mark  ( a1 a2 a3 )
  postpone [  ; immediate

: option  ( x "name" -- )
  \ Compile an option _x_ to execute the word _name_.
  ,                           \ compile the option
  ' ,                         \ get cfa and compile it too
  1 #options +!  ;

: ]options  ( a1 a2 a3 -- )
  \ a1 = address of exit point
  \ a2 = address of default option cfa
  \ a3 = address of number of options
  #options @ swap !           \ store number of options
  (default-option) @ swap !   \ store default option cfa
  >resolve                    \ store exit point
  ]  ;

( options[-test )

: o1 ." option 1" ;  : o2 ." option 2" ;  : o3 ." option 3" ;

: test  ( c -- )
  options[
    char a option o1  char b option o2  char c option o3
  ]options  ;

: o0 ." default" ;

: testd  ( c -- )
  options[
    char a option o1  char b option o2  char c option o3
    default-option o0
  ]options  ;

Wrote 2, in the kernel. Updated 2constant accordingly. Substituted the final part of 2variable with a branch to the same code in 2,. At the end only 7 bytes are used.

Wrote wdump, an alternative to dump that shows 16-bit values, useful for inspecting the code fields.

( wdump )

need break-key?  need 16hex.

[defined] bs ?\ : bs  ( -- )  8 emit  ;

: wdump  ( a n -- )
  \ Show the contents of _n_ cells starting from _a_.
  0
  \ XXX TODO use `?do` instead of `if` when available
  2dup <> if
    do
      i 4 mod 0= if  cr dup 16hex. space  then  \ show address
      dup @ 16hex. cell+
      break-key? ?exhaust
    loop
  else  2drop  then  drop  ;

2015-10-16

Improved (options). Now it's smaller and faster:

: (options)  ( i*x x -- j*x )

  \ x = option to search for

  false swap  ( false x ) \ default flag returned by the loop
  r> dup @ >r   \ set the new exit point
  cell+ dup >r  \ save the address of the default option cfa
  dup cell+ @  ( false x a n )
  \ a = address of the first compiled option minus two cells
  \ n = number of compiled options

  0 do
    [ 2 cells ] literal + 2dup @ =  ( false x a' f )  \ match?
    \ a' = address of the current compiled option
    if  nip nip cell+ perform  exhaust true 0 0  then
  loop  ( f x1 x2 )  2drop

  if    rdrop       \ match, so discard the default option
  else  r> perform  \ no match, so execute the default option
  then  ;   -->

Changed the order of the parameters of emits. Now the count is the second one.

Wrote ?? without evaluate (not implemented yet):

( ?? )

  \ Credits:
  \ Code adapted from Galope.
  \ Original code by Neil Bawd, presented at FORML 1986.
  \ This version does not use `evaluate`.

: ??  ( Compilation: "name" -- ) ( Runtime: f -- )
  postpone if
  parse-name find-name 0= -13 ?throw compile,
  postpone then
  ;  immediate

But a simpler is possible:

: ??  ( f -- )  0= if  r> cell+ >r  then  ;

Improved located: now the string searched for is delimited with spaces. This prevents name clashes and makes it unnecessary to add the spaces explicitly in risky cases, for example s" j " needed.

: delimited  ( ca1 len1 -- ca2 len2 )
  dup 2+ dup allocate-string swap  ( ca1 len1 ca2 len2 )
  2dup blank  2dup 2>r drop char+ smove 2r>  ;
  \ Add a leading space and trailing space to the given string.

: located  ( ca len -- screen | false )
  delimited  last-locatable @ 1+  first-locatable @
  default-first-locatable @  first-locatable !
  do  0 i line>string 2over
    contains if  2drop i unloop exit  then
    \ break-key? ?exhaust
    \ XXX TODO -- `break-key?` is not in the kernel
  loop  2drop false  ;  -->
  \ Locate the screen that contains the name _ca len_
  \ (but delimited with spaces at both sides) in its first line.
  \ If not found, return zero. The search is case-sensitive.

Implemented [needed]. It allows selective compilation depending on the word specified by need or needed:

2variable needed-word

: [needed]  ( "name" -- f )
  parse-name needed-word 2@  compare 0=  ; immediate

: [unneeded]  ( "name" -- f )
  postpone [needed] 0=  ; immediate

: needed  ( ca len -- )
  needed-word 2@ 2>r  2dup needed-word 2!
  2dup save-string -trailing -leading undefined?
    \ a copy of the string is used because `undefined?`
    \ converts it to uppercase
  if  reneeded  else  2drop  then  2r> needed-word 2!  ;

Usage example of [needed] and [unneeded]:

( within between )

[unneeded] within dup
?\ : within  ( n1|u1 n2|u2 n3|u3 -- f )  over - >r - r> u<  ;
?\ ;s

need -rot
: between  ( n1|u1 n2|u2 n3|u3 -- f )  over - -rot - u< 0=  ;

Implemented some bit-manipulation words in the library:

( test-bits set-bits reset-bits )

  \ Credits:
  \ Words inspired by MPE PowerForth for TiniARM.

need z80-asm  need [if]

[needed] test-bits [if]
code test-bits  ( b ca -- wf )
  hl pop  de pop  e a ld  m and
  ' true cfa>pfa jpnz  ' false cfa>pfa jp
  end-code  ;s  [then]
  \ AND the bitmask _b_ with the contents of _ca_ and return
  \ `true` if the result is non-zero or `false` if the result
  \ is zero. Byte operation.

[needed] set-bits [if]
code set-bits  ( b ca -- )
  hl pop  de pop  e a ld  m or  a m ld  jpnext
  end-code  ;s  [then]
  \ Apply the bitmask _b_ ORred with the contents of _ca_. Byte
  \ operation.

[needed] reset-bits [if]
code reset-bits  ( b ca -- )
  hl pop  de pop  e a ld  cpl  m and  a m ld  jpnext
  end-code  ;s  [then]
  \ Apply the bitmask _b_ inverted and ANDed with the contents
  \ of _ca_. Byte operation.

  \ XXX `toggle-bits` is in the kernel
  \ [needed] toggle-bits [if]
  \ code toggle-bits  ( b ca -- )
  \   hl pop  de pop  m a ld  e xor  a m ld  jpnext
  \   end-code  ;s  [then]
  \   \ Invert the bits at _ca_ specified by the bitmask _b_. Byte
  \   \ operation.

The definition of fig-Forth's toggle in the kernel was modified to suit the word set: now it's called toggle-bits and the order of its parameters have been changed.

Renamed pixel? to test-pixel to make the pixel wordset analogous.

Moved roll to the library. 28 bytes saved.

2015-10-17

Substituted message with a deferred called .throw; wrote its default behaviour .throw#. Its extended behaviour, similar to the old message, is written in the library as (.throw). Moved all related words to the library: error>ordinal, error>line and .line. Commented out the unused word warning. All this saved 111 bytes: 33561 bytes free.

Alas, line>string can not be moved to the library because located uses it, before need has been defined.

2015-10-18

Wrote some words to increment and decrement the contents of memory addresses: 1+!, 1-!, c1+! and c1-!.

Renamed command (a factor of the editor's text) to parse-line; that's what it does.

Added the Forth-2012 data structures.

2015-10-19

Wrote an improved version of ?? that works with immediate and parsing words:

: ??  ( Compilation: "name" -- ) ( Runtime: f -- )
  postpone if
  parse-name find-name  ( x 0 | cfa 1 | cfa -1 )
  dup 0= -13 ?throw
  1 = if  execute  else  compile,  then
  postpone then
  ;  immediate

2015-10-20

Wrote compile-only and started modifying interpret and find-name accordingly.

2015-10-21

Finished compile-only and all related changes. The old behaviour still can be selected with conditional compilation of the kernel.

2015-10-22

Removed state-smartness from the old fig-Forth version of literal. Modified interpret accordingly. Updated cliteral. Wrote 2lit, needed for the improved version of 2literal.

Wrote char? after DZX-Forth.

Fixed parse-char: a silly mistake, a missing drop.

Renamed all words that convert between components of a definition. The following table shows the old and the new names, compared with those used by several Forth standards and the Gforth system.

Solo Forth (old) fig-Forth Forth-83 Forth-94 Gforth Forth-2012 Solo Forth (new)
cfa>nfa >name >name >name
cfa>pfa >body >body >body >body >body
cfap>lfa >>link
lfa>nfa l>name link>name
nfa>cfa name> name>int and name>comp name>compile and name>interpret name>
nfa>lfa n>link name>link
nfa>string name>string name>string name>string
pfa>cfa cfa body> body>
pfa>lfa lfa body>link
pfa>nfa nfa body>name

name>compile and name>interpret will be implemented.

2015-10-23

Improved number-base: now empty strings are supported.

Improved number? to recognize chars between single quotes, after the Forth-2012 Standard. Wrote char? to do the actual recognition; it's called at the start of number? (2dup char? if nip nip 1 exit then). But there's a problem: the string received by number? has been already converted to uppercase by find-name in interpret.

  _colon_header char_question_,'CHAR?'

; doc{
;
; char?  ( ca len -- c true | false )
;
; ----
; : char?  ( ca len -- c true | false )
;   3 <> if
;     dup c@ [char] ' <> if
;       dup [ 2 chars ] literal + c@ [char] ' <>
;       if  char+ c@ true exit  then
;     then
;   then
;   drop false ;
; }doc

  _literal 3
  dw equals_
  dw zero_branch_,char_question.not

char_question.right_length:
  dw dup_,c_fetch_
  _literal "'"
  dw equals_
  dw zero_branch_,char_question.not

char_question.first_quote:
  dw dup_,two_plus_,c_fetch_
  _literal "'"
  dw equals_
  dw zero_branch_,char_question.not

char_question.match:
  dw char_plus_,c_fetch_,true_,exit_

char_question.not:
  dw drop_,false_,exit_
  dw semicolon_s_

2015-10-24

Improved version of (find-name) that converts chars to uppercaso on the fly. The old problem was the strings had to be converted to uppercase first, what modified the contents input buffer. Fixed.

Moved the following words to the library: body>name, name>link, link>name, >>link, ?compiling, ?executing, save-counted-string, trail. They are not used in the kernel.

Fixed ' (for version 4 of find-name).

Removed versions 0..3 of find-name. Version 4 is chosen, written after Gforth: find-name ( ca len -- nfa | 0 ). Removed all unnecessary code from the kernel (many words had several versions, conditionally compiled depending on the active version of find-name).

  _colon_header find_name_,'FIND-NAME'

; doc{

; find-name  ( ca len -- nfa | 0 )
;
; 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
; zero.  If the definition is found, return its _nfa_.
;
; The search is case-insensitive.

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

; }doc

  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_
  dw paren_find_name_,question_dup_ ; ( nfa nfa | 0 ) word found?
  dw zero_branch_,find_name.loop
  dw nip_,nip_,unloop_,exit_
find_name.loop:
  dw paren_loop_,find_name.do
  dw two_drop_,false_
  dw semicolon_s_

Added the constants immediate-mask and compile-only-mask. Formerly their values were coded as literals in 4 words, but they were not accessible from the application.

Converted 7 constants to byte constants. This saves 7 bytes.

Renamed (find-name) to find-name-from.

Adapted ?? to the final version of find-name:

: ??  ( Compilation: "name" -- ) ( Runtime: f -- )
  postpone if
  defined ( nfa | 0 ) ?dup 0= -13 ?throw
  name>immediate? ( cfa f ) if  execute  else  compile,  then
  postpone then
  ;  immediate compile-only

Removed the old versions of defer, defer! and defer@ from the kernel, that were abandoned on 2015-09-22. The deferred words still could be compiled with the the old system.

2015-10-25

Implemented alias and synonym.

( alias synonym )

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

  \ doc{
  \
  \ alias  ( cfa "name" -- )
  \
  \ Create an alias _name_ that will execute _cfa_.
  \ In Solo Forth an alias is a deferred word.
  \
  \ }doc

  \ Credits:
  \ The code of `synonym` is adapted from the example provided in the
  \ Forth-2012 documentation, and improved with `compile-only?`.

: synonym  ( "newname" "oldname" -- )
  create immediate
    smudge ' , smudge
  does>  ( -- )
   ( pfa ) @ ( cfa ) dup >name dup ( cfa nfa nfa )
   compile-only? executing? and -14 ?throw
   immediate? executing? or
   if  execute  else  compile,  then  ;

  \ doc{
  \
  \ synonym  ( "newname" "oldname" -- )
  \
  \ Create a definition for _newname_ with the the semantics
  \ defined below. _newname_ may be the same as _oldname_; when
  \ looking up _oldname_, _newname_ shall not be found.

  \ newname ( Interpretation: i*x -- j*x )
  \         Perform the interpretation semantics of _oldname_.
  \
  \ newname ( Compilation: i*x -- j*x )
  \         Perform the compilation semantics of _oldname_.
  \
  \ Standard: Forth-2012 (TOOLS EXT).
  \
  \ }doc

Wrote a Z80 macro to define deferred words in the kernel:

_defer_header: macro _base_label,_name,_flags,_cfa

  _code_header _base_label,_name,_flags
  ld hl,_cfa
  jp next2

  endm

  ; XXX OLD syntax:
  _code_header home_,'HOME'
  ld hl,paren_mode32_home_
  jp next2

  ; XXX NEW syntax:
  _defer_header home_,'HOME',,paren_mode32_home_

Improved alias:

: code?  ( cfa -- f )  dup >body swap @ =  ;

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

: code-alias  ( cfa "name" -- )
  @ header smudge latest name> !  ;

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

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

And then improved alias once more:

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

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

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

: (code-alias)  ( a "name" -- )
  header smudge latest name> !  ;
  \ Create a code word that executes the code at _a_.

: code-alias  ( cfa "name" -- )  @ (code-alias)  ;
  \ Create a code word that executes the code pointed by _cfa_.

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

Wrote a new version of case, modified from eForth, shorter than the previous one.

( case )

  \ Credits:
  \ Code adapted and modified from eForth.

  \ This version uses 48 bytes.

0 constant case  immediate compile-only

: of
  \ Compilation: ( -- orig )
  \ Run-time: ( x1 x2 -- )
  postpone over postpone = postpone if  postpone drop
  ; immediate compile-only

: endof  ( orig1 -- orig2 )
  postpone else  ; immediate compile-only

: endcase
  ( Compilation: 0 orig1..orign -- )
  ( Run-time: x -- )
  postpone drop  begin  ?dup  while  [compile] then  repeat
  ; immediate compile-only

( case )

  \ Credits:
  \ Code adapted and modified from eForth.

  \ This version uses 54 bytes.

0 constant case  immediate compile-only

: of
  \ Compilation: ( -- orig )
  \ Run-time: ( x1 x2 -- )
  postpone over postpone = postpone if  postpone drop
  ; immediate compile-only

: endof  ( orig1 -- orig2 )
  postpone else  ; immediate compile-only

: (endcase) ( 0 orig1..orign -- )
  begin  ?dup  while  [compile] then  repeat  ;

: endcase
  ( Compilation: 0 orig1..orign -- )
  ( Run-time: x -- )
  postpone drop (endcase)  ; immediate compile-only

Finished adding compile-only to all words that don't have interpretation semantics.

Started implementing the select control structure from Galope.

Started implementing the control-flow stack words.

Improved need and needed a bit.

2015-10-26

Renamed test-bits, set-bits, reset-bits and toggle-bits as c@test-bits?, c!set-bits, c!reset-bits and c!toggle-bits.

2015-10-27

Added to the library some words written by Wil Baden: r'@, possibly and anew.

Added >order (after Gforth) to the library.

Moved c@test-bits?, c!set-bits and c!reset-bits to the kernel, to be used by immediate, immediate?, compile-only compile-only? and the future hide and reveal.

Factored out set-latest-lex from immediate and compile-only. Factored out lex! (after eForth) from set-latest-lex.

Added the Solo Forth version to greeting. Unfortunately the Pasmo assembler can not manipulate 32-bit numbers, so the contents of version has to be calculated by hand:

; ----------------------------------------------
  _two_constant_header version_,'VERSION'

  dw 307,31475 ; = 20151027

Wrote a simpler alternative implementation of privatize:

( privatize )

  \ Usage example:
  \
  \ ----
  \ private{
  \
  \ : hello  ( -- )  ." hello"  ;
  \
  \ }private
  \
  \ : salute  ( -- )  hello  ;
  \
  \ privatize
  \
  \ salute  \ ok!
  \ hello   \ error!
  \ ----

  \ Credits:
  \
  \ The idea for this code was taken from an article by Deway
  \ Val Schorre, _Structured programming by adding modules to
  \ FORTH_, published in Forth Dimensions 2/5 page 132
  \ (1981-01). The following original code is for fig-Forth.
  \ I added stack effects and comments:

  \ : INTERNAL  ( -- nfa )  CURRENT @ @  ;
  \   \ Start the definition of internal words of the module.
  \   \ Return the nfa of the latest word created in the
  \   \ `current` vocabulary.
  \
  \ : EXTERNAL  ( -- nfa )  HERE  ;
  \   \ Start the definition of external words of the module.
  \   \ Return the nfa of the next word to be defined.
  \
  \ : MODULE  ( nfa1 nfa2 -- )  PFA LFA !  ;
  \   \ End the module.
  \   \ Link the first external word to the word before the
  \   \ first internal word, thus making the internal words
  \   \ invisible.

  \ The names have been changed after an analogous code from
  \ pForth, for clarity.

need >>link

: private{  ( -- nfa )  latest  ;
  \ Start private definitions.
  \ Return the nfa of the latest word created in the
  \ `current` vocabulary.

: }private  ( -- cfap )  np@  ;
  \ End private definitions.
  \ Return the cfap (code field address pointer) of the first
  \ word to be defined as public, that is, the current value
  \ of the names pointer.

: privatize  ( nfa cfap -- )  >>link !n  ;
  \ Hide all words between `private{` and `}private`:
  \ Link the first public word to the word before the
  \ first private word, thus making the internal words
  \ invisible.

2015-10-29

Wrote hide and reveal to substitute smudge. Moved smudge and its factor smudged to the library. Wrote hided and revealed, useful factors of hide and reveal.

Wrote default-bank and names-bank. They are code words that call alternative entry point of the Z80 routine used by bank. This way the code can be used by high-level and low-level words, and beside some memory is saved in both cases.

Removing smudge caused a problem: the old smudge in ; was compensated by another smudge in :noname, else the word defined before :noname would be affected. Now, in order to deactivate the reveal in ; when the word being defined was created by :noname, a flag has to be used, what makes ; slower. This method was adapted from hForth.

; ----------------------------------------------
  _variable_header noname_question_,'NONAME?'

; doc{
;
; noname?  ( -- a )
;
; A variable that holds a flag: was the word being defined
; created by `:noname`? This flag is set by `:noname` and reset
; by `;`.
;
; }doc

  dw false

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


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

  ; Credits:
  ; Code modified from the Afera library.

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

  dw here_ ; cfa
  dw store_csp_
  dw lit_,do_colon,comma_ ; create the code field
  dw noname_question_,on_
  dw right_bracket_
  dw semicolon_s_

; ----------------------------------------------
  _colon_header semicolon_,';',immediate+compile_only

; doc{
;
; ;  ( -- )
;
; ----
; : ;  ( -- )
;   ?csb postpone ;s
;   postpone [
;   noname? @  noname? off  ?exit
;   reveal  ;
; }doc

  dw question_csp_
  dw compile_,semicolon_s_
  dw left_bracket_
  dw noname_question_,fetch_
  dw noname_question_,off_
  dw question_exit_
  dw reveal_
  dw semicolon_s_

2015-10-31

Started implementing the post-Forth-83 loops in the kernel, with alternative names, after Spectrum Forth-83.