Diff for /gforth/cross.fs between versions 1.118 and 1.121

version 1.118, 2002/01/05 20:16:17 version 1.121, 2002/03/19 18:07:55
Line 249  hex     \ the defualt base for the cross Line 249  hex     \ the defualt base for the cross
   
 hex  hex
   
   \ FIXME delete`
 \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are  \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are
                         \ for cross-compiling                          \ for cross-compiling
 \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!  \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!
   
   \ FIXME move down
 : comment? ( c-addr u -- c-addr u )  : comment? ( c-addr u -- c-addr u )
         2dup s" (" compare 0=          2dup s" (" compare 0=
         IF    postpone (          IF    postpone (
         ELSE  2dup s" \" compare 0= IF postpone \ THEN          ELSE  2dup s" \" compare 0= IF postpone \ THEN
         THEN ;          THEN ;
   
 : X     bl word count [ ' target >wordlist ] Literal search-wordlist  : X ( -- <name> )
         IF      state @ IF compile,  \G The next word in the input is a target word.
                 ELSE execute THEN  \G Equivalent to T <name> but without permanent
         ELSE    -1 ABORT" Cross: access method not supported!"  \G switch to target dictionary. Used as prefix e.g. for @, !, here etc.
         THEN ; immediate    bl word count [ ' target >wordlist ] Literal search-wordlist
     IF state @ IF compile, ELSE execute THEN
     ELSE  -1 ABORT" Cross: access method not supported!"
     THEN ; immediate
   
 \ Begin CROSS COMPILER:  \ Begin CROSS COMPILER:
   
Line 712  Plugin branchtoresolve, ( branch-addr -- Line 717  Plugin branchtoresolve, ( branch-addr --
 Plugin branchtomark, ( -- target-addr ) \ marks a branch destination  Plugin branchtomark, ( -- target-addr ) \ marks a branch destination
   
 Plugin colon, ( tcfa -- )               \ compiles call to tcfa at current position  Plugin colon, ( tcfa -- )               \ compiles call to tcfa at current position
 Plugin xt, ( tcfa -- )                  \ compiles xt  
 Plugin prim, ( tcfa -- )                \ compiles primitive invocation  Plugin prim, ( tcfa -- )                \ compiles primitive invocation
 Plugin colonmark, ( -- addr )           \ marks a colon call  Plugin colonmark, ( -- addr )           \ marks a colon call
 Plugin colon-resolve ( tcfa addr -- )  Plugin colon-resolve ( tcfa addr -- )
Line 746  Plugin next, ( for-token ) Line 750  Plugin next, ( for-token )
 Plugin leave,   ( -- )  Plugin leave,   ( -- )
 Plugin ?leave,  ( -- )  Plugin ?leave,  ( -- )
   
 [IFUNDEF] ca>native  Plugin ca>native  \ Convert a code address to the processors
 Plugin ca>native                            \ native address. This is used in doprim, and
 [THEN]                    \ code/code: primitive definitions word to
                     \ convert the addresses.
                     \ The only target where we need this is the misc
                     \ which is a 16 Bit processor with word addresses
                     \ but the forth system we build has a normal byte
                     \ addressed memory model    
   
 Plugin doprim,  \ compiles start of a primitive  Plugin doprim,  \ compiles start of a primitive
 Plugin docol,           \ compiles start of a colon definition  Plugin docol,           \ compiles start of a colon definition
Line 899  Variable cross-space-dp-orig Line 908  Variable cross-space-dp-orig
   THEN ;    THEN ;
   
 Defer is-forward  Defer is-forward
 Defer do-refered  
   
 : prim-forward   ( ghost -- )  
   colonmark, 1 do-refered ; \ compile space for call  
 ' prim-forward IS is-forward  
   
 : (ghostheader) ( -- )  : (ghostheader) ( -- )
     ghost-list linked <fwd> , 0 , ['] NoExec , what's is-forward ,      ghost-list linked <fwd> , 0 , ['] NoExec , ['] is-forward ,
     0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;      0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;
   
 : ghostheader ( -- ) (ghostheader) 0 , ;  : ghostheader ( -- ) (ghostheader) 0 , ;
Line 1068  Ghost branch    Ghost ?branch Line 1072  Ghost branch    Ghost ?branch
 Ghost unloop    Ghost ;S                        2drop  Ghost unloop    Ghost ;S                        2drop
 Ghost lit       Ghost !                         2drop  Ghost lit       Ghost !                         2drop
 Ghost noop                                      drop  Ghost noop                                      drop
 Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop  
 Ghost :dovar                                    drop  
 Ghost over      Ghost =         Ghost drop      2drop drop  Ghost over      Ghost =         Ghost drop      2drop drop
 Ghost 2drop drop  Ghost 2drop drop
 Ghost 2dup drop  Ghost 2dup drop
Line 1085  Ghost lit-perform drop Line 1087  Ghost lit-perform drop
 Ghost lit+ drop  Ghost lit+ drop
 Ghost does-exec drop  Ghost does-exec drop
   
   Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
   Ghost :dovar                                    drop
   
 \ \ Parameter for target systems                         06oct92py  \ \ Parameter for target systems                         06oct92py
   
   
Line 1643  T has? relocate H Line 1648  T has? relocate H
   
 >CROSS  >CROSS
   
 : call-forward ( ghost -- )  
     there 0 colon, 0 do-refered ;  
 ' call-forward IS is-forward  
   
 Ghost (do)      Ghost (?do)                     2drop  Ghost (do)      Ghost (?do)                     2drop
 Ghost (for)                                     drop  Ghost (for)                                     drop
 Ghost (loop)    Ghost (+loop)                   2drop  Ghost (loop)    Ghost (+loop)                   2drop
Line 1656  Ghost (.")      Ghost (S")      Ghost (A Line 1657  Ghost (.")      Ghost (S")      Ghost (A
 Ghost (C")                                      drop  Ghost (C")                                      drop
 Ghost '                                         drop  Ghost '                                         drop
   
 \ ' prim-forward IS is-forward  
   
 \ user ghosts  \ user ghosts
   
 Ghost state drop  Ghost state drop
Line 1719  previous Line 1718  previous
 >CROSS  >CROSS
   
 : (cc) T a, H ;                                 ' (cc) plugin-of colon,  : (cc) T a, H ;                                 ' (cc) plugin-of colon,
 : (xt) T a, H ;                                 ' (xt) plugin-of xt,  
 : (prim) T a, H ;                               ' (prim) plugin-of prim,  : (prim) T a, H ;                               ' (prim) plugin-of prim,
   
 : (cr) >tempdp colon, tempdp> ;                 ' (cr) plugin-of colon-resolve  : (cr) >tempdp colon, tempdp> ;                 ' (cr) plugin-of colon-resolve
Line 1733  previous Line 1731  previous
         tempdp> ;                               ' (dr) plugin-of doer-resolve          tempdp> ;                               ' (dr) plugin-of doer-resolve
   
 : (cm) ( -- addr )  : (cm) ( -- addr )
     T here align H      there -1 colon, ;                           ' (cm) plugin-of colonmark,
     -1 xt, ;                                    ' (cm) plugin-of colonmark,  
   
 >TARGET  >TARGET
 : compile, ( xt -- )  : compile, ( xt -- )
Line 1762  previous Line 1759  previous
     space>      space>
 ;  ;
   
 ' (refered) IS do-refered  
   
 : refered ( ghost tag -- )  : refered ( ghost tag -- )
 \G creates a resolve structure  \G creates a resolve structure
     T here aligned H swap (refered)      T here aligned H swap (refered)
Line 1821  Defer resolve-warning Line 1816  Defer resolve-warning
   >link ! ;    >link ! ;
   
 : colon-resolved   ( ghost -- )  : colon-resolved   ( ghost -- )
     >link @ colon, ; \ compile-call  \ compiles a call to a colon definition,
   \ compile action for >comp field
       >link @ colon, ; 
   
 : prim-resolved  ( ghost -- )  : prim-resolved  ( ghost -- )
   \ compiles a call to a primitive
     >link @ prim, ;      >link @ prim, ;
   
   : (is-forward)   ( ghost -- )
       colonmark, 0 (refered) ; \ compile space for call
   ' (is-forward) IS is-forward
   
 0 Value resolved  0 Value resolved
   
 : resolve  ( ghost tcfa -- )  : resolve  ( ghost tcfa -- )
Line 1848  Defer resolve-warning Line 1850  Defer resolve-warning
     \ mark ghost as resolved      \ mark ghost as resolved
     dup r@ >link ! <res> r@ >magic !      dup r@ >link ! <res> r@ >magic !
     r@ to resolved      r@ to resolved
     r@ >comp @ ['] prim-forward = IF  
         ['] prim-resolved  r@ >comp !  THEN  \    r@ >comp @ ['] is-forward =
     r@ >comp @ what's is-forward = IF  \    ABORT" >comp action not set on a resolved ghost"
         ['] prim-resolved  r@ >comp !  THEN  
       \ copmile action defaults to colon-resolved
       \ if this is not right something must be set before
       \ calling resolve
       r@ >comp @ ['] is-forward = IF
           ['] colon-resolved r@ >comp !
       THEN
     \ loop through forward referencies      \ loop through forward referencies
     r> -rot       r> -rot 
     comp-state @ >r Resolving comp-state !      comp-state @ >r Resolving comp-state !
Line 1867  Defer resolve-warning Line 1875  Defer resolve-warning
   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> = ABORT" CROSS: gexecute on immediate word"
   (gexecute) ;    (gexecute) ;
   
 : addr,  ( ghost -- )  : addr,  ( ghost -- )
Line 2183  Defer setup-prim-semantics Line 2191  Defer setup-prim-semantics
   Ghost tuck swap resolve <do:> swap tuck >magic !    Ghost tuck swap resolve <do:> swap tuck >magic !
   asmprimname, ;    asmprimname, ;
   
 : Alias:   ( cfa -- ) \ name  : Doer:   ( cfa -- ) \ name
   >in @ skip? IF  2drop  EXIT  THEN  >in !    >in @ skip? IF  2drop  EXIT  THEN  >in !
   dup 0< s" prims" T $has? H 0= and    dup 0< s" prims" T $has? H 0= and
   IF    IF
       .sourcepos ." needs doer: " >in @ bl word count type >in ! cr        .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
   THEN    THEN
   Ghost tuck swap resolve <do:> swap >magic ! ;    Ghost
     tuck swap resolve <do:> swap >magic ! ;
   
 Variable prim#  Variable prim#
 : first-primitive ( n -- )  prim# ! ;  : first-primitive ( n -- )  prim# ! ;
Line 2199  Variable prim# Line 2208  Variable prim#
   IF    IF
      .sourcepos ." needs prim: " >in @ bl word count type >in ! cr       .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
   THEN    THEN
 \  ['] prim-forward IS is-forward  
   prim# @ (THeader ( S xt ghost )    prim# @ (THeader ( S xt ghost )
     ['] prim-resolved over >comp !
   dup >ghost-flags <primitive> set-flag    dup >ghost-flags <primitive> set-flag
   over resolve T A, H alias-mask flag!    over resolve T A, H alias-mask flag!
 \  ['] call-forward IS is-forward  
   -1 prim# +! ;    -1 prim# +! ;
 >CROSS  >CROSS
   
Line 2283  T 2 cells H Value xt>body Line 2291  T 2 cells H Value xt>body
   
 : (docol,)  ( -- ) [G'] :docol (doer,) ;                ' (docol,) plugin-of docol,  : (docol,)  ( -- ) [G'] :docol (doer,) ;                ' (docol,) plugin-of docol,
   
                                                           ' NOOP plugin-of ca>native
   
 : (doprim,) ( -- )  : (doprim,) ( -- )
   there xt>body + ca>native T a, H 1 fillcfa ;          ' (doprim,) plugin-of doprim,    there xt>body + ca>native T a, H 1 fillcfa ;          ' (doprim,) plugin-of doprim,
   
 : (doeshandler,) ( -- )   : (doeshandler,) ( -- ) 
   T cfalign H compile :doesjump T 0 , H ;               ' (doeshandler,) plugin-of doeshandler,    T cfalign H [G'] :doesjump addr, T 0 , H ;            ' (doeshandler,) plugin-of doeshandler,
   
 : (dodoes,) ( does-action-ghost -- )  : (dodoes,) ( does-action-ghost -- )
   ]comp [G'] :dodoes gexecute comp[    ]comp [G'] :dodoes addr, comp[
   addr,    addr,
   \ the relocator in the c engine, does not like the    \ the relocator in the c engine, does not like the
   \ does-address to marked for relocation    \ does-address to marked for relocation
Line 2321  Defer (end-code) Line 2331  Defer (end-code)
 >TARGET  >TARGET
 : Code  : Code
   defempty?    defempty?
   (THeader there resolve    (THeader ( ghost )
     ['] prim-resolved over >comp !
     there resolve
     
   [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]    [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
   doprim,     doprim, 
   [THEN]    [THEN]
   depth (code) ;    depth (code) ;
   
   \ FIXME : no-compile -1 ABORT" this ghost is not for compilation" ;
   
 : Code:  : Code:
   defempty?    defempty?
     Ghost dup there ca>native resolve  <do:> swap >magic !      Ghost >r 
       r@ there ca>native resolve  
       <do:> r@ >magic !
       r> drop
     depth (code) ;      depth (code) ;
   
 : end-code  : end-code
Line 2498  Cond: [ ( -- ) interpreting-state ;Cond Line 2516  Cond: [ ( -- ) interpreting-state ;Cond
 : !does ( does-action -- )  : !does ( does-action -- )
     tlastcfa @ [G'] :dovar killref      tlastcfa @ [G'] :dovar killref
     >space here >r ghostheader space>      >space here >r ghostheader space>
       ['] colon-resolved r@ >comp !
     r@ created >do:ghost ! r@ swap resolve      r@ created >do:ghost ! r@ swap resolve
     r> tlastcfa @ >tempdp dodoes, tempdp> ;      r> tlastcfa @ >tempdp dodoes, tempdp> ;
   
Line 2505  Defer instant-interpret-does>-hook Line 2524  Defer instant-interpret-does>-hook
   
 : does-resolved ( ghost -- )  : does-resolved ( ghost -- )
     compile does-exec g>xt T a, H ;      compile does-exec g>xt T a, H ;
 \    dup g>body alit, >do:ghost @ g>xt 0 t>body - colon, ;  
   
 : resolve-does>-part ( -- )  : resolve-does>-part ( -- )
 \ resolve words made by builders  \ resolve words made by builders
Line 2782  DO:  abort" Not in cross mode" ;DO Line 2800  DO:  abort" Not in cross mode" ;DO
 \ this section defines different compilation  \ this section defines different compilation
 \ actions for created words  \ actions for created words
 \ this will help the peephole optimizer  \ this will help the peephole optimizer
 \ I (jaw) took this from bernds lates cross-compiler  \ I (jaw) took this from bernds latest cross-compiler
 \ changes but seperated it from the original  \ changes but seperated it from the original
 \ Builder words. The final plan is to put this  \ Builder words. The final plan is to put this
 \ into a seperate file, together with the peephole  \ into a seperate file, together with the peephole
Line 2794  T has? peephole H [IF] Line 2812  T has? peephole H [IF]
 >CROSS  >CROSS
   
 : (callc) compile call T >body a, H ;           ' (callc) plugin-of colon,  : (callc) compile call T >body a, H ;           ' (callc) plugin-of colon,
   : (callcm) T here 0 a, 0 a, H ;                 ' (callcm) plugin-of colonmark,
 : (call-res) >tempdp resolved gexecute tempdp> drop ;  : (call-res) >tempdp resolved gexecute tempdp> drop ;
                                                 ' (call-res) plugin-of colon-resolve                                                  ' (call-res) plugin-of colon-resolve
 : (prim) dup 0< IF  ( $4000 - ) ELSE  : (pprim) dup 0< IF  $4000 -  ELSE
     ." wrong usage of (prim) "      cr ." wrong usage of (prim) "
     dup gdiscover IF  .ghost  ELSE  .  THEN  cr -2 throw  THEN      dup gdiscover IF  .ghost  ELSE  .  THEN  cr -1 throw  THEN
     T a, H ;                                    ' (prim) plugin-of prim,      T a, H ;                                    ' (pprim) plugin-of prim,
   
 \ if we want this, we have to spilt aconstant  \ if we want this, we have to spilt aconstant
 \ and constant!!  \ and constant!!

Removed from v.1.118  
changed lines
  Added in v.1.121


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