Commit a25b7dfc authored by Bernd Paysan's avatar Bernd Paysan

newTO works, not yet replaced TO

parent c12e9951
......@@ -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,30 +2895,30 @@ 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 ;
T cfalign here vtsize cell+ H + [T'] noop T >vtable :noname H drop ;
>CROSS
\ instantiate deferred extra, now
......@@ -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> ;
......
......@@ -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,11 +501,19 @@ 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}.
......@@ -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 ;
......
......@@ -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 ...
......
......@@ -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
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