version 1.118, 2002/01/05 20:16:17
|
version 1.119, 2002/01/05 22:58:59
|
Line 902 Defer is-forward
|
Line 902 Defer is-forward
|
Defer do-refered |
Defer do-refered |
|
|
: prim-forward ( ghost -- ) |
: prim-forward ( ghost -- ) |
colonmark, 1 do-refered ; \ compile space for call |
colonmark, 0 do-refered ; \ compile space for call |
|
: doer-forward ( ghost -- ) |
|
colonmark, 2 do-refered ; \ compile space for doer |
' prim-forward IS is-forward |
' prim-forward IS is-forward |
|
|
: (ghostheader) ( -- ) |
: (ghostheader) ( -- ) |
Line 1068 Ghost branch Ghost ?branch
|
Line 1070 Ghost branch Ghost ?branch
|
Ghost unloop Ghost ;S 2drop |
Ghost unloop Ghost ;S 2drop |
Ghost lit Ghost ! 2drop |
Ghost lit Ghost ! 2drop |
Ghost noop drop |
Ghost noop drop |
Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop |
|
Ghost :dovar drop |
|
Ghost over Ghost = Ghost drop 2drop drop |
Ghost over Ghost = Ghost drop 2drop drop |
Ghost 2drop drop |
Ghost 2drop drop |
Ghost 2dup drop |
Ghost 2dup drop |
Line 1085 Ghost lit-perform drop
|
Line 1085 Ghost lit-perform drop
|
Ghost lit+ drop |
Ghost lit+ drop |
Ghost does-exec drop |
Ghost does-exec drop |
|
|
|
' doer-forward IS is-forward |
|
|
|
Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop |
|
Ghost :dovar drop |
|
|
|
' prim-forward IS is-forward |
|
|
\ \ Parameter for target systems 06oct92py |
\ \ Parameter for target systems 06oct92py |
|
|
|
|
Line 2183 Defer setup-prim-semantics
|
Line 2190 Defer setup-prim-semantics
|
Ghost tuck swap resolve <do:> swap tuck >magic ! |
Ghost tuck swap resolve <do:> swap tuck >magic ! |
asmprimname, ; |
asmprimname, ; |
|
|
: Alias: ( cfa -- ) \ name |
: Doer: ( cfa -- ) \ name |
>in @ skip? IF 2drop EXIT THEN >in ! |
>in @ skip? IF 2drop EXIT THEN >in ! |
dup 0< s" prims" T $has? H 0= and |
dup 0< s" prims" T $has? H 0= and |
IF |
IF |
.sourcepos ." needs doer: " >in @ bl word count type >in ! cr |
.sourcepos ." needs doer: " >in @ bl word count type >in ! cr |
THEN |
THEN |
Ghost tuck swap resolve <do:> swap >magic ! ; |
Ghost |
|
tuck swap resolve <do:> swap >magic ! ; |
|
|
Variable prim# |
Variable prim# |
: first-primitive ( n -- ) prim# ! ; |
: first-primitive ( n -- ) prim# ! ; |
Line 2199 Variable prim#
|
Line 2207 Variable prim#
|
IF |
IF |
.sourcepos ." needs prim: " >in @ bl word count type >in ! cr |
.sourcepos ." needs prim: " >in @ bl word count type >in ! cr |
THEN |
THEN |
\ ['] prim-forward IS is-forward |
|
prim# @ (THeader ( S xt ghost ) |
prim# @ (THeader ( S xt ghost ) |
dup >ghost-flags <primitive> set-flag |
dup >ghost-flags <primitive> set-flag |
over resolve T A, H alias-mask flag! |
over resolve T A, H alias-mask flag! |
\ ['] call-forward IS is-forward |
|
-1 prim# +! ; |
-1 prim# +! ; |
>CROSS |
>CROSS |
|
|
Line 2287 T 2 cells H Value xt>body
|
Line 2293 T 2 cells H Value xt>body
|
there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) plugin-of doprim, |
there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) plugin-of doprim, |
|
|
: (doeshandler,) ( -- ) |
: (doeshandler,) ( -- ) |
T cfalign H compile :doesjump T 0 , H ; ' (doeshandler,) plugin-of doeshandler, |
T cfalign H [G'] :doesjump addr, T 0 , H ; ' (doeshandler,) plugin-of doeshandler, |
|
|
: (dodoes,) ( does-action-ghost -- ) |
: (dodoes,) ( does-action-ghost -- ) |
]comp [G'] :dodoes gexecute comp[ |
]comp [G'] :dodoes addr, comp[ |
addr, |
addr, |
\ the relocator in the c engine, does not like the |
\ the relocator in the c engine, does not like the |
\ does-address to marked for relocation |
\ does-address to marked for relocation |
Line 2505 Defer instant-interpret-does>-hook
|
Line 2511 Defer instant-interpret-does>-hook
|
|
|
: does-resolved ( ghost -- ) |
: does-resolved ( ghost -- ) |
compile does-exec g>xt T a, H ; |
compile does-exec g>xt T a, H ; |
\ dup g>body alit, >do:ghost @ g>xt 0 t>body - colon, ; |
|
|
|
: resolve-does>-part ( -- ) |
: resolve-does>-part ( -- ) |
\ resolve words made by builders |
\ resolve words made by builders |
Line 2796 T has? peephole H [IF]
|
Line 2801 T has? peephole H [IF]
|
: (callc) compile call T >body a, H ; ' (callc) plugin-of colon, |
: (callc) compile call T >body a, H ; ' (callc) plugin-of colon, |
: (call-res) >tempdp resolved gexecute tempdp> drop ; |
: (call-res) >tempdp resolved gexecute tempdp> drop ; |
' (call-res) plugin-of colon-resolve |
' (call-res) plugin-of colon-resolve |
: (prim) dup 0< IF ( $4000 - ) ELSE |
: (prim) dup 0< IF $4000 - ELSE |
." wrong usage of (prim) " |
." wrong usage of (prim) " |
dup gdiscover IF .ghost ELSE . THEN cr -2 throw THEN |
dup gdiscover IF .ghost ELSE . THEN cr -2 throw THEN |
T a, H ; ' (prim) plugin-of prim, |
T a, H ; ' (prim) plugin-of prim, |