version 1.94, 2001/03/11 22:50:49
|
version 1.101, 2001/09/04 09:15:28
|
Line 808 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 944 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 1050 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 1087 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 1579 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 1777 Comment ( Comment \
|
Line 1776 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, |
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 |
Line 1976 Cond: ; ( -- ) restrict?
|
Line 1979 Cond: ; ( -- ) restrict?
|
state off |
state off |
;Resolve @ |
;Resolve @ |
IF ;Resolve @ ;Resolve cell+ @ resolve |
IF ;Resolve @ ;Resolve cell+ @ resolve |
['] prim-resolved ;Resolve @ >comp ! THEN |
['] 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 1994 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 2037 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 2075 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 2097 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 ! ; immediate |
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 2127 Builder 2Constant
|
Line 2140 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 2137 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 2147 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 2157 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 2388 Cond: NEXT restrict? sys? next, ;Cond
|
Line 2404 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 ; |
Line 2426 Cond: compile ( -- ) restrict? \ name
|
Line 2442 Cond: compile ( -- ) restrict? \ name
|
IF gexecute |
IF gexecute |
ELSE compile (compile) addr, THEN THEN ;Cond |
ELSE compile (compile) addr, THEN THEN ;Cond |
|
|
|
Cond: [compile] ( -- ) restrict? \ name |
|
bl word gfind dup 0= ABORT" CROSS: Can't compile" |
|
0> IF gexecute |
|
ELSE dup >magic @ <imm> = |
|
IF gexecute |
|
ELSE compile (compile) addr, THEN THEN ;Cond |
|
|
Cond: postpone ( -- ) restrict? \ name |
Cond: postpone ( -- ) restrict? \ name |
bl word gfind dup 0= ABORT" CROSS: Can't compile" |
bl word gfind dup 0= ABORT" CROSS: Can't compile" |
0> IF gexecute |
0> IF gexecute |
Line 2682 previous
|
Line 2705 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 |
Line 2699 previous
|
Line 2726 previous
|
: unlock previous forth also cross ; |
: unlock previous forth also cross ; |
|
|
\ also minimal |
\ also minimal |
: [[ also unlock ; |
: [[+++ also unlock ; |
: ]] previous previous also also ; |
: +++]] previous previous also also ; |
|
|
unlock definitions also minimal |
unlock definitions also minimal |
: lock lock ; |
: lock lock ; |