Diff for /gforth/cross.fs between versions 1.105 and 1.107

version 1.105, 2001/09/05 09:42:38 version 1.107, 2001/09/05 11:01:27
Line 23 Line 23
 [IF]  [IF]
   
 ToDo:  ToDo:
 Crossdoc destination ./doc/crossdoc.fd makes no sense when  - Crossdoc destination ./doc/crossdoc.fd makes no sense when
 cross.fs is uses seperately. jaw    cross.fs is used seperately. jaw
 Do we need this char translation with >address and in branchoffset?   - Do we need this char translation with >address and in branchoffset? 
 (>body also affected) jaw    (>body also affected) jaw
 Clean up mark> and >resolve stuff jaw  - MAXU etc. can be done with dlit,
   
 [THEN]  [THEN]
   
Line 690  Variable ppi-temp 0 ppi-temp ! Line 690  Variable ppi-temp 0 ppi-temp !
   POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate    POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate
   
   
   Plugin dlit, ( d -- )                   \ compile numerical value the target
 Plugin lit, ( n -- )  Plugin lit, ( n -- )
 Plugin alit, ( n -- )  Plugin alit, ( n -- )
   
Line 801  Struct Line 802  Struct
   \ points to the where we have to resolve (linked-list)    \ points to the where we have to resolve (linked-list)
   cell% field >link    cell% field >link
   
   \ execution symantics (while target compiling) of ghost    \ execution semantics (while target compiling) of ghost
   cell% field >exec    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    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    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 >exec2
   
   cell% field >created    cell% field >created
Line 865  Variable cross-space-dp-orig Line 878  Variable cross-space-dp-orig
   cross-space-end u> ABORT" CROSS: cross-space overflow"    cross-space-end u> ABORT" CROSS: cross-space overflow"
   cross-space-dp-orig @ dp ! ;    cross-space-dp-orig @ dp ! ;
   
   \ this is just for debugging, to see this in the backtrace
 : execute-exec execute ;  : execute-exec execute ;
 : execute-exec2 execute ;  : execute-exec2 execute ;
 : execute-exec-compile execute ;  : execute-exec-compile execute ;
