An example of implementation the dual-semantics words via Resolver and via Recognizer mechanism

dual-semantics-via-recognizer.example.fth

\ Definition of the following words:
\   VALUE TO S"
\ via Recognizer API v4
\ http://amforth.sourceforge.net/pr/Recognizer-rfc-D.html

wordlist constant markup

: rec-markup ( c-addr u -- rectype-markup-word | rectype-null )
  markup search-wordlist if execute exit then rectype-null
;

: value ( x "name" -- ) create , does> @ ;

get-current markup set-current

  :noname ( -- c-addr u ) '"' parse  ;
  :noname ( --          ) '"' parse slit, ;
  'noop
  rectype: s"

  :noname ( x -- ) ' >body ! ;
  :noname ( --   ) ' >body lit, '! compile, ;
  'noop
  rectype: to

set-current

forth-recognizer get-recognizer
'rec-markup swap 1+ forth-recognizer set-recognizer
\ Appending at the top to use the new definitions
\ instead of the old 'TO' and 'S"'




\ If we need to distinguish these markup words from other types,
\ we can use additional rectype wrapper as:

: execute-rectype  ( i*x rectype -- j*x ) rectype>int   execute ;
: compile-rectype  ( i*x rectype -- j*x ) rectype>comp  execute ;

'execute-rectype 'compile-rectype 'lit, rectype: rectype-markup

: rec-markup-ext ( c-addr u -- rectype rectype-markup | rectype-null )
  markup search-wordlist if execute rectype-markup exit then
  rectype-null
;

dual-semantics-via-resolver.example.fth

\ Definition of the following words:
\   VALUE TO S"
\ via Resolver API v1
\ https://github.com/ruv/forth-design-exp/blob/master/docs/resolver-api.md

\ NB: POSTPONE should be tweaked to explicitly support the markup words


wordlist constant markup
: tt-markup ( i*x xt -- j*x ) execute ;
: resolve-markup ( c-addr u -- xt tt-markup | c-addr u  0 )
  markup sfind-wordlist ?E0 'tt-markup
;

: value ( x "name" -- ) create , does> @ ;

markup push-current
: s" ( -- c-addr u | ) '"' parse tt-slit ;
: to ( x | -- ) ' >body tt-lit '! tt-xt ;
: postpone
  parse-lexeme resolve-lexeme dup ?NF
  'tt-markup =? if tt-lit 'execute-compiling tt-xt exit then
  \ ... other variants
  -32 throw \ "invalid name argument"
;
drop-current

'resolve-markup preempt-resolver

Short URL: https://git.io/JvcGL