Diff for /gforth/cross.fs between versions 1.116 and 1.117

version 1.116, 2001/11/11 22:33:31 version 1.117, 2002/01/04 20:31:53
Line 712  Plugin branchtoresolve, ( branch-addr -- Line 712  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 1694  previous Line 1695  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 ]comp prim, comp[ tempdp> ;      ' (cr) plugin-of colon-resolve  : (cr) >tempdp ]comp xt, comp[ tempdp> ;        ' (cr) plugin-of colon-resolve
 : (ar) T ! H ;                                  ' (ar) plugin-of addr-resolve  : (ar) T ! H ;                                  ' (ar) plugin-of addr-resolve
 : (dr)  ( ghost res-pnt target-addr addr )  : (dr)  ( ghost res-pnt target-addr addr )
         >tempdp drop over           >tempdp drop over 
Line 1708  previous Line 1710  previous
   
 : (cm) ( -- addr )  : (cm) ( -- addr )
     T here align H      T here align H
     -1 prim, ;                                  ' (cm) plugin-of colonmark,      -1 xt, ;                                    ' (cm) plugin-of colonmark,
   
 >TARGET  >TARGET
 : compile, ( xt -- )  : compile, ( xt -- )
Line 1800  Defer resolve-warning Line 1802  Defer resolve-warning
   
 \ FIXME: not used currently  \ FIXME: not used currently
 : does-resolved ( ghost -- )  : does-resolved ( ghost -- )
     dup g>body alit, >do:ghost @ g>body colon, ;      dup g>body alit, >do:ghost @ g>xt 0 t>body - colon, ;
   
 : (is-forward)   ( ghost -- )  : (is-forward)   ( ghost -- )
   colonmark, 0 (refered) ; \ compile space for call    colonmark, 0 (refered) ; \ compile space for call
Line 2122  Variable aprim-nr -20 aprim-nr ! Line 2124  Variable aprim-nr -20 aprim-nr !
 : copy-execution-semantics ( ghost-from ghost-dest -- )  : copy-execution-semantics ( ghost-from ghost-dest -- )
   >r    >r
   dup >exec @ r@ >exec !    dup >exec @ r@ >exec !
     dup >comp @ r@ >comp !
   dup >exec2 @ r@ >exec2 !    dup >exec2 @ r@ >exec2 !
   dup >exec-compile @ r@ >exec-compile !    dup >exec-compile @ r@ >exec-compile !
   dup >ghost-xt @ r@ >ghost-xt !    dup >ghost-xt @ r@ >ghost-xt !
Line 2168  Defer setup-prim-semantics Line 2171  Defer setup-prim-semantics
 Variable prim#  Variable prim#
 : first-primitive ( n -- )  prim# ! ;  : first-primitive ( n -- )  prim# ! ;
 : Primitive  ( -- ) \ name  : Primitive  ( -- ) \ name
   >in @ skip? IF  2drop  EXIT  THEN  >in !    >in @ skip? IF  drop  EXIT  THEN  >in !
   dup 0< s" prims" T $has? H 0= and    s" prims" T $has? H 0=
   IF    IF
      .sourcepos ." needs prim: " >in @ bl word count type >in ! cr       .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
   THEN    THEN
Line 2465  Cond: [ ( -- ) interpreting-state ;Cond Line 2468  Cond: [ ( -- ) interpreting-state ;Cond
   
 >CROSS  >CROSS
   
 Create GhostDummy ghostheader  0 Value created
 <res> GhostDummy >magic !  
   
 : !does ( does-action -- )  : !does ( does-action -- )
 \ !! zusammenziehen und dodoes, machen!  
     tlastcfa @ [G'] :dovar killref      tlastcfa @ [G'] :dovar killref
 \    tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;      >space here >r ghostheader space>
 \ !! geht so nicht, da dodoes, ghost will!      r@ created >do:ghost ! r@ swap resolve
     GhostDummy >link ! GhostDummy       r> tlastcfa @ >tempdp dodoes, tempdp> ;
     tlastcfa @ >tempdp dodoes, tempdp> ;  
   
   
 Defer instant-interpret-does>-hook  Defer instant-interpret-does>-hook
   
 : resolve-does>-part ( -- )  : resolve-does>-part ( -- )
 \ resolve words made by builders  \ resolve words made by builders
   Last-Header-Ghost @ >do:ghost @ ?dup     Last-Header-Ghost @ >do:ghost @ ?dup 
   IF    there resolve     IF  there resolve  THEN ;
         \ TODO: set special DOES> resolver action here  
   THEN ;  
   
 >TARGET  >TARGET
 Cond: DOES>  Cond: DOES>
Line 2493  Cond: DOES> Line 2490  Cond: DOES>
         ;Cond          ;Cond
   
 : DOES> switchrom doeshandler, T here H !does   : DOES> switchrom doeshandler, T here H !does 
     ['] does-resolved created >comp !
   instant-interpret-does>-hook    instant-interpret-does>-hook
   depth T ] H ;    depth T ] H ;
   
Line 2512  Cond: DOES> Line 2510  Cond: DOES>
   ghost to built     ghost to built 
   built >created @ 0= IF    built >created @ 0= IF
     built >created on      built >created on
     ['] prim-resolved built >comp !   
   THEN ;    THEN ;
   
 : gdoes,  ( ghost -- )  : gdoes,  ( ghost -- )
Line 2532  Cond: DOES> Line 2529  Cond: DOES>
   ;    ;
   
 : takeover-x-semantics ( S constructor-ghost new-ghost -- )  : takeover-x-semantics ( S constructor-ghost new-ghost -- )
 \g stores execution semantic and compilation semantic in the built word     \g stores execution semantic and compilation semantic in the built word
    swap >do:ghost @      swap >do:ghost @ 2dup swap >do:ghost !
    \ we use the >exec2 field for the semantic of a created word,     \ we use the >exec2 field for the semantic of a created word,
    \ using exec or exec2 makes no difference for normal cross-compilation     \ using exec or exec2 makes no difference for normal cross-compilation
    \ but is usefull for instant where the exec field is already     \ but is usefull for instant where the exec field is already
Line 2545  Cond: DOES> Line 2542  Cond: DOES>
   create-forward-warn    create-forward-warn
   IF ['] reswarn-forward IS resolve-warning THEN    IF ['] reswarn-forward IS resolve-warning THEN
   executed-ghost @ (Theader    executed-ghost @ (Theader
   dup >created on    dup >created on  dup to created
   2dup takeover-x-semantics hereresolve gdoes, ;    2dup takeover-x-semantics hereresolve gdoes, ;
   
 : RTCreate ( <name> -- )  : RTCreate ( <name> -- )
Line 2754  T has? peephole H [IF] Line 2751  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,
   : (prim) dup 0< IF  ( $4000 - ) ELSE
       ." wrong usage of (prim) "
       dup gdiscover IF  .ghost  ELSE  .  THEN  cr -2 throw  THEN
       T a, H ;                                    ' (prim) 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!!
Line 2768  compile: g>body alit, compile @ ;compile Line 2769  compile: g>body alit, compile @ ;compile
   
 \ this changes also Variable, AVariable and 2Variable  \ this changes also Variable, AVariable and 2Variable
 Builder Create  Builder Create
 \ compile: g>body alit, ;compile  compile: g>body alit, ;compile
   
 Builder User  Builder User
 compile: g>body compile useraddr T @ , H ;compile  compile: g>body compile useraddr T @ , H ;compile
Line 2779  compile: g>body alit, compile @ compile Line 2780  compile: g>body alit, compile @ compile
 Builder (Field)  Builder (Field)
 compile: g>body T @ H lit, compile + ;compile  compile: g>body T @ H lit, compile + ;compile
   
   Builder interpret/compile:
   compile: does-resolved ;compile
   
   Builder input-method
   compile: does-resolved ;compile
   
   Builder input-var
   compile: does-resolved ;compile
   
 [THEN]  [THEN]
   
 \ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py

Removed from v.1.116  
changed lines
  Added in v.1.117


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