Verified Commit bd578c3a authored by Bernd Paysan's avatar Bernd Paysan
Browse files

Factor common parts of synonym/alias

parent cf978224

cross.fs

+5 −7
Original line number Diff line number Diff line
@@ -3065,9 +3065,8 @@ ghost abi-code, 
2drop

ghost ;abi-code,

drop

ghost default-name>int

ghost default-name>comp

2drop

drop

ghost i/c>int

ghost i/c>comp

2drop
@@ -3078,10 +3077,9 @@ ghost defer-defer@ 
ghost named>string

ghost named>link

2drop

ghost (noname->comp)

ghost noname>string

ghost noname>link

2drop drop

2drop

ghost value-to

ghost umethod,

2drop
@@ -3102,7 +3100,7 @@ Create vttemplate 
0 ,

findghost :, ,

findghost no-to ,

findghost default-name>int ,

findghost noop ,

findghost default-name>comp ,

findghost no-defer@ ,

findghost named>string ,
@@ -3149,13 +3147,13 @@ End-Struct vtable-struct 
: vt-template, ( -- )

    T here 0 A, H vttemplate ! ;

:noname ( -- )

    [G'] default-name>int  vttemplate g>vt>int !

    [G'] noop              vttemplate g>vt>int !

    [G'] default-name>comp vttemplate g>vt>comp !

    [G'] named>string      vttemplate g>vt>string !

    [G'] named>link        vttemplate g>vt>link ! ; is vt-named

:noname ( -- )

    [G'] noop              vttemplate g>vt>int !

    [G'] (noname->comp)    vttemplate g>vt>comp !

    [G'] default-name>comp vttemplate g>vt>comp !

    [G'] noname>string     vttemplate g>vt>string !

    [G'] noname>link       vttemplate g>vt>link ! ; is vt-noname

: vt-populate ( -- )

kernel/comp.fs

+26 −22
Original line number Diff line number Diff line
@@ -310,9 +310,8 @@ has? primcentric [IF] 


\ \ ticks



: default-name>comp ( nt -- w xt ) \ gforth name-to-comp

' compile, AConstant default-name>comp ( nt -- w xt ) \ gforth default-name-to-comp

    \G @i{w xt} is the compilation token for the word @i{nt}.

    name>int ['] compile, ;



: [(')]  ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick

    (') postpone Literal ; immediate restrict
@@ -395,15 +394,11 @@ include ./recognizer.fs 


\ \ Create Variable User Constant                        	17mar93py



\ : a>comp ( nt -- xt1 xt2 )  name>int ['] compile, ;



: defer@, ( xt -- )

    dup lit, >namevt @ >vtdefer@ @ opt-compile, ;



: a>int ( nt -- )  >body @ ;

: a>comp ( nt -- xt1 xt2 )  name>int ['] compile, ;

\ dup >r >body @

\    ['] execute ['] compile, r> >f+c @ immediate-mask and select ;



: s>int ( nt -- xt )  >body @ name>int ;

: s>comp ( nt -- xt1 xt2 )  >body @ name>comp ;
@@ -415,22 +410,31 @@ opt: ( xt -- ) ?fold-to >body @ (to), ; 
opt: ( xt -- ) ?fold-to >body @ defer@, ;

: s-compile, ( xt -- )  >body @ compile, ;



: Alias    ( xt "name" -- ) \ gforth

: (synonym) ( ... xt "name" -- ) \ gforth

    Header reveal ['] on vtcopy  dodefer,

    ['] a>int set->int ['] a>comp set->comp ['] s-to set-to

    ['] s-defer@ set-defer@  ['] s-compile, set-optimizer

    dup A, lastcfa ! ;

    execute A,

    ['] s-to       set-to

    ['] s-defer@   set-defer@

    ['] s-compile, set-optimizer

    lastcfa ! ;



: make-alias ( xt -- last xt )

    ['] a>int set->int ['] a>comp set->comp  dup ;



: Alias    ( xt "name" -- ) \ gforth

    ['] make-alias (synonym) ;



: alias? ( nt -- flag )

    >namevt @ >vt>int 2@ ['] a>comp ['] a>int d= ;



: Synonym ( "name" "oldname" -- ) \ Forth200x

    Header reveal  ['] on vtcopy

: make-synonym ( "name" -- last xt )

    ?parse-name find-name dup 0= #-13 and throw

    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

    ['] s-defer@ set-defer@  ['] s-compile, set-optimizer ;

    ['] s>int set->int ['] s>comp set->comp

    dup compile-only? IF  compile-only  THEN

    dup name>int swap ;



: Synonym ( "name" "oldname" -- ) \ Forth200x

    ['] make-synonym (synonym) ;



: synonym? ( nt -- flag )

    >namevt @ >vt>int 2@ ['] s>comp ['] s>int d= ;
@@ -540,7 +544,7 @@ Create vttemplate 
' no-to A,             \ to field

' no-defer@ A,         \ defer@

0 A,                   \ extra field

' default-name>int A,  \ name>int field

' noop A,  \ name>int field

' default-name>comp A, \ name>comp field

' named>string A,      \ name>string field

' named>link A,        \ name>link field
@@ -724,7 +728,6 @@ defer 0-adjust-locals-size ( -- ) 
    \ by ;-hook before this stuff here is processed).

    ['] noop defstart ;



: (noname->comp) ( nt -- nt xt )  ['] compile, ;

: (:noname) ( -- colon-sys )

    \ common factor of : and :noname

    docol, colon-sys ] :-hook ( unlocal-state off ) ;
@@ -733,16 +736,17 @@ defer 0-adjust-locals-size ( -- ) 
    free-old-local-names

    Header (:noname) ;



: default-i/c ( -- )

    ['] noop set->int

    ['] default-name>comp set->comp ;

: noname-vt ( -- )

    \G modify vt for noname words

    ['] noop set->int

    ['] (noname->comp) set->comp

    default-i/c

    ['] noname>string set-name>string

    ['] noname>link set-name>link ;

: named-vt ( -- )

    \G modify vt for named words

    ['] default-name>int set->int

    ['] default-name>comp set->comp

    default-i/c

    ['] named>string set-name>string

    ['] named>link set-name>link ;

: ?noname-vt ( -- ) last @ 0= IF  noname-vt  ELSE  named-vt  THEN ;

minos2/actors.fs

+4 −2
Original line number Diff line number Diff line
@@ -83,8 +83,10 @@ end-class click-actor 
    rot >o click-actor new >o to data is ck-action o o> !act o o> ;



:noname ( rx ry b n -- )

    fdrop fdrop 2 = swap 1 <= and IF

	click( o hex. ." is clicked, do-action " action-of ck-action xt-see cr )

    fdrop fdrop 1 and 0= swap 1 <= and IF  do-action  THEN

	do-action

    THEN

; click-actor is clicked

:noname ( ukeyaddr u -- )

    bounds ?DO  I c@ bl = IF  do-action  THEN