An implementation of POSPONE via FIND

postpone-portable.env-ascetic.fth

\ 2023-09-28 ruv
\ Create fake "[defined]" for testing purpose:
\   -- make the original words (if any) "postpone", "literal", "lit," invisible for "[defined]"

: [available] ( "name" -- xt|0 )
  bl word ['] find execute-compilatingly if exit then drop 0
; immediate

: [defined] ( "name" -- flag )
  ['] [available] execute dup 0= if exit then
  [ [available] lit,      ] literal over = 0= and
  [ [available] literal   ] literal over = 0= and
  [ [available] postpone  ] literal over = 0= and
  0<>
; immediate

: [undefined] ( "name" -- flag )
  ['] [defined] execute 0=
; immediate

postpone-portable.env-ascetic.test.fth

\ To test in both variants of the envirionment, load the files in the following order:

[defined] warning   [if] warning  off [then]
[defined] warnings  [if] warnings off [then]

include ./postpone-portable.fth
include ./postpone-portable.test.fth

include ./postpone-portable.env-ascetic.fth
include ./postpone-portable.fth
include ./postpone-portable.test.fth

postpone-portable.fth

\ 2021-05-03 ruv

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

\ This implementation meets the common expectations in regards
\ to perfoming compilation semantics in interpretation state in general.
\
\ It also defines the interpretation semantics for "POSTPONE",
\ which are to perfom the compilation semantics for the word in the immediate argument.
\
\ Additionally, it defines the words "LITERAL" (via "EVALUATE") and  "LIT,", if they are absent.


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

: compilation  ( -- flag ) state @ 0<> ;

: enter-compilation  ( -- )           ] ;

[defined] postpone [if]
: leave-compilation  ( -- )  postpone [ ;
[else] [defined] [compile] [if]
: leave-compilation  ( -- ) [compile] [ ;
[else]
: leave-compilation  ( -- ) ['] [ execute ;
[then] [then]

: execute-compilatingly ( i*x xt --j*x )
  compilation    if  execute  exit  then
  enter-compilation  execute  leave-compilation
;
: execute-interpretively ( i*x xt --j*x )
  compilation 0= if  execute  exit  then
  leave-compilation  execute  enter-compilation
;
\ Alternative naming:
\   "execute-compiling"
\   "execute-interpreting"
\ These names are consistent with a well known word "execute-parsing".



\ ===== Compatibilty layer

[undefined] literal  [undefined] postpone  or [if]
  : tt-lit-instr ( x -- x| )  state @ if 0 <# #s #> >r pad r@ cmove pad r> evaluate then ;
[then]

[undefined] literal [if]
  .( \ Info: 'literal' was not provided by the system ) cr
  : literal ( x -- | x -- x ) tt-lit-instr ; immediate
[then]

[undefined] postpone [if]
  .( \ Info: 'postpone' was not provided by the system ) cr
  \ It's a minimal correct implementation of POSTPONE
  \ This version is used only during translation of this source code file.

  : compile, compile, ; \ to ensure the interpretation semantics
  : postpone ( "name" -- )
    state @ 0= -14 and throw
    bl word find  dup 0= -13 and throw  1 =
    >r tt-lit-instr r> if ['] execute-compilatingly else ['] compile, then compile,
  ; immediate
[then]

[undefined] lit, [if]
  .( \ Info: 'lit,' was not provided by the system ) cr
  : 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]



\ ===== 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-interpretively
;
: find-sem-compil? ( c-addr u -- xt flag-special true | false )
  ['] find-sem? execute-compilatingly
;



\ ===== Implementation of the standard POSTPONE
\ with the expected compilation semantics, which are to perform the compilation semantics
\ for the immediate argument.
\ 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-compilatingly else ['] compile, then true exit then
  false
;

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

postpone-portable.test.fth

\ 2021-05-03 ruv

CR
.( \ 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


.( \ 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 LIT, ) CR

\ Ensure that "lit," properly works in interpretation state
t{ :noname [ 0 1 lit, ] [if] literal [then] ; 0 swap execute -> 0 1 }t


.( \ 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

See also: About POSTPONE semantics in edge cases