Commit c0e4b37b authored by Bernd Paysan's avatar Bernd Paysan

postpone> now really does the whole postponing action

parent f3042776
......@@ -1110,6 +1110,7 @@ Ghost lit+ drop
Ghost does-exec drop
Ghost extra-exec drop
Ghost no-to drop
Ghost post, drop
Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop
Ghost :dovar Ghost dovar-vt Ghost dodoes-vt 2drop drop
......@@ -2918,7 +2919,7 @@ Create vttemplate vtsize allot
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'] post, T >vtable :noname H drop ;
>CROSS
\ instantiate deferred extra, now
......@@ -2933,7 +2934,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 [T'] no-to created T vtable, here H
[T'] extra, [T'] post, [T'] no-to created T vtable, here H
tlastcfa @ t>namevt >tempdp
created >do:ghost @ >exec2 @ addr, tempdp>
tlastcfa @ >tempdp [G'] :doextra (doer,) tempdp> ;
......
......@@ -153,7 +153,7 @@ si-prefixes count bl scan drop Constant zero-exp
[ifdef] r:fail
: r:fnumber ;
compile> drop postpone Fliteral ;
postpone> postpone Fliteral ;
postpone> >r postpone Fliteral r> post, ;
: fnum-recognizer ( addr u -- float int-table | r:fail )
prefix-number
......
......@@ -457,7 +457,7 @@ compile> drop ['] !extra does>-like :-hook ;
\ compile> to define compile, action
Create vttemplate 0 A, ' peephole-compile, A, ' noop A, 0 A, ' no-to A, \ initialize to one known vt
Create vttemplate 0 A, ' peephole-compile, A, ' post, A, 0 A, ' no-to A, \ initialize to one known vt
: vtcopy, ( xt -- ) \ gforth vtcopy-comma
vttemplate here >namevt !
......@@ -487,7 +487,7 @@ Create vttemplate 0 A, ' peephole-compile, A, ' noop A, 0 A, ' no-to A, \ initia
nip reveal does>-like drop start-xt drop ;
: !compile, ( xt -- ) vttemplate >vtcompile, ! ;
: !postpone, ( xt -- ) vttemplate >vtpostpone ! ;
: !postpone ( xt -- ) vttemplate >vtpostpone ! ;
: !to ( xt -- ) vttemplate >vtto ! ;
: compile> ( -- colon-sys )
......@@ -495,8 +495,8 @@ Create vttemplate 0 A, ' peephole-compile, A, ' noop A, 0 A, ' no-to A, \ initia
compile> ['] !compile, start-xt-like ; ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ gforth compile-to
: postpone> ( -- colon-sys )
start-xt !postpone, ;
compile> ['] !postpone, start-xt-like ; ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ gforth lit-to
start-xt !postpone ;
compile> ['] !postpone start-xt-like ; ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ gforth lit-to
\ defer and friends
......
......@@ -25,6 +25,8 @@
has? new-does [IF]
: extra, ['] extra-exec peephole-compile, , ;
: >comp ( xt -- ) name>comp execute ;
: post, ( xt -- ) lit, postpone >comp ;
: no-to ( -- ) -32 throw ;
compile> -32 throw ;
[THEN]
......
......@@ -36,17 +36,21 @@
: lit, ( n -- ) postpone Literal ;
: >int ( token table -- ) name>int execute ;
: >postpone ( token table -- )
dup (name>x) drop >namevt @ >vtpostpone perform ;
: word-recognizer ( addr u -- xt | r:fail )
find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ]
dup 0= IF drop ['] r:fail THEN ;
:noname ( n xt -- ) drop postpone Literal ;
:noname ( n -- ) postpone Literal ;
:noname ( n xt -- ) >r postpone Literal r> post, ;
: r:num ;
>vtable
:noname ( d xt -- ) drop postpone 2Literal ;
:noname ( d -- ) postpone 2Literal ;
:noname ( d xt -- ) >r postpone 2Literal r> post, ;
: r:2num ;
>vtable
......@@ -111,12 +115,6 @@ Variable forth-recognizer
\G Enter compilation state.
['] compiler-r IS parser1 state on ;
: >int ( token table -- ) name>int execute ;
: >comp ( xt -- ) name>comp execute ;
: >postpone ( token table -- )
dup >r (name>x) drop >namevt @ >vtpostpone perform
r> lit, postpone >comp ;
: postpone ( "name" -- ) \ core
\g Compiles the compilation semantics of @i{name}.
parse-name forth-recognizer do-recognizer >postpone
......
......@@ -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 ' value! vtable: Value
:noname >body @ ['] lit peephole-compile, , ; ' noop ' no-to vtable: Constant
:noname >body ['] lit@ peephole-compile, , ; ' post, ' value! vtable: Value
:noname >body @ ['] lit peephole-compile, , ; ' post, ' no-to vtable: Constant
:noname >body 2@ swap
['] lit peephole-compile, ,
['] 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
['] lit peephole-compile, , ; ' post, ' no-to vtable: 2Constant
:noname >body ['] call peephole-compile, , ; ' post, ' no-to vtable: :-dummy
:noname >body ['] lit peephole-compile, , ; ' post, ' no-to vtable: Variable
:noname >body @ ['] useraddr peephole-compile, , ; ' post, ' no-to vtable: User
:noname >body ['] lit-perform peephole-compile, , ; ' post, ' value! vtable: Defer
:noname >body @ ['] lit+ peephole-compile, , ; ' post, ' no-to vtable: Field
:noname >body ['] abi-call peephole-compile, , ; ' post, ' no-to vtable: (abi-code)
:noname ['] ;abi-code-exec peephole-compile, , ; ' post, ' no-to vtable: (;abi-code)
' peephole-compile, ' post, ' no-to vtable: prim-dummy
:noname ['] does-exec peephole-compile, , ; ' post, ' no-to vtable: does>-dummy
' extra, ' post, ' no-to vtable: extra>-dummy
AVariable vtable-list
......@@ -19,7 +19,7 @@
: r:to (int-to) ;
compile> drop (comp-to) ;
postpone> lit, ;
postpone> >r lit, r> post, ;
: to-recognizer ( addr u -- xt r:to | r:fail )
2dup s" ->" string-prefix? 0= IF 2drop ['] r:fail EXIT THEN
......
......@@ -21,7 +21,7 @@
: r:string ;
compile> drop slit, ;
postpone> slit, ;
postpone> >r slit, r> post, ;
: string-recognizer ( addr u -- addr u' r:string | r:fail )
2dup s\" \"" string-prefix?
......
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