version 1.161, 2006/12/31 13:39:11
|
version 1.164, 2007/04/01 21:30:26
|
Line 1175 false DefaultValue header
|
Line 1175 false DefaultValue header
|
false DefaultValue backtrace |
false DefaultValue backtrace |
false DefaultValue new-input |
false DefaultValue new-input |
false DefaultValue peephole |
false DefaultValue peephole |
|
false DefaultValue primcentric |
false DefaultValue abranch |
false DefaultValue abranch |
true DefaultValue f83headerstring |
true DefaultValue f83headerstring |
true DefaultValue control-rack |
true DefaultValue control-rack |
Line 1243 bits/byte Constant tbits/byte
|
Line 1244 bits/byte Constant tbits/byte
|
H |
H |
tbits/char bits/byte / Constant tbyte |
tbits/char bits/byte / Constant tbyte |
|
|
|
: >signed ( u -- n ) |
|
1 tbits/char tcell * 1- lshift 2dup and |
|
IF negate or ELSE drop THEN ; |
|
|
\ Variables 06oct92py |
\ Variables 06oct92py |
|
|
Line 2315 Variable prim#
|
Line 2319 Variable prim#
|
prim# @ (THeader ( S xt ghost ) |
prim# @ (THeader ( S xt ghost ) |
['] prim-resolved over >comp ! |
['] prim-resolved over >comp ! |
dup >ghost-flags <primitive> set-flag |
dup >ghost-flags <primitive> set-flag |
over resolve-noforwards T A, H alias-mask flag! |
s" EC" T $has? H 0= |
|
IF |
|
over resolve-noforwards T A, H |
|
alias-mask flag! |
|
ELSE |
|
T here H resolve-noforwards T A, H |
|
THEN |
-1 prim# +! ; |
-1 prim# +! ; |
>CROSS |
>CROSS |
|
|
Line 2625 Cond: [ ( -- ) interpreting-state ;Cond
|
Line 2635 Cond: [ ( -- ) interpreting-state ;Cond
|
|
|
Defer instant-interpret-does>-hook ' noop IS instant-interpret-does>-hook |
Defer instant-interpret-does>-hook ' noop IS instant-interpret-does>-hook |
|
|
T has? peephole H [IF] |
T has? primcentric H [IF] |
: does-resolved ( ghost -- ) |
: does-resolved ( ghost -- ) |
compile does-exec g>xt T a, H ; |
compile does-exec g>xt T a, H ; |
[ELSE] |
[ELSE] |
Line 2640 T has? peephole H [IF]
|
Line 2650 T has? peephole H [IF]
|
|
|
>TARGET |
>TARGET |
Cond: DOES> |
Cond: DOES> |
T here H [ T has? peephole H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells |
T here H [ T has? primcentric H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells |
H + alit, compile (does>2) compile ;s |
H + alit, compile (does>2) compile ;s |
doeshandler, resolve-does>-part |
doeshandler, resolve-does>-part |
;Cond |
;Cond |
Line 2960 DO: abort" Not in cross mode" ;DO
|
Line 2970 DO: abort" Not in cross mode" ;DO
|
\ optimizer for cross |
\ optimizer for cross |
|
|
|
|
T has? peephole H [IF] |
T has? primcentric H [IF] |
|
|
\ .( loading peephole optimization) cr |
\ .( loading peephole optimization) cr |
|
|
Line 2970 T has? peephole H [IF]
|
Line 2980 T has? peephole H [IF]
|
: (callcm) T here 0 a, 0 a, H ; ' (callcm) plugin-of colonmark, |
: (callcm) T here 0 a, 0 a, H ; ' (callcm) plugin-of colonmark, |
: (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 |
|
T has? ec H [IF] |
|
: (pprim) T @ H >signed dup 0< IF $4000 - ELSE |
|
cr ." wrong usage of (prim) " |
|
dup gdiscover IF .ghost ELSE . THEN cr -1 throw THEN |
|
T a, H ; ' (pprim) plugin-of prim, |
|
[ELSE] |
: (pprim) dup 0< IF $4000 - ELSE |
: (pprim) dup 0< IF $4000 - ELSE |
cr ." wrong usage of (prim) " |
cr ." wrong usage of (prim) " |
dup gdiscover IF .ghost ELSE . THEN cr -1 throw THEN |
dup gdiscover IF .ghost ELSE . THEN cr -1 throw THEN |
T a, H ; ' (pprim) plugin-of prim, |
T a, H ; ' (pprim) plugin-of prim, |
|
[THEN] |
|
|
\ if we want this, we have to spilt aconstant |
\ if we want this, we have to spilt aconstant |
\ and constant!! |
\ and constant!! |
Line 2997 Builder Defer
|
Line 3014 Builder Defer
|
compile: g>body compile lit-perform T A, H ;compile |
compile: g>body compile lit-perform T A, H ;compile |
|
|
Builder (Field) |
Builder (Field) |
compile: g>body T @ H compile lit+ T , H ;compile |
compile: g>body T @ H compile lit+ T here H reloff T , H ;compile |
|
|
Builder interpret/compile: |
Builder interpret/compile: |
compile: does-resolved ;compile |
compile: does-resolved ;compile |