version 1.109, 2001/09/05 13:11:36
|
version 1.110, 2001/09/05 14:25:48
|
Line 986 Exists-Warnings on
|
Line 986 Exists-Warnings on
|
|
|
Variable reuse-ghosts reuse-ghosts off |
Variable reuse-ghosts reuse-ghosts off |
|
|
1 [IF] \ FIXME: define when vocs are ready |
|
: HeaderGhost ( "name" -- ghost ) |
: HeaderGhost ( "name" -- ghost ) |
>in @ |
>in @ |
bl word count |
bl word count |
Line 1003 Variable reuse-ghosts reuse-ghosts off
|
Line 1002 Variable reuse-ghosts reuse-ghosts off
|
\ defined words, this is a workaround |
\ defined words, this is a workaround |
\ for the redefined \ until vocs work |
\ for the redefined \ until vocs work |
Make-Ghost ; |
Make-Ghost ; |
[THEN] |
|
|
|
|
|
: .ghost ( ghost -- ) >ghostname type ; |
: .ghost ( ghost -- ) >ghostname type ; |
|
|
Line 1640 T has? relocate H
|
Line 1637 T has? relocate H
|
>TARGET |
>TARGET |
|
|
: count dup X c@ swap X char+ swap ; |
: count dup X c@ swap X char+ swap ; |
\ FIXME -1 on 64 bit machines?!?! |
|
: on T -1 swap ! H ; |
: on -1 -1 rot TD! ; |
: off T 0 swap ! H ; |
: off T 0 swap ! H ; |
|
|
: tcmove ( source dest len -- ) |
: tcmove ( source dest len -- ) |
Line 1774 Defer resolve-warning
|
Line 1771 Defer resolve-warning
|
: prim-resolved ( ghost -- ) |
: prim-resolved ( ghost -- ) |
>link @ prim, ; |
>link @ prim, ; |
|
|
\ FIXME: not activated |
\ FIXME: not used currently |
: does-resolved ( ghost -- ) |
: does-resolved ( ghost -- ) |
dup g>body alit, >do:ghost @ g>body colon, ; |
dup g>body alit, >do:ghost @ g>body colon, ; |
|
|
Line 1814 Defer resolve-warning
|
Line 1811 Defer resolve-warning
|
|
|
\ gexecute ghost, 01nov92py |
\ gexecute ghost, 01nov92py |
|
|
\ FIXME cleanup |
|
\ : is-resolved ( ghost -- ) |
|
\ >link @ colon, ; \ compile-call |
|
|
|
: (gexecute) ( ghost -- ) |
: (gexecute) ( ghost -- ) |
dup >comp @ EXECUTE ; |
dup >comp @ EXECUTE ; |
|
|
: gexecute ( ghost -- ) |
: gexecute ( ghost -- ) |
\ dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN |
dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN |
(gexecute) ; |
(gexecute) ; |
|
|
: addr, ( ghost -- ) |
: addr, ( ghost -- ) |
dup forward? IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ; |
dup forward? IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ; |
|
|
\ !! : ghost, ghost gexecute ; |
|
|
|
\ .unresolved 11may93jaw |
\ .unresolved 11may93jaw |
|
|
variable ResolveFlag |
variable ResolveFlag |
Line 2288 Cond: ALiteral ( n -- ) alit, ;Cond
|
Line 2279 Cond: ALiteral ( n -- ) alit, ;Cond
|
Cond: [Char] ( "<char>" -- ) Char lit, ;Cond |
Cond: [Char] ( "<char>" -- ) Char lit, ;Cond |
|
|
tchar 1 = [IF] |
tchar 1 = [IF] |
\ Cond: chars ;Cond |
Cond: chars ;Cond |
[THEN] |
[THEN] |
|
|
\ some special literals 27jan97jaw |
\ some special literals 27jan97jaw |
Line 2376 Cond: MAXI
|
Line 2367 Cond: MAXI
|
\ by the way: defining a second interpreter (a compiler-)loop |
\ by the way: defining a second interpreter (a compiler-)loop |
\ is not allowed if a system should be ans conform |
\ is not allowed if a system should be ans conform |
|
|
|
: (:) ( ghost -- ) |
|
\ common factor of : and :noname. Prepare ;Resolve and start definition |
|
;Resolve ! there ;Resolve cell+ ! |
|
docol, ]comp colon-start depth T ] H ; |
|
|
: : ( -- colon-sys ) \ Name |
: : ( -- colon-sys ) \ Name |
defempty? |
defempty? |
constflag off \ don't let this flag work over colon defs |
constflag off \ don't let this flag work over colon defs |
\ just to go sure nothing unwanted happens |
\ just to go sure nothing unwanted happens |
>in @ skip? IF drop skip-defs EXIT THEN >in ! |
>in @ skip? IF drop skip-defs EXIT THEN >in ! |
(THeader ;Resolve ! there ;Resolve cell+ ! |
(THeader (:) ; |
docol, ]comp colon-start depth T ] H ; |
|
|
|
: :noname ( -- colon-sys ) |
: :noname ( -- colon-sys ) |
X cfalign |
X cfalign there |
\ FIXME: cleanup!!!!!!!! |
\ define a nameless ghost |
\ idtentical to : with dummy ghost?! |
here ghostheader dup last-header-ghost ! dup to lastghost |
here ghostheader dup ;Resolve ! dup last-header-ghost ! to lastghost |
(:) ; |
there ;Resolve cell+ ! |
|
there docol, ]comp |
|
colon-start depth T ] H ; |
|
|
|
Cond: EXIT ( -- ) compile ;S ;Cond |
Cond: EXIT ( -- ) compile ;S ;Cond |
|
|
Line 2492 Cond: DOES>
|
Line 2484 Cond: DOES>
|
|
|
: takeover-x-semantics ( S constructor-ghost new-ghost -- ) |
: takeover-x-semantics ( S constructor-ghost new-ghost -- ) |
\g stores execution semantic and compilation semantic in the built word |
\g stores execution semantic and compilation semantic in the built word |
\g if the word already has a semantic (concerns S", IS, .", DOES>) |
|
\g then keep it |
|
swap >do:ghost @ |
swap >do:ghost @ |
\ we use the >exec2 field for the semantic of a crated word, |
\ we use the >exec2 field for the semantic of a created word, |
\ so predefined semantics e.g. for .... |
\ using exec or exec2 makes no difference for normal cross-compilation |
\ FIXME: find an example in the normal kernel!!! |
\ but is usefull for instant where the exec field is already |
|
\ defined (e.g. Vocabularies) |
2dup >exec @ swap >exec2 ! |
2dup >exec @ swap >exec2 ! |
\ cr ." XXX" over .ghost |
|
\ dup >comp @ xt-see |
|
>comp @ swap >comp ! ; |
>comp @ swap >comp ! ; |
\ old version of this: |
|
\ >exec dup @ ['] NoExec = |
|
\ IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ; |
|
|
|
: TCreate ( <name> -- ) |
: TCreate ( <name> -- ) |
create-forward-warn |
create-forward-warn |
Line 2543 Cond: DOES>
|
Line 2529 Cond: DOES>
|
postpone ; built >exec ! ; immediate |
postpone ; built >exec ! ; immediate |
|
|
: gdoes> ( ghost -- addr flag ) |
: gdoes> ( ghost -- addr flag ) |
executed-ghost @ |
executed-ghost @ g>body ; |
\ FIXME: cleanup |
|
\ compiling? ABORT" CROSS: Executing gdoes> while compiling" |
|
\ ?! compiling? IF gexecute true EXIT THEN |
|
g>body ( false ) ; |
|
|
|
\ DO: ;DO 11may93jaw |
\ DO: ;DO 11may93jaw |
\ changed to ?EXIT 10may93jaw |
|
|
|
: do:ghost! ( ghost -- ) built >do:ghost ! ; |
: do:ghost! ( ghost -- ) built >do:ghost ! ; |
: doexec! ( xt -- ) built >do:ghost @ >exec ! ; |
: doexec! ( xt -- ) built >do:ghost @ >exec ! ; |
|
|
: DO: ( -- [xt] [colon-sys] ) |
: DO: ( -- [xt] [colon-sys] ) |
here ghostheader do:ghost! |
here ghostheader do:ghost! |
:noname postpone gdoes> ( postpone ?EXIT ) ; |
:noname postpone gdoes> ; |
|
|
: by: ( -- [xt] [colon-sys] ) \ name |
: by: ( -- [xt] [colon-sys] ) \ name |
Ghost do:ghost! |
Ghost do:ghost! |
:noname postpone gdoes> ( postpone ?EXIT ) ; |
:noname postpone gdoes> ; |
|
|
: ;DO ( [xt] [colon-sys] -- ) |
: ;DO ( [xt] [colon-sys] -- ) |
postpone ; doexec! ; immediate |
postpone ; doexec! ; immediate |
Line 3050 magic 7 + c!
|
Line 3031 magic 7 + c!
|
swap >image swap r@ write-file throw |
swap >image swap r@ write-file throw |
r> close-file throw ; |
r> close-file throw ; |
|
|
1 [IF] |
\ save-asm-region 29aug01jaw |
|
|
Variable name-ptr |
Variable name-ptr |
Create name-buf 200 chars allot |
Create name-buf 200 chars allot |
Line 3257 Variable outfile-fd
|
Line 3238 Variable outfile-fd
|
: save-asm-region ( region adr len -- ) |
: save-asm-region ( region adr len -- ) |
create-outfile (save-asm-region) close-outfile ; |
create-outfile (save-asm-region) close-outfile ; |
|
|
[THEN] |
|
|
|
\ \ minimal definitions |
\ \ minimal definitions |
|
|
>MINIMAL also minimal |
>MINIMAL also minimal |