version 1.93, 2001/03/11 21:47:27
|
version 1.100, 2001/07/10 20:47:09
|
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 942 Variable user-vars 0 user-vars !
|
Line 944 Variable user-vars 0 user-vars !
|
: target>bitmask-size ( u1 -- u2 ) |
: target>bitmask-size ( u1 -- u2 ) |
1- tcell>bit rshift 1+ ; |
1- tcell>bit rshift 1+ ; |
|
|
: allocatetarget ( size --- adr ) |
: allocatetarget ( size -- adr ) |
dup allocate ABORT" CROSS: No memory for target" |
dup allocate ABORT" CROSS: No memory for target" |
swap over swap erase ; |
swap over swap erase ; |
|
|
Line 1048 T has? rom H
|
Line 1050 T has? rom H
|
' dictionary ALIAS rom-dictionary |
' dictionary ALIAS rom-dictionary |
|
|
|
|
: setup-target ( -- ) \G initialize targets memory space |
: setup-target ( -- ) \G initialize target's memory space |
s" rom" T $has? H |
s" rom" T $has? H |
IF \ check for ram and rom... |
IF \ check for ram and rom... |
\ address-space area nip 0<> |
\ address-space area nip 0<> |
Line 1085 T has? rom H
|
Line 1087 T has? rom H
|
ELSE r> drop THEN |
ELSE r> drop THEN |
REPEAT drop ; |
REPEAT drop ; |
|
|
\ MakeKernal 22feb99jaw |
\ MakeKernel 22feb99jaw |
|
|
: makekernel ( targetsize -- targetsize ) |
: makekernel ( targetsize -- targetsize ) |
dup dictionary >rlen ! setup-target ; |
dup dictionary >rlen ! setup-target ; |
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 1574 Variable to-doc to-doc on
|
Line 1579 Variable to-doc to-doc on
|
IF |
IF |
s" " doc-file-id write-line throw |
s" " doc-file-id write-line throw |
s" make-doc " doc-file-id write-file throw |
s" make-doc " doc-file-id write-file throw |
|
Last-Header-Ghost @ >ghostname doc-file-id write-file throw |
tlast @ >image count 1F and doc-file-id write-file throw |
|
>in @ |
>in @ |
[char] ( parse 2drop |
[char] ( parse 2drop |
[char] ) parse doc-file-id write-file throw |
[char] ) parse doc-file-id write-file throw |
Line 1772 Comment ( Comment \
|
Line 1776 Comment ( Comment \
|
ELSE postpone literal postpone gexecute THEN ; |
ELSE postpone literal postpone gexecute THEN ; |
immediate |
immediate |
|
|
|
T has? peephole H [IF] |
|
: (cc) compile call T >body a, H ; ' (cc) IS colon, |
|
[ELSE] |
|
' (prim) IS colon, |
|
[THEN] |
|
|
: [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 1815 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 1978 Cond: ; ( -- ) restrict?
|
comp[ |
comp[ |
state off |
state off |
;Resolve @ |
;Resolve @ |
IF ;Resolve @ ;Resolve cell+ @ resolve THEN |
IF ;Resolve @ ;Resolve cell+ @ resolve |
|
['] colon-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 1986 Create GhostDummy ghostheader
|
Line 1997 Create GhostDummy ghostheader
|
GhostDummy >link ! GhostDummy |
GhostDummy >link ! GhostDummy |
tlastcfa @ >tempdp dodoes, tempdp> ; |
tlastcfa @ >tempdp dodoes, tempdp> ; |
|
|
|
: g>body ( ghost -- body ) |
|
>link @ T >body H ; |
|
: does-resolved ( ghost -- ) |
|
dup g>body alit, >end @ g>body colon, ; |
|
|
>TARGET |
>TARGET |
Cond: DOES> restrict? |
Cond: DOES> restrict? |
compile (does>) doeshandler, |
compile (does>) doeshandler, |
\ resolve words made by builders |
\ resolve words made by builders |
tdoes @ ?dup IF @ T here H resolve THEN |
tdoes @ ?dup IF @ dup T here H resolve |
|
['] prim-resolved swap >comp ! THEN |
;Cond |
;Cond |
: DOES> switchrom doeshandler, T here H !does depth T ] H ; |
: DOES> switchrom doeshandler, T here H !does depth T ] H ; |
|
|
Line 1999 Cond: DOES> restrict?
|
Line 2016 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 2029 Cond: DOES> restrict?
|
Line 2046 Cond: DOES> restrict?
|
executed-ghost @ |
executed-ghost @ |
create-forward-warn |
create-forward-warn |
IF ['] reswarn-forward IS resolve-warning THEN |
IF ['] reswarn-forward IS resolve-warning THEN |
Theader >r dup gdoes, |
Theader >r dup , dup gdoes, |
\ stores execution semantic in the built word |
\ stores execution semantic in the built word |
\ if the word already has a semantic (concerns S", IS, .", DOES>) |
\ if the word already has a semantic (concerns S", IS, .", DOES>) |
\ then keep it |
\ then keep it |
Line 2067 Cond: DOES> restrict?
|
Line 2084 Cond: DOES> restrict?
|
postpone TCreate |
postpone TCreate |
[ [THEN] ] ; |
[ [THEN] ] ; |
|
|
: g>body ( ghost -- body ) |
|
>link @ T >body H ; |
|
: gdoes> ( ghost -- addr flag ) |
: gdoes> ( ghost -- addr flag ) |
executed-ghost @ |
executed-ghost @ |
state @ IF gexecute true EXIT THEN |
state @ IF gexecute true EXIT THEN |
Line 2089 Cond: DOES> restrict?
|
Line 2104 Cond: DOES> restrict?
|
postpone ; ( S addr xt ) |
postpone ; ( S addr xt ) |
over >exec ! ; immediate |
over >exec ! ; immediate |
|
|
|
T has? peephole H [IF] |
: 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 |
|
[ELSE] |
|
: compile: ( ghost -- ghost xt colon-sys ) :noname ; |
|
: ;compile ( ghost xt colon-sys -- ghost ) |
|
postpone ; drop ['] prim-resolved over >comp ! ; immediate |
|
[THEN] |
|
|
: by ( -- ghost ) \ Name |
: by ( -- ghost ) \ Name |
ghost >end @ ; |
ghost >end @ ; |
Line 2102 Cond: DOES> restrict?
|
Line 2123 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 2129 Builder Variable
|
Line 2150 Builder Variable
|
[ELSE] |
[ELSE] |
Build: T 0 , H ; |
Build: T 0 , H ; |
by Create |
by Create |
|
\ compile: alit, ;compile |
Builder Variable |
Builder Variable |
[THEN] |
[THEN] |
|
|
Line 2139 Builder 2Variable
|
Line 2161 Builder 2Variable
|
[ELSE] |
[ELSE] |
Build: T 0 , 0 , H ; |
Build: T 0 , 0 , H ; |
by Create |
by Create |
|
\ compile: alit, ;compile |
Builder 2Variable |
Builder 2Variable |
[THEN] |
[THEN] |
|
|
Line 2149 Builder AVariable
|
Line 2172 Builder AVariable
|
[ELSE] |
[ELSE] |
Build: T 0 A, H ; |
Build: T 0 A, H ; |
by Create |
by Create |
|
\ compile: alit, ;compile |
Builder AVariable |
Builder AVariable |
[THEN] |
[THEN] |
|
|
Line 2171 Variable tudp 0 tudp !
|
Line 2195 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 2216 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 2233 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 2674 previous
|
Line 2698 previous
|
: .s .s ; |
: .s .s ; |
: bye bye ; |
: bye bye ; |
|
|
|
\ dummy |
|
|
|
: group source >in ! drop ; |
|
|
\ turnkey direction |
\ turnkey direction |
: H forth ; immediate |
: H forth ; immediate |
: T minimal ; immediate |
: T minimal ; immediate |