Commit 8a9a28d7 authored by Anton Ertl's avatar Anton Ertl

set-does> now uses dodoesxt

parent a0078dc2
......@@ -789,6 +789,7 @@ Plugin doer,
Plugin fini, \ compiles end of definition ;s
Plugin doeshandler,
Plugin dodoes,
Plugin dodoesxt,
Plugin colon-start
' noop plugin-of colon-start
......@@ -1120,7 +1121,7 @@ Ghost refill drop
Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop
Ghost :dovar Ghost dovar-vt Ghost dodoes-vt 2drop drop
Ghost :doextra Ghost doextra-vt Ghost extra, 2drop drop
Ghost :docolloc drop
Ghost :docolloc Ghost :dodoesxt 2drop
\ \ Parameter for target systems 06oct92py
......@@ -2483,6 +2484,11 @@ T 2 cells H Value xt>body
addr,
2 fillcfa ; ' (dodoes,) plugin-of dodoes,
: (dodoesxt,) ( does-action-ghost -- )
]comp [G'] :dodoesxt addr, comp[
addr,
2 fillcfa ; ' (dodoesxt,) plugin-of dodoesxt,
: (dlit,) ( n -- ) compile lit td, ; ' (dlit,) plugin-of dlit,
: (lit,) ( n -- ) s>d dlit, ; ' (lit,) plugin-of lit,
......@@ -2708,6 +2714,7 @@ Cond: [ ( -- ) interpreting-state ;Cond
0 Value created
Ghost does, drop
Ghost doesxt, drop
Defer gset-compiler
......@@ -3099,6 +3106,12 @@ by: :dodoes ;DO
vt: [G'] does, gset-compiler ;vt
\ vtghost: dodoes-vt
Builder doesxt>-dummy
Build: ;Build
by: :dodoesxt ;DO
vt: [G'] doesxt, gset-compiler ;vt
\ vtghost: dodoesxt-vt
Builder extra>-dummy
Build: ;Build
by: :doextra ;DO
......
......@@ -494,7 +494,7 @@ Create vttemplate
here >namevt vttemplate ! ;
: vtcopy, ( xt -- ) \ gforth vtcopy-comma
dup vtcopy here >r dup >code-address cfa, >does-code r> cell+ ! ;
dup vtcopy here >r dup >code-address cfa, cell+ @ r> cell+ ! ;
: vtsave ( -- addr u ) \ gforth
\g save vttemplate for nested definitions
......@@ -531,7 +531,8 @@ Create vttemplate
: set-defer@ ( xt -- ) vttemplate >vtdefer@ ! ;
: set->int ( xt -- ) vttemplate >vt>int ! ;
: set->comp ( xt -- ) vttemplate >vt>comp ! ;
: set-does> ( xt -- ) >body !does ; \ more work than the aboves
\ : set-does> ( xt -- ) >body !does ; \ more work than the aboves
: set-does> ( xt -- ) !doesxt ; \ more work than the aboves
:noname ( -- colon-sys )
start-xt set-compiler ;
......@@ -628,6 +629,13 @@ defer ;-hook ( sys2 -- sys1 )
\ does>
: doesxt, ( xt -- )
dup >body postpone literal cell+ @ compile, ;
: !doesxt ( xt -- ) \ gforth store-doesxt
latestxt doesxt-code!
['] doesxt, set-compiler ;
: !does ( addr -- ) \ gforth store-does
vttemplate >vtcompile, @ ['] udp >namevt @ >vtcompile, @ =
IF
......
......@@ -67,6 +67,12 @@ true [IF] \ !! don't know what to put here
['] spaces >code-address ;
[THEN]
doer? :dodoesxt [if]
doesxt>-dummy (doesxt>-dummy)
: dodoesxt: ( -- addr )
\G the code address of a @code{set-does>}-defined word.
['] (doesxt>-dummy) >code-address ;
[then]
doer? :doabicode [IF]
(ABI-CODE) (abi-code-dummy)
......
......@@ -483,12 +483,15 @@ cell% -2 * 0 0 field body> ( xt -- a_addr )
\G Otherwise @i{a-addr} is 0.
dup @ dodoes: = if
cell+ @
else
dup @ doextra: = IF
>namevt @ >vtextra @
ELSE
drop 0
THEN
else dup @ dodoesxt: = if
cell+ @ >body \ >body in case the result is used for does-code!
else
dup @ doextra: = IF
>namevt @ >vtextra @
ELSE
drop 0
THEN
then
endif ;
' ! alias code-address! ( c_addr xt -- ) \ gforth
......@@ -503,6 +506,15 @@ cell% -2 * 0 0 field body> ( xt -- a_addr )
\G Create a code field at @i{xt} for a child of a @code{DOES>}-word;
\G @i{a-addr} is the start of the Forth code after @code{DOES>}.
dodoes: over ! cell+ ! ;
\ after eliminating dodoes:, this changes to
\ body> doesxt-code! ;
: doesxt-code! ( xt1 xt2 -- ) \ gforth
\G Create a code field at @i{xt2} for a child of a
\G @code{SET-DOES>}-word; afterwards, when @i{xt2} is run, its body
\G address is pushed and @i{xt1} is run. Note: This changes only the
\G code field, for correctness you also need to change the compiler
dodoesxt: over ! cell+ ! ;
: extra-code! ( a-addr xt -- ) \ gforth
\G Create a code field at @i{xt} for a child of a @code{EXTRA>}-word;
......
......@@ -835,6 +835,7 @@ c-extender !
ScanMode c-pass ! dup makepass
DisplayMode c-pass ! makepass ;
: seedoes ( xt -- )
\ !! make it work for general xt set-does> words
dup s" create" .defname cr
S" DOES> " Com# .string XPos @ Level !
>does-code see-threaded ;
......
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