ruv/special-words-as-immediate.fth Secret

## special-words-as-immediate.fth
\ 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
	\ 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 ( ix xt -- jx ) 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 ( ix xt --jx ) 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