Skip to content

Instantly share code, notes, and snippets.

@ruv

ruv/postpone-portable.fth Secret

Last active Jun 14, 2021
Embed
What would you like to do?
An implementation of POSPONE via FIND
\ 2021-05-03 ruv
\ Implementing of the standard POSTPONE via "FIND", "COMPILE,", and "LITERAL"
\ This implementation meets the common expectations in regards
\ to perfoming compilation semantics in interpretation state.
\ Also it defines the interpretaion semantics for POSTPONE
\ which are to perfom the compilation semantics for the word in the argument.
\ ===== Compatibilty layer
[undefined] postpone [if]
\ It's a temporary instrumental implementation of POSTPONE
\ It will be used only during translation of this source code file.
: tt-lit-instr ( x -- x | ) state @ if 0 <# #s #> >r pad r@ cmove pad r> evaluate then ;
: compile, compile, ; \ to ensure execution semantics
: postpone ( "name" -- )
state @ 0= if -14 throw then
parse-name pad 2dup c! dup >r char+ swap cmove r> find dup 0= -13 and throw 1 =
if compile, exit then tt-lit-instr ['] compile, compile,
; immediate
[then]
[undefined] lit, [if]
: 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]
\ ===== STATE control
\ 2019-09-24 ruv
variable state-dirty \ private
: state-on ( -- ) state-dirty on ] ;
: state-off ( -- ) state-dirty on postpone [ ; \ [ ' [ compile, ]
: execute-compiling ( i*x xt --j*x )
state @ if execute exit then
state-dirty @ >r state-on state-dirty off execute state-dirty @ if rdrop exit then state-off r> state-dirty !
;
: execute-interpreting ( i*x xt --j*x )
state @ 0= if execute exit then
state-dirty @ >r state-off state-dirty off execute state-dirty @ if rdrop exit then state-on r> state-dirty !
;
\ Redefenition of the words that change STATE to also set "state-dirty".
\
\ see: 6.1.2250 STATE, 15.6.2.2250 STATE
\ -- https://forth-standard.org/standard/core/STATE
\ Only the following standard words alter the value in STATE:
\ ":" (colon), ";" (semicolon), ABORT, QUIT, :NONAME, "[" (left-bracket), "]" (right-bracket).
\ -- https://forth-standard.org/standard/tools/STATE
\ allow ;CODE to change the value in STATE.
: [ state-off ; immediate
: ] state-on ;
: :noname state-dirty on :noname ;
: : state-dirty on : ;
: ; state-dirty on postpone ; ; immediate
: abort state-dirty on abort ;
: quit state-dirty on quit ;
[defined] ;code [if]
: ;code state-dirty on postpone ;code ; 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-interpreting
;
: find-sem-compil? ( c-addr u -- xt flag-special true | false )
['] find-sem? execute-compiling
;
\ ===== Implementation of the standard POSTPONE
\ 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-compiling else ['] compile, then true exit then
false
;
\ The implementation defined interpretation semantics for this "postpone"
\ is to perform the compilation semantics of the argument.
: postpone ( "name" -- )
parse-name find-compiler? 0= -13 and throw ( xt xt-compiler )
state @ if swap lit, compile, exit then execute
; immediate
\ 2021-05-03 ruv
CR
.( \ 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 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
@ruv

This comment has been minimized.

Copy link
Owner Author

@ruv ruv commented May 15, 2021

A short URL: https://git.io/J30D6

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