Skip to content

Instantly share code, notes, and snippets.

@ruv
Last active September 26, 2023 21:19
Show Gist options
  • Save ruv/21e7b4d0693dce587adeecb824e9c5aa to your computer and use it in GitHub Desktop.
Save ruv/21e7b4d0693dce587adeecb824e9c5aa to your computer and use it in GitHub Desktop.
Example of a correct implementation of POSTPONE for some standard words that are implemented as immediate STATE-dependent words
\ 2019-09-24 ruv
\ 2019-10-09
\ Some well known but yet non standard words
[undefined] lit, [if] : lit, postpone literal ; [then]
[undefined] slit, [if] : slit, postpone sliteral ; [then]
\ Common useful factors
: =? ( x1 x2 -- x1 false | true ) over = dup if nip then ;
: xt, compile, ; \ ensure default interpretation semantics
: state-on ( -- ) ] ;
: state-off ( -- ) postpone [ ; \ [ ' [ xt, ]
\ Token translators
: tt-xt ( i*x xt -- j*x ) state @ if xt, else execute then ;
: tt-lit ( x -- x| ) state @ if lit, then ;
: tt-slit ( c-addr u -- | c-addr u -- c-addr2 u ) state @ if slit, then ;
\ Note: separate buffering of the string literal in interpretation state
\ is absent for the sake of this example simplicity.
\ An initial action for a deferred word
: error-np ( -- ) -21 throw ; \ Not Provided, "unsupported operation"
\ Implementing of: 'to', 'is', 'action-of', 's"'
: value create , does> @ ;
: defer create ['] error-np , does> @ execute ;
: defer@ >body @ ;
: defer! >body ! ;
: is ' >body tt-lit ['] ! tt-xt ; immediate
: to [ ' is xt, ] ; immediate \ synonym; don't use postpone
: action-of ' >body tt-lit ['] @ tt-xt ; immediate
: s" [char] " parse tt-slit ; immediate
\ NB: 2VALUE and FVALUE can be easy implemeted too,
\ with a bit modification of TO and VALUE
: execute-compiling-intact ( i*x xt --j*x ) state @ if execute exit then state-on execute state-off ;
\ NB: this word guarantees interpretation state after execution if it was before execution
\ Support of an additional attribute (boolean in this case) for a word in a very portable manner
variable special-list 0 special-list !
: special-word? ( xt -- flag ) special-list swap begin swap @ dup while tuck cell+ @ =? until true then nip ;
: special ( x -- ) align here special-list @ , special-list ! , ;
: special-words< ( "ccc" -- ) begin >in @ parse-name nip swap >in ! while ' special repeat ;
\ Declare some words as special
special-words< to is action-of s"
\ a helper
: tick-word< ( "name" -- xt imm-flag ) bl word find dup 0= -13 and throw 1 = ;
\ NB: it may return different xt and flag depending on STATE
\ Implementation of "postpone" in the prevailing behavior variant
: postpone ( "name" -- ) tick-word< ( xt imm-flag )
if dup special-word? if lit, ['] execute-compiling-intact then
else lit, ['] xt,
then xt,
; immediate special-words< postpone
\ POSTPONE is special, since a wrapper for POSTPONE should resolve names in compilation state
\ (the same is for [COMPILE]).
\ Another way is to use STATE independent 'tick-word-compiling<' as
\ : tick-word-compiling< bl word ['] find execute-compiling-intact dup 0= -13 and throw 1 = ;
[defined] [compile] [if]
\ Implementation of "[compile]" in the prevailing behavior variant
: [compile] ( "name" -- ) tick-word< ( xt imm-flag )
if dup special-word? if lit, ['] execute-compiling-intact then
then xt,
; immediate special-words< [compile]
\ NB: see a problem concerning "[compile] exit" (as an example)
\ at https://forth-standard.org/standard/core/BracketCOMPILE#contribution-192
[then]
\ NB: a portable implementation of POSTPONE with exactly standard behavior (in place of popular) is simpler,
\ since it does not require an additional attribute (as "special-list" above), the result of FIND is enough.
\ Implementation of the words: 'if', 'else', 'then'
\ as STATE-dependent immediate words
: ?state state @ 0= -14 and throw ; \ "interpreting a compile-only word"
: if ?state postpone if ; immediate
: else ?state postpone else ; immediate
: then ?state postpone then ; immediate
special-words< if else then
@ruv
Copy link
Author

ruv commented Feb 11, 2020

A short link: https://git.io/JvctZ

This gist is obsolete!

Please, refer to other resources:

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment