Commit a25b7dfc authored by Bernd Paysan's avatar Bernd Paysan
Browse files

newTO works, not yet replaced TO

parent c12e9951

cross.fs

+10 −9
Original line number Diff line number Diff line
@@ -1109,6 +1109,7 @@ Ghost lit-perform drop 
Ghost lit+ drop

Ghost does-exec drop

Ghost extra-exec drop

Ghost no-to drop



Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop

Ghost :dovar	Ghost dovar-vt	Ghost dodoes-vt	2drop drop
@@ -2894,27 +2895,27 @@ Create vttemplate vtsize allot 
    REPEAT  drop (vt,) ;



>TARGET

: vtable, ( compile-xt tokenize-xt ghost -- )

: vtable, ( compile-xt tokenize-xt to-xt ghost -- )

    >r tvtable-list @ T here swap A, H tvtable-list !

    swap T A, A, H

    swap rot T A, A, H

    r> dup IF

	dup >do:ghost @ >magic @ <do:> <> IF

	    ." vtable: " dup >ghostname type space

	    dup >magic @ hex. space

	    >do:ghost @  dup >ghostname type space

	    dup >magic @ hex. cr

	    addr,  T 0 A, H EXIT

	    addr,  T A, H EXIT

	THEN

    THEN

    drop  T 0 A, 0 A, H

    ( extra field for dodoes ) ;

    T A, A, H

    ( extra field for dodoes, to-field ) ;



: vtable: ( compile-xt tokenize-xt "name" -- )

: vtable: ( compile-xt tokenize-xt to-xt "name" -- )

    Ghost dup >do:ghost @ >exec2 @ hereresolve T vtable, H ;



