--- gforth/cross.fs 2001/09/05 09:42:38 1.105 +++ gforth/cross.fs 2001/09/05 11:01:27 1.107 @@ -23,11 +23,11 @@ [IF] ToDo: -Crossdoc destination ./doc/crossdoc.fd makes no sense when -cross.fs is uses seperately. jaw -Do we need this char translation with >address and in branchoffset? -(>body also affected) jaw -Clean up mark> and >resolve stuff jaw +- Crossdoc destination ./doc/crossdoc.fd makes no sense when + cross.fs is used seperately. jaw +- Do we need this char translation with >address and in branchoffset? + (>body also affected) jaw +- MAXU etc. can be done with dlit, [THEN] @@ -690,6 +690,7 @@ Variable ppi-temp 0 ppi-temp ! POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate +Plugin dlit, ( d -- ) \ compile numerical value the target Plugin lit, ( n -- ) Plugin alit, ( n -- ) @@ -801,13 +802,25 @@ Struct \ points to the where we have to resolve (linked-list) cell% field >link - \ execution symantics (while target compiling) of ghost + \ execution semantics (while target compiling) of ghost cell% field >exec + \ compilation action of this ghost; this is what is + \ done to compile a call (or whatever) to this definition. + \ E.g. >comp contains the semantic of postpone s" + \ whereas >exec-compile contains the semantic of s" cell% field >comp + \ Compilation sematics (while parsing) of this ghost. E.g. + \ "\" will skip the rest of line. + \ These semantics are defined by Cond: and + \ if a word is made immediate in instant, then the >exec2 field + \ gets copied to here cell% field >exec-compile + \ Additional execution semantics of this ghost. This is used + \ for code generated by instant and for the doer-xt of created + \ words cell% field >exec2 cell% field >created @@ -865,6 +878,7 @@ Variable cross-space-dp-orig cross-space-end u> ABORT" CROSS: cross-space overflow" cross-space-dp-orig @ dp ! ; +\ this is just for debugging, to see this in the backtrace : execute-exec execute ; : execute-exec2 execute ; : execute-exec-compile execute ; @@ -1443,25 +1457,28 @@ variable constflag constflag off bigendian [IF] - : S! ( n addr -- ) >r s>d r> tcell bounds swap 1- + : DS! ( d addr -- ) tcell bounds swap 1- DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; - : S@ ( addr -- n ) >r 0 0 r> tcell bounds - DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; + : DS@ ( addr -- d ) >r 0 0 r> tcell bounds + DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP ; : Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1- DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; : Sc@ ( addr -- n ) >r 0 0 r> tchar bounds DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; [ELSE] - : S! ( n addr -- ) >r s>d r> tcell bounds + : DS! ( d addr -- ) tcell bounds DO maxbyte ud/mod rot I c! LOOP 2drop ; - : S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1- - DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; + : DS@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1- + DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP ; : Sc! ( n addr -- ) >r s>d r> tchar bounds DO maxbyte ud/mod rot I c! LOOP 2drop ; : Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1- DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; [THEN] +: S! ( n addr -- ) >r s>d r> DS! ; +: S@ ( addr -- n ) DS@ d>s ; + : taddr>region ( taddr -- region | 0 ) \G finds for a target-address the correct region \G returns 0 if taddr is not in range of a target memory region @@ -1596,32 +1613,14 @@ T has? relocate H : A, ( w -- ) >address T here H relon T , H ; ->CROSS - -: tcmove ( source dest len -- ) -\G cmove in target memory - tchar * bounds - ?DO dup T c@ H I T c! H 1+ - tchar +LOOP drop ; - - -\ \ Load Assembler - ->TARGET -H also Forth definitions - -\ FIXME: should we include the assembler really in the forth -\ dictionary?!?!?!? This conflicts with the existing assembler -\ of the host forth system!! -[IFDEF] asm-include asm-include [THEN] hex - -previous - \ \ -------------------- Host/Target copy etc. 29aug01jaw >CROSS +: TD! >image DS! ; +: TD@ >image DS@ ; + : th-count ( taddr -- host-addr len ) \G returns host address of target string assert1( tbyte 1 = ) @@ -1645,6 +1644,29 @@ previous : on T -1 swap ! H ; : off T 0 swap ! H ; +: tcmove ( source dest len -- ) +\G cmove in target memory + tchar * bounds + ?DO dup T c@ H I T c! H 1+ + tchar +LOOP drop ; + +: td, ( d -- ) +\G Store a host value as one cell into the target + there tcell X allot TD! ; + +\ \ Load Assembler + +>TARGET +H also Forth definitions + +\ FIXME: should we include the assembler really in the forth +\ dictionary?!?!?!? This conflicts with the existing assembler +\ of the host forth system!! +[IFDEF] asm-include asm-include [THEN] hex + +previous + + >CROSS : (cc) T a, H ; ' (cc) plugin-of colon, @@ -1666,8 +1688,7 @@ previous >TARGET : compile, ( xt -- ) - dup xt>ghost >ghost-flags get-flag - IF prim, ELSE colon, THEN ; + dup xt>ghost >comp @ EXECUTE ; >CROSS \ resolve structure @@ -2183,13 +2204,13 @@ Cond: ['] T ' H alit, ;Cond \ \ threading modell 13dec92py \ modularized 14jun97jaw -T 2 cells H .s Value xt>body +T 2 cells H Value xt>body : (>body) ( cfa -- pfa ) xt>body + ; ' (>body) plugin-of t>body : fillcfa ( usedcells -- ) - T cells H xt>body swap - dup . + T cells H xt>body swap - assert1( dup 0 >= ) 0 ?DO 0 X c, tchar +LOOP ; @@ -2212,7 +2233,9 @@ T 2 cells H .s Value xt>body [ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ] 2 fillcfa ; ' (dodoes,) plugin-of dodoes, -: (lit,) ( n -- ) compile lit T , H ; ' (lit,) plugin-of lit, +: (dlit,) ( n -- ) compile lit td, ; ' (dlit,) plugin-of dlit, + +: (lit,) ( n -- ) s>d dlit, ; ' (lit,) plugin-of lit, \ if we dont produce relocatable code alit, defaults to lit, jaw \ this is just for convenience, so we don't have to define alit, @@ -2273,6 +2296,9 @@ Cond: chars ;Cond \ !! Known Bug: Special Literals and plug-ins work only correct \ on 16 and 32 Bit Targets and 32 Bit Hosts! +\ This section could be done with dlit, now. But first I need +\ some test code JAW + Cond: MAXU tcell 1 cells u> IF compile lit tcell 0 ?DO FF T c, H LOOP @@ -2437,7 +2463,7 @@ Cond: DOES> : Builder ( Create-xt do-ghost "name" -- ) \ builds up a builder in current vocabulary \ create-xt is executed when word is interpreted -\ do:-xt is executet when the created word from builder is executed +\ 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 Make-Ghost ( Create-xt do-ghost ghost ) @@ -2521,21 +2547,31 @@ Cond: DOES> \ DO: ;DO 11may93jaw \ changed to ?EXIT 10may93jaw -: DO: ( -- ghost [xt] [colon-sys] ) +: DO: ( -- do-ghost [xt] [colon-sys] ) here ghostheader :noname postpone gdoes> ( postpone ?EXIT ) ; -: by: ( -- ghost [xt] [colon-sys] ) \ name +: by: ( -- do-ghost [xt] [colon-sys] ) \ name Ghost :noname postpone gdoes> ( postpone ?EXIT ) ; -: ;DO ( ghost [xt] [colon-sys] -- addr ) +: ;DO ( do-ghost [xt] [colon-sys] -- do-ghost ) postpone ; ( S addr xt ) over >exec ! ; immediate -: by ( -- addr ) \ Name +: by ( -- do-ghost ) \ Name Ghost >do:ghost @ ; +: compile: ( do-ghost -- do-ghost [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 ; over >comp ! ; immediate + + + >TARGET \ Variables and Constants 05dec92py