version 1.93, 2001/03/11 21:47:27
|
version 1.94, 2001/03/11 22:50:49
|
Line 678 Defer branchfrom, ( -- ) \ ?!
|
Line 678 Defer branchfrom, ( -- ) \ ?!
|
Defer branchtomark, ( -- target-addr ) \ marks a branch destination |
Defer branchtomark, ( -- target-addr ) \ marks a branch destination |
|
|
Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position |
Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position |
|
Defer prim, ( tcfa -- ) \ compiles a primitive invocation |
|
\ at current position |
Defer colonmark, ( -- addr ) \ marks a colon call |
Defer colonmark, ( -- addr ) \ marks a colon call |
Defer colon-resolve ( tcfa addr -- ) |
Defer colon-resolve ( tcfa addr -- ) |
|
|
Line 806 ghost (next)
|
Line 808 ghost (next)
|
ghost unloop ghost ;S 2drop |
ghost unloop ghost ;S 2drop |
ghost lit ghost (compile) ghost ! 2drop drop |
ghost lit ghost (compile) ghost ! 2drop drop |
ghost (does>) ghost noop 2drop |
ghost (does>) ghost noop 2drop |
ghost (.") ghost (S") ghost (ABORT") 2drop drop |
ghost (.") ghost (S") ghost (ABORT") 2drop drop ( " ) |
ghost ' drop |
ghost ' drop |
ghost :docol ghost :doesjump ghost :dodoes 2drop drop |
ghost :docol ghost :doesjump ghost :dodoes 2drop drop |
ghost :dovar ghost :dodefer ghost :dofield 2drop drop |
ghost :dovar ghost :dodefer ghost :dofield 2drop drop |
Line 1350 DEFER dodoes,
|
Line 1352 DEFER dodoes,
|
DEFER ]comp \ starts compilation |
DEFER ]comp \ starts compilation |
DEFER comp[ \ ends compilation |
DEFER comp[ \ ends compilation |
|
|
: (cc) T a, H ; ' (cc) IS colon, |
: (prim) T a, H ; ' (prim) IS prim, |
|
|
: (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve |
: (cr) >tempdp ]comp prim, comp[ tempdp> ; ' (cr) IS colon-resolve |
: (ar) T ! H ; ' (ar) IS addr-resolve |
: (ar) T ! H ; ' (ar) IS addr-resolve |
: (dr) ( ghost res-pnt target-addr addr ) |
: (dr) ( ghost res-pnt target-addr addr ) |
>tempdp drop over |
>tempdp drop over |
Line 1364 DEFER comp[ \ ends compilation
|
Line 1366 DEFER comp[ \ ends compilation
|
|
|
: (cm) ( -- addr ) |
: (cm) ( -- addr ) |
T here align H |
T here align H |
-1 colon, ; ' (cm) IS colonmark, |
-1 prim, ; ' (cm) IS colonmark, |
|
|
>TARGET |
>TARGET |
: compile, colon, ; |
: compile, prim, ; |
>CROSS |
>CROSS |
|
|
: refered ( ghost tag -- ) |
: refered ( ghost tag -- ) |
Line 1439 Exists-Warnings on
|
Line 1441 Exists-Warnings on
|
ELSE true abort" CROSS: Ghostnames inconsistent " |
ELSE true abort" CROSS: Ghostnames inconsistent " |
THEN ; |
THEN ; |
|
|
: is-resolved ( ghost -- ) |
: colon-resolved ( ghost -- ) |
>link @ colon, ; \ compile-call |
>link @ colon, ; \ compile-call |
|
: prim-resolved ( ghost -- ) |
|
>link @ prim, ; |
|
|
: resolve ( ghost tcfa -- ) |
: resolve ( ghost tcfa -- ) |
\G resolve referencies to ghost with tcfa |
\G resolve referencies to ghost with tcfa |
Line 1451 Exists-Warnings on
|
Line 1455 Exists-Warnings on
|
swap >r r@ >link @ swap \ ( list tcfa R: ghost ) |
swap >r r@ >link @ swap \ ( list tcfa R: ghost ) |
\ mark ghost as resolved |
\ mark ghost as resolved |
dup r@ >link ! <res> r@ >magic ! |
dup r@ >link ! <res> r@ >magic ! |
r@ >comp @ ['] is-forward = IF ['] is-resolved r@ >comp ! THEN |
r@ >comp @ ['] is-forward = IF |
|
['] prim-resolved r@ >comp ! THEN |
\ loop through forward referencies |
\ loop through forward referencies |
r> -rot |
r> -rot |
comp-state @ >r Resolving comp-state ! |
comp-state @ >r Resolving comp-state ! |
Line 1772 Comment ( Comment \
|
Line 1777 Comment ( Comment \
|
ELSE postpone literal postpone gexecute THEN ; |
ELSE postpone literal postpone gexecute THEN ; |
immediate |
immediate |
|
|
|
: (cc) compile call T a, H ; ' (cc) IS colon, |
|
|
: [G'] |
: [G'] |
\G ticks a ghost and returns its address |
\G ticks a ghost and returns its address |
bl word gfind 0= ABORT" CROSS: Ghost don't exists" |
bl word gfind 0= ABORT" CROSS: Ghost don't exists" |
Line 1805 Cond: ['] T ' H alit, ;Cond
|
Line 1812 Cond: ['] T ' H alit, ;Cond
|
|
|
: (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H |
: (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H |
|
|
: (doer,) ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ; ' (doer,) IS doer, |
: (doer,) ( ghost -- ) ]comp addr, comp[ 1 fillcfa ; ' (doer,) IS doer, |
|
|
: (docol,) ( -- ) [G'] :docol doer, ; ' (docol,) IS docol, |
: (docol,) ( -- ) [G'] :docol doer, ; ' (docol,) IS docol, |
|
|
Line 1968 Cond: ; ( -- ) restrict?
|
Line 1975 Cond: ; ( -- ) restrict?
|
comp[ |
comp[ |
state off |
state off |
;Resolve @ |
;Resolve @ |
IF ;Resolve @ ;Resolve cell+ @ resolve THEN |
IF ;Resolve @ ;Resolve cell+ @ resolve |
|
['] prim-resolved ;Resolve @ >comp ! THEN |
Interpreting comp-state ! |
Interpreting comp-state ! |
;Cond |
;Cond |
Cond: [ restrict? state off Interpreting comp-state ! ;Cond |
Cond: [ restrict? state off Interpreting comp-state ! ;Cond |
Line 1999 Cond: DOES> restrict?
|
Line 2007 Cond: DOES> restrict?
|
|
|
\ Builder 11may93jaw |
\ Builder 11may93jaw |
|
|
: Builder ( Create-xt do:-xt "name" -- ) |
: Builder ( Create-xt do-ghost "name" -- ) |
\ builds up a builder in current vocabulary |
\ builds up a builder in current vocabulary |
\ create-xt is executed when word is interpreted |
\ create-xt is executed when word is interpreted |
\ do:-xt is executet when the created word from builder is executed |
\ do:-xt is executet when the created word from builder is executed |
\ for do:-xt an additional entry after the normal ghost-enrys is used |
\ for do:-xt an additional entry after the normal ghost-enrys is used |
|
|
Make-Ghost ( Create-xt do:-xt ghost ) |
Make-Ghost ( Create-xt do-ghost ghost ) |
rot swap ( do:-xt Create-xt ghost ) |
rot swap ( do-ghost Create-xt ghost ) |
>exec ! , ; |
>exec ! , ; |
|
|
: gdoes, ( ghost -- ) |
: gdoes, ( ghost -- ) |
Line 2092 Cond: DOES> restrict?
|
Line 2100 Cond: DOES> restrict?
|
: compile: ( ghost -- ghost [xt] [colon-sys] ) |
: compile: ( ghost -- ghost [xt] [colon-sys] ) |
:noname postpone g>body ; |
:noname postpone g>body ; |
: ;compile ( ghost [xt] [colon-sys] -- ghost ) |
: ;compile ( ghost [xt] [colon-sys] -- ghost ) |
postpone ; over >comp ! ; |
postpone ; over >comp ! ; immediate |
|
|
: by ( -- ghost ) \ Name |
: by ( -- ghost ) \ Name |
ghost >end @ ; |
ghost >end @ ; |
Line 2102 Cond: DOES> restrict?
|
Line 2110 Cond: DOES> restrict?
|
|
|
Build: ( n -- ) ; |
Build: ( n -- ) ; |
by: :docon ( ghost -- n ) T @ H ;DO |
by: :docon ( ghost -- n ) T @ H ;DO |
\ compile: alit, compile @ ;compile |
compile: alit, compile @ ;compile |
Builder (Constant) |
Builder (Constant) |
|
|
Build: ( n -- ) T , H ; |
Build: ( n -- ) T , H ; |
Line 2119 Builder 2Constant
|
Line 2127 Builder 2Constant
|
|
|
BuildSmart: ; |
BuildSmart: ; |
by: :dovar ( ghost -- addr ) ;DO |
by: :dovar ( ghost -- addr ) ;DO |
\ compile: alit, ;compile |
compile: alit, ;compile |
Builder Create |
Builder Create |
|
|
T has? rom H [IF] |
T has? rom H [IF] |
Line 2171 Variable tudp 0 tudp !
|
Line 2179 Variable tudp 0 tudp !
|
|
|
Build: 0 u, X , ; |
Build: 0 u, X , ; |
by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO |
by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO |
\ compile: compile useraddr @ , ;compile |
compile: compile useraddr T @ , H ;compile |
Builder User |
Builder User |
|
|
Build: 0 u, X , 0 u, drop ; |
Build: 0 u, X , 0 u, drop ; |
Line 2192 Builder AValue
|
Line 2200 Builder AValue
|
|
|
BuildSmart: ( -- ) [T'] noop T A, H ; |
BuildSmart: ( -- ) [T'] noop T A, H ; |
by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
\ compile: alit, compile @ compile execute ;compile |
compile: alit, compile @ compile execute ;compile |
Builder Defer |
Builder Defer |
|
|
Build: ( inter comp -- ) swap T immediate A, A, H ; |
Build: ( inter comp -- ) swap T immediate A, A, H ; |
Line 2209 Builder interpret/compile:
|
Line 2217 Builder interpret/compile:
|
|
|
Build: ; |
Build: ; |
by: :dofield T @ H + ;DO |
by: :dofield T @ H + ;DO |
\ compile: T @ H lit, compile + ;compile |
compile: T @ H lit, compile + ;compile |
Builder (Field) |
Builder (Field) |
|
|
Build: ( align1 offset1 align size "name" -- align2 offset2 ) |
Build: ( align1 offset1 align size "name" -- align2 offset2 ) |
Line 2380 Cond: NEXT restrict? sys? next, ;Cond
|
Line 2388 Cond: NEXT restrict? sys? next, ;Cond
|
|
|
: ," [char] " parse T string, align H ; |
: ," [char] " parse T string, align H ; |
|
|
Cond: ." restrict? compile (.") T ," H ;Cond |
Cond: ." restrict? compile (.") T ," H ;Cond ( " ) |
Cond: S" restrict? compile (S") T ," H ;Cond |
Cond: S" restrict? compile (S") T ," H ;Cond ( " ) |
Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond |
Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond ( " ) |
|
|
Cond: IS T ' >body H compile ALiteral compile ! ;Cond |
Cond: IS T ' >body H compile ALiteral compile ! ;Cond |
: IS T >address ' >body ! H ; |
: IS T >address ' >body ! H ; |