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.
\ 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 execution semantics
  : postpone ( "name" -- )
    state @ 0= if -14 throw then
    parse-name  pad 2dup c! dup >r char+ swap cmove r> 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

variable state-dirty  \ private

: state-on  ( -- ) state-dirty on   ] ;
: state-off ( -- ) state-dirty on   postpone [ ; \  [ ' [ compile, ]

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


\ Redefenition of the words that change STATE to also set "state-dirty".
\
\ see: 6.1.2250 STATE, 15.6.2.2250 STATE
\   -- https://forth-standard.org/standard/core/STATE
\     Only the following standard words alter the value in STATE:
\     ":" (colon), ";" (semicolon), ABORT, QUIT, :NONAME, "[" (left-bracket), "]" (right-bracket).
\   -- https://forth-standard.org/standard/tools/STATE
\     allow ;CODE to change the value in STATE.

: [ state-off   ; immediate
: ] state-on    ;

: :noname   state-dirty on  :noname ;
: :         state-dirty on  : ;
: ;         state-dirty on  postpone ; ; immediate

: abort     state-dirty on  abort ;
: quit      state-dirty on  quit ;

[defined] ;code [if]
  : ;code state-dirty on postpone ;code ; immediate
[then]



\ ===== 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

.( \ OK ) CR CR

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