More work on replacing DOES> with EXTRA>

parent f72a2f8d
Pipeline #659 passed with stage
in 8 minutes and 47 seconds
......@@ -830,7 +830,6 @@ Plugin doer,
Plugin fini, \ compiles end of definition ;s
Plugin doeshandler,
Plugin dodoes,
Plugin dodoesxt,
Plugin colon-start
' noop plugin-of colon-start
......@@ -1193,13 +1192,14 @@ Ghost lit-perform drop
Ghost lit+ drop
Ghost does-exec drop
Ghost extra-exec drop
Ghost extra-xt drop
Ghost does-xt drop
Ghost no-to drop
Ghost refill drop
Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop
Ghost :dovar drop
Ghost :dodoesxt Ghost :doextraxt 2drop
Ghost :doextraxt drop
\ \ Parameter for target systems 06oct92py
......@@ -2592,11 +2592,6 @@ 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,
: doextraxt, ( -- )
]comp [G'] :doextraxt addr, comp[
0 addr,
......@@ -2828,10 +2823,10 @@ Cond: [ ( -- ) interpreting-state ;Cond
0 Value created
Ghost does, drop
Ghost doesxt, drop
Defer gset-optimizer
Defer gset-extra
: !does ( does-action -- )
tlastcfa @ [G'] :dovar killref
[G'] does, gset-optimizer
......@@ -2851,7 +2846,7 @@ X has? primcentric [IF]
: does-resolved ( ghost -- )
compile does-exec g>xt T a, H ;
: extra-resolved ( ghost -- )
compile extra-exec g>xt T a, H ;
compile extra-xt g>xt T a, H ;
[ELSE]
: does-resolved ( ghost -- )
g>xt T a, H ;
......@@ -2871,17 +2866,17 @@ Cond: DOES>
;Cond
Cond: EXTRA>
T here cfaligned H [ T has? primcentric H [IF] ] 8 [ [ELSE] ] 7 [ [THEN] ] T cells
H + alit, compile !extraxt [compile] ;
T :noname H resolve-does>-part
H + alit, compile !extraxt compile ;
T :noname H 2drop depth resolve-does>-part
;Cond
: DOES>
: oldDOES>
['] does-resolved created >comp !
switchrom doeshandler, T here H !does
instant-interpret-does>-hook
depth ;Resolve off T ] H ;
: EXTRA>
: DOES>
['] extra-resolved created >comp !
T here cfaligned #10 cells H \ includes noname header+vtable
+ !newdoes
......@@ -3146,7 +3141,7 @@ End-Struct vtable-struct
: gset-to ( ghost -- ) vttemplate >vtto ! ;
: gset-defer@ ( ghost -- ) vttemplate >vtdefer@ ! ;
: gset->comp ( ghost -- ) vttemplate >vt>comp ! ;
: gset-extra ( ghost -- ) vttemplate >vtextra ! ;
:noname ( ghost -- ) vttemplate >vtextra ! ; is gset-extra
: set-optimizer ( xt -- ) xt>ghost vttemplate >vtcompile, ! ;
: set-to ( xt -- ) xt>ghost vttemplate >vtto ! ;
......@@ -3258,12 +3253,6 @@ by: :dodoes ;DO
vt: [G'] does, gset-optimizer ;vt
\ vtghost: dodoes-vt
Builder doesxt>-dummy
Build: ;Build
by: :dodoesxt ;DO
vt: [G'] doesxt, gset-optimizer ;vt
\ vtghost: dodoesxt-vt
Builder extraxt>-dummy
Build: ;Build
by: :doextraxt ;DO
......
......@@ -544,7 +544,6 @@ opt: drop ( xt -- )
[ has? peephole [IF] ] finish-code [ [THEN] ]
defstart ;
extraxt>-dummy (doextraxt-dummy)
: !extraxt ( addr -- ) \ gforth store-extra
created?
IF
......@@ -618,7 +617,6 @@ Create vttemplate
: set->int ( xt -- ) vttemplate >vt>int ! ;
: set->comp ( xt -- ) vttemplate >vt>comp ! ;
: set-does> ( xt -- ) !extraxt ; \ more work than the aboves
: set-doesxt> ( xt -- ) !doesxt ; \ more work than the aboves
:noname ( -- colon-sys ) start-xt set-optimizer ;
:noname ['] set-optimizer start-xt-like ;
......@@ -763,19 +761,12 @@ defer 0-adjust-locals-size ( -- )
\ does>
: doesxt, ( xt -- ) postpone does-xt , ;
\ dup >body postpone literal cell+ @ compile, ;
: !doesxt ( xt -- ) \ gforth store-doesxt
latestxt doesxt-code!
['] doesxt, set-optimizer ;
: created? ( -- flag )
vttemplate >vtcompile, @ ['] udp >namevt @ >vtcompile, @ = ;
: !does ( addr -- ) \ gforth store-does
created? IF
['] spaces >namevt @ >vtcompile, @ set-optimizer
['] does, set-optimizer
THEN
latestxt does-code! ;
......
......@@ -59,10 +59,10 @@ doer? :dofield [IF]
['] >body vtcopy, ;
[THEN]
true [IF] \ !! don't know what to put here
doer? :dodoes [IF]
: dodoes: ( -- addr ) \ gforth
\G The code address of a @code{DOES>}-defined word.
['] spaces >code-address ;
['] (does-dummy) >code-address ;
[THEN]
doer? :doabicode [IF]
......
......@@ -61,19 +61,13 @@ doer? :dofield [IF]
['] >body >code-address ;
[THEN]
true [IF] \ !! don't know what to put here
doer? :dodoes [IF]
does>-dummy (does-dummy)
: dodoes: ( -- addr ) \ gforth
\G The code address of a @code{DOES>}-defined word.
['] spaces >code-address ;
['] (does-dummy) >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)
: doabicode: ( -- addr ) \ gforth
......@@ -87,14 +81,8 @@ doer? :do;abicode [IF]
['] (;abi-code-dummy) >code-address ;
[THEN]
doer? :doextra [IF]
\ extra>-dummy (doextra-dummy)
: doextra: ( -- addr )
['] (doextra-dummy) >code-address ;
[THEN]
doer? :doextraxt [IF]
\ extra>-dummy (doextra-dummy)
extraxt>-dummy (doextraxt-dummy)
: doextraxt: ( -- addr )
['] (doextraxt-dummy) >code-address ;
[THEN]
......@@ -541,14 +541,11 @@ cell% -2 * 0 0 field body> ( xt -- a_addr )
\G Otherwise @i{a-addr} is 0.
dup @ dodoes: = if
cell+ @
else dup @ dodoesxt: = if
cell+ @ >body
else
dup @ doextraxt: = IF
>namevt @ >vtextra @ >body
ELSE
drop 0
THEN
else
dup @ doextraxt: = if
>namevt @ >vtextra @ >body
else
drop 0
then
endif ;
......@@ -565,14 +562,7 @@ cell% -2 * 0 0 field body> ( xt -- a_addr )
\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+ ! ;
\ body> extra-xt! ;
: extra-xt! ( xt1 xt2 -- ) \ gforth
\G Create a code field at @i{xt2} for a child of a @code{DOES>}-word;
......
......@@ -183,7 +183,7 @@ bl 80 times \ times from target compiler! 11may93jaw
DOES> ( u -- ) spaces-loop ;
Create backspaces
08 80 times \ times from target compiler! 11may93jaw
EXTRA> ( u -- ) over 2* negate out +! spaces-loop ;
DOES> ( u -- ) over 2* negate out +! spaces-loop ;
hex
Defer deadline ( d -- )
......
......@@ -21,8 +21,8 @@ require ./vars.fs
include ./input-class.fs
include ./int.fs
has? compiler [IF]
include ./comp.fs
include ./vtables.fs
include ./comp.fs
[THEN]
include ./accept.fs
include ./input.fs
......
......@@ -40,13 +40,13 @@
\ cross-compiler does not implement them).
>body cell+ (uv) ! ;
opt: ( xt-method xt-to -- )
drop >body cell+ postpone Aliteral postpone (uv) postpone ! ;
drop >body cell+ lit, postpone (uv) postpone ! ;
: umethod@ ( addr -- xt )
\ this is not a proper word, but a DEFER@: OPT-DEFER@: word (but
\ the cross-compiler does not implement them).
>body cell+ (uv) @ ;
opt: ( xt-method xt-defer@ -- )
drop >body cell+ postpone Aliteral postpone (uv) postpone @ ;
drop >body cell+ lit, postpone (uv) postpone @ ;
AVariable vtable-list
......@@ -707,8 +707,9 @@ VARIABLE C-Pass
CREATE C-Table \ primitives map to code only
' lit A, ' c-lit A,
' does-exec A, ' c-callxt A,
[IFDEF] does-xt ' does-xt A, ' c-callxt A,
' extra-exec A, ' c-callxt A,
[IFDEF] does-xt ' does-xt A, ' c-callxt A, [THEN]
[IFDEF] extra-exec ' extra-exec A, ' c-callxt A, [THEN]
[IFDEF] extra-xt ' extra-xt A, ' c-callxt A, [THEN]
' lit@ A, ' c-call A,
[IFDEF] call ' call A, ' c-call A, [THEN]
[IFDEF] call-loc ' call-loc A, ' c-call A, [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