version 1.121, 2002/03/19 18:07:55
|
version 1.122, 2002/03/20 11:28:26
|
Line 1528 bigendian
|
Line 1528 bigendian
|
2drop 0 ; |
2drop 0 ; |
|
|
: taddr>region-abort ( taddr -- region | 0 ) |
: taddr>region-abort ( taddr -- region | 0 ) |
|
\G Same as taddr>region but aborts if taddr is not |
|
\G a valid address in the target address space |
dup taddr>region dup 0= |
dup taddr>region dup 0= |
IF drop cr ." Wrong address: " .addr |
IF drop cr ." Wrong address: " .addr |
-1 ABORT" Address out of range!" |
-1 ABORT" Address out of range!" |
Line 1830 Defer resolve-warning
|
Line 1832 Defer resolve-warning
|
|
|
0 Value resolved |
0 Value resolved |
|
|
: resolve ( ghost tcfa -- ) |
: resolve-forward-references ( ghost resolve-list -- ) |
\G resolve referencies to ghost with tcfa |
\ loop through forward referencies |
|
comp-state @ >r Resolving comp-state ! |
|
over >link @ resolve-loop |
|
r> comp-state ! |
|
|
|
['] noop IS resolve-warning ; |
|
|
|
|
|
: (resolve) ( ghost tcfa -- ghost resolve-list ) |
|
\ check for a valid address, it is a primitive reference |
|
\ otherwise |
dup taddr>region 0<> IF |
dup taddr>region 0<> IF |
|
\ define this address in the region address type table |
2dup (>regiontype) define-addr-struct addr-xt-ghost |
2dup (>regiontype) define-addr-struct addr-xt-ghost |
|
|
\ we define new address only if empty |
\ we define new address only if empty |
\ this is for not to take over the alias ghost |
\ this is for not to take over the alias ghost |
\ (different ghost, but identical xt) |
\ (different ghost, but identical xt) |
\ but the very first that really defines it |
\ but the very first that really defines it |
dup @ 0= IF ! ELSE 2drop THEN |
dup @ 0= IF ! ELSE 2drop THEN |
THEN |
THEN |
|
swap >r |
\ is ghost resolved?, second resolve means another |
|
\ definition with the same name |
|
over undefined? 0= IF exists EXIT THEN |
|
\ get linked-list |
|
swap >r r@ >link @ swap \ ( list tcfa R: ghost ) |
|
\ mark ghost as resolved |
|
dup r@ >link ! <res> r@ >magic ! |
|
r@ to resolved |
r@ to resolved |
|
|
\ r@ >comp @ ['] is-forward = |
\ r@ >comp @ ['] is-forward = |
Line 1858 Defer resolve-warning
|
Line 1863 Defer resolve-warning
|
\ if this is not right something must be set before |
\ if this is not right something must be set before |
\ calling resolve |
\ calling resolve |
r@ >comp @ ['] is-forward = IF |
r@ >comp @ ['] is-forward = IF |
['] colon-resolved r@ >comp ! |
['] colon-resolved r@ >comp ! |
THEN |
THEN |
\ loop through forward referencies |
r@ >link @ swap \ ( list tcfa R: ghost ) |
r> -rot |
\ mark ghost as resolved |
comp-state @ >r Resolving comp-state ! |
r@ >link ! <res> r@ >magic ! |
resolve-loop |
r> swap ; |
r> comp-state ! |
|
|
|
['] noop IS resolve-warning |
: resolve ( ghost tcfa -- ) |
; |
\G resolve referencies to ghost with tcfa |
|
\ is ghost resolved?, second resolve means another |
|
\ definition with the same name |
|
over undefined? 0= IF exists EXIT THEN |
|
(resolve) |
|
( ghost resolve-list ) |
|
resolve-forward-references ; |
|
|
|
: resolve-noforwards ( ghost tcfa -- ) |
|
\G Same as resolve but complain if there are any |
|
\G forward references on this ghost |
|
\ is ghost resolved?, second resolve means another |
|
\ definition with the same name |
|
over undefined? 0= IF exists EXIT THEN |
|
(resolve) |
|
IF cr ." No forward references allowed on: " .ghost cr |
|
-1 ABORT" Illegal forward reference" |
|
THEN |
|
drop ; |
|
|
\ gexecute ghost, 01nov92py |
\ gexecute ghost, 01nov92py |
|
|
Line 2188 Defer setup-prim-semantics
|
Line 2210 Defer setup-prim-semantics
|
|
|
: mapprim: ( "forthname" "asmlabel" -- ) |
: mapprim: ( "forthname" "asmlabel" -- ) |
-1 aprim-nr +! aprim-nr @ |
-1 aprim-nr +! aprim-nr @ |
Ghost tuck swap resolve <do:> swap tuck >magic ! |
Ghost tuck swap resolve-noforwards <do:> swap tuck >magic ! |
asmprimname, ; |
asmprimname, ; |
|
|
: Doer: ( cfa -- ) \ name |
: Doer: ( cfa -- ) \ name |
Line 2198 Defer setup-prim-semantics
|
Line 2220 Defer setup-prim-semantics
|
.sourcepos ." needs doer: " >in @ bl word count type >in ! cr |
.sourcepos ." needs doer: " >in @ bl word count type >in ! cr |
THEN |
THEN |
Ghost |
Ghost |
tuck swap resolve <do:> swap >magic ! ; |
tuck swap resolve-noforwards <do:> swap >magic ! ; |
|
|
Variable prim# |
Variable prim# |
: first-primitive ( n -- ) prim# ! ; |
: first-primitive ( n -- ) prim# ! ; |
Line 2211 Variable prim#
|
Line 2233 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 T A, H alias-mask flag! |
over resolve-noforwards T A, H alias-mask flag! |
-1 prim# +! ; |
-1 prim# +! ; |
>CROSS |
>CROSS |
|
|
Line 2333 Defer (end-code)
|
Line 2355 Defer (end-code)
|
defempty? |
defempty? |
(THeader ( ghost ) |
(THeader ( ghost ) |
['] prim-resolved over >comp ! |
['] prim-resolved over >comp ! |
there resolve |
there resolve-noforwards |
|
|
[ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF] |
[ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF] |
doprim, |
doprim, |
Line 2345 Defer (end-code)
|
Line 2367 Defer (end-code)
|
: Code: |
: Code: |
defempty? |
defempty? |
Ghost >r |
Ghost >r |
r@ there ca>native resolve |
r@ there ca>native resolve-noforwards |
<do:> r@ >magic ! |
<do:> r@ >magic ! |
r> drop |
r> drop |
depth (code) ; |
depth (code) ; |
Line 3533 previous
|
Line 3555 previous
|
: rot rot ; |
: rot rot ; |
: drop drop ; |
: drop drop ; |
: = = ; |
: = = ; |
|
: <> <> ; |
: 0= 0= ; |
: 0= 0= ; |
: lshift lshift ; |
: lshift lshift ; |
: 2/ 2/ ; |
: 2/ 2/ ; |
Line 3587 previous
|
Line 3610 previous
|
\ : words also ghosts |
\ : words also ghosts |
\ words previous ; |
\ words previous ; |
: .s .s ; |
: .s .s ; |
|
: depth depth ; |
: bye bye ; |
: bye bye ; |
|
|
\ dummy |
\ dummy |