Skip to content

Instantly share code, notes, and snippets.

@ruv

ruv/postpone-portable.env-ascetic.fth Secret

Last active September 28, 2023 16:35
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save ruv/fe2256dde1ca304f31ed925c8b998259 to your computer and use it in GitHub Desktop.
Save ruv/fe2256dde1ca304f31ed925c8b998259 to your computer and use it in GitHub Desktop.
Download ZIP
An implementation of POSPONE via FIND
Raw
postpone-portable.env-ascetic.fth
\ 2023-09-28 ruv
\ Create fake "[defined]" for testing purpose:
\ -- make the original words (if any) "postpone", "literal", "lit," invisible for "[defined]"
: [available] ( "name" -- xt|0 )
bl word ['] find execute-compilatingly if exit then drop 0
; immediate
: [defined] ( "name" -- flag )
['] [available] execute dup 0= if exit then
[ [available] lit, ] literal over = 0= and
[ [available] literal ] literal over = 0= and
[ [available] postpone ] literal over = 0= and
0<>
; immediate
: [undefined] ( "name" -- flag )
['] [defined] execute 0=
; immediate
Raw
postpone-portable.env-ascetic.test.fth
\ To test in both variants of the envirionment, load the files in the following order:
[defined] warning [if] warning off [then]
[defined] warnings [if] warnings off [then]
include ./postpone-portable.fth
include ./postpone-portable.test.fth
include ./postpone-portable.env-ascetic.fth
include ./postpone-portable.fth
include ./postpone-portable.test.fth
Raw
postpone-portable.fth
\ 2021-05-03 ruv
\ Implementing of the standard POSTPONE via "FIND" and "COMPILE," only.
\ This implementation meets the common expectations in regards
\ to perfoming compilation semantics in interpretation state in general.
\
\ It also defines the interpretation semantics for "POSTPONE",
\ which are to perfom the compilation semantics for the word in the immediate argument.
\
\ Additionally, it defines the words "LITERAL" (via "EVALUATE") and "LIT,", if they are absent.
\ ===== 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
: compilation ( -- flag ) state @ 0<> ;
: enter-compilation ( -- ) ] ;
[defined] postpone [if]
: leave-compilation ( -- ) postpone [ ;
[else] [defined] [compile] [if]
: leave-compilation ( -- ) [compile] [ ;
[else]
: leave-compilation ( -- ) ['] [ execute ;
[then] [then]
: execute-compilatingly ( i*x xt --j*x )
compilation if execute exit then
enter-compilation execute leave-compilation
;
: execute-interpretively ( i*x xt --j*x )
compilation 0= if execute exit then
leave-compilation execute enter-compilation
;
\ ===== Compatibilty layer
[undefined] literal [undefined] postpone or [if]
: tt-lit-instr ( x -- x| ) state @ if 0 <# #s #> >r here r@ cmove here r> evaluate then ;
[then]
[undefined] literal [if]
.( \ Info: 'literal' was not provided by the system ) cr
: literal ( x -- | x -- x ) tt-lit-instr ; immediate
[then]
[undefined] postpone [if]
.( \ Info: 'postpone' was not provided by the system ) cr
\ It's a minimal correct implementation of POSTPONE
\ This version is used only during translation of this source code file.
: compile, compile, ; \ to ensure the interpretation semantics
: postpone ( "name" -- )
state @ 0= -14 and throw
bl word find dup 0= -13 and throw 1 =
>r tt-lit-instr r> if ['] execute-compilatingly else ['] compile, then compile,
; immediate
[then]
[undefined] lit, [if]
.( \ Info: 'lit,' was not provided by the system ) cr
: 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]
\ ===== 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-interpretively
;
: find-sem-compil? ( c-addr u -- xt flag-special true | false )
['] find-sem? execute-compilatingly
;
\ ===== Implementation of the standard POSTPONE
\ with the expected compilation semantics, which are to perform the compilation semantics
\ for the immediate argument.
\ 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-compilatingly else ['] compile, then true exit then
false
;
\ The implementation defined interpretation semantics for this "postpone"
\ are to perform the compilation semantics of the argument.
: postpone ( "name" -- )
parse-name find-compiler? 0= -13 and throw ( xt xt-compiler )
compilation if swap lit, compile, exit then execute
; immediate
Raw
postpone-portable.test.fth
\ 2021-05-03 ruv
CR
.( \ 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
.( \ 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 LIT, ) CR
\ Ensure that "lit," properly works in interpretation state
t{ :noname [ 0 1 lit, ] [if] literal [then] ; 0 swap execute -> 0 1 }t
.( \ 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
Copy link
Author

ruv commented May 15, 2021 •
edited

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

See also: About POSTPONE semantics in edge cases

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