An implementation of POSPONE via FIND

postpone-portable.fth

\ 2021-05-03 ruv

\ Implementing of the standard POSTPONE via "FIND", "COMPILE,", and "LITERAL"

\ This implementation meets the common expectations in regards
\ to perfoming compilation semantics in interpretation state in general.
\
\ Also it defines the interpretaion semantics for POSTPONE
\ which are to perfom the compilation semantics for the word in the argument.


\ ===== Compatibilty layer

[undefined] postpone [if]
  \ It's a temporary instrumental implementation of POSTPONE
  \ It will be used only during translation of this source code file.

  : tt-lit-instr ( x -- x | ) state @ if 0 <# #s #> >r pad r@ cmove pad r> evaluate then ;
  : compile, compile, ; \ to ensure the interpretation semantics
  : postpone ( "name" -- )
    state @ 0= -14 and throw
    bl word find  dup 0= -13 and throw  1 =
    if compile, exit then   tt-lit-instr  ['] compile, compile,
  ; immediate
[then]

[undefined] lit, [if]
  : lit, ( x -- ) postpone literal ;
[then]
[undefined] 2nip [if]
  : 2nip ( d2 d1 -- d1 ) 2swap 2drop ;
[then]
[undefined] rdrop [if]
  : rdrop ( R: x -- ) postpone r> postpone drop ; immediate
[then]



\ ===== STATE control
\ 2019-09-24 ruv
\ 2021-07-13 ruv -- remove state-dirty (since it produces inconsistency)
\   see: https://github.com/ForthHub/discussion/discussions/103
\        https://groups.google.com/g/comp.lang.forth/c/U0XhM-TDZV0/m/gd2l5ScRAQAJ

: state-on  ( -- )           ] ;
: state-off ( -- )  postpone [ ;

: execute-compiling ( i*x xt --j*x )
  state @ if  execute  exit  then
  state-on  execute  state-off
;
: execute-interpreting ( i*x xt --j*x )
  state @ 0= if  execute  exit  then
  state-off  execute  state-on
;



\ ===== Use FIND to find semantics
\ 2021-04-27 ruv

255 dup constant size-buf-for-find allocate throw constant buf-for-find

: carbon-c-for-find ( c-addr u -- c-addr2 )
  dup size-buf-for-find u> if -19 throw then
  buf-for-find 2dup c! dup >r char+ swap cmove r>
;
: find-sem ( c-addr u -- xt flag-special true | c-addr u false )
  2dup carbon-c-for-find find dup if 2nip 1 = true exit then nip
;
: find-sem? ( c-addr u -- xt flag-special true | false )
  find-sem dup if exit then nip nip
;
: find-sem-interp? ( c-addr u -- xt flag-special true | false )
  ['] find-sem? execute-interpreting
;
: find-sem-compil? ( c-addr u -- xt flag-special true | false )
  ['] find-sem? execute-compiling
;



\ ===== Implementation of the standard POSTPONE
\ 2021-05-03 ruv

: find-compiler? ( c-addr u -- xt xt-compiler true | false )
  \ 2dup find-sem-interp? if 0= if nip nip ['] compile, true exit then drop then
  find-sem-compil? if if ['] execute-compiling else ['] compile, then true exit then
  false
;

\ The implementation defined interpretation semantics for this "postpone"
\ is to perform the compilation semantics of the argument.
: postpone ( "name" -- )
  parse-name find-compiler? 0= -13 and throw ( xt xt-compiler )
  state @ if swap lit, compile, exit then execute
; immediate

postpone-portable.test.fth

\ 2021-05-03 ruv

CR
.( \ Testing FIND ) CR

t{ s" dup" find-sem?        rot drop  ->  0 -1  }t
t{ s" ("   find-sem?        rot drop  -> -1 -1  }t
t{ s" dup" find-sem-interp? rot drop  ->  0 -1  }t
t{ s" dup" find-sem-compil? nip nip   -> -1     }t
t{ s" ("   find-sem-compil? rot drop  -> -1 -1  }t

.( \ OK ) CR CR

.( \ Testing new POSTPONE ) CR

 : x state @ if 1 lit, else 0 then ; immediate
 : y postpone x ; immediate

t{ x -> 0 }t
t{ :noname x ; 0 swap execute -> 0 1 }t
t{ :noname y ; 0 swap execute -> 0 1 }t
t{ :noname [ y ] ; 0 swap execute -> 0 1 }t

 : p postpone postpone ; immediate
 : n1 123 ;

t{ : foo [ p n1 ] ; immediate -> }t
t{ : bar [ foo ] ; : baz foo ;  -> }t
t{  bar baz -> 123 123 }t


.( \ Testing STATE control ) CR

 : eval{ ( i*x "ccc}" -- j*x ) [char] } parse evaluate postpone [  ;  immediate
 : [s] ( -- flag ) state @ 0<> ; immediate

 : x] ] ; immediate
 : y] postpone x] ; \ it should do nothing

t{ eval{ [s] y] [s] } = -> true }t


.( \ OK ) CR CR

A short URL: https://git.io/J30D6

See also: About POSTPONE semantics in edge cases