: >vtable ( compile-xt tokenize-xt -- )

    T here H lastxt T 0 cell+ H -

    dup [G'] docol-vt killref T ! 0 vtable, H ;

    dup [G'] docol-vt killref T ! H [T'] no-to 0 T vtable, H ;



: compile> ( -- colon-sys )

    T cfalign here vtsize cell+ H + [T'] noop  T >vtable :noname H drop ;
@@ -2932,7 +2933,7 @@ Create vttemplate vtsize allot 
    r@ created >do:ghost @ >exec2 !

    T align H r> hereresolve

    r> T here vtsize H + resolve

    [T'] extra, [T'] noop created T vtable, here H

    [T'] extra, [T'] noop [T'] no-to created T vtable, here H

    tlastcfa @ t>namevt >tempdp

    created >do:ghost @ >exec2 @ addr, tempdp>

    tlastcfa @ >tempdp [G'] :doextra (doer,) tempdp> ;

kernel/comp.fs

+19 −10
Original line number Diff line number Diff line
@@ -443,14 +443,13 @@ defer defer-default ( -- ) 
    [ has? peephole [IF] ] finish-code [ [THEN] ]

    defstart ;



: !does    ( addr -- ) \ gforth	store-does

    ['] spaces >namevt @ >vtcompile, @ vttemplate >vtcompile, !

    latestxt does-code! ;

\ : !does    ( addr -- ) \ gforth	store-does

\     ['] spaces >namevt @ >vtcompile, @ !compile,

\     latestxt does-code! ;



extra>-dummy (doextra-dummy)

: !extra   ( addr -- ) \ gforth store-extra

    ['] (doextra-dummy) >namevt @ >vtcompile, @ vttemplate >vtcompile, !

    latestxt extra-code! ;

    ['] extra, !compile,  latestxt extra-code! ;



: DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core        extra

    vt, cfalign 0 , here !extra ] defstart :-hook ;
@@ -458,10 +457,7 @@ compile> drop ['] !extra does>-like :-hook ; 


\ compile> to define compile, action



: vtable, ( compile,-xt tokenize-xt -- )

    here vtable-list @ , vtable-list ! swap , , 0 , ;



Create vttemplate 0 A, ' peephole-compile, A, ' noop A, 0 A, \ initialize to one known vt

Create vttemplate 0 A, ' peephole-compile, A, ' noop A, 0 A, ' no-to A, \ initialize to one known vt



: vtcopy,     ( xt -- )  \ gforth	vtcopy-comma

    vttemplate here >namevt !
@@ -495,6 +491,7 @@ Create vttemplate 0 A, ' peephole-compile, A, ' noop A, 0 A, \ initialize to one 


: !compile, ( xt -- ) vttemplate >vtcompile, ! ;

: !lit,     ( xt -- ) vttemplate >vtlit, ! ;

: !to       ( xt -- ) vttemplate >vtto ! ;



: compile> ( -- colon-sys )

    start-xt  !compile, ;
@@ -504,12 +501,20 @@ compile> ['] !compile, start-xt-like ; ( compilation colon-sys1 -- colon-sys2 ; 
    start-xt  !lit, ;

compile> ['] !lit,     start-xt-like ;  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ gforth        lit-to



: to> ( -- colon-sys )

    start-xt  !to ;

compile> ['] !to       start-xt-like ;  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ gforth        to-to



\ defer and friends



: defer! ( xt xt-deferred -- ) \ gforth  defer-store

\G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}.

    >body ! ;



: value! ( xt xt-deferred -- ) \ gforth  defer-store

    >body ! ;

compile> drop >body postpone ALiteral postpone ! ;

    

: <IS> ( "name" xt -- ) \ gforth

    \g Changes the @code{defer}red word @var{name} to execute @var{xt}.

    record-name ' defer! ;
@@ -522,7 +527,11 @@ compile> ['] !lit, start-xt-like ; ( compilation colon-sys1 -- colon-sys2 ; 
: IS <IS> ;

compile> drop postpone [IS] ;



' IS Alias TO

' IS alias TO



: newTO ( value "name" -- )

    ' dup >namevt @ >vtto perform ;

compile> drop ' dup >namevt @ >vtto @ compile, ;



: interpret/compile? ( xt -- flag ) drop false ;

kernel/int.fs

+2 −0
Original line number Diff line number Diff line
@@ -25,6 +25,8 @@ 


has? new-does [IF]

    : extra, ['] extra-exec peephole-compile, , ;

    : no-to ( -- )  -32 throw ;

    compile> -32 throw ;

[THEN]



require ./basics.fs 	\ bounds decimal hex ...

kernel/vtables.fs

+13 −13
Original line number Diff line number Diff line
@@ -17,20 +17,20 @@ 
\ You should have received a copy of the GNU General Public License

\ along with this program. If not, see http://www.gnu.org/licenses/.



:noname >body ['] lit@ peephole-compile, , ;        ' noop vtable: Value

:noname >body @ ['] lit peephole-compile, , ;       ' noop vtable: Constant

:noname >body ['] lit@ peephole-compile, , ;        ' noop ' value! vtable: Value

:noname >body @ ['] lit peephole-compile, , ;       ' noop ' no-to  vtable: Constant

:noname >body 2@ swap

    ['] lit peephole-compile, ,

    ['] lit peephole-compile, , ;                   ' noop vtable: 2Constant    

:noname >body ['] call peephole-compile, , ;        ' noop vtable: :-dummy

:noname >body ['] lit peephole-compile, , ;         ' noop vtable: Variable

:noname >body @ ['] useraddr peephole-compile, , ;  ' noop vtable: User

:noname >body ['] lit-perform peephole-compile, , ; ' noop vtable: Defer

:noname >body @ ['] lit+ peephole-compile, , ;      ' noop vtable: Field

:noname >body ['] abi-call peephole-compile, , ;    ' noop vtable: (abi-code)

:noname ['] ;abi-code-exec peephole-compile, , ;    ' noop vtable: (;abi-code)

' peephole-compile,                                 ' noop vtable: prim-dummy

:noname ['] does-exec peephole-compile, , ;         ' noop vtable: does>-dummy

' extra, ' noop vtable: extra>-dummy

    ['] lit peephole-compile, , ;                   ' noop ' no-to  vtable: 2Constant    

:noname >body ['] call peephole-compile, , ;        ' noop ' no-to  vtable: :-dummy

:noname >body ['] lit peephole-compile, , ;         ' noop ' no-to  vtable: Variable

:noname >body @ ['] useraddr peephole-compile, , ;  ' noop ' no-to  vtable: User

:noname >body ['] lit-perform peephole-compile, , ; ' noop ' value! vtable: Defer

:noname >body @ ['] lit+ peephole-compile, , ;      ' noop ' no-to  vtable: Field

:noname >body ['] abi-call peephole-compile, , ;    ' noop ' no-to  vtable: (abi-code)

:noname ['] ;abi-code-exec peephole-compile, , ;    ' noop ' no-to  vtable: (;abi-code)

' peephole-compile,                                 ' noop ' no-to  vtable: prim-dummy

:noname ['] does-exec peephole-compile, , ;         ' noop ' no-to  vtable: does>-dummy

' extra, ' noop ' no-to vtable: extra>-dummy



AVariable vtable-list