--- gforth/cross.fs 2001/09/05 11:45:38 1.108 +++ gforth/cross.fs 2001/09/12 14:45:38 1.113 @@ -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 ; @@ -1145,8 +1142,11 @@ true DefaultValue standardthreading s" relocate" T environment? H \ JAW why set NIL to this?! [IF] drop \ SetValue NIL -[ELSE] >ENVIRON T NIL H SetValue relocate +[ELSE] >ENVIRON X NIL SetValue relocate [THEN] +>TARGET + +0 Constant NIL >CROSS @@ -1227,6 +1227,10 @@ Variable mirrored-link \ linked : >rlen cell+ ; : >rstart ; +: (region) ( addr len region -- ) +\G change startaddress and length of an existing region + >r r@ last-defined-region ! + r@ >rlen ! dup r@ >rstart ! r> >rdp ! ; : region ( addr len -- ) \G create a new region @@ -1240,8 +1244,7 @@ Variable mirrored-link \ linked region-link linked 0 , 0 , 0 , bl word count string, ELSE \ store new parameters in region bl word drop - >body >r r@ last-defined-region ! - r@ >rlen ! dup r@ >rstart ! r> >rdp ! + >body (region) THEN ; : borders ( region -- startaddr endaddr ) @@ -1359,8 +1362,11 @@ T has? rom H \ MakeKernel 22feb99jaw -: makekernel ( targetsize -- targetsize ) - dup dictionary >rlen ! setup-target ; +: makekernel ( targetsize -- ) +\G convenience word to setup the memory of the target +\G used by main.fs of the c-engine based systems + 100 swap dictionary (region) + setup-target ; >MINIMAL : makekernel makekernel ; @@ -1640,8 +1646,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 +1690,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 +1780,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 +1820,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 @@ -2111,12 +2111,12 @@ Variable last-prim-ghost Defer setup-prim-semantics -: aprim ( -- ) +: mapprim ( "forthname" "asmlabel" -- ) THeader -1 aprim-nr +! aprim-nr @ T A, H asmprimname, setup-prim-semantics ; -: aprim: ( -- ) +: mapprim: ( "forthname" "asmlabel" -- ) -1 aprim-nr +! aprim-nr @ Ghost tuck swap resolve swap tuck >magic ! asmprimname, ; @@ -2288,7 +2288,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 +2376,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 +2469,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 +2493,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 +2538,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 +2618,6 @@ by Create \ User variables 04may94py ->CROSS - Variable tup 0 tup ! Variable tudp 0 tudp ! @@ -2642,8 +2629,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 +2665,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 +2680,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 +2712,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 @@ -3021,7 +3013,7 @@ magic 7 + c! : save-cross ( "image-name" "binary-name" -- ) bl parse ." Saving to " 2dup type cr w/o bin create-file throw >r - TNIL IF + s" header" X $has? IF s" #! " r@ write-file throw bl parse r@ write-file throw s" --image-file" r@ write-file throw @@ -3037,7 +3029,7 @@ magic 7 + c! THEN image @ there r@ write-file throw \ write image - TNIL IF + s" relocate" X $has? IF bit$ @ there 1- tcell>bit rshift 1+ r@ write-file throw \ write tags THEN @@ -3048,7 +3040,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 @@ -3102,6 +3094,7 @@ Create name-buf 200 chars allot THEN @nb ; +\ FIXME why disabled?! : label-from-ghostnameXX ( ghost -- addr len ) \ same as (label-from-ghostname) but caches generated names dup >asm-name @ ?dup IF nip count EXIT THEN @@ -3255,8 +3248,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 +3259,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 @@ -3525,6 +3516,3 @@ UNLOCK >CROSS [IFDEF] extend-cross extend-cross [THEN] LOCK - - -