Verified Commit 468de529 authored by Bernd Paysan's avatar Bernd Paysan
Browse files

More work on replacing DOES> with EXTRA>

parent f72a2f8d

cross.fs

+10 −21
Original line number Diff line number Diff line
@@ -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,9 +2823,9 @@ 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
@@ -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

kernel/comp.fs

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

kernel/copydoers.fs

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

kernel/getdoers.fs

+4 −16
Original line number Diff line number Diff line
@@ -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]

kernel/int.fs

+6 −16
Original line number Diff line number Diff line
@@ -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

	dup @ doextraxt: = if

	    >namevt @ >vtextra @ >body

            ELSE

	else

	    drop 0

            THEN

        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;