Line 1443  variable constflag constflag off Line 1457  variable constflag constflag off
   
 bigendian  bigendian
 [IF]  [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 ;       DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
    : S@  ( addr -- n )  >r 0 0 r> tcell bounds     : DS@  ( addr -- d )  >r 0 0 r> tcell bounds
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP ;
    : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-     : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-
      DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
    : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds     : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
 [ELSE]  [ELSE]
    : S!  ( n addr -- )  >r s>d r> tcell bounds     : DS!  ( d addr -- )  tcell bounds
      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
    : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-     : DS@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
      DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP ;
    : Sc!  ( n addr -- )  >r s>d r> tchar bounds     : Sc!  ( n addr -- )  >r s>d r> tchar bounds
      DO  maxbyte ud/mod rot I c!  LOOP  2drop ;       DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
    : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds swap 1-     : 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 ;       DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
 [THEN]  [THEN]
   
   : S! ( n addr -- ) >r s>d r> DS! ;
   : S@ ( addr -- n ) DS@ d>s ;
   
 : taddr>region ( taddr -- region | 0 )  : taddr>region ( taddr -- region | 0 )
 \G finds for a target-address the correct region  \G finds for a target-address the correct region
 \G returns 0 if taddr is not in range of a target memory region  \G returns 0 if taddr is not in range of a target memory region
Line 1596  T has? relocate H Line 1613  T has? relocate H
 : A,    ( w -- )        >address T here H relon T , 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  \ \ --------------------        Host/Target copy etc.           29aug01jaw
   
   
 >CROSS  >CROSS
   
   : TD! >image DS! ;
   : TD@ >image DS@ ;
   
 : th-count ( taddr -- host-addr len )  : th-count ( taddr -- host-addr len )
 \G returns host address of target string  \G returns host address of target string
   assert1( tbyte 1 = )    assert1( tbyte 1 = )
Line 1645  previous Line 1644  previous
 : on            T -1 swap ! H ;   : on            T -1 swap ! H ; 
 : off           T 0 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  >CROSS
   
 : (cc) T a, H ;                                 ' (cc) plugin-of colon,  : (cc) T a, H ;                                 ' (cc) plugin-of colon,
Line 1666  previous Line 1688  previous
   
 >TARGET  >TARGET
 : compile, ( xt -- )  : compile, ( xt -- )
   dup xt>ghost >ghost-flags <primitive> get-flag    dup xt>ghost >comp @ EXECUTE ;
   IF prim, ELSE colon, THEN ;  
 >CROSS  >CROSS
   
 \ resolve structure  \ resolve structure
Line 2183  Cond: [']  T ' H alit, ;Cond Line 2204  Cond: [']  T ' H alit, ;Cond
 \ \ threading modell                                    13dec92py  \ \ threading modell                                    13dec92py
 \ modularized                                           14jun97jaw  \ modularized                                           14jun97jaw
   
 T 2 cells H .s Value xt>body  T 2 cells H Value xt>body
   
 : (>body)   ( cfa -- pfa )   : (>body)   ( cfa -- pfa ) 
   xt>body + ;                                           ' (>body) plugin-of t>body    xt>body + ;                                           ' (>body) plugin-of t>body
   
 : fillcfa   ( usedcells -- )  : fillcfa   ( usedcells -- )
   T cells H xt>body swap - dup .    T cells H xt>body swap -
   assert1( dup 0 >= )    assert1( dup 0 >= )
   0 ?DO 0 X c, tchar +LOOP ;    0 ?DO 0 X c, tchar +LOOP ;
   
Line 2212  T 2 cells H .s Value xt>body Line 2233  T 2 cells H .s Value xt>body
   [ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ]    [ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ]
   2 fillcfa ;                                           ' (dodoes,) plugin-of dodoes,    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  \ if we dont produce relocatable code alit, defaults to lit, jaw
 \ this is just for convenience, so we don't have to define alit,  \ this is just for convenience, so we don't have to define alit,
Line 2273  Cond: chars ;Cond Line 2296  Cond: chars ;Cond
 \ !! Known Bug: Special Literals and plug-ins work only correct  \ !! Known Bug: Special Literals and plug-ins work only correct
 \ on 16 and 32 Bit Targets and 32 Bit Hosts!  \ 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  Cond: MAXU
   tcell 1 cells u>     tcell 1 cells u> 
   IF    compile lit tcell 0 ?DO FF T c, H LOOP     IF    compile lit tcell 0 ?DO FF T c, H LOOP 
Line 2437  Cond: DOES> Line 2463  Cond: DOES>
 : Builder    ( Create-xt do-ghost "name" -- )  : Builder    ( Create-xt do-ghost "name" -- )
 \ builds up a builder in current vocabulary  \ builds up a builder in current vocabulary
 \ create-xt is executed when word is interpreted  \ 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  \ for do:-xt an additional entry after the normal ghost-entrys is used
   
   Make-Ghost            ( Create-xt do-ghost ghost )    Make-Ghost            ( Create-xt do-ghost ghost )
Line 2521  Cond: DOES> Line 2547  Cond: DOES>
 \ DO: ;DO                                               11may93jaw  \ DO: ;DO                                               11may93jaw
 \ changed to ?EXIT                                      10may93jaw  \ changed to ?EXIT                                      10may93jaw
   
 : DO:     ( -- ghost [xt] [colon-sys] )  : DO:     ( -- do-ghost [xt] [colon-sys] )
   here ghostheader    here ghostheader
   :noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ( postpone ?EXIT ) ;
   
 : by:     ( -- ghost [xt] [colon-sys] ) \ name  : by:     ( -- do-ghost [xt] [colon-sys] ) \ name
   Ghost    Ghost
   :noname postpone gdoes> ( postpone ?EXIT ) ;    :noname postpone gdoes> ( postpone ?EXIT ) ;
   
 : ;DO ( ghost [xt] [colon-sys] -- addr )  : ;DO ( do-ghost [xt] [colon-sys] -- do-ghost )
   postpone ;    ( S addr xt )    postpone ;    ( S addr xt )
   over >exec ! ; immediate    over >exec ! ; immediate
   
 : by      ( -- addr ) \ Name  : by      ( -- do-ghost ) \ Name
   Ghost >do:ghost @ ;    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  >TARGET
 \ Variables and Constants                              05dec92py  \ Variables and Constants                              05dec92py
   

Removed from v.1.105  
changed lines
  Added in v.1.107


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>