Example of a correct implementation of POSTPONE for some standard words that are implemented as immediate STATE-dependent words

special-words-as-immediate.fth

\ 2019-09-24 ruv
\ 2019-10-09


\ Some well known but yet non standard words
[undefined] lit,    [if]  : lit,    postpone literal  ;   [then]
[undefined] slit,   [if]  : slit,   postpone sliteral ;   [then]

\ Common useful factors
: =? ( x1 x2 -- x1 false | true ) over = dup if nip then ;
: xt, compile, ; \ ensure default interpretation semantics
: state-on  ( -- ) ] ;
: state-off ( -- ) postpone [ ; \  [ ' [ xt, ]


\ Token translators
: tt-xt ( i*x xt -- j*x ) state @ if xt, else execute then ;
: tt-lit ( x -- x| ) state @ if lit, then ;
: tt-slit ( c-addr u -- | c-addr u -- c-addr2 u ) state @ if slit, then ;
\ Note: separate buffering of the string literal in interpretation state
\ is absent for the sake of this example simplicity.

\ An initial action for a deferred word
: error-np ( -- ) -21 throw ; \ Not Provided, "unsupported operation"


\ Implementing of: 'to', 'is', 'action-of', 's"'
: value create , does> @ ;
: defer create ['] error-np , does> @ execute ;
: defer@ >body @ ;
: defer! >body ! ;
: is ' >body tt-lit ['] ! tt-xt ; immediate
: to [ ' is xt, ] ; immediate \ synonym; don't use postpone
: action-of ' >body tt-lit ['] @ tt-xt ; immediate
: s" [char] " parse tt-slit ; immediate

\ NB: 2VALUE and FVALUE can be easy implemeted too,
\ with a bit modification of TO and VALUE


: execute-compiling-intact ( i*x xt --j*x ) state @ if execute exit then state-on execute state-off ;
\ NB: this word guarantees interpretation state after execution if it was before execution


\ Support of an additional attribute (boolean in this case) for a word in a very portable manner
variable special-list 0 special-list !
: special-word? ( xt -- flag ) special-list swap begin swap @ dup while tuck cell+ @ =? until true then nip ;
: special ( x -- ) align here special-list @ , special-list ! , ;
: special-words< ( "ccc" -- ) begin >in @ parse-name nip swap >in ! while ' special repeat ;


\ Declare some words as special
special-words< to is action-of s"

\ a helper
: tick-word< ( "name" -- xt imm-flag ) bl word find dup 0= -13 and throw 1 = ;
\ NB: it may return different xt and flag depending on STATE

\ Implementation of "postpone" in the prevailing behavior variant
: postpone ( "name" -- ) tick-word< ( xt imm-flag )
  if dup special-word? if lit, ['] execute-compiling-intact then
  else lit, ['] xt,
  then xt,
; immediate special-words< postpone
\ POSTPONE is special, since a wrapper for POSTPONE should resolve names in compilation state
\ (the same is for [COMPILE]).
\ Another way is to use STATE independent 'tick-word-compiling<' as
\ : tick-word-compiling< bl word ['] find execute-compiling-intact dup 0= -13 and throw 1 = ;

[defined] [compile] [if]
\ Implementation of "[compile]" in the prevailing behavior variant
: [compile] ( "name" -- ) tick-word< ( xt imm-flag )
  if dup special-word? if lit, ['] execute-compiling-intact then
  then xt,
; immediate special-words< [compile]
[then]


\ NB: a portable implementation of POSTPONE with exactly standard behavior (in place of popular) is simpler,
\ since it does not require an additional attribute (as "special-list" above), the result of FIND is enough.



\ Implementation of the words: 'if', 'else', 'then'
\ as STATE-dependent immediate words

: ?state state @ 0= -14 and throw ; \ "interpreting a compile-only word"

: if    ?state postpone if    ; immediate
: else  ?state postpone else  ; immediate
: then  ?state postpone then  ; immediate

special-words< if else then

short link: https://git.io/JvctZ

see also a more complete implementation: https://git.io/JUE8L (postpone), https://git.io/JU1JO (dual words)