Implement `create` and `does>` in a standard Forth program

create-does.fth

\ 2024-08-11 Ruv

\ A portable implementation of `create`, `>body`, and `does>`
\ for illustrative purposes.

\ One not standard word is used:
\   latest-name ( -- nt )
\ See: https://forth-standard.org/proposals/new-words-latest-name-and-latest-name-in?hideDiff#reply-1251


[undefined] noop  [if] : noop ; [then]
[undefined] lit,  [if] : lit, ( x -- ) postpone literal ; [then]
[undefined] name> [if] : name> ( nt -- xt ) name>interpret ?dup if exit then [: -14 throw ;] ;  [then]
[undefined] latest-name [if]
  s" gforth" environment? [if] s" 000.007.009_20130903" compare  1 = [if]
    : latest-name-in ( wid -- nt|0 ) wordlist-id @ ;
    : latest-name ( -- nt | ⊥ ) get-current latest-name-in dup 0= abort" the compilation word list is empty" ;
  [then] [then]
[then]



\ defer metadoes ( i*x a-addr.data-created -- j*x )
\   - let's avoid using `defer` in this implementation.
variable _metadoes
: metadoes ( i*x a-addr.data-created -- j*x ) _metadoes @ execute ;

: reset-metadoes ( -- )
  [: ( i*x a-addr.data-created -- j*x ) 2@ execute ;] _metadoes !
; reset-metadoes

\ Create a definition for "name" that is a partially applied xt to x
: define-partially-applied ( x xt "name" -- ) 2>r  :  r> r> lit, compile, postpone ; ;

: create ( "name" -- )
  align here ( a-addr.data-created ) >r ['] noop , 0 ,
  r@ ['] metadoes define-partially-applied \ it consumes "name"
  here r> ( a-addr.data-field a-addr.data-created ) cell+ !
;
\ The command:
\   create foo
\ is equivalent to the command:
\   align here >r  ['] noop , 0 ,   : foo [ r@ lit, ] metadoes ;  here r> cell+ !
\ assuming that `>r`, `r>` and `[']` behave as expected in interpretation state.
\ NB: `foo` is the result of partial application of `metadoes` to "a-addr.data-created".


\ Apply "xt.metadoes" to "a-addr.data-created" associated with "xt.created"
: apply-metadoes ( i*x xt.created xt.metadoes -- j*x )
  \ xt.metadoes ( i*x a-addr.data-created -- j*x )
  dup >r  _metadoes ! ( xt.created ) catch ( 0|ior )
  _metadoes @ r> <> if ( 0|ior ) throw exit then
  reset-metadoes  -31 throw \ ">BODY or DOES> Run-Time used on non-CREATEd definition"
;

: >body ( xt.created -- a-addr.data-field )
  [: ( a-addr.data-created -- a-addr.data-field ) reset-metadoes  cell+ @ ;]
  apply-metadoes
;
: alter-does ( xt.does-new xt.created -- )
  \ xt.does-new ( i*x a-addr.data-field -- j*x )
  [: ( xt.does-new a-addr.data-created -- ) reset-metadoes  ! ;]
  apply-metadoes
;
: alter-does-latest ( xt.does-new -- )
  \ xt.does-new ( i*x a-addr.data-field -- j*x )
  latest-name name>  alter-does
;


\ Redefine `;` and `;]` to properly end the does-part

variable _in-does \ an additional part of the control-flow stack
: reset-in-does ( -- ) false _in-does ! ; reset-in-does
\ DataType: does-sys = ( colon-sys | quotation-sys colon-sys | does-sys flag.in-does.prev quotation-sys colon-sys )

: end-colon ( colon-sys -- ) postpone ;  ;
: end-quote ( quotation-sys colon-sys -- ) postpone ;] ;
: end-does ( does-sys  flag.in-does.prev quotation-sys colon-sys -- does-sys )
  end-quote  postpone alter-does-latest _in-does !
;

: ;   ( does-sys -- )
  _in-does @ 0= if end-colon  exit then  end-does recurse
; immediate

: ;]  ( does-sys -- )
  _in-does @ 0= if end-quote  exit then  end-does recurse
; immediate

: does> ( does-sys -- does-sys )
  _in-does @  true _in-does !  postpone [:
  \ NB: nested `does>` shall work
; immediate

\ Implementation details. Translation of the code:
\   : foo ... does> bar ... does> baz ... ;
\ produces the code that is equivalent to:
\   : foo ... [: bar ... [: baz ... ;] alter-does-latest ;] alter-does-latest ;


\ Reset _in-does to properly work after an error (if any)
: :         reset-in-does :       ;
: :noname   reset-in-does :noname ;


\ eof

create-does.test.fth

\ 2024-08-11

.( Testing "create-does.fth" ... ) cr

t{ here ' noop , 15 , metadoes -> 15 }t
t{ here ' @   , dup , metadoes ' @ = -> true }t

t{ create foo -> }t
t{ foo -> here }t
t{ ' foo >body -> here }t
t{ 123 , -> }t
t{ [: @ ;]  here swap  alter-does-latest  here =  -> true }t
t{ ' foo >body @ -> 123 }t
t{ foo -> 123 }t

\ test redefined semicolon
t{ : bar 456 ; -> }t
t{ bar -> 456 }t
t{ :noname 789 ; execute -> 789 }t

\ test `does>`
t{ : alt1 does> @ ; -> }t
t{ create bar1 11 , alt1 -> }t
t{ bar1 -> 11 }t

\ test nested `does>`
t{ : alt2 does> @ does> @ ; -> }t
t{ create baz1 22 , alt2 -> }t
t{ create baz2 33 , baz1 -> 22 }t
t{ baz2 -> 33 }t

\ test applying `>body` to an incorrect xt
t{ :noname ['] abort >body drop ; catch drop -> }t
t{ foo -> 123 }t
t{ :noname ['] abort >body drop ; catch -> -31 }t

\ test `does>` in a quotation
t{ create foo2 123 , :noname [: does> @ 1+ ;] ; execute execute -> }t
t{ foo2 -> 124 }t
t{ [: does> @ 2 + does> @ 3 + ;] execute -> }t
t{ foo2 -> 125 }t \ change e.s.
t{ foo2 -> 126 }t \ no change 1
t{ foo2 -> 126 }t \ no change 2


.( Testing "create-does.fth" is complete ) cr