--- gforth/cross.fs 2001/09/05 11:45:38 1.108 +++ gforth/cross.fs 2001/09/05 14:25:48 1.110 @@ -986,7 +986,6 @@ Exists-Warnings on Variable reuse-ghosts reuse-ghosts off -1 [IF] \ FIXME: define when vocs are ready : HeaderGhost ( "name" -- ghost ) >in @ bl word count @@ -1003,8 +1002,6 @@ Variable reuse-ghosts reuse-ghosts off \ defined words, this is a workaround \ for the redefined \ until vocs work Make-Ghost ; -[THEN] - : .ghost ( ghost -- ) >ghostname type ; @@ -1640,8 +1637,8 @@ T has? relocate H >TARGET : 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 ; : tcmove ( source dest len -- ) @@ -1684,7 +1681,7 @@ previous : (cm) ( -- addr ) T here align H - -1 colon, ; ' (cm) plugin-of colonmark, + -1 prim, ; ' (cm) plugin-of colonmark, >TARGET : compile, ( xt -- ) @@ -1774,7 +1771,7 @@ Defer resolve-warning : prim-resolved ( ghost -- ) >link @ prim, ; -\ FIXME: not activated +\ FIXME: not used currently : does-resolved ( ghost -- ) dup g>body alit, >do:ghost @ g>body colon, ; @@ -1814,22 +1811,16 @@ Defer resolve-warning \ gexecute ghost, 01nov92py -\ FIXME cleanup -\ : is-resolved ( ghost -- ) -\ >link @ colon, ; \ compile-call - : (gexecute) ( ghost -- ) dup >comp @ EXECUTE ; : gexecute ( ghost -- ) -\ dup >magic @ = IF -1 ABORT" CROSS: gexecute on immediate word" THEN + dup >magic @ = IF -1 ABORT" CROSS: gexecute on immediate word" THEN (gexecute) ; : addr, ( ghost -- ) dup forward? IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ; -\ !! : ghost, ghost gexecute ; - \ .unresolved 11may93jaw variable ResolveFlag @@ -2288,7 +2279,7 @@ Cond: ALiteral ( n -- ) alit, ;Cond Cond: [Char] ( "" -- ) Char lit, ;Cond tchar 1 = [IF] -\ Cond: chars ;Cond +Cond: chars ;Cond [THEN] \ some special literals 27jan97jaw @@ -2376,22 +2367,23 @@ Cond: MAXI \ by the way: defining a second interpreter (a compiler-)loop \ 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 defempty? constflag off \ don't let this flag work over colon defs \ just to go sure nothing unwanted happens >in @ skip? IF drop skip-defs EXIT THEN >in ! - (THeader ;Resolve ! there ;Resolve cell+ ! - docol, ]comp colon-start depth T ] H ; + (THeader (:) ; : :noname ( -- colon-sys ) - X cfalign - \ FIXME: cleanup!!!!!!!! - \ idtentical to : with dummy ghost?! - here ghostheader dup ;Resolve ! dup last-header-ghost ! to lastghost - there ;Resolve cell+ ! - there docol, ]comp - colon-start depth T ] H ; + X cfalign there + \ define a nameless ghost + here ghostheader dup last-header-ghost ! dup to lastghost + (:) ; Cond: EXIT ( -- ) compile ;S ;Cond @@ -2468,8 +2460,7 @@ Cond: DOES> \ do:-xt is executed when the created word from builder is executed \ for do:-xt an additional entry after the normal ghost-entrys is used - ghost ( Create-xt do-ghost ghost ) - to built + ghost to built built >created @ 0= IF built >created on ['] prim-resolved built >comp ! @@ -2493,17 +2484,13 @@ Cond: DOES> : takeover-x-semantics ( S constructor-ghost new-ghost -- ) \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 @ - \ we use the >exec2 field for the semantic of a crated word, - \ so predefined semantics e.g. for .... - \ FIXME: find an example in the normal kernel!!! + \ we use the >exec2 field for the semantic of a created word, + \ using exec or exec2 makes no difference for normal cross-compilation + \ but is usefull for instant where the exec field is already + \ defined (e.g. Vocabularies) 2dup >exec @ swap >exec2 ! >comp @ swap >comp ! ; -\ old version of this: -\ >exec dup @ ['] NoExec = -\ IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ; : TCreate ( -- ) create-forward-warn @@ -2542,42 +2529,35 @@ Cond: DOES> postpone ; built >exec ! ; immediate : gdoes> ( ghost -- addr flag ) - executed-ghost @ -\ FIXME: cleanup -\ compiling? ABORT" CROSS: Executing gdoes> while compiling" -\ ?! compiling? IF gexecute true EXIT THEN - g>body ( false ) ; + executed-ghost @ g>body ; \ DO: ;DO 11may93jaw -\ changed to ?EXIT 10may93jaw : do:ghost! ( ghost -- ) built >do:ghost ! ; : doexec! ( xt -- ) built >do:ghost @ >exec ! ; : DO: ( -- [xt] [colon-sys] ) here ghostheader do:ghost! - :noname postpone gdoes> ( postpone ?EXIT ) ; + :noname postpone gdoes> ; : by: ( -- [xt] [colon-sys] ) \ name Ghost do:ghost! - :noname postpone gdoes> ( postpone ?EXIT ) ; + :noname postpone gdoes> ; : ;DO ( [xt] [colon-sys] -- ) postpone ; doexec! ; immediate -: by ( -- do-ghost ) \ Name +: by ( -- ) \ Name Ghost >do:ghost @ do:ghost! ; -: compile: ( do-ghost -- do-ghost [xt] [colon-sys] ) +: compile: ( --[xt] [colon-sys] ) \G defines a compile time action for created words \G by this builder :noname ; -: ;compile ( do-ghost [xt] [colon-sys] -- do-ghost ) - postpone ; built >do:ghost @ >comp ! ; immediate - +: ;compile ( [xt] [colon-sys] -- ) + postpone ; built >do:ghost @ >comp ! ; immediate ->TARGET \ Variables and Constants 05dec92py Builder (Constant) @@ -2629,8 +2609,6 @@ by Create \ User variables 04may94py ->CROSS - Variable tup 0 tup ! Variable tudp 0 tudp ! @@ -2642,8 +2620,6 @@ Variable tudp 0 tudp ! tup @ tudp @ + T A! H tudp @ dup T cell+ H tudp ! ; ->TARGET - Builder User Build: 0 u, X , ;Build by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO @@ -2680,11 +2656,10 @@ DO: ( ghost -- ) ABORT" CROSS: Don't exe \ Sturctures 23feb95py ->CROSS : nalign ( addr1 n -- addr2 ) \ addr2 is the aligned version of addr1 wrt the alignment size n 1- tuck + swap invert and ; ->TARGET + Builder (Field) Build: ;Build @@ -2696,11 +2671,13 @@ Build: ( align1 offset1 align size "name + >r nalign r> ;Build by (Field) +>TARGET : struct T 1 chars 0 H ; : end-struct T 2Constant H ; : cell% ( n -- size align ) T 1 cells H dup ; +>CROSS \ Input-Methods 01py @@ -2726,10 +2703,16 @@ DO: abort" Not in cross mode" ;DO T has? peephole H [IF] -: (cc) compile call T >body a, H ; ' (cc) IS colon, +>CROSS +: (callc) compile call T >body a, H ; ' (callc) plugin-of colon, + +\ if we want this, we have to spilt aconstant +\ and constant!! +\ Builder (Constant) +\ compile: g>body X @ lit, ;compile Builder (Constant) -compile: g>body X @ lit, ;compile +compile: g>body alit, compile @ ;compile Builder (Value) compile: g>body alit, compile @ ;compile @@ -3048,7 +3031,7 @@ magic 7 + c! swap >image swap r@ write-file throw r> close-file throw ; -1 [IF] +\ save-asm-region 29aug01jaw Variable name-ptr Create name-buf 200 chars allot @@ -3255,8 +3238,6 @@ Variable outfile-fd : save-asm-region ( region adr len -- ) create-outfile (save-asm-region) close-outfile ; -[THEN] - \ \ minimal definitions >MINIMAL also minimal @@ -3268,8 +3249,8 @@ Variable outfile-fd \ \ [IF] [ELSE] [THEN] ... 14sep97jaw \ it is useful to define our own structures and not to rely -\ on the words in the compiler -\ The words in the compiler might be defined with vocabularies +\ on the words in the host system +\ The words in the host system might be defined with vocabularies \ this doesn't work with our self-made compile-loop Create parsed 20 chars allot \ store word we parsed