An implementation of POSPONE via FIND
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
\ 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 in general. | |
\ | |
\ 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 the interpretation semantics | |
: postpone ( "name" -- ) | |
state @ 0= -14 and throw | |
bl word 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 | |
\ 2021-07-13 ruv -- remove state-dirty (since it produces inconsistency) | |
\ see: https://github.com/ForthHub/discussion/discussions/103 | |
\ https://groups.google.com/g/comp.lang.forth/c/U0XhM-TDZV0/m/gd2l5ScRAQAJ | |
: state-on ( -- ) ] ; | |
: state-off ( -- ) postpone [ ; | |
: execute-compiling ( i*x xt --j*x ) | |
state @ if execute exit then | |
state-on execute state-off | |
; | |
: execute-interpreting ( i*x xt --j*x ) | |
state @ 0= if execute exit then | |
state-off execute state-on | |
; | |
\ ===== 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
\ 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 | |
.( \ Testing STATE control ) CR | |
: eval{ ( i*x "ccc}" -- j*x ) [char] } parse evaluate postpone [ ; immediate | |
: [s] ( -- flag ) state @ 0<> ; immediate | |
: x] ] ; immediate | |
: y] postpone x] ; \ it should do nothing | |
t{ eval{ [s] y] [s] } = -> true }t | |
.( \ OK ) CR CR |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
A short URL: https://git.io/J30D6
See also: About POSTPONE semantics in edge cases