Verified Commit 24ebef20 authored by Bernd Paysan's avatar Bernd Paysan
Browse files

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

parent c9fee3de

cross.fs

+5 −2
Original line number Diff line number Diff line
@@ -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 !

kernel/comp.fs

+12 −11
Original line number Diff line number Diff line
@@ -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 ;

minos2/text-style.fs

+2 −2
Original line number Diff line number Diff line
@@ -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 ;