Factor common parts of synonym/alias

parent cf978224
Pipeline #820 passed with stage
in 8 minutes and 16 seconds
...@@ -3065,9 +3065,8 @@ ghost abi-code, ...@@ -3065,9 +3065,8 @@ ghost abi-code,
2drop 2drop
ghost ;abi-code, ghost ;abi-code,
drop drop
ghost default-name>int
ghost default-name>comp ghost default-name>comp
2drop drop
ghost i/c>int ghost i/c>int
ghost i/c>comp ghost i/c>comp
2drop 2drop
...@@ -3078,10 +3077,9 @@ ghost defer-defer@ ...@@ -3078,10 +3077,9 @@ ghost defer-defer@
ghost named>string ghost named>string
ghost named>link ghost named>link
2drop 2drop
ghost (noname->comp)
ghost noname>string ghost noname>string
ghost noname>link ghost noname>link
2drop drop 2drop
ghost value-to ghost value-to
ghost umethod, ghost umethod,
2drop 2drop
...@@ -3102,7 +3100,7 @@ Create vttemplate ...@@ -3102,7 +3100,7 @@ Create vttemplate
0 , 0 ,
findghost :, , findghost :, ,
findghost no-to , findghost no-to ,
findghost default-name>int , findghost noop ,
findghost default-name>comp , findghost default-name>comp ,
findghost no-defer@ , findghost no-defer@ ,
findghost named>string , findghost named>string ,
...@@ -3149,13 +3147,13 @@ End-Struct vtable-struct ...@@ -3149,13 +3147,13 @@ End-Struct vtable-struct
: vt-template, ( -- ) : vt-template, ( -- )
T here 0 A, H vttemplate ! ; T here 0 A, H vttemplate ! ;
:noname ( -- ) :noname ( -- )
[G'] default-name>int vttemplate g>vt>int ! [G'] noop vttemplate g>vt>int !
[G'] default-name>comp vttemplate g>vt>comp ! [G'] default-name>comp vttemplate g>vt>comp !
[G'] named>string vttemplate g>vt>string ! [G'] named>string vttemplate g>vt>string !
[G'] named>link vttemplate g>vt>link ! ; is vt-named [G'] named>link vttemplate g>vt>link ! ; is vt-named
:noname ( -- ) :noname ( -- )
[G'] noop vttemplate g>vt>int ! [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>string vttemplate g>vt>string !
[G'] noname>link vttemplate g>vt>link ! ; is vt-noname [G'] noname>link vttemplate g>vt>link ! ; is vt-noname
: vt-populate ( -- ) : vt-populate ( -- )
......
...@@ -310,9 +310,8 @@ has? primcentric [IF] ...@@ -310,9 +310,8 @@ has? primcentric [IF]
\ \ ticks \ \ 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}. \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 : [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
(') postpone Literal ; immediate restrict (') postpone Literal ; immediate restrict
...@@ -395,15 +394,11 @@ include ./recognizer.fs ...@@ -395,15 +394,11 @@ include ./recognizer.fs
\ \ Create Variable User Constant 17mar93py \ \ Create Variable User Constant 17mar93py
\ : a>comp ( nt -- xt1 xt2 ) name>int ['] compile, ;
: defer@, ( xt -- ) : defer@, ( xt -- )
dup lit, >namevt @ >vtdefer@ @ opt-compile, ; dup lit, >namevt @ >vtdefer@ @ opt-compile, ;
: a>int ( nt -- ) >body @ ; : a>int ( nt -- ) >body @ ;
: a>comp ( nt -- xt1 xt2 ) name>int ['] compile, ; : 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>int ( nt -- xt ) >body @ name>int ;
: s>comp ( nt -- xt1 xt2 ) >body @ name>comp ; : s>comp ( nt -- xt1 xt2 ) >body @ name>comp ;
...@@ -415,22 +410,31 @@ opt: ( xt -- ) ?fold-to >body @ (to), ; ...@@ -415,22 +410,31 @@ opt: ( xt -- ) ?fold-to >body @ (to), ;
opt: ( xt -- ) ?fold-to >body @ defer@, ; opt: ( xt -- ) ?fold-to >body @ defer@, ;
: s-compile, ( xt -- ) >body @ compile, ; : s-compile, ( xt -- ) >body @ compile, ;
: Alias ( xt "name" -- ) \ gforth : (synonym) ( ... xt "name" -- ) \ gforth
Header reveal ['] on vtcopy dodefer, Header reveal ['] on vtcopy dodefer,
['] a>int set->int ['] a>comp set->comp ['] s-to set-to execute A,
['] s-defer@ set-defer@ ['] s-compile, set-optimizer ['] s-to set-to
dup A, lastcfa ! ; ['] 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 ) : alias? ( nt -- flag )
>namevt @ >vt>int 2@ ['] a>comp ['] a>int d= ; >namevt @ >vt>int 2@ ['] a>comp ['] a>int d= ;
: Synonym ( "name" "oldname" -- ) \ Forth200x : make-synonym ( "name" -- last xt )
Header reveal ['] on vtcopy
?parse-name find-name dup 0= #-13 and throw ?parse-name find-name dup 0= #-13 and throw
dodefer, dup A, ['] s>int set->int ['] s>comp set->comp
dup compile-only? IF compile-only THEN name>int lastcfa ! dup compile-only? IF compile-only THEN
['] s>int set->int ['] s>comp set->comp ['] s-to set-to dup name>int swap ;
['] s-defer@ set-defer@ ['] s-compile, set-optimizer ;
: Synonym ( "name" "oldname" -- ) \ Forth200x
['] make-synonym (synonym) ;
: synonym? ( nt -- flag ) : synonym? ( nt -- flag )
>namevt @ >vt>int 2@ ['] s>comp ['] s>int d= ; >namevt @ >vt>int 2@ ['] s>comp ['] s>int d= ;
...@@ -540,7 +544,7 @@ Create vttemplate ...@@ -540,7 +544,7 @@ Create vttemplate
' no-to A, \ to field ' no-to A, \ to field
' no-defer@ A, \ defer@ ' no-defer@ A, \ defer@
0 A, \ extra field 0 A, \ extra field
' default-name>int A, \ name>int field ' noop A, \ name>int field
' default-name>comp A, \ name>comp field ' default-name>comp A, \ name>comp field
' named>string A, \ name>string field ' named>string A, \ name>string field
' named>link A, \ name>link field ' named>link A, \ name>link field
...@@ -724,7 +728,6 @@ defer 0-adjust-locals-size ( -- ) ...@@ -724,7 +728,6 @@ defer 0-adjust-locals-size ( -- )
\ by ;-hook before this stuff here is processed). \ by ;-hook before this stuff here is processed).
['] noop defstart ; ['] noop defstart ;
: (noname->comp) ( nt -- nt xt ) ['] compile, ;
: (:noname) ( -- colon-sys ) : (:noname) ( -- colon-sys )
\ common factor of : and :noname \ common factor of : and :noname
docol, colon-sys ] :-hook ( unlocal-state off ) ; docol, colon-sys ] :-hook ( unlocal-state off ) ;
...@@ -733,16 +736,17 @@ defer 0-adjust-locals-size ( -- ) ...@@ -733,16 +736,17 @@ defer 0-adjust-locals-size ( -- )
free-old-local-names free-old-local-names
Header (:noname) ; Header (:noname) ;
: default-i/c ( -- )
['] noop set->int
['] default-name>comp set->comp ;
: noname-vt ( -- ) : noname-vt ( -- )
\G modify vt for noname words \G modify vt for noname words
['] noop set->int default-i/c
['] (noname->comp) set->comp
['] noname>string set-name>string ['] noname>string set-name>string
['] noname>link set-name>link ; ['] noname>link set-name>link ;
: named-vt ( -- ) : named-vt ( -- )
\G modify vt for named words \G modify vt for named words
['] default-name>int set->int default-i/c
['] default-name>comp set->comp
['] named>string set-name>string ['] named>string set-name>string
['] named>link set-name>link ; ['] named>link set-name>link ;
: ?noname-vt ( -- ) last @ 0= IF noname-vt ELSE named-vt THEN ; : ?noname-vt ( -- ) last @ 0= IF noname-vt ELSE named-vt THEN ;
......
...@@ -83,8 +83,10 @@ end-class click-actor ...@@ -83,8 +83,10 @@ end-class click-actor
rot >o click-actor new >o to data is ck-action o o> !act o o> ; rot >o click-actor new >o to data is ck-action o o> !act o o> ;
:noname ( rx ry b n -- ) :noname ( rx ry b n -- )
click( o hex. ." is clicked, do-action " action-of ck-action xt-see cr ) fdrop fdrop 2 = swap 1 <= and IF
fdrop fdrop 1 and 0= swap 1 <= and IF do-action THEN click( o hex. ." is clicked, do-action " action-of ck-action xt-see cr )
do-action
THEN
; click-actor is clicked ; click-actor is clicked
:noname ( ukeyaddr u -- ) :noname ( ukeyaddr u -- )
bounds ?DO I c@ bl = IF do-action THEN bounds ?DO I c@ bl = IF do-action THEN
......
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