Synonym/Alias with dodefer to make nts executable in any case

parent c9fee3de
Pipeline #645 passed with stage
in 8 minutes and 47 seconds
......@@ -3155,17 +3155,20 @@ End-Struct vtable-struct
>TARGET
ghost a>int drop
ghost a>comp drop
ghost a-to drop
ghost s-to drop
ghost :dodefer drop
: Alias ( cfa -- ) \ name
>in @ skip? IF 2drop EXIT THEN >in !
(THeader ( S xt ghost )
2dup swap xt>ghost swap copy-execution-semantics
[G'] @ vttemplate >vt>int !
[G'] a>int vttemplate >vt>int !
[G'] a>comp vttemplate >vt>comp !
[G'] s-to vttemplate >vtto !
over resolve T A, H ;
over resolve [G'] :dodefer (doer,) T A, H ;
: interpret/compile: ( xt1 xt2 "name" -- )
(THeader <res> over >magic ! there swap >link !
......
......@@ -253,7 +253,7 @@ Defer char@ ( addr u -- char addr' u' )
' noop Alias recurse
\g Alias to the current definition.
unlock tlastcfa @ lock AConstant lastcfa
unlock tlastcfa @ >body lock AConstant lastcfa
\ this is the alias pointer in the recurse header, named lastcfa.
\ changing lastcfa now changes where recurse aliases to
\ it's always an alias of the current definition
......@@ -389,28 +389,29 @@ include ./recognizer.fs
\ : a>comp ( nt -- xt1 xt2 ) name>int ['] compile, ;
: a>comp ( nt -- xt1 xt2 ) dup >r @
: a>int ( nt -- ) >body @ ;
: a>comp ( nt -- xt1 xt2 ) dup >r >body @
['] execute ['] compile, r> immediate? select ;
: s>int ( nt -- xt ) @ name>int ;
: s>comp ( nt -- xt1 xt2 ) @ name>comp ;
: s>int ( nt -- xt ) >body @ name>int ;
: s>comp ( nt -- xt1 xt2 ) >body @ name>comp ;
: s-to ( val nt -- )
\ actually a TO: TO-OPT: word, but cross.fs does not support that
@ (int-to) ;
opt: drop @ (comp-to) ;
>body @ (int-to) ;
opt: drop >body @ (comp-to) ;
: Alias ( xt "name" -- ) \ gforth
Header reveal ['] on vtcopy ?noname-vt
['] @ set->int ['] a>comp set->comp ['] s-to set-to
dup A, lastcfa ! ;
Header reveal ['] on vtcopy
['] a>int set->int ['] a>comp set->comp ['] s-to set-to
dodefer, dup A, lastcfa ! ;
: alias? ( nt -- flag )
>namevt @ >vt>int 2@ ['] a>comp ['] @ d= ;
>namevt @ >vt>int 2@ ['] a>comp ['] a>int d= ;
: Synonym ( "name" "oldname" -- ) \ Forth200x
Header ['] on vtcopy
parse-name find-name dup 0= #-13 and throw
dup A,
dodefer, dup A,
dup compile-only? IF compile-only THEN name>int lastcfa !
['] s>int set->int ['] s>comp set->comp ['] s-to set-to reveal ;
......
......@@ -74,12 +74,12 @@ Defer }}text' ' }}text IS }}text'
: \\ }}text' /left ;
: p\\ ( text -- )
}}text' >r {{ r> glue*l }}glue }}p box[] >bl'
dpy-w @ s>f font-size# 140% f* f- 1e text-shrink% f2/ f- f/ dup .par-split ;
dpy-w @ s>f font-size# 70% f* f- 1e text-shrink% f2/ f- f/ dup .par-split ;
: p2\\ ( text1 text2 -- )
}}text' >r dark-blue }}text' blackish >r {{ r> }}z >r
{{ r> r> over >r glue*l }}glue }}p box[] >bl'
r> over >o to lhang o>
dpy-w @ s>f font-size# 140% f* f- 1e text-shrink% f2/ f- f/ dup .par-split ;
dpy-w @ s>f font-size# 70% f* f- 1e text-shrink% f2/ f- f/ dup .par-split ;
: e\\ }}emoji >r }}text' >r {{ r> glue*l }}glue r> }}h box[] >bl ;
: /right ( o -- o' )
>r {{ glue*l }}glue r> }}h box[] >bl ;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment