\ An implementation of CREATE DOES> and >BODY overtop of Gforth's existing one,
\ for illustration.  Tested under Gforth 0.6.2.
\ Neal Bridges, 2006.  neal@quartus.net

variable latestcreate

: (create) ( addr -- )
  dup @  \ leave the dataspace address on the stack
  swap cell+ perform  \ perform the associated action
;

: CREATE
\ This implementation of CREATE gives each word two private cells:
\  The first holds the dataspace pointer at the time the word is CREATEd.
\  The second holds the xt of the associated action, noop by default.
  align here >r   \ save the address of the CREATEd word's dataspace pointer to backpatch
  0 ,
  here latestcreate !  \ save this so DOES> can assign an action to the CREATEd word
  ['] noop ,   \ default action is no action
  :
    r@ postpone literal  postpone (create)
  postpone ;
  here r> !   \ backpatch the dataspace pointer with the correct address
;

: (does) ( xt -- ) latestcreate @ ! ;

: DOES>
  ['] noop  postpone literal
  here  1 cells -  >r  \ save this to backpatch the literal
  postpone (does)
  postpone ;  \ terminate the current definition
  here r> !  \ backpatch the literal with the xt of the subsequent code
  (:noname)  \ begin a new headerless word that doesn't leave an xt on the stack at ; time
; immediate

: >BODY
  3 cells + @ @  \ this works in Gforth to retrieve the dataspace pointer from our CREATEs
;